module/language/tree-il/fix-letrec.scm

   1 ;;; transformation of letrec into simpler forms
   2
   3 ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
   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)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (srfi srfi-11)
  23   #:use-module (language tree-il)
  24   #:use-module (language tree-il primitives)
  25   #:export (fix-letrec!))
  26
  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.
  30
  31 (define fix-fold
  32   (make-tree-il-folder unref ref set simple lambda complex))
  33
  34 (define (simple-expression? x bound-vars)
  35   (record-case x
  36     ((<void>) #t)
  37     ((<const>) #t)
  38     ((<lexical-ref> gensym)
  39      (not (memq gensym bound-vars)))
  40     ((<conditional> test consequent alternate)
  41      (and (simple-expression? test bound-vars)
  42           (simple-expression? consequent bound-vars)
  43           (simple-expression? alternate bound-vars)))
  44     ((<sequence> exps)
  45      (and-map (lambda (x) (simple-expression? x bound-vars))
  46               exps))
  47     ((<application> proc args)
  48      (and (primitive-ref? proc)
  49           (effect-free-primitive? (primitive-ref-name proc))
  50           ;; FIXME: check arity?
  51           (and-map (lambda (x) (simple-expression? x bound-vars))
  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))
  75                       ((<letrec> gensyms)
  76                        (values (append gensyms unref)
  77                                ref
  78                                set
  79                                simple
  80                                lambda*
  81                                complex))
  82                       ((<let> gensyms)
  83                        (values (append gensyms unref)
  84                                ref
  85                                set
  86                                simple
  87                                lambda*
  88                                complex))
  89                       (else
  90                        (values unref ref set simple lambda* complex))))
  91                   (lambda (x unref ref set simple lambda* complex)
  92                     (record-case x
  93                       ((<letrec> (orig-gensyms gensyms) vals)
  94                        (let lp ((gensyms orig-gensyms) (vals vals)
  95                                 (s '()) (l '()) (c '()))
  96                          (cond
  97                           ((null? gensyms)
  98                            (values unref
  99                                    ref
 100                                    set
 101                                    (append s simple)
 102                                    (append l lambda*)
 103                                    (append c complex)))
 104                           ((memq (car gensyms) unref)
 105                            (lp (cdr gensyms) (cdr vals)
 106                                s l c))
 107                           ((memq (car gensyms) set)
 108                            (lp (cdr gensyms) (cdr vals)
 109                                s l (cons (car gensyms) c)))
 110                           ((lambda? (car vals))
 111                            (lp (cdr gensyms) (cdr vals)
 112                                s (cons (car gensyms) l) c))
 113                           ((simple-expression? (car vals) orig-gensyms)
 114                            (lp (cdr gensyms) (cdr vals)
 115                                (cons (car gensyms) s) l c))
 116                           (else
 117                            (lp (cdr gensyms) (cdr vals)
 118                                s l (cons (car gensyms) c))))))
 119                       ((<let> (orig-gensyms gensyms) vals)
 120                        ;; The point is to compile let-bound lambdas as
 121                        ;; efficiently as we do letrec-bound lambdas, so
 122                        ;; we use the same algorithm for analyzing the
 123                        ;; gensyms. There is no problem recursing into the
 124                        ;; bindings after the let, because all variables
 125                        ;; have been renamed.
 126                        (let lp ((gensyms orig-gensyms) (vals vals)
 127                                 (s '()) (l '()) (c '()))
 128                          (cond
 129                           ((null? gensyms)
 130                            (values unref
 131                                    ref
 132                                    set
 133                                    (append s simple)
 134                                    (append l lambda*)
 135                                    (append c complex)))
 136                           ((memq (car gensyms) unref)
 137                            (lp (cdr gensyms) (cdr vals)
 138                                s l c))
 139                           ((memq (car gensyms) set)
 140                            (lp (cdr gensyms) (cdr vals)
 141                                s l (cons (car gensyms) c)))
 142                           ((and (lambda? (car vals))
 143                                 (not (memq (car gensyms) set)))
 144                            (lp (cdr gensyms) (cdr vals)
 145                                s (cons (car gensyms) l) c))
 146                           ;; There is no difference between simple and
 147                           ;; complex, for the purposes of let. Just lump
 148                           ;; them all into complex.
 149                           (else
 150                            (lp (cdr gensyms) (cdr vals)
 151                                s l (cons (car gensyms) c))))))
 152                       (else
 153                        (values unref ref set simple lambda* complex))))
 154                   '()
 155                   '()
 156                   '()
 157                   '()
 158                   '()
 159                   '())))
 160     (values unref simple lambda* complex)))
 161
 162 (define (fix-letrec! x)
 163   (let-values (((unref simple lambda* complex) (partition-vars x)))
 164     (post-order!
 165      (lambda (x)
 166        (record-case x
 167
 168          ;; Sets to unreferenced variables may be replaced by their
 169          ;; expression, called for effect.
 170          ((<lexical-set> gensym exp)
 171           (if (memq gensym unref)
 172               (make-sequence #f (list exp (make-void #f)))
 173               x))
 174
 175          ((<letrec> src names gensyms vals body)
 176           (let ((binds (map list gensyms names vals)))
 177             (define (lookup set)
 178               (map (lambda (v) (assq v binds))
 179                    (lset-intersection eq? gensyms set)))
 180             (let ((u (lookup unref))
 181                   (s (lookup simple))
 182                   (l (lookup lambda*))
 183                   (c (lookup complex)))
 184               ;; Bind "simple" bindings, and locations for complex
 185               ;; bindings.
 186               (make-let
 187                src
 188                (append (map cadr s) (map cadr c))
 189                (append (map car s) (map car c))
 190                (append (map caddr s) (map (lambda (x) (make-void #f)) c))
 191                ;; Bind lambdas using the fixpoint operator.
 192                (make-fix
 193                 src (map cadr l) (map car l) (map caddr l)
 194                 (make-sequence
 195                  src
 196                  (append
 197                   ;; The right-hand-sides of the unreferenced
 198                   ;; bindings, for effect.
 199                   (map caddr u)
 200                   (if (null? c)
 201                       ;; No complex bindings, just emit the body.
 202                       (list body)
 203                       (list
 204                        ;; Evaluate the the "complex" bindings, in a `let' to
 205                        ;; indicate that order doesn't matter, and bind to
 206                        ;; their variables.
 207                        (let ((tmps (map (lambda (x) (gensym)) c)))
 208                          (make-let
 209                           #f (map cadr c) tmps (map caddr c)
 210                           (make-sequence
 211                            #f
 212                            (map (lambda (x tmp)
 213                                   (make-lexical-set
 214                                    #f (cadr x) (car x)
 215                                    (make-lexical-ref #f (cadr x) tmp)))
 216                                 c tmps))))
 217                        ;; Finally, the body.
 218                        body)))))))))
 219
 220          ((<let> src names gensyms vals body)
 221           (let ((binds (map list gensyms names vals)))
 222             (define (lookup set)
 223               (map (lambda (v) (assq v binds))
 224                    (lset-intersection eq? gensyms set)))
 225             (let ((u (lookup unref))
 226                   (l (lookup lambda*))
 227                   (c (lookup complex)))
 228               (make-sequence
 229                src
 230                (append
 231                 ;; unreferenced bindings, called for effect.
 232                 (map caddr u)
 233                 (list
 234                  ;; unassigned lambdas use fix.
 235                  (make-fix src (map cadr l) (map car l) (map caddr l)
 236                            ;; and the "complex" bindings.
 237                            (make-let src (map cadr c) (map car c) (map caddr c)
 238                                      body))))))))
 239
 240          (else x)))
 241      x)))