module/language/cps/closure-conversion.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 2014 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 ;;; Commentary:
  20 ;;;
  21 ;;; This pass converts a CPS term in such a way that no function has any
  22 ;;; free variables.  Instead, closures are built explicitly with
  23 ;;; make-closure primcalls, and free variables are referenced through
  24 ;;; the closure.
  25 ;;;
  26 ;;; Closure conversion also removes any $letrec forms that contification
  27 ;;; did not handle.  See (language cps) for a further discussion of
  28 ;;; $letrec.
  29 ;;;
  30 ;;; Code:
  31
  32 (define-module (language cps closure-conversion)
  33   #:use-module (ice-9 match)
  34   #:use-module ((srfi srfi-1) #:select (fold
  35                                         lset-union lset-difference
  36                                         list-index))
  37   #:use-module (srfi srfi-26)
  38   #:use-module (language cps)
  39   #:export (convert-closures))
  40
  41 ;; free := var ...
  42
  43 (define (convert-free-var var self free k)
  44   "Convert one possibly free variable reference to a bound reference.
  45
  46 If @var{var} is free (i.e., present in @var{free},), it is replaced
  47 by a closure reference via a @code{free-ref} primcall, and @var{k} is
  48 called with the new var.  Otherwise @var{var} is bound, so @var{k} is
  49 called with @var{var}."
  50   (cond
  51    ((list-index (cut eq? <> var) free)
  52     => (lambda (free-idx)
  53          (let-fresh (k* kidx) (idx var*)
  54            (build-cps-term
  55              ($letk ((kidx ($kargs ('idx) (idx)
  56                              ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
  57                                ($continue k* #f
  58                                  ($primcall 'free-ref (self idx)))))))
  59                ($continue kidx #f ($const free-idx)))))))
  60    (else (k var))))
  61
  62 (define (convert-free-vars vars self free k)
  63   "Convert a number of possibly free references to bound references.
  64 @var{k} is called with the bound references, and should return the
  65 term."
  66   (match vars
  67     (() (k '()))
  68     ((var . vars)
  69      (convert-free-var var self free
  70                        (lambda (var)
  71                          (convert-free-vars vars self free
  72                                             (lambda (vars)
  73                                               (k (cons var vars)))))))))
  74
  75 (define (init-closure src v free outer-self outer-free body)
  76   "Initialize the free variables @var{free} in a closure bound to
  77 @var{v}, and continue with @var{body}.  @var{outer-self} must be the
  78 label of the outer procedure, where the initialization will be
  79 performed, and @var{outer-free} is the list of free variables there."
  80   (fold (lambda (free idx body)
  81           (let-fresh (k) (idxvar)
  82             (build-cps-term
  83               ($letk ((k ($kargs () () ,body)))
  84                 ,(convert-free-var
  85                   free outer-self outer-free
  86                   (lambda (free)
  87                     (values (build-cps-term
  88                               ($letconst (('idx idxvar idx))
  89                                 ($continue k src
  90                                   ($primcall 'free-set! (v idxvar free)))))
  91                             '())))))))
  92         body
  93         free
  94         (iota (length free))))
  95
  96 (define (compute-free-vars exp)
  97   "Compute the set of free variables for all $fun instances in
  98 @var{exp}."
  99   (let ((table (make-hash-table)))
 100     (define (union a b)
 101       (lset-union eq? a b))
 102     (define (difference a b)
 103       (lset-difference eq? a b))
 104     (define (visit-cont cont bound)
 105       (match cont
 106         (($ $cont label ($ $kargs names vars body))
 107          (visit-term body (append vars bound)))
 108         (($ $cont label ($ $kfun src meta self tail clause))
 109          (let ((free (if clause
 110                          (visit-cont clause (list self))
 111                          '())))
 112            (hashq-set! table label (cons free cont))
 113            (difference free bound)))
 114         (($ $cont label ($ $kclause arity body alternate))
 115          (let ((free (visit-cont body bound)))
 116            (if alternate
 117                (union (visit-cont alternate bound) free)
 118                free)))
 119         (($ $cont) '())))
 120     (define (visit-term term bound)
 121       (match term
 122         (($ $letk conts body)
 123          (fold (lambda (cont free)
 124                  (union (visit-cont cont bound) free))
 125                (visit-term body bound)
 126                conts))
 127         (($ $letrec names vars (($ $fun () cont) ...) body)
 128          (let ((bound (append vars bound)))
 129            (fold (lambda (cont free)
 130                    (union (visit-cont cont bound) free))
 131                  (visit-term body bound)
 132                  cont)))
 133         (($ $continue k src ($ $fun () body))
 134          (visit-cont body bound))
 135         (($ $continue k src exp)
 136          (visit-exp exp bound))))
 137     (define (visit-exp exp bound)
 138       (define (adjoin var free)
 139         (if (or (memq var bound) (memq var free))
 140             free
 141             (cons var free)))
 142       (match exp
 143         ((or ($ $void) ($ $const) ($ $prim)) '())
 144         (($ $call proc args)
 145          (fold adjoin (adjoin proc '()) args))
 146         (($ $callk k* proc args)
 147          (fold adjoin (adjoin proc '()) args))
 148         (($ $primcall name args)
 149          (fold adjoin '() args))
 150         (($ $values args)
 151          (fold adjoin '() args))
 152         (($ $prompt escape? tag handler)
 153          (adjoin tag '()))))
 154
 155     (let ((free (visit-cont exp '())))
 156       (unless (null? free)
 157         (error "Expected no free vars in toplevel thunk" free exp))
 158       table)))
 159
 160 (define (convert-one label table)
 161   (match (hashq-ref table label)
 162     ((free . (and fun ($ $cont _ ($ $kfun _ _ self))))
 163      (define (visit-cont cont)
 164        (rewrite-cps-cont cont
 165          (($ $cont label ($ $kargs names vars body))
 166           (label ($kargs names vars ,(visit-term body))))
 167          (($ $cont label ($ $kfun src meta self tail clause))
 168           (label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
 169          (($ $cont label ($ $kclause arity body alternate))
 170           (label ($kclause ,arity ,(visit-cont body)
 171                          ,(and alternate (visit-cont alternate)))))
 172          (($ $cont) ,cont)))
 173      (define (visit-term term)
 174        (match term
 175          (($ $letk conts body)
 176           (build-cps-term
 177             ($letk ,(map visit-cont conts) ,(visit-term body))))
 178
 179          ;; Remove letrec.
 180          (($ $letrec names vars funs body)
 181           (let lp ((in (map list names vars funs))
 182                    (bindings (lambda (body) body))
 183                    (body (visit-term body)))
 184             (match in
 185               (() (bindings body))
 186               (((name var ($ $fun ()
 187                              (and fun-body
 188                                   ($ $cont kfun ($ $kfun src))))) . in)
 189                (match (hashq-ref table kfun)
 190                  ((fun-free . _)
 191                   (lp in
 192                       (lambda (body)
 193                         (let-fresh (k) ()
 194                           (build-cps-term
 195                             ($letk ((k ($kargs (name) (var) ,(bindings body))))
 196                               ($continue k src
 197                                 ($closure kfun (length fun-free)))))))
 198                       (init-closure src var fun-free self free body))))))))
 199
 200          (($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
 201           term)
 202
 203          (($ $continue k src ($ $fun () ($ $cont kfun)))
 204           (match (hashq-ref table kfun)
 205             ((() . _)
 206              (build-cps-term ($continue k src ($closure kfun 0))))
 207             ((fun-free . _)
 208              (let-fresh (kinit) (v)
 209                (build-cps-term
 210                  ($letk ((kinit ($kargs (v) (v)
 211                                   ,(init-closure
 212                                     src v fun-free self free
 213                                     (build-cps-term
 214                                       ($continue k src ($values (v))))))))
 215                    ($continue kinit src
 216                      ($closure kfun (length fun-free)))))))))
 217
 218          (($ $continue k src ($ $call proc args))
 219           (convert-free-vars (cons proc args) self free
 220                              (match-lambda
 221                               ((proc . args)
 222                                (build-cps-term
 223                                  ($continue k src ($call proc args)))))))
 224
 225          (($ $continue k src ($ $callk k* proc args))
 226           (convert-free-vars (cons proc args) self free
 227                              (match-lambda
 228                               ((proc . args)
 229                                (build-cps-term
 230                                  ($continue k src ($callk k* proc args)))))))
 231
 232          (($ $continue k src ($ $primcall name args))
 233           (convert-free-vars args self free
 234                              (lambda (args)
 235                                (build-cps-term
 236                                  ($continue k src ($primcall name args))))))
 237
 238          (($ $continue k src ($ $values args))
 239           (convert-free-vars args self free
 240                              (lambda (args)
 241                                (build-cps-term
 242                                  ($continue k src ($values args))))))
 243
 244          (($ $continue k src ($ $prompt escape? tag handler))
 245           (convert-free-var tag self free
 246                             (lambda (tag)
 247                               (build-cps-term
 248                                 ($continue k src
 249                                   ($prompt escape? tag handler))))))))
 250      (visit-cont fun))))
 251
 252 (define (convert-closures fun)
 253   "Convert free reference in @var{exp} to primcalls to @code{free-ref},
 254 and allocate and initialize flat closures."
 255   (with-fresh-name-state fun
 256     (let* ((table (compute-free-vars fun))
 257            (labels (sort (hash-map->list (lambda (k v) k) table) <)))
 258       (build-cps-term
 259         ($program ,(map (cut convert-one <> table) labels))))))