mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 06:20:23 +02:00
Code Activity

Replace $letrec with $rec

Browse source 
* module/language/cps.scm ($rec): Replace $letrec with $rec, which is an
  expression, not a term.  This means that the names bound by the letrec
  appear twice: once in the $rec term, and once in the continuation.
  This is not very elegant, but the situation is better than it was
  before.  Adapt all callers.

* doc/ref/compiler.texi (CPS in Guile): Incomplete documentation
  updates.  I'll update these later when the IL settles down.
This commit is contained in:
Andy Wingo 2015-04-01 09:51:13 +02:00
parent 4ce1857019
commit 34ff3af9f0
21 changed files with 361 additions and 384 deletions
Download patch file Download diff file Expand all files Collapse all files

114
doc/ref/compiler.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 @c Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015
@c Free Software Foundation, Inc. @c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@ -659,14 +659,25 @@ and @var{syms} are lists of symbols, and @var{funs} is a list of
@code{$fun} values. @var{syms} are globally unique. @code{$fun} values. @var{syms} are globally unique.
@end deftp @end deftp
A higher-order CPS program is a @code{$cont} containing a @code{$kfun}
(see below), and the @code{$kfun} which contains clauses and those
clauses contain terms. A first-order CPS program, on the other hand, is
the result of closure conversion and does not contain nested functions.
Closure conversion lifts code for all functions up to the top, collects
their entry continuations as a list of @code{$cont} @code{$kfun}
instances and binds them in a @code{$program}.
@deftp {CPS Term} $program funs
A first-order CPS term declaring a recursive scope for first-order
functions in a compilation unit. @var{funs} is a list of @code{$cont}
@code{$kfun} instances. The first entry in the list is the entry
function for the program.
@end deftp
Here is an inventory of the kinds of expressions in Guile's CPS Here is an inventory of the kinds of expressions in Guile's CPS
language. Recall that all expressions are wrapped in a @code{$continue} language. Recall that all expressions are wrapped in a @code{$continue}
term which specifies their continuation. term which specifies their continuation.
@deftp {CPS Expression} $void
Continue with the unspecified value.
@end deftp
@deftp {CPS Expression} $const val @deftp {CPS Expression} $const val
Continue with the constant value @var{val}. Continue with the constant value @var{val}.
@end deftp @end deftp
@ -676,16 +687,27 @@ Continue with the procedure that implements the primitive operation
named by @var{name}. named by @var{name}.
@end deftp @end deftp
@deftp {CPS Expression} $fun src meta free body @deftp {CPS Expression} $fun free body
Continue with a procedure. @var{src} identifies the source information Continue with a procedure. @var{free} is a list of free variables
for the procedure declaration, and @var{meta} is the metadata alist as accessed by the procedure. Early CPS uses an empty list for @var{free};
described above in Tree-IL's @code{<lambda>}. @var{free} is a list of only after closure conversion is it correctly populated. Finally,
free variables accessed by the procedure. Early CPS uses an empty list @var{body} is the @code{$kfun} @code{$cont} of the procedure entry.
for @var{free}; only after closure conversion is it correctly populated.
Finally, @var{body} is the @code{$kentry} @code{$cont} of the procedure
entry.
@end deftp @end deftp
@code{$fun} is part of higher-level CPS. After closure conversion,
@code{$fun} instances are given a concrete representation. By default,
a closure is represented as an object built by a @code{$closure}
expression
@deftp {CPS Expression} $closure label nfree
Build a closure that joins the code at the continuation named
@var{label} with space for @var{nfree} free variables. The variables
will be initialized later via @code{free-variable-set!} primcalls.
@end deftp
If the closure can be proven to never escape its scope then other
lighter-weight representations can be chosen.
@deftp {CPS Expression} $call proc args @deftp {CPS Expression} $call proc args
@deftpx {CPS Expression} $callk label proc args @deftpx {CPS Expression} $callk label proc args
Call @var{proc} with the arguments @var{args}, and pass all values to Call @var{proc} with the arguments @var{args}, and pass all values to
@ -712,6 +734,21 @@ for details.
Pass the values named by the list @var{args} to the continuation. Pass the values named by the list @var{args} to the continuation.
@end deftp @end deftp
@deftp {CPS Expression} $branch kt exp
Evaluate the branching expression @var{exp}, and continue to @var{kt}
with zero values if the test evaluates to true. Otherwise, in the false
Only certain expressions are valid in a @var{$branch}. Compiling a
@code{$branch} avoids allocating space for the test variable, so the
expression should be evaluatable without temporary values. In practice
this condition is true for @code{$primcall}s to @code{null?}, @code{=},
and similar primitives that have corresponding @code{br-if-@var{foo}} VM
operations; see the source code for full details. When in doubt, bind
the test expression to a variable, and reference the variable in the
@code{$branch} expression. The optimizer should inline the reference if
possible.
@end deftp
@deftp {CPS Expression} $prompt escape? tag handler @deftp {CPS Expression} $prompt escape? tag handler
Push a prompt on the stack identified by the variable name @var{tag}, Push a prompt on the stack identified by the variable name @var{tag},
which may be escape-only if @var{escape?} is true, and continue with which may be escape-only if @var{escape?} is true, and continue with
@ -741,32 +778,10 @@ names @var{names}, and then evaluate the sub-term @var{body}.
@end deftp @end deftp
Variable names (the names in the @var{syms} of a @code{$kargs}) should Variable names (the names in the @var{syms} of a @code{$kargs}) should
be globally unique, and also disjoint from continuation labels. To bind be unique among all other variable names. To bind a value to a variable
a value to a variable and then evaluate some term, you would continue and then evaluate some term, you would continue with the value to a
with the value to a @code{$kargs} that declares one variable. The bound @code{$kargs} that declares one variable. The bound value would then be
value would then be available for use within the body of the available for use within the body of the @code{$kargs}.
@code{$kargs}.
@deftp {CPS Continuation} $kif kt kf
Receive one value. If it is true for the purposes of Scheme, branch to
the continuation labelled @var{kt}, passing no values; otherwise, branch
to @var{kf}.
@end deftp
For internal reasons, only certain terms may continue to a @code{$kif}.
Compiling @code{$kif} avoids allocating space for the test variable, so
it needs to be preceded by expressions that can test-and-branch without
temporary values. In practice this condition is true for
@code{$primcall}s to @code{null?}, @code{=}, and similar primitives that
have corresponding @code{br-if-@var{foo}} VM operations; see the source
code for full details. When in doubt, bind the test expression to a
variable, and continue to the @code{$kif} with a @code{$values}
expression. The optimizer should elide the @code{$values} if it is not
needed.
Calls out to other functions need to be wrapped in a @code{$kreceive}
continuation in order to adapt the returned values to their uses in the
calling function, if any.
@deftp {CPS Continuation} $kreceive arity k @deftp {CPS Continuation} $kreceive arity k
Receive values on the stack. Parse them according to @var{arity}, and Receive values on the stack. Parse them according to @var{arity}, and
@ -794,25 +809,30 @@ Note that all of these names with the exception of the @var{var}s in the
Additionally, there are three specific kinds of continuations that can Additionally, there are three specific kinds of continuations that can
only be declared at function entries. only be declared at function entries.
@deftp {CPS Continuation} $kentry self tail clauses @deftp {CPS Continuation} $kfun src meta self tail clauses
Declare a function entry. @var{self} is a variable bound to the Declare a function entry. @var{src} is the source information for the
procedure being called, and which may be used for self-references. procedure declaration, and @var{meta} is the metadata alist as described
above in Tree-IL's @code{<lambda>}. @var{self} is a variable bound to
the procedure being called, and which may be used for self-references.
@var{tail} declares the @code{$cont} wrapping the @code{$ktail} for this @var{tail} declares the @code{$cont} wrapping the @code{$ktail} for this
function, corresponding to the function's tail continuation. function, corresponding to the function's tail continuation.
@var{clauses} is a list of @code{$kclause} @code{$cont} instances. @var{clause} is the first @code{$kclause} @code{$cont} instance for the
first @code{case-lambda} clause in the function, or otherwise @code{#f}.
@end deftp @end deftp
@deftp {CPS Continuation} $ktail @deftp {CPS Continuation} $ktail
A tail continuation. A tail continuation.
@end deftp @end deftp
@deftp {CPS Continuation} $kclause arity cont @deftp {CPS Continuation} $kclause arity cont alternate
A clause of a function with a given arity. Applications of a function A clause of a function with a given arity. Applications of a function
with a compatible set of actual arguments will continue to @var{cont}, a with a compatible set of actual arguments will continue to @var{cont}, a
@code{$kargs} @code{$cont} instance representing the clause body. @code{$kargs} @code{$cont} instance representing the clause body. If
the arguments are incompatible, control proceeds to @var{alternate},
which is a @code{$kclause} @code{$cont} for the next clause, or
@code{#f} if there is no next clause.
@end deftp @end deftp
@node Building CPS @node Building CPS
@subsubsection Building CPS @subsubsection Building CPS
@ -836,8 +856,8 @@ see the specifications below for full details.
@deffnx {Scheme Syntax} build-cps-term ($letk (cont ...) term) @deffnx {Scheme Syntax} build-cps-term ($letk (cont ...) term)
@deffnx {Scheme Syntax} build-cps-term ($letrec names syms funs term) @deffnx {Scheme Syntax} build-cps-term ($letrec names syms funs term)
@deffnx {Scheme Syntax} build-cps-term ($continue k src exp) @deffnx {Scheme Syntax} build-cps-term ($continue k src exp)
@deffnx {Scheme Syntax} build-cps-term ($program conts)
@deffnx {Scheme Syntax} build-cps-exp ,val @deffnx {Scheme Syntax} build-cps-exp ,val
@deffnx {Scheme Syntax} build-cps-exp ($void)
@deffnx {Scheme Syntax} build-cps-exp ($const val) @deffnx {Scheme Syntax} build-cps-exp ($const val)
@deffnx {Scheme Syntax} build-cps-exp ($prim name) @deffnx {Scheme Syntax} build-cps-exp ($prim name)
@deffnx {Scheme Syntax} build-cps-exp ($fun src meta free body) @deffnx {Scheme Syntax} build-cps-exp ($fun src meta free body)

52
module/language/cps.scm
View file

@ -113,7 +113,7 @@
make-$arity make-$arity
;; Terms. ;; Terms.
$letk $continue $letrec $letk $continue
;; Continuations. ;; Continuations.
$cont $cont
@ -122,7 +122,7 @@
$kreceive $kargs $kfun $ktail $kclause $kreceive $kargs $kfun $ktail $kclause
;; Expressions. ;; Expressions.
$const $prim $fun $closure $branch $const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt $call $callk $primcall $values $prompt
;; First-order CPS root. ;; First-order CPS root.
@ -177,7 +177,6 @@
;; Terms. ;; Terms.
(define-cps-type $letk conts body) (define-cps-type $letk conts body)
(define-cps-type $continue k src exp) (define-cps-type $continue k src exp)
(define-cps-type $letrec names syms funs body) ; Higher-order.
;; Continuations ;; Continuations
(define-cps-type $cont k cont) (define-cps-type $cont k cont)
@ -191,6 +190,7 @@
(define-cps-type $const val) (define-cps-type $const val)
(define-cps-type $prim name) (define-cps-type $prim name)
(define-cps-type $fun free body) ; Higher-order. (define-cps-type $fun free body) ; Higher-order.
(define-cps-type $rec names syms funs) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order. (define-cps-type $closure label nfree) ; First-order.
(define-cps-type $branch k exp) (define-cps-type $branch k exp)
(define-cps-type $call proc args) (define-cps-type $call proc args)
@ -263,12 +263,13 @@
(define-syntax build-cps-exp (define-syntax build-cps-exp
(syntax-rules (unquote (syntax-rules (unquote
$const $prim $fun $closure $branch $const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt) $call $callk $primcall $values $prompt)
((_ (unquote exp)) exp) ((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val)) ((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name)) ((_ ($prim name)) (make-$prim name))
((_ ($fun free body)) (make-$fun free (build-cps-cont body))) ((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
((_ ($closure k nfree)) (make-$closure k nfree)) ((_ ($closure k nfree)) (make-$closure k nfree))
((_ ($call proc (unquote args))) (make-$call proc args)) ((_ ($call proc (unquote args))) (make-$call proc args))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
@ -287,7 +288,7 @@
(make-$prompt escape? tag handler)))) (make-$prompt escape? tag handler))))
(define-syntax build-cps-term (define-syntax build-cps-term
(syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue) (syntax-rules (unquote $letk $letk* $letconst $program $continue)
((_ (unquote exp)) ((_ (unquote exp))
exp) exp)
((_ ($letk (unquote conts) body)) ((_ ($letk (unquote conts) body))
@ -308,8 +309,6 @@
($continue kconst (let ((props (source-properties val))) ($continue kconst (let ((props (source-properties val)))
(and (pair? props) props)) (and (pair? props) props))
($const val)))))) ($const val))))))
((_ ($letrec names gensyms funs body))
(make-$letrec names gensyms funs (build-cps-term body)))
((_ ($program (unquote conts))) ((_ ($program (unquote conts)))
(make-$program conts)) (make-$program conts))
((_ ($program (cont ...))) ((_ ($program (cont ...)))
@ -386,9 +385,8 @@
(build-cps-exp ($fun free ,(parse-cps body)))) (build-cps-exp ($fun free ,(parse-cps body))))
(('closure k nfree) (('closure k nfree)
(build-cps-exp ($closure k nfree))) (build-cps-exp ($closure k nfree)))
(('letrec ((name sym fun) ...) body) (('rec (name sym fun) ...)
(build-cps-term (build-cps-exp ($rec name sym (map parse-cps fun))))
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
(('program (cont ...)) (('program (cont ...))
(build-cps-term ($program ,(map parse-cps cont)))) (build-cps-term ($program ,(map parse-cps cont))))
(('call proc arg ...) (('call proc arg ...)
@ -445,11 +443,10 @@
`(fun ,free ,(unparse-cps body))) `(fun ,free ,(unparse-cps body)))
(($ $closure k nfree) (($ $closure k nfree)
`(closure ,k ,nfree)) `(closure ,k ,nfree))
(($ $letrec names syms funs body) (($ $rec names syms funs)
`(letrec ,(map (lambda (name sym fun) `(rec ,@(map (lambda (name sym fun)
(list name sym (unparse-cps fun))) (list name sym (unparse-cps fun)))
names syms funs) names syms funs)))
,(unparse-cps body)))
(($ $program conts) (($ $program conts)
`(program ,(map unparse-cps conts))) `(program ,(map unparse-cps conts)))
(($ $call proc args) (($ $call proc args)
@ -509,15 +506,13 @@
(($ $continue k src exp) (($ $continue k src exp)
(match exp (match exp
(($ $fun) (fun-folder exp seed ...)) (($ $fun) (fun-folder exp seed ...))
(_ (values seed ...)))) (($ $rec names syms funs)
(let lp ((funs funs) (seed seed) ...)
(($ $letrec names syms funs body) (if (null? funs)
(let-values (((seed ...) (term-folder body seed ...))) (values seed ...)
(let lp ((funs funs) (seed seed) ...) (let-values (((seed ...) (fun-folder (car funs) seed ...)))
(if (null? funs) (lp (cdr funs) seed ...)))))
(values seed ...) (_ (values seed ...))))))
(let-values (((seed ...) (fun-folder (car funs) seed ...)))
(lp (cdr funs) seed ...))))))))
(cont-folder cont seed ...))) (cont-folder cont seed ...)))
@ -541,7 +536,6 @@
((cont . conts) ((cont . conts)
(let-values (((seed ...) (cont-folder cont seed ...))) (let-values (((seed ...) (cont-folder cont seed ...)))
(lp conts seed ...))))))) (lp conts seed ...)))))))
(($ $letrec names syms funs body) (term-folder body seed ...))
(_ (values seed ...)))) (_ (values seed ...))))
(define (clause-folder clause seed ...) (define (clause-folder clause seed ...)
(match clause (match clause
@ -567,12 +561,7 @@
(values (max label max-label) (values (max label max-label)
(match cont (match cont
(($ $kargs names vars body) (($ $kargs names vars body)
(let lp ((body body) (max-var (fold max max-var vars))) (fold max max-var vars))
(match body
(($ $letk conts body) (lp body max-var))
(($ $letrec names vars funs body)
(lp body (fold max max-var vars)))
(_ max-var))))
(($ $kfun src meta self) (($ $kfun src meta self)
(max self max-var)) (max self max-var))
(_ max-var)))) (_ max-var))))
@ -612,7 +601,6 @@
(let lp ((body body)) (let lp ((body body))
(match body (match body
(($ $letk conts body) (lp body)) (($ $letk conts body) (lp body))
(($ $letrec names vars funs body) (lp body))
(($ $continue k src exp) (($ $continue k src exp)
(match exp (match exp
(($ $prompt escape? tag handler) (proc k handler)) (($ $prompt escape? tag handler) (proc k handler))

15
module/language/cps/arities.scm
View file

@ -40,13 +40,6 @@
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body))) ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs body)
($letrec names syms (map (lambda (fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun free ,(fix-arities* body dfg)))))
funs)
,(visit-term body)))
(($ $continue k src exp) (($ $continue k src exp)
,(visit-exp k src exp)))) ,(visit-exp k src exp))))
@ -143,6 +136,14 @@
(($ $fun free body) (($ $fun free body)
,(adapt-exp 1 k src (build-cps-exp ,(adapt-exp 1 k src (build-cps-exp
($fun free ,(fix-arities* body dfg))))) ($fun free ,(fix-arities* body dfg)))))
(($ $rec names syms funs)
;; Assume $rec expressions have the correct arity.
($continue k src
($rec names syms (map (lambda (fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun free ,(fix-arities* body dfg)))))
funs))))
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that ;; In general, calls have unknown return arity. For that
;; reason every non-tail call has a $kreceive continuation to ;; reason every non-tail call has a $kreceive continuation to

90
module/language/cps/closure-conversion.scm
View file

@ -23,15 +23,16 @@
;;; make-closure primcalls, and free variables are referenced through ;;; make-closure primcalls, and free variables are referenced through
;;; the closure. ;;; the closure.
;;; ;;;
;;; Closure conversion also removes any $letrec forms that contification ;;; Closure conversion also removes any $rec expressions that
;;; did not handle. See (language cps) for a further discussion of ;;; contification did not handle. See (language cps) for a further
;;; $letrec. ;;; discussion of $rec.
;;; ;;;
;;; Code: ;;; Code:
(define-module (language cps closure-conversion) (define-module (language cps closure-conversion)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold #:use-module ((srfi srfi-1) #:select (fold
filter-map
lset-union lset-difference lset-union lset-difference
list-index)) list-index))
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
@ -48,7 +49,8 @@
(let ((bound-vars (make-hash-table)) (let ((bound-vars (make-hash-table))
(free-vars (make-hash-table)) (free-vars (make-hash-table))
(named-funs (make-hash-table)) (named-funs (make-hash-table))
(well-known-vars (make-bitvector (var-counter) #t))) (well-known-vars (make-bitvector (var-counter) #t))
(letrec-conts (make-hash-table)))
(define (add-named-fun! var cont) (define (add-named-fun! var cont)
(hashq-set! named-funs var cont) (hashq-set! named-funs var cont)
(match cont (match cont
@ -97,13 +99,6 @@
(union (visit-cont cont bound) free)) (union (visit-cont cont bound) free))
(visit-term body bound) (visit-term body bound)
conts)) conts))
(($ $letrec names vars (($ $fun () cont) ...) body)
(let ((bound (append vars bound)))
(for-each add-named-fun! vars cont)
(fold (lambda (cont free)
(union (visit-cont cont bound) free))
(visit-term body bound)
cont)))
(($ $continue k src ($ $fun () body)) (($ $continue k src ($ $fun () body))
(match (lookup-predecessors k dfg) (match (lookup-predecessors k dfg)
((_) (match (lookup-cont k dfg) ((_) (match (lookup-cont k dfg)
@ -111,6 +106,14 @@
(add-named-fun! var body)))) (add-named-fun! var body))))
(_ #f)) (_ #f))
(visit-cont body bound)) (visit-cont body bound))
(($ $continue k src ($ $rec names vars (($ $fun () cont) ...)))
(hashq-set! letrec-conts k (lookup-cont k dfg))
(let ((bound (append vars bound)))
(for-each add-named-fun! vars cont)
(fold (lambda (cont free)
(union (visit-cont cont bound) free))
'()
cont)))
(($ $continue k src exp) (($ $continue k src exp)
(visit-exp exp bound)))) (visit-exp exp bound))))
(define (visit-exp exp bound) (define (visit-exp exp bound)
@ -138,7 +141,8 @@
(let ((free (visit-cont exp '()))) (let ((free (visit-cont exp '())))
(unless (null? free) (unless (null? free)
(error "Expected no free vars in toplevel thunk" free exp)) (error "Expected no free vars in toplevel thunk" free exp))
(values bound-vars free-vars named-funs (compute-well-known-labels))))) (values bound-vars free-vars named-funs (compute-well-known-labels)
letrec-conts))))
(define (prune-free-vars free-vars named-funs well-known var-aliases) (define (prune-free-vars free-vars named-funs well-known var-aliases)
(define (well-known? label) (define (well-known? label)
@ -229,7 +233,8 @@
(vector-set! var-aliases var alias)))))) (vector-set! var-aliases var alias))))))
named-funs))) named-funs)))
(define (convert-one bound label fun free-vars named-funs well-known aliases) (define (convert-one bound label fun free-vars named-funs well-known aliases
letrec-conts)
(define (well-known? label) (define (well-known? label)
(bitvector-ref well-known label)) (bitvector-ref well-known label))
@ -422,31 +427,18 @@ bound to @var{var}, and continue with @var{body}."
(label ($kclause ,arity ,(visit-cont body) (label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate))))) ,(and alternate (visit-cont alternate)))))
(($ $cont) ,cont))) (($ $cont) ,cont)))
(define (maybe-visit-cont cont)
(match cont
;; We will inline the $kargs that binds letrec vars in place of
;; the $rec expression.
(($ $cont label)
(and (not (hashq-ref letrec-conts label))
(visit-cont cont)))))
(define (visit-term term) (define (visit-term term)
(match term (match term
(($ $letk conts body) (($ $letk conts body)
(build-cps-term (build-cps-term
($letk ,(map visit-cont conts) ,(visit-term body)))) ($letk ,(filter-map maybe-visit-cont conts) ,(visit-term body))))
;; Remove letrec.
(($ $letrec names vars funs body)
(let lp ((in (map list names vars funs))
(bindings (lambda (body) body))
(body (visit-term body)))
(match in
(() (bindings body))
(((name var ($ $fun ()
(and fun-body
($ $cont kfun ($ $kfun src))))) . in)
(let ((fun-free (hashq-ref free-vars kfun)))
(lp in
(lambda (body)
(allocate-closure
src name var kfun (well-known? kfun) fun-free
(bindings body)))
(init-closure
src var (well-known? kfun) fun-free
body)))))))
(($ $continue k src (or ($ $const) ($ $prim))) (($ $continue k src (or ($ $const) ($ $prim)))
term) term)
@ -475,6 +467,31 @@ bound to @var{var}, and continue with @var{body}."
src var (well-known? kfun) fun-free src var (well-known? kfun) fun-free
(build-cps-term ($continue k src ($values (var))))))))))) (build-cps-term ($continue k src ($values (var)))))))))))
;; Remove letrec.
(($ $continue k src ($ $rec names vars funs))
(let lp ((in (map list names vars funs))
(bindings (lambda (body) body))
(body (match (hashq-ref letrec-conts k)
;; Remove these letrec bindings, as we're
;; going to inline the body after building
;; each closure separately.
(($ $kargs names syms body)
(visit-term body)))))
(match in
(() (bindings body))
(((name var ($ $fun ()
(and fun-body
($ $cont kfun ($ $kfun src))))) . in)
(let ((fun-free (hashq-ref free-vars kfun)))
(lp in
(lambda (body)
(allocate-closure
src name var kfun (well-known? kfun) fun-free
(bindings body)))
(init-closure
src var (well-known? kfun) fun-free
body)))))))
(($ $continue k src ($ $call proc args)) (($ $continue k src ($ $call proc args))
(match (hashq-ref named-funs proc) (match (hashq-ref named-funs proc)
(($ $cont kfun) (($ $cont kfun)
@ -534,7 +551,7 @@ and allocate and initialize flat closures."
(let ((dfg (compute-dfg fun))) (let ((dfg (compute-dfg fun)))
(with-fresh-name-state-from-dfg dfg (with-fresh-name-state-from-dfg dfg
(call-with-values (lambda () (analyze-closures fun dfg)) (call-with-values (lambda () (analyze-closures fun dfg))
(lambda (bound-vars free-vars named-funs well-known) (lambda (bound-vars free-vars named-funs well-known letrec-conts)
(let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <)) (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
(aliases (make-vector (var-counter) #f))) (aliases (make-vector (var-counter) #f)))
(prune-free-vars free-vars named-funs well-known aliases) (prune-free-vars free-vars named-funs well-known aliases)
@ -543,5 +560,6 @@ and allocate and initialize flat closures."
,(map (lambda (label) ,(map (lambda (label)
(convert-one (hashq-ref bound-vars label) label (convert-one (hashq-ref bound-vars label) label
(lookup-cont label dfg) (lookup-cont label dfg)
free-vars named-funs well-known aliases)) free-vars named-funs well-known aliases
letrec-conts))
labels))))))))) labels)))))))))

7
module/language/cps/constructors.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -46,9 +46,6 @@
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body))) ,(visit-term body)))
(($ $letrec names syms funs body)
($letrec names syms (map visit-fun funs)
,(visit-term body)))
(($ $continue k src ($ $primcall 'list args)) (($ $continue k src ($ $primcall 'list args))
,(let-fresh (kvalues) (val) ,(let-fresh (kvalues) (val)
(build-cps-term (build-cps-term
@ -91,6 +88,8 @@
($primcall 'make-vector (len init)))))))) ($primcall 'make-vector (len init))))))))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun))) ($continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
($continue k src ($rec names syms (map visit-fun funs))))
(($ $continue) (($ $continue)
,term))) ,term)))
(define (visit-fun fun) (define (visit-fun fun)

163
module/language/cps/contification.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -43,14 +43,11 @@
(scope-table (make-hash-table)) (scope-table (make-hash-table))
(call-substs '()) (call-substs '())
(cont-substs '()) (cont-substs '())
(fun-elisions '())
(cont-splices (make-hash-table))) (cont-splices (make-hash-table)))
(define (subst-call! sym arities body-ks) (define (subst-call! sym arities body-ks)
(set! call-substs (acons sym (map cons arities body-ks) call-substs))) (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
(define (subst-return! old-tail new-tail) (define (subst-return! old-tail new-tail)
(set! cont-substs (acons old-tail new-tail cont-substs))) (set! cont-substs (acons old-tail new-tail cont-substs)))
(define (elide-function! k cont)
(set! fun-elisions (acons k cont fun-elisions)))
(define (splice-conts! scope conts) (define (splice-conts! scope conts)
(for-each (match-lambda (for-each (match-lambda
(($ $cont k) (hashq-set! scope-table k scope))) (($ $cont k) (hashq-set! scope-table k scope)))
@ -237,45 +234,6 @@
(($ $letk conts body) (($ $letk conts body)
(for-each visit-cont conts) (for-each visit-cont conts)
(visit-term body term-k)) (visit-term body term-k))
(($ $letrec names syms funs body)
(define (split-components nsf)
;; FIXME: Compute strongly-connected components. Currently
;; we just put non-recursive functions in their own
;; components, and lump everything else in the remaining
;; component.
(define (recursive? k)
(or-map (cut variable-free-in? <> k dfg) syms))
(let lp ((nsf nsf) (rec '()))
(match nsf
(()
(if (null? rec)
'()
(list rec)))
(((and elt (n s ($ $fun free ($ $cont kfun))))
. nsf)
(if (recursive? kfun)
(lp nsf (cons elt rec))
(cons (list elt) (lp nsf rec)))))))
(define (extract-arities+bodies clauses)
(values (map extract-arities clauses)
(map extract-bodies clauses)))
(define (visit-component component)
(match component
(((name sym fun) ...)
(match fun
((($ $fun free
($ $cont fun-k
($ $kfun src meta self ($ $cont tail-k ($ $ktail))
clause)))
...)
(call-with-values (lambda () (extract-arities+bodies clause))
(lambda (arities bodies)
(if (contify-funs term-k sym self tail-k arities bodies)
(for-each (cut for-each visit-cont <>) bodies)
(for-each visit-fun fun)))))))))
(visit-term body term-k)
(for-each visit-component
(split-components (map list names syms funs))))
(($ $continue k src exp) (($ $continue k src exp)
(match exp (match exp
(($ $fun free (($ $fun free
@ -287,15 +245,60 @@
(extract-arities clause) (extract-arities clause)
(extract-bodies clause)))) (extract-bodies clause))))
(begin (begin
(elide-function! k (lookup-cont k dfg))
(for-each visit-cont (extract-bodies clause))) (for-each visit-cont (extract-bodies clause)))
(visit-fun exp))) (visit-fun exp)))
(($ $rec names syms funs)
(define (split-components nsf)
;; FIXME: Compute strongly-connected components. Currently
;; we just put non-recursive functions in their own
;; components, and lump everything else in the remaining
;; component.
(define (recursive? k)
(or-map (cut variable-free-in? <> k dfg) syms))
(let lp ((nsf nsf) (rec '()))
(match nsf
(()
(if (null? rec)
'()
(list rec)))
(((and elt (n s ($ $fun free ($ $cont kfun))))
. nsf)
(if (recursive? kfun)
(lp nsf (cons elt rec))
(cons (list elt) (lp nsf rec)))))))
(define (extract-arities+bodies clauses)
(values (map extract-arities clauses)
(map extract-bodies clauses)))
(define (visit-component component)
(match component
(((name sym fun) ...)
(match fun
((($ $fun free
($ $cont fun-k
($ $kfun src meta self ($ $cont tail-k ($ $ktail))
clause)))
...)
(call-with-values (lambda () (extract-arities+bodies clause))
(lambda (arities bodies)
;; Technically the procedures are created in
;; term-k but bound for use in k. But, there is
;; a tight link between term-k and k, as they
;; are in the same block. Mark k as the
;; contification scope, because that's where
;; they'll be used. Perhaps we can fix this
;; with the new CPS dialect that doesn't have
;; $letk.
(if (contify-funs k sym self tail-k arities bodies)
(for-each (cut for-each visit-cont <>) bodies)
(for-each visit-fun fun)))))))))
(for-each visit-component
(split-components (map list names syms funs))))
(_ #t))))) (_ #t)))))
(visit-cont fun) (visit-cont fun)
(values call-substs cont-substs fun-elisions cont-splices))) (values call-substs cont-substs cont-splices)))
(define (apply-contification fun call-substs cont-substs fun-elisions cont-splices) (define (apply-contification fun call-substs cont-substs cont-splices)
(define (contify-call src proc args) (define (contify-call src proc args)
(and=> (assq-ref call-substs proc) (and=> (assq-ref call-substs proc)
(lambda (clauses) (lambda (clauses)
@ -331,8 +334,6 @@
((cont ...) ((cont ...)
(let lp ((term term)) (let lp ((term term))
(rewrite-cps-term term (rewrite-cps-term term
(($ $letrec names syms funs body)
($letrec names syms funs ,(lp body)))
(($ $letk conts* body) (($ $letk conts* body)
($letk ,(append conts* (filter-map visit-cont cont)) ($letk ,(append conts* (filter-map visit-cont cont))
,body)) ,body))
@ -345,16 +346,18 @@
($fun free ,(visit-cont body))))) ($fun free ,(visit-cont body)))))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont (? (cut assq <> fun-elisions))) (($ $cont label ($ $kargs names syms body))
;; This cont gets inlined in place of the $fun. ;; Remove bindings for functions that have been contified.
,#f) ,(rewrite-cps-cont (filter (match-lambda
(($ $cont sym ($ $kargs names syms body)) ((name sym) (not (assq sym call-substs))))
(sym ($kargs names syms ,(visit-term body sym)))) (map list names syms))
(($ $cont sym ($ $kfun src meta self tail clause)) (((names syms) ...)
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))) (label ($kargs names syms ,(visit-term body label))))))
(($ $cont sym ($ $kclause arity body alternate)) (($ $cont label ($ $kfun src meta self tail clause))
(sym ($kclause ,arity ,(visit-cont body) (label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
,(and alternate (visit-cont alternate))))) (($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont) (($ $cont)
,cont))) ,cont)))
(define (visit-term term term-k) (define (visit-term term term-k)
@ -364,37 +367,37 @@
(let lp ((body (visit-term body term-k))) (let lp ((body (visit-term body term-k)))
;; Because we attach contified functions on a particular ;; Because we attach contified functions on a particular
;; term-k, and one term-k can correspond to an arbitrarily ;; term-k, and one term-k can correspond to an arbitrarily
;; nested sequence of $letrec and $letk instances, normalize ;; nested sequence of $letk instances, normalize so that all
;; so that all continuations are bound by one $letk -- ;; continuations are bound by one $letk -- guaranteeing that
;; guaranteeing that they are in the same scope. ;; they are in the same scope.
(rewrite-cps-term body (rewrite-cps-term body
(($ $letrec names syms funs body)
($letrec names syms funs ,(lp body)))
(($ $letk conts* body) (($ $letk conts* body)
($letk ,(append conts* (filter-map visit-cont conts)) ($letk ,(append conts* (filter-map visit-cont conts))
,body)) ,body))
(body (body
($letk ,(filter-map visit-cont conts) ($letk ,(filter-map visit-cont conts)
,body))))) ,body)))))
(($ $letrec names syms funs body)
(rewrite-cps-term (filter (match-lambda
((n s f) (not (assq s call-substs))))
(map list names syms funs))
(((names syms funs) ...)
($letrec names syms (map visit-fun funs)
,(visit-term body term-k)))))
(($ $continue k src exp) (($ $continue k src exp)
(splice-continuations (splice-continuations
term-k term-k
(match exp (match exp
(($ $fun) (($ $fun free
(cond ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k))))
((assq-ref fun-elisions k) ;; If the function's tail continuation has been substituted,
=> (match-lambda ;; that means it has been contified.
(($ $kargs (_) (_) body) (continue k src
(visit-term body k)))) (if (assq tail-k cont-substs)
(else (build-cps-exp ($values ()))
(continue k src (visit-fun exp))))) (visit-fun exp))))
(($ $rec names syms funs)
(match (filter (match-lambda
((n s f) (not (assq s call-substs))))
(map list names syms funs))
(() (continue k src (build-cps-exp ($values ()))))
(((names syms funs) ...)
(continue k src
(build-cps-exp
($rec names syms (map visit-fun funs)))))))
(($ $call proc args) (($ $call proc args)
(or (contify-call src proc args) (or (contify-call src proc args)
(continue k src exp))) (continue k src exp)))
@ -403,9 +406,9 @@
(define (contify fun) (define (contify fun)
(call-with-values (lambda () (compute-contification fun)) (call-with-values (lambda () (compute-contification fun))
(lambda (call-substs cont-substs fun-elisions cont-splices) (lambda (call-substs cont-substs cont-splices)
(if (null? call-substs) (if (null? call-substs)
fun fun
;; Iterate to fixed point. ;; Iterate to fixed point.
(contify (contify
(apply-contification fun call-substs cont-substs fun-elisions cont-splices)))))) (apply-contification fun call-substs cont-substs cont-splices))))))

35
module/language/cps/cse.scm
View file

@ -39,7 +39,6 @@
(let lp ((body body)) (let lp ((body body))
(match body (match body
(($ $letk conts body) (lp body)) (($ $letk conts body) (lp body))
(($ $letrec names vars funs body) (lp body))
(($ $continue k src exp) (($ $continue k src exp)
(match exp (match exp
(($ $prompt escape? tag handler) (list k handler)) (($ $prompt escape? tag handler) (list k handler))
@ -246,16 +245,8 @@ could be that both true and false proofs are available."
(label-count (1+ label-count))) (label-count (1+ label-count)))
(match cont (match cont
(($ $kargs names vars body) (($ $kargs names vars body)
(let lp ((body body) (values min-label label-count
(min-var (fold min min-var vars)) (fold min min-var vars) (+ var-count (length vars))))
(var-count (+ var-count (length vars))))
(match body
(($ $letrec names vars funs body)
(lp body
(fold min min-var vars)
(+ var-count (length vars))))
(($ $letk conts body) (lp body min-var var-count))
(_ (values min-label label-count min-var var-count)))))
(($ $kfun src meta self) (($ $kfun src meta self)
(values min-label label-count (min self min-var) (1+ var-count))) (values min-label label-count (min self min-var) (1+ var-count)))
(_ (_
@ -297,6 +288,7 @@ could be that both true and false proofs are available."
(($ $const val) (cons 'const val)) (($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name)) (($ $prim name) (cons 'prim name))
(($ $fun free body) #f) (($ $fun free body) #f)
(($ $rec names syms funs) #f)
(($ $call proc args) #f) (($ $call proc args) #f)
(($ $callk k proc args) #f) (($ $callk k proc args) #f)
(($ $primcall name args) (($ $primcall name args)
@ -475,12 +467,19 @@ could be that both true and false proofs are available."
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler)))) ($prompt escape? (subst-var tag) handler))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map subst-var free) ,(cse body dfg)))))
(define (visit-exp* k src exp) (define (visit-exp* k src exp)
(match exp (match exp
(($ $fun free body) (($ $fun)
(build-cps-term (build-cps-term
($continue k src ($continue k src ,(visit-fun exp))))
($fun (map subst-var free) ,(cse body dfg))))) (($ $rec names syms funs)
(build-cps-term
($continue k src ($rec names syms (map visit-fun funs)))))
(_ (_
(cond (cond
((vector-ref equiv-labels (label->idx label)) ((vector-ref equiv-labels (label->idx label))
@ -523,14 +522,6 @@ could be that both true and false proofs are available."
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)
,(visit-term body label)) ,(visit-term body label))
(($ $letrec names syms funs body)
($letrec names syms
(map (lambda (fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map subst-var free) ,(cse body dfg)))))
funs)
,(visit-term body label)))
(($ $continue k src exp) (($ $continue k src exp)
,(let ((conts (append-map visit-dom-conts ,(let ((conts (append-map visit-dom-conts
(vector-ref doms (label->idx label))))) (vector-ref doms (label->idx label)))))

70
module/language/cps/dce.scm
View file

@ -190,14 +190,6 @@
(let lp ((body body)) (let lp ((body body))
(match body (match body
(($ $letk conts body) (lp body)) (($ $letk conts body) (lp body))
(($ $letrec names syms funs body)
(lp body)
(for-each (lambda (sym fun)
(when (value-live? sym)
(match fun
(($ $fun free body)
(visit-fun body)))))
syms funs))
(($ $continue k src exp) (($ $continue k src exp)
(unless (bitvector-ref live-conts n) (unless (bitvector-ref live-conts n)
(when (visit-grey-exp n exp) (when (visit-grey-exp n exp)
@ -209,6 +201,13 @@
#f) #f)
(($ $fun free body) (($ $fun free body)
(visit-fun body)) (visit-fun body))
(($ $rec names syms funs)
(for-each (lambda (sym fun)
(when (value-live? sym)
(match fun
(($ $fun free body)
(visit-fun body)))))
syms funs))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(mark-live! tag)) (mark-live! tag))
(($ $call proc args) (($ $call proc args)
@ -309,22 +308,6 @@
(match (visit-conts conts) (match (visit-conts conts)
(() body) (() body)
(conts (build-cps-term ($letk ,conts ,body)))))) (conts (build-cps-term ($letk ,conts ,body))))))
(($ $letrec names syms funs body)
(let ((body (visit-term body term-k)))
(match (filter-map
(lambda (name sym fun)
(and (value-live? sym)
(match fun
(($ $fun free body)
(list name
sym
(build-cps-exp
($fun free ,(visit-fun body))))))))
names syms funs)
(() body)
(((names syms funs) ...)
(build-cps-term
($letrec names syms funs ,body))))))
(($ $continue k src ($ $values args)) (($ $continue k src ($ $values args))
(match (vector-ref defs (label->idx term-k)) (match (vector-ref defs (label->idx term-k))
(#f term) (#f term)
@ -336,19 +319,36 @@
($continue k src ($values args))))))) ($continue k src ($values args)))))))
(($ $continue k src exp) (($ $continue k src exp)
(if (bitvector-ref live-conts (label->idx term-k)) (if (bitvector-ref live-conts (label->idx term-k))
(rewrite-cps-term exp (match exp
(($ $fun free body) (($ $fun free body)
($continue k src ($fun free ,(visit-fun body)))) (build-cps-term
($continue k src ($fun free ,(visit-fun body)))))
(($ $rec names syms funs)
(rewrite-cps-term
(filter-map
(lambda (name sym fun)
(and (value-live? sym)
(match fun
(($ $fun free body)
(list name
sym
(build-cps-exp
($fun free ,(visit-fun body))))))))
names syms funs)
(()
($continue k src ($values ())))
(((names syms funs) ...)
($continue k src ($rec names syms funs)))))
(_ (_
,(match (vector-ref defs (label->idx term-k)) (match (vector-ref defs (label->idx term-k))
((or #f ((? value-live?) ...)) ((or #f ((? value-live?) ...))
(build-cps-term (build-cps-term
($continue k src ,exp))) ($continue k src ,exp)))
(syms (syms
(let-fresh (adapt) () (let-fresh (adapt) ()
(build-cps-term (build-cps-term
($letk (,(make-adaptor adapt k syms)) ($letk (,(make-adaptor adapt k syms))
($continue adapt src ,exp)))))))) ($continue adapt src ,exp))))))))
(build-cps-term ($continue k src ($values ()))))))) (build-cps-term ($continue k src ($values ())))))))
(visit-cont fun)))) (visit-cont fun))))
(visit-fun fun)) (visit-fun fun))

52
module/language/cps/dfg.scm
View file

@ -566,32 +566,14 @@ body continuation in the prompt."
min-var max-var var-count) min-var max-var var-count)
(let ((min-label (min* label min-label)) (let ((min-label (min* label min-label))
(max-label (max label max-label))) (max-label (max label max-label)))
(define (visit-letrec body min-var max-var var-count)
(match body
(($ $letk conts body)
(visit-letrec body min-var max-var var-count))
(($ $letrec names vars funs body)
(visit-letrec body
(cond (min-var (fold min min-var vars))
((pair? vars) (fold min (car vars) (cdr vars)))
(else min-var))
(fold max max-var vars)
(+ var-count (length vars))))
(($ $continue) (values min-var max-var var-count))))
(match cont (match cont
(($ $kargs names vars body) (($ $kargs names vars body)
(call-with-values (values min-label max-label (1+ label-count)
(lambda () (cond (min-var (fold min min-var vars))
(if global? ((pair? vars) (fold min (car vars) (cdr vars)))
(visit-letrec body min-var max-var var-count) (else min-var))
(values min-var max-var var-count))) (fold max max-var vars)
(lambda (min-var max-var var-count) (+ var-count (length vars))))
(values min-label max-label (1+ label-count)
(cond (min-var (fold min min-var vars))
((pair? vars) (fold min (car vars) (cdr vars)))
(else min-var))
(fold max max-var vars)
(+ var-count (length vars))))))
(($ $kfun src meta self) (($ $kfun src meta self)
(values min-label max-label (1+ label-count) (values min-label max-label (1+ label-count)
(min* self min-var) (max self max-var) (1+ var-count))) (min* self min-var) (max self max-var) (1+ var-count)))
@ -653,16 +635,6 @@ body continuation in the prompt."
cont k) cont k)
(for-each/2 visit-cont cont k) (for-each/2 visit-cont cont k)
(visit-term body label)) (visit-term body label))
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
(for-each (cut add-def! <> label) syms)
(for-each (lambda (fun)
(match fun
(($ $fun free body)
(visit-fun body))))
funs)
(visit-term body label))
(($ $continue k src exp) (($ $continue k src exp)
(link-blocks! label k) (link-blocks! label k)
(visit-exp exp label)))) (visit-exp exp label))))
@ -690,7 +662,15 @@ body continuation in the prompt."
(link-blocks! label handler)) (link-blocks! label handler))
(($ $fun free body) (($ $fun free body)
(when global? (when global?
(visit-fun body))))) (visit-fun body)))
(($ $rec names syms funs)
(unless global?
(error "$rec should not be present when building a local DFG"))
(for-each (lambda (fun)
(match fun
(($ $fun free body)
(visit-fun body))))
funs))))
(define (visit-clause clause kfun) (define (visit-clause clause kfun)
(match clause (match clause
@ -769,6 +749,7 @@ body continuation in the prompt."
(($ $const val) (format port "const ~@y" val)) (($ $const val) (format port "const ~@y" val))
(($ $prim name) (format port "prim ~a" name)) (($ $prim name) (format port "prim ~a" name))
(($ $fun free ($ $cont kbody)) (format port "fun k~a" kbody)) (($ $fun free ($ $cont kbody)) (format port "fun k~a" kbody))
(($ $rec names syms funs) (format port "rec~{ v~a~}" syms))
(($ $closure label nfree) (format port "closure k~a (~a free)" label nfree)) (($ $closure label nfree) (format port "closure k~a (~a free)" label nfree))
(($ $call proc args) (format port "call~{ v~a~}" (cons proc args))) (($ $call proc args) (format port "call~{ v~a~}" (cons proc args)))
(($ $callk k proc args) (format port "callk k~a~{ v~a~}" k (cons proc args))) (($ $callk k proc args) (format port "callk k~a~{ v~a~}" k (cons proc args)))
@ -820,7 +801,6 @@ body continuation in the prompt."
(match term (match term
(($ $kargs names syms body) (find-call body)) (($ $kargs names syms body) (find-call body))
(($ $letk conts body) (find-call body)) (($ $letk conts body) (find-call body))
(($ $letrec names syms funs body) (find-call body))
(($ $continue) term))) (($ $continue) term)))
(define (call-expression call) (define (call-expression call)

2
module/language/cps/effects-analysis.scm
View file

@ -443,7 +443,7 @@ is or might be a read or a write to the same location as A."
(match exp (match exp
((or ($ $const) ($ $prim) ($ $values)) ((or ($ $const) ($ $prim) ($ $values))
&no-effects) &no-effects)
(($ $fun) ((or ($ $fun) ($ $rec))
(&allocate &unknown-memory-kinds)) (&allocate &unknown-memory-kinds))
(($ $prompt) (($ $prompt)
(&write-object &prompt)) (&write-object &prompt))

7
module/language/cps/elide-values.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -52,9 +52,6 @@
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body))) ,(visit-term body)))
(($ $letrec names syms funs body)
($letrec names syms (map visit-fun funs)
,(visit-term body)))
(($ $continue k src ($ $primcall 'values vals)) (($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (vector-ref conts k) ,(rewrite-cps-term (vector-ref conts k)
(($ $ktail) (($ $ktail)
@ -95,6 +92,8 @@
($continue k src ($values vals)))))))) ($continue k src ($values vals))))))))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun))) ($continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
($continue k src ($rec names syms (map visit-fun funs))))
(($ $continue) (($ $continue)
,term))) ,term)))
(define (visit-fun fun) (define (visit-fun fun)

7
module/language/cps/prune-bailouts.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. ;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -60,9 +60,6 @@
(define (visit-term term ktail) (define (visit-term term ktail)
(rewrite-cps-term term (rewrite-cps-term term
(($ $letrec names vars funs body)
($letrec names vars (map visit-fun funs)
,(visit-term body ktail)))
(($ $letk conts body) (($ $letk conts body)
($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts) ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
,(visit-term body ktail))) ,(visit-term body ktail)))
@ -72,6 +69,8 @@
(define (visit-exp k src exp ktail) (define (visit-exp k src exp ktail)
(rewrite-cps-term exp (rewrite-cps-term exp
(($ $fun) ($continue k src ,(visit-fun exp))) (($ $fun) ($continue k src ,(visit-fun exp)))
(($ $rec names vars funs)
($continue k src ($rec names vars (map visit-fun funs))))
(($ $primcall (and name (or 'error 'scm-error 'throw)) args) (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
,(if (eq? k ktail) ,(if (eq? k ktail)
(build-cps-term ($continue k src ,exp)) (build-cps-term ($continue k src ,exp))

9
module/language/cps/prune-top-level-scopes.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2014 Free Software Foundation, Inc. ;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -53,12 +53,11 @@
(($ $letk conts body) (($ $letk conts body)
(for-each visit-cont conts) (for-each visit-cont conts)
(visit-term body)) (visit-term body))
(($ $letrec names syms funs body)
(for-each visit-fun funs)
(visit-term body))
(($ $continue k src exp) (($ $continue k src exp)
(match exp (match exp
(($ $fun) (visit-fun exp)) (($ $fun) (visit-fun exp))
(($ $rec names syms funs)
(for-each visit-fun funs))
(($ $primcall 'cached-toplevel-box (scope name bound?)) (($ $primcall 'cached-toplevel-box (scope name bound?))
(hashq-set! scope-var->used? scope #t)) (hashq-set! scope-var->used? scope #t))
(($ $primcall 'cache-current-module! (module scope)) (($ $primcall 'cache-current-module! (module scope))
@ -105,8 +104,6 @@
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body))) ($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs body)
($letrec names syms funs ,(visit-term body)))
(($ $continue k src (($ $continue k src
(and ($ $primcall 'cache-current-module! (module scope)) (and ($ $primcall 'cache-current-module! (module scope))
(? (lambda _ (? (lambda _

20
module/language/cps/renumber.scm
View file

@ -52,7 +52,6 @@
(let lp ((body body)) (let lp ((body body))
(match body (match body
(($ $letk conts body) (lp body)) (($ $letk conts body) (lp body))
(($ $letrec names syms funs body) (lp body))
(($ $continue k src exp) (($ $continue k src exp)
(match exp (match exp
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
@ -168,8 +167,6 @@
(visit-cont (car conts)) (visit-cont (car conts))
(lp (cdr conts)))) (lp (cdr conts))))
(visit-term body label)) (visit-term body label))
(($ $letrec names syms funs body)
(visit-term body label))
(($ $continue k src exp) (($ $continue k src exp)
(add-predecessor! label k) (add-predecessor! label k)
(match exp (match exp
@ -222,19 +219,17 @@
(($ $letk conts body) (($ $letk conts body)
(for-each visit-cont conts) (for-each visit-cont conts)
(visit-term body reachable?)) (visit-term body reachable?))
(($ $letrec names syms funs body) (($ $continue k src ($ $fun free body))
(when reachable?
(set! queue (cons body queue))))
(($ $continue k src ($ $rec names syms funs))
(when reachable? (when reachable?
(for-each rename! syms)
(set! queue (fold (lambda (fun queue) (set! queue (fold (lambda (fun queue)
(match fun (match fun
(($ $fun free body) (($ $fun free body)
(cons body queue)))) (cons body queue))))
queue queue
funs))) funs))))
(visit-term body reachable?))
(($ $continue k src ($ $fun free body))
(when reachable?
(set! queue (cons body queue))))
(($ $continue) #f))) (($ $continue) #f)))
(match fun (match fun
@ -301,9 +296,6 @@
,(match (visit-conts conts) ,(match (visit-conts conts)
(() (visit-term body)) (() (visit-term body))
(conts (build-cps-term ($letk ,conts ,(visit-term body)))))) (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
(($ $letrec names vars funs body)
($letrec names (map rename vars) (map visit-fun funs)
,(visit-term body)))
(($ $continue k src exp) (($ $continue k src exp)
($continue (relabel k) src ,(visit-exp exp))))) ($continue (relabel k) src ,(visit-exp exp)))))
(define (visit-exp exp) (define (visit-exp exp)
@ -314,6 +306,8 @@
(build-cps-exp ($closure (relabel k) nfree))) (build-cps-exp ($closure (relabel k) nfree)))
(($ $fun) (($ $fun)
(visit-fun exp)) (visit-fun exp))
(($ $rec names vars funs)
(build-cps-exp ($rec names (map rename vars) (map visit-fun funs))))
(($ $values args) (($ $values args)
(let ((args (map rename args))) (let ((args (map rename args)))
(build-cps-exp ($values args)))) (build-cps-exp ($values args))))

5
module/language/cps/self-references.scm
View file

@ -45,9 +45,6 @@
(define (visit-term term) (define (visit-term term)
(rewrite-cps-term term (rewrite-cps-term term
(($ $letrec names vars funs body)
($letrec names vars (map visit-recursive-fun funs vars)
,(visit-term body)))
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body))) ,(visit-term body)))
@ -59,6 +56,8 @@
((or ($ $const) ($ $prim)) ,exp) ((or ($ $const) ($ $prim)) ,exp)
(($ $fun free body) (($ $fun free body)
($fun free ,(resolve-self-references body env))) ($fun free ,(resolve-self-references body env)))
(($ $rec names vars funs)
($rec names vars (map visit-recursive-fun funs vars)))
(($ $call proc args) (($ $call proc args)
($call (subst proc) ,(map subst args))) ($call (subst proc) ,(map subst args)))
(($ $callk k proc args) (($ $callk k proc args)

39
module/language/cps/simplify.scm
View file

@ -50,14 +50,13 @@
(($ $letk conts body) (($ $letk conts body)
(for-each visit-cont conts) (for-each visit-cont conts)
(visit-term body term-k term-args)) (visit-term body term-k term-args))
(($ $letrec names syms funs body)
(for-each visit-fun funs)
(visit-term body term-k term-args))
(($ $continue k src ($ $values args)) (($ $continue k src ($ $values args))
(when (and (equal? term-args args) (not (eq? k term-k))) (when (and (equal? term-args args) (not (eq? k term-k)))
(hashq-set! table term-k k))) (hashq-set! table term-k k)))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
(visit-fun fun)) (visit-fun fun))
(($ $continue k src ($ $rec names syms funs))
(for-each visit-fun funs))
(($ $continue k src _) (($ $continue k src _)
#f))) #f)))
(define (visit-fun fun) (define (visit-fun fun)
@ -126,13 +125,12 @@
(($ $letk conts body) (($ $letk conts body)
($letk ,(map (cut visit-cont <> scope) conts) ($letk ,(map (cut visit-cont <> scope) conts)
,(visit-term body scope))) ,(visit-term body scope)))
(($ $letrec names syms funs body)
($letrec names syms (map visit-fun funs)
,(visit-term body scope)))
(($ $continue k src ($ $values args)) (($ $continue k src ($ $values args))
($continue (reduce-values k scope) src ($values args))) ($continue (reduce-values k scope) src ($values args)))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue (reduce k scope) src ,(visit-fun fun))) ($continue (reduce k scope) src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
($continue k src ($rec names syms (map visit-fun funs))))
(($ $continue k src ($ $const const)) (($ $continue k src ($ $const const))
,(let ((k (reduce k scope))) ,(let ((k (reduce k scope)))
(or (reduce-const k src scope const) (or (reduce-const k src scope const)
@ -168,9 +166,6 @@
(($ $letk conts body) (($ $letk conts body)
(for-each visit-cont conts) (for-each visit-cont conts)
(visit-term body)) (visit-term body))
(($ $letrec names syms funs body)
(for-each visit-fun funs)
(visit-term body))
(($ $continue k src ($ $values args)) (($ $continue k src ($ $values args))
(match (lookup-cont k dfg) (match (lookup-cont k dfg)
(($ $kargs names syms body) (($ $kargs names syms body)
@ -188,6 +183,8 @@
(_ #f))) (_ #f)))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
(visit-fun fun)) (visit-fun fun))
(($ $continue k src ($ $rec names syms funs))
(for-each visit-fun funs))
(($ $continue k src _) (($ $continue k src _)
#f))) #f)))
(define (visit-fun fun) (define (visit-fun fun)
@ -227,10 +224,6 @@
(() (visit-term body)) (() (visit-term body))
(conts (build-cps-term (conts (build-cps-term
($letk ,conts ,(visit-term body)))))) ($letk ,conts ,(visit-term body))))))
(($ $letrec names syms funs body)
(build-cps-term
($letrec names syms (map visit-fun funs)
,(visit-term body))))
(($ $continue k src exp) (($ $continue k src exp)
(cond (cond
((hashq-ref k-table k) => visit-term) ((hashq-ref k-table k) => visit-term)
@ -240,6 +233,8 @@
(match exp (match exp
((or ($ $const) ($ $prim)) exp) ((or ($ $const) ($ $prim)) exp)
(($ $fun) (visit-fun exp)) (($ $fun) (visit-fun exp))
(($ $rec names syms funs)
(build-cps-exp ($rec names (map subst syms) (map visit-fun funs))))
(($ $call proc args) (($ $call proc args)
(let ((args (map subst args))) (let ((args (map subst args)))
(build-cps-exp ($call (subst proc) args)))) (build-cps-exp ($call (subst proc) args))))
@ -284,10 +279,17 @@
(label ($kargs names vars ,(visit-term body label)))) (label ($kargs names vars ,(visit-term body label))))
(_ (label ,cont)))) (_ (label ,cont))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun free ,(visit-fun-cont body)))))
(define (visit-exp k src exp) (define (visit-exp k src exp)
(rewrite-cps-term exp (rewrite-cps-term exp
(($ $fun free body) (($ $fun free body)
($continue k src ($fun free ,(visit-fun-cont body)))) ($continue k src ,(visit-fun exp)))
(($ $rec names syms funs)
($continue k src ($rec names syms (map visit-fun funs))))
(_ (_
($continue k src ,exp)))) ($continue k src ,exp))))
@ -311,15 +313,6 @@
(rewrite-cps-term term (rewrite-cps-term term
(($ $letk conts body) (($ $letk conts body)
,(visit-term body label)) ,(visit-term body label))
(($ $letrec names syms funs body)
($letrec names syms (let lp ((funs funs))
(match funs
(() '())
((($ $fun free body) . funs)
(cons (build-cps-exp
($fun free ,(visit-fun-cont body)))
(lp funs)))))
,(visit-term body label)))
(($ $continue k src exp) (($ $continue k src exp)
,(let ((conts (visit-dom-conts* (vector-ref doms label)))) ,(let ((conts (visit-dom-conts* (vector-ref doms label))))
(if (null? conts) (if (null? conts)

5
module/language/cps/specialize-primcalls.scm
View file

@ -54,11 +54,10 @@
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body))) ,(visit-term body)))
(($ $letrec names syms funs body)
($letrec names syms (map visit-fun funs)
,(visit-term body)))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun))) ($continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
($continue k src ($rec names syms (map visit-fun funs))))
(($ $continue k src ($ $primcall name args)) (($ $continue k src ($ $primcall name args))
,(visit-primcall k src name args)) ,(visit-primcall k src name args))
(($ $continue) (($ $continue)

9
module/language/cps/type-fold.scm
View file

@ -1,5 +1,5 @@
;;; Abstract constant folding on CPS ;;; Abstract constant folding on CPS
;;; Copyright (C) 2014 Free Software Foundation, Inc. ;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;; ;;;
;;; This library is free software: you can redistribute it and/or modify ;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as ;;; it under the terms of the GNU Lesser General Public License as
@ -356,8 +356,6 @@
(($ $letk conts body) (($ $letk conts body)
(for-each visit-cont conts) (for-each visit-cont conts)
(visit-term body label)) (visit-term body label))
(($ $letrec _ _ _ body)
(visit-term body label))
(($ $continue k src ($ $primcall name args)) (($ $continue k src ($ $primcall name args))
;; We might be able to fold primcalls that define a value. ;; We might be able to fold primcalls that define a value.
(match (lookup-cont k dfg) (match (lookup-cont k dfg)
@ -402,11 +400,10 @@
(($ $letk conts body) (($ $letk conts body)
($letk ,(map visit-cont conts) ($letk ,(map visit-cont conts)
,(visit-term body label))) ,(visit-term body label)))
(($ $letrec names vars funs body)
($letrec names vars (map visit-fun funs)
,(visit-term body label)))
(($ $continue k src (and fun ($ $fun))) (($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun))) ($continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names vars funs))
($continue k src ($rec names vars (map visit-fun funs))))
(($ $continue k src (and primcall ($ $primcall name args))) (($ $continue k src (and primcall ($ $primcall name args)))
,(cond ,(cond
((bitvector-ref folded? (label->idx label)) ((bitvector-ref folded? (label->idx label))

8
module/language/cps/types.scm
View file

@ -1304,6 +1304,9 @@ mapping symbols to types."
(propagate! 0 k types)))) (propagate! 0 k types))))
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
(propagate! 0 k types)) (propagate! 0 k types))
(($ $rec names vars funs)
(let ((proc-type (make-type-entry &procedure -inf.0 +inf.0)))
(propagate! 0 k (adjoin-vars types vars proc-type))))
(_ (_
(match (lookup-cont k dfg) (match (lookup-cont k dfg)
(($ $kargs (_) (var)) (($ $kargs (_) (var))
@ -1333,11 +1336,6 @@ mapping symbols to types."
(($ $kargs names vars term) (($ $kargs names vars term)
(let visit-term ((term term) (types types)) (let visit-term ((term term) (types types))
(match term (match term
(($ $letrec names vars funs term)
(visit-term term
(adjoin-vars types vars
(make-type-entry &procedure
-inf.0 +inf.0))))
(($ $letk conts term) (($ $letk conts term)
(visit-term term types)) (visit-term term types))
(($ $continue k src exp) (($ $continue k src exp)

14
module/language/cps/verify.scm
View file

@ -143,6 +143,13 @@
#t) #t)
(($ $fun) (($ $fun)
(visit-fun exp k-env v-env)) (visit-fun exp k-env v-env))
(($ $rec (name ...) (sym ...) (fun ...))
(unless (= (length name) (length sym) (length fun))
(error "letrec syms, names, and funs not same length" term))
;; FIXME: syms added in two places (here in $rec versus also in
;; target $kargs)
(let ((v-env (add-vars sym v-env)))
(for-each (cut visit-fun <> k-env v-env) fun)))
(($ $call proc (arg ...)) (($ $call proc (arg ...))
(check-var proc v-env) (check-var proc v-env)
(for-each (cut check-var <> v-env) arg)) (for-each (cut check-var <> v-env) arg))
@ -177,13 +184,6 @@
(for-each (cut visit-cont-body <> k-env v-env) cont) (for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env))) (visit-term body k-env v-env)))
(($ $letrec (name ...) (sym ...) (fun ...) body)
(unless (= (length name) (length sym) (length fun))
(error "letrec syms, names, and funs not same length" term))
(let ((v-env (add-vars sym v-env)))
(for-each (cut visit-fun <> k-env v-env) fun)
(visit-term body k-env v-env)))
(($ $continue k src exp) (($ $continue k src exp)
(check-label k k-env) (check-label k k-env)
(check-src src) (check-src src)

22
module/language/tree-il/compile-cps.scm
View file

@ -524,16 +524,18 @@
(($ <fix> src names gensyms funs body) (($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later. ;; Some letrecs can be contified; that happens later.
(if (current-topbox-scope) (if (current-topbox-scope)
(let-fresh () (self) (let ((vars (map bound-var gensyms)))
(build-cps-term (let-fresh (krec) ()
($letrec names (build-cps-term
(map bound-var gensyms) ($letk ((krec ($kargs names vars
(map (lambda (fun) ,(convert body k subst))))
(match (convert fun k subst) ($continue krec src
(($ $continue _ _ (and fun ($ $fun))) ($rec names vars
fun))) (map (lambda (fun)
funs) (match (convert fun k subst)
,(convert body k subst)))) (($ $continue _ _ (and fun ($ $fun)))
fun)))
funs)))))))
(let ((scope-id (fresh-scope-id))) (let ((scope-id (fresh-scope-id)))
(let-fresh (kscope) () (let-fresh (kscope) ()
(build-cps-term (build-cps-term