mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +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

9
doc/ref/compiler.texi
View file

@ -388,6 +388,15 @@ A conditional. Note that @var{else} is not optional.
@deftpx {External Representation} (call @var{proc} . @var{args}) @deftpx {External Representation} (call @var{proc} . @var{args})
A procedure call. A procedure call.
@end deftp @end deftp
@deftp {Scheme Variable} <primcall> src name args
@deftpx {External Representation} (primcall @var{name} . @var{args})
A call to a primitive. Equivalent to @code{(call (primitive @var{name})
. @var{args})}. This construct is often more convenient to generate and
analyze than @code{<call>}.
As part of the compilation process, instances of @code{(call (primitive
@var{name}) . @var{args})} are transformed into primcalls.
@end deftp
@deftp {Scheme Variable} <sequence> src exps @deftp {Scheme Variable} <sequence> src exps
@deftpx {External Representation} (begin . @var{exps}) @deftpx {External Representation} (begin . @var{exps})
Like Scheme's @code{begin}. Like Scheme's @code{begin}.

1
libguile/expand.c
View file

@ -1244,6 +1244,7 @@ scm_init_expand ()
DEFINE_NAMES (TOPLEVEL_DEFINE); DEFINE_NAMES (TOPLEVEL_DEFINE);
DEFINE_NAMES (CONDITIONAL); DEFINE_NAMES (CONDITIONAL);
DEFINE_NAMES (CALL); DEFINE_NAMES (CALL);
DEFINE_NAMES (PRIMCALL);
DEFINE_NAMES (SEQUENCE); DEFINE_NAMES (SEQUENCE);
DEFINE_NAMES (LAMBDA); DEFINE_NAMES (LAMBDA);
DEFINE_NAMES (LAMBDA_CASE); DEFINE_NAMES (LAMBDA_CASE);

14
libguile/expand.h
View file

@ -48,6 +48,7 @@ typedef enum
SCM_EXPANDED_TOPLEVEL_DEFINE, SCM_EXPANDED_TOPLEVEL_DEFINE,
SCM_EXPANDED_CONDITIONAL, SCM_EXPANDED_CONDITIONAL,
SCM_EXPANDED_CALL, SCM_EXPANDED_CALL,
SCM_EXPANDED_PRIMCALL,
SCM_EXPANDED_SEQUENCE, SCM_EXPANDED_SEQUENCE,
SCM_EXPANDED_LAMBDA, SCM_EXPANDED_LAMBDA,
SCM_EXPANDED_LAMBDA_CASE, SCM_EXPANDED_LAMBDA_CASE,
@ -241,6 +242,19 @@ enum
#define SCM_MAKE_EXPANDED_CALL(src, proc, args) \ #define SCM_MAKE_EXPANDED_CALL(src, proc, args) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_CALL], 0, SCM_NUM_EXPANDED_CALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (args)) scm_c_make_struct (exp_vtables[SCM_EXPANDED_CALL], 0, SCM_NUM_EXPANDED_CALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (args))
#define SCM_EXPANDED_PRIMCALL_TYPE_NAME "primcall"
#define SCM_EXPANDED_PRIMCALL_FIELD_NAMES \
{ "src", "name", "args", }
enum
{
SCM_EXPANDED_PRIMCALL_SRC,
SCM_EXPANDED_PRIMCALL_NAME,
SCM_EXPANDED_PRIMCALL_ARGS,
SCM_NUM_EXPANDED_PRIMCALL_FIELDS,
};
#define SCM_MAKE_EXPANDED_PRIMCALL(src, name, args) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_PRIMCALL], 0, SCM_NUM_EXPANDED_PRIMCALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (args))
#define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence" #define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence"
#define SCM_EXPANDED_SEQUENCE_FIELD_NAMES \ #define SCM_EXPANDED_SEQUENCE_FIELD_NAMES \
{ "src", "exps", } { "src", "exps", }

14
libguile/memoize.c
View file

@ -263,6 +263,20 @@ memoize (SCM exp, SCM env)
return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args); return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
} }
case SCM_EXPANDED_PRIMCALL:
{
SCM proc, args;
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
else
proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
SCM_BOOL_F);
args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
return MAKMEMO_CALL (proc, scm_ilength (args), args);
}
case SCM_EXPANDED_SEQUENCE: case SCM_EXPANDED_SEQUENCE:
return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env)); return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env));

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

File diff suppressed because it is too large Load diff

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

@ -402,11 +402,13 @@
(lambda (src req opt rest kw inits vars body else-case) (lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case 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 (define build-primref
(lambda (src name) (lambda (src name)
(if (equal? (module-name (current-module)) '(guile)) (make-primitive-ref src name)))
(make-toplevel-ref src name)
(make-module-ref src '(guile) name #f))))
(define (build-data src exp) (define (build-data src exp)
(make-const src exp)) (make-const src exp))
@ -1038,9 +1040,9 @@
(build-global-definition (build-global-definition
no-source no-source
name name
(build-call (build-primcall
no-source no-source
(build-primref no-source 'make-syntax-transformer) 'make-syntax-transformer
(list (build-data no-source name) (list (build-data no-source name)
(build-data no-source 'macro) (build-data no-source 'macro)
e))))) e)))))
@ -1954,9 +1956,7 @@
(if (list? (cadr x)) (if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x))) (error "how did we get here" x)))
(else (build-call no-source (else (build-primcall no-source (car x) (map regen (cdr x)))))))
(build-primref no-source (car x))
(map regen (cdr x)))))))
(lambda (e r w s mod) (lambda (e r w s mod)
(let ((e (source-wrap e w s mod))) (let ((e (source-wrap e w s mod)))
@ -2288,20 +2288,21 @@
(lambda (pvars exp y r mod) (lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars))) (let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-call no-source (build-primcall
(build-primref no-source 'apply) no-source
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() 'apply
(chi exp (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
(extend-env (chi exp
labels (extend-env
(map (lambda (var level) labels
(make-binding 'syntax `(,var . ,level))) (map (lambda (var level)
new-vars (make-binding 'syntax `(,var . ,level)))
(map cdr pvars)) new-vars
r) (map cdr pvars))
(make-binding-wrap ids labels empty-wrap) r)
mod)) (make-binding-wrap ids labels empty-wrap)
y)))))) mod))
y))))))
(define gen-clause (define gen-clause
(lambda (x keys clauses r pat fender exp mod) (lambda (x keys clauses r pat fender exp mod)
@ -2330,22 +2331,18 @@
(build-dispatch-call pvars exp y r mod) (build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r mod)))) (gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any) (list (if (eq? p 'any)
(build-call no-source (build-primcall no-source 'list (list x))
(build-primref no-source 'list) (build-primcall no-source '$sc-dispatch
(list x)) (list x (build-data no-source p)))))))))))))
(build-call no-source
(build-primref no-source '$sc-dispatch)
(list x (build-data no-source p)))))))))))))
(define gen-syntax-case (define gen-syntax-case
(lambda (x keys clauses r mod) (lambda (x keys clauses r mod)
(if (null? clauses) (if (null? clauses)
(build-call no-source (build-primcall no-source 'syntax-violation
(build-primref no-source 'syntax-violation) (list (build-data no-source #f)
(list (build-data no-source #f) (build-data no-source
(build-data no-source "source expression failed to match any pattern")
"source expression failed to match any pattern") x))
x))
(syntax-case (car clauses) () (syntax-case (car clauses) ()
((pat exp) ((pat exp)
(if (and (id? #'pat) (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. ;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args) (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 ;;; Error reporting routine for syntax/compilation problems or build
;;; code for a runtime-error output. ;;; code for a runtime-error output.
@ -118,9 +118,8 @@
(apply error args)) (apply error args))
(define (runtime-error loc msg . args) (define (runtime-error loc msg . args)
(make-call loc (make-primcall loc 'error
(make-primitive-ref loc 'error) (cons (make-const loc msg) args)))
(cons (make-const loc msg) args)))
;;; Generate code to ensure a global symbol is there for further use of ;;; Generate code to ensure a global symbol is there for further use of
;;; a given symbol. In general during the compilation, those needed are ;;; a given symbol. In general during the compilation, those needed are
@ -151,12 +150,11 @@
(call-primitive (call-primitive
loc loc
'with-fluids* 'with-fluids*
(make-call loc (make-primcall loc 'list
(make-primitive-ref loc 'list) (map (lambda (sym)
(map (lambda (sym) (make-module-ref loc module sym #t))
(make-module-ref loc module sym #t)) syms))
syms)) (make-primcall loc 'list vals)
(make-call loc (make-primitive-ref loc 'list) vals)
(make-lambda loc (make-lambda loc
'() '()
(make-lambda-case #f '() #f #f #f '() '() body #f)))) (make-lambda-case #f '() #f #f #f '() '() body #f))))
@ -828,11 +826,9 @@
loc loc
name name
function-slot function-slot
(make-call (make-primcall loc 'cons
loc (list (make-const loc 'macro)
(make-module-ref loc '(guile) 'cons #t) (compile-lambda loc args body))))
(list (make-const loc 'macro)
(compile-lambda loc args body))))
(make-const loc name))))) (make-const loc name)))))
(compile (ensuring-globals loc bindings-data tree-il) (compile (ensuring-globals loc bindings-data tree-il)
#:from '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 <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 <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
<call> call? make-call call-src call-proc call-args <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 <sequence> sequence? make-sequence sequence-src sequence-exps
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src <lambda-case> lambda-case? make-lambda-case lambda-case-src
@ -119,6 +120,7 @@
;; (<toplevel-define> name exp) ;; (<toplevel-define> name exp)
;; (<conditional> test consequent alternate) ;; (<conditional> test consequent alternate)
;; (<call> proc args) ;; (<call> proc args)
;; (<primcall> name args)
;; (<sequence> exps) ;; (<sequence> exps)
;; (<lambda> meta body) ;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate) ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
@ -152,6 +154,9 @@
((call ,proc . ,args) ((call ,proc . ,args)
(make-call loc (retrans proc) (map retrans args))) (make-call loc (retrans proc) (map retrans args)))
((primcall ,name . ,args)
(make-primcall loc name (map retrans args)))
((if ,test ,consequent ,alternate) ((if ,test ,consequent ,alternate)
(make-conditional loc (retrans test) (retrans consequent) (retrans alternate))) (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
@ -256,6 +261,9 @@
((<call> proc args) ((<call> proc args)
`(call ,(unparse-tree-il proc) ,@(map unparse-tree-il 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) ((<conditional> test consequent alternate)
`(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate))) `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
@ -339,6 +347,9 @@
((<call> proc args) ((<call> proc args)
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
((<primcall> name args)
`(,name ,@(map tree-il->scheme args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
(if (void? alternate) (if (void? alternate)
`(if ,(tree-il->scheme test) ,(tree-il->scheme consequent)) `(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)))))) (loop test (down tree result))))))
((<call> proc args) ((<call> proc args)
(up tree (loop (cons proc args) (down tree result)))) (up tree (loop (cons proc args) (down tree result))))
((<primcall> name args)
(up tree (loop args (down tree result))))
((<sequence> exps) ((<sequence> exps)
(up tree (loop exps (down tree result)))) (up tree (loop exps (down tree result))))
((<lambda> body) ((<lambda> body)
@ -584,6 +597,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<call> proc args) ((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...))) (let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...))) (fold-values foldts args seed ...)))
((<primcall> name args)
(fold-values foldts args seed ...))
((<sequence> exps) ((<sequence> exps)
(fold-values foldts exps seed ...)) (fold-values foldts exps seed ...))
((<lambda> body) ((<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-proc x) (lp proc))
(set! (call-args x) (map lp args))) (set! (call-args x) (map lp args)))
((<primcall> name args)
(set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test)) (set! (conditional-test x) (lp test))
(set! (conditional-consequent x) (lp consequent)) (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-proc x) (lp proc))
(set! (call-args x) (map lp args))) (set! (call-args x) (map lp args)))
((<primcall> name args)
(set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test)) (set! (conditional-test x) (lp test))
(set! (conditional-consequent x) (lp consequent)) (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) (apply lset-union eq? (step-tail-call proc args)
(map step args))) (map step args)))
((<primcall> args)
(apply lset-union eq? (map step args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
(lset-union eq? (step test) (step-tail consequent) (step-tail alternate))) (lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
@ -367,6 +370,9 @@
((<call> proc args) ((<call> proc args)
(apply max (recur proc) (map recur args))) (apply max (recur proc) (map recur args)))
((<primcall> args)
(apply max n (map recur args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
(max (recur test) (recur consequent) (recur 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)))))) (lp (cdr exps))))))
((<call> src proc args) ((<call> src proc args)
;; FIXME: need a better pattern-matcher here
(cond (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 ;; self-call in tail position
((and (lexical-ref? proc) ((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label) self-label (eq? (lexical-ref-gensym proc) self-label)
@ -518,6 +353,141 @@
(emit-branch #f 'br RA) (emit-branch #f 'br RA)
(emit-label POST))))))))) (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) ((<conditional> src test consequent alternate)
;; TEST ;; TEST
;; (br-if-not L1) ;; (br-if-not L1)
@ -526,54 +496,33 @@
;; L1: alternate ;; L1: alternate
;; L2: ;; L2:
(let ((L1 (make-label)) (L2 (make-label))) (let ((L1 (make-label)) (L2 (make-label)))
;; need a pattern matcher
(record-case test (record-case test
((<call> proc args) ((<primcall> name args)
(record-case proc (pmatch (cons name args)
((<primitive-ref> name) ((eq? ,a ,b)
(let ((len (length args))) (comp-push a)
(cond (comp-push b)
(emit-branch src 'br-if-not-eq L1))
((and (eq? name 'eq?) (= len 2)) ((null? ,x)
(comp-push (car args)) (comp-push x)
(comp-push (cadr args)) (emit-branch src 'br-if-not-null L1))
(emit-branch src 'br-if-not-eq L1)) ((not ,x)
(record-case x
((and (eq? name 'null?) (= len 1)) ((<primcall> name args)
(comp-push (car args)) (pmatch (cons name args)
(emit-branch src 'br-if-not-null L1)) ((eq? ,a ,b)
(comp-push a)
((and (eq? name 'not) (= len 1)) (comp-push b)
(let ((app (car args))) (emit-branch src 'br-if-eq L1))
(record-case app ((null? ,x)
((<call> proc args) (comp-push x)
(let ((len (length args))) (emit-branch src 'br-if-null L1))
(record-case proc (else
((<primitive-ref> name) (comp-push x)
(cond (emit-branch src 'br-if L1))))
(else
((and (eq? name 'eq?) (= len 2)) (comp-push x)
(comp-push (car args)) (emit-branch src 'br-if L1))))
(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)))))
(else (else
(comp-push test) (comp-push test)
(emit-branch src 'br-if-not L1)))) (emit-branch src 'br-if-not L1))))

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

@ -44,9 +44,8 @@
((<sequence> exps) ((<sequence> exps)
(and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?)) (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
exps)) exps))
((<call> proc args) ((<primcall> name args)
(and (primitive-ref? proc) (and (simple-primitive? name)
(simple-primitive? (primitive-ref-name proc))
;; FIXME: check arity? ;; FIXME: check arity?
(and-map (lambda (x) (and-map (lambda (x)
(simple-expression? x bound-vars simple-primitive?)) (simple-expression? x bound-vars simple-primitive?))

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

@ -47,44 +47,36 @@
(else x))) (else x)))
(else x))) (else x)))
((<call> src proc args) ((<primcall> src name args)
(record-case proc (pmatch (cons name args)
;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) ((,member ,k ,l) (guard (and (memq member '(memq memv))
((<primitive-ref> name) (const? k)
(case name (list? (const-exp l))))
((memq memv) (cond
(pmatch args ((null? (const-exp l))
((,k ,l) (guard (const? l) (list? (const-exp l))) (make-const #f #f))
(cond ((const? k)
((null? (const-exp l)) (make-const #f (->bool ((case member
(make-const #f #f)) ((memq) memq)
((const? k) ((memv) memv)
(make-const #f (->bool ((case name (else (error "what" member)))
((memq) memq) (const-exp k) (const-exp l)))))
((memv) memv) (else
(else (error "unexpected member func" name))) (let lp ((elts (const-exp l)))
(const-exp k) (const-exp l))))) (let ((test (make-primcall
(else #f
(let lp ((elts (const-exp l))) (case member
(let ((test (make-call ((memq) 'eq?)
#f ((memv) 'eqv?)
(make-primitive-ref #f (case name (else (error "what" member)))
((memq) 'eq?) (list k (make-const #f (car elts))))))
((memv) 'eqv?) (if (null? (cdr elts))
(else (error "what")))) test
(list k (make-const #f (car elts)))))) (make-conditional
(if (null? (cdr elts)) src
test test
(make-conditional (make-const #f #t)
src (lp (cdr elts)))))))))
test
(make-const #f #t)
(lp (cdr elts)))))))))
(else x)))
(else x)))
(else x))) (else x)))
((<lambda> meta body) ((<lambda> meta body)
@ -114,32 +106,27 @@
(or (inline1 x) x)) (or (inline1 x) x))
(lp alternate))))))) (lp alternate)))))))
((<primitive-ref> name) (else #f)))
(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)))
((<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))) (else #f)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
@ -178,10 +165,9 @@
(and (not opt) (not kw) rest (not alternate) (and (not opt) (not kw) rest (not alternate)
(record-case body (record-case body
((<call> proc args) ((<primcall> name args)
;; (lambda args (apply (lambda ...) args)) => (lambda ...) ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
(and (primitive-ref? proc) (and (eq? name '@apply)
(eq? (primitive-ref-name proc) '@apply)
(pair? args) (pair? args)
(lambda? (car args)) (lambda? (car args))
(args-compatible? (cdr args) gensyms) (args-compatible? (cdr args) gensyms)

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

@ -172,6 +172,9 @@
(and=> (hashq-ref *interesting-primitive-vars* (and=> (hashq-ref *interesting-primitive-vars*
(module-variable m name)) (module-variable m name))
(lambda (name) (make-primitive-ref src 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))) (else #f)))
x)) x))
@ -183,11 +186,9 @@
(pre-order! (pre-order!
(lambda (x) (lambda (x)
(record-case x (record-case x
((<call> src proc args) ((<primcall> src name args)
(and (primitive-ref? proc) (let ((expand (hashq-ref *primitive-expand-table* name)))
(let ((expand (hashq-ref *primitive-expand-table* (and expand (apply expand src args))))
(primitive-ref-name proc))))
(and expand (apply expand src args)))))
(else #f))) (else #f)))
x)) x))
@ -203,8 +204,8 @@
(lp (cdr in) (lp (cdr in)
(cons (if (eq? (caar in) 'quote) (cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in)) `(make-const src ,@(cdar in))
`(make-call src (make-primitive-ref src ',(caar in)) `(make-primcall src ',(caar in)
,(inline-args (cdar in)))) ,(inline-args (cdar in))))
out))) out)))
((symbol? (car in)) ((symbol? (car in))
;; assume it's locally bound ;; assume it's locally bound
@ -222,8 +223,8 @@
,(consequent then) ,(consequent then)
,(consequent else))) ,(consequent else)))
(else (else
`(make-call src (make-primitive-ref src ',(car exp)) `(make-primcall src ',(car exp)
,(inline-args (cdr exp)))))) ,(inline-args (cdr exp))))))
((symbol? exp) ((symbol? exp)
;; assume locally bound ;; assume locally bound
exp) exp)
@ -470,9 +471,9 @@
;; trickery here. ;; trickery here.
(make-lambda-case (make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym) (tree-il-src handler) '() #f 'args #f '() (list args-sym)
(make-call #f (make-primitive-ref #f 'apply) (make-primcall #f 'apply
(list handler (list handler
(make-lexical-ref #f 'args args-sym))) (make-lexical-ref #f 'args args-sym)))
#f)))) #f))))
(else #f))) (else #f)))
@ -491,9 +492,9 @@
;; trickery here. ;; trickery here.
(make-lambda-case (make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym) (tree-il-src handler) '() #f 'args #f '() (list args-sym)
(make-call #f (make-primitive-ref #f 'apply) (make-primcall #f 'apply
(list handler (list handler
(make-lexical-ref #f 'args args-sym))) (make-lexical-ref #f 'args args-sym)))
#f)))) #f))))
(else #f))) (else #f)))
(else #f))) (else #f)))

46
test-suite/tests/tree-il.test
View file

@ -63,7 +63,7 @@
(begin (void) (const 1)) (begin (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive +) (void) (const 1)) (primcall + (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1)))) (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
(with-test-prefix "application" (with-test-prefix "application"
@ -98,7 +98,7 @@
(eq? l1 l3) (eq? l2 l4)) (eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (if (toplevel foo) (const 1) (const 2))) (primcall null? (if (toplevel foo) (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
(const 1) (branch br ,l2) (const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4) (label ,l3) (const 2) (label ,l4)
@ -115,7 +115,7 @@
(program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (primitive +)) (primcall null? (primitive +))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1) (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1)))) (call return 1))))
@ -135,7 +135,7 @@
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (call (primitive null?) (lexical x y))) (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1) (lexical #t #f ref 0) (call null? 1) (call return 1)
@ -145,7 +145,7 @@
(assert-tree-il->glil (assert-tree-il->glil
;; unreferenced sets may be optimized away -- make sure they are ref'd ;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(set! (lexical x y) (call (primitive 1+) (lexical x y)))) (set! (lexical x y) (primcall 1+ (lexical x y))))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
@ -154,7 +154,7 @@
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(begin (set! (lexical x y) (call (primitive 1+) (lexical x y))) (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
(lexical x y))) (lexical x y)))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
@ -164,8 +164,8 @@
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(call (primitive null?) (primcall null?
(set! (lexical x y) (call (primitive 1+) (lexical x y))))) (set! (lexical x y) (primcall 1+ (lexical x y)))))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
@ -186,7 +186,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (@ (foo) bar)) (primcall null? (@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar) (module public ref (foo) bar)
(call null? 1) (call return 1))) (call null? 1) (call return 1)))
@ -204,7 +204,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (@@ (foo) bar)) (primcall null? (@@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar) (module private ref (foo) bar)
(call null? 1) (call return 1)))) (call null? 1) (call return 1))))
@ -223,7 +223,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (set! (@ (foo) bar) (const 2))) (primcall null? (set! (@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1))) (void) (call null? 1) (call return 1)))
@ -241,7 +241,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (set! (@@ (foo) bar) (const 2))) (primcall null? (set! (@@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
@ -260,7 +260,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (toplevel bar)) (primcall null? (toplevel bar))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (toplevel ref bar)
(call null? 1) (call return 1)))) (call null? 1) (call return 1))))
@ -279,7 +279,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (set! (toplevel bar) (const 2))) (primcall null? (set! (toplevel bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
@ -298,7 +298,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (define bar (const 2))) (primcall null? (define bar (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
@ -315,7 +315,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (const 2)) (primcall null? (const 2))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
@ -336,7 +336,7 @@
;; complex bindings -> box and set! within let ;; complex bindings -> box and set! within let
(assert-tree-il->glil (assert-tree-il->glil
(letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar))) (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
(call (primitive +) (lexical x x1) (lexical y y1))) (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _) (program () (std-prelude 0 4 #f) (label _)
(void) (void) ;; what are these? (void) (void) ;; what are these?
(bind (x #t 0) (y #t 1)) (bind (x #t 0) (y #t 1))
@ -352,7 +352,7 @@
;; complex bindings in letrec* -> box and set! in order ;; complex bindings in letrec* -> box and set! in order
(assert-tree-il->glil (assert-tree-il->glil
(letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar))) (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
(call (primitive +) (lexical x x1) (lexical y y1))) (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _) (program () (std-prelude 0 2 #f) (label _)
(void) (void) ;; what are these? (void) (void) ;; what are these?
(bind (x #t 0) (y #t 1)) (bind (x #t 0) (y #t 1))
@ -470,7 +470,7 @@
(const #t) (call return 1))) (const #t) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive null?) (begin (const #f) (const 2))) (primcall null? (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
@ -512,10 +512,10 @@
(with-test-prefix "apply" (with-test-prefix "apply"
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive @apply) (toplevel foo) (toplevel bar)) (primcall @apply (toplevel foo) (toplevel bar))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (call (primitive @apply) (toplevel foo) (toplevel bar)) (void)) (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@ -531,10 +531,10 @@
(with-test-prefix "call/cc" (with-test-prefix "call/cc"
(assert-tree-il->glil (assert-tree-il->glil
(call (primitive @call-with-current-continuation) (toplevel foo)) (primcall @call-with-current-continuation (toplevel foo))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (call (primitive @call-with-current-continuation) (toplevel foo)) (void)) (begin (primcall @call-with-current-continuation (toplevel foo)) (void))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)