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

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) (comp-tail body)
(emit-code #f (make-glil-unbind))) (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) (for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self) (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n) ((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n))) (emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc)))) (,loc (error "badness" x loc))))
gensyms) 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) (emit-bindings src names gensyms allocation self emit-code)
(for-each (lambda (v) (cond
(pmatch (hashq-ref (hashq-ref allocation v) self) (in-order?
((#t #t . ,n) ;; For letrec*, bind values in order.
(emit-code src (make-glil-lexical #t #t 'set n))) (for-each (lambda (name v val)
(,loc (error "badness" x loc)))) (pmatch (hashq-ref (hashq-ref allocation v) self)
(reverse gensyms)) ((#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) (comp-tail body)
(emit-code #f (make-glil-unbind))) (emit-code #f (make-glil-unbind)))

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

@ -31,24 +31,25 @@
(define fix-fold (define fix-fold
(make-tree-il-folder unref ref set simple lambda complex)) (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 (record-case x
((<void>) #t) ((<void>) #t)
((<const>) #t) ((<const>) #t)
((<lexical-ref> gensym) ((<lexical-ref> gensym)
(not (memq gensym bound-vars))) (not (memq gensym bound-vars)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
(and (simple-expression? test bound-vars) (and (simple-expression? test bound-vars simple-primitive?)
(simple-expression? consequent bound-vars) (simple-expression? consequent bound-vars simple-primitive?)
(simple-expression? alternate bound-vars))) (simple-expression? alternate bound-vars simple-primitive?)))
((<sequence> exps) ((<sequence> exps)
(and-map (lambda (x) (simple-expression? x bound-vars)) (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
exps)) exps))
((<application> proc args) ((<application> proc args)
(and (primitive-ref? proc) (and (primitive-ref? proc)
(effect-free-primitive? (primitive-ref-name proc)) (simple-primitive? (primitive-ref-name proc))
;; FIXME: check arity? ;; FIXME: check arity?
(and-map (lambda (x) (simple-expression? x bound-vars)) (and-map (lambda (x)
(simple-expression? x bound-vars simple-primitive?))
args))) args)))
(else #f))) (else #f)))
@ -90,27 +91,43 @@
(values unref ref set simple lambda* complex)))) (values unref ref set simple lambda* complex))))
(lambda (x unref ref set simple lambda* complex) (lambda (x unref ref set simple lambda* complex)
(record-case x (record-case x
((<letrec> (orig-gensyms gensyms) vals) ((<letrec> in-order? (orig-gensyms gensyms) vals)
(let lp ((gensyms orig-gensyms) (vals vals) (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '())) (s '()) (l '()) (c '()))
(cond (cond
((null? gensyms) ((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 ref
set set
(append s simple) (append s simple)
(append l lambda*) (append l lambda*)
(append c complex))) (append c complex)))
((memq (car gensyms) unref) ((memq (car gensyms) unref)
(lp (cdr gensyms) (cdr vals) ;; See above note about unref and letrec*.
s l c)) (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) ((memq (car gensyms) set)
(lp (cdr gensyms) (cdr vals) (lp (cdr gensyms) (cdr vals)
s l (cons (car gensyms) c))) s l (cons (car gensyms) c)))
((lambda? (car vals)) ((lambda? (car vals))
(lp (cdr gensyms) (cdr vals) (lp (cdr gensyms) (cdr vals)
s (cons (car gensyms) l) c)) 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) (lp (cdr gensyms) (cdr vals)
(cons (car gensyms) s) l c)) (cons (car gensyms) s) l c))
(else (else
@ -172,11 +189,17 @@
(make-sequence #f (list exp (make-void #f))) (make-sequence #f (list exp (make-void #f)))
x)) x))
((<letrec> src names gensyms vals body) ((<letrec> src in-order? names gensyms vals body)
(let ((binds (map list gensyms names vals))) (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) (define (lookup set)
(map (lambda (v) (assq v binds)) (let lp ((binds binds))
(lset-intersection eq? gensyms set))) (cond
((null? binds) '())
((memq (caar binds) set)
(cons (car binds) (lp (cdr binds))))
(else (lp (cdr binds))))))
(let ((u (lookup unref)) (let ((u (lookup unref))
(s (lookup simple)) (s (lookup simple))
(l (lookup lambda*)) (l (lookup lambda*))
@ -197,25 +220,34 @@
;; The right-hand-sides of the unreferenced ;; The right-hand-sides of the unreferenced
;; bindings, for effect. ;; bindings, for effect.
(map caddr u) (map caddr u)
(if (null? c) (cond
;; No complex bindings, just emit the body. ((null? c)
(list body) ;; No complex bindings, just emit the body.
(list (list body))
;; Evaluate the the "complex" bindings, in a `let' to (in-order?
;; indicate that order doesn't matter, and bind to ;; For letrec*, assign complex bindings in order, then the
;; their variables. ;; body.
(let ((tmps (map (lambda (x) (gensym)) c))) (append
(make-let (map (lambda (c)
#f (map cadr c) tmps (map caddr c) (make-lexical-set #f (cadr c) (car c) (caddr c)))
(make-sequence c)
#f (list body)))
(map (lambda (x tmp) (else
(make-lexical-set ;; Otherwise for plain letrec, evaluate the the "complex"
#f (cadr x) (car x) ;; bindings, in a `let' to indicate that order doesn't
(make-lexical-ref #f (cadr x) tmp))) ;; matter, and bind to their variables.
c tmps)))) (list
;; Finally, the body. (let ((tmps (map (lambda (x) (gensym)) c)))
body))))))))) (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> src names gensyms vals body)
(let ((binds (map list gensyms names vals))) (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 _) (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 "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" (with-test-prefix "lambda"
(assert-tree-il->glil (assert-tree-il->glil
(lambda () (lambda ()