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

   1 ;;; transformation of letrec into simpler forms
   2
   3 ;; Copyright (C) 2009, 2010, 2011, 2012 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 effects)
  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-primcall?)
  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-primcall?)
  42           (simple-expression? consequent bound-vars simple-primcall?)
  43           (simple-expression? alternate bound-vars simple-primcall?)))
  44     ((<sequence> exps)
  45      (and-map (lambda (x) (simple-expression? x bound-vars simple-primcall?))
  46               exps))
  47     ((<application> proc args)
  48      (and (primitive-ref? proc)
  49           (simple-primcall? x)
  50           (and-map (lambda (x)
  51                      (simple-expression? x bound-vars simple-primcall?))
  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> in-order? (orig-gensyms gensyms) vals)
  94                        (define compute-effects
  95                          (make-effects-analyzer (lambda (x) (memq x set))))
  96                        (define (effect-free-primcall? x)
  97                          (let ((effects (compute-effects x)))
  98                            (effect-free?
  99                             (exclude-effects effects (logior &allocation
 100                                                              &type-check)))))
 101                        (define (effect+exception-free-primcall? x)
 102                          (let ((effects (compute-effects x)))
 103                            (effect-free?
 104                             (exclude-effects effects &allocation))))
 105                        (let lp ((gensyms orig-gensyms) (vals vals)
 106                                 (s '()) (l '()) (c '()))
 107                          (cond
 108                           ((null? gensyms)
 109                            ;; Unreferenced complex vars are still
 110                            ;; complex for letrec*.  We need to update
 111                            ;; our algorithm to "Fixing letrec reloaded"
 112                            ;; to fix this.
 113                            (values (if in-order?
 114                                        (lset-difference eq? unref c)
 115                                        unref)
 116                                    ref
 117                                    set
 118                                    (append s simple)
 119                                    (append l lambda*)
 120                                    (append c complex)))
 121                           ((memq (car gensyms) unref)
 122                            ;; See above note about unref and letrec*.
 123                            (if (and in-order?
 124                                     (not (lambda? (car vals)))
 125                                     (not (simple-expression?
 126                                           (car vals) orig-gensyms
 127                                           effect+exception-free-primcall?)))
 128                                (lp (cdr gensyms) (cdr vals)
 129                                    s l (cons (car gensyms) c))
 130                                (lp (cdr gensyms) (cdr vals)
 131                                    s l c)))
 132                           ((memq (car gensyms) set)
 133                            (lp (cdr gensyms) (cdr vals)
 134                                s l (cons (car gensyms) c)))
 135                           ((lambda? (car vals))
 136                            (lp (cdr gensyms) (cdr vals)
 137                                s (cons (car gensyms) l) c))
 138                           ((simple-expression?
 139                             (car vals) orig-gensyms
 140                             (if in-order?
 141                                 effect+exception-free-primcall?
 142                                 effect-free-primcall?))
 143                            ;; For letrec*, we can't consider e.g. `car' to be
 144                            ;; "simple", as it could raise an exception. Hence
 145                            ;; effect+exception-free-primitive? above.
 146                            (lp (cdr gensyms) (cdr vals)
 147                                (cons (car gensyms) s) l c))
 148                           (else
 149                            (lp (cdr gensyms) (cdr vals)
 150                                s l (cons (car gensyms) c))))))
 151                       ((<let> (orig-gensyms gensyms) vals)
 152                        ;; The point is to compile let-bound lambdas as
 153                        ;; efficiently as we do letrec-bound lambdas, so
 154                        ;; we use the same algorithm for analyzing the
 155                        ;; gensyms. There is no problem recursing into the
 156                        ;; bindings after the let, because all variables
 157                        ;; have been renamed.
 158                        (let lp ((gensyms orig-gensyms) (vals vals)
 159                                 (s '()) (l '()) (c '()))
 160                          (cond
 161                           ((null? gensyms)
 162                            (values unref
 163                                    ref
 164                                    set
 165                                    (append s simple)
 166                                    (append l lambda*)
 167                                    (append c complex)))
 168                           ((memq (car gensyms) unref)
 169                            (lp (cdr gensyms) (cdr vals)
 170                                s l c))
 171                           ((memq (car gensyms) set)
 172                            (lp (cdr gensyms) (cdr vals)
 173                                s l (cons (car gensyms) c)))
 174                           ((and (lambda? (car vals))
 175                                 (not (memq (car gensyms) set)))
 176                            (lp (cdr gensyms) (cdr vals)
 177                                s (cons (car gensyms) l) c))
 178                           ;; There is no difference between simple and
 179                           ;; complex, for the purposes of let. Just lump
 180                           ;; them all into complex.
 181                           (else
 182                            (lp (cdr gensyms) (cdr vals)
 183                                s l (cons (car gensyms) c))))))
 184                       (else
 185                        (values unref ref set simple lambda* complex))))
 186                   '()
 187                   '()
 188                   '()
 189                   '()
 190                   '()
 191                   '())))
 192     (values unref simple lambda* complex)))
 193
 194 (define (make-sequence* src exps)
 195   (let lp ((in exps) (out '()))
 196     (if (null? (cdr in))
 197         (if (null? out)
 198             (car in)
 199             (make-sequence src (reverse (cons (car in) out))))
 200         (let ((head (car in)))
 201           (record-case head
 202             ((<lambda>) (lp (cdr in) out))
 203             ((<const>) (lp (cdr in) out))
 204             ((<lexical-ref>) (lp (cdr in) out))
 205             ((<void>) (lp (cdr in) out))
 206             (else (lp (cdr in) (cons head out))))))))
 207
 208 (define (fix-letrec! x)
 209   (let-values (((unref simple lambda* complex) (partition-vars x)))
 210     (post-order!
 211      (lambda (x)
 212        (record-case x
 213
 214          ;; Sets to unreferenced variables may be replaced by their
 215          ;; expression, called for effect.
 216          ((<lexical-set> gensym exp)
 217           (if (memq gensym unref)
 218               (make-sequence* #f (list exp (make-void #f)))
 219               x))
 220
 221          ((<letrec> src in-order? names gensyms vals body)
 222           (let ((binds (map list gensyms names vals)))
 223             ;; The bindings returned by this function need to appear in the same
 224             ;; order that they appear in the letrec.
 225             (define (lookup set)
 226               (let lp ((binds binds))
 227                 (cond
 228                  ((null? binds) '())
 229                  ((memq (caar binds) set)
 230                   (cons (car binds) (lp (cdr binds))))
 231                  (else (lp (cdr binds))))))
 232             (let ((u (lookup unref))
 233                   (s (lookup simple))
 234                   (l (lookup lambda*))
 235                   (c (lookup complex)))
 236               ;; Bind "simple" bindings, and locations for complex
 237               ;; bindings.
 238               (make-let
 239                src
 240                (append (map cadr s) (map cadr c))
 241                (append (map car s) (map car c))
 242                (append (map caddr s) (map (lambda (x) (make-void #f)) c))
 243                ;; Bind lambdas using the fixpoint operator.
 244                (make-fix
 245                 src (map cadr l) (map car l) (map caddr l)
 246                 (make-sequence*
 247                  src
 248                  (append
 249                   ;; The right-hand-sides of the unreferenced
 250                   ;; bindings, for effect.
 251                   (map caddr u)
 252                   (cond
 253                    ((null? c)
 254                     ;; No complex bindings, just emit the body.
 255                     (list body))
 256                    (in-order?
 257                     ;; For letrec*, assign complex bindings in order, then the
 258                     ;; body.
 259                     (append
 260                      (map (lambda (c)
 261                             (make-lexical-set #f (cadr c) (car c)
 262                                               (caddr c)))
 263                           c)
 264                      (list body)))
 265                    (else
 266                     ;; Otherwise for plain letrec, evaluate the "complex"
 267                     ;; bindings, in a `let' to indicate that order doesn't
 268                     ;; matter, and bind to their variables.
 269                     (list
 270                      (let ((tmps (map (lambda (x) (gensym)) c)))
 271                        (make-let
 272                         #f (map cadr c) tmps (map caddr c)
 273                         (make-sequence
 274                          #f
 275                          (map (lambda (x tmp)
 276                                 (make-lexical-set
 277                                  #f (cadr x) (car x)
 278                                  (make-lexical-ref #f (cadr x) tmp)))
 279                               c tmps))))
 280                      body))))))))))
 281
 282          ((<let> src names gensyms vals body)
 283           (let ((binds (map list gensyms names vals)))
 284             (define (lookup set)
 285               (map (lambda (v) (assq v binds))
 286                    (lset-intersection eq? gensyms set)))
 287             (let ((u (lookup unref))
 288                   (l (lookup lambda*))
 289                   (c (lookup complex)))
 290               (make-sequence*
 291                src
 292                (append
 293                 ;; unreferenced bindings, called for effect.
 294                 (map caddr u)
 295                 (list
 296                  ;; unassigned lambdas use fix.
 297                  (make-fix src (map cadr l) (map car l) (map caddr l)
 298                            ;; and the "complex" bindings.
 299                            (make-let src (map cadr c) (map car c) (map caddr c)
 300                                      body))))))))
 301
 302          (else x)))
 303      x)))
 304
 305 ;;; Local Variables:
 306 ;;; eval: (put 'record-case 'scheme-indent-function 1)
 307 ;;; End: