Gecko [ www.utparral.edu.mx ]

Name	Size	Permission
closure-conversion.scm	35.09 KB	-rw-r--r--
compile-bytecode.scm	28.33 KB	-rw-r--r--
constructors.scm	3.71 KB	-rw-r--r--
contification.scm	18.34 KB	-rw-r--r--
cse.scm	17.17 KB	-rw-r--r--
dce.scm	14.91 KB	-rw-r--r--
effects-analysis.scm	22.37 KB	-rw-r--r--
elide-values.scm	3.36 KB	-rw-r--r--
handle-interrupts.scm	2.54 KB	-rw-r--r--
intmap.scm	28.24 KB	-rw-r--r--
intset.scm	29.58 KB	-rw-r--r--
licm.scm	13.95 KB	-rw-r--r--
optimize.scm	4.89 KB	-rw-r--r--
peel-loops.scm	12.08 KB	-rw-r--r--
primitives.scm	4.43 KB	-rw-r--r--
prune-bailouts.scm	3.12 KB	-rw-r--r--
prune-top-level-scopes.scm	2.25 KB	-rw-r--r--
reify-primitives.scm	6.75 KB	-rw-r--r--
renumber.scm	9.39 KB	-rw-r--r--
rotate-loops.scm	10.68 KB	-rw-r--r--
self-references.scm	3.22 KB	-rw-r--r--
simplify.scm	10.88 KB	-rw-r--r--
slot-allocation.scm	41.93 KB	-rw-r--r--
specialize-numbers.scm	29.3 KB	-rw-r--r--
specialize-primcalls.scm	3.97 KB	-rw-r--r--
spec.scm	1.76 KB	-rw-r--r--
split-rec.scm	7.13 KB	-rw-r--r--
type-checks.scm	3.12 KB	-rw-r--r--
type-fold.scm	17.35 KB	-rw-r--r--
types.scm	66.76 KB	-rw-r--r--
utils.scm	20.62 KB	-rw-r--r--
verify.scm	10.52 KB	-rw-r--r--
with-cps.scm	5.72 KB	-rw-r--r--

Code Editor : closure-conversion.scm

;;; Continuation-passing style (CPS) intermediate language (IL)

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;;
;;; This pass converts a CPS term in such a way that no function has any
;;; free variables.  Instead, closures are built explicitly with
;;; make-closure primcalls, and free variables are referenced through
;;; the closure.
;;;
;;; Closure conversion also removes any $rec expressions that
;;; contification did not handle.  See (language cps) for a further
;;; discussion of $rec.
;;;
;;; Code:

(define-module (language cps closure-conversion)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (fold
                                        filter-map
                                        ))
  #:use-module (srfi srfi-11)
  #:use-module (language cps)
  #:use-module (language cps utils)
  #:use-module (language cps with-cps)
  #:use-module (language cps intmap)
  #:use-module (language cps intset)
  #:export (convert-closures))

(define (compute-function-bodies conts kfun)
  "Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in
conts."
  (let visit-fun ((kfun kfun) (out empty-intmap))
    (let ((body (compute-function-body conts kfun)))
      (intset-fold
       (lambda (label out)
         (match (intmap-ref conts label)
           (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
            (visit-fun kfun out))
           (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
            (fold visit-fun out kfun))
           (_ out)))
       body
       (intmap-add out kfun body)))))

(define (compute-program-body functions)
  (intmap-fold (lambda (label body out) (intset-union body out))
               functions
               empty-intset))

(define (filter-reachable conts functions)
  (let ((reachable (compute-program-body functions)))
    (intmap-fold
     (lambda (label cont out)
       (if (intset-ref reachable label)
           out
           (intmap-remove out label)))
     conts conts)))

(define (compute-non-operator-uses conts)
  (persistent-intset
   (intmap-fold
    (lambda (label cont uses)
      (define (add-use var uses) (intset-add! uses var))
      (define (add-uses vars uses)
        (match vars
          (() uses)
          ((var . vars) (add-uses vars (add-use var uses)))))
      (match cont
        (($ $kargs _ _ ($ $continue _ _ exp))
         (match exp
           ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses)
           (($ $values args)
            (add-uses args uses))
           (($ $call proc args)
            (add-uses args uses))
           (($ $branch kt ($ $values (arg)))
            (add-use arg uses))
           (($ $branch kt ($ $primcall name args))
            (add-uses args uses))
           (($ $primcall name args)
            (add-uses args uses))
           (($ $prompt escape? tag handler)
            (add-use tag uses))))
        (_ uses)))
    conts
    empty-intset)))

(define (compute-singly-referenced-labels conts body)
  (define (add-ref label single multiple)
    (define (ref k single multiple)
      (if (intset-ref single k)
          (values single (intset-add! multiple k))
          (values (intset-add! single k) multiple)))
    (define (ref0) (values single multiple))
    (define (ref1 k) (ref k single multiple))
    (define (ref2 k k*)
      (if k*
          (let-values (((single multiple) (ref k single multiple)))
            (ref k* single multiple))
          (ref1 k)))
    (match (intmap-ref conts label)
      (($ $kreceive arity k) (ref1 k))
      (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
      (($ $ktail) (ref0))
      (($ $kclause arity kbody kalt) (ref2 kbody kalt))
      (($ $kargs names syms ($ $continue k src exp))
       (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
  (let*-values (((single multiple) (values empty-intset empty-intset))
                ((single multiple) (intset-fold add-ref body single multiple)))
    (intset-subtract (persistent-intset single)
                     (persistent-intset multiple))))

(define (compute-function-names conts functions)
  "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function
whose bound vars we know."
  (define (add-named-fun var kfun out)
    (let ((self (match (intmap-ref conts kfun)
                  (($ $kfun src meta self) self))))
      (intmap-add out kfun (intset var self))))
  (intmap-fold
   (lambda (label body out)
     (let ((single (compute-singly-referenced-labels conts body)))
       (intset-fold
        (lambda (label out)
          (match (intmap-ref conts label)
            (($ $kargs _ _ ($ $continue k _ ($ $fun kfun)))
             (if (intset-ref single k)
                 (match (intmap-ref conts k)
                   (($ $kargs (_) (var)) (add-named-fun var kfun out))
                   (_ out))
                 out))
            (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun) ...))))
             (unless (intset-ref single k)
               (error "$rec continuation has multiple predecessors??"))
             (fold add-named-fun out vars kfun))
            (_ out)))
        body
        out)))
   functions
   empty-intmap))

(define (compute-well-known-functions conts bound->label)
  "Compute a set of labels indicating the well-known functions in
@var{conts}.  A well-known function is a function whose bound names we
know and which is never used in a non-operator position."
  (intset-subtract
   (persistent-intset
    (intmap-fold (lambda (bound label candidates)
                   (intset-add! candidates label))
                 bound->label
                 empty-intset))
   (persistent-intset
    (intset-fold (lambda (var not-well-known)
                   (match (intmap-ref bound->label var (lambda (_) #f))
                     (#f not-well-known)
                     (label (intset-add! not-well-known label))))
                 (compute-non-operator-uses conts)
                 empty-intset))))

(define (intset-cons i set)
  (intset-add set i))

(define (compute-shared-closures conts well-known)
  "Compute a map LABEL->VAR indicating the sets of functions that will
share a closure.  If a functions's label is in the map, it is shared.
The entries indicate the var of the shared closure, which will be one of
the bound vars of the closure."
  (intmap-fold
   (lambda (label cont out)
     (match cont
       (($ $kargs _ _
           ($ $continue _ _ ($ $rec names vars (($ $fun kfuns) ...))))
        ;; The split-rec pass should have ensured that this $rec forms a
        ;; strongly-connected component, so the free variables from all of
        ;; the functions will be alive as long as one of the closures is
        ;; alive.  For that reason we can consider storing all free
        ;; variables in one closure and sharing it.
        (let* ((kfuns-set (fold intset-cons empty-intset kfuns))
               (unknown-kfuns (intset-subtract kfuns-set well-known)))
          (cond
           ((or (eq? empty-intset kfuns-set) (trivial-intset kfuns-set))
            ;; There is only zero or one function bound here.  Trivially
            ;; shared already.
            out)
           ((eq? empty-intset unknown-kfuns)
            ;; All functions are well-known; we can share a closure.  Use
            ;; the first bound variable.
            (let ((closure (car vars)))
              (intset-fold (lambda (kfun out)
                             (intmap-add out kfun closure))
                           kfuns-set out)))
           ((trivial-intset unknown-kfuns)
            => (lambda (unknown-kfun)
                 ;; Only one function is not-well-known.  Use that
                 ;; function's closure as the shared closure.
                 (let ((closure (assq-ref (map cons kfuns vars) unknown-kfun)))
                   (intset-fold (lambda (kfun out)
                                  (intmap-add out kfun closure))
                                kfuns-set out))))
           (else
            ;; More than one not-well-known function means we need more
            ;; than one proper closure, so we can't share.
            out))))
       (_ out)))
   conts
   empty-intmap))

(define* (rewrite-shared-closure-calls cps functions label->bound shared kfun)
  "Rewrite CPS such that every call to a function with a shared closure
instead is a $callk to that label, but passing the shared closure as the
proc argument.  For recursive calls, use the appropriate 'self'
variable, if possible.  Also rewrite uses of the non-well-known but
shared closures to use the appropriate 'self' variable, if possible."
  ;; env := var -> (var . label)
  (define (rewrite-fun kfun cps env)
    (define (subst var)
      (match (intmap-ref env var (lambda (_) #f))
        (#f var)
        ((var . label) var)))

(define (rename-exp label cps names vars k src exp)
      (intmap-replace!
       cps label
       (build-cont
         ($kargs names vars
           ($continue k src
             ,(rewrite-exp exp
                ((or ($ $const) ($ $prim)) ,exp)
                (($ $call proc args)
                 ,(let ((args (map subst args)))
                    (rewrite-exp (intmap-ref env proc (lambda (_) #f))
                      (#f ($call proc ,args))
                      ((closure . label) ($callk label closure ,args)))))
                (($ $primcall name args)
                 ($primcall name ,(map subst args)))
                (($ $branch k ($ $values (arg)))
                 ($branch k ($values ((subst arg)))))
                (($ $branch k ($ $primcall name args))
                 ($branch k ($primcall name ,(map subst args))))
                (($ $values args)
                 ($values ,(map subst args)))
                (($ $prompt escape? tag handler)
                 ($prompt escape? (subst tag) handler))))))))

(define (visit-exp label cps names vars k src exp)
      (define (compute-env label bound self rec-bound rec-labels env)
        (define (add-bound-var bound label env)
          (intmap-add env bound (cons self label) (lambda (old new) new)))
        (if (intmap-ref shared label (lambda (_) #f))
            ;; Within a function with a shared closure, rewrite
            ;; references to bound vars to use the "self" var.
            (fold add-bound-var env rec-bound rec-labels)
            ;; Otherwise be sure to use "self" references in any
            ;; closure.
            (add-bound-var bound label env)))
      (match exp
        (($ $fun label)
         (rewrite-fun label cps env))
        (($ $rec names vars (($ $fun labels) ...))
         (fold (lambda (label var cps)
                 (match (intmap-ref cps label)
                   (($ $kfun src meta self)
                    (rewrite-fun label cps
                                 (compute-env label var self vars labels
                                              env)))))
               cps labels vars))
        (_ (rename-exp label cps names vars k src exp))))
    
    (define (rewrite-cont label cps)
      (match (intmap-ref cps label)
        (($ $kargs names vars ($ $continue k src exp))
         (visit-exp label cps names vars k src exp))
        (_ cps)))

(intset-fold rewrite-cont (intmap-ref functions kfun) cps))

;; Initial environment is bound-var -> (shared-var . label) map for
  ;; functions with shared closures.
  (let ((env (intmap-fold (lambda (label shared env)
                            (intset-fold (lambda (bound env)
                                           (intmap-add env bound
                                                       (cons shared label)))
                                         (intset-remove
                                          (intmap-ref label->bound label)
                                          (match (intmap-ref cps label)
                                            (($ $kfun src meta self) self)))
                                         env))
                          shared
                          empty-intmap)))
    (persistent-intmap (rewrite-fun kfun cps env))))

(define (compute-free-vars conts kfun shared)
  "Compute a FUN-LABEL->FREE-VAR... map describing all free variable
references."
  (define (add-def var defs) (intset-add! defs var))
  (define (add-defs vars defs)
    (match vars
      (() defs)
      ((var . vars) (add-defs vars (add-def var defs)))))
  (define (add-use var uses)
    (intset-add! uses var))
  (define (add-uses vars uses)
    (match vars
      (() uses)
      ((var . vars) (add-uses vars (add-use var uses)))))
  (define (visit-nested-funs body)
    (intset-fold
     (lambda (label out)
       (match (intmap-ref conts label)
         (($ $kargs _ _ ($ $continue _ _
                           ($ $fun kfun)))
          (intmap-union out (visit-fun kfun)))
         (($ $kargs _ _ ($ $continue _ _
                           ($ $rec _ _ (($ $fun labels) ...))))
          (let* ((out (fold (lambda (kfun out)
                              (intmap-union out (visit-fun kfun)))
                            out labels))
                 (free (fold (lambda (kfun free)
                               (intset-union free (intmap-ref out kfun)))
                             empty-intset labels)))
            (fold (lambda (kfun out)
                    ;; For functions that share a closure, the free
                    ;; variables for one will be the union of the free
                    ;; variables for all.
                    (if (intmap-ref shared kfun (lambda (_) #f))
                        (intmap-replace out kfun free)
                        out))
                  out
                  labels)))
         (_ out)))
     body
     empty-intmap))
  (define (visit-fun kfun)
    (let* ((body (compute-function-body conts kfun))
           (free (visit-nested-funs body)))
      (call-with-values
          (lambda ()
            (intset-fold
             (lambda (label defs uses)
               (match (intmap-ref conts label)
                 (($ $kargs names vars ($ $continue k src exp))
                  (values
                   (add-defs vars defs)
                   (match exp
                     ((or ($ $const) ($ $prim)) uses)
                     (($ $fun kfun)
                      (intset-union (persistent-intset uses)
                                    (intmap-ref free kfun)))
                     (($ $rec names vars (($ $fun kfun) ...))
                      (fold (lambda (kfun uses)
                              (intset-union (persistent-intset uses)
                                            (intmap-ref free kfun)))
                            uses kfun))
                     (($ $values args)
                      (add-uses args uses))
                     (($ $call proc args)
                      (add-use proc (add-uses args uses)))
                     (($ $callk label proc args)
                      (add-use proc (add-uses args uses)))
                     (($ $branch kt ($ $values (arg)))
                      (add-use arg uses))
                     (($ $branch kt ($ $primcall name args))
                      (add-uses args uses))
                     (($ $primcall name args)
                      (add-uses args uses))
                     (($ $prompt escape? tag handler)
                      (add-use tag uses)))))
                 (($ $kfun src meta self)
                  (values (add-def self defs) uses))
                 (_ (values defs uses))))
             body empty-intset empty-intset))
        (lambda (defs uses)
          (intmap-add free kfun (intset-subtract
                                 (persistent-intset uses)
                                 (persistent-intset defs)))))))
  (visit-fun kfun))

(define (eliminate-closure? label free-vars)
  (eq? (intmap-ref free-vars label) empty-intset))

(define (closure-label label shared bound->label)
  (cond
   ((intmap-ref shared label (lambda (_) #f))
    => (lambda (closure)
         (intmap-ref bound->label closure)))
   (else label)))

(define (closure-alias label well-known free-vars)
  (and (intset-ref well-known label)
       (trivial-intset (intmap-ref free-vars label))))

(define (prune-free-vars free-vars bound->label well-known shared)
  "Given the label->bound-var map @var{free-vars}, remove free variables
that are known functions with zero free variables, and replace
references to well-known functions with one free variable with that free
variable, until we reach a fixed point on the free-vars map."
  (define (prune-free in-label free free-vars)
    (intset-fold (lambda (var free)
                   (match (intmap-ref bound->label var (lambda (_) #f))
                     (#f free)
                     (label
                      (cond
                       ((eliminate-closure? label free-vars)
                        (intset-remove free var))
                       ((closure-alias (closure-label label shared bound->label)
                                       well-known free-vars)
                        => (lambda (alias)
                             ;; If VAR is free in LABEL, then ALIAS must
                             ;; also be free because its definition must
                             ;; precede VAR's definition.
                             (intset-add (intset-remove free var) alias)))
                       (else free)))))
                 free free))
  (fixpoint (lambda (free-vars)
              (intmap-fold (lambda (label free free-vars)
                             (intmap-replace free-vars label
                                             (prune-free label free free-vars)))
                           free-vars
                           free-vars))
            free-vars))

(define (intset-find set i)
  (let lp ((idx 0) (start #f))
    (let ((start (intset-next set start)))
      (cond
       ((not start) (error "not found" set i))
       ((= start i) idx)
       (else (lp (1+ idx) (1+ start)))))))

(define (intset-count set)
  (intset-fold (lambda (_ count) (1+ count)) set 0))

(define (convert-one cps label body free-vars bound->label well-known shared)
  (define (well-known? label)
    (intset-ref well-known label))

(let* ((free (intmap-ref free-vars label))
         (nfree (intset-count free))
         (self-known? (well-known? (closure-label label shared bound->label)))
         (self (match (intmap-ref cps label) (($ $kfun _ _ self) self))))
    (define (convert-arg cps var k)
      "Convert one possibly free variable reference to a bound reference.

If @var{var} is free, it is replaced by a closure reference via a
@code{free-ref} primcall, and @var{k} is called with the new var.
Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
      ;; We know that var is not the name of a well-known function.
      (cond
       ((and=> (intmap-ref bound->label var (lambda (_) #f))
               (lambda (kfun)
                 (and (eq? empty-intset (intmap-ref free-vars kfun))
                      kfun)))
        ;; A not-well-known function with zero free vars.  Copy as a
        ;; constant, relying on the linker to reify just one copy.
        => (lambda (kfun)
             (with-cps cps
               (letv var*)
               (let$ body (k var*))
               (letk k* ($kargs (#f) (var*) ,body))
               (build-term ($continue k* #f ($closure kfun 0))))))
       ((intset-ref free var)
        (match (vector self-known? nfree)
          (#(#t 1)
           ;; A reference to the one free var of a well-known function.
           (with-cps cps
             ($ (k self))))
          (#(#t 2)
           ;; A reference to one of the two free vars in a well-known
           ;; function.
           (let ((op (if (= var (intset-next free)) 'car 'cdr)))
             (with-cps cps
               (letv var*)
               (let$ body (k var*))
               (letk k* ($kargs (#f) (var*) ,body))
               (build-term ($continue k* #f ($primcall op (self)))))))
          (_
           (let ((idx (intset-find free var)))
             (cond
              (self-known?
               (with-cps cps
                 (letv var* u64)
                 (let$ body (k var*))
                 (letk k* ($kargs (#f) (var*) ,body))
                 (letk kunbox ($kargs ('idx) (u64)
                                ($continue k* #f
                                  ($primcall 'vector-ref (self u64)))))
                 ($ (with-cps-constants ((idx idx))
                      (build-term
                        ($continue kunbox #f
                          ($primcall 'scm->u64 (idx))))))))
              (else
               (with-cps cps
                 (letv var*)
                 (let$ body (k var*))
                 (letk k* ($kargs (#f) (var*) ,body))
                 ($ (with-cps-constants ((idx idx))
                      (build-term
                        ($continue k* #f
                          ($primcall 'free-ref (self idx)))))))))))))
       (else
        (with-cps cps
          ($ (k var))))))
  
    (define (convert-args cps vars k)
      "Convert a number of possibly free references to bound references.
@var{k} is called with the bound references, and should return the
term."
      (match vars
        (()
         (with-cps cps
           ($ (k '()))))
        ((var . vars)
         (convert-arg cps var
           (lambda (cps var)
             (convert-args cps vars
               (lambda (cps vars)
                 (with-cps cps
                   ($ (k (cons var vars)))))))))))
  
    (define (allocate-closure cps k src label known? nfree)
      "Allocate a new closure, and pass it to $var{k}."
      (match (vector known? nfree)
        (#(#f nfree)
         ;; The call sites cannot be enumerated; allocate a closure.
         (with-cps cps
           (build-term ($continue k src ($closure label nfree)))))
        (#(#t 2)
         ;; Well-known closure with two free variables; the closure is a
         ;; pair.
         (with-cps cps
           ($ (with-cps-constants ((false #f))
                (build-term
                  ($continue k src ($primcall 'cons (false false))))))))
        ;; Well-known callee with more than two free variables; the closure
        ;; is a vector.
        (#(#t nfree)
         (unless (> nfree 2)
           (error "unexpected well-known nullary, unary, or binary closure"))
         (with-cps cps
           ($ (with-cps-constants ((nfree nfree)
                                   (false #f))
                (letv u64)
                (letk kunbox ($kargs ('nfree) (u64)
                               ($continue k src
                                 ($primcall 'make-vector (u64 false)))))
                (build-term
                  ($continue kunbox src ($primcall 'scm->u64 (nfree))))))))))

(define (init-closure cps k src var known? free)
      "Initialize the free variables @var{closure-free} in a closure
bound to @var{var}, and continue to @var{k}."
      (match (vector known? (intset-count free))
        ;; Well-known callee with zero or one free variables; no
        ;; initialization necessary.
        (#(#t (or 0 1))
         (with-cps cps
           (build-term ($continue k src ($values ())))))
        ;; Well-known callee with two free variables; do a set-car! and
        ;; set-cdr!.
        (#(#t 2)
         (let* ((free0 (intset-next free))
                (free1 (intset-next free (1+ free0))))
           (convert-arg cps free0
             (lambda (cps v0)
               (with-cps cps
                 (let$ body
                       (convert-arg free1
                           (lambda (cps v1)
                             (with-cps cps
                               (build-term
                                 ($continue k src
                                   ($primcall 'set-cdr! (var v1))))))))
                 (letk kcdr ($kargs () () ,body))
                 (build-term
                   ($continue kcdr src ($primcall 'set-car! (var v0)))))))))
        ;; Otherwise residualize a sequence of vector-set! or free-set!,
        ;; depending on whether the callee is well-known or not.
        (_
         (let lp ((cps cps) (prev #f) (idx 0))
           (match (intset-next free prev)
             (#f (with-cps cps
                   (build-term ($continue k src ($values ())))))
             (v (with-cps cps
                  (let$ body (lp (1+ v) (1+ idx)))
                  (letk k ($kargs () () ,body))
                  ($ (convert-arg v
                       (lambda (cps v)
                         (cond
                          (known?
                           (with-cps cps
                             (letv u64)
                             (letk kunbox
                                   ($kargs ('idx) (u64)
                                     ($continue k src
                                       ($primcall 'vector-set! (var u64 v)))))
                             ($ (with-cps-constants ((idx idx))
                                  (build-term
                                    ($continue kunbox src
                                      ($primcall 'scm->u64 (idx))))))))
                          (else
                           (with-cps cps
                             ($ (with-cps-constants ((idx idx))
                                  (build-term
                                    ($continue k src
                                      ($primcall 'free-set!
                                                 (var idx v)))))))))))))))))))

(define (make-single-closure cps k src kfun)
      (let ((free (intmap-ref free-vars kfun)))
        (match (vector (well-known? kfun) (intset-count free))
          (#(#f 0)
           (with-cps cps
             (build-term ($continue k src ($closure kfun 0)))))
          (#(#t 0)
           (with-cps cps
             (build-term ($continue k src ($const #f)))))
          (#(#t 1)
           ;; A well-known closure of one free variable is replaced
           ;; at each use with the free variable itself, so we don't
           ;; need a binding at all; and yet, the continuation
           ;; expects one value, so give it something.  DCE should
           ;; clean up later.
           (with-cps cps
             (build-term ($continue k src ($const #f)))))
          (#(well-known? nfree)
           ;; A bit of a mess, but beta conversion should remove the
           ;; final $values if possible.
           (with-cps cps
             (letv closure)
             (letk k* ($kargs () () ($continue k src ($values (closure)))))
             (let$ init (init-closure k* src closure well-known? free))
             (letk knew ($kargs (#f) (closure) ,init))
             ($ (allocate-closure knew src kfun well-known? nfree)))))))

;; The callee is known, but not necessarily well-known.
    (define (convert-known-proc-call cps k src label closure args)
      (define (have-closure cps closure)
        (convert-args cps args
          (lambda (cps args)
            (with-cps cps
              (build-term
                ($continue k src ($callk label closure args)))))))
      (cond
       ((eq? (intmap-ref free-vars label) empty-intset)
        ;; Known call, no free variables; no closure needed.
        ;; Pass #f as closure argument.
        (with-cps cps
          ($ (with-cps-constants ((false #f))
               ($ (have-closure false))))))
       ((and (well-known? (closure-label label shared bound->label))
             (trivial-intset (intmap-ref free-vars label)))
        ;; Well-known closures with one free variable are
        ;; replaced at their use sites by uses of the one free
        ;; variable.
        => (lambda (var)
             (convert-arg cps var have-closure)))
       (else
        ;; Otherwise just load the proc.
        (convert-arg cps closure have-closure))))

(define (visit-term cps term)
      (match term
        (($ $continue k src (or ($ $const) ($ $prim)))
         (with-cps cps
           term))

(($ $continue k src ($ $fun kfun))
         (with-cps cps
           ($ (make-single-closure k src kfun))))

;; Remove letrec.
        (($ $continue k src ($ $rec names vars (($ $fun kfuns) ...)))
         (match (vector names vars kfuns)
           (#(() () ())
            ;; Trivial empty case.
            (with-cps cps
              (build-term ($continue k src ($values ())))))
           (#((name) (var) (kfun))
            ;; Trivial single case.  We have already proven that K has
            ;; only LABEL as its predecessor, so we have been able
            ;; already to rewrite free references to the bound name with
            ;; the self name.
            (with-cps cps
              ($ (make-single-closure k src kfun))))
           (#(_ _ (kfun0 . _))
            ;; A non-trivial strongly-connected component.  Does it have
            ;; a shared closure?
            (match (intmap-ref shared kfun0 (lambda (_) #f))
              (#f
               ;; Nope.  Allocate closures for each function.
               (let lp ((cps (match (intmap-ref cps k)
                               ;; Steal declarations from the continuation.
                               (($ $kargs names vals body)
                                (intmap-replace cps k
                                                (build-cont
                                                  ($kargs () () ,body))))))
                        (in (map vector names vars kfuns))
                        (init (lambda (cps)
                                (with-cps cps
                                  (build-term
                                    ($continue k src ($values ())))))))
                 (match in
                   (() (init cps))
                   ((#(name var kfun) . in)
                    (let* ((known? (well-known? kfun))
                           (free (intmap-ref free-vars kfun))
                           (nfree (intset-count free)))
                      (define (next-init cps)
                        (with-cps cps
                          (let$ body (init))
                          (letk k ($kargs () () ,body))
                          ($ (init-closure k src var known? free))))
                      (with-cps cps
                        (let$ body (lp in next-init))
                        (letk k ($kargs (name) (var) ,body))
                        ($ (allocate-closure k src kfun known? nfree))))))))
              (shared
               ;; If shared is in the bound->var map, that means one of
               ;; the functions is not well-known.  Otherwise use kfun0
               ;; as the function label, but just so make-single-closure
               ;; can find the free vars, not for embedding in the
               ;; closure.
               (let* ((kfun (intmap-ref bound->label shared (lambda (_) kfun0)))
                      (cps (match (intmap-ref cps k)
                             ;; Make continuation declare only the shared
                             ;; closure.
                             (($ $kargs names vals body)
                              (intmap-replace cps k
                                              (build-cont
                                                ($kargs (#f) (shared) ,body)))))))
                 (with-cps cps
                   ($ (make-single-closure k src kfun)))))))))

(($ $continue k src ($ $call proc args))
         (match (intmap-ref bound->label proc (lambda (_) #f))
           (#f
            (convert-arg cps proc
              (lambda (cps proc)
                (convert-args cps args
                  (lambda (cps args)
                    (with-cps cps
                      (build-term
                        ($continue k src ($call proc args)))))))))
           (label
            (convert-known-proc-call cps k src label proc args))))

(($ $continue k src ($ $callk label proc args))
         (convert-known-proc-call cps k src label proc args))

(($ $continue k src ($ $primcall name args))
         (convert-args cps args
           (lambda (cps args)
             (with-cps cps
               (build-term
                 ($continue k src ($primcall name args)))))))

(($ $continue k src ($ $branch kt ($ $primcall name args)))
         (convert-args cps args
           (lambda (cps args)
             (with-cps cps
               (build-term
                 ($continue k src
                   ($branch kt ($primcall name args))))))))

(($ $continue k src ($ $branch kt ($ $values (arg))))
         (convert-arg cps arg
           (lambda (cps arg)
             (with-cps cps
               (build-term
                 ($continue k src
                   ($branch kt ($values (arg)))))))))

(($ $continue k src ($ $values args))
         (convert-args cps args
           (lambda (cps args)
             (with-cps cps
               (build-term
                 ($continue k src ($values args)))))))

(($ $continue k src ($ $prompt escape? tag handler))
         (convert-arg cps tag
           (lambda (cps tag)
             (with-cps cps
               (build-term
                 ($continue k src
                   ($prompt escape? tag handler)))))))))

(intset-fold (lambda (label cps)
                   (match (intmap-ref cps label (lambda (_) #f))
                     (($ $kargs names vars term)
                      (with-cps cps
                        (let$ term (visit-term term))
                        (setk label ($kargs names vars ,term))))
                     (_ cps)))
                 body
                 cps)))

(define (convert-closures cps)
  "Convert free reference in @var{cps} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
  (let* ((kfun 0) ;; Ass-u-me.
         ;; label -> body-label...
         (functions (compute-function-bodies cps kfun))
         (cps (filter-reachable cps functions))
         ;; label -> bound-var...
         (label->bound (compute-function-names cps functions))
         ;; bound-var -> label
         (bound->label (invert-partition label->bound))
         ;; label...
         (well-known (compute-well-known-functions cps bound->label))
         ;; label -> closure-var
         (shared (compute-shared-closures cps well-known))
         (cps (rewrite-shared-closure-calls cps functions label->bound shared
                                            kfun))
         ;; label -> free-var...
         (free-vars (compute-free-vars cps kfun shared))
         (free-vars (prune-free-vars free-vars bound->label well-known shared)))
    (let ((free-in-program (intmap-ref free-vars kfun)))
      (unless (eq? empty-intset free-in-program)
        (error "Expected no free vars in program" free-in-program)))
    (with-fresh-name-state cps
      (persistent-intmap
       (intmap-fold
        (lambda (label body cps)
          (convert-one cps label body free-vars bound->label well-known shared))
        functions
        cps)))))

;;; Local Variables:
;;; eval: (put 'convert-arg 'scheme-indent-function 2)
;;; eval: (put 'convert-args 'scheme-indent-function 2)
;;; End:

${this.title}

Code Editor : closure-conversion.scm