mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 09:40:25 +02:00
Code Activity

add <primcall> to tree-il

Browse source 
* 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 2011-06-02 17:41:45 +02:00
parent 7081d4f981
commit a881a4ae3b
14 changed files with 7186 additions and 7090 deletions
Download patch file Download diff file Expand all files Collapse all files

13543
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

67
module/ice-9/psyntax.scm
View file

@ -402,12 +402,14 @@
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
(define build-primcall
(lambda (src name args)
(make-primcall src name args)))
(define build-primref
(lambda (src name)
(if (equal? (module-name (current-module)) '(guile))
(make-toplevel-ref src name)
(make-module-ref src '(guile) name #f))))
(make-primitive-ref src name)))
(define (build-data src exp)
(make-const src exp))
@ -1038,9 +1040,9 @@
(build-global-definition
no-source
name
(build-call
(build-primcall
no-source
(build-primref no-source 'make-syntax-transformer)
'make-syntax-transformer
(list (build-data no-source name)
(build-data no-source 'macro)
e)))))
@ -1954,9 +1956,7 @@
(if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
(else (build-call no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
(else (build-primcall no-source (car x) (map regen (cdr x)))))))
(lambda (e r w s mod)
(let ((e (source-wrap e w s mod)))
@ -2288,20 +2288,21 @@
(lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-call no-source
(build-primref no-source 'apply)
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
(chi exp
(extend-env
labels
(map (lambda (var level)
(make-binding 'syntax `(,var . ,level)))
new-vars
(map cdr pvars))
r)
(make-binding-wrap ids labels empty-wrap)
mod))
y))))))
(build-primcall
no-source
'apply
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
(chi exp
(extend-env
labels
(map (lambda (var level)
(make-binding 'syntax `(,var . ,level)))
new-vars
(map cdr pvars))
r)
(make-binding-wrap ids labels empty-wrap)
mod))
y))))))
(define gen-clause
(lambda (x keys clauses r pat fender exp mod)
@ -2330,22 +2331,18 @@
(build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any)
(build-call no-source
(build-primref no-source 'list)
(list x))
(build-call no-source
(build-primref no-source '$sc-dispatch)
(list x (build-data no-source p)))))))))))))
(build-primcall no-source 'list (list x))
(build-primcall no-source '$sc-dispatch
(list x (build-data no-source p)))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
(build-call no-source
(build-primref no-source 'syntax-violation)
(list (build-data no-source #f)
(build-data no-source
"source expression failed to match any pattern")
x))
(build-primcall no-source 'syntax-violation
(list (build-data no-source #f)
(build-data no-source
"source expression failed to match any pattern")
x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? #'pat)

26
module/language/elisp/compile-tree-il.scm
View file

@ -109,7 +109,7 @@
;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args)
(make-call loc (make-primitive-ref loc sym) args))
(make-primcall loc sym args))
;;; Error reporting routine for syntax/compilation problems or build
;;; code for a runtime-error output.
@ -118,9 +118,8 @@
(apply error args))
(define (runtime-error loc msg . args)
(make-call loc
(make-primitive-ref loc 'error)
(cons (make-const loc msg) args)))
(make-primcall loc 'error
(cons (make-const loc msg) args)))
;;; Generate code to ensure a global symbol is there for further use of
;;; a given symbol. In general during the compilation, those needed are
@ -151,12 +150,11 @@
(call-primitive
loc
'with-fluids*
(make-call loc
(make-primitive-ref loc 'list)
(map (lambda (sym)
(make-module-ref loc module sym #t))
syms))
(make-call loc (make-primitive-ref loc 'list) vals)
(make-primcall loc 'list
(map (lambda (sym)
(make-module-ref loc module sym #t))
syms))
(make-primcall loc 'list vals)
(make-lambda loc
'()
(make-lambda-case #f '() #f #f #f '() '() body #f))))
@ -828,11 +826,9 @@
loc
name
function-slot
(make-call
loc
(make-module-ref loc '(guile) 'cons #t)
(list (make-const loc 'macro)
(compile-lambda loc args body))))
(make-primcall loc 'cons
(list (make-const loc 'macro)
(compile-lambda loc args body))))
(make-const loc name)))))
(compile (ensuring-globals loc bindings-data tree-il)
#:from 'tree-il

21
module/language/tree-il.scm
View file

@ -35,6 +35,7 @@
<toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
<call> call? make-call call-src call-proc call-args
<primcall> primcall? make-primcall primcall-src primcall-name primcall-args
<sequence> sequence? make-sequence sequence-src sequence-exps
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
@ -119,6 +120,7 @@
;; (<toplevel-define> name exp)
;; (<conditional> test consequent alternate)
;; (<call> proc args)
;; (<primcall> name args)
;; (<sequence> exps)
;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
@ -152,6 +154,9 @@
((call ,proc . ,args)
(make-call loc (retrans proc) (map retrans args)))
((primcall ,name . ,args)
(make-primcall loc name (map retrans args)))
((if ,test ,consequent ,alternate)
(make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
@ -256,6 +261,9 @@
((<call> proc args)
`(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
((<primcall> name args)
`(primcall ,name ,@(map unparse-tree-il args)))
((<conditional> test consequent alternate)
`(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
@ -339,6 +347,9 @@
((<call> proc args)
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
((<primcall> name args)
`(,name ,@(map tree-il->scheme args)))
((<conditional> test consequent alternate)
(if (void? alternate)
`(if ,(tree-il->scheme test) ,(tree-il->scheme consequent))
@ -510,6 +521,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
(loop test (down tree result))))))
((<call> proc args)
(up tree (loop (cons proc args) (down tree result))))
((<primcall> name args)
(up tree (loop args (down tree result))))
((<sequence> exps)
(up tree (loop exps (down tree result))))
((<lambda> body)
@ -584,6 +597,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
((<primcall> name args)
(fold-values foldts args seed ...))
((<sequence> exps)
(fold-values foldts exps seed ...))
((<lambda> body)
@ -638,6 +653,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (call-proc x) (lp proc))
(set! (call-args x) (map lp args)))
((<primcall> name args)
(set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
(set! (conditional-consequent x) (lp consequent))
@ -722,6 +740,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (call-proc x) (lp proc))
(set! (call-args x) (map lp args)))
((<primcall> name args)
(set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
(set! (conditional-consequent x) (lp consequent))

6
module/language/tree-il/analyze.scm
View file

@ -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)))

373
module/language/tree-il/compile-glil.scm
View file

@ -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))))

5
module/language/tree-il/fix-letrec.scm
View file

@ -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?))

120
module/language/tree-il/inline.scm
View file

@ -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)

31
module/language/tree-il/primitives.scm
View file

@ -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)))