mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

compiler support for letrec*

Browse source 
* test-suite/tests/tree-il.test ("letrec"): Add some tests.
* module/language/tree-il/compile-glil.scm (flatten): Add support for
  compiling letrec* in its unoptimized form.

* module/language/tree-il/fix-letrec.scm (simple-expression?):
  Parameterize, so that letrec* will not treat `(car x)' as primitive
  (because it could raise an exception).
  (partition-vars): Lump unreferenced vars in with complex vars, when
  compiling letrec*.
  (fix-letrec!): No need to evaluate inits within a let for letrec*.
This commit is contained in:
Andy Wingo 2010-06-17 12:47:46 +02:00
parent 4ee781a688
commit 60d4b22448
3 changed files with 134 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -778,21 +778,35 @@
(comp-tail body)
(emit-code #f (make-glil-unbind)))
((<letrec> src names gensyms vals body)
((<letrec> src in-order? names gensyms vals body)
;; First prepare heap storage slots.
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc))))
gensyms)
(for-each comp-push vals)
;; Even though the slots are empty, the bindings are valid.
(emit-bindings src names gensyms allocation self emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
(reverse gensyms))
(cond
(in-order?
;; For letrec*, bind values in order.
(for-each (lambda (name v val)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(comp-push val)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
names gensyms vals))
(else
;; But for letrec, eval all values, then bind.
(for-each comp-push vals)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
(reverse gensyms))))
(comp-tail body)
(emit-code #f (make-glil-unbind)))

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

@ -31,24 +31,25 @@
(define fix-fold
(make-tree-il-folder unref ref set simple lambda complex))
(define (simple-expression? x bound-vars)
(define (simple-expression? x bound-vars simple-primitive?)
(record-case x
((<void>) #t)
((<const>) #t)
((<lexical-ref> gensym)
(not (memq gensym bound-vars)))
((<conditional> test consequent alternate)
(and (simple-expression? test bound-vars)
(simple-expression? consequent bound-vars)
(simple-expression? alternate bound-vars)))
(and (simple-expression? test bound-vars simple-primitive?)
(simple-expression? consequent bound-vars simple-primitive?)
(simple-expression? alternate bound-vars simple-primitive?)))
((<sequence> exps)
(and-map (lambda (x) (simple-expression? x bound-vars))
(and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
exps))
((<application> proc args)
(and (primitive-ref? proc)
(effect-free-primitive? (primitive-ref-name proc))
(simple-primitive? (primitive-ref-name proc))
;; FIXME: check arity?
(and-map (lambda (x) (simple-expression? x bound-vars))
(and-map (lambda (x)
(simple-expression? x bound-vars simple-primitive?))
args)))
(else #f)))
@ -90,27 +91,43 @@
(values unref ref set simple lambda* complex))))
(lambda (x unref ref set simple lambda* complex)
(record-case x
((<letrec> (orig-gensyms gensyms) vals)
((<letrec> in-order? (orig-gensyms gensyms) vals)
(let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
((null? gensyms)
(values unref
;; Unreferenced vars are still complex for letrec*.
;; We need to update our algorithm to "Fixing letrec
;; reloaded" to fix this.
(values (if in-order?
(lset-difference eq? unref c)
unref)
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
((memq (car gensyms) unref)
(lp (cdr gensyms) (cdr vals)
s l c))
;; See above note about unref and letrec*.
(if in-order?
(lp (cdr gensyms) (cdr vals)
s l (cons (car gensyms) c))
(lp (cdr gensyms) (cdr vals)
s l c)))
((memq (car gensyms) set)
(lp (cdr gensyms) (cdr vals)
s l (cons (car gensyms) c)))
((lambda? (car vals))
(lp (cdr gensyms) (cdr vals)
s (cons (car gensyms) l) c))
((simple-expression? (car vals) orig-gensyms)
((simple-expression?
(car vals) orig-gensyms
(if in-order?
effect+exception-free-primitive?
effect-free-primitive?))
;; For letrec*, we can't consider e.g. `car' to be
;; "simple", as it could raise an exception. Hence
;; effect+exception-free-primitive? above.
(lp (cdr gensyms) (cdr vals)
(cons (car gensyms) s) l c))
(else
@ -172,11 +189,17 @@
(make-sequence #f (list exp (make-void #f)))
x))
((<letrec> src names gensyms vals body)
((<letrec> src in-order? names gensyms vals body)
(let ((binds (map list gensyms names vals)))
;; The bindings returned by this function need to appear in the same
;; order that they appear in the letrec.
(define (lookup set)
(map (lambda (v) (assq v binds))
(lset-intersection eq? gensyms set)))
(let lp ((binds binds))
(cond
((null? binds) '())
((memq (caar binds) set)
(cons (car binds) (lp (cdr binds))))
(else (lp (cdr binds))))))
(let ((u (lookup unref))
(s (lookup simple))
(l (lookup lambda*))
@ -197,25 +220,34 @@
;; The right-hand-sides of the unreferenced
;; bindings, for effect.
(map caddr u)
(if (null? c)
;; No complex bindings, just emit the body.
(list body)
(list
;; Evaluate the the "complex" bindings, in a `let' to
;; indicate that order doesn't matter, and bind to
;; their variables.
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(make-sequence
#f
(map (lambda (x tmp)
(make-lexical-set
#f (cadr x) (car x)
(make-lexical-ref #f (cadr x) tmp)))
c tmps))))
;; Finally, the body.
body)))))))))
(cond
((null? c)
;; No complex bindings, just emit the body.
(list body))
(in-order?
;; For letrec*, assign complex bindings in order, then the
;; body.
(append
(map (lambda (c)
(make-lexical-set #f (cadr c) (car c) (caddr c)))
c)
(list body)))
(else
;; Otherwise for plain letrec, evaluate the the "complex"
;; bindings, in a `let' to indicate that order doesn't
;; matter, and bind to their variables.
(list
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(make-sequence
#f
(map (lambda (x tmp)
(make-lexical-set
#f (cadr x) (car x)
(make-lexical-ref #f (cadr x) tmp)))
c tmps))))
body))))))))))
((<let> src names gensyms vals body)
(let ((binds (map list gensyms names vals)))

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

@ -319,6 +319,52 @@
(program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
(with-test-prefix "letrec"
;; simple bindings -> let
(assert-tree-il->glil
(letrec (x y) (x1 y1) ((const 10) (const 20))
(apply (toplevel foo) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(const 10) (const 20)
(bind (x #f 0) (y #f 1))
(lexical #t #f set 1) (lexical #t #f set 0)
(toplevel ref foo)
(lexical #t #f ref 0) (lexical #t #f ref 1)
(call tail-call 2)
(unbind)))
;; complex bindings -> box and set! within let
(assert-tree-il->glil
(letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
(apply (primitive +) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
(lexical #t #t box 1) (lexical #t #t box 0)
(call new-frame 0) (toplevel ref foo) (call call 0)
(call new-frame 0) (toplevel ref bar) (call call 0)
(bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
(lexical #t #f ref 2) (lexical #t #t set 0)
(lexical #t #f ref 3) (lexical #t #t set 1) (unbind)
(lexical #t #t ref 0) (lexical #t #t ref 1)
(call add 2) (call return 1) (unbind)))
;; complex bindings in letrec* -> box and set! in order
(assert-tree-il->glil
(letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
(apply (primitive +) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
(lexical #t #t box 1) (lexical #t #t box 0)
(call new-frame 0) (toplevel ref foo) (call call 0)
(lexical #t #t set 0)
(call new-frame 0) (toplevel ref bar) (call call 0)
(lexical #t #t set 1)
(lexical #t #t ref 0)
(lexical #t #t ref 1)
(call add 2) (call return 1) (unbind))))
(with-test-prefix "lambda"
(assert-tree-il->glil
(lambda ()