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