diff options
author | Andy Wingo <wingo@pobox.com> | 2015-04-01 09:51:13 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-04-01 10:10:10 +0200 |
commit | 34ff3af9f0024c6d5163f422ca5e1202a560efe3 (patch) | |
tree | 0ae6a9d9a969d5f089497554d546b4cb4913c774 | |
parent | 4ce1857019d046049923c910a19817b594930a5b (diff) | |
download | guile-34ff3af9f0024c6d5163f422ca5e1202a560efe3.tar.gz |
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.
-rw-r--r-- | doc/ref/compiler.texi | 114 | ||||
-rw-r--r-- | module/language/cps.scm | 52 | ||||
-rw-r--r-- | module/language/cps/arities.scm | 15 | ||||
-rw-r--r-- | module/language/cps/closure-conversion.scm | 90 | ||||
-rw-r--r-- | module/language/cps/constructors.scm | 7 | ||||
-rw-r--r-- | module/language/cps/contification.scm | 163 | ||||
-rw-r--r-- | module/language/cps/cse.scm | 35 | ||||
-rw-r--r-- | module/language/cps/dce.scm | 70 | ||||
-rw-r--r-- | module/language/cps/dfg.scm | 52 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 2 | ||||
-rw-r--r-- | module/language/cps/elide-values.scm | 7 | ||||
-rw-r--r-- | module/language/cps/prune-bailouts.scm | 7 | ||||
-rw-r--r-- | module/language/cps/prune-top-level-scopes.scm | 9 | ||||
-rw-r--r-- | module/language/cps/renumber.scm | 20 | ||||
-rw-r--r-- | module/language/cps/self-references.scm | 5 | ||||
-rw-r--r-- | module/language/cps/simplify.scm | 39 | ||||
-rw-r--r-- | module/language/cps/specialize-primcalls.scm | 5 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 9 | ||||
-rw-r--r-- | module/language/cps/types.scm | 8 | ||||
-rw-r--r-- | module/language/cps/verify.scm | 14 | ||||
-rw-r--r-- | 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 640733838..9743c5357 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. -@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 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}. + +@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 language. Recall that all expressions are wrapped in a @code{$continue} term which specifies their continuation. -@deftp {CPS Expression} $void -Continue with the unspecified value. -@end 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 -@deftp {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. +@deftp {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, +@var{body} is the @code{$kfun} @code{$cont} of the procedure entry. +@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 @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 +@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 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 -@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. +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 +@code{$kargs} 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. -@deftp {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. +@deftp {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. -@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 @deftp {CPS Continuation} $ktail A tail continuation. @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 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 - @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) +@deffnx {Scheme Syntax} build-cps-term ($program conts) @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 ($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 ee201979f..3e0748ff5 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 479d56dcb..7448eb006 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 90e6bdcd2..8848e0725 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 16de82569..1416f1782 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 dc832c338..88bc097b0 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 593346ee9..3534596c5 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 e6780c35a..0be9d61c4 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 e2cc4a218..6cba7649f 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 ~@y" 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 3c0da24d7..7a49f869f 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 6823debbc..100ad1f5b 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 3ba28d900..cc0c08bc7 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 ed0907429..f300db408 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 4bbeb36ef..58968a7bb 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 62d3f654a..6cf2545ec 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 d74767f92..8f3b63078 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 cb5a70d89..3a840dd07 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 21f242b20..c13f7fb43 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 e508bf49b..7e26600c0 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 e005594d3..e10cf8319 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 0cea636ea..65bec09b5 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 |