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