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

   1 ;;; transformation of letrec into simpler forms
   2
   3 ;; Copyright (C) 2009, 2010, 2011 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 simple-primitive?)
  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 simple-primitive?)
  42           (simple-expression? consequent bound-vars simple-primitive?)
  43           (simple-expression? alternate bound-vars simple-primitive?)))
  44     ((<sequence> exps)
  45      (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
  46               exps))
  47     ((<application> proc args)
  48      (and (primitive-ref? proc)
  49           (simple-primitive? (primitive-ref-name proc))
  50           ;; FIXME: check arity?
  51           (and-map (lambda (x)
  52                      (simple-expression? x bound-vars simple-primitive?))
  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))
  76                       ((<letrec> gensyms)
  77                        (values (append gensyms unref)
  78                                ref
  79                                set
  80                                simple
  81                                lambda*
  82                                complex))
  83                       ((<let> gensyms)
  84                        (values (append gensyms unref)
  85                                ref
  86                                set
  87                                simple
  88                                lambda*
  89                                complex))
  90                       (else
  91                        (values unref ref set simple lambda* complex))))
  92                   (lambda (x unref ref set simple lambda* complex)
  93                     (record-case x
  94                       ((<letrec> in-order? (orig-gensyms gensyms) vals)
  95                        (let lp ((gensyms orig-gensyms) (vals vals)
  96                                 (s '()) (l '()) (c '()))
  97                          (cond
  98                           ((null? gensyms)
  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.
 103                            (values (if in-order?
 104                                        (lset-difference eq? unref c)
 105                                        unref)
 106                                    ref
 107                                    set
 108                                    (append s simple)
 109                                    (append l lambda*)
 110                                    (append c complex)))
 111                           ((memq (car gensyms) unref)
 112                            ;; See above note about unref and letrec*.
 113                            (if (and in-order?
 114                                     (not (lambda? (car vals)))
 115                                     (not (simple-expression?
 116                                           (car vals) orig-gensyms
 117                                           effect+exception-free-primitive?)))
 118                                (lp (cdr gensyms) (cdr vals)
 119                                    s l (cons (car gensyms) c))
 120                                (lp (cdr gensyms) (cdr vals)
 121                                    s l c)))
 122                           ((memq (car gensyms) set)
 123                            (lp (cdr gensyms) (cdr vals)
 124                                s l (cons (car gensyms) c)))
 125                           ((lambda? (car vals))
 126                            (lp (cdr gensyms) (cdr vals)
 127                                s (cons (car gensyms) l) c))
 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.
 136                            (lp (cdr gensyms) (cdr vals)
 137                                (cons (car gensyms) s) l c))
 138                           (else
 139                            (lp (cdr gensyms) (cdr vals)
 140                                s l (cons (car gensyms) c))))))
 141                       ((<let> (orig-gensyms gensyms) vals)
 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
 145                        ;; gensyms. There is no problem recursing into the
 146                        ;; bindings after the let, because all variables
 147                        ;; have been renamed.
 148                        (let lp ((gensyms orig-gensyms) (vals vals)
 149                                 (s '()) (l '()) (c '()))
 150                          (cond
 151                           ((null? gensyms)
 152                            (values unref
 153                                    ref
 154                                    set
 155                                    (append s simple)
 156                                    (append l lambda*)
 157                                    (append c complex)))
 158                           ((memq (car gensyms) unref)
 159                            (lp (cdr gensyms) (cdr vals)
 160                                s l c))
 161                           ((memq (car gensyms) set)
 162                            (lp (cdr gensyms) (cdr vals)
 163                                s l (cons (car gensyms) c)))
 164                           ((and (lambda? (car vals))
 165                                 (not (memq (car gensyms) set)))
 166                            (lp (cdr gensyms) (cdr vals)
 167                                s (cons (car gensyms) l) c))
 168                           ;; There is no difference between simple and
 169                           ;; complex, for the purposes of let. Just lump
 170                           ;; them all into complex.
 171                           (else
 172                            (lp (cdr gensyms) (cdr vals)
 173                                s l (cons (car gensyms) c))))))
 174                       (else
 175                        (values unref ref set simple lambda* complex))))
 176                   '()
 177                   '()
 178                   '()
 179                   '()
 180                   '()
 181                   '())))
 182     (values unref simple lambda* complex)))
 183
 184 (define (fix-letrec! x)
 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)
 194               (make-sequence #f (list exp (make-void #f)))
 195               x))
 196
 197          ((<letrec> src in-order? names gensyms vals body)
 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))))))))))
 257
 258          ((<let> src names gensyms vals body)
 259           (let ((binds (map list gensyms names vals)))
 260             (define (lookup set)
 261               (map (lambda (v) (assq v binds))
 262                    (lset-intersection eq? gensyms set)))
 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
 278          (else x)))
 279      x)))
 280
 281 ;;; Local Variables:
 282 ;;; eval: (put 'record-case 'scheme-indent-function 1)
 283 ;;; End: