;;; open-coding primitive procedures
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(define-module (language tree-il primitives)
#:use-module (system base pmatch)
- #:use-module (rnrs bytevector)
+ #:use-module (rnrs bytevectors)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
- expand-primitives! effect-free-primitive?))
+ expand-primitives!
+ effect-free-primitive? effect+exception-free-primitive?
+ constructor-primitive? accessor-primitive?
+ singly-valued-primitive? equality-primitive?))
(define *interesting-primitive-names*
'(apply @apply
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor
not
- pair? null? list? acons cons cons*
+ pair? null? list? symbol? vector? string? struct?
+ nil?
+ acons cons cons*
list vector
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
+ vector-length vector-ref vector-set!
variable-ref variable-set!
variable-bound?
- ;; args of variable-set are switched; it needs special help
fluid-ref fluid-set!
- @prompt prompt abort
+ @prompt call-with-prompt @abort abort-to-prompt
+ make-prompt-tag
- struct? struct-vtable make-struct struct-ref struct-set!
+ string-length string-ref string-set!
+
+ struct-vtable make-struct struct-ref struct-set!
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
(for-each add-interesting-primitive! *interesting-primitive-names*)
+(define *primitive-constructors*
+ ;; Primitives that return a fresh object.
+ '(acons cons cons* list vector make-struct make-struct/no-tail
+ make-prompt-tag))
+
+(define *primitive-accessors*
+ ;; Primitives that are pure, but whose result depends on the mutable
+ ;; memory pointed to by their operands.
+ '(vector-ref
+ car cdr
+ memq memv
+ struct-vtable struct-ref
+ string-ref
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u16-ref bytevector-u16-native-ref
+ bytevector-s16-ref bytevector-s16-native-ref
+ bytevector-u32-ref bytevector-u32-native-ref
+ bytevector-s32-ref bytevector-s32-native-ref
+ bytevector-u64-ref bytevector-u64-native-ref
+ bytevector-s64-ref bytevector-s64-native-ref
+ bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+ bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+
(define *effect-free-primitives*
+ `(values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? symbol? vector? struct? string?
+ nil?
+ string-length vector-length
+ ;; These all should get expanded out by expand-primitives!.
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ ,@*primitive-constructors*
+ ,@*primitive-accessors*))
+
+;; Like *effect-free-primitives* above, but further restricted in that they
+;; cannot raise exceptions.
+(define *effect+exception-free-primitives*
'(values
eq? eqv? equal?
+ not
+ pair? null? list? symbol? vector? struct? string?
+ acons cons cons* list vector))
+
+;; Primitives that only return one value.
+(define *singly-valued-primitives*
+ '(eq? eqv? equal?
+ memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
+ ash logand logior logxor
not
- pair? null? list? acons cons cons*
+ pair? null? list? symbol? vector? acons cons cons*
+ nil?
list vector
car cdr
+ set-car! set-cdr!
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref
- struct? struct-vtable make-struct struct-ref
- bytevector-u8-ref bytevector-s8-ref
- bytevector-u16-ref bytevector-u16-native-ref
- bytevector-s16-ref bytevector-s16-native-ref
- bytevector-u32-ref bytevector-u32-native-ref
- bytevector-s32-ref bytevector-s32-native-ref
- bytevector-u64-ref bytevector-u64-native-ref
- bytevector-s64-ref bytevector-s64-native-ref
- bytevector-ieee-single-ref bytevector-ieee-single-native-ref
- bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+ vector-ref vector-set!
+ variable-ref variable-set!
+ variable-bound?
+ fluid-ref fluid-set!
+ make-prompt-tag
+ struct? struct-vtable make-struct struct-ref struct-set!
+ string-length string-ref string-set!
+ bytevector-u8-ref bytevector-u8-set!
+ bytevector-s8-ref bytevector-s8-set!
+ u8vector-ref u8vector-set! s8vector-ref s8vector-set!
+ bytevector-u16-ref bytevector-u16-set!
+ bytevector-u16-native-ref bytevector-u16-native-set!
+ bytevector-s16-ref bytevector-s16-set!
+ bytevector-s16-native-ref bytevector-s16-native-set!
+ u16vector-ref u16vector-set! s16vector-ref s16vector-set!
+ bytevector-u32-ref bytevector-u32-set!
+ bytevector-u32-native-ref bytevector-u32-native-set!
+ bytevector-s32-ref bytevector-s32-set!
+ bytevector-s32-native-ref bytevector-s32-native-set!
+ u32vector-ref u32vector-set! s32vector-ref s32vector-set!
+ bytevector-u64-ref bytevector-u64-set!
+ bytevector-u64-native-ref bytevector-u64-native-set!
+ bytevector-s64-ref bytevector-s64-set!
+ bytevector-s64-native-ref bytevector-s64-native-set!
+ u64vector-ref u64vector-set! s64vector-ref s64vector-set!
+ bytevector-ieee-single-ref bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+ bytevector-ieee-double-ref bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
+ f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+(define *equality-primitives*
+ '(eq? eqv? equal?))
(define *effect-free-primitive-table* (make-hash-table))
+(define *effect+exceptions-free-primitive-table* (make-hash-table))
+(define *singly-valued-primitive-table* (make-hash-table))
+(define *equality-primitive-table* (make-hash-table))
-(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
+(for-each (lambda (x)
+ (hashq-set! *effect-free-primitive-table* x #t))
*effect-free-primitives*)
-
+(for-each (lambda (x)
+ (hashq-set! *effect+exceptions-free-primitive-table* x #t))
+ *effect+exception-free-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *singly-valued-primitive-table* x #t))
+ *singly-valued-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *equality-primitive-table* x #t))
+ *equality-primitives*)
+
+(define (constructor-primitive? prim)
+ (memq prim *primitive-constructors*))
+(define (accessor-primitive? prim)
+ (memq prim *primitive-accessors*))
(define (effect-free-primitive? prim)
(hashq-ref *effect-free-primitive-table* prim))
+(define (effect+exception-free-primitive? prim)
+ (hashq-ref *effect+exceptions-free-primitive-table* prim))
+(define (singly-valued-primitive? prim)
+ (hashq-ref *singly-valued-primitive-table* prim))
+(define (equality-primitive? prim)
+ (hashq-ref *equality-primitive-table* prim))
(define (resolve-primitives! x mod)
+ (define local-definitions
+ (make-hash-table))
+
+ (let collect-local-definitions ((x x))
+ (record-case x
+ ((<toplevel-define> name)
+ (hashq-set! local-definitions name #t))
+ ((<seq> head tail)
+ (collect-local-definitions head)
+ (collect-local-definitions tail))
+ (else #f)))
+
(post-order!
(lambda (x)
(record-case x
((<toplevel-ref> src name)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable mod name))
+ (and=> (and (not (hashq-ref local-definitions name))
+ (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name)))
(lambda (name) (make-primitive-ref src name))))
((<module-ref> src mod name public?)
;; for the moment, we're disabling primitive resolution for
;; public refs because resolve-interface can raise errors.
- (let ((m (and (not public?) (resolve-module mod))))
- (and m
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable m name))
- (lambda (name) (make-primitive-ref src name))))))
+ (and=> (and=> (resolve-module mod)
+ (if public?
+ module-public-interface
+ identity))
+ (lambda (m)
+ (and=> (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (lambda (name)
+ (make-primitive-ref src name))))))
+ ((<call> src proc args)
+ (and (primitive-ref? proc)
+ (make-primcall src (primitive-ref-name proc) args)))
(else #f)))
x))
(pre-order!
(lambda (x)
(record-case x
- ((<application> src proc args)
- (and (primitive-ref? proc)
- (let ((expand (hashq-ref *primitive-expand-table*
- (primitive-ref-name proc))))
- (and expand (apply expand src args)))))
+ ((<primcall> src name args)
+ (let ((expand (hashq-ref *primitive-expand-table* name)))
+ (and expand (apply expand src args))))
(else #f)))
x))
(lp (cdr in)
(cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in))
- `(make-application src (make-primitive-ref src ',(caar in))
- ,(inline-args (cdar in))))
+ `(make-primcall src ',(caar in)
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
,(consequent then)
,(consequent else)))
(else
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))))
+ `(make-primcall src ',(car exp)
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
((number? exp)
`(make-const src ,exp))
+ ((not exp)
+ ;; failed match
+ #f)
(else (error "bad consequent yall" exp))))
`(hashq-set! *primitive-expand-table*
',sym
(define-primitive-expander zero? (x)
(= x 0))
+;; FIXME: All the code that uses `const?' is redundant with `peval'.
+
(define-primitive-expander +
() 0
- (x) x
+ (x) (values x)
(x y) (if (and (const? y)
(let ((y (const-exp y)))
(and (number? y) (exact? y) (= y 1))))
(define-primitive-expander *
() 1
- (x) x
+ (x) (values x)
(x y z . rest) (* x (* y z . rest)))
(define-primitive-expander -
(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
(define-primitive-expander cons*
- (x) x
+ (x) (values x)
(x y) (cons x y)
(x y . rest) (cons x (cons* y . rest)))
(define-primitive-expander call/cc (proc)
(@call-with-current-continuation proc))
-(define-primitive-expander values (x) x)
-
-;; swap args
-(define-primitive-expander variable-set! (var val)
- (variable-set val var))
+(define-primitive-expander make-struct (vtable tail-size . args)
+ (if (and (const? tail-size)
+ (let ((n (const-exp tail-size)))
+ (and (number? n) (exact? n) (zero? n))))
+ (make-struct/no-tail vtable . args)
+ #f))
(define-primitive-expander u8vector-ref (vec i)
(bytevector-u8-ref vec i))
(define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x))
-(hashq-set! *primitive-expand-table*
- 'dynamic-wind
- (case-lambda
- ((src pre thunk post)
- ;; Here we will make concessions to the fact that our inliner is
- ;; lame, and add a hack.
- (cond
- ((lambda? thunk)
- (let ((PRE (gensym " pre"))
- (POST (gensym " post")))
- (make-let
- src
- '(pre post)
- (list PRE POST)
- (list pre post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-application #f thunk '())
- (make-lexical-ref #f 'post POST)))))
- (else
- (let ((PRE (gensym " pre"))
- (THUNK (gensym " thunk"))
- (POST (gensym " post")))
- (make-let
- src
- '(pre thunk post)
- (list PRE THUNK POST)
- (list pre thunk post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
- (make-lexical-ref #f 'post POST)))))))
- (else #f)))
-
(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
((src pre expr post)
- (let ((PRE (gensym " pre"))
- (POST (gensym " post")))
+ (let ((PRE (gensym "pre-"))
+ (POST (gensym "post-")))
(make-let
src
'(pre post)
(make-dynwind
src
(make-lexical-ref #f 'pre PRE)
+ (make-call #f (make-lexical-ref #f 'pre PRE) '())
expr
+ (make-call #f (make-lexical-ref #f 'post POST) '())
(make-lexical-ref #f 'post POST)))))))
(hashq-set! *primitive-expand-table*
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
+ (make-primcall #f 'apply
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
(hashq-set! *primitive-expand-table*
- 'prompt
+ 'call-with-prompt
(case-lambda
((src tag thunk handler)
- ;; Sigh. Until the inliner does its job, manually inline
- ;; (let ((h (lambda ...))) (prompt k x h))
- (cond
- ((lambda? handler)
- (let ((args-sym (gensym)))
- (make-prompt
- src tag (make-application #f thunk '())
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
- #f))))
- (else #f)))
+ (let ((handler-sym (gensym))
+ (args-sym (gensym)))
+ (make-let
+ src '(handler) (list handler-sym) (list handler)
+ (make-prompt
+ src tag (make-call #f thunk '())
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-primcall
+ #f 'apply
+ (list (make-lexical-ref #f 'handler handler-sym)
+ (make-lexical-ref #f 'args args-sym)))
+ #f)))))
(else #f)))
(hashq-set! *primitive-expand-table*
- 'abort
+ '@abort
+ (case-lambda
+ ((src tag tail-args)
+ (make-abort src tag '() tail-args))
+ (else #f)))
+(hashq-set! *primitive-expand-table*
+ 'abort-to-prompt
(case-lambda
((src tag . args)
- (make-abort src tag args))
+ (make-abort src tag args (make-const #f '())))
(else #f)))
HCoop / bpt / guile.git / blobdiff