[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/04: Replace $letrec with $rec
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 03/04: Replace $letrec with $rec |
|
Date: |
Wed, 01 Apr 2015 08:27:46 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 34ff3af9f0024c6d5163f422ca5e1202a560efe3
Author: Andy Wingo <address@hidden>
Date: Wed Apr 1 09:51:13 2015 +0200
Replace $letrec with $rec
* 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.
---
doc/ref/compiler.texi | 114 ++++++++++-------
module/language/cps.scm | 52 +++-----
module/language/cps/arities.scm | 15 +-
module/language/cps/closure-conversion.scm | 90 ++++++++-----
module/language/cps/constructors.scm | 7 +-
module/language/cps/contification.scm | 163 ++++++++++++------------
module/language/cps/cse.scm | 35 ++---
module/language/cps/dce.scm | 70 +++++-----
module/language/cps/dfg.scm | 52 +++-----
module/language/cps/effects-analysis.scm | 2 +-
module/language/cps/elide-values.scm | 7 +-
module/language/cps/prune-bailouts.scm | 7 +-
module/language/cps/prune-top-level-scopes.scm | 9 +-
module/language/cps/renumber.scm | 20 +--
module/language/cps/self-references.scm | 5 +-
module/language/cps/simplify.scm | 39 +++----
module/language/cps/specialize-primcalls.scm | 5 +-
module/language/cps/type-fold.scm | 9 +-
module/language/cps/types.scm | 8 +-
module/language/cps/verify.scm | 14 +-
module/language/tree-il/compile-cps.scm | 22 ++--
21 files changed, 361 insertions(+), 384 deletions(-)
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 6407338..9743c53 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014
address@hidden Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015
@c Free Software Foundation, Inc.
@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.
@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}.
+
address@hidden {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}
address@hidden instances. The first entry in the list is the entry
+function for the program.
address@hidden deftp
+
Here is an inventory of the kinds of expressions in Guile's CPS
language. Recall that all expressions are wrapped in a @code{$continue}
term which specifies their continuation.
address@hidden {CPS Expression} $void
-Continue with the unspecified value.
address@hidden deftp
-
@deftp {CPS Expression} $const val
Continue with the constant value @var{val}.
@end deftp
@@ -676,16 +687,27 @@ Continue with the procedure that implements the primitive
operation
named by @var{name}.
@end deftp
address@hidden {CPS Expression} $fun src meta free body
-Continue with a procedure. @var{src} identifies the source information
-for the procedure declaration, and @var{meta} is the metadata alist as
-described above in Tree-IL's @code{<lambda>}. @var{free} is a list of
-free variables accessed by the procedure. Early CPS uses an empty list
-for @var{free}; only after closure conversion is it correctly populated.
-Finally, @var{body} is the @code{$kentry} @code{$cont} of the procedure
-entry.
address@hidden {CPS Expression} $fun free body
+Continue with a procedure. @var{free} is a list of free variables
+accessed by the procedure. Early CPS uses an empty list for @var{free};
+only after closure conversion is it correctly populated. Finally,
address@hidden is the @code{$kfun} @code{$cont} of the procedure entry.
address@hidden deftp
+
address@hidden is part of higher-level CPS. After closure conversion,
address@hidden instances are given a concrete representation. By default,
+a closure is represented as an object built by a @code{$closure}
+expression
+
address@hidden {CPS Expression} $closure label nfree
+Build a closure that joins the code at the continuation named
address@hidden 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
@deftpx {CPS Expression} $callk label proc args
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.
@end deftp
address@hidden {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
address@hidden 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 @address@hidden 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
address@hidden expression. The optimizer should inline the reference if
+possible.
address@hidden deftp
+
@deftp {CPS Expression} $prompt escape? tag handler
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
@@ -741,32 +778,10 @@ names @var{names}, and then evaluate the sub-term
@var{body}.
@end deftp
Variable names (the names in the @var{syms} of a @code{$kargs}) should
-be globally unique, and also disjoint from continuation labels. To bind
-a value to a variable and then evaluate some term, you would continue
-with the value to a @code{$kargs} that declares one variable. The bound
-value would then be available for use within the body of the
address@hidden
-
address@hidden {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}.
address@hidden 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
address@hidden to @code{null?}, @code{=}, and similar primitives that
-have corresponding @address@hidden 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.
+be unique among all other variable names. To bind a value to a variable
+and then evaluate some term, you would continue with the value to a
address@hidden that declares one variable. The bound value would then be
+available for use within the body of the @code{$kargs}.
@deftp {CPS Continuation} $kreceive arity k
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
only be declared at function entries.
address@hidden {CPS Continuation} $kentry self tail clauses
-Declare a function entry. @var{self} is a variable bound to the
-procedure being called, and which may be used for self-references.
address@hidden {CPS Continuation} $kfun src meta self tail clauses
+Declare a function entry. @var{src} is the source information for the
+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
function, corresponding to the function's tail continuation.
address@hidden is a list of @code{$kclause} @code{$cont} instances.
address@hidden is the first @code{$kclause} @code{$cont} instance for the
+first @code{case-lambda} clause in the function, or otherwise @code{#f}.
@end deftp
@deftp {CPS Continuation} $ktail
A tail continuation.
@end deftp
address@hidden {CPS Continuation} $kclause arity cont
address@hidden {CPS Continuation} $kclause arity cont alternate
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
address@hidden @code{$cont} instance representing the clause body.
address@hidden @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
address@hidden if there is no next clause.
@end deftp
-
@node 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 ($letrec names syms funs term)
@deffnx {Scheme Syntax} build-cps-term ($continue k src exp)
address@hidden {Scheme Syntax} build-cps-term ($program conts)
@deffnx {Scheme Syntax} build-cps-exp ,val
address@hidden {Scheme Syntax} build-cps-exp ($void)
@deffnx {Scheme Syntax} build-cps-exp ($const val)
@deffnx {Scheme Syntax} build-cps-exp ($prim name)
@deffnx {Scheme Syntax} build-cps-exp ($fun src meta free body)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index ee20197..3e0748f 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -113,7 +113,7 @@
make-$arity
;; Terms.
- $letk $continue $letrec
+ $letk $continue
;; Continuations.
$cont
@@ -122,7 +122,7 @@
$kreceive $kargs $kfun $ktail $kclause
;; Expressions.
- $const $prim $fun $closure $branch
+ $const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt
;; First-order CPS root.
@@ -177,7 +177,6 @@
;; Terms.
(define-cps-type $letk conts body)
(define-cps-type $continue k src exp)
-(define-cps-type $letrec names syms funs body) ; Higher-order.
;; Continuations
(define-cps-type $cont k cont)
@@ -191,6 +190,7 @@
(define-cps-type $const val)
(define-cps-type $prim name)
(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 $branch k exp)
(define-cps-type $call proc args)
@@ -263,12 +263,13 @@
(define-syntax build-cps-exp
(syntax-rules (unquote
- $const $prim $fun $closure $branch
+ $const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt)
((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
((_ ($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))
((_ ($call proc (unquote args))) (make-$call proc args))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
@@ -287,7 +288,7 @@
(make-$prompt escape? tag handler))))
(define-syntax build-cps-term
- (syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
+ (syntax-rules (unquote $letk $letk* $letconst $program $continue)
((_ (unquote exp))
exp)
((_ ($letk (unquote conts) body))
@@ -308,8 +309,6 @@
($continue kconst (let ((props (source-properties val)))
(and (pair? props) props))
($const val))))))
- ((_ ($letrec names gensyms funs body))
- (make-$letrec names gensyms funs (build-cps-term body)))
((_ ($program (unquote conts)))
(make-$program conts))
((_ ($program (cont ...)))
@@ -386,9 +385,8 @@
(build-cps-exp ($fun free ,(parse-cps body))))
(('closure k nfree)
(build-cps-exp ($closure k nfree)))
- (('letrec ((name sym fun) ...) body)
- (build-cps-term
- ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
+ (('rec (name sym fun) ...)
+ (build-cps-exp ($rec name sym (map parse-cps fun))))
(('program (cont ...))
(build-cps-term ($program ,(map parse-cps cont))))
(('call proc arg ...)
@@ -445,11 +443,10 @@
`(fun ,free ,(unparse-cps body)))
(($ $closure k nfree)
`(closure ,k ,nfree))
- (($ $letrec names syms funs body)
- `(letrec ,(map (lambda (name sym fun)
- (list name sym (unparse-cps fun)))
- names syms funs)
- ,(unparse-cps body)))
+ (($ $rec names syms funs)
+ `(rec ,@(map (lambda (name sym fun)
+ (list name sym (unparse-cps fun)))
+ names syms funs)))
(($ $program conts)
`(program ,(map unparse-cps conts)))
(($ $call proc args)
@@ -509,15 +506,13 @@
(($ $continue k src exp)
(match exp
(($ $fun) (fun-folder exp seed ...))
- (_ (values seed ...))))
-
- (($ $letrec names syms funs body)
- (let-values (((seed ...) (term-folder body seed ...)))
- (let lp ((funs funs) (seed seed) ...)
- (if (null? funs)
- (values seed ...)
- (let-values (((seed ...) (fun-folder (car funs) seed ...)))
- (lp (cdr funs) seed ...))))))))
+ (($ $rec names syms funs)
+ (let lp ((funs funs) (seed seed) ...)
+ (if (null? funs)
+ (values seed ...)
+ (let-values (((seed ...) (fun-folder (car funs) seed ...)))
+ (lp (cdr funs) seed ...)))))
+ (_ (values seed ...))))))
(cont-folder cont seed ...)))
@@ -541,7 +536,6 @@
((cont . conts)
(let-values (((seed ...) (cont-folder cont seed ...)))
(lp conts seed ...)))))))
- (($ $letrec names syms funs body) (term-folder body seed ...))
(_ (values seed ...))))
(define (clause-folder clause seed ...)
(match clause
@@ -567,12 +561,7 @@
(values (max label max-label)
(match cont
(($ $kargs names vars body)
- (let lp ((body body) (max-var (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))))
+ (fold max max-var vars))
(($ $kfun src meta self)
(max self max-var))
(_ max-var))))
@@ -612,7 +601,6 @@
(let lp ((body body))
(match body
(($ $letk conts body) (lp body))
- (($ $letrec names vars funs body) (lp body))
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler) (proc k handler))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 479d56d..7448eb0 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -40,13 +40,6 @@
(rewrite-cps-term term
(($ $letk conts 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)
,(visit-exp k src exp))))
@@ -143,6 +136,14 @@
(($ $fun free body)
,(adapt-exp 1 k src (build-cps-exp
($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))
;; In general, calls have unknown return arity. For that
;; reason every non-tail call has a $kreceive continuation to
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 90e6bdc..8848e07 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -23,15 +23,16 @@
;;; make-closure primcalls, and free variables are referenced through
;;; the closure.
;;;
-;;; Closure conversion also removes any $letrec forms that contification
-;;; did not handle. See (language cps) for a further discussion of
-;;; $letrec.
+;;; 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
lset-union lset-difference
list-index))
#:use-module (srfi srfi-9)
@@ -48,7 +49,8 @@
(let ((bound-vars (make-hash-table))
(free-vars (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)
(hashq-set! named-funs var cont)
(match cont
@@ -97,13 +99,6 @@
(union (visit-cont cont bound) free))
(visit-term body bound)
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))
(match (lookup-predecessors k dfg)
((_) (match (lookup-cont k dfg)
@@ -111,6 +106,14 @@
(add-named-fun! var body))))
(_ #f))
(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)
(visit-exp exp bound))))
(define (visit-exp exp bound)
@@ -138,7 +141,8 @@
(let ((free (visit-cont exp '())))
(unless (null? free)
(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 (well-known? label)
@@ -229,7 +233,8 @@
(vector-set! var-aliases var alias))))))
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)
(bitvector-ref well-known label))
@@ -422,31 +427,18 @@ bound to @var{var}, and continue with @var{body}."
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $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)
(match term
(($ $letk conts body)
(build-cps-term
- ($letk ,(map 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)))))))
+ ($letk ,(filter-map maybe-visit-cont conts) ,(visit-term body))))
(($ $continue k src (or ($ $const) ($ $prim)))
term)
@@ -475,6 +467,31 @@ bound to @var{var}, and continue with @var{body}."
src var (well-known? kfun) fun-free
(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))
(match (hashq-ref named-funs proc)
(($ $cont kfun)
@@ -534,7 +551,7 @@ and allocate and initialize flat closures."
(let ((dfg (compute-dfg fun)))
(with-fresh-name-state-from-dfg 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) <))
(aliases (make-vector (var-counter) #f)))
(prune-free-vars free-vars named-funs well-known aliases)
@@ -543,5 +560,6 @@ and allocate and initialize flat closures."
,(map (lambda (label)
(convert-one (hashq-ref bound-vars label) label
(lookup-cont label dfg)
- free-vars named-funs well-known aliases))
+ free-vars named-funs well-known aliases
+ letrec-conts))
labels)))))))))
diff --git a/module/language/cps/constructors.scm
b/module/language/cps/constructors.scm
index 16de825..1416f17 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -46,9 +46,6 @@
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(visit-term body)))
- (($ $letrec names syms funs body)
- ($letrec names syms (map visit-fun funs)
- ,(visit-term body)))
(($ $continue k src ($ $primcall 'list args))
,(let-fresh (kvalues) (val)
(build-cps-term
@@ -91,6 +88,8 @@
($primcall 'make-vector (len init))))))))
(($ $continue k src (and 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)
,term)))
(define (visit-fun fun)
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index dc832c3..88bc097 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -43,14 +43,11 @@
(scope-table (make-hash-table))
(call-substs '())
(cont-substs '())
- (fun-elisions '())
(cont-splices (make-hash-table)))
(define (subst-call! sym arities body-ks)
(set! call-substs (acons sym (map cons arities body-ks) call-substs)))
(define (subst-return! old-tail new-tail)
(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)
(for-each (match-lambda
(($ $cont k) (hashq-set! scope-table k scope)))
@@ -237,45 +234,6 @@
(($ $letk conts body)
(for-each visit-cont conts)
(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)
(match exp
(($ $fun free
@@ -287,15 +245,60 @@
(extract-arities clause)
(extract-bodies clause))))
(begin
- (elide-function! k (lookup-cont k dfg))
(for-each visit-cont (extract-bodies clause)))
(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)))))
(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)
(and=> (assq-ref call-substs proc)
(lambda (clauses)
@@ -331,8 +334,6 @@
((cont ...)
(let lp ((term term))
(rewrite-cps-term term
- (($ $letrec names syms funs body)
- ($letrec names syms funs ,(lp body)))
(($ $letk conts* body)
($letk ,(append conts* (filter-map visit-cont cont))
,body))
@@ -345,16 +346,18 @@
($fun free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont (? (cut assq <> fun-elisions)))
- ;; This cont gets inlined in place of the $fun.
- ,#f)
- (($ $cont sym ($ $kargs names syms body))
- (sym ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
- (($ $cont sym ($ $kclause arity body alternate))
- (sym ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
+ (($ $cont label ($ $kargs names syms body))
+ ;; Remove bindings for functions that have been contified.
+ ,(rewrite-cps-cont (filter (match-lambda
+ ((name sym) (not (assq sym call-substs))))
+ (map list names syms))
+ (((names syms) ...)
+ (label ($kargs names syms ,(visit-term body label))))))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(define (visit-term term term-k)
@@ -364,37 +367,37 @@
(let lp ((body (visit-term body term-k)))
;; Because we attach contified functions on a particular
;; term-k, and one term-k can correspond to an arbitrarily
- ;; nested sequence of $letrec and $letk instances, normalize
- ;; so that all continuations are bound by one $letk --
- ;; guaranteeing that they are in the same scope.
+ ;; nested sequence of $letk instances, normalize so that all
+ ;; continuations are bound by one $letk -- guaranteeing that
+ ;; they are in the same scope.
(rewrite-cps-term body
- (($ $letrec names syms funs body)
- ($letrec names syms funs ,(lp body)))
(($ $letk conts* body)
($letk ,(append conts* (filter-map visit-cont conts))
,body))
(body
($letk ,(filter-map visit-cont conts)
,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)
(splice-continuations
term-k
(match exp
- (($ $fun)
- (cond
- ((assq-ref fun-elisions k)
- => (match-lambda
- (($ $kargs (_) (_) body)
- (visit-term body k))))
- (else
- (continue k src (visit-fun exp)))))
+ (($ $fun free
+ ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k))))
+ ;; If the function's tail continuation has been substituted,
+ ;; that means it has been contified.
+ (continue k src
+ (if (assq tail-k cont-substs)
+ (build-cps-exp ($values ()))
+ (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)
(or (contify-call src proc args)
(continue k src exp)))
@@ -403,9 +406,9 @@
(define (contify 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)
fun
;; Iterate to fixed point.
(contify
- (apply-contification fun call-substs cont-substs fun-elisions
cont-splices))))))
+ (apply-contification fun call-substs cont-substs cont-splices))))))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 593346e..3534596 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -39,7 +39,6 @@
(let lp ((body body))
(match body
(($ $letk conts body) (lp body))
- (($ $letrec names vars funs body) (lp body))
(($ $continue k src exp)
(match exp
(($ $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)))
(match cont
(($ $kargs names vars body)
- (let lp ((body body)
- (min-var (fold min min-var 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)))))
+ (values min-label label-count
+ (fold min min-var vars) (+ var-count (length vars))))
(($ $kfun src meta self)
(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))
(($ $prim name) (cons 'prim name))
(($ $fun free body) #f)
+ (($ $rec names syms funs) #f)
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name args)
@@ -475,12 +467,19 @@ could be that both true and false proofs are available."
(($ $prompt escape? 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)
(match exp
- (($ $fun free body)
+ (($ $fun)
+ (build-cps-term
+ ($continue k src ,(visit-fun exp))))
+ (($ $rec names syms funs)
(build-cps-term
- ($continue k src
- ($fun (map subst-var free) ,(cse body dfg)))))
+ ($continue k src ($rec names syms (map visit-fun funs)))))
(_
(cond
((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
(($ $letk conts body)
,(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)
,(let ((conts (append-map visit-dom-conts
(vector-ref doms (label->idx label)))))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index e6780c3..0be9d61 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -190,14 +190,6 @@
(let lp ((body body))
(match 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)
(unless (bitvector-ref live-conts n)
(when (visit-grey-exp n exp)
@@ -209,6 +201,13 @@
#f)
(($ $fun free 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)
(mark-live! tag))
(($ $call proc args)
@@ -309,22 +308,6 @@
(match (visit-conts 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))
(match (vector-ref defs (label->idx term-k))
(#f term)
@@ -336,19 +319,36 @@
($continue k src ($values args)))))))
(($ $continue k src exp)
(if (bitvector-ref live-conts (label->idx term-k))
- (rewrite-cps-term exp
+ (match exp
(($ $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))
- ((or #f ((? value-live?) ...))
- (build-cps-term
- ($continue k src ,exp)))
- (syms
- (let-fresh (adapt) ()
- (build-cps-term
- ($letk (,(make-adaptor adapt k syms))
- ($continue adapt src ,exp))))))))
+ (match (vector-ref defs (label->idx term-k))
+ ((or #f ((? value-live?) ...))
+ (build-cps-term
+ ($continue k src ,exp)))
+ (syms
+ (let-fresh (adapt) ()
+ (build-cps-term
+ ($letk (,(make-adaptor adapt k syms))
+ ($continue adapt src ,exp))))))))
(build-cps-term ($continue k src ($values ())))))))
(visit-cont fun))))
(visit-fun fun))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index e2cc4a2..6cba764 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -566,32 +566,14 @@ body continuation in the prompt."
min-var max-var var-count)
(let ((min-label (min* label min-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
(($ $kargs names vars body)
- (call-with-values
- (lambda ()
- (if global?
- (visit-letrec body min-var max-var var-count)
- (values min-var max-var var-count)))
- (lambda (min-var max-var var-count)
- (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))))))
+ (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)
(values min-label max-label (1+ label-count)
(min* self min-var) (max self max-var) (1+ var-count)))
@@ -653,16 +635,6 @@ body continuation in the prompt."
cont k)
(for-each/2 visit-cont cont k)
(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)
(link-blocks! label k)
(visit-exp exp label))))
@@ -690,7 +662,15 @@ body continuation in the prompt."
(link-blocks! label handler))
(($ $fun free body)
(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)
(match clause
@@ -769,6 +749,7 @@ body continuation in the prompt."
(($ $const val) (format port "const address@hidden" val))
(($ $prim name) (format port "prim ~a" name))
(($ $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))
(($ $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)))
@@ -820,7 +801,6 @@ body continuation in the prompt."
(match term
(($ $kargs names syms body) (find-call body))
(($ $letk conts body) (find-call body))
- (($ $letrec names syms funs body) (find-call body))
(($ $continue) term)))
(define (call-expression call)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 3c0da24..7a49f86 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -443,7 +443,7 @@ is or might be a read or a write to the same location as A."
(match exp
((or ($ $const) ($ $prim) ($ $values))
&no-effects)
- (($ $fun)
+ ((or ($ $fun) ($ $rec))
(&allocate &unknown-memory-kinds))
(($ $prompt)
(&write-object &prompt))
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
index 6823deb..100ad1f 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -52,9 +52,6 @@
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(visit-term body)))
- (($ $letrec names syms funs body)
- ($letrec names syms (map visit-fun funs)
- ,(visit-term body)))
(($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (vector-ref conts k)
(($ $ktail)
@@ -95,6 +92,8 @@
($continue k src ($values vals))))))))
(($ $continue k src (and 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)
,term)))
(define (visit-fun fun)
diff --git a/module/language/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
index 3ba28d9..cc0c08b 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -60,9 +60,6 @@
(define (visit-term term ktail)
(rewrite-cps-term term
- (($ $letrec names vars funs body)
- ($letrec names vars (map visit-fun funs)
- ,(visit-term body ktail)))
(($ $letk conts body)
($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
,(visit-term body ktail)))
@@ -72,6 +69,8 @@
(define (visit-exp k src exp ktail)
(rewrite-cps-term 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)
,(if (eq? k ktail)
(build-cps-term ($continue k src ,exp))
diff --git a/module/language/cps/prune-top-level-scopes.scm
b/module/language/cps/prune-top-level-scopes.scm
index ed09074..f300db4 100644
--- a/module/language/cps/prune-top-level-scopes.scm
+++ b/module/language/cps/prune-top-level-scopes.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -53,12 +53,11 @@
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body))
- (($ $letrec names syms funs body)
- (for-each visit-fun funs)
- (visit-term body))
(($ $continue k src exp)
(match exp
(($ $fun) (visit-fun exp))
+ (($ $rec names syms funs)
+ (for-each visit-fun funs))
(($ $primcall 'cached-toplevel-box (scope name bound?))
(hashq-set! scope-var->used? scope #t))
(($ $primcall 'cache-current-module! (module scope))
@@ -105,8 +104,6 @@
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
- (($ $letrec names syms funs body)
- ($letrec names syms funs ,(visit-term body)))
(($ $continue k src
(and ($ $primcall 'cache-current-module! (module scope))
(? (lambda _
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 4bbeb36..58968a7 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -52,7 +52,6 @@
(let lp ((body body))
(match body
(($ $letk conts body) (lp body))
- (($ $letrec names syms funs body) (lp body))
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler)
@@ -168,8 +167,6 @@
(visit-cont (car conts))
(lp (cdr conts))))
(visit-term body label))
- (($ $letrec names syms funs body)
- (visit-term body label))
(($ $continue k src exp)
(add-predecessor! label k)
(match exp
@@ -222,19 +219,17 @@
(($ $letk conts body)
(for-each visit-cont conts)
(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?
- (for-each rename! syms)
(set! queue (fold (lambda (fun queue)
(match fun
(($ $fun free body)
(cons body queue))))
queue
- funs)))
- (visit-term body reachable?))
- (($ $continue k src ($ $fun free body))
- (when reachable?
- (set! queue (cons body queue))))
+ funs))))
(($ $continue) #f)))
(match fun
@@ -301,9 +296,6 @@
,(match (visit-conts 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 (relabel k) src ,(visit-exp exp)))))
(define (visit-exp exp)
@@ -314,6 +306,8 @@
(build-cps-exp ($closure (relabel k) nfree)))
(($ $fun)
(visit-fun exp))
+ (($ $rec names vars funs)
+ (build-cps-exp ($rec names (map rename vars) (map visit-fun funs))))
(($ $values args)
(let ((args (map rename args)))
(build-cps-exp ($values args))))
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
index 62d3f65..6cf2545 100644
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.scm
@@ -45,9 +45,6 @@
(define (visit-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 ,(map visit-cont conts)
,(visit-term body)))
@@ -59,6 +56,8 @@
((or ($ $const) ($ $prim)) ,exp)
(($ $fun free body)
($fun free ,(resolve-self-references body env)))
+ (($ $rec names vars funs)
+ ($rec names vars (map visit-recursive-fun funs vars)))
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index d74767f..8f3b630 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -50,14 +50,13 @@
(($ $letk conts body)
(for-each visit-cont conts)
(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))
(when (and (equal? term-args args) (not (eq? k term-k)))
(hashq-set! table term-k k)))
(($ $continue k src (and fun ($ $fun)))
(visit-fun fun))
+ (($ $continue k src ($ $rec names syms funs))
+ (for-each visit-fun funs))
(($ $continue k src _)
#f)))
(define (visit-fun fun)
@@ -126,13 +125,12 @@
(($ $letk conts body)
($letk ,(map (cut visit-cont <> scope) conts)
,(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 (reduce-values k scope) src ($values args)))
(($ $continue k src (and 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))
,(let ((k (reduce k scope)))
(or (reduce-const k src scope const)
@@ -168,9 +166,6 @@
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body))
- (($ $letrec names syms funs body)
- (for-each visit-fun funs)
- (visit-term body))
(($ $continue k src ($ $values args))
(match (lookup-cont k dfg)
(($ $kargs names syms body)
@@ -188,6 +183,8 @@
(_ #f)))
(($ $continue k src (and fun ($ $fun)))
(visit-fun fun))
+ (($ $continue k src ($ $rec names syms funs))
+ (for-each visit-fun funs))
(($ $continue k src _)
#f)))
(define (visit-fun fun)
@@ -227,10 +224,6 @@
(() (visit-term body))
(conts (build-cps-term
($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)
(cond
((hashq-ref k-table k) => visit-term)
@@ -240,6 +233,8 @@
(match exp
((or ($ $const) ($ $prim)) exp)
(($ $fun) (visit-fun exp))
+ (($ $rec names syms funs)
+ (build-cps-exp ($rec names (map subst syms) (map visit-fun funs))))
(($ $call proc args)
(let ((args (map subst args)))
(build-cps-exp ($call (subst proc) args))))
@@ -284,10 +279,17 @@
(label ($kargs names vars ,(visit-term body label))))
(_ (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)
(rewrite-cps-term exp
(($ $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))))
@@ -311,15 +313,6 @@
(rewrite-cps-term term
(($ $letk conts body)
,(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)
,(let ((conts (visit-dom-conts* (vector-ref doms label))))
(if (null? conts)
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index cb5a70d..3a840dd 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -54,11 +54,10 @@
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(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 ,(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))
,(visit-primcall k src name args))
(($ $continue)
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index 21f242b..c13f7fb 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -1,5 +1,5 @@
;;; 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
;;; it under the terms of the GNU Lesser General Public License as
@@ -356,8 +356,6 @@
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body label))
- (($ $letrec _ _ _ body)
- (visit-term body label))
(($ $continue k src ($ $primcall name args))
;; We might be able to fold primcalls that define a value.
(match (lookup-cont k dfg)
@@ -402,11 +400,10 @@
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(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 ,(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)))
,(cond
((bitvector-ref folded? (label->idx label))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index e508bf4..7e26600 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1304,6 +1304,9 @@ mapping symbols to types."
(propagate! 0 k types))))
((or ($ $call) ($ $callk))
(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)
(($ $kargs (_) (var))
@@ -1333,11 +1336,6 @@ mapping symbols to types."
(($ $kargs names vars term)
(let visit-term ((term term) (types types))
(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)
(visit-term term types))
(($ $continue k src exp)
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index e005594..e10cf83 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -143,6 +143,13 @@
#t)
(($ $fun)
(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 ...))
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
@@ -177,13 +184,6 @@
(for-each (cut visit-cont-body <> k-env v-env) cont)
(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)
(check-label k k-env)
(check-src src)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 0cea636..65bec09 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -524,16 +524,18 @@
(($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.
(if (current-topbox-scope)
- (let-fresh () (self)
- (build-cps-term
- ($letrec names
- (map bound-var gensyms)
- (map (lambda (fun)
- (match (convert fun k subst)
- (($ $continue _ _ (and fun ($ $fun)))
- fun)))
- funs)
- ,(convert body k subst))))
+ (let ((vars (map bound-var gensyms)))
+ (let-fresh (krec) ()
+ (build-cps-term
+ ($letk ((krec ($kargs names vars
+ ,(convert body k subst))))
+ ($continue krec src
+ ($rec names vars
+ (map (lambda (fun)
+ (match (convert fun k subst)
+ (($ $continue _ _ (and fun ($ $fun)))
+ fun)))
+ funs)))))))
(let ((scope-id (fresh-scope-id)))
(let-fresh (kscope) ()
(build-cps-term
- [Guile-commits] branch master updated (dfa11aa -> 50fcdfe), Andy Wingo, 2015/04/01
- [Guile-commits] 02/04: Precise range inference on <, <=, >=, > branches, Andy Wingo, 2015/04/01
- [Guile-commits] 01/04: Fix intmap bug for maps with only one element, Andy Wingo, 2015/04/01
- [Guile-commits] 04/04: Remove "free" field of $fun, Andy Wingo, 2015/04/01
- [Guile-commits] 03/04: Replace $letrec with $rec,
Andy Wingo <=