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

;;; transformation of letrec into simpler forms

;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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 effects)
  #: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-primcall?)
  (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-primcall?)
          (simple-expression? consequent bound-vars simple-primcall?)
          (simple-expression? alternate bound-vars simple-primcall?)))
    ((<seq> head tail)
     (and (simple-expression? head bound-vars simple-primcall?)
          (simple-expression? tail bound-vars simple-primcall?)))
    ((<primcall> name args)
     (and (simple-primcall? x)
          (and-map (lambda (x)
                     (simple-expression? x bound-vars simple-primcall?))
                   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)
                       (define compute-effects
                         (make-effects-analyzer (lambda (x) (memq x set))))
                       (define (effect-free-primcall? x)
                         (let ((effects (compute-effects x)))
                           (effect-free?
                            (exclude-effects effects (logior &allocation
                                                             &type-check)))))
                       (define (effect+exception-free-primcall? x)
                         (let ((effects (compute-effects x)))
                           (effect-free?
                            (exclude-effects effects &allocation))))
                       (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-primcall?)))
                               (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-primcall?
                                effect-free-primcall?))
                           ;; 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 (make-seq* src head tail)
  (record-case head
    ((<lambda>) tail)
    ((<const>) tail)
    ((<lexical-ref>) tail)
    ((<void>) tail)
    (else (make-seq src head tail))))

(define (list->seq* loc exps)
  (if (null? (cdr exps))
      (car exps)
      (let lp ((exps (cdr exps)) (effects (list (car exps))))
        (if (null? (cdr exps))
            (make-seq* loc
                       (fold (lambda (exp tail) (make-seq* #f exp tail))
                             (car effects)
                             (cdr effects))
                       (car exps))
            (lp (cdr exps) (cons (car exps) effects))))))

(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-seq* #f 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)
                (list->seq*
                 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 "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)
                        (list->seq
                         #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)))
              (list->seq*
               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
403d78f9	3	;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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)
b8a5606b	24	#:use-module (language tree-il effects)
403d78f9	25	#:export (fix-letrec))
c21c89b1 AW	26
c21c89b1 AW	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
b8a5606b	34	(define (simple-expression? x bound-vars simple-primcall?)
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)
b8a5606b AW	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?)))
6fc3eae4	44	((<seq> head tail)
2aed2667 AW	45	(and (simple-expression? head bound-vars simple-primcall?)
2aed2667 AW	46	(simple-expression? tail bound-vars simple-primcall?)))
a881a4ae	47	((<primcall> name args)
2aed2667	48	(and (simple-primcall? x)
60d4b224	49	(and-map (lambda (x)
b8a5606b	50	(simple-expression? x bound-vars simple-primcall?))
80af1168 AW	51	args)))
	52	(else #f)))
	53
	54	(define (partition-vars x)
	55	(let-values
	56	(((unref ref set simple lambda* complex)
	57	(fix-fold x
	58	(lambda (x unref ref set simple lambda* complex)
	59	(record-case x
	60	((<lexical-ref> gensym)
	61	(values (delq gensym unref)
	62	(lset-adjoin eq? ref gensym)
	63	set
	64	simple
	65	lambda*
	66	complex))
	67	((<lexical-set> gensym)
	68	(values unref
	69	ref
	70	(lset-adjoin eq? set gensym)
	71	simple
	72	lambda*
	73	complex))
93f63467 AW	74	((<letrec> gensyms)
93f63467 AW	75	(values (append gensyms unref)
80af1168 AW	76	ref
	77	set
	78	simple
	79	lambda*
	80	complex))
93f63467 AW	81	((<let> gensyms)
93f63467 AW	82	(values (append gensyms unref)
aaae0d5a AW	83	ref
	84	set
	85	simple
	86	lambda*
	87	complex))
80af1168 AW	88	(else
	89	(values unref ref set simple lambda* complex))))
	90	(lambda (x unref ref set simple lambda* complex)
	91	(record-case x
60d4b224	92	((<letrec> in-order? (orig-gensyms gensyms) vals)
b8a5606b AW	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)))
	97	(effect-free?
	98	(exclude-effects effects (logior &allocation
	99	&type-check)))))
	100	(define (effect+exception-free-primcall? x)
	101	(let ((effects (compute-effects x)))
	102	(effect-free?
	103	(exclude-effects effects &allocation))))
93f63467	104	(let lp ((gensyms orig-gensyms) (vals vals)
80af1168 AW	105	(s '()) (l '()) (c '()))
80af1168 AW	106	(cond
93f63467	107	((null? gensyms)
df129795 AW	108	;; Unreferenced complex vars are still
	109	;; complex for letrec*. We need to update
	110	;; our algorithm to "Fixing letrec reloaded"
	111	;; to fix this.
60d4b224 AW	112	(values (if in-order?
	113	(lset-difference eq? unref c)
	114	unref)
80af1168 AW	115	ref
	116	set
	117	(append s simple)
	118	(append l lambda*)
	119	(append c complex)))
93f63467	120	((memq (car gensyms) unref)
60d4b224	121	;; See above note about unref and letrec*.
df129795 AW	122	(if (and in-order?
	123	(not (lambda? (car vals)))
	124	(not (simple-expression?
	125	(car vals) orig-gensyms
b8a5606b	126	effect+exception-free-primcall?)))
60d4b224 AW	127	(lp (cdr gensyms) (cdr vals)
	128	s l (cons (car gensyms) c))
	129	(lp (cdr gensyms) (cdr vals)
	130	s l c)))
93f63467 AW	131	((memq (car gensyms) set)
	132	(lp (cdr gensyms) (cdr vals)
	133	s l (cons (car gensyms) c)))
80af1168	134	((lambda? (car vals))
93f63467 AW	135	(lp (cdr gensyms) (cdr vals)
93f63467 AW	136	s (cons (car gensyms) l) c))
60d4b224 AW	137	((simple-expression?
	138	(car vals) orig-gensyms
	139	(if in-order?
b8a5606b AW	140	effect+exception-free-primcall?
b8a5606b AW	141	effect-free-primcall?))
60d4b224 AW	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.
93f63467 AW	145	(lp (cdr gensyms) (cdr vals)
93f63467 AW	146	(cons (car gensyms) s) l c))
80af1168	147	(else
93f63467 AW	148	(lp (cdr gensyms) (cdr vals)
	149	s l (cons (car gensyms) c))))))
	150	((<let> (orig-gensyms gensyms) vals)
aaae0d5a AW	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
93f63467	154	;; gensyms. There is no problem recursing into the
aaae0d5a AW	155	;; bindings after the let, because all variables
aaae0d5a AW	156	;; have been renamed.
93f63467	157	(let lp ((gensyms orig-gensyms) (vals vals)
aaae0d5a AW	158	(s '()) (l '()) (c '()))
aaae0d5a AW	159	(cond
93f63467	160	((null? gensyms)
aaae0d5a AW	161	(values unref
	162	ref
	163	set
	164	(append s simple)
	165	(append l lambda*)
	166	(append c complex)))
93f63467 AW	167	((memq (car gensyms) unref)
93f63467 AW	168	(lp (cdr gensyms) (cdr vals)
aaae0d5a	169	s l c))
93f63467 AW	170	((memq (car gensyms) set)
	171	(lp (cdr gensyms) (cdr vals)
	172	s l (cons (car gensyms) c)))
aaae0d5a	173	((and (lambda? (car vals))
93f63467 AW	174	(not (memq (car gensyms) set)))
	175	(lp (cdr gensyms) (cdr vals)
	176	s (cons (car gensyms) l) c))
aaae0d5a AW	177	;; There is no difference between simple and
	178	;; complex, for the purposes of let. Just lump
	179	;; them all into complex.
	180	(else
93f63467 AW	181	(lp (cdr gensyms) (cdr vals)
93f63467 AW	182	s l (cons (car gensyms) c))))))
80af1168 AW	183	(else
	184	(values unref ref set simple lambda* complex))))
	185	'()
	186	'()
	187	'()
	188	'()
	189	'()
	190	'())))
	191	(values unref simple lambda* complex)))
	192
74bbb994 AW	193	(define (make-seq* src head tail)
	194	(record-case head
	195	((<lambda>) tail)
	196	((<const>) tail)
	197	((<lexical-ref>) tail)
	198	((<void>) tail)
	199	(else (make-seq src head tail))))
	200
	201	(define (list->seq* loc exps)
	202	(if (null? (cdr exps))
	203	(car exps)
	204	(let lp ((exps (cdr exps)) (effects (list (car exps))))
	205	(if (null? (cdr exps))
	206	(make-seq* loc
	207	(fold (lambda (exp tail) (make-seq* #f exp tail))
	208	(car effects)
	209	(cdr effects))
	210	(car exps))
	211	(lp (cdr exps) (cons (car exps) effects))))))
86e4479a	212
403d78f9	213	(define (fix-letrec x)
80af1168	214	(let-values (((unref simple lambda* complex) (partition-vars x)))
403d78f9	215	(post-order
80af1168 AW	216	(lambda (x)
	217	(record-case x
	218
	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)
74bbb994	223	(make-seq* #f exp (make-void #f))
80af1168 AW	224	x))
80af1168 AW	225
60d4b224	226	((<letrec> src in-order? names gensyms vals body)
df129795 AW	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.
	230	(define (lookup set)
	231	(let lp ((binds binds))
	232	(cond
	233	((null? binds) '())
	234	((memq (caar binds) set)
	235	(cons (car binds) (lp (cdr binds))))
	236	(else (lp (cdr binds))))))
	237	(let ((u (lookup unref))
	238	(s (lookup simple))
	239	(l (lookup lambda*))
	240	(c (lookup complex)))
	241	;; Bind "simple" bindings, and locations for complex
	242	;; bindings.
	243	(make-let
	244	src
	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.
	249	(make-fix
	250	src (map cadr l) (map car l) (map caddr l)
74bbb994	251	(list->seq*
df129795 AW	252	src
	253	(append
	254	;; The right-hand-sides of the unreferenced
	255	;; bindings, for effect.
	256	(map caddr u)
	257	(cond
	258	((null? c)
	259	;; No complex bindings, just emit the body.
	260	(list body))
	261	(in-order?
	262	;; For letrec*, assign complex bindings in order, then the
	263	;; body.
	264	(append
	265	(map (lambda (c)
	266	(make-lexical-set #f (cadr c) (car c)
	267	(caddr c)))
	268	c)
	269	(list body)))
	270	(else
b3da54d1	271	;; Otherwise for plain letrec, evaluate the "complex"
df129795 AW	272	;; bindings, in a `let' to indicate that order doesn't
	273	;; matter, and bind to their variables.
	274	(list
	275	(let ((tmps (map (lambda (x) (gensym)) c)))
	276	(make-let
	277	#f (map cadr c) tmps (map caddr c)
6fc3eae4	278	(list->seq
df129795 AW	279	#f
	280	(map (lambda (x tmp)
	281	(make-lexical-set
	282	#f (cadr x) (car x)
	283	(make-lexical-ref #f (cadr x) tmp)))
	284	c tmps))))
	285	body))))))))))
80af1168	286
93f63467 AW	287	((<let> src names gensyms vals body)
93f63467 AW	288	(let ((binds (map list gensyms names vals)))
aaae0d5a AW	289	(define (lookup set)
aaae0d5a AW	290	(map (lambda (v) (assq v binds))
93f63467	291	(lset-intersection eq? gensyms set)))
aaae0d5a AW	292	(let ((u (lookup unref))
	293	(l (lookup lambda*))
	294	(c (lookup complex)))
74bbb994	295	(list->seq*
aaae0d5a AW	296	src
	297	(append
	298	;; unreferenced bindings, called for effect.
	299	(map caddr u)
	300	(list
	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)
	305	body))))))))
	306
80af1168 AW	307	(else x)))
80af1168 AW	308	x)))
65ea26c5 LC	309
	310	;;; Local Variables:
	311	;;; eval: (put 'record-case 'scheme-indent-function 1)
	312	;;; End: