mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
tree-il support for case-lambda
* 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
parent
c783b0827c
commit
8a4ca0ea3b
7 changed files with 4825 additions and 4531 deletions
File diff suppressed because it is too large
Load diff
|
|
@ -448,17 +448,66 @@
|
|||
((@ (language tree-il) make-toplevel-define) source var exp))
|
||||
(else (decorate-source `(define ,var ,exp) source)))))
|
||||
|
||||
(define build-lambda
|
||||
(lambda (src ids vars docstring exp)
|
||||
;; Ideally we would have all lambdas be case lambdas, but that would
|
||||
;; 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*)
|
||||
((c) ((@ (language tree-il) make-lambda) src ids vars
|
||||
((c) ((@ (language tree-il) make-lambda) src
|
||||
(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
|
||||
`(lambda ,vars ,@(if docstring (list docstring) '())
|
||||
,exp)
|
||||
`(lambda ,(if rest (apply cons* vars) vars)
|
||||
,@(if docstring (list docstring) '())
|
||||
,exp)
|
||||
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
|
||||
(lambda (src name)
|
||||
(if (equal? (module-name (current-module)) '(guile))
|
||||
|
|
@ -506,7 +555,7 @@
|
|||
(ids (cdr ids)))
|
||||
(case (fluid-ref *mode*)
|
||||
((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)
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
((@ (language tree-il) make-letrec) src
|
||||
|
|
@ -1455,48 +1504,6 @@
|
|||
(cons (cons er (source-wrap e w s mod))
|
||||
(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
|
||||
(lambda (rec? e r w s mod k)
|
||||
(syntax-case e ()
|
||||
|
|
@ -1574,6 +1581,7 @@
|
|||
(let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
|
||||
(build-lexical-var no-source id))))
|
||||
|
||||
;; appears to return a reversed list
|
||||
(define lambda-var-list
|
||||
(lambda (vars)
|
||||
(let lvl ((vars vars) (ls '()) (w empty-wrap))
|
||||
|
|
@ -1777,7 +1785,10 @@
|
|||
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
|
||||
((primitive) (build-primref 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
|
||||
(build-primref no-source (car x))
|
||||
(map regen (cdr x)))))))
|
||||
|
|
@ -1794,11 +1805,55 @@
|
|||
|
||||
(global-extend 'core 'lambda
|
||||
(lambda (e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ . c)
|
||||
(chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
|
||||
(lambda (names vars docstring body)
|
||||
(build-lambda s names vars docstring body)))))))
|
||||
(define (docstring&body ids vars labels c)
|
||||
(syntax-case c ()
|
||||
((docstring e1 e2 ...)
|
||||
(string? (syntax->datum (syntax docstring)))
|
||||
(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
|
||||
|
|
@ -1975,7 +2030,7 @@
|
|||
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
|
||||
(build-application no-source
|
||||
(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
|
||||
(extend-env
|
||||
labels
|
||||
|
|
@ -2002,7 +2057,7 @@
|
|||
(let ((y (gen-var 'tmp)))
|
||||
; fat finger binding and references to temp variable y
|
||||
(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
|
||||
'tmp y)))
|
||||
(build-conditional no-source
|
||||
|
|
@ -2039,16 +2094,16 @@
|
|||
(let ((labels (list (gen-label)))
|
||||
(var (gen-var (syntax pat))))
|
||||
(build-application no-source
|
||||
(build-lambda no-source
|
||||
(list (syntax->datum (syntax pat))) (list var)
|
||||
#f
|
||||
(chi (syntax exp)
|
||||
(extend-env labels
|
||||
(list (make-binding 'syntax `(,var . 0)))
|
||||
r)
|
||||
(make-binding-wrap (syntax (pat))
|
||||
labels empty-wrap)
|
||||
mod))
|
||||
(build-simple-lambda
|
||||
no-source (list (syntax->datum (syntax pat))) #f (list var)
|
||||
#f
|
||||
(chi (syntax exp)
|
||||
(extend-env labels
|
||||
(list (make-binding 'syntax `(,var . 0)))
|
||||
r)
|
||||
(make-binding-wrap (syntax (pat))
|
||||
labels empty-wrap)
|
||||
mod))
|
||||
(list x)))
|
||||
(gen-clause x keys (cdr clauses) r
|
||||
(syntax pat) #t (syntax exp) mod)))
|
||||
|
|
@ -2067,7 +2122,7 @@
|
|||
(let ((x (gen-var 'tmp)))
|
||||
; fat finger binding and references to temp variable x
|
||||
(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
|
||||
'tmp x)
|
||||
(syntax (key ...)) (syntax (m ...))
|
||||
|
|
|
|||
|
|
@ -36,11 +36,14 @@
|
|||
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
|
||||
<application> application? make-application application-src application-proc application-args
|
||||
<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
|
||||
<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
|
||||
<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
|
||||
unparse-tree-il
|
||||
|
|
@ -65,11 +68,12 @@
|
|||
(<conditional> test then else)
|
||||
(<application> proc args)
|
||||
(<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)
|
||||
(<letrec> 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))
|
||||
(make-toplevel-define loc name (retrans exp)))
|
||||
|
||||
((lambda ,names ,vars ,exp)
|
||||
(make-lambda loc names vars '() (retrans exp)))
|
||||
((lambda ,meta ,body)
|
||||
(make-lambda loc meta (retrans body)))
|
||||
|
||||
((lambda ,names ,vars ,meta ,exp)
|
||||
(make-lambda loc names vars meta (retrans exp)))
|
||||
((lambda-case ((,req ,opt ,rest ,kw ,vars ,predicate) ,body) ,else)
|
||||
(make-lambda-case loc req opt rest kw vars
|
||||
(and=> predicate retrans)
|
||||
(retrans body)
|
||||
(and=> else retrans)))
|
||||
|
||||
((const ,exp)
|
||||
(make-const loc exp))
|
||||
|
|
@ -148,8 +155,8 @@
|
|||
((fix ,names ,vars ,vals ,body)
|
||||
(make-fix loc names vars (map retrans vals) (retrans body)))
|
||||
|
||||
((let-values ,names ,vars ,exp ,body)
|
||||
(make-let-values loc names vars (retrans exp) (retrans body)))
|
||||
((let-values ,exp ,body)
|
||||
(make-let-values loc (retrans exp) (retrans body)))
|
||||
|
||||
(else
|
||||
(error "unrecognized tree-il" exp)))))
|
||||
|
|
@ -189,8 +196,13 @@
|
|||
((<toplevel-define> name exp)
|
||||
`(define ,name ,(unparse-tree-il exp)))
|
||||
|
||||
((<lambda> names vars meta body)
|
||||
`(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
|
||||
((<lambda> meta 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))
|
||||
|
|
@ -207,8 +219,8 @@
|
|||
((<fix> names vars vals body)
|
||||
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
|
||||
|
||||
((<let-values> names vars exp body)
|
||||
`(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
|
||||
((<let-values> exp body)
|
||||
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
|
||||
|
||||
(define (tree-il->scheme e)
|
||||
(record-case e
|
||||
|
|
@ -247,10 +259,31 @@
|
|||
((<toplevel-define> name exp)
|
||||
`(define ,name ,(tree-il->scheme exp)))
|
||||
|
||||
((<lambda> vars meta body)
|
||||
`(lambda ,vars
|
||||
,@(cond ((assq-ref meta 'documentation) => list) (else '()))
|
||||
,(tree-il->scheme body)))
|
||||
((<lambda> meta body)
|
||||
;; fixme: put in docstring
|
||||
(if (and (lambda-case? 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)
|
||||
(if (and (self-evaluating? exp) (not (vector? exp)))
|
||||
|
|
@ -272,7 +305,7 @@
|
|||
|
||||
((<let-values> vars exp body)
|
||||
`(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)
|
||||
|
|
@ -306,6 +339,15 @@ This is an implementation of `foldts' as described by Andy Wingo in
|
|||
(up tree (loop exps (down tree result))))
|
||||
((<lambda> body)
|
||||
(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)
|
||||
(up tree (loop body
|
||||
(loop vals
|
||||
|
|
@ -357,6 +399,18 @@ This is an implementation of `foldts' as described by Andy Wingo in
|
|||
(fold-values foldts exps seed ...))
|
||||
((<lambda> body)
|
||||
(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*-values (((seed ...) (fold-values foldts vals seed ...)))
|
||||
(foldts body seed ...)))
|
||||
|
|
@ -397,9 +451,16 @@ This is an implementation of `foldts' as described by Andy Wingo in
|
|||
((<toplevel-define> name exp)
|
||||
(set! (toplevel-define-exp x) (lp exp)))
|
||||
|
||||
((<lambda> vars meta body)
|
||||
((<lambda> 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)
|
||||
(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-body x) (lp body)))
|
||||
|
||||
((<let-values> vars exp body)
|
||||
((<let-values> exp body)
|
||||
(set! (let-values-exp x) (lp exp))
|
||||
(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)
|
||||
(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)
|
||||
(set! (sequence-exps x) (map lp exps)))
|
||||
|
||||
|
|
|
|||
|
|
@ -112,13 +112,20 @@
|
|||
;; translated into labels, and information on what free variables to
|
||||
;; 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:
|
||||
;;
|
||||
;; sym -> {lambda -> address}
|
||||
;; lambda -> (nlocs labels . free-locs)
|
||||
;; lambda -> (labels . free-locs)
|
||||
;; lambda-case -> (gensym . nlocs)
|
||||
;;
|
||||
;; address ::= (local? boxed? . index)
|
||||
;; labels ::= ((sym . lambda-vars) ...)
|
||||
;; labels ::= ((sym . lambda) ...)
|
||||
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
|
||||
;; free variable addresses are relative to parent proc.
|
||||
|
||||
|
|
@ -141,9 +148,9 @@
|
|||
;; refcounts: sym -> count
|
||||
;; allows us to detect the or-expansion in O(1) time
|
||||
(define refcounts (make-hash-table))
|
||||
;; labels: sym -> lambda-vars
|
||||
;; labels: sym -> lambda
|
||||
;; for determining if fixed-point procedures can be rendered as
|
||||
;; labels. lambda-vars may be an improper list.
|
||||
;; labels.
|
||||
(define labels (make-hash-table))
|
||||
|
||||
;; returns variables referenced in expr
|
||||
|
|
@ -167,9 +174,21 @@
|
|||
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
|
||||
(if (not (and tail-call-args
|
||||
(memq gensym labels-in-proc)
|
||||
(let ((args (hashq-ref labels gensym)))
|
||||
(and (list? args)
|
||||
(= (length args) (length tail-call-args))))))
|
||||
(let ((p (hashq-ref labels gensym)))
|
||||
(and p
|
||||
(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))
|
||||
(list gensym))
|
||||
|
||||
|
|
@ -195,19 +214,24 @@
|
|||
(else
|
||||
(lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
|
||||
|
||||
((<lambda> vars body)
|
||||
(let ((locally-bound (let rev* ((vars vars) (out '()))
|
||||
(cond ((null? vars) out)
|
||||
((pair? vars) (rev* (cdr vars)
|
||||
(cons (car vars) out)))
|
||||
(else (cons vars out))))))
|
||||
(hashq-set! bound-vars x locally-bound)
|
||||
(let* ((referenced (recur body x))
|
||||
(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)))
|
||||
((<lambda> body)
|
||||
;; order is important here
|
||||
(hashq-set! bound-vars x '())
|
||||
(let ((free (recur body x)))
|
||||
(hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
|
||||
(hashq-set! free-vars x free)
|
||||
free))
|
||||
|
||||
((<lambda-case> vars predicate body else)
|
||||
(hashq-set! bound-vars proc
|
||||
(append (reverse vars) (hashq-ref bound-vars proc)))
|
||||
(lset-union
|
||||
eq?
|
||||
(lset-difference eq?
|
||||
(lset-union eq? (if predicate (step predicate) '())
|
||||
(step-tail body))
|
||||
vars)
|
||||
(if else (step-tail else) '())))
|
||||
|
||||
((<let> vars vals body)
|
||||
(hashq-set! bound-vars proc
|
||||
|
|
@ -226,7 +250,7 @@
|
|||
|
||||
((<fix> vars vals body)
|
||||
;; 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)
|
||||
(hashq-set! bound-vars proc
|
||||
(append (reverse vars) (hashq-ref bound-vars proc)))
|
||||
|
|
@ -240,21 +264,14 @@
|
|||
;; prevent label allocation.)
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
((<lambda> (lvars vars) body)
|
||||
(let ((locally-bound
|
||||
(let rev* ((lvars lvars) (out '()))
|
||||
(cond ((null? lvars) out)
|
||||
((pair? lvars) (rev* (cdr lvars)
|
||||
(cons (car lvars) out)))
|
||||
(else (cons lvars out))))))
|
||||
(hashq-set! bound-vars x locally-bound)
|
||||
;; 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)))))
|
||||
((<lambda> body)
|
||||
;; just like the closure case, except here we use
|
||||
;; recur/labels instead of recur
|
||||
(hashq-set! bound-vars x '())
|
||||
(let ((free (recur/labels body x vars)))
|
||||
(hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
|
||||
(hashq-set! free-vars x free)
|
||||
free))))
|
||||
vals))
|
||||
(vars-with-refs (map cons vars var-refs))
|
||||
(body-refs (recur/labels body proc vars)))
|
||||
|
|
@ -302,15 +319,8 @@
|
|||
(apply lset-union eq? body-refs var-refs)
|
||||
vars)))
|
||||
|
||||
((<let-values> vars exp body)
|
||||
(let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
|
||||
(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)))
|
||||
((<let-values> exp body)
|
||||
(lset-union eq? (step exp) (step body)))
|
||||
|
||||
(else '())))
|
||||
|
||||
|
|
@ -342,7 +352,7 @@
|
|||
((<sequence> exps)
|
||||
(apply max (map recur exps)))
|
||||
|
||||
((<lambda> vars body)
|
||||
((<lambda> body)
|
||||
;; allocate closure vars in order
|
||||
(let lp ((c (hashq-ref free-vars x)) (n 0))
|
||||
(if (pair? c)
|
||||
|
|
@ -352,18 +362,7 @@
|
|||
`(#f ,(hashq-ref assigned (car c)) . ,n))
|
||||
(lp (cdr c) (1+ n)))))
|
||||
|
||||
(let ((nlocs
|
||||
(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))))
|
||||
(let ((nlocs (allocate! body x 0))
|
||||
(free-addresses
|
||||
(map (lambda (v)
|
||||
(hashq-ref (hashq-ref allocation v) proc))
|
||||
|
|
@ -373,9 +372,25 @@
|
|||
(cons sym (hashq-ref labels sym)))
|
||||
(hashq-ref bound-vars x)))))
|
||||
;; set procedure allocations
|
||||
(hashq-set! allocation x (cons* nlocs labels free-addresses)))
|
||||
(hashq-set! allocation x (cons labels free-addresses)))
|
||||
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 ((nmax (apply max (map recur vals))))
|
||||
(cond
|
||||
|
|
@ -427,22 +442,12 @@
|
|||
((null? vars)
|
||||
(max nmax (allocate! body proc n)))
|
||||
((hashq-ref labels (car vars))
|
||||
;; allocate label bindings & body inline to proc
|
||||
;; allocate lambda body inline to proc
|
||||
(lp (cdr vars)
|
||||
(cdr vals)
|
||||
(record-case (car vals)
|
||||
((<lambda> vars body)
|
||||
(let lp ((vars vars) (n 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))))))))
|
||||
((<lambda> body)
|
||||
(max nmax (allocate! body proc n))))))
|
||||
(else
|
||||
;; allocate closure
|
||||
(lp (cdr vars)
|
||||
|
|
@ -461,25 +466,8 @@
|
|||
(hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
|
||||
(lp (cdr in) (1+ n))))))))
|
||||
|
||||
((<let-values> vars exp body)
|
||||
(let ((nmax (recur exp)))
|
||||
(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))))))))
|
||||
((<let-values> exp body)
|
||||
(max (recur exp) (recur body)))
|
||||
|
||||
(else n)))
|
||||
|
||||
|
|
@ -504,21 +492,10 @@
|
|||
(refs binding-info-refs) ;; (GENSYM ...)
|
||||
(locs binding-info-locs)) ;; (LOCATION ...)
|
||||
|
||||
;; FIXME!!
|
||||
(define (report-unused-variables tree env)
|
||||
"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)
|
||||
;; X is a leaf: extend INFO's refs accordingly.
|
||||
(let ((refs (binding-info-refs info))
|
||||
|
|
@ -546,9 +523,9 @@
|
|||
((<lexical-set> gensym)
|
||||
(make-binding-info vars (cons gensym refs)
|
||||
(cons src locs)))
|
||||
((<lambda> vars names)
|
||||
(let ((vars (dotless-list vars))
|
||||
(names (dotless-list names)))
|
||||
((<lambda-case> req opt rest kw vars)
|
||||
;; FIXME keywords.
|
||||
(let ((names `(,@req ,@(or opt '()) . ,(or rest '()))))
|
||||
(make-binding-info (extend vars names) refs
|
||||
(cons src locs))))
|
||||
((<let> vars names)
|
||||
|
|
@ -560,9 +537,6 @@
|
|||
((<fix> vars names)
|
||||
(make-binding-info (extend vars names) refs
|
||||
(cons src locs)))
|
||||
((<let-values> vars names)
|
||||
(make-binding-info (extend vars names) refs
|
||||
(cons src locs)))
|
||||
(else info))))
|
||||
|
||||
(lambda (x info)
|
||||
|
|
@ -577,7 +551,7 @@
|
|||
;; Don't report lambda parameters as
|
||||
;; unused.
|
||||
(if (and (not (memq gensym refs))
|
||||
(not (and (lambda? x)
|
||||
(not (and (lambda-case? x)
|
||||
(memq gensym
|
||||
inner-vars))))
|
||||
(let ((name (cadr var))
|
||||
|
|
@ -597,10 +571,9 @@
|
|||
;; It doesn't hurt as these are unique names, it just
|
||||
;; makes REFS unnecessarily fat.
|
||||
(record-case x
|
||||
((<lambda> vars)
|
||||
(let ((vars (dotless-list vars)))
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs))))
|
||||
((<lambda-case> vars)
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs)))
|
||||
((<let> vars)
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs)))
|
||||
|
|
@ -610,9 +583,6 @@
|
|||
((<fix> vars)
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs)))
|
||||
((<let-values> vars)
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs)))
|
||||
(else info))))
|
||||
(make-binding-info '() '() '())
|
||||
tree)
|
||||
|
|
|
|||
|
|
@ -32,9 +32,11 @@
|
|||
|
||||
;; allocation:
|
||||
;; 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 variable addresses are relative to parent proc.
|
||||
|
||||
|
|
@ -56,7 +58,8 @@
|
|||
(warn x e))))
|
||||
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))
|
||||
(allocation (analyze-lexicals x)))
|
||||
|
||||
|
|
@ -173,47 +176,21 @@
|
|||
(reverse out)))
|
||||
|
||||
(define (flatten-lambda x self-label allocation)
|
||||
(receive (ids vars nargs nrest)
|
||||
(let lp ((ids (lambda-names x)) (vars (lambda-vars x))
|
||||
(oids '()) (ovars '()) (n 0))
|
||||
(cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
|
||||
((pair? vars) (lp (cdr ids) (cdr vars)
|
||||
(cons (car ids) oids) (cons (car vars) ovars)
|
||||
(1+ n)))
|
||||
(else (values (reverse (cons ids oids))
|
||||
(reverse (cons vars ovars))
|
||||
(1+ n) 1))))
|
||||
(let ((nlocs (car (hashq-ref allocation x)))
|
||||
(labels (cadr (hashq-ref allocation x))))
|
||||
(make-glil-program
|
||||
(lambda-meta x)
|
||||
(with-output-to-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)))))))
|
||||
(record-case x
|
||||
((<lambda> src meta body)
|
||||
(make-glil-program
|
||||
meta
|
||||
(with-output-to-code
|
||||
(lambda (emit-code)
|
||||
;; write source info for proc
|
||||
(if src (emit-code #f (make-glil-source src)))
|
||||
;; emit pre-prelude label for self tail calls in which the
|
||||
;; number of arguments doesn't check out at compile time
|
||||
(if self-label
|
||||
(emit-code #f (make-glil-label self-label)))
|
||||
;; compile the body, yo
|
||||
(flatten body allocation x self-label (car (hashq-ref allocation x))
|
||||
emit-code)))))))
|
||||
|
||||
(define (flatten x allocation self self-label fix-labels emit-code)
|
||||
(define (emit-label label)
|
||||
|
|
@ -410,43 +387,78 @@
|
|||
(error "bad primitive op: too many pushes"
|
||||
op (instruction-pushes op))))))
|
||||
|
||||
;; da capo al fine
|
||||
;; self-call in tail position
|
||||
((and (lexical-ref? proc)
|
||||
self-label (eq? (lexical-ref-gensym proc) self-label)
|
||||
;; self-call in tail position is a goto
|
||||
(eq? context 'tail)
|
||||
;; make sure the arity is right
|
||||
(list? (lambda-vars self))
|
||||
(= (length args) (length (lambda-vars self))))
|
||||
;; evaluate new values
|
||||
(eq? context 'tail))
|
||||
;; first, evaluate new values, pushing them on the stack
|
||||
(for-each comp-push args)
|
||||
;; rename & goto
|
||||
(for-each (lambda (sym)
|
||||
(pmatch (hashq-ref (hashq-ref allocation sym) self)
|
||||
((#t ,boxed? . ,index)
|
||||
;; set unboxed, as the proc prelude will box if needed
|
||||
(emit-code #f (make-glil-lexical #t #f 'set index)))
|
||||
(,x (error "what" x))))
|
||||
(reverse (lambda-vars self)))
|
||||
(emit-branch src 'br self-label))
|
||||
(let lp ((lcase (lambda-body self)))
|
||||
(cond
|
||||
((and (lambda-case? lcase)
|
||||
(not (lambda-case-kw lcase))
|
||||
(not (lambda-case-opt lcase))
|
||||
(not (lambda-case-rest lcase))
|
||||
(= (length args) (length (lambda-case-req lcase))))
|
||||
;; we have a case that matches the args; rename variables
|
||||
;; 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
|
||||
((and (lexical-ref? proc)
|
||||
(assq (lexical-ref-gensym proc) fix-labels))
|
||||
;; evaluate new values, assuming that analyze-lexicals did its
|
||||
;; job, and that the arity was right
|
||||
;; like the self-tail-call case, though we can handle "drop"
|
||||
;; contexts too. first, evaluate new values, pushing them on
|
||||
;; the stack
|
||||
(for-each comp-push args)
|
||||
;; rename
|
||||
(for-each (lambda (sym)
|
||||
(pmatch (hashq-ref (hashq-ref allocation sym) self)
|
||||
((#t #f . ,index)
|
||||
(emit-code #f (make-glil-lexical #t #f 'set index)))
|
||||
((#t #t . ,index)
|
||||
(emit-code #f (make-glil-lexical #t #t 'box index)))
|
||||
(,x (error "what" x))))
|
||||
(reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
|
||||
;; goto!
|
||||
(emit-branch src 'br (lexical-ref-gensym proc)))
|
||||
;; find the specific case, rename args, and goto the case label
|
||||
(let lp ((lcase (lambda-body
|
||||
(assq-ref fix-labels (lexical-ref-gensym proc)))))
|
||||
(cond
|
||||
((and (lambda-case? lcase)
|
||||
(not (lambda-case-kw lcase))
|
||||
(not (lambda-case-opt lcase))
|
||||
(not (lambda-case-rest lcase))
|
||||
(= (length args) (length (lambda-case-req lcase))))
|
||||
;; we have a case that matches the args; rename variables
|
||||
;; 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
|
||||
(if (not (eq? context 'tail))
|
||||
|
|
@ -570,7 +582,7 @@
|
|||
(maybe-emit-return))
|
||||
|
||||
((<lambda>)
|
||||
(let ((free-locs (cddr (hashq-ref allocation x))))
|
||||
(let ((free-locs (cdr (hashq-ref allocation x))))
|
||||
(case context
|
||||
((push vals tail)
|
||||
(emit-code #f (flatten-lambda x #f allocation))
|
||||
|
|
@ -587,6 +599,44 @@
|
|||
(emit-code #f (make-glil-call 'make-closure 2)))))))
|
||||
(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)
|
||||
(for-each comp-push vals)
|
||||
(emit-bindings src names vars allocation self emit-code)
|
||||
|
|
@ -637,7 +687,7 @@
|
|||
((hashq-ref allocation x)
|
||||
;; allocating a closure
|
||||
(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
|
||||
;; free-variables vector, so we are mutating fresh
|
||||
;; closures on the heap.
|
||||
|
|
@ -652,15 +702,19 @@
|
|||
;; labels allocation: emit label & body, but jump over it
|
||||
(let ((POST (make-label)))
|
||||
(emit-branch #f 'br POST)
|
||||
(emit-label v)
|
||||
;; we know the lambda vars are a list
|
||||
(emit-bindings #f (lambda-names x) (lambda-vars x)
|
||||
allocation self emit-code)
|
||||
(if (lambda-src x)
|
||||
(emit-code #f (make-glil-source (lambda-src x))))
|
||||
(comp-fix (lambda-body x) (or RA new-RA))
|
||||
(emit-code #f (make-glil-unbind))
|
||||
(emit-label POST)))))
|
||||
(let lp ((lcase (lambda-body x)))
|
||||
(if lcase
|
||||
(record-case lcase
|
||||
((<lambda-case> src req vars body else)
|
||||
(emit-label (car (hashq-ref allocation lcase)))
|
||||
;; FIXME: opt & kw args in the bindings
|
||||
(emit-bindings #f req vars allocation self emit-code)
|
||||
(if src
|
||||
(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
|
||||
vars)
|
||||
;; Emit bindings metadata for closures
|
||||
|
|
@ -677,7 +731,7 @@
|
|||
(for-each
|
||||
(lambda (x v)
|
||||
(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
|
||||
'())))
|
||||
(if (not (null? free-locs))
|
||||
|
|
@ -701,31 +755,27 @@
|
|||
(emit-label new-RA))
|
||||
(emit-code #f (make-glil-unbind))))
|
||||
|
||||
((<let-values> src names vars exp body)
|
||||
(let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
|
||||
(cond
|
||||
((pair? inames)
|
||||
(lp (cons (car inames) names) (cons (car ivars) vars)
|
||||
(cdr inames) (cdr ivars) #f))
|
||||
((not (null? inames))
|
||||
(lp (cons inames names) (cons ivars vars) '() '() #t))
|
||||
(else
|
||||
(let ((names (reverse! names))
|
||||
(vars (reverse! vars))
|
||||
(MV (make-label)))
|
||||
(comp-vals exp MV)
|
||||
(emit-code #f (make-glil-const 1))
|
||||
(emit-label MV)
|
||||
(emit-code src (make-glil-mv-bind
|
||||
(vars->bind-list names vars allocation self)
|
||||
rest?))
|
||||
(for-each (lambda (v)
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) self)
|
||||
((#t #f . ,n)
|
||||
(emit-code src (make-glil-lexical #t #f 'set n)))
|
||||
((#t #t . ,n)
|
||||
(emit-code src (make-glil-lexical #t #t 'box n)))
|
||||
(,loc (error "badness" x loc))))
|
||||
(reverse vars))
|
||||
(comp-tail body)
|
||||
(emit-code #f (make-glil-unbind))))))))))
|
||||
((<let-values> src exp body)
|
||||
(record-case body
|
||||
((<lambda-case> req opt kw rest vars predicate body else)
|
||||
(if (or opt kw predicate else)
|
||||
(error "unexpected lambda-case in let-values" x))
|
||||
(let ((MV (make-label)))
|
||||
(comp-vals exp MV)
|
||||
(emit-code #f (make-glil-const 1))
|
||||
(emit-label MV)
|
||||
(emit-code src (make-glil-mv-bind
|
||||
(vars->bind-list
|
||||
(append req (if rest (list rest) '()))
|
||||
vars allocation self)
|
||||
(and rest #t)))
|
||||
(for-each (lambda (v)
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) self)
|
||||
((#t #f . ,n)
|
||||
(emit-code src (make-glil-lexical #t #f 'set n)))
|
||||
((#t #t . ,n)
|
||||
(emit-code src (make-glil-lexical #t #t 'box n)))
|
||||
(,loc (error "badness" x loc))))
|
||||
(reverse vars))
|
||||
(comp-tail body)
|
||||
(emit-code #f (make-glil-unbind)))))))))
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@
|
|||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
(define-module (language tree-il inline)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (language tree-il)
|
||||
#:export (inline!))
|
||||
|
|
@ -34,16 +35,20 @@
|
|||
;; This is a completely brain-dead optimization pass whose sole claim to
|
||||
;; fame is ((lambda () x)) => x.
|
||||
(define (inline! x)
|
||||
(post-order!
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
((<application> src proc args)
|
||||
(cond
|
||||
|
||||
;; ((lambda () x)) => x
|
||||
((and (lambda? proc) (null? (lambda-vars proc))
|
||||
(null? args))
|
||||
(lambda-body proc))
|
||||
(define (inline1 x)
|
||||
(record-case x
|
||||
((<application> src proc args)
|
||||
(record-case proc
|
||||
;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
|
||||
((<lambda> body)
|
||||
(let lp ((lcase body))
|
||||
(and lcase
|
||||
(record-case lcase
|
||||
((<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))
|
||||
;; => (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 Scheme's let-values expands into call-with-values,
|
||||
;; then here we reduce it to tree-il's let-values.
|
||||
((and (primitive-ref? proc)
|
||||
(eq? (primitive-ref-name proc) '@call-with-values)
|
||||
(= (length args) 2)
|
||||
(lambda? (cadr args)))
|
||||
(let ((producer (car args))
|
||||
(consumer (cadr args)))
|
||||
(make-let-values src
|
||||
(lambda-names consumer)
|
||||
(lambda-vars consumer)
|
||||
(if (and (lambda? producer)
|
||||
(null? (lambda-names producer)))
|
||||
(lambda-body producer)
|
||||
(make-application src producer '()))
|
||||
(lambda-body consumer))))
|
||||
((<primitive-ref> name)
|
||||
(and (eq? name '@call-with-values)
|
||||
(pmatch args
|
||||
((,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-predicate (lambda-body consumer)))
|
||||
(not (lambda-case-else (lambda-body consumer))))
|
||||
(make-let-values
|
||||
src
|
||||
(let ((x (make-application src producer '())))
|
||||
(or (inline1 x) x))
|
||||
(lambda-body consumer)))
|
||||
(else #f))))
|
||||
|
||||
(else #f)))
|
||||
|
||||
((<let> vars body)
|
||||
(if (null? vars) body x))
|
||||
((<let> vars body)
|
||||
(if (null? vars) body x))
|
||||
|
||||
((<letrec> vars body)
|
||||
(if (null? vars) body x))
|
||||
((<letrec> vars body)
|
||||
(if (null? vars) body x))
|
||||
|
||||
((<fix> vars body)
|
||||
(if (null? vars) body x))
|
||||
((<fix> vars body)
|
||||
(if (null? vars) body x))
|
||||
|
||||
(else #f)))
|
||||
x))
|
||||
(else #f)))
|
||||
(post-order! inline1 x))
|
||||
|
|
|
|||
|
|
@ -47,14 +47,6 @@
|
|||
'out))))))
|
||||
|
||||
(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 ()
|
||||
((_ in pat test ...)
|
||||
(let ((exp 'in))
|
||||
|
|
@ -69,21 +61,21 @@
|
|||
(with-test-prefix "void"
|
||||
(assert-tree-il->glil
|
||||
(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
|
||||
(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
|
||||
(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"
|
||||
(assert-tree-il->glil
|
||||
(apply (toplevel foo) (const 1))
|
||||
(program () (std-prelude 0 0 #f) (toplevel ref foo) (const 1) (call goto/args 1)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call goto/args 1)))
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -91,26 +83,26 @@
|
|||
(and (eq? l1 l3) (eq? l2 l4)))
|
||||
(assert-tree-il->glil
|
||||
(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))))
|
||||
|
||||
(with-test-prefix "conditional"
|
||||
(assert-tree-il->glil/pmatch
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(label ,l2) (const 2) (call return 1))
|
||||
(eq? l1 l2))
|
||||
|
||||
(assert-tree-il->glil/pmatch
|
||||
(assert-tree-il->glil
|
||||
(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))
|
||||
(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)))
|
||||
(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)
|
||||
(label ,l3) (const 2) (label ,l4)
|
||||
(call null? 1) (call return 1))
|
||||
|
|
@ -119,35 +111,35 @@
|
|||
(with-test-prefix "primitive-ref"
|
||||
(assert-tree-il->glil
|
||||
(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
|
||||
(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
|
||||
(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))))
|
||||
|
||||
(with-test-prefix "lexical refs"
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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 #f) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(lexical #t #f ref 0) (call null? 1) (call return 1)
|
||||
(unbind))))
|
||||
|
|
@ -157,7 +149,7 @@
|
|||
;; unreferenced sets may be optimized away -- make sure they are ref'd
|
||||
(let (x) (y) ((const 1))
|
||||
(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)
|
||||
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
|
||||
(void) (call return 1)
|
||||
|
|
@ -167,7 +159,7 @@
|
|||
(let (x) (y) ((const 1))
|
||||
(begin (set! (lexical x y) (apply (primitive 1+) (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)
|
||||
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
|
||||
(lexical #t #t ref 0) (call return 1)
|
||||
|
|
@ -177,7 +169,7 @@
|
|||
(let (x) (y) ((const 1))
|
||||
(apply (primitive null?)
|
||||
(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)
|
||||
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
|
||||
(call null? 1) (call return 1)
|
||||
|
|
@ -186,234 +178,259 @@
|
|||
(with-test-prefix "module refs"
|
||||
(assert-tree-il->glil
|
||||
(@ (foo) bar)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(module public ref (foo) bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (@ (foo) bar))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(module public ref (foo) bar)
|
||||
(call null? 1) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(@@ (foo) bar)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(module private ref (foo) bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (@@ (foo) bar))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(module private ref (foo) bar)
|
||||
(call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "module sets"
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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 #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(void) (call null? 1) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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 #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(void) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "toplevel refs"
|
||||
(assert-tree-il->glil
|
||||
(toplevel bar)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(toplevel ref bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (toplevel bar) (const #f))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(toplevel ref bar) (call drop 1)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (toplevel bar))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(toplevel ref bar)
|
||||
(call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "toplevel sets"
|
||||
(assert-tree-il->glil
|
||||
(set! (toplevel bar) (const 2))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(const 2) (toplevel set bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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 #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(void) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "toplevel defines"
|
||||
(assert-tree-il->glil
|
||||
(define bar (const 2))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(const 2) (toplevel define bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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 #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(void) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "constants"
|
||||
(assert-tree-il->glil
|
||||
(const 2)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(const 2) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (const 2) (const #f))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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))))
|
||||
|
||||
(with-test-prefix "lambda"
|
||||
(assert-tree-il->glil
|
||||
(lambda (x) (y) () (const 2))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(lambda ()
|
||||
(lambda-case (((x) #f #f #f (y) #f) (const 2)) #f))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(program () (std-prelude 1 1 #f)
|
||||
(bind (x #f 0))
|
||||
(const 2) (call return 1))
|
||||
(bind (x #f 0)) (label _)
|
||||
(const 2) (call return 1) (unbind))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x x1) (y y1) () (const 2))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(lambda ()
|
||||
(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)
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(const 2) (call return 1))
|
||||
(bind (x #f 0) (y #f 1)) (label _)
|
||||
(const 2) (call return 1)
|
||||
(unbind))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda x y () (const 2))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (opt-prelude 0 0 #t 1 #f)
|
||||
(bind (x #f 0))
|
||||
(const 2) (call return 1))
|
||||
(lambda ()
|
||||
(lambda-case ((() #f x #f (y) #f) (const 2))
|
||||
#f))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(program () (opt-prelude 0 0 #t 1 #f)
|
||||
(bind (x #f 0)) (label _)
|
||||
(const 2) (call return 1)
|
||||
(unbind))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (const 2))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(lambda ()
|
||||
(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)
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(const 2) (call return 1))
|
||||
(bind (x #f 0) (x1 #f 1)) (label _)
|
||||
(const 2) (call return 1)
|
||||
(unbind))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (lexical x y))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(lambda ()
|
||||
(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)
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(lexical #t #f ref 0) (call return 1))
|
||||
(bind (x #f 0) (x1 #f 1)) (label _)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(unbind))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (lexical x1 y1))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(lambda ()
|
||||
(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)
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(lexical #t #f ref 1) (call return 1))
|
||||
(bind (x #f 0) (x1 #f 1)) (label _)
|
||||
(lexical #t #f ref 1) (call return 1)
|
||||
(unbind))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 1 1 #f)
|
||||
(bind (x #f 0))
|
||||
(lambda ()
|
||||
(lambda-case (((x) #f #f #f (x1) #f)
|
||||
(lambda ()
|
||||
(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)
|
||||
(bind (y #f 0))
|
||||
(lexical #f #f ref 0) (call return 1))
|
||||
(bind (y #f 0)) (label _)
|
||||
(lexical #f #f ref 0) (call return 1)
|
||||
(unbind))
|
||||
(lexical #t #f ref 0)
|
||||
(call vector 1)
|
||||
(call make-closure 2)
|
||||
(call return 1))
|
||||
(call return 1)
|
||||
(unbind))
|
||||
(call return 1))))
|
||||
|
||||
(with-test-prefix "sequence"
|
||||
(assert-tree-il->glil
|
||||
(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)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(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))))
|
||||
|
||||
;; FIXME: binding info for or-hacked locals might bork the disassembler,
|
||||
;; and could be tightened in any case
|
||||
(with-test-prefix "the or hack"
|
||||
(assert-tree-il->glil/pmatch
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1))
|
||||
(if (lexical x y)
|
||||
(lexical x y)
|
||||
(let (a) (b) ((const 2))
|
||||
(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)
|
||||
(lexical #t #f ref 0) (branch br-if-not ,l1)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
|
|
@ -425,13 +442,13 @@
|
|||
(eq? l1 l2))
|
||||
|
||||
;; second bound var is unreferenced
|
||||
(assert-tree-il->glil/pmatch
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1))
|
||||
(if (lexical x y)
|
||||
(lexical x y)
|
||||
(let (a) (b) ((const 2))
|
||||
(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)
|
||||
(lexical #t #f ref 0) (branch br-if-not ,l1)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
|
|
@ -443,10 +460,10 @@
|
|||
(with-test-prefix "apply"
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive @apply) (toplevel foo) (toplevel bar))
|
||||
(program () (std-prelude 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
|
||||
(assert-tree-il->glil
|
||||
(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 drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -454,7 +471,7 @@
|
|||
(and (eq? l1 l3) (eq? l2 l4)))
|
||||
(assert-tree-il->glil
|
||||
(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)
|
||||
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
|
||||
(call goto/args 1))))
|
||||
|
|
@ -462,10 +479,10 @@
|
|||
(with-test-prefix "call/cc"
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive @call-with-current-continuation) (toplevel foo))
|
||||
(program () (std-prelude 0 0 #f) (toplevel ref foo) (call goto/cc 1)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call goto/cc 1)))
|
||||
(assert-tree-il->glil
|
||||
(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 drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -474,7 +491,7 @@
|
|||
(assert-tree-il->glil
|
||||
(apply (toplevel foo)
|
||||
(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 bar) (call call/cc 1)
|
||||
(call goto/args 1))))
|
||||
|
|
@ -507,15 +524,18 @@
|
|||
(1+ y))
|
||||
0
|
||||
(parse-tree-il
|
||||
'(lambda (x y) (x1 y1)
|
||||
(apply (toplevel +)
|
||||
(lexical x x1)
|
||||
(lexical y y1)))))))
|
||||
'(lambda ()
|
||||
(lambda-case
|
||||
(((x y) #f #f #f (x1 y1) #f)
|
||||
(apply (toplevel +)
|
||||
(lexical x x1)
|
||||
(lexical y y1)))
|
||||
#f))))))
|
||||
(and (equal? (map strip-source leaves)
|
||||
(list (make-lexical-ref #f 'y 'y1)
|
||||
(make-lexical-ref #f 'x 'x1)
|
||||
(make-toplevel-ref #f '+)))
|
||||
(= (length downs) 2)
|
||||
(= (length downs) 3)
|
||||
(equal? (reverse (map strip-source ups))
|
||||
(map strip-source downs))))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue