1 ;;; transformation of letrec into simpler forms
3 ;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (language tree-il fix-letrec)
20 #:use-module (system base syntax)
21 #:use-module (srfi srfi-1)
22 #:use-module (srfi srfi-11)
23 #:use-module (language tree-il)
24 #:use-module (language tree-il effects)
25 #:export (fix-letrec))
27 ;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
28 ;; Efficient Implementation of Scheme's Recursive Binding Construct", by
29 ;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
32 (make-tree-il-folder unref ref set simple lambda complex))
34 (define (simple-expression? x bound-vars simple-primcall?)
38 ((<lexical-ref> gensym)
39 (not (memq gensym bound-vars)))
40 ((<conditional> test consequent alternate)
41 (and (simple-expression? test bound-vars simple-primcall?)
42 (simple-expression? consequent bound-vars simple-primcall?)
43 (simple-expression? alternate bound-vars simple-primcall?)))
45 (and (simple-expression? head bound-vars simple-primcall?)
46 (simple-expression? tail bound-vars simple-primcall?)))
47 ((<primcall> name args)
48 (and (simple-primcall? x)
50 (simple-expression? x bound-vars simple-primcall?))
54 (define (partition-vars x)
56 (((unref ref set simple lambda* complex)
58 (lambda (x unref ref set simple lambda* complex)
60 ((<lexical-ref> gensym)
61 (values (delq gensym unref)
62 (lset-adjoin eq? ref gensym)
67 ((<lexical-set> gensym)
70 (lset-adjoin eq? set gensym)
75 (values (append gensyms unref)
82 (values (append gensyms unref)
89 (values unref ref set simple lambda* complex))))
90 (lambda (x unref ref set simple lambda* complex)
92 ((<letrec> in-order? (orig-gensyms gensyms) vals)
93 (define compute-effects
94 (make-effects-analyzer (lambda (x) (memq x set))))
95 (define (effect-free-primcall? x)
96 (let ((effects (compute-effects x)))
98 (exclude-effects effects (logior &allocation
100 (define (effect+exception-free-primcall? x)
101 (let ((effects (compute-effects x)))
103 (exclude-effects effects &allocation))))
104 (let lp ((gensyms orig-gensyms) (vals vals)
105 (s '()) (l '()) (c '()))
108 ;; Unreferenced complex vars are still
109 ;; complex for letrec*. We need to update
110 ;; our algorithm to "Fixing letrec reloaded"
112 (values (if in-order?
113 (lset-difference eq? unref c)
120 ((memq (car gensyms) unref)
121 ;; See above note about unref and letrec*.
123 (not (lambda? (car vals)))
124 (not (simple-expression?
125 (car vals) orig-gensyms
126 effect+exception-free-primcall?)))
127 (lp (cdr gensyms) (cdr vals)
128 s l (cons (car gensyms) c))
129 (lp (cdr gensyms) (cdr vals)
131 ((memq (car gensyms) set)
132 (lp (cdr gensyms) (cdr vals)
133 s l (cons (car gensyms) c)))
134 ((lambda? (car vals))
135 (lp (cdr gensyms) (cdr vals)
136 s (cons (car gensyms) l) c))
138 (car vals) orig-gensyms
140 effect+exception-free-primcall?
141 effect-free-primcall?))
142 ;; For letrec*, we can't consider e.g. `car' to be
143 ;; "simple", as it could raise an exception. Hence
144 ;; effect+exception-free-primitive? above.
145 (lp (cdr gensyms) (cdr vals)
146 (cons (car gensyms) s) l c))
148 (lp (cdr gensyms) (cdr vals)
149 s l (cons (car gensyms) c))))))
150 ((<let> (orig-gensyms gensyms) vals)
151 ;; The point is to compile let-bound lambdas as
152 ;; efficiently as we do letrec-bound lambdas, so
153 ;; we use the same algorithm for analyzing the
154 ;; gensyms. There is no problem recursing into the
155 ;; bindings after the let, because all variables
156 ;; have been renamed.
157 (let lp ((gensyms orig-gensyms) (vals vals)
158 (s '()) (l '()) (c '()))
167 ((memq (car gensyms) unref)
168 (lp (cdr gensyms) (cdr vals)
170 ((memq (car gensyms) set)
171 (lp (cdr gensyms) (cdr vals)
172 s l (cons (car gensyms) c)))
173 ((and (lambda? (car vals))
174 (not (memq (car gensyms) set)))
175 (lp (cdr gensyms) (cdr vals)
176 s (cons (car gensyms) l) c))
177 ;; There is no difference between simple and
178 ;; complex, for the purposes of let. Just lump
179 ;; them all into complex.
181 (lp (cdr gensyms) (cdr vals)
182 s l (cons (car gensyms) c))))))
184 (values unref ref set simple lambda* complex))))
191 (values unref simple lambda* complex)))
193 (define (make-seq* src head tail)
197 ((<lexical-ref>) tail)
199 (else (make-seq src head tail))))
201 (define (list->seq* loc exps)
202 (if (null? (cdr exps))
204 (let lp ((exps (cdr exps)) (effects (list (car exps))))
205 (if (null? (cdr exps))
207 (fold (lambda (exp tail) (make-seq* #f exp tail))
211 (lp (cdr exps) (cons (car exps) effects))))))
213 (define (fix-letrec x)
214 (let-values (((unref simple lambda* complex) (partition-vars x)))
219 ;; Sets to unreferenced variables may be replaced by their
220 ;; expression, called for effect.
221 ((<lexical-set> gensym exp)
222 (if (memq gensym unref)
223 (make-seq* #f exp (make-void #f))
226 ((<letrec> src in-order? names gensyms vals body)
227 (let ((binds (map list gensyms names vals)))
228 ;; The bindings returned by this function need to appear in the same
229 ;; order that they appear in the letrec.
231 (let lp ((binds binds))
234 ((memq (caar binds) set)
235 (cons (car binds) (lp (cdr binds))))
236 (else (lp (cdr binds))))))
237 (let ((u (lookup unref))
240 (c (lookup complex)))
241 ;; Bind "simple" bindings, and locations for complex
245 (append (map cadr s) (map cadr c))
246 (append (map car s) (map car c))
247 (append (map caddr s) (map (lambda (x) (make-void #f)) c))
248 ;; Bind lambdas using the fixpoint operator.
250 src (map cadr l) (map car l) (map caddr l)
254 ;; The right-hand-sides of the unreferenced
255 ;; bindings, for effect.
259 ;; No complex bindings, just emit the body.
262 ;; For letrec*, assign complex bindings in order, then the
266 (make-lexical-set #f (cadr c) (car c)
271 ;; Otherwise for plain letrec, evaluate the "complex"
272 ;; bindings, in a `let' to indicate that order doesn't
273 ;; matter, and bind to their variables.
275 (let ((tmps (map (lambda (x) (gensym)) c)))
277 #f (map cadr c) tmps (map caddr c)
283 (make-lexical-ref #f (cadr x) tmp)))
287 ((<let> src names gensyms vals body)
288 (let ((binds (map list gensyms names vals)))
290 (map (lambda (v) (assq v binds))
291 (lset-intersection eq? gensyms set)))
292 (let ((u (lookup unref))
294 (c (lookup complex)))
298 ;; unreferenced bindings, called for effect.
301 ;; unassigned lambdas use fix.
302 (make-fix src (map cadr l) (map car l) (map caddr l)
303 ;; and the "complex" bindings.
304 (make-let src (map cadr c) (map car c) (map caddr c)
311 ;;; eval: (put 'record-case 'scheme-indent-function 1)