[bpt/guile.git] / module / language / tree-il / fix-letrec.scm

;;; transformation of letrec into simpler forms

;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (language tree-il fix-letrec)
  #:use-module (system base syntax)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (language tree-il)
  #:use-module (language tree-il primitives)
  #:export (fix-letrec!))

;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
;; Efficient Implementation of Scheme's Recursive Binding Construct", by
;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.

(define fix-fold
  (make-tree-il-folder unref ref set simple lambda complex))

(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-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 simple-primitive?))
              exps))
    ((<primcall> name args)
     (and (simple-primitive? name)
          ;; FIXME: check arity?
          (and-map (lambda (x)
                     (simple-expression? x bound-vars simple-primitive?))
                   args)))
    (else #f)))

(define (partition-vars x)
  (let-values
      (((unref ref set simple lambda* complex)
        (fix-fold x
                  (lambda (x unref ref set simple lambda* complex)
                    (record-case x
                      ((<lexical-ref> gensym)
                       (values (delq gensym unref)
                               (lset-adjoin eq? ref gensym)
                               set
                               simple
                               lambda*
                               complex))
                      ((<lexical-set> gensym)
                       (values unref
                               ref
                               (lset-adjoin eq? set gensym)
                               simple
                               lambda*
                               complex))
                      ((<letrec> gensyms)
                       (values (append gensyms unref)
                               ref
                               set
                               simple
                               lambda*
                               complex))
                      ((<let> gensyms)
                       (values (append gensyms unref)
                               ref
                               set
                               simple
                               lambda*
                               complex))
                      (else
                       (values unref ref set simple lambda* complex))))
                  (lambda (x unref ref set simple lambda* complex)
                    (record-case x
                      ((<letrec> in-order? (orig-gensyms gensyms) vals)
                       (let lp ((gensyms orig-gensyms) (vals vals)
                                (s '()) (l '()) (c '()))
                         (cond
                          ((null? gensyms)
                           ;; Unreferenced complex 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)
                           ;; See above note about unref and letrec*.
                           (if (and in-order?
                                    (not (lambda? (car vals)))
                                    (not (simple-expression?
                                          (car vals) orig-gensyms
                                          effect+exception-free-primitive?)))
                               (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
                            (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
                           (lp (cdr gensyms) (cdr vals)
                               s l (cons (car gensyms) c))))))
                      ((<let> (orig-gensyms gensyms) vals)
                       ;; The point is to compile let-bound lambdas as
                       ;; efficiently as we do letrec-bound lambdas, so
                       ;; we use the same algorithm for analyzing the
                       ;; gensyms. There is no problem recursing into the
                       ;; bindings after the let, because all variables
                       ;; have been renamed.
                       (let lp ((gensyms orig-gensyms) (vals vals)
                                (s '()) (l '()) (c '()))
                         (cond
                          ((null? gensyms)
                           (values unref
                                   ref
                                   set
                                   (append s simple)
                                   (append l lambda*)
                                   (append c complex)))
                          ((memq (car gensyms) unref)
                           (lp (cdr gensyms) (cdr vals)
                               s l c))
                          ((memq (car gensyms) set)
                           (lp (cdr gensyms) (cdr vals)
                               s l (cons (car gensyms) c)))
                          ((and (lambda? (car vals))
                                (not (memq (car gensyms) set)))
                           (lp (cdr gensyms) (cdr vals)
                               s (cons (car gensyms) l) c))
                          ;; There is no difference between simple and
                          ;; complex, for the purposes of let. Just lump
                          ;; them all into complex.
                          (else
                           (lp (cdr gensyms) (cdr vals)
                               s l (cons (car gensyms) c))))))
                      (else
                       (values unref ref set simple lambda* complex))))
                  '()
                  '()
                  '()
                  '()
                  '()
                  '())))
    (values unref simple lambda* complex)))

(define (fix-letrec! x)
  (let-values (((unref simple lambda* complex) (partition-vars x)))
    (post-order!
     (lambda (x)
       (record-case x

         ;; Sets to unreferenced variables may be replaced by their
         ;; expression, called for effect.
         ((<lexical-set> gensym exp)
          (if (memq gensym unref)
              (make-sequence #f (list exp (make-void #f)))
              x))

         ((<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)
              (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*))
                  (c (lookup complex)))
              ;; Bind "simple" bindings, and locations for complex
              ;; bindings.
              (make-let
               src
               (append (map cadr s) (map cadr c))
               (append (map car s) (map car c))
               (append (map caddr s) (map (lambda (x) (make-void #f)) c))
               ;; Bind lambdas using the fixpoint operator.
               (make-fix
                src (map cadr l) (map car l) (map caddr l)
                (make-sequence
                 src
                 (append
                  ;; The right-hand-sides of the unreferenced
                  ;; bindings, for effect.
                  (map caddr u)
                  (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)))
            (define (lookup set)
              (map (lambda (v) (assq v binds))
                   (lset-intersection eq? gensyms set)))
            (let ((u (lookup unref))
                  (l (lookup lambda*))
                  (c (lookup complex)))
              (make-sequence
               src
               (append
                ;; unreferenced bindings, called for effect.
                (map caddr u)
                (list
                 ;; unassigned lambdas use fix.
                 (make-fix src (map cadr l) (map car l) (map caddr l)
                           ;; and the "complex" bindings.
                           (make-let src (map cadr c) (map car c) (map caddr c)
                                     body))))))))
         
         (else x)))
     x)))

;;; Local Variables:
;;; eval: (put 'record-case 'scheme-indent-function 1)
;;; End:
Commit	Line	Data
c21c89b1 AW	1	;;; transformation of letrec into simpler forms
c21c89b1 AW	2
65ea26c5	3	;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
c21c89b1 AW	4
	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.
	9	;;;;
	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.
	14	;;;;
	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
	18
	19	(define-module (language tree-il fix-letrec)
	20	#:use-module (system base syntax)
80af1168 AW	21	#:use-module (srfi srfi-1)
80af1168 AW	22	#:use-module (srfi srfi-11)
c21c89b1	23	#:use-module (language tree-il)
80af1168	24	#:use-module (language tree-il primitives)
c21c89b1 AW	25	#:export (fix-letrec!))
	26
	27	;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
bc03d89f	28	;; Efficient Implementation of Scheme's Recursive Binding Construct", by
c21c89b1 AW	29	;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
c21c89b1 AW	30
80af1168 AW	31	(define fix-fold
	32	(make-tree-il-folder unref ref set simple lambda complex))
	33
60d4b224	34	(define (simple-expression? x bound-vars simple-primitive?)
80af1168 AW	35	(record-case x
	36	((<void>) #t)
	37	((<const>) #t)
	38	((<lexical-ref> gensym)
	39	(not (memq gensym bound-vars)))
b6d93b11	40	((<conditional> test consequent alternate)
60d4b224 AW	41	(and (simple-expression? test bound-vars simple-primitive?)
	42	(simple-expression? consequent bound-vars simple-primitive?)
	43	(simple-expression? alternate bound-vars simple-primitive?)))
80af1168	44	((<sequence> exps)
60d4b224	45	(and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
80af1168	46	exps))
a881a4ae AW	47	((<primcall> name args)
a881a4ae AW	48	(and (simple-primitive? name)
322a36ce	49	;; FIXME: check arity?
60d4b224 AW	50	(and-map (lambda (x)
60d4b224 AW	51	(simple-expression? x bound-vars simple-primitive?))
80af1168 AW	52	args)))
	53	(else #f)))
	54
	55	(define (partition-vars x)
	56	(let-values
	57	(((unref ref set simple lambda* complex)
	58	(fix-fold x
	59	(lambda (x unref ref set simple lambda* complex)
	60	(record-case x
	61	((<lexical-ref> gensym)
	62	(values (delq gensym unref)
	63	(lset-adjoin eq? ref gensym)
	64	set
	65	simple
	66	lambda*
	67	complex))
	68	((<lexical-set> gensym)
	69	(values unref
	70	ref
	71	(lset-adjoin eq? set gensym)
	72	simple
	73	lambda*
	74	complex))
93f63467 AW	75	((<letrec> gensyms)
93f63467 AW	76	(values (append gensyms unref)
80af1168 AW	77	ref
	78	set
	79	simple
	80	lambda*
	81	complex))
93f63467 AW	82	((<let> gensyms)
93f63467 AW	83	(values (append gensyms unref)
aaae0d5a AW	84	ref
	85	set
	86	simple
	87	lambda*
	88	complex))
80af1168 AW	89	(else
	90	(values unref ref set simple lambda* complex))))
	91	(lambda (x unref ref set simple lambda* complex)
	92	(record-case x
60d4b224	93	((<letrec> in-order? (orig-gensyms gensyms) vals)
93f63467	94	(let lp ((gensyms orig-gensyms) (vals vals)
80af1168 AW	95	(s '()) (l '()) (c '()))
80af1168 AW	96	(cond
93f63467	97	((null? gensyms)
df129795 AW	98	;; Unreferenced complex vars are still
	99	;; complex for letrec*. We need to update
	100	;; our algorithm to "Fixing letrec reloaded"
	101	;; to fix this.
60d4b224 AW	102	(values (if in-order?
	103	(lset-difference eq? unref c)
	104	unref)
80af1168 AW	105	ref
	106	set
	107	(append s simple)
	108	(append l lambda*)
	109	(append c complex)))
93f63467	110	((memq (car gensyms) unref)
60d4b224	111	;; See above note about unref and letrec*.
df129795 AW	112	(if (and in-order?
	113	(not (lambda? (car vals)))
	114	(not (simple-expression?
	115	(car vals) orig-gensyms
	116	effect+exception-free-primitive?)))
60d4b224 AW	117	(lp (cdr gensyms) (cdr vals)
	118	s l (cons (car gensyms) c))
	119	(lp (cdr gensyms) (cdr vals)
	120	s l c)))
93f63467 AW	121	((memq (car gensyms) set)
	122	(lp (cdr gensyms) (cdr vals)
	123	s l (cons (car gensyms) c)))
80af1168	124	((lambda? (car vals))
93f63467 AW	125	(lp (cdr gensyms) (cdr vals)
93f63467 AW	126	s (cons (car gensyms) l) c))
60d4b224 AW	127	((simple-expression?
	128	(car vals) orig-gensyms
	129	(if in-order?
	130	effect+exception-free-primitive?
	131	effect-free-primitive?))
	132	;; For letrec*, we can't consider e.g. `car' to be
	133	;; "simple", as it could raise an exception. Hence
	134	;; effect+exception-free-primitive? above.
93f63467 AW	135	(lp (cdr gensyms) (cdr vals)
93f63467 AW	136	(cons (car gensyms) s) l c))
80af1168	137	(else
93f63467 AW	138	(lp (cdr gensyms) (cdr vals)
	139	s l (cons (car gensyms) c))))))
	140	((<let> (orig-gensyms gensyms) vals)
aaae0d5a AW	141	;; The point is to compile let-bound lambdas as
	142	;; efficiently as we do letrec-bound lambdas, so
	143	;; we use the same algorithm for analyzing the
93f63467	144	;; gensyms. There is no problem recursing into the
aaae0d5a AW	145	;; bindings after the let, because all variables
aaae0d5a AW	146	;; have been renamed.
93f63467	147	(let lp ((gensyms orig-gensyms) (vals vals)
aaae0d5a AW	148	(s '()) (l '()) (c '()))
aaae0d5a AW	149	(cond
93f63467	150	((null? gensyms)
aaae0d5a AW	151	(values unref
	152	ref
	153	set
	154	(append s simple)
	155	(append l lambda*)
	156	(append c complex)))
93f63467 AW	157	((memq (car gensyms) unref)
93f63467 AW	158	(lp (cdr gensyms) (cdr vals)
aaae0d5a	159	s l c))
93f63467 AW	160	((memq (car gensyms) set)
	161	(lp (cdr gensyms) (cdr vals)
	162	s l (cons (car gensyms) c)))
aaae0d5a	163	((and (lambda? (car vals))
93f63467 AW	164	(not (memq (car gensyms) set)))
	165	(lp (cdr gensyms) (cdr vals)
	166	s (cons (car gensyms) l) c))
aaae0d5a AW	167	;; There is no difference between simple and
	168	;; complex, for the purposes of let. Just lump
	169	;; them all into complex.
	170	(else
93f63467 AW	171	(lp (cdr gensyms) (cdr vals)
93f63467 AW	172	s l (cons (car gensyms) c))))))
80af1168 AW	173	(else
	174	(values unref ref set simple lambda* complex))))
	175	'()
	176	'()
	177	'()
	178	'()
	179	'()
	180	'())))
	181	(values unref simple lambda* complex)))
	182
c21c89b1	183	(define (fix-letrec! x)
80af1168 AW	184	(let-values (((unref simple lambda* complex) (partition-vars x)))
	185	(post-order!
	186	(lambda (x)
	187	(record-case x
	188
	189	;; Sets to unreferenced variables may be replaced by their
	190	;; expression, called for effect.
	191	((<lexical-set> gensym exp)
	192	(if (memq gensym unref)
aaae0d5a	193	(make-sequence #f (list exp (make-void #f)))
80af1168 AW	194	x))
80af1168 AW	195
60d4b224	196	((<letrec> src in-order? names gensyms vals body)
df129795 AW	197	(let ((binds (map list gensyms names vals)))
	198	;; The bindings returned by this function need to appear in the same
	199	;; order that they appear in the letrec.
	200	(define (lookup set)
	201	(let lp ((binds binds))
	202	(cond
	203	((null? binds) '())
	204	((memq (caar binds) set)
	205	(cons (car binds) (lp (cdr binds))))
	206	(else (lp (cdr binds))))))
	207	(let ((u (lookup unref))
	208	(s (lookup simple))
	209	(l (lookup lambda*))
	210	(c (lookup complex)))
	211	;; Bind "simple" bindings, and locations for complex
	212	;; bindings.
	213	(make-let
	214	src
	215	(append (map cadr s) (map cadr c))
	216	(append (map car s) (map car c))
	217	(append (map caddr s) (map (lambda (x) (make-void #f)) c))
	218	;; Bind lambdas using the fixpoint operator.
	219	(make-fix
	220	src (map cadr l) (map car l) (map caddr l)
	221	(make-sequence
	222	src
	223	(append
	224	;; The right-hand-sides of the unreferenced
	225	;; bindings, for effect.
	226	(map caddr u)
	227	(cond
	228	((null? c)
	229	;; No complex bindings, just emit the body.
	230	(list body))
	231	(in-order?
	232	;; For letrec*, assign complex bindings in order, then the
	233	;; body.
	234	(append
	235	(map (lambda (c)
	236	(make-lexical-set #f (cadr c) (car c)
	237	(caddr c)))
	238	c)
	239	(list body)))
	240	(else
	241	;; Otherwise for plain letrec, evaluate the the "complex"
	242	;; bindings, in a `let' to indicate that order doesn't
	243	;; matter, and bind to their variables.
	244	(list
	245	(let ((tmps (map (lambda (x) (gensym)) c)))
	246	(make-let
	247	#f (map cadr c) tmps (map caddr c)
	248	(make-sequence
	249	#f
	250	(map (lambda (x tmp)
	251	(make-lexical-set
	252	#f (cadr x) (car x)
	253	(make-lexical-ref #f (cadr x) tmp)))
	254	c tmps))))
	255	body))))))))))
80af1168	256
93f63467 AW	257	((<let> src names gensyms vals body)
93f63467 AW	258	(let ((binds (map list gensyms names vals)))
aaae0d5a AW	259	(define (lookup set)
aaae0d5a AW	260	(map (lambda (v) (assq v binds))
93f63467	261	(lset-intersection eq? gensyms set)))
aaae0d5a AW	262	(let ((u (lookup unref))
	263	(l (lookup lambda*))
	264	(c (lookup complex)))
	265	(make-sequence
	266	src
	267	(append
	268	;; unreferenced bindings, called for effect.
	269	(map caddr u)
	270	(list
	271	;; unassigned lambdas use fix.
	272	(make-fix src (map cadr l) (map car l) (map caddr l)
	273	;; and the "complex" bindings.
	274	(make-let src (map cadr c) (map car c) (map caddr c)
	275	body))))))))
	276
80af1168 AW	277	(else x)))
80af1168 AW	278	x)))
65ea26c5 LC	279
	280	;;; Local Variables:
	281	;;; eval: (put 'record-case 'scheme-indent-function 1)
	282	;;; End: