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

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