mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-19 02:00:26 +02:00
add <primcall> to tree-il
* libguile/expand.c: * libguile/expand.h (SCM_EXPANDED_PRIMCALL_TYPE_NAME): (SCM_EXPANDED_PRIMCALL_FIELD_NAMES): (SCM_EXPANDED_PRIMCALL_SRC): (SCM_EXPANDED_PRIMCALL_NAME): (SCM_EXPANDED_PRIMCALL_ARGS): (SCM_MAKE_EXPANDED_PRIMCALL): Add "primcall" Tree-IL type. * doc/ref/compiler.texi (Tree-IL): Update docs. * libguile/memoize.c (memoize): Memoizer for primcalls. * module/ice-9/psyntax.scm: Build primcalls, sometimes. Also change build-primref to just make a primitive-ref. * module/language/tree-il.scm: Add primcall to the exports, parsers, serializers, etc. * module/language/tree-il/analyze.scm: * module/language/tree-il/compile-glil.scm: * module/language/tree-il/fix-letrec.scm: * module/language/tree-il/inline.scm: * module/language/tree-il/primitives.scm: * module/language/elisp/compile-tree-il.scm: Add primcall support. * test-suite/tests/tree-il.test: Use primcalls sometimes.
This commit is contained in:
Andy Wingo
parent
7081d4f981
commit
a881a4ae3b
14 changed files with 7186 additions and 7090 deletions
|
|
@ -182,6 +182,9 @@
|
|||
(apply lset-union eq? (step-tail-call proc args)
|
||||
(map step args)))
|
||||
|
||||
((<primcall> args)
|
||||
(apply lset-union eq? (map step args)))
|
||||
|
||||
((<conditional> test consequent alternate)
|
||||
(lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
|
||||
|
||||
|
|
@ -367,6 +370,9 @@
|
|||
((<call> proc args)
|
||||
(apply max (recur proc) (map recur args)))
|
||||
|
||||
((<primcall> args)
|
||||
(apply max n (map recur args)))
|
||||
|
||||
((<conditional> test consequent alternate)
|
||||
(max (recur test) (recur consequent) (recur alternate)))
|
||||
|
||||
|
|
|
|||
|
|
@ -256,172 +256,7 @@
|
|||
(lp (cdr exps))))))
|
||||
|
||||
((<call> src proc args)
|
||||
;; FIXME: need a better pattern-matcher here
|
||||
(cond
|
||||
((and (primitive-ref? proc)
|
||||
(eq? (primitive-ref-name proc) '@apply)
|
||||
(>= (length args) 1))
|
||||
(let ((proc (car args))
|
||||
(args (cdr args)))
|
||||
(cond
|
||||
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
|
||||
(not (eq? context 'push)) (not (eq? context 'vals)))
|
||||
;; tail: (lambda () (apply values '(1 2)))
|
||||
;; drop: (lambda () (apply values '(1 2)) 3)
|
||||
;; push: (lambda () (list (apply values '(10 12)) 1))
|
||||
(case context
|
||||
((drop) (for-each comp-drop args) (maybe-emit-return))
|
||||
((tail)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call 'return/values* (length args))))))
|
||||
|
||||
(else
|
||||
(case context
|
||||
((tail)
|
||||
(comp-push proc)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
|
||||
((push)
|
||||
(emit-code src (make-glil-call 'new-frame 0))
|
||||
(comp-push proc)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call 'apply (1+ (length args))))
|
||||
(maybe-emit-return))
|
||||
((vals)
|
||||
(comp-vals
|
||||
(make-call src (make-primitive-ref #f 'apply)
|
||||
(cons proc args))
|
||||
MVRA)
|
||||
(maybe-emit-return))
|
||||
((drop)
|
||||
;; Well, shit. The proc might return any number of
|
||||
;; values (including 0), since it's in a drop context,
|
||||
;; yet apply does not create a MV continuation. So we
|
||||
;; mv-call out to our trampoline instead.
|
||||
(comp-drop
|
||||
(make-call src (make-primitive-ref #f 'apply)
|
||||
(cons proc args)))
|
||||
(maybe-emit-return)))))))
|
||||
|
||||
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
|
||||
(not (eq? context 'push)))
|
||||
;; tail: (lambda () (values '(1 2)))
|
||||
;; drop: (lambda () (values '(1 2)) 3)
|
||||
;; push: (lambda () (list (values '(10 12)) 1))
|
||||
;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
|
||||
(case context
|
||||
((drop) (for-each comp-drop args) (maybe-emit-return))
|
||||
((vals)
|
||||
(for-each comp-push args)
|
||||
(emit-code #f (make-glil-const (length args)))
|
||||
(emit-branch src 'br MVRA))
|
||||
((tail)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call 'return/values (length args))))))
|
||||
|
||||
((and (primitive-ref? proc)
|
||||
(eq? (primitive-ref-name proc) '@call-with-values)
|
||||
(= (length args) 2))
|
||||
;; CONSUMER
|
||||
;; PRODUCER
|
||||
;; (mv-call MV)
|
||||
;; ([tail]-call 1)
|
||||
;; goto POST
|
||||
;; MV: [tail-]call/nargs
|
||||
;; POST: (maybe-drop)
|
||||
(case context
|
||||
((vals)
|
||||
;; Fall back.
|
||||
(comp-vals
|
||||
(make-call src (make-primitive-ref #f 'call-with-values)
|
||||
args)
|
||||
MVRA)
|
||||
(maybe-emit-return))
|
||||
(else
|
||||
(let ((MV (make-label)) (POST (make-label))
|
||||
(producer (car args)) (consumer (cadr args)))
|
||||
(if (not (eq? context 'tail))
|
||||
(emit-code src (make-glil-call 'new-frame 0)))
|
||||
(comp-push consumer)
|
||||
(emit-code src (make-glil-call 'new-frame 0))
|
||||
(comp-push producer)
|
||||
(emit-code src (make-glil-mv-call 0 MV))
|
||||
(case context
|
||||
((tail) (emit-code src (make-glil-call 'tail-call 1)))
|
||||
(else (emit-code src (make-glil-call 'call 1))
|
||||
(emit-branch #f 'br POST)))
|
||||
(emit-label MV)
|
||||
(case context
|
||||
((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
|
||||
(else (emit-code src (make-glil-call 'call/nargs 0))
|
||||
(emit-label POST)
|
||||
(if (eq? context 'drop)
|
||||
(emit-code #f (make-glil-call 'drop 1)))
|
||||
(maybe-emit-return)))))))
|
||||
|
||||
((and (primitive-ref? proc)
|
||||
(eq? (primitive-ref-name proc) '@call-with-current-continuation)
|
||||
(= (length args) 1))
|
||||
(case context
|
||||
((tail)
|
||||
(comp-push (car args))
|
||||
(emit-code src (make-glil-call 'tail-call/cc 1)))
|
||||
((vals)
|
||||
(comp-vals
|
||||
(make-call
|
||||
src (make-primitive-ref #f 'call-with-current-continuation)
|
||||
args)
|
||||
MVRA)
|
||||
(maybe-emit-return))
|
||||
((push)
|
||||
(comp-push (car args))
|
||||
(emit-code src (make-glil-call 'call/cc 1))
|
||||
(maybe-emit-return))
|
||||
((drop)
|
||||
;; Crap. Just like `apply' in drop context.
|
||||
(comp-drop
|
||||
(make-call
|
||||
src (make-primitive-ref #f 'call-with-current-continuation)
|
||||
args))
|
||||
(maybe-emit-return))))
|
||||
|
||||
;; A hack for variable-set, the opcode for which takes its args
|
||||
;; reversed, relative to the variable-set! function
|
||||
((and (primitive-ref? proc)
|
||||
(eq? (primitive-ref-name proc) 'variable-set!)
|
||||
(= (length args) 2))
|
||||
(comp-push (cadr args))
|
||||
(comp-push (car args))
|
||||
(emit-code src (make-glil-call 'variable-set 2))
|
||||
(case context
|
||||
((tail push vals) (emit-code #f (make-glil-void))))
|
||||
(maybe-emit-return))
|
||||
|
||||
((and (primitive-ref? proc)
|
||||
(or (hash-ref *primcall-ops*
|
||||
(cons (primitive-ref-name proc) (length args)))
|
||||
(hash-ref *primcall-ops* (primitive-ref-name proc))))
|
||||
=> (lambda (op)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call op (length args)))
|
||||
(case (instruction-pushes op)
|
||||
((0)
|
||||
(case context
|
||||
((tail push vals) (emit-code #f (make-glil-void))))
|
||||
(maybe-emit-return))
|
||||
((1)
|
||||
(case context
|
||||
((drop) (emit-code #f (make-glil-call 'drop 1))))
|
||||
(maybe-emit-return))
|
||||
((-1)
|
||||
;; A control instruction, like return/values. Here we
|
||||
;; just have to hope that the author of the tree-il
|
||||
;; knew what they were doing.
|
||||
*unspecified*)
|
||||
(else
|
||||
(error "bad primitive op: too many pushes"
|
||||
op (instruction-pushes op))))))
|
||||
|
||||
;; self-call in tail position
|
||||
((and (lexical-ref? proc)
|
||||
self-label (eq? (lexical-ref-gensym proc) self-label)
|
||||
|
|
@ -518,6 +353,141 @@
|
|||
(emit-branch #f 'br RA)
|
||||
(emit-label POST)))))))))
|
||||
|
||||
((<primcall> src name args)
|
||||
(pmatch (cons name args)
|
||||
((@apply ,proc . ,args)
|
||||
(cond
|
||||
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
|
||||
(not (eq? context 'push)) (not (eq? context 'vals)))
|
||||
;; tail: (lambda () (apply values '(1 2)))
|
||||
;; drop: (lambda () (apply values '(1 2)) 3)
|
||||
;; push: (lambda () (list (apply values '(10 12)) 1))
|
||||
(case context
|
||||
((drop) (for-each comp-drop args) (maybe-emit-return))
|
||||
((tail)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call 'return/values* (length args))))))
|
||||
|
||||
(else
|
||||
(case context
|
||||
((tail)
|
||||
(comp-push proc)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
|
||||
((push)
|
||||
(emit-code src (make-glil-call 'new-frame 0))
|
||||
(comp-push proc)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call 'apply (1+ (length args))))
|
||||
(maybe-emit-return))
|
||||
(else
|
||||
(comp-tail (make-primcall src 'apply (cons proc args))))))))
|
||||
|
||||
((values . _) (guard (not (eq? context 'push)))
|
||||
;; tail: (lambda () (values '(1 2)))
|
||||
;; drop: (lambda () (values '(1 2)) 3)
|
||||
;; push: (lambda () (list (values '(10 12)) 1))
|
||||
;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
|
||||
(case context
|
||||
((drop) (for-each comp-drop args) (maybe-emit-return))
|
||||
((vals)
|
||||
(for-each comp-push args)
|
||||
(emit-code #f (make-glil-const (length args)))
|
||||
(emit-branch src 'br MVRA))
|
||||
((tail)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call 'return/values (length args))))))
|
||||
|
||||
((@call-with-values ,producer ,consumer)
|
||||
;; CONSUMER
|
||||
;; PRODUCER
|
||||
;; (mv-call MV)
|
||||
;; ([tail]-call 1)
|
||||
;; goto POST
|
||||
;; MV: [tail-]call/nargs
|
||||
;; POST: (maybe-drop)
|
||||
(case context
|
||||
((vals)
|
||||
;; Fall back.
|
||||
(comp-tail (make-primcall src 'call-with-values args)))
|
||||
(else
|
||||
(let ((MV (make-label)) (POST (make-label)))
|
||||
(if (not (eq? context 'tail))
|
||||
(emit-code src (make-glil-call 'new-frame 0)))
|
||||
(comp-push consumer)
|
||||
(emit-code src (make-glil-call 'new-frame 0))
|
||||
(comp-push producer)
|
||||
(emit-code src (make-glil-mv-call 0 MV))
|
||||
(case context
|
||||
((tail) (emit-code src (make-glil-call 'tail-call 1)))
|
||||
(else (emit-code src (make-glil-call 'call 1))
|
||||
(emit-branch #f 'br POST)))
|
||||
(emit-label MV)
|
||||
(case context
|
||||
((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
|
||||
(else (emit-code src (make-glil-call 'call/nargs 0))
|
||||
(emit-label POST)
|
||||
(if (eq? context 'drop)
|
||||
(emit-code #f (make-glil-call 'drop 1)))
|
||||
(maybe-emit-return)))))))
|
||||
|
||||
((@call-with-current-continuation ,proc)
|
||||
(case context
|
||||
((tail)
|
||||
(comp-push proc)
|
||||
(emit-code src (make-glil-call 'tail-call/cc 1)))
|
||||
((vals)
|
||||
(comp-vals
|
||||
(make-primcall src 'call-with-current-continuation args)
|
||||
MVRA)
|
||||
(maybe-emit-return))
|
||||
((push)
|
||||
(comp-push proc)
|
||||
(emit-code src (make-glil-call 'call/cc 1))
|
||||
(maybe-emit-return))
|
||||
((drop)
|
||||
;; Fall back.
|
||||
(comp-tail
|
||||
(make-primcall src 'call-with-current-continuation args)))))
|
||||
|
||||
;; A hack for variable-set, the opcode for which takes its args
|
||||
;; reversed, relative to the variable-set! function
|
||||
((variable-set! ,var ,val)
|
||||
(comp-push val)
|
||||
(comp-push var)
|
||||
(emit-code src (make-glil-call 'variable-set 2))
|
||||
(case context
|
||||
((tail push vals) (emit-code #f (make-glil-void))))
|
||||
(maybe-emit-return))
|
||||
|
||||
(else
|
||||
(cond
|
||||
((or (hash-ref *primcall-ops* (cons name (length args)))
|
||||
(hash-ref *primcall-ops* name))
|
||||
=> (lambda (op)
|
||||
(for-each comp-push args)
|
||||
(emit-code src (make-glil-call op (length args)))
|
||||
(case (instruction-pushes op)
|
||||
((0)
|
||||
(case context
|
||||
((tail push vals) (emit-code #f (make-glil-void))))
|
||||
(maybe-emit-return))
|
||||
((1)
|
||||
(case context
|
||||
((drop) (emit-code #f (make-glil-call 'drop 1))))
|
||||
(maybe-emit-return))
|
||||
((-1)
|
||||
;; A control instruction, like return/values. Here we
|
||||
;; just have to hope that the author of the tree-il
|
||||
;; knew what they were doing.
|
||||
*unspecified*)
|
||||
(else
|
||||
(error "bad primitive op: too many pushes"
|
||||
op (instruction-pushes op))))))
|
||||
(else
|
||||
;; Fall back to the normal compilation strategy.
|
||||
(comp-tail (make-call src (make-primitive-ref #f name) args)))))))
|
||||
|
||||
((<conditional> src test consequent alternate)
|
||||
;; TEST
|
||||
;; (br-if-not L1)
|
||||
|
|
@ -526,54 +496,33 @@
|
|||
;; L1: alternate
|
||||
;; L2:
|
||||
(let ((L1 (make-label)) (L2 (make-label)))
|
||||
;; need a pattern matcher
|
||||
(record-case test
|
||||
((<call> proc args)
|
||||
(record-case proc
|
||||
((<primitive-ref> name)
|
||||
(let ((len (length args)))
|
||||
(cond
|
||||
|
||||
((and (eq? name 'eq?) (= len 2))
|
||||
(comp-push (car args))
|
||||
(comp-push (cadr args))
|
||||
(emit-branch src 'br-if-not-eq L1))
|
||||
|
||||
((and (eq? name 'null?) (= len 1))
|
||||
(comp-push (car args))
|
||||
(emit-branch src 'br-if-not-null L1))
|
||||
|
||||
((and (eq? name 'not) (= len 1))
|
||||
(let ((app (car args)))
|
||||
(record-case app
|
||||
((<call> proc args)
|
||||
(let ((len (length args)))
|
||||
(record-case proc
|
||||
((<primitive-ref> name)
|
||||
(cond
|
||||
|
||||
((and (eq? name 'eq?) (= len 2))
|
||||
(comp-push (car args))
|
||||
(comp-push (cadr args))
|
||||
(emit-branch src 'br-if-eq L1))
|
||||
|
||||
((and (eq? name 'null?) (= len 1))
|
||||
(comp-push (car args))
|
||||
(emit-branch src 'br-if-null L1))
|
||||
|
||||
(else
|
||||
(comp-push app)
|
||||
(emit-branch src 'br-if L1))))
|
||||
(else
|
||||
(comp-push app)
|
||||
(emit-branch src 'br-if L1)))))
|
||||
(else
|
||||
(comp-push app)
|
||||
(emit-branch src 'br-if L1)))))
|
||||
|
||||
(else
|
||||
(comp-push test)
|
||||
(emit-branch src 'br-if-not L1)))))
|
||||
((<primcall> name args)
|
||||
(pmatch (cons name args)
|
||||
((eq? ,a ,b)
|
||||
(comp-push a)
|
||||
(comp-push b)
|
||||
(emit-branch src 'br-if-not-eq L1))
|
||||
((null? ,x)
|
||||
(comp-push x)
|
||||
(emit-branch src 'br-if-not-null L1))
|
||||
((not ,x)
|
||||
(record-case x
|
||||
((<primcall> name args)
|
||||
(pmatch (cons name args)
|
||||
((eq? ,a ,b)
|
||||
(comp-push a)
|
||||
(comp-push b)
|
||||
(emit-branch src 'br-if-eq L1))
|
||||
((null? ,x)
|
||||
(comp-push x)
|
||||
(emit-branch src 'br-if-null L1))
|
||||
(else
|
||||
(comp-push x)
|
||||
(emit-branch src 'br-if L1))))
|
||||
(else
|
||||
(comp-push x)
|
||||
(emit-branch src 'br-if L1))))
|
||||
(else
|
||||
(comp-push test)
|
||||
(emit-branch src 'br-if-not L1))))
|
||||
|
|
|
|||
|
|
@ -44,9 +44,8 @@
|
|||
((<sequence> exps)
|
||||
(and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
|
||||
exps))
|
||||
((<call> proc args)
|
||||
(and (primitive-ref? proc)
|
||||
(simple-primitive? (primitive-ref-name proc))
|
||||
((<primcall> name args)
|
||||
(and (simple-primitive? name)
|
||||
;; FIXME: check arity?
|
||||
(and-map (lambda (x)
|
||||
(simple-expression? x bound-vars simple-primitive?))
|
||||
|
|
|
|||
|
|
@ -47,44 +47,36 @@
|
|||
(else x)))
|
||||
(else x)))
|
||||
|
||||
((<call> src proc args)
|
||||
(record-case proc
|
||||
;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
|
||||
((<primitive-ref> name)
|
||||
(case name
|
||||
((memq memv)
|
||||
(pmatch args
|
||||
((,k ,l) (guard (const? l) (list? (const-exp l)))
|
||||
(cond
|
||||
((null? (const-exp l))
|
||||
(make-const #f #f))
|
||||
((const? k)
|
||||
(make-const #f (->bool ((case name
|
||||
((memq) memq)
|
||||
((memv) memv)
|
||||
(else (error "unexpected member func" name)))
|
||||
(const-exp k) (const-exp l)))))
|
||||
(else
|
||||
(let lp ((elts (const-exp l)))
|
||||
(let ((test (make-call
|
||||
#f
|
||||
(make-primitive-ref #f (case name
|
||||
((memq) 'eq?)
|
||||
((memv) 'eqv?)
|
||||
(else (error "what"))))
|
||||
(list k (make-const #f (car elts))))))
|
||||
(if (null? (cdr elts))
|
||||
test
|
||||
(make-conditional
|
||||
src
|
||||
test
|
||||
(make-const #f #t)
|
||||
(lp (cdr elts)))))))))
|
||||
|
||||
(else x)))
|
||||
|
||||
(else x)))
|
||||
|
||||
((<primcall> src name args)
|
||||
(pmatch (cons name args)
|
||||
((,member ,k ,l) (guard (and (memq member '(memq memv))
|
||||
(const? k)
|
||||
(list? (const-exp l))))
|
||||
(cond
|
||||
((null? (const-exp l))
|
||||
(make-const #f #f))
|
||||
((const? k)
|
||||
(make-const #f (->bool ((case member
|
||||
((memq) memq)
|
||||
((memv) memv)
|
||||
(else (error "what" member)))
|
||||
(const-exp k) (const-exp l)))))
|
||||
(else
|
||||
(let lp ((elts (const-exp l)))
|
||||
(let ((test (make-primcall
|
||||
#f
|
||||
(case member
|
||||
((memq) 'eq?)
|
||||
((memv) 'eqv?)
|
||||
(else (error "what" member)))
|
||||
(list k (make-const #f (car elts))))))
|
||||
(if (null? (cdr elts))
|
||||
test
|
||||
(make-conditional
|
||||
src
|
||||
test
|
||||
(make-const #f #t)
|
||||
(lp (cdr elts)))))))))
|
||||
(else x)))
|
||||
|
||||
((<lambda> meta body)
|
||||
|
|
@ -114,34 +106,29 @@
|
|||
(or (inline1 x) x))
|
||||
(lp alternate)))))))
|
||||
|
||||
((<primitive-ref> name)
|
||||
(case name
|
||||
((@call-with-values)
|
||||
(pmatch args
|
||||
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
|
||||
;; => (let-values (((a b . c) foo)) bar)
|
||||
;;
|
||||
;; Note that this is a singly-binding form of let-values.
|
||||
;; Also note that Scheme's let-values expands into
|
||||
;; call-with-values, then here we reduce it to tree-il's
|
||||
;; let-values.
|
||||
((,producer ,consumer)
|
||||
(guard (lambda? consumer)
|
||||
(lambda-case? (lambda-body consumer))
|
||||
(not (lambda-case-opt (lambda-body consumer)))
|
||||
(not (lambda-case-kw (lambda-body consumer)))
|
||||
(not (lambda-case-alternate (lambda-body consumer))))
|
||||
(make-let-values
|
||||
src
|
||||
(let ((x (make-call src producer '())))
|
||||
(or (inline1 x) x))
|
||||
(lambda-body consumer)))
|
||||
(else #f)))
|
||||
|
||||
(else #f)))
|
||||
|
||||
(else #f)))
|
||||
|
||||
((<primcall> src name args)
|
||||
(pmatch (cons name args)
|
||||
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
|
||||
;; => (let-values (((a b . c) foo)) bar)
|
||||
;;
|
||||
;; Note that this is a singly-binding form of let-values. Also
|
||||
;; note that Scheme's let-values expands into call-with-values,
|
||||
;; then here we reduce it to tree-il's let-values.
|
||||
((@call-with-values ,producer ,consumer)
|
||||
(guard (lambda? consumer)
|
||||
(lambda-case? (lambda-body consumer))
|
||||
(not (lambda-case-opt (lambda-body consumer)))
|
||||
(not (lambda-case-kw (lambda-body consumer)))
|
||||
(not (lambda-case-alternate (lambda-body consumer))))
|
||||
(make-let-values
|
||||
src
|
||||
(let ((x (make-call src producer '())))
|
||||
(or (inline1 x) x))
|
||||
(lambda-body consumer)))
|
||||
(else #f)))
|
||||
|
||||
((<conditional> test consequent alternate)
|
||||
(let ((btest (boolean-value test)))
|
||||
(or (record-case btest
|
||||
|
|
@ -178,10 +165,9 @@
|
|||
|
||||
(and (not opt) (not kw) rest (not alternate)
|
||||
(record-case body
|
||||
((<call> proc args)
|
||||
((<primcall> name args)
|
||||
;; (lambda args (apply (lambda ...) args)) => (lambda ...)
|
||||
(and (primitive-ref? proc)
|
||||
(eq? (primitive-ref-name proc) '@apply)
|
||||
(and (eq? name '@apply)
|
||||
(pair? args)
|
||||
(lambda? (car args))
|
||||
(args-compatible? (cdr args) gensyms)
|
||||
|
|
|
|||
|
|
@ -172,6 +172,9 @@
|
|||
(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))
|
||||
|
||||
|
|
@ -183,11 +186,9 @@
|
|||
(pre-order!
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
((<call> 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))
|
||||
|
||||
|
|
@ -203,8 +204,8 @@
|
|||
(lp (cdr in)
|
||||
(cons (if (eq? (caar in) 'quote)
|
||||
`(make-const src ,@(cdar in))
|
||||
`(make-call 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
|
||||
|
|
@ -222,8 +223,8 @@
|
|||
,(consequent then)
|
||||
,(consequent else)))
|
||||
(else
|
||||
`(make-call 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)
|
||||
|
|
@ -470,9 +471,9 @@
|
|||
;; trickery here.
|
||||
(make-lambda-case
|
||||
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
|
||||
(make-call #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)))
|
||||
|
||||
|
|
@ -491,9 +492,9 @@
|
|||
;; trickery here.
|
||||
(make-lambda-case
|
||||
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
|
||||
(make-call #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)))
|
||||
(else #f)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue