mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

tree-il support for case-lambda

Browse source 
* module/language/tree-il.scm (<lambda>, <lambda-case>): Split lambda
  into the lambda itself, denoting the procedure, and lambda-case,
  denoting a particular arity case. Lambda-case is fairly featureful,
  and has not yet been fully tested.
  (<let-values>): Use a <lambda-case> as the binding expression. Seems
  to suit the purpose well.
  Adapt parsers, unparsers, traversal operators, etc. Sometimes in this
  first version we assume there are no optional args, rest args, or a
  predicate.

* module/language/tree-il/analyze.scm (analyze-lexicals): Adapt for the
  new case-lambda regime. Fairly well commented. It actually simplifies
  things.
  (report-unused-variables): Update for new tree-il.

* module/language/tree-il/compile-glil.scm: Adapt for the new tree-il.
  There are some first stabs here at proper case-lambda compilation, but
  they are untested as of yet.

* module/language/tree-il/inline.scm (inline!): Rework so we can
  recurse on a single node; though these transformations are strictly
  reductive, so they should complete in bounded time. Simplify
  accordingly, and adapt to case-lambda. Oh, and we handle lambda->let
  in not just the nullary case.

* module/ice-9/psyntax.scm (build-simple-lambda, build-case-lambda)
  (build-lambda-case): New constructors. The idea is that after syntax
  expansion, we shouldn't have to deal with improper lists any more.
  Build-simple-lambda is a shortcut for the common case. The others are
  not fully exercised yet. Adapt callers.
  (syntax): Add some debugging in the lambda case. I don't fully
  understand this, but in practice we don't seem to see rest args here.
  (lambda): Inline chi-lambda-clause, and adapt for build-simple-lambda.
* module/ice-9/psyntax-pp.scm: Regenerated.

* test-suite/tests/tree-il.test: Update tests for new tree-il lambda
  format, and to expect post-prelude labels for all glil programs.
This commit is contained in:
Andy Wingo 2009-10-14 00:08:35 +02:00
parent c783b0827c
commit 8a4ca0ea3b
7 changed files with 4825 additions and 4531 deletions
Download patch file Download diff file Expand all files Collapse all files

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

File diff suppressed because it is too large Load diff

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

@ -448,17 +448,66 @@
((@ (language tree-il) make-toplevel-define) source var exp)) ((@ (language tree-il) make-toplevel-define) source var exp))
(else (decorate-source `(define ,var ,exp) source))))) (else (decorate-source `(define ,var ,exp) source)))))
(define build-lambda ;; Ideally we would have all lambdas be case lambdas, but that would
(lambda (src ids vars docstring exp) ;; need special support in the interpreter for the full capabilities of
;; case-lambda, with optional and keyword args, predicates, and else
;; clauses. This will come with the new interpreter, but for now we
;; separate the cases.
(define build-simple-lambda
(lambda (src req rest vars docstring exp)
(case (fluid-ref *mode*) (case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lambda) src ids vars ((c) ((@ (language tree-il) make-lambda) src
(if docstring `((documentation . ,docstring)) '()) (if docstring `((documentation . ,docstring)) '())
exp)) ;; hah, a case in which kwargs would be nice.
((@ (language tree-il) make-lambda-case)
;; src req opt rest kw vars predicate body else
src req #f rest #f vars #f exp #f)))
(else (decorate-source (else (decorate-source
`(lambda ,vars ,@(if docstring (list docstring) '()) `(lambda ,(if rest (apply cons* vars) vars)
,exp) ,@(if docstring (list docstring) '())
,exp)
src))))) src)))))
(define build-case-lambda
(lambda (src docstring body)
(case (fluid-ref *mode*)
((c) ((@ (language tree-il) make-lambda) src
(if docstring `((documentation . ,docstring)) '())
body))
(else (decorate-source
;; really gross hack
`(lambda %%args
,@(if docstring (list docstring) '())
(cond ,@body))
src)))))
(define build-lambda-case
;; kw: ((keyword var init) ...)
(lambda (src req opt rest kw vars predicate body else-case)
(case (fluid-ref *mode*)
((c)
((@ (language tree-il) make-lambda-case)
src req opt rest kw vars predicate body else-case))
(else
(let ((nkw (map (lambda (x)
`(list ,(car x)
;; grr
,(let lp ((vars vars) (i 0))
(cond ((null? vars) (error "bad kwarg" x))
((eq? (cadr x) (car vars)) i)
(else (lp (cdr vars) (1+ i)))))
(lambda () ,(caddr x))))
kw)))
(decorate-source
`((((@@ (ice-9 optargs) parse-lambda-case)
(list ,(length req) ,(length opt) ,(and rest #t) ,nkw
,(if predicate (error "not yet implemented") #f))
%%args)
=> (lambda ,vars ,body))
,@(or else-case
`((%%args (error "wrong number of arguments" %%args)))))
src))))))
(define build-primref (define build-primref
(lambda (src name) (lambda (src name)
(if (equal? (module-name (current-module)) '(guile)) (if (equal? (module-name (current-module)) '(guile))
@ -506,7 +555,7 @@
(ids (cdr ids))) (ids (cdr ids)))
(case (fluid-ref *mode*) (case (fluid-ref *mode*)
((c) ((c)
(let ((proc (build-lambda src ids vars #f body-exp))) (let ((proc (build-simple-lambda src ids #f vars #f body-exp)))
(maybe-name-value! f-name proc) (maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
((@ (language tree-il) make-letrec) src ((@ (language tree-il) make-letrec) src
@ -1455,48 +1504,6 @@
(cons (cons er (source-wrap e w s mod)) (cons (cons er (source-wrap e w s mod))
(cdr body))))))))))))))))) (cdr body)))))))))))))))))
(define chi-lambda-clause
(lambda (e docstring c r w mod k)
(syntax-case c ()
((args doc e1 e2 ...)
(and (string? (syntax->datum (syntax doc))) (not docstring))
(chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
(((id ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(k (map syntax->datum ids)
new-vars
(and docstring (syntax->datum docstring))
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
(make-binding-wrap ids labels w)
mod))))))
((ids e1 e2 ...)
(let ((old-ids (lambda-var-list (syntax ids))))
(if (not (valid-bound-ids? old-ids))
(syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels old-ids))
(new-vars (map gen-var old-ids)))
(k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids)))
(if (null? ls1)
(syntax->datum ls2)
(f (cdr ls1) (cons (syntax->datum (car ls1)) ls2))))
(let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
(if (null? ls1)
ls2
(f (cdr ls1) (cons (car ls1) ls2))))
(and docstring (syntax->datum docstring))
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
(make-binding-wrap old-ids labels w)
mod))))))
(_ (syntax-violation 'lambda "bad lambda" e)))))
(define chi-local-syntax (define chi-local-syntax
(lambda (rec? e r w s mod k) (lambda (rec? e r w s mod k)
(syntax-case e () (syntax-case e ()
@ -1574,6 +1581,7 @@
(let ((id (if (syntax-object? id) (syntax-object-expression id) id))) (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
(build-lexical-var no-source id)))) (build-lexical-var no-source id))))
;; appears to return a reversed list
(define lambda-var-list (define lambda-var-list
(lambda (vars) (lambda (vars)
(let lvl ((vars vars) (ls '()) (w empty-wrap)) (let lvl ((vars vars) (ls '()) (w empty-wrap))
@ -1777,7 +1785,10 @@
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x))) ((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x))) ((quote) (build-data no-source (cadr x)))
((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x)))) ((lambda)
(if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) #f (regen (caddr x)))
(error "how did we get here" x)))
(else (build-application no-source (else (build-application no-source
(build-primref no-source (car x)) (build-primref no-source (car x))
(map regen (cdr x))))))) (map regen (cdr x)))))))
@ -1794,11 +1805,55 @@
(global-extend 'core 'lambda (global-extend 'core 'lambda
(lambda (e r w s mod) (lambda (e r w s mod)
(syntax-case e () (define (docstring&body ids vars labels c)
((_ . c) (syntax-case c ()
(chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod ((docstring e1 e2 ...)
(lambda (names vars docstring body) (string? (syntax->datum (syntax docstring)))
(build-lambda s names vars docstring body))))))) (values (syntax->datum (syntax docstring))
(chi-body (syntax (e1 e2 ...))
(source-wrap e w s mod)
(extend-var-env labels vars r)
(make-binding-wrap ids labels w)
mod)))
((e1 e2 ...)
(values #f
(chi-body (syntax (e1 e2 ...))
(source-wrap e w s mod)
(extend-var-env labels vars r)
(make-binding-wrap ids labels w)
mod)))))
(syntax-case e ()
((_ (id ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(syntax-violation 'lambda "invalid parameter list" e)
(let ((vars (map gen-var ids))
(labels (gen-labels ids)))
(call-with-values
(lambda ()
(docstring&body ids vars labels
(syntax (e1 e2 ...))))
(lambda (docstring body)
(build-simple-lambda s (map syntax->datum ids) #f
vars docstring body)))))))
((_ ids e1 e2 ...)
(let ((rids (lambda-var-list (syntax ids))))
(if (not (valid-bound-ids? rids))
(syntax-violation 'lambda "invalid parameter list" e)
(let* ((req (reverse (cdr rids)))
(rest (car rids))
(rrids (reverse rids))
(vars (map gen-var rrids))
(labels (gen-labels rrids)))
(call-with-values
(lambda ()
(docstring&body rrids vars labels
(syntax (e1 e2 ...))))
(lambda (docstring body)
(build-simple-lambda s (map syntax->datum req)
(syntax->datum rest)
vars docstring body)))))))
(_ (syntax-violation 'lambda "bad lambda" e)))))
(global-extend 'core 'let (global-extend 'core 'let
@ -1975,7 +2030,7 @@
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source (build-application no-source
(build-primref no-source 'apply) (build-primref no-source 'apply)
(list (build-lambda no-source (map syntax->datum ids) new-vars #f (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars #f
(chi exp (chi exp
(extend-env (extend-env
labels labels
@ -2002,7 +2057,7 @@
(let ((y (gen-var 'tmp))) (let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y ; fat finger binding and references to temp variable y
(build-application no-source (build-application no-source
(build-lambda no-source (list 'tmp) (list y) #f (build-simple-lambda no-source (list 'tmp) #f (list y) #f
(let ((y (build-lexical-reference 'value no-source (let ((y (build-lexical-reference 'value no-source
'tmp y))) 'tmp y)))
(build-conditional no-source (build-conditional no-source
@ -2039,16 +2094,16 @@
(let ((labels (list (gen-label))) (let ((labels (list (gen-label)))
(var (gen-var (syntax pat)))) (var (gen-var (syntax pat))))
(build-application no-source (build-application no-source
(build-lambda no-source (build-simple-lambda
(list (syntax->datum (syntax pat))) (list var) no-source (list (syntax->datum (syntax pat))) #f (list var)
#f #f
(chi (syntax exp) (chi (syntax exp)
(extend-env labels (extend-env labels
(list (make-binding 'syntax `(,var . 0))) (list (make-binding 'syntax `(,var . 0)))
r) r)
(make-binding-wrap (syntax (pat)) (make-binding-wrap (syntax (pat))
labels empty-wrap) labels empty-wrap)
mod)) mod))
(list x))) (list x)))
(gen-clause x keys (cdr clauses) r (gen-clause x keys (cdr clauses) r
(syntax pat) #t (syntax exp) mod))) (syntax pat) #t (syntax exp) mod)))
@ -2067,7 +2122,7 @@
(let ((x (gen-var 'tmp))) (let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x ; fat finger binding and references to temp variable x
(build-application s (build-application s
(build-lambda no-source (list 'tmp) (list x) #f (build-simple-lambda no-source (list 'tmp) #f (list x) #f
(gen-syntax-case (build-lexical-reference 'value no-source (gen-syntax-case (build-lexical-reference 'value no-source
'tmp x) 'tmp x)
(syntax (key ...)) (syntax (m ...)) (syntax (key ...)) (syntax (m ...))

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

@ -36,11 +36,14 @@
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else <conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
<application> application? make-application application-src application-proc application-args <application> application? make-application application-src application-proc application-args
<sequence> sequence? make-sequence sequence-src sequence-exps <sequence> sequence? make-sequence sequence-src sequence-exps
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars 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-req lambda-case-opt lambda-case-rest lambda-case-kw lambda-case-vars
lambda-case-predicate lambda-case-body lambda-case-else
<let> let? make-let let-src let-names let-vars let-vals let-body <let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
parse-tree-il parse-tree-il
unparse-tree-il unparse-tree-il
@ -65,11 +68,12 @@
(<conditional> test then else) (<conditional> test then else)
(<application> proc args) (<application> proc args)
(<sequence> exps) (<sequence> exps)
(<lambda> names vars meta body) (<lambda> meta body)
(<lambda-case> req opt rest kw vars predicate body else)
(<let> names vars vals body) (<let> names vars vals body)
(<letrec> names vars vals body) (<letrec> names vars vals body)
(<fix> names vars vals body) (<fix> names vars vals body)
(<let-values> names vars exp body)) (<let-values> exp body))
@ -127,11 +131,14 @@
((define ,name ,exp) (guard (symbol? name)) ((define ,name ,exp) (guard (symbol? name))
(make-toplevel-define loc name (retrans exp))) (make-toplevel-define loc name (retrans exp)))
((lambda ,names ,vars ,exp) ((lambda ,meta ,body)
(make-lambda loc names vars '() (retrans exp))) (make-lambda loc meta (retrans body)))
((lambda ,names ,vars ,meta ,exp) ((lambda-case ((,req ,opt ,rest ,kw ,vars ,predicate) ,body) ,else)
(make-lambda loc names vars meta (retrans exp))) (make-lambda-case loc req opt rest kw vars
(and=> predicate retrans)
(retrans body)
(and=> else retrans)))
((const ,exp) ((const ,exp)
(make-const loc exp)) (make-const loc exp))
@ -148,8 +155,8 @@
((fix ,names ,vars ,vals ,body) ((fix ,names ,vars ,vals ,body)
(make-fix loc names vars (map retrans vals) (retrans body))) (make-fix loc names vars (map retrans vals) (retrans body)))
((let-values ,names ,vars ,exp ,body) ((let-values ,exp ,body)
(make-let-values loc names vars (retrans exp) (retrans body))) (make-let-values loc (retrans exp) (retrans body)))
(else (else
(error "unrecognized tree-il" exp))))) (error "unrecognized tree-il" exp)))))
@ -189,8 +196,13 @@
((<toplevel-define> name exp) ((<toplevel-define> name exp)
`(define ,name ,(unparse-tree-il exp))) `(define ,name ,(unparse-tree-il exp)))
((<lambda> names vars meta body) ((<lambda> meta body)
`(lambda ,names ,vars ,meta ,(unparse-tree-il body))) `(lambda ,meta ,(unparse-tree-il body)))
((<lambda-case> req opt rest kw vars predicate body else)
`(lambda-case ((,req ,opt ,rest ,kw ,vars ,(and=> predicate unparse-tree-il))
,(unparse-tree-il body))
,(and=> else unparse-tree-il)))
((<const> exp) ((<const> exp)
`(const ,exp)) `(const ,exp))
@ -207,8 +219,8 @@
((<fix> names vars vals body) ((<fix> names vars vals body)
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body))) `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
((<let-values> names vars exp body) ((<let-values> exp body)
`(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body))))) `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
(define (tree-il->scheme e) (define (tree-il->scheme e)
(record-case e (record-case e
@ -247,10 +259,31 @@
((<toplevel-define> name exp) ((<toplevel-define> name exp)
`(define ,name ,(tree-il->scheme exp))) `(define ,name ,(tree-il->scheme exp)))
((<lambda> vars meta body) ((<lambda> meta body)
`(lambda ,vars ;; fixme: put in docstring
,@(cond ((assq-ref meta 'documentation) => list) (else '())) (if (and (lambda-case? body)
,(tree-il->scheme body))) (not (lambda-case-else body)))
`(lambda ,@(car (tree-il->scheme body)))
`(case-lambda ,@(tree-il->scheme body))))
((<lambda-case> req opt rest kw vars predicate body else)
;; FIXME
#; `(((,@req
,@(if (not opt)
'()
(cons #:optional opt))
,@(if (not kw)
'()
(cons #:key (cdr kw)))
,@(if predicate
(list #:predicate (tree-il->scheme predicate))
'())
. ,(or rest '()))
,(tree-il->scheme body))
,@(if else (tree-il->scheme else) '()))
`((,(if rest (apply cons* vars) vars)
,(tree-il->scheme body))
,@(if else (tree-il->scheme else) '())))
((<const> exp) ((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp))) (if (and (self-evaluating? exp) (not (vector? exp)))
@ -272,7 +305,7 @@
((<let-values> vars exp body) ((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp)) `(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body)))))) ,(tree-il->scheme (make-lambda #f '() body))))))
(define (tree-il-fold leaf down up seed tree) (define (tree-il-fold leaf down up seed tree)
@ -306,6 +339,15 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop exps (down tree result)))) (up tree (loop exps (down tree result))))
((<lambda> body) ((<lambda> body)
(up tree (loop body (down tree result)))) (up tree (loop body (down tree result))))
((<lambda-case> predicate body else)
(up tree (if else
(loop else
(if predicate
(loop body (loop predicate (down tree result)))
(loop body (down tree result))))
(if predicate
(loop body (loop predicate (down tree result)))
(loop body (down tree result))))))
((<let> vals body) ((<let> vals body)
(up tree (loop body (up tree (loop body
(loop vals (loop vals
@ -357,6 +399,18 @@ This is an implementation of `foldts' as described by Andy Wingo in
(fold-values foldts exps seed ...)) (fold-values foldts exps seed ...))
((<lambda> body) ((<lambda> body)
(foldts body seed ...)) (foldts body seed ...))
((<lambda-case> predicate body else)
(if predicate
(if else
(let*-values (((seed ...) (foldts predicate seed ...))
((seed ...) (foldts body seed ...)))
(foldts else seed ...))
(let-values (((seed ...) (foldts predicate seed ...)))
(foldts body seed ...)))
(if else
(let-values (((seed ...) (foldts body seed ...)))
(foldts else seed ...))
(foldts body seed ...))))
((<let> vals body) ((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...))) (let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...))) (foldts body seed ...)))
@ -397,9 +451,16 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<toplevel-define> name exp) ((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp))) (set! (toplevel-define-exp x) (lp exp)))
((<lambda> vars meta body) ((<lambda> body)
(set! (lambda-body x) (lp body))) (set! (lambda-body x) (lp body)))
((<lambda-case> predicate body else)
(if predicate
(set! (lambda-case-predicate x) (lp predicate)))
(set! (lambda-case-body x) (lp body))
(if else
(set! (lambda-case-else x) (lp else))))
((<sequence> exps) ((<sequence> exps)
(set! (sequence-exps x) (map lp exps))) (set! (sequence-exps x) (map lp exps)))
@ -415,7 +476,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (fix-vals x) (map lp vals)) (set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body))) (set! (fix-body x) (lp body)))
((<let-values> vars exp body) ((<let-values> exp body)
(set! (let-values-exp x) (lp exp)) (set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body))) (set! (let-values-body x) (lp body)))
@ -451,6 +512,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<lambda> body) ((<lambda> body)
(set! (lambda-body x) (lp body))) (set! (lambda-body x) (lp body)))
((<lambda-case> predicate body else)
(if predicate (set! (lambda-case-predicate x) (lp predicate)))
(set! (lambda-case-body x) (lp body))
(if else (set! (lambda-case-else x) (lp else))))
((<sequence> exps) ((<sequence> exps)
(set! (sequence-exps x) (map lp exps))) (set! (sequence-exps x) (map lp exps)))

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

@ -112,13 +112,20 @@
;; translated into labels, and information on what free variables to ;; translated into labels, and information on what free variables to
;; capture from its lexical parent procedure. ;; capture from its lexical parent procedure.
;; ;;
;; In addition, we have a conflation: while we're traversing the code,
;; recording information to pass to the compiler, we take the
;; opportunity to generate labels for each lambda-case clause, so that
;; generated code can skip argument checks at runtime if they match at
;; compile-time.
;;
;; That is: ;; That is:
;; ;;
;; sym -> {lambda -> address} ;; sym -> {lambda -> address}
;; lambda -> (nlocs labels . free-locs) ;; lambda -> (labels . free-locs)
;; lambda-case -> (gensym . nlocs)
;; ;;
;; address ::= (local? boxed? . index) ;; address ::= (local? boxed? . index)
;; labels ::= ((sym . lambda-vars) ...) ;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc. ;; free variable addresses are relative to parent proc.
@ -141,9 +148,9 @@
;; refcounts: sym -> count ;; refcounts: sym -> count
;; allows us to detect the or-expansion in O(1) time ;; allows us to detect the or-expansion in O(1) time
(define refcounts (make-hash-table)) (define refcounts (make-hash-table))
;; labels: sym -> lambda-vars ;; labels: sym -> lambda
;; for determining if fixed-point procedures can be rendered as ;; for determining if fixed-point procedures can be rendered as
;; labels. lambda-vars may be an improper list. ;; labels.
(define labels (make-hash-table)) (define labels (make-hash-table))
;; returns variables referenced in expr ;; returns variables referenced in expr
@ -167,9 +174,21 @@
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(if (not (and tail-call-args (if (not (and tail-call-args
(memq gensym labels-in-proc) (memq gensym labels-in-proc)
(let ((args (hashq-ref labels gensym))) (let ((p (hashq-ref labels gensym)))
(and (list? args) (and p
(= (length args) (length tail-call-args)))))) (let lp ((c (lambda-body p)))
(and c (lambda-case? c)
(or
;; for now prohibit optional &
;; keyword arguments; can relax this
;; restriction later
(and (= (length (lambda-case-req c))
(length tail-call-args))
(not (lambda-case-opt c))
(not (lambda-case-kw c))
(not (lambda-case-rest c))
(not (lambda-case-predicate c)))
(lp (lambda-case-else c)))))))))
(hashq-set! labels gensym #f)) (hashq-set! labels gensym #f))
(list gensym)) (list gensym))
@ -195,19 +214,24 @@
(else (else
(lp (cdr exps) (lset-union eq? ret (step (car exps)))))))) (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
((<lambda> vars body) ((<lambda> body)
(let ((locally-bound (let rev* ((vars vars) (out '())) ;; order is important here
(cond ((null? vars) out) (hashq-set! bound-vars x '())
((pair? vars) (rev* (cdr vars) (let ((free (recur body x)))
(cons (car vars) out))) (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
(else (cons vars out)))))) (hashq-set! free-vars x free)
(hashq-set! bound-vars x locally-bound) free))
(let* ((referenced (recur body x))
(free (lset-difference eq? referenced locally-bound)) ((<lambda-case> vars predicate body else)
(all-bound (reverse! (hashq-ref bound-vars x)))) (hashq-set! bound-vars proc
(hashq-set! bound-vars x all-bound) (append (reverse vars) (hashq-ref bound-vars proc)))
(hashq-set! free-vars x free) (lset-union
free))) eq?
(lset-difference eq?
(lset-union eq? (if predicate (step predicate) '())
(step-tail body))
vars)
(if else (step-tail else) '())))
((<let> vars vals body) ((<let> vars vals body)
(hashq-set! bound-vars proc (hashq-set! bound-vars proc
@ -226,7 +250,7 @@
((<fix> vars vals body) ((<fix> vars vals body)
;; Try to allocate these procedures as labels. ;; Try to allocate these procedures as labels.
(for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val))) (for-each (lambda (sym val) (hashq-set! labels sym val))
vars vals) vars vals)
(hashq-set! bound-vars proc (hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc))) (append (reverse vars) (hashq-ref bound-vars proc)))
@ -240,21 +264,14 @@
;; prevent label allocation.) ;; prevent label allocation.)
(lambda (x) (lambda (x)
(record-case x (record-case x
((<lambda> (lvars vars) body) ((<lambda> body)
(let ((locally-bound ;; just like the closure case, except here we use
(let rev* ((lvars lvars) (out '())) ;; recur/labels instead of recur
(cond ((null? lvars) out) (hashq-set! bound-vars x '())
((pair? lvars) (rev* (cdr lvars) (let ((free (recur/labels body x vars)))
(cons (car lvars) out))) (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
(else (cons lvars out)))))) (hashq-set! free-vars x free)
(hashq-set! bound-vars x locally-bound) free))))
;; recur/labels, the difference from the closure case
(let* ((referenced (recur/labels body x vars))
(free (lset-difference eq? referenced locally-bound))
(all-bound (reverse! (hashq-ref bound-vars x))))
(hashq-set! bound-vars x all-bound)
(hashq-set! free-vars x free)
free)))))
vals)) vals))
(vars-with-refs (map cons vars var-refs)) (vars-with-refs (map cons vars var-refs))
(body-refs (recur/labels body proc vars))) (body-refs (recur/labels body proc vars)))
@ -302,15 +319,8 @@
(apply lset-union eq? body-refs var-refs) (apply lset-union eq? body-refs var-refs)
vars))) vars)))
((<let-values> vars exp body) ((<let-values> exp body)
(let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars)) (lset-union eq? (step exp) (step body)))
(if (pair? in)
(lp (cons (car in) out) (cdr in))
(if (null? in) out (cons in out))))))
(hashq-set! bound-vars proc bound)
(lset-difference eq?
(lset-union eq? (step exp) (step-tail body))
bound)))
(else '()))) (else '())))
@ -342,7 +352,7 @@
((<sequence> exps) ((<sequence> exps)
(apply max (map recur exps))) (apply max (map recur exps)))
((<lambda> vars body) ((<lambda> body)
;; allocate closure vars in order ;; allocate closure vars in order
(let lp ((c (hashq-ref free-vars x)) (n 0)) (let lp ((c (hashq-ref free-vars x)) (n 0))
(if (pair? c) (if (pair? c)
@ -352,18 +362,7 @@
`(#f ,(hashq-ref assigned (car c)) . ,n)) `(#f ,(hashq-ref assigned (car c)) . ,n))
(lp (cdr c) (1+ n))))) (lp (cdr c) (1+ n)))))
(let ((nlocs (let ((nlocs (allocate! body x 0))
(let lp ((vars vars) (n 0))
(if (not (null? vars))
;; allocate args
(let ((v (if (pair? vars) (car vars) vars)))
(hashq-set! allocation v
(make-hashq
x `(#t ,(hashq-ref assigned v) . ,n)))
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))
;; allocate body, return total number of locals
;; (including arguments)
(allocate! body x n))))
(free-addresses (free-addresses
(map (lambda (v) (map (lambda (v)
(hashq-ref (hashq-ref allocation v) proc)) (hashq-ref (hashq-ref allocation v) proc))
@ -373,9 +372,25 @@
(cons sym (hashq-ref labels sym))) (cons sym (hashq-ref labels sym)))
(hashq-ref bound-vars x))))) (hashq-ref bound-vars x)))))
;; set procedure allocations ;; set procedure allocations
(hashq-set! allocation x (cons* nlocs labels free-addresses))) (hashq-set! allocation x (cons labels free-addresses)))
n) n)
((<lambda-case> vars predicate body else)
(max
(let lp ((vars vars) (n n))
(if (null? vars)
(let ((nlocs (max (if predicate (allocate! predicate body n) n)
(allocate! body proc n))))
;; label and nlocs for the case
(hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
nlocs)
(begin
(hashq-set! allocation (car vars)
(make-hashq
proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
(lp (cdr vars) (1+ n)))))
(if else (allocate! else proc n) n)))
((<let> vars vals body) ((<let> vars vals body)
(let ((nmax (apply max (map recur vals)))) (let ((nmax (apply max (map recur vals))))
(cond (cond
@ -427,22 +442,12 @@
((null? vars) ((null? vars)
(max nmax (allocate! body proc n))) (max nmax (allocate! body proc n)))
((hashq-ref labels (car vars)) ((hashq-ref labels (car vars))
;; allocate label bindings & body inline to proc ;; allocate lambda body inline to proc
(lp (cdr vars) (lp (cdr vars)
(cdr vals) (cdr vals)
(record-case (car vals) (record-case (car vals)
((<lambda> vars body) ((<lambda> body)
(let lp ((vars vars) (n n)) (max nmax (allocate! body proc n))))))
(if (not (null? vars))
;; allocate bindings
(let ((v (if (pair? vars) (car vars) vars)))
(hashq-set!
allocation v
(make-hashq
proc `(#t ,(hashq-ref assigned v) . ,n)))
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))
;; allocate body
(max nmax (allocate! body proc n))))))))
(else (else
;; allocate closure ;; allocate closure
(lp (cdr vars) (lp (cdr vars)
@ -461,25 +466,8 @@
(hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
(lp (cdr in) (1+ n)))))))) (lp (cdr in) (1+ n))))))))
((<let-values> vars exp body) ((<let-values> exp body)
(let ((nmax (recur exp))) (max (recur exp) (recur body)))
(let lp ((vars vars) (n n))
(cond
((null? vars)
(max nmax (allocate! body proc n)))
((not (pair? vars))
(hashq-set! allocation vars
(make-hashq proc
`(#t ,(hashq-ref assigned vars) . ,n)))
;; the 1+ for this var
(max nmax (allocate! body proc (1+ n))))
(else
(let ((v (car vars)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))))
(else n))) (else n)))
@ -504,21 +492,10 @@
(refs binding-info-refs) ;; (GENSYM ...) (refs binding-info-refs) ;; (GENSYM ...)
(locs binding-info-locs)) ;; (LOCATION ...) (locs binding-info-locs)) ;; (LOCATION ...)
;; FIXME!!
(define (report-unused-variables tree env) (define (report-unused-variables tree env)
"Report about unused variables in TREE. Return TREE." "Report about unused variables in TREE. Return TREE."
(define (dotless-list lst)
;; If LST is a dotted list, return a proper list equal to LST except that
;; the very last element is a pair; otherwise return LST.
(let loop ((lst lst)
(result '()))
(cond ((null? lst)
(reverse result))
((pair? lst)
(loop (cdr lst) (cons (car lst) result)))
(else
(loop '() (cons lst result))))))
(tree-il-fold (lambda (x info) (tree-il-fold (lambda (x info)
;; X is a leaf: extend INFO's refs accordingly. ;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (binding-info-refs info)) (let ((refs (binding-info-refs info))
@ -546,9 +523,9 @@
((<lexical-set> gensym) ((<lexical-set> gensym)
(make-binding-info vars (cons gensym refs) (make-binding-info vars (cons gensym refs)
(cons src locs))) (cons src locs)))
((<lambda> vars names) ((<lambda-case> req opt rest kw vars)
(let ((vars (dotless-list vars)) ;; FIXME keywords.
(names (dotless-list names))) (let ((names `(,@req ,@(or opt '()) . ,(or rest '()))))
(make-binding-info (extend vars names) refs (make-binding-info (extend vars names) refs
(cons src locs)))) (cons src locs))))
((<let> vars names) ((<let> vars names)
@ -560,9 +537,6 @@
((<fix> vars names) ((<fix> vars names)
(make-binding-info (extend vars names) refs (make-binding-info (extend vars names) refs
(cons src locs))) (cons src locs)))
((<let-values> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
(else info)))) (else info))))
(lambda (x info) (lambda (x info)
@ -577,7 +551,7 @@
;; Don't report lambda parameters as ;; Don't report lambda parameters as
;; unused. ;; unused.
(if (and (not (memq gensym refs)) (if (and (not (memq gensym refs))
(not (and (lambda? x) (not (and (lambda-case? x)
(memq gensym (memq gensym
inner-vars)))) inner-vars))))
(let ((name (cadr var)) (let ((name (cadr var))
@ -597,10 +571,9 @@
;; It doesn't hurt as these are unique names, it just ;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat. ;; makes REFS unnecessarily fat.
(record-case x (record-case x
((<lambda> vars) ((<lambda-case> vars)
(let ((vars (dotless-list vars))) (make-binding-info (shrink vars refs) refs
(make-binding-info (shrink vars refs) refs (cdr locs)))
(cdr locs))))
((<let> vars) ((<let> vars)
(make-binding-info (shrink vars refs) refs (make-binding-info (shrink vars refs) refs
(cdr locs))) (cdr locs)))
@ -610,9 +583,6 @@
((<fix> vars) ((<fix> vars)
(make-binding-info (shrink vars refs) refs (make-binding-info (shrink vars refs) refs
(cdr locs))) (cdr locs)))
((<let-values> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
(else info)))) (else info))))
(make-binding-info '() '() '()) (make-binding-info '() '() '())
tree) tree)

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

@ -32,9 +32,11 @@
;; allocation: ;; allocation:
;; sym -> {lambda -> address} ;; sym -> {lambda -> address}
;; lambda -> (nlocs labels . free-locs) ;; lambda -> (labels . free-locs)
;; lambda-case -> (gensym . nlocs)
;; ;;
;; address := (local? boxed? . index) ;; address ::= (local? boxed? . index)
;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc. ;; free variable addresses are relative to parent proc.
@ -56,7 +58,8 @@
(warn x e)))) (warn x e))))
warnings) warnings)
(let* ((x (make-lambda (tree-il-src x) '() '() '() x)) (let* ((x (make-lambda (tree-il-src x) '()
(make-lambda-case #f '() #f #f #f '() #f x #f)))
(x (optimize! x e opts)) (x (optimize! x e opts))
(allocation (analyze-lexicals x))) (allocation (analyze-lexicals x)))
@ -173,47 +176,21 @@
(reverse out))) (reverse out)))
(define (flatten-lambda x self-label allocation) (define (flatten-lambda x self-label allocation)
(receive (ids vars nargs nrest) (record-case x
(let lp ((ids (lambda-names x)) (vars (lambda-vars x)) ((<lambda> src meta body)
(oids '()) (ovars '()) (n 0)) (make-glil-program
(cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) meta
((pair? vars) (lp (cdr ids) (cdr vars) (with-output-to-code
(cons (car ids) oids) (cons (car vars) ovars) (lambda (emit-code)
(1+ n))) ;; write source info for proc
(else (values (reverse (cons ids oids)) (if src (emit-code #f (make-glil-source src)))
(reverse (cons vars ovars)) ;; emit pre-prelude label for self tail calls in which the
(1+ n) 1)))) ;; number of arguments doesn't check out at compile time
(let ((nlocs (car (hashq-ref allocation x))) (if self-label
(labels (cadr (hashq-ref allocation x)))) (emit-code #f (make-glil-label self-label)))
(make-glil-program ;; compile the body, yo
(lambda-meta x) (flatten body allocation x self-label (car (hashq-ref allocation x))
(with-output-to-code emit-code)))))))
(lambda (emit-code)
;; write source info for proc
(if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x))))
;; the prelude, to check args & reset the stack pointer,
;; allowing room for locals
(if (zero? nrest)
(emit-code #f (make-glil-std-prelude nargs nlocs #f))
(emit-code #f (make-glil-opt-prelude (1- nargs) 0 #t nlocs #f)))
;; write bindings info
(if (not (null? ids))
(emit-bindings #f ids vars allocation x emit-code))
;; post-prelude label for self tail calls
(if self-label
(emit-code #f (make-glil-label self-label)))
;; box args if necessary
(for-each
(lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) x)
((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n)))))
vars)
;; and here, here, dear reader: we compile.
(flatten (lambda-body x) allocation x self-label
labels emit-code)))))))
(define (flatten x allocation self self-label fix-labels emit-code) (define (flatten x allocation self self-label fix-labels emit-code)
(define (emit-label label) (define (emit-label label)
@ -410,43 +387,78 @@
(error "bad primitive op: too many pushes" (error "bad primitive op: too many pushes"
op (instruction-pushes op)))))) op (instruction-pushes op))))))
;; da capo al fine ;; 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)
;; self-call in tail position is a goto (eq? context 'tail))
(eq? context 'tail) ;; first, evaluate new values, pushing them on the stack
;; make sure the arity is right
(list? (lambda-vars self))
(= (length args) (length (lambda-vars self))))
;; evaluate new values
(for-each comp-push args) (for-each comp-push args)
;; rename & goto (let lp ((lcase (lambda-body self)))
(for-each (lambda (sym) (cond
(pmatch (hashq-ref (hashq-ref allocation sym) self) ((and (lambda-case? lcase)
((#t ,boxed? . ,index) (not (lambda-case-kw lcase))
;; set unboxed, as the proc prelude will box if needed (not (lambda-case-opt lcase))
(emit-code #f (make-glil-lexical #t #f 'set index))) (not (lambda-case-rest lcase))
(,x (error "what" x)))) (= (length args) (length (lambda-case-req lcase))))
(reverse (lambda-vars self))) ;; we have a case that matches the args; rename variables
(emit-branch src 'br self-label)) ;; and goto the case label
(for-each (lambda (sym)
(pmatch (hashq-ref (hashq-ref allocation sym) self)
((#t #f . ,index) ; unboxed
(emit-code #f (make-glil-lexical #t #f 'set index)))
((#t #t . ,index) ; boxed
;; new box
(emit-code #f (make-glil-lexical #t #t 'box index)))
(,x (error "what" x))))
(reverse (lambda-case-vars lcase)))
(emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase)
;; no match, try next case
(lp (lambda-case-else lcase)))
(else
;; no cases left; shuffle args down and jump before the prelude.
(for-each (lambda (i)
(emit-code #f (make-glil-lexical #t #f 'set index)))
(reverse (iota (length args))))
(emit-branch src 'br self-label)))))
;; lambda, the ultimate goto ;; lambda, the ultimate goto
((and (lexical-ref? proc) ((and (lexical-ref? proc)
(assq (lexical-ref-gensym proc) fix-labels)) (assq (lexical-ref-gensym proc) fix-labels))
;; evaluate new values, assuming that analyze-lexicals did its ;; like the self-tail-call case, though we can handle "drop"
;; job, and that the arity was right ;; contexts too. first, evaluate new values, pushing them on
;; the stack
(for-each comp-push args) (for-each comp-push args)
;; rename ;; find the specific case, rename args, and goto the case label
(for-each (lambda (sym) (let lp ((lcase (lambda-body
(pmatch (hashq-ref (hashq-ref allocation sym) self) (assq-ref fix-labels (lexical-ref-gensym proc)))))
((#t #f . ,index) (cond
(emit-code #f (make-glil-lexical #t #f 'set index))) ((and (lambda-case? lcase)
((#t #t . ,index) (not (lambda-case-kw lcase))
(emit-code #f (make-glil-lexical #t #t 'box index))) (not (lambda-case-opt lcase))
(,x (error "what" x)))) (not (lambda-case-rest lcase))
(reverse (assq-ref fix-labels (lexical-ref-gensym proc)))) (= (length args) (length (lambda-case-req lcase))))
;; goto! ;; we have a case that matches the args; rename variables
(emit-branch src 'br (lexical-ref-gensym proc))) ;; and goto the case label
(for-each (lambda (sym)
(pmatch (hashq-ref (hashq-ref allocation sym) self)
((#t #f . ,index) ; unboxed
(emit-code #f (make-glil-lexical #t #f 'set index)))
((#t #t . ,index) ; boxed
(emit-code #f (make-glil-lexical #t #t 'box index)))
(,x (error "what" x))))
(reverse (lambda-case-vars lcase)))
(emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase)
;; no match, try next case
(lp (lambda-case-else lcase)))
(else
;; no cases left. we can't really handle this currently.
;; ideally we would push on a new frame, then do a "local
;; call" -- which doesn't require consing up a program
;; object. but for now error, as this sort of case should
;; preclude label allocation.
(error "couldn't find matching case for label call" x)))))
(else (else
(if (not (eq? context 'tail)) (if (not (eq? context 'tail))
@ -570,7 +582,7 @@
(maybe-emit-return)) (maybe-emit-return))
((<lambda>) ((<lambda>)
(let ((free-locs (cddr (hashq-ref allocation x)))) (let ((free-locs (cdr (hashq-ref allocation x))))
(case context (case context
((push vals tail) ((push vals tail)
(emit-code #f (flatten-lambda x #f allocation)) (emit-code #f (flatten-lambda x #f allocation))
@ -587,6 +599,44 @@
(emit-code #f (make-glil-call 'make-closure 2))))))) (emit-code #f (make-glil-call 'make-closure 2)))))))
(maybe-emit-return)) (maybe-emit-return))
((<lambda-case> req opt kw rest vars predicate else body)
;; the prelude, to check args & reset the stack pointer,
;; allowing room for locals
(let ((nlocs (cdr (hashq-ref allocation x))))
(if rest
(emit-code #f (make-glil-opt-prelude (length req) 0 #t nlocs #f))
(emit-code #f (make-glil-std-prelude (length req) nlocs #f))))
;; box args if necessary
(for-each
(lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n)))))
vars)
;; write bindings info -- FIXME deal with opt/kw
(if (not (null? vars))
(emit-bindings #f (append req (if rest (list rest) '()))
vars allocation self emit-code))
;; post-prelude case label for label calls
(emit-label (car (hashq-ref allocation x)))
(let ((else-label (and else (make-label))))
(if predicate
(begin
(comp-push predicate)
(if else-label
;; fixme: debox if necessary
(emit-branch src 'br-if-not else-label)
;; fixme: better error
(emit-code src (make-glil-call 'assert-true 0)))))
(comp-tail body)
(if (not (null? vars))
(emit-code #f (make-glil-unbind)))
(if else-label
(begin
(emit-label else-label)
(comp-tail else)))))
((<let> src names vars vals body) ((<let> src names vars vals body)
(for-each comp-push vals) (for-each comp-push vals)
(emit-bindings src names vars allocation self emit-code) (emit-bindings src names vars allocation self emit-code)
@ -637,7 +687,7 @@
((hashq-ref allocation x) ((hashq-ref allocation x)
;; allocating a closure ;; allocating a closure
(emit-code #f (flatten-lambda x v allocation)) (emit-code #f (flatten-lambda x v allocation))
(if (not (null? (cddr (hashq-ref allocation x)))) (if (not (null? (cdr (hashq-ref allocation x))))
;; Need to make-closure first, but with a temporary #f ;; Need to make-closure first, but with a temporary #f
;; free-variables vector, so we are mutating fresh ;; free-variables vector, so we are mutating fresh
;; closures on the heap. ;; closures on the heap.
@ -652,15 +702,19 @@
;; labels allocation: emit label & body, but jump over it ;; labels allocation: emit label & body, but jump over it
(let ((POST (make-label))) (let ((POST (make-label)))
(emit-branch #f 'br POST) (emit-branch #f 'br POST)
(emit-label v) (let lp ((lcase (lambda-body x)))
;; we know the lambda vars are a list (if lcase
(emit-bindings #f (lambda-names x) (lambda-vars x) (record-case lcase
allocation self emit-code) ((<lambda-case> src req vars body else)
(if (lambda-src x) (emit-label (car (hashq-ref allocation lcase)))
(emit-code #f (make-glil-source (lambda-src x)))) ;; FIXME: opt & kw args in the bindings
(comp-fix (lambda-body x) (or RA new-RA)) (emit-bindings #f req vars allocation self emit-code)
(emit-code #f (make-glil-unbind)) (if src
(emit-label POST))))) (emit-code #f (make-glil-source src)))
(comp-fix body (or RA new-RA))
(emit-code #f (make-glil-unbind))
(lp else)))
(emit-label POST)))))))
vals vals
vars) vars)
;; Emit bindings metadata for closures ;; Emit bindings metadata for closures
@ -677,7 +731,7 @@
(for-each (for-each
(lambda (x v) (lambda (x v)
(let ((free-locs (if (hashq-ref allocation x) (let ((free-locs (if (hashq-ref allocation x)
(cddr (hashq-ref allocation x)) (cdr (hashq-ref allocation x))
;; can hit this latter case for labels allocation ;; can hit this latter case for labels allocation
'()))) '())))
(if (not (null? free-locs)) (if (not (null? free-locs))
@ -701,31 +755,27 @@
(emit-label new-RA)) (emit-label new-RA))
(emit-code #f (make-glil-unbind)))) (emit-code #f (make-glil-unbind))))
((<let-values> src names vars exp body) ((<let-values> src exp body)
(let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f)) (record-case body
(cond ((<lambda-case> req opt kw rest vars predicate body else)
((pair? inames) (if (or opt kw predicate else)
(lp (cons (car inames) names) (cons (car ivars) vars) (error "unexpected lambda-case in let-values" x))
(cdr inames) (cdr ivars) #f)) (let ((MV (make-label)))
((not (null? inames)) (comp-vals exp MV)
(lp (cons inames names) (cons ivars vars) '() '() #t)) (emit-code #f (make-glil-const 1))
(else (emit-label MV)
(let ((names (reverse! names)) (emit-code src (make-glil-mv-bind
(vars (reverse! vars)) (vars->bind-list
(MV (make-label))) (append req (if rest (list rest) '()))
(comp-vals exp MV) vars allocation self)
(emit-code #f (make-glil-const 1)) (and rest #t)))
(emit-label MV) (for-each (lambda (v)
(emit-code src (make-glil-mv-bind (pmatch (hashq-ref (hashq-ref allocation v) self)
(vars->bind-list names vars allocation self) ((#t #f . ,n)
rest?)) (emit-code src (make-glil-lexical #t #f 'set n)))
(for-each (lambda (v) ((#t #t . ,n)
(pmatch (hashq-ref (hashq-ref allocation v) self) (emit-code src (make-glil-lexical #t #t 'box n)))
((#t #f . ,n) (,loc (error "badness" x loc))))
(emit-code src (make-glil-lexical #t #f 'set n))) (reverse vars))
((#t #t . ,n) (comp-tail body)
(emit-code src (make-glil-lexical #t #t 'box n))) (emit-code #f (make-glil-unbind)))))))))
(,loc (error "badness" x loc))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind))))))))))

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

@ -17,6 +17,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language tree-il inline) (define-module (language tree-il inline)
#:use-module (system base pmatch)
#:use-module (system base syntax) #:use-module (system base syntax)
#:use-module (language tree-il) #:use-module (language tree-il)
#:export (inline!)) #:export (inline!))
@ -34,16 +35,20 @@
;; This is a completely brain-dead optimization pass whose sole claim to ;; This is a completely brain-dead optimization pass whose sole claim to
;; fame is ((lambda () x)) => x. ;; fame is ((lambda () x)) => x.
(define (inline! x) (define (inline! x)
(post-order! (define (inline1 x)
(lambda (x) (record-case x
(record-case x ((<application> src proc args)
((<application> src proc args) (record-case proc
(cond ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
((<lambda> body)
;; ((lambda () x)) => x (let lp ((lcase body))
((and (lambda? proc) (null? (lambda-vars proc)) (and lcase
(null? args)) (record-case lcase
(lambda-body proc)) ((<lambda-case> req opt rest kw vars predicate body else)
(if (and (= (length vars) (length req) (length args)))
(let ((x (make-let src req vars args body)))
(or (inline1 x) x))
(lp else)))))))
;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar) ;; => (let-values (((a b . c) foo)) bar)
@ -51,31 +56,33 @@
;; Note that this is a singly-binding form of let-values. Also ;; Note that this is a singly-binding form of let-values. Also
;; note that Scheme's let-values expands into call-with-values, ;; note that Scheme's let-values expands into call-with-values,
;; then here we reduce it to tree-il's let-values. ;; then here we reduce it to tree-il's let-values.
((and (primitive-ref? proc) ((<primitive-ref> name)
(eq? (primitive-ref-name proc) '@call-with-values) (and (eq? name '@call-with-values)
(= (length args) 2) (pmatch args
(lambda? (cadr args))) ((,producer ,consumer)
(let ((producer (car args)) (guard (lambda? consumer)
(consumer (cadr args))) (lambda-case? (lambda-body consumer))
(make-let-values src (not (lambda-case-opt (lambda-body consumer)))
(lambda-names consumer) (not (lambda-case-kw (lambda-body consumer)))
(lambda-vars consumer) (not (lambda-case-predicate (lambda-body consumer)))
(if (and (lambda? producer) (not (lambda-case-else (lambda-body consumer))))
(null? (lambda-names producer))) (make-let-values
(lambda-body producer) src
(make-application src producer '())) (let ((x (make-application src producer '())))
(lambda-body consumer)))) (or (inline1 x) x))
(lambda-body consumer)))
(else #f))))
(else #f))) (else #f)))
((<let> vars body) ((<let> vars body)
(if (null? vars) body x)) (if (null? vars) body x))
((<letrec> vars body) ((<letrec> vars body)
(if (null? vars) body x)) (if (null? vars) body x))
((<fix> vars body) ((<fix> vars body)
(if (null? vars) body x)) (if (null? vars) body x))
(else #f))) (else #f)))
x)) (post-order! inline1 x))

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

@ -47,14 +47,6 @@
'out)))))) 'out))))))
(define-syntax assert-tree-il->glil (define-syntax assert-tree-il->glil
(syntax-rules ()
((_ in out)
(pass-if 'in
(let ((tree-il (strip-source (parse-tree-il 'in))))
(equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
'out))))))
(define-syntax assert-tree-il->glil/pmatch
(syntax-rules () (syntax-rules ()
((_ in pat test ...) ((_ in pat test ...)
(let ((exp 'in)) (let ((exp 'in))
@ -69,21 +61,21 @@
(with-test-prefix "void" (with-test-prefix "void"
(assert-tree-il->glil (assert-tree-il->glil
(void) (void)
(program () (std-prelude 0 0 #f) (void) (call return 1))) (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (void) (const 1)) (begin (void) (const 1))
(program () (std-prelude 0 0 #f) (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
(apply (primitive +) (void) (const 1)) (apply (primitive +) (void) (const 1))
(program () (std-prelude 0 0 #f) (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"
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (const 1)) (apply (toplevel foo) (const 1))
(program () (std-prelude 0 0 #f) (toplevel ref foo) (const 1) (call goto/args 1))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call goto/args 1)))
(assert-tree-il->glil/pmatch (assert-tree-il->glil
(begin (apply (toplevel foo) (const 1)) (void)) (begin (apply (toplevel foo) (const 1)) (void))
(program () (std-prelude 0 0 #f) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -91,26 +83,26 @@
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar))) (apply (toplevel foo) (apply (toplevel bar)))
(program () (std-prelude 0 0 #f)(toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call goto/args 1)))) (call goto/args 1))))
(with-test-prefix "conditional" (with-test-prefix "conditional"
(assert-tree-il->glil/pmatch (assert-tree-il->glil
(if (const #t) (const 1) (const 2)) (if (const #t) (const 1) (const 2))
(program () (std-prelude 0 0 #f) (const #t) (branch br-if-not ,l1) (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
(const 1) (call return 1) (const 1) (call return 1)
(label ,l2) (const 2) (call return 1)) (label ,l2) (const 2) (call return 1))
(eq? l1 l2)) (eq? l1 l2))
(assert-tree-il->glil/pmatch (assert-tree-il->glil
(begin (if (const #t) (const 1) (const 2)) (const #f)) (begin (if (const #t) (const 1) (const 2)) (const #f))
(program () (std-prelude 0 0 #f) (const #t) (branch br-if-not ,l1) (branch br ,l2) (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1)) (label ,l3) (label ,l4) (const #f) (call return 1))
(eq? l1 l3) (eq? l2 l4)) (eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil/pmatch (assert-tree-il->glil
(apply (primitive null?) (if (const #t) (const 1) (const 2))) (apply (primitive null?) (if (const #t) (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (const #t) (branch br-if-not ,l1) (program () (std-prelude 0 0 #f) (label _) (const #t) (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)
(call null? 1) (call return 1)) (call null? 1) (call return 1))
@ -119,35 +111,35 @@
(with-test-prefix "primitive-ref" (with-test-prefix "primitive-ref"
(assert-tree-il->glil (assert-tree-il->glil
(primitive +) (primitive +)
(program () (std-prelude 0 0 #f) (toplevel ref +) (call return 1))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (primitive +) (const #f)) (begin (primitive +) (const #f))
(program () (std-prelude 0 0 #f) (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
(apply (primitive null?) (primitive +)) (apply (primitive null?) (primitive +))
(program () (std-prelude 0 0 #f) (toplevel ref +) (call null? 1) (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1)))) (call return 1))))
(with-test-prefix "lexical refs" (with-test-prefix "lexical refs"
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y)) (let (x) (y) ((const 1)) (lexical x y))
(program () (std-prelude 0 1 #f) (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 return 1) (lexical #t #f ref 0) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program () (std-prelude 0 1 #f) (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)
(const #f) (call return 1) (const #f) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
(program () (std-prelude 0 1 #f) (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)
(unbind)))) (unbind))))
@ -157,7 +149,7 @@
;; 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) (apply (primitive 1+) (lexical x y)))) (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
(program () (std-prelude 0 1 #f) (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)
(void) (call return 1) (void) (call return 1)
@ -167,7 +159,7 @@
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
(lexical x y))) (lexical x y)))
(program () (std-prelude 0 1 #f) (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)
(lexical #t #t ref 0) (call return 1) (lexical #t #t ref 0) (call return 1)
@ -177,7 +169,7 @@
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(apply (primitive null?) (apply (primitive null?)
(set! (lexical x y) (apply (primitive 1+) (lexical x y))))) (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
(program () (std-prelude 0 1 #f) (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)
(call null? 1) (call return 1) (call null? 1) (call return 1)
@ -186,234 +178,259 @@
(with-test-prefix "module refs" (with-test-prefix "module refs"
(assert-tree-il->glil (assert-tree-il->glil
(@ (foo) bar) (@ (foo) bar)
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar) (module public ref (foo) bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (@ (foo) bar) (const #f)) (begin (@ (foo) bar) (const #f))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar) (call drop 1) (module public ref (foo) bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar)) (apply (primitive null?) (@ (foo) bar))
(program () (std-prelude 0 0 #f) (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)))
(assert-tree-il->glil (assert-tree-il->glil
(@@ (foo) bar) (@@ (foo) bar)
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar) (module private ref (foo) bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (@@ (foo) bar) (const #f)) (begin (@@ (foo) bar) (const #f))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar) (call drop 1) (module private ref (foo) bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar)) (apply (primitive null?) (@@ (foo) bar))
(program () (std-prelude 0 0 #f) (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))))
(with-test-prefix "module sets" (with-test-prefix "module sets"
(assert-tree-il->glil (assert-tree-il->glil
(set! (@ (foo) bar) (const 2)) (set! (@ (foo) bar) (const 2))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f)) (begin (set! (@ (foo) bar) (const 2)) (const #f))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2))) (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (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)))
(assert-tree-il->glil (assert-tree-il->glil
(set! (@@ (foo) bar) (const 2)) (set! (@@ (foo) bar) (const 2))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f)) (begin (set! (@@ (foo) bar) (const 2)) (const #f))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2))) (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (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))))
(with-test-prefix "toplevel refs" (with-test-prefix "toplevel refs"
(assert-tree-il->glil (assert-tree-il->glil
(toplevel bar) (toplevel bar)
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (toplevel ref bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (toplevel bar) (const #f)) (begin (toplevel bar) (const #f))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (call drop 1) (toplevel ref bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (toplevel bar)) (apply (primitive null?) (toplevel bar))
(program () (std-prelude 0 0 #f) (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))))
(with-test-prefix "toplevel sets" (with-test-prefix "toplevel sets"
(assert-tree-il->glil (assert-tree-il->glil
(set! (toplevel bar) (const 2)) (set! (toplevel bar) (const 2))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f)) (begin (set! (toplevel bar) (const 2)) (const #f))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2))) (apply (primitive null?) (set! (toplevel bar) (const 2)))
(program () (std-prelude 0 0 #f) (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))))
(with-test-prefix "toplevel defines" (with-test-prefix "toplevel defines"
(assert-tree-il->glil (assert-tree-il->glil
(define bar (const 2)) (define bar (const 2))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (define bar (const 2)) (const #f)) (begin (define bar (const 2)) (const #f))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (define bar (const 2))) (apply (primitive null?) (define bar (const 2)))
(program () (std-prelude 0 0 #f) (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))))
(with-test-prefix "constants" (with-test-prefix "constants"
(assert-tree-il->glil (assert-tree-il->glil
(const 2) (const 2)
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (call return 1))) (const 2) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (const 2) (const #f)) (begin (const 2) (const #f))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (const 2)) (apply (primitive null?) (const 2))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda" (with-test-prefix "lambda"
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x) (y) () (const 2)) (lambda ()
(program () (std-prelude 0 0 #f) (lambda-case (((x) #f #f #f (y) #f) (const 2)) #f))
(program () (std-prelude 0 0 #f) (label _)
(program () (std-prelude 1 1 #f) (program () (std-prelude 1 1 #f)
(bind (x #f 0)) (bind (x #f 0)) (label _)
(const 2) (call return 1)) (const 2) (call return 1) (unbind))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x x1) (y y1) () (const 2)) (lambda ()
(program () (std-prelude 0 0 #f) (lambda-case (((x y) #f #f #f (x1 y1) #f)
(const 2))
#f))
(program () (std-prelude 0 0 #f) (label _)
(program () (std-prelude 2 2 #f) (program () (std-prelude 2 2 #f)
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (y #f 1)) (label _)
(const 2) (call return 1)) (const 2) (call return 1)
(unbind))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda x y () (const 2)) (lambda ()
(program () (std-prelude 0 0 #f) (lambda-case ((() #f x #f (y) #f) (const 2))
(program () (opt-prelude 0 0 #t 1 #f) #f))
(bind (x #f 0)) (program () (std-prelude 0 0 #f) (label _)
(const 2) (call return 1)) (program () (opt-prelude 0 0 #t 1 #f)
(bind (x #f 0)) (label _)
(const 2) (call return 1)
(unbind))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (const 2)) (lambda ()
(program () (std-prelude 0 0 #f) (lambda-case (((x) #f x1 #f (y y1) #f) (const 2))
#f))
(program () (std-prelude 0 0 #f) (label _)
(program () (opt-prelude 1 0 #t 2 #f) (program () (opt-prelude 1 0 #t 2 #f)
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1)) (label _)
(const 2) (call return 1)) (const 2) (call return 1)
(unbind))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x y)) (lambda ()
(program () (std-prelude 0 0 #f) (lambda-case (((x) #f x1 #f (y y1) #f) (lexical x y))
#f))
(program () (std-prelude 0 0 #f) (label _)
(program () (opt-prelude 1 0 #t 2 #f) (program () (opt-prelude 1 0 #t 2 #f)
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1)) (label _)
(lexical #t #f ref 0) (call return 1)) (lexical #t #f ref 0) (call return 1)
(unbind))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x1 y1)) (lambda ()
(program () (std-prelude 0 0 #f) (lambda-case (((x) #f x1 #f (y y1) #f) (lexical x1 y1))
#f))
(program () (std-prelude 0 0 #f) (label _)
(program () (opt-prelude 1 0 #t 2 #f) (program () (opt-prelude 1 0 #t 2 #f)
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1)) (label _)
(lexical #t #f ref 1) (call return 1)) (lexical #t #f ref 1) (call return 1)
(unbind))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) (lambda ()
(program () (std-prelude 0 0 #f) (lambda-case (((x) #f #f #f (x1) #f)
(program () (std-prelude 1 1 #f) (lambda ()
(bind (x #f 0)) (lambda-case (((y) #f #f #f (y1) #f)
(lexical x x1))
#f)))
#f))
(program () (std-prelude 0 0 #f) (label _)
(program () (std-prelude 1 1 #f)
(bind (x #f 0)) (label _)
(program () (std-prelude 1 1 #f) (program () (std-prelude 1 1 #f)
(bind (y #f 0)) (bind (y #f 0)) (label _)
(lexical #f #f ref 0) (call return 1)) (lexical #f #f ref 0) (call return 1)
(unbind))
(lexical #t #f ref 0) (lexical #t #f ref 0)
(call vector 1) (call vector 1)
(call make-closure 2) (call make-closure 2)
(call return 1)) (call return 1)
(unbind))
(call return 1)))) (call return 1))))
(with-test-prefix "sequence" (with-test-prefix "sequence"
(assert-tree-il->glil (assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t)) (begin (begin (const 2) (const #f)) (const #t))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const #t) (call return 1))) (const #t) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2))) (apply (primitive null?) (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler, ;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case ;; and could be tightened in any case
(with-test-prefix "the or hack" (with-test-prefix "the or hack"
(assert-tree-il->glil/pmatch (assert-tree-il->glil
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(if (lexical x y) (if (lexical x y)
(lexical x y) (lexical x y)
(let (a) (b) ((const 2)) (let (a) (b) ((const 2))
(lexical a b)))) (lexical a b))))
(program () (std-prelude 0 1 #f) (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) (branch br-if-not ,l1) (lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
@ -425,13 +442,13 @@
(eq? l1 l2)) (eq? l1 l2))
;; second bound var is unreferenced ;; second bound var is unreferenced
(assert-tree-il->glil/pmatch (assert-tree-il->glil
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(if (lexical x y) (if (lexical x y)
(lexical x y) (lexical x y)
(let (a) (b) ((const 2)) (let (a) (b) ((const 2))
(lexical x y)))) (lexical x y))))
(program () (std-prelude 0 1 #f) (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) (branch br-if-not ,l1) (lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
@ -443,10 +460,10 @@
(with-test-prefix "apply" (with-test-prefix "apply"
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar)) (apply (primitive @apply) (toplevel foo) (toplevel bar))
(program () (std-prelude 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
(assert-tree-il->glil/pmatch (assert-tree-il->glil
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (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 () #f) (unbind) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -454,7 +471,7 @@
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo) (toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1)))) (call goto/args 1))))
@ -462,10 +479,10 @@
(with-test-prefix "call/cc" (with-test-prefix "call/cc"
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo)) (apply (primitive @call-with-current-continuation) (toplevel foo))
(program () (std-prelude 0 0 #f) (toplevel ref foo) (call goto/cc 1))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call goto/cc 1)))
(assert-tree-il->glil/pmatch (assert-tree-il->glil
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
(program () (std-prelude 0 0 #f) (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 () #f) (unbind) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -474,7 +491,7 @@
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar))) (apply (toplevel @call-with-current-continuation) (toplevel bar)))
(program () (std-prelude 0 0 #f) (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo) (toplevel ref foo)
(toplevel ref bar) (call call/cc 1) (toplevel ref bar) (call call/cc 1)
(call goto/args 1)))) (call goto/args 1))))
@ -507,15 +524,18 @@
(1+ y)) (1+ y))
0 0
(parse-tree-il (parse-tree-il
'(lambda (x y) (x1 y1) '(lambda ()
(apply (toplevel +) (lambda-case
(lexical x x1) (((x y) #f #f #f (x1 y1) #f)
(lexical y y1))))))) (apply (toplevel +)
(lexical x x1)
(lexical y y1)))
#f))))))
(and (equal? (map strip-source leaves) (and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1) (list (make-lexical-ref #f 'y 'y1)
(make-lexical-ref #f 'x 'x1) (make-lexical-ref #f 'x 'x1)
(make-toplevel-ref #f '+))) (make-toplevel-ref #f '+)))
(= (length downs) 2) (= (length downs) 3)
(equal? (reverse (map strip-source ups)) (equal? (reverse (map strip-source ups))
(map strip-source downs)))))) (map strip-source downs))))))