[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 13/13: Rename CPS2 to CPS
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 13/13: Rename CPS2 to CPS |
|
Date: |
Wed, 22 Jul 2015 15:32:30 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit aa7f0e25ac8ea8340745f6aa337a9f0c64f00881
Author: Andy Wingo <address@hidden>
Date: Wed Jul 22 17:18:30 2015 +0200
Rename CPS2 to CPS
---
module/Makefile.am | 57 +-
module/language/cps2.scm | 362 -----
module/language/cps2/closure-conversion.scm | 824 ------------
module/language/cps2/compile-bytecode.scm | 433 ------
module/language/cps2/constructors.scm | 98 --
module/language/cps2/contification.scm | 475 -------
module/language/cps2/cse.scm | 449 -------
module/language/cps2/dce.scm | 399 ------
module/language/cps2/effects-analysis.scm | 484 -------
module/language/cps2/elide-values.scm | 88 --
module/language/cps2/optimize.scm | 106 --
module/language/cps2/prune-bailouts.scm | 86 --
module/language/cps2/prune-top-level-scopes.scm | 63 -
module/language/cps2/reify-primitives.scm | 167 ---
module/language/cps2/renumber.scm | 217 ---
module/language/cps2/self-references.scm | 79 --
module/language/cps2/simplify.scm | 267 ----
module/language/cps2/slot-allocation.scm | 995 --------------
module/language/cps2/spec.scm | 37 -
module/language/cps2/specialize-primcalls.scm | 59 -
module/language/cps2/split-rec.scm | 174 ---
module/language/cps2/type-fold.scm | 425 ------
module/language/cps2/types.scm | 1408 --------------------
module/language/cps2/utils.scm | 477 -------
module/language/cps2/verify.scm | 306 -----
module/language/cps2/with-cps.scm | 145 --
.../tree-il/{compile-cps2.scm => compile-cps.scm} | 12 +-
module/language/tree-il/spec.scm | 6 +-
28 files changed, 36 insertions(+), 8662 deletions(-)
diff --git a/module/Makefile.am b/module/Makefile.am
index c53f9e4..b29a4bf 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -60,7 +60,6 @@ SOURCES = \
\
language/tree-il.scm \
$(TREE_IL_LANG_SOURCES) \
- $(CPS2_LANG_SOURCES) \
$(CPS_LANG_SOURCES) \
$(BYTECODE_LANG_SOURCES) \
$(VALUE_LANG_SOURCES) \
@@ -117,39 +116,37 @@ TREE_IL_LANG_SOURCES =
\
language/tree-il/canonicalize.scm \
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
- language/tree-il/compile-cps2.scm \
+ language/tree-il/compile-cps.scm \
language/tree-il/debug.scm \
language/tree-il/spec.scm
CPS_LANG_SOURCES = \
- language/cps/primitives.scm
-
-CPS2_LANG_SOURCES = \
- language/cps2.scm \
- language/cps2/closure-conversion.scm \
- language/cps2/compile-bytecode.scm \
- language/cps2/constructors.scm \
- language/cps2/contification.scm \
- language/cps2/cse.scm \
- language/cps2/dce.scm \
- language/cps2/effects-analysis.scm \
- language/cps2/elide-values.scm \
- language/cps2/prune-bailouts.scm \
- language/cps2/prune-top-level-scopes.scm \
- language/cps2/reify-primitives.scm \
- language/cps2/renumber.scm \
- language/cps2/optimize.scm \
- language/cps2/simplify.scm \
- language/cps2/self-references.scm \
- language/cps2/slot-allocation.scm \
- language/cps2/spec.scm \
- language/cps2/specialize-primcalls.scm \
- language/cps2/split-rec.scm \
- language/cps2/type-fold.scm \
- language/cps2/types.scm \
- language/cps2/utils.scm \
- language/cps2/verify.scm \
- language/cps2/with-cps.scm
+ language/cps.scm \
+ language/cps/closure-conversion.scm \
+ language/cps/compile-bytecode.scm \
+ language/cps/constructors.scm \
+ language/cps/contification.scm \
+ language/cps/cse.scm \
+ language/cps/dce.scm \
+ language/cps/effects-analysis.scm \
+ language/cps/elide-values.scm \
+ language/cps/primitives.scm \
+ language/cps/prune-bailouts.scm \
+ language/cps/prune-top-level-scopes.scm \
+ language/cps/reify-primitives.scm \
+ language/cps/renumber.scm \
+ language/cps/optimize.scm \
+ language/cps/simplify.scm \
+ language/cps/self-references.scm \
+ language/cps/slot-allocation.scm \
+ language/cps/spec.scm \
+ language/cps/specialize-primcalls.scm \
+ language/cps/split-rec.scm \
+ language/cps/type-fold.scm \
+ language/cps/types.scm \
+ language/cps/utils.scm \
+ language/cps/verify.scm \
+ language/cps/with-cps.scm
BYTECODE_LANG_SOURCES = \
language/bytecode.scm \
diff --git a/module/language/cps2.scm b/module/language/cps2.scm
deleted file mode 100644
index 76219f3..0000000
--- a/module/language/cps2.scm
+++ /dev/null
@@ -1,362 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; [Transitional note: CPS2 is a new version of CPS, and is a bit of an
-;;; experiment. All of the comments in this file pretend that CPS2 will
-;;; replace CPS, and will be named CPS.]
-;;;
-;;; This is the continuation-passing style (CPS) intermediate language
-;;; (IL) for Guile.
-;;;
-;;; In CPS, a term is a labelled expression that calls a continuation.
-;;; A function is a collection of terms. No term belongs to more than
-;;; one function. The function is identified by the label of its entry
-;;; term, and its body is composed of those terms that are reachable
-;;; from the entry term. A program is a collection of functions,
-;;; identified by the entry label of the entry function.
-;;;
-;;; Terms are themselves wrapped in continuations, which specify how
-;;; predecessors may continue to them. For example, a $kargs
-;;; continuation specifies that the term may be called with a specific
-;;; number of values, and that those values will then be bound to
-;;; lexical variables. $kreceive specifies that some number of values
-;;; will be passed on the stack, as from a multiple-value return. Those
-;;; values will be passed to a $kargs, if the number of values is
-;;; compatible with the $kreceive's arity. $kfun is an entry point to a
-;;; function, and receives arguments according to a well-known calling
-;;; convention (currently, on the stack) and the stack before
-;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and
-;;; only appears within a $kfun; it checks the incoming values for the
-;;; correct arity and dispatches to a $kargs, or to the next clause.
-;;; Finally, $ktail is the tail continuation for a function, and
-;;; contains no term.
-;;;
-;;; Each continuation has a label that is unique in the program. As an
-;;; implementation detail, the labels are integers, which allows us to
-;;; easily sort them topologically. A program is a map from integers to
-;;; continuations, where continuation 0 in the map is the entry point
-;;; for the program, and is a $kfun of no arguments.
-;;;
-;;; $continue nodes call continuations. The expression contained in the
-;;; $continue node determines the value or values that are passed to the
-;;; target continuation: $const to pass a constant value, $values to
-;;; pass multiple named values, etc. $continue nodes also record the
-;;; source location corresponding to the expression.
-;;;
-;;; As mentioned above, a $kargs continuation can bind variables, if it
-;;; receives incoming values. $kfun also binds a value, corresponding
-;;; to the closure being called. A traditional CPS implementation will
-;;; nest terms in each other, binding them in "let" forms, ensuring that
-;;; continuations are declared and bound within the scope of the values
-;;; that they may use. In this way, the scope tree is a proof that
-;;; variables are defined before they are used. However, this proof is
-;;; conservative; it is possible for a variable to always be defined
-;;; before it is used, but not to be in scope:
-;;;
-;;; (letrec ((k1 (lambda (v1) (k2)))
-;;; (k2 (lambda () v1)))
-;;; (k1 0))
-;;;
-;;; This example is invalid, as v1 is used outside its scope. However
-;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside
-;;; k1:
-;;;
-;;; (letrec ((k1 (lambda (v1)
-;;; (letrec ((k2 (lambda () v1)))
-;;; (k2))))
-;;; (k1 0))
-;;;
-;;; Because program transformation usually uses flow-based analysis,
-;;; having to update the scope tree to manifestly prove a transformation
-;;; that has already proven correct is needless overhead, and in the
-;;; worst case can prevent optimizations from occuring. For that
-;;; reason, Guile's CPS language does not nest terms. Instead, we use
-;;; the invariant that definitions must dominate uses. To check the
-;;; validity of a CPS program is thus more involved than checking for a
-;;; well-scoped tree; you have to do flow analysis to determine a
-;;; dominator tree. However the flexibility that this grants us is
-;;; worth the cost of throwing away the embedded proof of the scope
-;;; tree.
-;;;
-;;; This particular formulation of CPS was inspired by Andrew Kennedy's
-;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
-;;; hackers should read that excellent paper! As in Kennedy's paper,
-;;; continuations are second-class, and may be thought of as basic block
-;;; labels. All values are bound to variables using continuation calls:
-;;; even constants!
-;;;
-;;; Finally, note that there are two flavors of CPS: higher-order and
-;;; first-order. By "higher-order", we mean that variables may be free
-;;; across function boundaries. Higher-order CPS contains $fun and $rec
-;;; expressions that declare functions in the scope of their term.
-;;; Closure conversion results in first-order CPS, where closure
-;;; representations have been explicitly chosen, and all variables used
-;;; in a function are bound. Higher-order CPS is good for
-;;; interprocedural optimizations like contification and beta reduction,
-;;; while first-order CPS is better for instruction selection, register
-;;; allocation, and code generation.
-;;;
-;;; See (language tree-il compile-cps) for details on how Tree-IL
-;;; converts to CPS.
-;;;
-;;; Code:
-
-(define-module (language cps2)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-9 gnu)
- #:use-module (srfi srfi-11)
- #:export (;; Helper.
- $arity
- make-$arity
-
- ;; Continuations.
- $kreceive $kargs $kfun $ktail $kclause
-
- ;; Terms.
- $continue
-
- ;; Expressions.
- $const $prim $fun $rec $closure $branch
- $call $callk $primcall $values $prompt
-
- ;; Building macros.
- build-cont build-term build-exp
- rewrite-cont rewrite-term rewrite-exp
-
- ;; External representation.
- parse-cps unparse-cps))
-
-;; FIXME: Use SRFI-99, when Guile adds it.
-(define-syntax define-record-type*
- (lambda (x)
- (define (id-append ctx . syms)
- (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
- (syntax-case x ()
- ((_ name field ...)
- (and (identifier? #'name) (and-map identifier? #'(field ...)))
- (with-syntax ((cons (id-append #'name #'make- #'name))
- (pred (id-append #'name #'name #'?))
- ((getter ...) (map (lambda (f)
- (id-append f #'name #'- f))
- #'(field ...))))
- #'(define-record-type name
- (cons field ...)
- pred
- (field getter)
- ...))))))
-
-(define-syntax-rule (define-cps-type name field ...)
- (begin
- (define-record-type* name field ...)
- (set-record-type-printer! name print-cps)))
-
-(define (print-cps exp port)
- (format port "#<cps ~S>" (unparse-cps exp)))
-
-;; Helper.
-(define-record-type* $arity req opt rest kw allow-other-keys?)
-
-;; Continuations
-(define-cps-type $kreceive arity kbody)
-(define-cps-type $kargs names syms term)
-(define-cps-type $kfun src meta self ktail kclause)
-(define-cps-type $ktail)
-(define-cps-type $kclause arity kbody kalternate)
-
-;; Terms.
-(define-cps-type $continue k src exp)
-
-;; Expressions.
-(define-cps-type $const val)
-(define-cps-type $prim name)
-(define-cps-type $fun body) ; Higher-order.
-(define-cps-type $rec names syms funs) ; Higher-order.
-(define-cps-type $closure label nfree) ; First-order.
-(define-cps-type $branch kt exp)
-(define-cps-type $call proc args)
-(define-cps-type $callk k proc args) ; First-order.
-(define-cps-type $primcall name args)
-(define-cps-type $values args)
-(define-cps-type $prompt escape? tag handler)
-
-(define-syntax build-arity
- (syntax-rules (unquote)
- ((_ (unquote exp)) exp)
- ((_ (req opt rest kw allow-other-keys?))
- (make-$arity req opt rest kw allow-other-keys?))))
-
-(define-syntax build-cont
- (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
- ((_ (unquote exp))
- exp)
- ((_ ($kreceive req rest kargs))
- (make-$kreceive (make-$arity req '() rest '() #f) kargs))
- ((_ ($kargs (name ...) (unquote syms) body))
- (make-$kargs (list name ...) syms (build-term body)))
- ((_ ($kargs (name ...) (sym ...) body))
- (make-$kargs (list name ...) (list sym ...) (build-term body)))
- ((_ ($kargs names syms body))
- (make-$kargs names syms (build-term body)))
- ((_ ($kfun src meta self ktail kclause))
- (make-$kfun src meta self ktail kclause))
- ((_ ($ktail))
- (make-$ktail))
- ((_ ($kclause arity kbody kalternate))
- (make-$kclause (build-arity arity) kbody kalternate))))
-
-(define-syntax build-term
- (syntax-rules (unquote $rec $continue)
- ((_ (unquote exp))
- exp)
- ((_ ($continue k src exp))
- (make-$continue k src (build-exp exp)))))
-
-(define-syntax build-exp
- (syntax-rules (unquote
- $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 kentry)) (make-$fun kentry))
- ((_ ($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 ...)))
- ((_ ($call proc args)) (make-$call proc args))
- ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
- ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
- ((_ ($callk k proc args)) (make-$callk k proc args))
- ((_ ($primcall name (unquote args))) (make-$primcall name args))
- ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
- ((_ ($primcall name args)) (make-$primcall name args))
- ((_ ($values (unquote args))) (make-$values args))
- ((_ ($values (arg ...))) (make-$values (list arg ...)))
- ((_ ($values args)) (make-$values args))
- ((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
- ((_ ($prompt escape? tag handler))
- (make-$prompt escape? tag handler))))
-
-(define-syntax-rule (rewrite-cont x (pat cont) ...)
- (match x
- (pat (build-cont cont)) ...))
-(define-syntax-rule (rewrite-term x (pat term) ...)
- (match x
- (pat (build-term term)) ...))
-(define-syntax-rule (rewrite-exp x (pat body) ...)
- (match x
- (pat (build-exp body)) ...))
-
-(define (parse-cps exp)
- (define (src exp)
- (let ((props (source-properties exp)))
- (and (pair? props) props)))
- (match exp
- ;; Continuations.
- (('kreceive req rest k)
- (build-cont ($kreceive req rest k)))
- (('kargs names syms body)
- (build-cont ($kargs names syms ,(parse-cps body))))
- (('kfun src meta self ktail kclause)
- (build-cont ($kfun (src exp) meta self ktail kclause)))
- (('ktail)
- (build-cont ($ktail)))
- (('kclause (req opt rest kw allow-other-keys?) kbody)
- (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f)))
- (('kclause (req opt rest kw allow-other-keys?) kbody kalt)
- (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
-
- ;; Calls.
- (('continue k exp)
- (build-term ($continue k (src exp) ,(parse-cps exp))))
- (('unspecified)
- (build-exp ($const *unspecified*)))
- (('const exp)
- (build-exp ($const exp)))
- (('prim name)
- (build-exp ($prim name)))
- (('fun kbody)
- (build-exp ($fun kbody)))
- (('closure k nfree)
- (build-exp ($closure k nfree)))
- (('rec (name sym fun) ...)
- (build-exp ($rec name sym (map parse-cps fun))))
- (('call proc arg ...)
- (build-exp ($call proc arg)))
- (('callk k proc arg ...)
- (build-exp ($callk k proc arg)))
- (('primcall name arg ...)
- (build-exp ($primcall name arg)))
- (('branch k exp)
- (build-exp ($branch k ,(parse-cps exp))))
- (('values arg ...)
- (build-exp ($values arg)))
- (('prompt escape? tag handler)
- (build-exp ($prompt escape? tag handler)))
- (_
- (error "unexpected cps" exp))))
-
-(define (unparse-cps exp)
- (match exp
- ;; Continuations.
- (($ $kreceive ($ $arity req () rest () #f) k)
- `(kreceive ,req ,rest ,k))
- (($ $kargs names syms body)
- `(kargs ,names ,syms ,(unparse-cps body)))
- (($ $kfun src meta self ktail kclause)
- `(kfun ,meta ,self ,ktail ,kclause))
- (($ $ktail)
- `(ktail))
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)
- `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
- . ,(if kalternate (list kalternate) '())))
-
- ;; Calls.
- (($ $continue k src exp)
- `(continue ,k ,(unparse-cps exp)))
- (($ $const val)
- (if (unspecified? val)
- '(unspecified)
- `(const ,val)))
- (($ $prim name)
- `(prim ,name))
- (($ $fun kbody)
- `(fun ,kbody))
- (($ $closure k nfree)
- `(closure ,k ,nfree))
- (($ $rec names syms funs)
- `(rec ,@(map (lambda (name sym fun)
- (list name sym (unparse-cps fun)))
- names syms funs)))
- (($ $call proc args)
- `(call ,proc ,@args))
- (($ $callk k proc args)
- `(callk ,k ,proc ,@args))
- (($ $primcall name args)
- `(primcall ,name ,@args))
- (($ $branch k exp)
- `(branch ,k ,(unparse-cps exp)))
- (($ $values args)
- `(values ,@args))
- (($ $prompt escape? tag handler)
- `(prompt ,escape? ,tag ,handler))
- (_
- (error "unexpected cps" exp))))
diff --git a/module/language/cps2/closure-conversion.scm
b/module/language/cps2/closure-conversion.scm
deleted file mode 100644
index 7de3448..0000000
--- a/module/language/cps2/closure-conversion.scm
+++ /dev/null
@@ -1,824 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; This pass converts a CPS term in such a way that no function has any
-;;; free variables. Instead, closures are built explicitly with
-;;; make-closure primcalls, and free variables are referenced through
-;;; the closure.
-;;;
-;;; Closure conversion also removes any $rec expressions that
-;;; contification did not handle. See (language cps) for a further
-;;; discussion of $rec.
-;;;
-;;; Code:
-
-(define-module (language cps2 closure-conversion)
- #:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (fold
- filter-map
- ))
- #:use-module (srfi srfi-11)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 with-cps)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (convert-closures))
-
-(define (compute-function-bodies conts kfun)
- "Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in
-conts."
- (let visit-fun ((kfun kfun) (out empty-intmap))
- (let ((body (compute-function-body conts kfun)))
- (intset-fold
- (lambda (label out)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
- (visit-fun kfun out))
- (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
- (fold visit-fun out kfun))
- (_ out)))
- body
- (intmap-add out kfun body)))))
-
-(define (compute-program-body functions)
- (intmap-fold (lambda (label body out) (intset-union body out))
- functions
- empty-intset))
-
-(define (filter-reachable conts functions)
- (let ((reachable (compute-program-body functions)))
- (intmap-fold
- (lambda (label cont out)
- (if (intset-ref reachable label)
- out
- (intmap-remove out label)))
- conts conts)))
-
-(define (compute-non-operator-uses conts)
- (persistent-intset
- (intmap-fold
- (lambda (label cont uses)
- (define (add-use var uses) (intset-add! uses var))
- (define (add-uses vars uses)
- (match vars
- (() uses)
- ((var . vars) (add-uses vars (add-use var uses)))))
- (match cont
- (($ $kargs _ _ ($ $continue _ _ exp))
- (match exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses)
- (($ $values args)
- (add-uses args uses))
- (($ $call proc args)
- (add-uses args uses))
- (($ $branch kt ($ $values (arg)))
- (add-use arg uses))
- (($ $branch kt ($ $primcall name args))
- (add-uses args uses))
- (($ $primcall name args)
- (add-uses args uses))
- (($ $prompt escape? tag handler)
- (add-use tag uses))))
- (_ uses)))
- conts
- empty-intset)))
-
-(define (compute-singly-referenced-labels conts body)
- (define (add-ref label single multiple)
- (define (ref k single multiple)
- (if (intset-ref single k)
- (values single (intset-add! multiple k))
- (values (intset-add! single k) multiple)))
- (define (ref0) (values single multiple))
- (define (ref1 k) (ref k single multiple))
- (define (ref2 k k*)
- (if k*
- (let-values (((single multiple) (ref k single multiple)))
- (ref k* single multiple))
- (ref1 k)))
- (match (intmap-ref conts label)
- (($ $kreceive arity k) (ref1 k))
- (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
- (($ $ktail) (ref0))
- (($ $kclause arity kbody kalt) (ref2 kbody kalt))
- (($ $kargs names syms ($ $continue k src exp))
- (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
- (let*-values (((single multiple) (values empty-intset empty-intset))
- ((single multiple) (intset-fold add-ref body single multiple)))
- (intset-subtract (persistent-intset single)
- (persistent-intset multiple))))
-
-(define (compute-function-names conts functions)
- "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function
-whose bound vars we know."
- (define (add-named-fun var kfun out)
- (let ((self (match (intmap-ref conts kfun)
- (($ $kfun src meta self) self))))
- (intmap-add out kfun (intset var self))))
- (intmap-fold
- (lambda (label body out)
- (let ((single (compute-singly-referenced-labels conts body)))
- (intset-fold
- (lambda (label out)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue k _ ($ $fun kfun)))
- (if (intset-ref single k)
- (match (intmap-ref conts k)
- (($ $kargs (_) (var)) (add-named-fun var kfun out))
- (_ out))
- out))
- (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun)
...))))
- (unless (intset-ref single k)
- (error "$rec continuation has multiple predecessors??"))
- (fold add-named-fun out vars kfun))
- (_ out)))
- body
- out)))
- functions
- empty-intmap))
-
-(define (compute-well-known-functions conts bound->label)
- "Compute a set of labels indicating the well-known functions in
address@hidden A well-known function is a function whose bound names we
-know and which is never used in a non-operator position."
- (intset-subtract
- (persistent-intset
- (intmap-fold (lambda (bound label candidates)
- (intset-add! candidates label))
- bound->label
- empty-intset))
- (persistent-intset
- (intset-fold (lambda (var not-well-known)
- (match (intmap-ref bound->label var (lambda (_) #f))
- (#f not-well-known)
- (label (intset-add! not-well-known label))))
- (compute-non-operator-uses conts)
- empty-intset))))
-
-(define (intset-cons i set)
- (intset-add set i))
-
-(define (compute-shared-closures conts well-known)
- "Compute a map LABEL->VAR indicating the sets of functions that will
-share a closure. If a functions's label is in the map, it is shared.
-The entries indicate the var of the shared closure, which will be one of
-the bound vars of the closure."
- (intmap-fold
- (lambda (label cont out)
- (match cont
- (($ $kargs _ _
- ($ $continue _ _ ($ $rec names vars (($ $fun kfuns) ...))))
- ;; The split-rec pass should have ensured that this $rec forms a
- ;; strongly-connected component, so the free variables from all of
- ;; the functions will be alive as long as one of the closures is
- ;; alive. For that reason we can consider storing all free
- ;; variables in one closure and sharing it.
- (let* ((kfuns-set (fold intset-cons empty-intset kfuns))
- (unknown-kfuns (intset-subtract kfuns-set well-known)))
- (cond
- ((or (eq? empty-intset kfuns-set) (trivial-intset kfuns-set))
- ;; There is only zero or one function bound here. Trivially
- ;; shared already.
- out)
- ((eq? empty-intset unknown-kfuns)
- ;; All functions are well-known; we can share a closure. Use
- ;; the first bound variable.
- (let ((closure (car vars)))
- (intset-fold (lambda (kfun out)
- (intmap-add out kfun closure))
- kfuns-set out)))
- ((trivial-intset unknown-kfuns)
- => (lambda (unknown-kfun)
- ;; Only one function is not-well-known. Use that
- ;; function's closure as the shared closure.
- (let ((closure (assq-ref (map cons kfuns vars) unknown-kfun)))
- (intset-fold (lambda (kfun out)
- (intmap-add out kfun closure))
- kfuns-set out))))
- (else
- ;; More than one not-well-known function means we need more
- ;; than one proper closure, so we can't share.
- out))))
- (_ out)))
- conts
- empty-intmap))
-
-(define* (rewrite-shared-closure-calls cps functions label->bound shared kfun)
- "Rewrite CPS such that every call to a function with a shared closure
-instead is a $callk to that label, but passing the shared closure as the
-proc argument. For recursive calls, use the appropriate 'self'
-variable, if possible. Also rewrite uses of the non-well-known but
-shared closures to use the appropriate 'self' variable, if possible."
- ;; env := var -> (var . label)
- (define (rewrite-fun kfun cps env)
- (define (subst var)
- (match (intmap-ref env var (lambda (_) #f))
- (#f var)
- ((var . label) var)))
-
- (define (rename-exp label cps names vars k src exp)
- (intmap-replace!
- cps label
- (build-cont
- ($kargs names vars
- ($continue k src
- ,(rewrite-exp exp
- ((or ($ $const) ($ $prim)) ,exp)
- (($ $call proc args)
- ,(let ((args (map subst args)))
- (rewrite-exp (intmap-ref env proc (lambda (_) #f))
- (#f ($call proc ,args))
- ((closure . label) ($callk label closure ,args)))))
- (($ $primcall name args)
- ($primcall name ,(map subst args)))
- (($ $branch k ($ $values (arg)))
- ($branch k ($values ((subst arg)))))
- (($ $branch k ($ $primcall name args))
- ($branch k ($primcall name ,(map subst args))))
- (($ $values args)
- ($values ,(map subst args)))
- (($ $prompt escape? tag handler)
- ($prompt escape? (subst tag) handler))))))))
-
- (define (visit-exp label cps names vars k src exp)
- (define (compute-env label bound self rec-bound rec-labels env)
- (define (add-bound-var bound label env)
- (intmap-add env bound (cons self label) (lambda (old new) new)))
- (if (intmap-ref shared label (lambda (_) #f))
- ;; Within a function with a shared closure, rewrite
- ;; references to bound vars to use the "self" var.
- (fold add-bound-var env rec-bound rec-labels)
- ;; Otherwise be sure to use "self" references in any
- ;; closure.
- (add-bound-var bound label env)))
- (match exp
- (($ $fun label)
- (rewrite-fun label cps env))
- (($ $rec names vars (($ $fun labels) ...))
- (fold (lambda (label var cps)
- (match (intmap-ref cps label)
- (($ $kfun src meta self)
- (rewrite-fun label cps
- (compute-env label var self vars labels
- env)))))
- cps labels vars))
- (_ (rename-exp label cps names vars k src exp))))
-
- (define (rewrite-cont label cps)
- (match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-exp label cps names vars k src exp))
- (_ cps)))
-
- (intset-fold rewrite-cont (intmap-ref functions kfun) cps))
-
- ;; Initial environment is bound-var -> (shared-var . label) map for
- ;; functions with shared closures.
- (let ((env (intmap-fold (lambda (label shared env)
- (intset-fold (lambda (bound env)
- (intmap-add env bound
- (cons shared label)))
- (intset-remove
- (intmap-ref label->bound label)
- (match (intmap-ref cps label)
- (($ $kfun src meta self) self)))
- env))
- shared
- empty-intmap)))
- (persistent-intmap (rewrite-fun kfun cps env))))
-
-(define (compute-free-vars conts kfun shared)
- "Compute a FUN-LABEL->FREE-VAR... map describing all free variable
-references."
- (define (add-def var defs) (intset-add! defs var))
- (define (add-defs vars defs)
- (match vars
- (() defs)
- ((var . vars) (add-defs vars (add-def var defs)))))
- (define (add-use var uses)
- (intset-add! uses var))
- (define (add-uses vars uses)
- (match vars
- (() uses)
- ((var . vars) (add-uses vars (add-use var uses)))))
- (define (visit-nested-funs body)
- (intset-fold
- (lambda (label out)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue _ _
- ($ $fun kfun)))
- (intmap-union out (visit-fun kfun)))
- (($ $kargs _ _ ($ $continue _ _
- ($ $rec _ _ (($ $fun labels) ...))))
- (let* ((out (fold (lambda (kfun out)
- (intmap-union out (visit-fun kfun)))
- out labels))
- (free (fold (lambda (kfun free)
- (intset-union free (intmap-ref out kfun)))
- empty-intset labels)))
- (fold (lambda (kfun out)
- ;; For functions that share a closure, the free
- ;; variables for one will be the union of the free
- ;; variables for all.
- (if (intmap-ref shared kfun (lambda (_) #f))
- (intmap-replace out kfun free)
- out))
- out
- labels)))
- (_ out)))
- body
- empty-intmap))
- (define (visit-fun kfun)
- (let* ((body (compute-function-body conts kfun))
- (free (visit-nested-funs body)))
- (call-with-values
- (lambda ()
- (intset-fold
- (lambda (label defs uses)
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (values
- (add-defs vars defs)
- (match exp
- ((or ($ $const) ($ $prim)) uses)
- (($ $fun kfun)
- (intset-union (persistent-intset uses)
- (intmap-ref free kfun)))
- (($ $rec names vars (($ $fun kfun) ...))
- (fold (lambda (kfun uses)
- (intset-union (persistent-intset uses)
- (intmap-ref free kfun)))
- uses kfun))
- (($ $values args)
- (add-uses args uses))
- (($ $call proc args)
- (add-use proc (add-uses args uses)))
- (($ $callk label proc args)
- (add-use proc (add-uses args uses)))
- (($ $branch kt ($ $values (arg)))
- (add-use arg uses))
- (($ $branch kt ($ $primcall name args))
- (add-uses args uses))
- (($ $primcall name args)
- (add-uses args uses))
- (($ $prompt escape? tag handler)
- (add-use tag uses)))))
- (($ $kfun src meta self)
- (values (add-def self defs) uses))
- (_ (values defs uses))))
- body empty-intset empty-intset))
- (lambda (defs uses)
- (intmap-add free kfun (intset-subtract
- (persistent-intset uses)
- (persistent-intset defs)))))))
- (visit-fun kfun))
-
-(define (eliminate-closure? label free-vars)
- (eq? (intmap-ref free-vars label) empty-intset))
-
-(define (closure-label label shared bound->label)
- (cond
- ((intmap-ref shared label (lambda (_) #f))
- => (lambda (closure)
- (intmap-ref bound->label closure)))
- (else label)))
-
-(define (closure-alias label well-known free-vars)
- (and (intset-ref well-known label)
- (trivial-intset (intmap-ref free-vars label))))
-
-(define (prune-free-vars free-vars bound->label well-known shared)
- "Given the label->bound-var map @var{free-vars}, remove free variables
-that are known functions with zero free variables, and replace
-references to well-known functions with one free variable with that free
-variable, until we reach a fixed point on the free-vars map."
- (define (prune-free in-label free free-vars)
- (intset-fold (lambda (var free)
- (match (intmap-ref bound->label var (lambda (_) #f))
- (#f free)
- (label
- (cond
- ((eliminate-closure? label free-vars)
- (intset-remove free var))
- ((closure-alias (closure-label label shared
bound->label)
- well-known free-vars)
- => (lambda (alias)
- ;; If VAR is free in LABEL, then ALIAS must
- ;; also be free because its definition must
- ;; precede VAR's definition.
- (intset-add (intset-remove free var) alias)))
- (else free)))))
- free free))
- (fixpoint (lambda (free-vars)
- (intmap-fold (lambda (label free free-vars)
- (intmap-replace free-vars label
- (prune-free label free
free-vars)))
- free-vars
- free-vars))
- free-vars))
-
-(define (intset-find set i)
- (let lp ((idx 0) (start #f))
- (let ((start (intset-next set start)))
- (cond
- ((not start) (error "not found" set i))
- ((= start i) idx)
- (else (lp (1+ idx) (1+ start)))))))
-
-(define (intset-count set)
- (intset-fold (lambda (_ count) (1+ count)) set 0))
-
-(define (convert-one cps label body free-vars bound->label well-known shared)
- (define (well-known? label)
- (intset-ref well-known label))
-
- (let* ((free (intmap-ref free-vars label))
- (nfree (intset-count free))
- (self-known? (well-known? (closure-label label shared bound->label)))
- (self (match (intmap-ref cps label) (($ $kfun _ _ self) self))))
- (define (convert-arg cps var k)
- "Convert one possibly free variable reference to a bound reference.
-
-If @var{var} is free, it is replaced by a closure reference via a
address@hidden primcall, and @var{k} is called with the new var.
-Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
- ;; We know that var is not the name of a well-known function.
- (cond
- ((and=> (intmap-ref bound->label var (lambda (_) #f))
- (lambda (kfun)
- (and (eq? empty-intset (intmap-ref free-vars kfun))
- kfun)))
- ;; A not-well-known function with zero free vars. Copy as a
- ;; constant, relying on the linker to reify just one copy.
- => (lambda (kfun)
- (with-cps cps
- (letv var*)
- (let$ body (k var*))
- (letk k* ($kargs (#f) (var*) ,body))
- (build-term ($continue k* #f ($closure kfun 0))))))
- ((intset-ref free var)
- (match (vector self-known? nfree)
- (#(#t 1)
- ;; A reference to the one free var of a well-known function.
- (with-cps cps
- ($ (k self))))
- (#(#t 2)
- ;; A reference to one of the two free vars in a well-known
- ;; function.
- (let ((op (if (= var (intset-next free)) 'car 'cdr)))
- (with-cps cps
- (letv var*)
- (let$ body (k var*))
- (letk k* ($kargs (#f) (var*) ,body))
- (build-term ($continue k* #f ($primcall op (self)))))))
- (_
- (let* ((idx (intset-find free var))
- (op (cond
- ((not self-known?) 'free-ref)
- ((<= idx #xff) 'vector-ref/immediate)
- (else 'vector-ref))))
- (with-cps cps
- (letv var*)
- (let$ body (k var*))
- (letk k* ($kargs (#f) (var*) ,body))
- ($ (with-cps-constants ((idx idx))
- (build-term
- ($continue k* #f ($primcall op (self idx)))))))))))
- (else
- (with-cps cps
- ($ (k var))))))
-
- (define (convert-args cps vars k)
- "Convert a number of possibly free references to bound references.
address@hidden is called with the bound references, and should return the
-term."
- (match vars
- (()
- (with-cps cps
- ($ (k '()))))
- ((var . vars)
- (convert-arg cps var
- (lambda (cps var)
- (convert-args cps vars
- (lambda (cps vars)
- (with-cps cps
- ($ (k (cons var vars)))))))))))
-
- (define (allocate-closure cps k src label known? nfree)
- "Allocate a new closure, and pass it to $var{k}."
- (match (vector known? nfree)
- (#(#f nfree)
- ;; The call sites cannot be enumerated; allocate a closure.
- (with-cps cps
- (build-term ($continue k src ($closure label nfree)))))
- (#(#t 2)
- ;; Well-known closure with two free variables; the closure is a
- ;; pair.
- (with-cps cps
- ($ (with-cps-constants ((false #f))
- (build-term
- ($continue k src ($primcall 'cons (false false))))))))
- ;; Well-known callee with more than two free variables; the closure
- ;; is a vector.
- (#(#t nfree)
- (unless (> nfree 2)
- (error "unexpected well-known nullary, unary, or binary closure"))
- (let ((op (if (<= nfree #xff) 'make-vector/immediate 'make-vector)))
- (with-cps cps
- ($ (with-cps-constants ((nfree nfree)
- (false #f))
- (build-term
- ($continue k src ($primcall op (nfree false)))))))))))
-
- (define (init-closure cps k src var known? free)
- "Initialize the free variables @var{closure-free} in a closure
-bound to @var{var}, and continue to @var{k}."
- (match (vector known? (intset-count free))
- ;; Well-known callee with zero or one free variables; no
- ;; initialization necessary.
- (#(#t (or 0 1))
- (with-cps cps
- (build-term ($continue k src ($values ())))))
- ;; Well-known callee with two free variables; do a set-car! and
- ;; set-cdr!.
- (#(#t 2)
- (let* ((free0 (intset-next free))
- (free1 (intset-next free (1+ free0))))
- (convert-arg cps free0
- (lambda (cps v0)
- (with-cps cps
- (let$ body
- (convert-arg free1
- (lambda (cps v1)
- (with-cps cps
- (build-term
- ($continue k src
- ($primcall 'set-cdr! (var v1))))))))
- (letk kcdr ($kargs () () ,body))
- (build-term
- ($continue kcdr src ($primcall 'set-car! (var v0)))))))))
- ;; Otherwise residualize a sequence of vector-set! or free-set!,
- ;; depending on whether the callee is well-known or not.
- (_
- (let lp ((cps cps) (prev #f) (idx 0))
- (match (intset-next free prev)
- (#f (with-cps cps
- (build-term ($continue k src ($values ())))))
- (v (with-cps cps
- (let$ body (lp (1+ v) (1+ idx)))
- (letk k ($kargs () () ,body))
- ($ (convert-arg v
- (lambda (cps v)
- (with-cps cps
- ($ (with-cps-constants ((idx idx))
- (let ((op (cond
- ((not known?) 'free-set!)
- ((<= idx #xff)
'vector-set!/immediate)
- (else 'vector-set!))))
- (build-term
- ($continue k src
- ($primcall op (var idx
v))))))))))))))))))
-
- (define (make-single-closure cps k src kfun)
- (let ((free (intmap-ref free-vars kfun)))
- (match (vector (well-known? kfun) (intset-count free))
- (#(#f 0)
- (with-cps cps
- (build-term ($continue k src ($closure kfun 0)))))
- (#(#t 0)
- (with-cps cps
- (build-term ($continue k src ($const #f)))))
- (#(#t 1)
- ;; A well-known closure of one free variable is replaced
- ;; at each use with the free variable itself, so we don't
- ;; need a binding at all; and yet, the continuation
- ;; expects one value, so give it something. DCE should
- ;; clean up later.
- (with-cps cps
- (build-term ($continue k src ($const #f)))))
- (#(well-known? nfree)
- ;; A bit of a mess, but beta conversion should remove the
- ;; final $values if possible.
- (with-cps cps
- (letv closure)
- (letk k* ($kargs () () ($continue k src ($values (closure)))))
- (let$ init (init-closure k* src closure well-known? free))
- (letk knew ($kargs (#f) (closure) ,init))
- ($ (allocate-closure knew src kfun well-known? nfree)))))))
-
- ;; The callee is known, but not necessarily well-known.
- (define (convert-known-proc-call cps k src label closure args)
- (define (have-closure cps closure)
- (convert-args cps args
- (lambda (cps args)
- (with-cps cps
- (build-term
- ($continue k src ($callk label closure args)))))))
- (cond
- ((eq? (intmap-ref free-vars label) empty-intset)
- ;; Known call, no free variables; no closure needed.
- ;; Pass #f as closure argument.
- (with-cps cps
- ($ (with-cps-constants ((false #f))
- ($ (have-closure false))))))
- ((and (well-known? (closure-label label shared bound->label))
- (trivial-intset (intmap-ref free-vars label)))
- ;; Well-known closures with one free variable are
- ;; replaced at their use sites by uses of the one free
- ;; variable.
- => (lambda (var)
- (convert-arg cps var have-closure)))
- (else
- ;; Otherwise just load the proc.
- (convert-arg cps closure have-closure))))
-
- (define (visit-term cps term)
- (match term
- (($ $continue k src (or ($ $const) ($ $prim)))
- (with-cps cps
- term))
-
- (($ $continue k src ($ $fun kfun))
- (with-cps cps
- ($ (make-single-closure k src kfun))))
-
- ;; Remove letrec.
- (($ $continue k src ($ $rec names vars (($ $fun kfuns) ...)))
- (match (vector names vars kfuns)
- (#(() () ())
- ;; Trivial empty case.
- (with-cps cps
- (build-term ($continue k src ($values ())))))
- (#((name) (var) (kfun))
- ;; Trivial single case. We have already proven that K has
- ;; only LABEL as its predecessor, so we have been able
- ;; already to rewrite free references to the bound name with
- ;; the self name.
- (with-cps cps
- ($ (make-single-closure k src kfun))))
- (#(_ _ (kfun0 . _))
- ;; A non-trivial strongly-connected component. Does it have
- ;; a shared closure?
- (match (intmap-ref shared kfun0 (lambda (_) #f))
- (#f
- ;; Nope. Allocate closures for each function.
- (let lp ((cps (match (intmap-ref cps k)
- ;; Steal declarations from the continuation.
- (($ $kargs names vals body)
- (intmap-replace cps k
- (build-cont
- ($kargs () () ,body))))))
- (in (map vector names vars kfuns))
- (init (lambda (cps)
- (with-cps cps
- (build-term
- ($continue k src ($values ())))))))
- (match in
- (() (init cps))
- ((#(name var kfun) . in)
- (let* ((known? (well-known? kfun))
- (free (intmap-ref free-vars kfun))
- (nfree (intset-count free)))
- (define (next-init cps)
- (with-cps cps
- (let$ body (init))
- (letk k ($kargs () () ,body))
- ($ (init-closure k src var known? free))))
- (with-cps cps
- (let$ body (lp in next-init))
- (letk k ($kargs (name) (var) ,body))
- ($ (allocate-closure k src kfun known? nfree))))))))
- (shared
- ;; If shared is in the bound->var map, that means one of
- ;; the functions is not well-known. Otherwise use kfun0
- ;; as the function label, but just so make-single-closure
- ;; can find the free vars, not for embedding in the
- ;; closure.
- (let* ((kfun (intmap-ref bound->label shared (lambda (_)
kfun0)))
- (cps (match (intmap-ref cps k)
- ;; Make continuation declare only the shared
- ;; closure.
- (($ $kargs names vals body)
- (intmap-replace cps k
- (build-cont
- ($kargs (#f) (shared)
,body)))))))
- (with-cps cps
- ($ (make-single-closure k src kfun)))))))))
-
- (($ $continue k src ($ $call proc args))
- (match (intmap-ref bound->label proc (lambda (_) #f))
- (#f
- (convert-arg cps proc
- (lambda (cps proc)
- (convert-args cps args
- (lambda (cps args)
- (with-cps cps
- (build-term
- ($continue k src ($call proc args)))))))))
- (label
- (convert-known-proc-call cps k src label proc args))))
-
- (($ $continue k src ($ $callk label proc args))
- (convert-known-proc-call cps k src label proc args))
-
- (($ $continue k src ($ $primcall name args))
- (convert-args cps args
- (lambda (cps args)
- (with-cps cps
- (build-term
- ($continue k src ($primcall name args)))))))
-
- (($ $continue k src ($ $branch kt ($ $primcall name args)))
- (convert-args cps args
- (lambda (cps args)
- (with-cps cps
- (build-term
- ($continue k src
- ($branch kt ($primcall name args))))))))
-
- (($ $continue k src ($ $branch kt ($ $values (arg))))
- (convert-arg cps arg
- (lambda (cps arg)
- (with-cps cps
- (build-term
- ($continue k src
- ($branch kt ($values (arg)))))))))
-
- (($ $continue k src ($ $values args))
- (convert-args cps args
- (lambda (cps args)
- (with-cps cps
- (build-term
- ($continue k src ($values args)))))))
-
- (($ $continue k src ($ $prompt escape? tag handler))
- (convert-arg cps tag
- (lambda (cps tag)
- (with-cps cps
- (build-term
- ($continue k src
- ($prompt escape? tag handler)))))))))
-
- (intset-fold (lambda (label cps)
- (match (intmap-ref cps label (lambda (_) #f))
- (($ $kargs names vars term)
- (with-cps cps
- (let$ term (visit-term term))
- (setk label ($kargs names vars ,term))))
- (_ cps)))
- body
- cps)))
-
-(define (convert-closures cps)
- "Convert free reference in @var{cps} to primcalls to @code{free-ref},
-and allocate and initialize flat closures."
- (let* ((kfun 0) ;; Ass-u-me.
- ;; label -> body-label...
- (functions (compute-function-bodies cps kfun))
- (cps (filter-reachable cps functions))
- ;; label -> bound-var...
- (label->bound (compute-function-names cps functions))
- ;; bound-var -> label
- (bound->label (invert-partition label->bound))
- ;; label...
- (well-known (compute-well-known-functions cps bound->label))
- ;; label -> closure-var
- (shared (compute-shared-closures cps well-known))
- (cps (rewrite-shared-closure-calls cps functions label->bound shared
- kfun))
- ;; label -> free-var...
- (free-vars (compute-free-vars cps kfun shared))
- (free-vars (prune-free-vars free-vars bound->label well-known
shared)))
- (let ((free-in-program (intmap-ref free-vars kfun)))
- (unless (eq? empty-intset free-in-program)
- (error "Expected no free vars in program" free-in-program)))
- (with-fresh-name-state cps
- (persistent-intmap
- (intmap-fold
- (lambda (label body cps)
- (convert-one cps label body free-vars bound->label well-known
shared))
- functions
- cps)))))
-
-;;; Local Variables:
-;;; eval: (put 'convert-arg 'scheme-indent-function 2)
-;;; eval: (put 'convert-args 'scheme-indent-function 2)
-;;; End:
diff --git a/module/language/cps2/compile-bytecode.scm
b/module/language/cps2/compile-bytecode.scm
deleted file mode 100644
index a39c9f2..0000000
--- a/module/language/cps2/compile-bytecode.scm
+++ /dev/null
@@ -1,433 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Compiling CPS to bytecode. The result is in the bytecode language,
-;;; which happens to be an ELF image as a bytecode.
-;;;
-;;; Code:
-
-(define-module (language cps2 compile-bytecode)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (language cps2)
- #:use-module (language cps primitives)
- #:use-module (language cps2 slot-allocation)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 closure-conversion)
- #:use-module (language cps2 optimize)
- #:use-module (language cps2 reify-primitives)
- #:use-module (language cps2 renumber)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:use-module (system vm assembler)
- #:export (compile-bytecode))
-
-(define (kw-arg-ref args kw default)
- (match (memq kw args)
- ((_ val . _) val)
- (_ default)))
-
-(define (intmap-for-each f map)
- (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
-
-(define (intmap-select map set)
- (persistent-intmap
- (intset-fold
- (lambda (k out)
- (intmap-add! out k (intmap-ref map k)))
- set
- empty-intmap)))
-
-(define (compile-function cps asm)
- (let ((allocation (allocate-slots cps))
- (frame-size #f))
- (define (maybe-slot sym)
- (lookup-maybe-slot sym allocation))
-
- (define (slot sym)
- (lookup-slot sym allocation))
-
- (define (constant sym)
- (lookup-constant-value sym allocation))
-
- (define (maybe-mov dst src)
- (unless (= dst src)
- (emit-mov asm dst src)))
-
- (define (compile-tail label exp)
- ;; There are only three kinds of expressions in tail position:
- ;; tail calls, multiple-value returns, and single-value returns.
- (match exp
- (($ $call proc args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (emit-tail-call asm (1+ (length args))))
- (($ $callk k proc args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (emit-tail-call-label asm (1+ (length args)) k))
- (($ $values ())
- (emit-reset-frame asm 1)
- (emit-return-values asm))
- (($ $values (arg))
- (if (maybe-slot arg)
- (emit-return asm (slot arg))
- (begin
- (emit-load-constant asm 1 (constant arg))
- (emit-return asm 1))))
- (($ $values args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (emit-reset-frame asm (1+ (length args)))
- (emit-return-values asm))
- (($ $primcall 'return (arg))
- (emit-return asm (slot arg)))))
-
- (define (compile-value label exp dst)
- (match exp
- (($ $values (arg))
- (maybe-mov dst (slot arg)))
- (($ $const exp)
- (emit-load-constant asm dst exp))
- (($ $closure k 0)
- (emit-load-static-procedure asm dst k))
- (($ $closure k nfree)
- (emit-make-closure asm dst k nfree))
- (($ $primcall 'current-module)
- (emit-current-module asm dst))
- (($ $primcall 'cached-toplevel-box (scope name bound?))
- (emit-cached-toplevel-box asm dst (constant scope) (constant name)
- (constant bound?)))
- (($ $primcall 'cached-module-box (mod name public? bound?))
- (emit-cached-module-box asm dst (constant mod) (constant name)
- (constant public?) (constant bound?)))
- (($ $primcall 'resolve (name bound?))
- (emit-resolve asm dst (constant bound?) (slot name)))
- (($ $primcall 'free-ref (closure idx))
- (emit-free-ref asm dst (slot closure) (constant idx)))
- (($ $primcall 'vector-ref (vector index))
- (emit-vector-ref asm dst (slot vector) (slot index)))
- (($ $primcall 'make-vector (length init))
- (emit-make-vector asm dst (slot length) (slot init)))
- (($ $primcall 'make-vector/immediate (length init))
- (emit-make-vector/immediate asm dst (constant length) (slot init)))
- (($ $primcall 'vector-ref/immediate (vector index))
- (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
- (($ $primcall 'allocate-struct (vtable nfields))
- (emit-allocate-struct asm dst (slot vtable) (slot nfields)))
- (($ $primcall 'allocate-struct/immediate (vtable nfields))
- (emit-allocate-struct/immediate asm dst (slot vtable) (constant
nfields)))
- (($ $primcall 'struct-ref (struct n))
- (emit-struct-ref asm dst (slot struct) (slot n)))
- (($ $primcall 'struct-ref/immediate (struct n))
- (emit-struct-ref/immediate asm dst (slot struct) (constant n)))
- (($ $primcall 'builtin-ref (name))
- (emit-builtin-ref asm dst (constant name)))
- (($ $primcall 'bv-u8-ref (bv idx))
- (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s8-ref (bv idx))
- (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u16-ref (bv idx))
- (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s16-ref (bv idx))
- (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u32-ref (bv idx val))
- (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s32-ref (bv idx val))
- (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-u64-ref (bv idx val))
- (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-s64-ref (bv idx val))
- (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-f32-ref (bv idx val))
- (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
- (($ $primcall 'bv-f64-ref (bv idx val))
- (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
- (($ $primcall name args)
- ;; FIXME: Inline all the cases.
- (let ((inst (prim-instruction name)))
- (emit-text asm `((,inst ,dst ,@(map slot args))))))))
-
- (define (compile-effect label exp k)
- (match exp
- (($ $values ()) #f)
- (($ $prompt escape? tag handler)
- (match (intmap-ref cps handler)
- (($ $kreceive ($ $arity req () rest () #f) khandler-body)
- (let ((receive-args (gensym "handler"))
- (nreq (length req))
- (proc-slot (lookup-call-proc-slot label allocation)))
- (emit-prompt asm (slot tag) escape? proc-slot receive-args)
- (emit-br asm k)
- (emit-label asm receive-args)
- (unless (and rest (zero? nreq))
- (emit-receive-values asm proc-slot (->bool rest) nreq))
- (when (and rest
- (match (intmap-ref cps khandler-body)
- (($ $kargs names (_ ... rest))
- (maybe-slot rest))))
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves handler allocation))
- (emit-reset-frame asm frame-size)
- (emit-br asm khandler-body)))))
- (($ $primcall 'cache-current-module! (sym scope))
- (emit-cache-current-module! asm (slot sym) (constant scope)))
- (($ $primcall 'free-set! (closure idx value))
- (emit-free-set! asm (slot closure) (slot value) (constant idx)))
- (($ $primcall 'box-set! (box value))
- (emit-box-set! asm (slot box) (slot value)))
- (($ $primcall 'struct-set! (struct index value))
- (emit-struct-set! asm (slot struct) (slot index) (slot value)))
- (($ $primcall 'struct-set!/immediate (struct index value))
- (emit-struct-set!/immediate asm (slot struct) (constant index) (slot
value)))
- (($ $primcall 'vector-set! (vector index value))
- (emit-vector-set! asm (slot vector) (slot index) (slot value)))
- (($ $primcall 'vector-set!/immediate (vector index value))
- (emit-vector-set!/immediate asm (slot vector) (constant index)
- (slot value)))
- (($ $primcall 'set-car! (pair value))
- (emit-set-car! asm (slot pair) (slot value)))
- (($ $primcall 'set-cdr! (pair value))
- (emit-set-cdr! asm (slot pair) (slot value)))
- (($ $primcall 'define! (sym value))
- (emit-define! asm (slot sym) (slot value)))
- (($ $primcall 'push-fluid (fluid val))
- (emit-push-fluid asm (slot fluid) (slot val)))
- (($ $primcall 'pop-fluid ())
- (emit-pop-fluid asm))
- (($ $primcall 'wind (winder unwinder))
- (emit-wind asm (slot winder) (slot unwinder)))
- (($ $primcall 'bv-u8-set! (bv idx val))
- (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s8-set! (bv idx val))
- (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u16-set! (bv idx val))
- (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s16-set! (bv idx val))
- (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u32-set! (bv idx val))
- (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s32-set! (bv idx val))
- (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-u64-set! (bv idx val))
- (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-s64-set! (bv idx val))
- (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-f32-set! (bv idx val))
- (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'bv-f64-set! (bv idx val))
- (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
- (($ $primcall 'unwind ())
- (emit-unwind asm))))
-
- (define (compile-values label exp syms)
- (match exp
- (($ $values args)
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation)))))
-
- (define (compile-test label exp kt kf next-label)
- (define (unary op sym)
- (cond
- ((eq? kt next-label)
- (op asm (slot sym) #t kf))
- (else
- (op asm (slot sym) #f kt)
- (unless (eq? kf next-label)
- (emit-br asm kf)))))
- (define (binary op a b)
- (cond
- ((eq? kt next-label)
- (op asm (slot a) (slot b) #t kf))
- (else
- (op asm (slot a) (slot b) #f kt)
- (unless (eq? kf next-label)
- (emit-br asm kf)))))
- (match exp
- (($ $values (sym))
- (call-with-values (lambda ()
- (lookup-maybe-constant-value sym allocation))
- (lambda (has-const? val)
- (if has-const?
- (if val
- (unless (eq? kt next-label)
- (emit-br asm kt))
- (unless (eq? kf next-label)
- (emit-br asm kf)))
- (unary emit-br-if-true sym)))))
- (($ $primcall 'null? (a)) (unary emit-br-if-null a))
- (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
- (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
- (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
- (($ $primcall 'char? (a)) (unary emit-br-if-char a))
- (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
- (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
- (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
- (($ $primcall 'string? (a)) (unary emit-br-if-string a))
- (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
- (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a))
- (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a))
- ;; Add more TC7 tests here. Keep in sync with
- ;; *branching-primcall-arities* in (language cps primitives) and
- ;; the set of macro-instructions in assembly.scm.
- (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
- (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
- (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
- (($ $primcall '< (a b)) (binary emit-br-if-< a b))
- (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
- (($ $primcall '= (a b)) (binary emit-br-if-= a b))
- (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
- (($ $primcall '> (a b)) (binary emit-br-if-< b a))
- (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
-
- (define (compile-trunc label k exp nreq rest-var)
- (define (do-call proc args emit-call)
- (let* ((proc-slot (lookup-call-proc-slot label allocation))
- (nargs (1+ (length args)))
- (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (emit-call asm proc-slot nargs)
- (emit-dead-slot-map asm proc-slot
- (lookup-dead-slot-map label allocation))
- (cond
- ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
- (match (lookup-parallel-moves k allocation)
- ((((? (lambda (src) (= src (1+ proc-slot))) src)
- . dst)) dst)
- (_ #f)))
- ;; The usual case: one required live return value, ignoring
- ;; any additional values.
- => (lambda (dst)
- (emit-receive asm dst proc-slot frame-size)))
- (else
- (unless (and (zero? nreq) rest-var)
- (emit-receive-values asm proc-slot (->bool rest-var) nreq))
- (when (and rest-var (maybe-slot rest-var))
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves k allocation))
- (emit-reset-frame asm frame-size)))))
- (match exp
- (($ $call proc args)
- (do-call proc args
- (lambda (asm proc-slot nargs)
- (emit-call asm proc-slot nargs))))
- (($ $callk k proc args)
- (do-call proc args
- (lambda (asm proc-slot nargs)
- (emit-call-label asm proc-slot nargs k))))))
-
- (define (compile-expression label k exp)
- (let* ((fallthrough? (= k (1+ label))))
- (define (maybe-emit-jump)
- (unless fallthrough?
- (emit-br asm k)))
- (match (intmap-ref cps k)
- (($ $ktail)
- (compile-tail label exp))
- (($ $kargs (name) (sym))
- (let ((dst (maybe-slot sym)))
- (when dst
- (compile-value label exp dst)))
- (maybe-emit-jump))
- (($ $kargs () ())
- (match exp
- (($ $branch kt exp)
- (compile-test label exp kt k (1+ label)))
- (_
- (compile-effect label exp k)
- (maybe-emit-jump))))
- (($ $kargs names syms)
- (compile-values label exp syms)
- (maybe-emit-jump))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (compile-trunc label k exp (length req)
- (and rest
- (match (intmap-ref cps kargs)
- (($ $kargs names (_ ... rest)) rest))))
- (unless (and fallthrough? (= kargs (1+ k)))
- (emit-br asm kargs))))))
-
- (define (compile-cont label cont)
- (match cont
- (($ $kfun src meta self tail clause)
- (when src
- (emit-source asm src))
- (emit-begin-program asm label meta))
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt)
- (let ((first? (match (intmap-ref cps (1- label))
- (($ $kfun) #t)
- (_ #f)))
- (kw-indices (map (match-lambda
- ((key name sym)
- (cons key (lookup-slot sym allocation))))
- kw)))
- (unless first?
- (emit-end-arity asm))
- (emit-label asm label)
- (set! frame-size (lookup-nlocals label allocation))
- (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
- frame-size alt)))
- (($ $kargs names vars ($ $continue k src exp))
- (emit-label asm label)
- (for-each (lambda (name var)
- (let ((slot (maybe-slot var)))
- (when slot
- (emit-definition asm name slot))))
- names vars)
- (when src
- (emit-source asm src))
- (compile-expression label k exp))
- (($ $kreceive arity kargs)
- (emit-label asm label))
- (($ $ktail)
- (emit-end-arity asm)
- (emit-end-program asm))))
-
- (intmap-for-each compile-cont cps)))
-
-(define (emit-bytecode exp env opts)
- (let ((asm (make-assembler)))
- (intmap-for-each (lambda (kfun body)
- (compile-function (intmap-select exp body) asm))
- (compute-reachable-functions exp 0))
- (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
- env
- env)))
-
-(define (lower-cps exp opts)
- (set! exp (optimize-higher-order-cps exp opts))
- (set! exp (convert-closures exp))
- (set! exp (optimize-first-order-cps exp opts))
- (set! exp (reify-primitives exp))
- (renumber exp))
-
-(define (compile-bytecode exp env opts)
- (set! exp (lower-cps exp opts))
- (emit-bytecode exp env opts))
diff --git a/module/language/cps2/constructors.scm
b/module/language/cps2/constructors.scm
deleted file mode 100644
index e4973f2..0000000
--- a/module/language/cps2/constructors.scm
+++ /dev/null
@@ -1,98 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Constructor inlining turns "list" primcalls into a series of conses,
-;;; and does similar transformations for "vector".
-;;;
-;;; Code:
-
-(define-module (language cps2 constructors)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 with-cps)
- #:use-module (language cps intmap)
- #:export (inline-constructors))
-
-(define (inline-list out k src args)
- (define (build-list out args k)
- (match args
- (()
- (with-cps out
- (build-term ($continue k src ($const '())))))
- ((arg . args)
- (with-cps out
- (letv tail)
- (letk ktail ($kargs ('tail) (tail)
- ($continue k src
- ($primcall 'cons (arg tail)))))
- ($ (build-list args ktail))))))
- (with-cps out
- (letv val)
- (letk kvalues ($kargs ('val) (val)
- ($continue k src
- ($primcall 'values (val)))))
- ($ (build-list args kvalues))))
-
-(define (inline-vector out k src args)
- (define (initialize out vec args n)
- (match args
- (()
- (with-cps out
- (build-term ($continue k src ($primcall 'values (vec))))))
- ((arg . args)
- (with-cps out
- (let$ next (initialize vec args (1+ n)))
- (letk knext ($kargs () () ,next))
- ($ (with-cps-constants ((idx n))
- (build-term ($continue knext src
- ($primcall 'vector-set! (vec idx arg))))))))))
- (with-cps out
- (letv vec)
- (let$ body (initialize vec args 0))
- (letk kalloc ($kargs ('vec) (vec) ,body))
- ($ (with-cps-constants ((len (length args))
- (init #f))
- (build-term ($continue kalloc src
- ($primcall 'make-vector (len init))))))))
-
-(define (find-constructor-inliner name)
- (match name
- ('list inline-list)
- ('vector inline-vector)
- (_ #f)))
-
-(define (inline-constructors conts)
- (with-fresh-name-state conts
- (persistent-intmap
- (intmap-fold
- (lambda (label cont out)
- (match cont
- (($ $kargs names vars ($ $continue k src ($ $primcall name args)))
- (let ((inline (find-constructor-inliner name)))
- (if inline
- (call-with-values (lambda () (inline out k src args))
- (lambda (out term)
- (intmap-replace! out label
- (build-cont ($kargs names vars ,term)))))
- out)))
- (_ out)))
- conts
- conts))))
diff --git a/module/language/cps2/contification.scm
b/module/language/cps2/contification.scm
deleted file mode 100644
index e15544a..0000000
--- a/module/language/cps2/contification.scm
+++ /dev/null
@@ -1,475 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Contification is a pass that turns $fun instances into $cont
-;;; instances if all calls to the $fun return to the same continuation.
-;;; This is a more rigorous variant of our old "fixpoint labels
-;;; allocation" optimization.
-;;;
-;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
-;;; and Weeks's "Contification using Dominators".
-;;;
-;;; Code:
-
-(define-module (language cps2 contification)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-11)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:use-module (language cps2)
- #:use-module (language cps2 renumber)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (contify))
-
-(define (compute-singly-referenced-labels conts)
- "Compute the set of labels in CONTS that have exactly one
-predecessor."
- (define (add-ref label cont single multiple)
- (define (ref k single multiple)
- (if (intset-ref single k)
- (values single (intset-add! multiple k))
- (values (intset-add! single k) multiple)))
- (define (ref0) (values single multiple))
- (define (ref1 k) (ref k single multiple))
- (define (ref2 k k*)
- (if k*
- (let-values (((single multiple) (ref k single multiple)))
- (ref k* single multiple))
- (ref1 k)))
- (match cont
- (($ $kreceive arity k) (ref1 k))
- (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
- (($ $ktail) (ref0))
- (($ $kclause arity kbody kalt) (ref2 kbody kalt))
- (($ $kargs names syms ($ $continue k src exp))
- (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
- (let*-values (((single multiple) (values empty-intset empty-intset))
- ((single multiple) (intmap-fold add-ref conts single
multiple)))
- (intset-subtract (persistent-intset single)
- (persistent-intset multiple))))
-
-(define (compute-functions conts)
- "Compute a map from $kfun label to bound variable names for all
-functions in CONTS. Functions have two bound variable names: their self
-binding, and the name they are given in their continuation. If their
-continuation has more than one predecessor, then the bound variable name
-doesn't uniquely identify the function, so we exclude that function from
-the set."
- (define (function-self label)
- (match (intmap-ref conts label)
- (($ $kfun src meta self) self)))
- (let ((single (compute-singly-referenced-labels conts)))
- (intmap-fold (lambda (label cont functions)
- (match cont
- (($ $kargs _ _ ($ $continue k src ($ $fun kfun)))
- (if (intset-ref single k)
- (match (intmap-ref conts k)
- (($ $kargs (name) (var))
- (intmap-add functions kfun
- (intset var (function-self kfun)))))
- functions))
- (($ $kargs _ _ ($ $continue k src
- ($ $rec _ vars (($ $fun kfuns) ...))))
- (if (intset-ref single k)
- (fold (lambda (var kfun functions)
- (intmap-add functions kfun
- (intset var (function-self
kfun))))
- functions vars kfuns)
- functions))
- (_ functions)))
- conts
- empty-intmap)))
-
-(define (compute-multi-clause conts)
- "Compute an set containing all labels that are part of a multi-clause
-case-lambda. See the note in compute-contification-candidates."
- (define (multi-clause? clause)
- (and clause
- (match (intmap-ref conts clause)
- (($ $kclause arity body alt)
- alt))))
- (intmap-fold (lambda (label cont multi)
- (match cont
- (($ $kfun src meta self tail clause)
- (if (multi-clause? clause)
- (intset-union multi (compute-function-body conts
label))
- multi))
- (_ multi)))
- conts
- empty-intset))
-
-(define (compute-arities conts functions)
- "Given the map FUNCTIONS whose keys are $kfun labels, return a map
-from label to arities."
- (define (clause-arities clause)
- (if clause
- (match (intmap-ref conts clause)
- (($ $kclause arity body alt)
- (cons arity (clause-arities alt))))
- '()))
- (intmap-map (lambda (label vars)
- (match (intmap-ref conts label)
- (($ $kfun src meta self tail clause)
- (clause-arities clause))))
- functions))
-
-;; For now, we don't contify functions with optional, keyword, or rest
-;; arguments.
-(define (contifiable-arity? arity)
- (match arity
- (($ $arity req () #f () aok?)
- #t)
- (_
- #f)))
-
-(define (arity-matches? arity nargs)
- (match arity
- (($ $arity req () #f () aok?)
- (= nargs (length req)))
- (_
- #f)))
-
-(define (compute-contification-candidates conts)
- "Compute and return a label -> (variable ...) map describing all
-functions with known uses that are only ever used as the operator of a
-$call, and are always called with a compatible arity."
- (let* ((functions (compute-functions conts))
- (multi-clause (compute-multi-clause conts))
- (vars (intmap-fold (lambda (label vars out)
- (intset-fold (lambda (var out)
- (intmap-add out var label))
- vars out))
- functions
- empty-intmap))
- (arities (compute-arities conts functions)))
- (define (restrict-arity functions proc nargs)
- (match (intmap-ref vars proc (lambda (_) #f))
- (#f functions)
- (label
- (let lp ((arities (intmap-ref arities label)))
- (match arities
- (() (intmap-remove functions label))
- ((arity . arities)
- (cond
- ((not (contifiable-arity? arity)) (lp '()))
- ((arity-matches? arity nargs) functions)
- (else (lp arities)))))))))
- (define (visit-cont label cont functions)
- (define (exclude-var functions var)
- (match (intmap-ref vars var (lambda (_) #f))
- (#f functions)
- (label (intmap-remove functions label))))
- (define (exclude-vars functions vars)
- (match vars
- (() functions)
- ((var . vars)
- (exclude-vars (exclude-var functions var) vars))))
- (match cont
- (($ $kargs _ _ ($ $continue _ _ exp))
- (match exp
- ((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec))
- functions)
- (($ $values args)
- (exclude-vars functions args))
- (($ $call proc args)
- (let ((functions (exclude-vars functions args)))
- ;; This contification algorithm is happy to contify the
- ;; `lp' in this example into a shared tail between clauses:
- ;;
- ;; (letrec ((lp (lambda () (lp))))
- ;; (case-lambda
- ;; ((a) (lp))
- ;; ((a b) (lp))))
- ;;
- ;; However because the current compilation pipeline has to
- ;; re-nest continuations into old CPS, there would be no
- ;; scope in which the tail would be valid. So, until the
- ;; old compilation pipeline is completely replaced,
- ;; conservatively exclude contifiable fucntions called
- ;; from multi-clause procedures.
- (if (intset-ref multi-clause label)
- (exclude-var functions proc)
- (restrict-arity functions proc (length args)))))
- (($ $callk k proc args)
- (exclude-vars functions (cons proc args)))
- (($ $branch kt ($ $primcall name args))
- (exclude-vars functions args))
- (($ $branch kt ($ $values (arg)))
- (exclude-var functions arg))
- (($ $primcall name args)
- (exclude-vars functions args))
- (($ $prompt escape? tag handler)
- (exclude-var functions tag))))
- (_ functions)))
- (intmap-fold visit-cont conts functions)))
-
-(define (compute-call-graph conts labels vars)
- "Given the set of contifiable functions LABELS and associated bound
-variables VARS, compute and return two values: a map
-LABEL->LABEL... indicating the contifiable functions called by a
-function, and a map LABEL->LABEL... indicating the return continuations
-for a function. The first return value also has an entry
-0->LABEL... indicating all contifiable functions called by
-non-contifiable functions. We assume that 0 is not in the contifiable
-function set."
- (let ((bodies
- ;; label -> fun-label for all labels in bodies of contifiable
- ;; functions
- (intset-fold (lambda (fun-label bodies)
- (intset-fold (lambda (label bodies)
- (intmap-add bodies label fun-label))
- (compute-function-body conts fun-label)
- bodies))
- labels
- empty-intmap)))
- (when (intset-ref labels 0)
- (error "internal error: label 0 should not be contifiable"))
- (intmap-fold
- (lambda (label cont calls returns)
- (match cont
- (($ $kargs _ _ ($ $continue k src ($ $call proc)))
- (match (intmap-ref vars proc (lambda (_) #f))
- (#f (values calls returns))
- (callee
- (let ((caller (intmap-ref bodies label (lambda (_) 0))))
- (values (intmap-add calls caller callee intset-add)
- (intmap-add returns callee k intset-add))))))
- (_ (values calls returns))))
- conts
- (intset->intmap (lambda (label) empty-intset) (intset-add labels 0))
- (intset->intmap (lambda (label) empty-intset) labels))))
-
-(define (tail-label conts label)
- (match (intmap-ref conts label)
- (($ $kfun src meta self tail body)
- tail)))
-
-(define (compute-return-labels labels tails returns return-substs)
- (define (subst k)
- (match (intmap-ref return-substs k (lambda (_) #f))
- (#f k)
- (k (subst k))))
- ;; Compute all return labels, then subtract tail labels of the
- ;; functions in question.
- (intset-subtract
- ;; Return labels for all calls to these labels.
- (intset-fold (lambda (label out)
- (intset-fold (lambda (k out)
- (intset-add out (subst k)))
- (intmap-ref returns label)
- out))
- labels
- empty-intset)
- (intset-fold (lambda (label out)
- (intset-add out (intmap-ref tails label)))
- labels
- empty-intset)))
-
-(define (intmap->intset map)
- (define (add-key label cont labels)
- (intset-add labels label))
- (intmap-fold add-key map empty-intset))
-
-(define (filter-contifiable contified groups)
- (intmap-fold (lambda (id labels groups)
- (let ((labels (intset-subtract labels contified)))
- (if (eq? empty-intset labels)
- groups
- (intmap-add groups id labels))))
- groups
- empty-intmap))
-
-(define (trivial-set set)
- (let ((first (intset-next set)))
- (and first
- (not (intset-next set (1+ first)))
- first)))
-
-(define (compute-contification conts)
- (let*-values
- (;; label -> (var ...)
- ((candidates) (compute-contification-candidates conts))
- ((labels) (intmap->intset candidates))
- ;; var -> label
- ((vars) (intmap-fold (lambda (label vars out)
- (intset-fold (lambda (var out)
- (intmap-add out var label))
- vars out))
- candidates
- empty-intmap))
- ;; caller-label -> callee-label..., callee-label -> return-label...
- ((calls returns) (compute-call-graph conts labels vars))
- ;; callee-label -> tail-label
- ((tails) (intset-fold
- (lambda (label tails)
- (intmap-add tails label (tail-label conts label)))
- labels
- empty-intmap))
- ;; Strongly connected components, allowing us to contify mutually
- ;; tail-recursive functions. Since `compute-call-graph' added on
- ;; a synthetic 0->LABEL... entry for contifiable functions called
- ;; by non-contifiable functions, we need to remove that entry
- ;; from the partition. It will be in its own component, as it
- ;; has no predecessors.
- ;;
- ;; id -> label...
- ((groups) (intmap-remove
- (compute-strongly-connected-components calls 0)
- 0)))
- ;; todo: thread groups through contification
- (define (attempt-contification labels contified return-substs)
- (let ((returns (compute-return-labels labels tails returns
- return-substs)))
- (cond
- ((trivial-set returns)
- => (lambda (k)
- ;; Success!
- (values (intset-union contified labels)
- (intset-fold (lambda (label return-substs)
- (let ((tail (intmap-ref tails label)))
- (intmap-add return-substs tail k)))
- labels return-substs))))
- ((trivial-set labels)
- ;; Single-label SCC failed to contify.
- (values contified return-substs))
- (else
- ;; Multi-label SCC failed to contify. Try instead to contify
- ;; each one.
- (intset-fold
- (lambda (label contified return-substs)
- (let ((labels (intset-add empty-intset label)))
- (attempt-contification labels contified return-substs)))
- labels contified return-substs)))))
- (call-with-values
- (lambda ()
- (fixpoint
- (lambda (contified return-substs)
- (intmap-fold
- (lambda (id group contified return-substs)
- (attempt-contification group contified return-substs))
- (filter-contifiable contified groups)
- contified
- return-substs))
- empty-intset
- empty-intmap))
- (lambda (contified return-substs)
- (values (intset-fold (lambda (label call-substs)
- (intset-fold
- (lambda (var call-substs)
- (intmap-add call-substs var label))
- (intmap-ref candidates label)
- call-substs))
- contified
- empty-intmap)
- return-substs)))))
-
-(define (apply-contification conts call-substs return-substs)
- (define (call-subst proc)
- (intmap-ref call-substs proc (lambda (_) #f)))
- (define (return-subst k)
- (intmap-ref return-substs k (lambda (_) #f)))
- (define (find-body kfun nargs)
- (match (intmap-ref conts kfun)
- (($ $kfun src meta self tail clause)
- (let lp ((clause clause))
- (match (intmap-ref conts clause)
- (($ $kclause arity body alt)
- (if (arity-matches? arity nargs)
- body
- (lp alt))))))))
- (define (continue k src exp)
- (define (lookup-return-cont k)
- (match (return-subst k)
- (#f k)
- (k (lookup-return-cont k))))
- (let ((k* (lookup-return-cont k)))
- (if (eq? k k*)
- (build-term ($continue k src ,exp))
- ;; We are contifying this return. It must be a call, a
- ;; $values expression, or a return primcall. k* will be
- ;; either a $ktail or a $kreceive continuation. CPS2 has this
- ;; thing though where $kreceive can't be the target of a
- ;; $values expression, and "return" can only continue to a
- ;; tail continuation, so we might have to rewrite to a
- ;; "values" primcall.
- (build-term
- ($continue k* src
- ,(match (intmap-ref conts k*)
- (($ $kreceive)
- (match exp
- (($ $primcall 'return (val))
- (build-exp ($primcall 'values (val))))
- (($ $call) exp)
- ;; Except for 'return, a primcall that can continue
- ;; to $ktail can also continue to $kreceive. TODO:
- ;; replace 'return with 'values, for consistency.
- (($ $primcall) exp)
- (($ $values vals)
- (build-exp ($primcall 'values vals)))))
- (($ $ktail) exp)))))))
- (define (visit-exp k src exp)
- (match exp
- (($ $call proc args)
- ;; If proc is contifiable, replace call with jump.
- (match (call-subst proc)
- (#f (continue k src exp))
- (kfun
- (let ((body (find-body kfun (length args))))
- (build-term ($continue body src ($values args)))))))
- (($ $fun kfun)
- ;; If the function's tail continuation has been
- ;; substituted, that means it has been contified.
- (if (return-subst (tail-label conts kfun))
- (continue k src (build-exp ($values ())))
- (continue k src exp)))
- (($ $rec names vars funs)
- (match (filter (match-lambda ((n v f) (not (call-subst v))))
- (map list names vars funs))
- (() (continue k src (build-exp ($values ()))))
- (((names vars funs) ...)
- (continue k src (build-exp ($rec names vars funs))))))
- (_ (continue k src exp))))
-
- ;; Renumbering is not strictly necessary but some passes may not be
- ;; equipped to deal with stale $kfun nodes whose bodies have been
- ;; wired into other functions.
- (renumber
- (intmap-map
- (lambda (label cont)
- (match cont
- (($ $kargs names vars ($ $continue k src exp))
- ;; Remove bindings for functions that have been contified.
- (match (filter (match-lambda ((name var) (not (call-subst var))))
- (map list names vars))
- (((names vars) ...)
- (build-cont
- ($kargs names vars ,(visit-exp k src exp))))))
- (_ cont)))
- conts)))
-
-(define (contify conts)
- ;; FIXME: Renumbering isn't really needed but dead continuations may
- ;; cause compute-singly-referenced-labels to spuriously mark some
- ;; conts as irreducible. For now we punt and renumber so that there
- ;; are only live conts.
- (let ((conts (renumber conts)))
- (let-values (((call-substs return-substs) (compute-contification conts)))
- (apply-contification conts call-substs return-substs))))
diff --git a/module/language/cps2/cse.scm b/module/language/cps2/cse.scm
deleted file mode 100644
index b5ac14d..0000000
--- a/module/language/cps2/cse.scm
+++ /dev/null
@@ -1,449 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Common subexpression elimination for CPS.
-;;;
-;;; Code:
-
-(define-module (language cps2 cse)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 effects-analysis)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (eliminate-common-subexpressions))
-
-(define (intset-pop set)
- (match (intset-next set)
- (#f (values set #f))
- (i (values (intset-remove set i) i))))
-
-(define-syntax-rule (make-worklist-folder* seed ...)
- (lambda (f worklist seed ...)
- (let lp ((worklist worklist) (seed seed) ...)
- (call-with-values (lambda () (intset-pop worklist))
- (lambda (worklist i)
- (if i
- (call-with-values (lambda () (f i seed ...))
- (lambda (i* seed ...)
- (let add ((i* i*) (worklist worklist))
- (match i*
- (() (lp worklist seed ...))
- ((i . i*) (add i* (intset-add worklist i)))))))
- (values seed ...)))))))
-
-(define worklist-fold*
- (case-lambda
- ((f worklist seed)
- ((make-worklist-folder* seed) f worklist seed))))
-
-(define (compute-available-expressions conts kfun effects)
- "Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
-an intset containing ancestor labels whose value is available at LABEL."
- (define (propagate avail succ out)
- (let* ((in (intmap-ref avail succ (lambda (_) #f)))
- (in* (if in (intset-intersect in out) out)))
- (if (eq? in in*)
- (values '() avail)
- (values (list succ)
- (intmap-add avail succ in* (lambda (old new) new))))))
-
- (define (clobber label in)
- (let ((fx (intmap-ref effects label)))
- (cond
- ((not (causes-effect? fx &write))
- ;; Fast-path if this expression clobbers nothing.
- in)
- (else
- ;; Kill clobbered expressions. FIXME: there is no need to check
- ;; on any label before than the last dominating label that
- ;; clobbered everything. Another way to speed things up would
- ;; be to compute a clobber set per-effect, which we could
- ;; subtract from "in".
- (let lp ((label 0) (in in))
- (cond
- ((intset-next in label)
- => (lambda (label)
- (if (effect-clobbers? fx (intmap-ref effects label))
- (lp (1+ label) (intset-remove in label))
- (lp (1+ label) in))))
- (else in)))))))
-
- (define (visit-cont label avail)
- (let* ((in (intmap-ref avail label))
- (out (intset-add (clobber label in) label)))
- (define (propagate0)
- (values '() avail))
- (define (propagate1 succ)
- (propagate avail succ out))
- (define (propagate2 succ0 succ1)
- (let*-values (((changed0 avail) (propagate avail succ0 out))
- ((changed1 avail) (propagate avail succ1 out)))
- (values (append changed0 changed1) avail)))
-
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (match exp
- (($ $branch kt) (propagate2 k kt))
- (($ $prompt escape? tag handler) (propagate2 k handler))
- (_ (propagate1 k))))
- (($ $kreceive arity k)
- (propagate1 k))
- (($ $kfun src meta self tail clause)
- (if clause
- (propagate1 clause)
- (propagate0)))
- (($ $kclause arity kbody kalt)
- (if kalt
- (propagate2 kbody kalt)
- (propagate1 kbody)))
- (($ $ktail) (propagate0)))))
-
- (worklist-fold* visit-cont
- (intset kfun)
- (intmap-add empty-intmap kfun empty-intset)))
-
-(define (compute-truthy-expressions conts kfun boolv)
- "Compute a \"truth map\", indicating which expressions can be shown to
-be true and/or false at each label in the function starting at KFUN..
-Returns an intmap of intsets. The even elements of the intset indicate
-labels that may be true, and the odd ones indicate those that may be
-false. It could be that both true and false proofs are available."
- (define (true-idx label) (ash label 1))
- (define (false-idx label) (1+ (ash label 1)))
-
- (define (propagate boolv succ out)
- (let* ((in (intmap-ref boolv succ (lambda (_) #f)))
- (in* (if in (intset-intersect in out) out)))
- (if (eq? in in*)
- (values '() boolv)
- (values (list succ)
- (intmap-add boolv succ in* (lambda (old new) new))))))
-
- (define (visit-cont label boolv)
- (let ((in (intmap-ref boolv label)))
- (define (propagate0)
- (values '() boolv))
- (define (propagate1 succ)
- (propagate boolv succ in))
- (define (propagate2 succ0 succ1)
- (let*-values (((changed0 boolv) (propagate boolv succ0 in))
- ((changed1 boolv) (propagate boolv succ1 in)))
- (values (append changed0 changed1) boolv)))
- (define (propagate-branch succ0 succ1)
- (let*-values (((changed0 boolv)
- (propagate boolv succ0
- (intset-add in (false-idx label))))
- ((changed1 boolv)
- (propagate boolv succ1
- (intset-add in (true-idx label)))))
- (values (append changed0 changed1) boolv)))
-
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (match exp
- (($ $branch kt) (propagate-branch k kt))
- (($ $prompt escape? tag handler) (propagate2 k handler))
- (_ (propagate1 k))))
- (($ $kreceive arity k)
- (propagate1 k))
- (($ $kfun src meta self tail clause)
- (if clause
- (propagate1 clause)
- (propagate0)))
- (($ $kclause arity kbody kalt)
- (if kalt
- (propagate2 kbody kalt)
- (propagate1 kbody)))
- (($ $ktail) (propagate0)))))
-
- (let ((boolv (worklist-fold* visit-cont
- (intset kfun)
- (intmap-add boolv kfun empty-intset))))
- ;; Now visit nested functions. We don't do this in the worklist
- ;; folder because that would be exponential.
- (define (recurse kfun boolv)
- (compute-truthy-expressions conts kfun boolv))
- (intset-fold
- (lambda (label boolv)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue _ _ exp))
- (match exp
- (($ $fun kfun) (recurse kfun boolv))
- (($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun))
- (_ boolv)))
- (_ boolv)))
- (compute-function-body conts kfun)
- boolv)))
-
-(define (intset-map f set)
- (persistent-intmap
- (intset-fold (lambda (i out) (intmap-add! out i (f i)))
- set
- empty-intmap)))
-
-;; Returns a map of label-idx -> (var-idx ...) indicating the variables
-;; defined by a given labelled expression.
-(define (compute-defs conts kfun)
- (intset-map (lambda (label)
- (match (intmap-ref conts label)
- (($ $kfun src meta self tail clause)
- (list self))
- (($ $kclause arity body alt)
- (match (intmap-ref conts body)
- (($ $kargs names vars) vars)))
- (($ $kreceive arity kargs)
- (match (intmap-ref conts kargs)
- (($ $kargs names vars) vars)))
- (($ $ktail)
- '())
- (($ $kargs names vars ($ $continue k))
- (match (intmap-ref conts k)
- (($ $kargs names vars) vars)
- (_ #f)))))
- (compute-function-body conts kfun)))
-
-(define (compute-singly-referenced succs)
- (define (visit label succs single multiple)
- (intset-fold (lambda (label single multiple)
- (if (intset-ref single label)
- (values single (intset-add! multiple label))
- (values (intset-add! single label) multiple)))
- succs single multiple))
- (call-with-values (lambda ()
- (intmap-fold visit succs empty-intset empty-intset))
- (lambda (single multiple)
- (intset-subtract (persistent-intset single)
- (persistent-intset multiple)))))
-
-(define (compute-equivalent-subexpressions conts kfun effects
- equiv-labels var-substs)
- (let* ((succs (compute-successors conts kfun))
- (singly-referenced (compute-singly-referenced succs))
- (avail (compute-available-expressions conts kfun effects))
- (defs (compute-defs conts kfun))
- (equiv-set (make-hash-table)))
- (define (subst-var var-substs var)
- (intmap-ref var-substs var (lambda (var) var)))
- (define (subst-vars var-substs vars)
- (let lp ((vars vars))
- (match vars
- (() '())
- ((var . vars) (cons (subst-var var-substs var) (lp vars))))))
-
- (define (compute-exp-key var-substs exp)
- (match exp
- (($ $const val) (cons 'const val))
- (($ $prim name) (cons 'prim name))
- (($ $fun body) #f)
- (($ $rec names syms funs) #f)
- (($ $call proc args) #f)
- (($ $callk k proc args) #f)
- (($ $primcall name args)
- (cons* 'primcall name (subst-vars var-substs args)))
- (($ $branch _ ($ $primcall name args))
- (cons* 'primcall name (subst-vars var-substs args)))
- (($ $branch) #f)
- (($ $values args) #f)
- (($ $prompt escape? tag handler) #f)))
-
- (define (add-auxiliary-definitions! label var-substs exp-key)
- (define (subst var)
- (subst-var var-substs var))
- (let ((defs (intmap-ref defs label)))
- (define (add-def! aux-key var)
- (let ((equiv (hash-ref equiv-set aux-key '())))
- (hash-set! equiv-set aux-key
- (acons label (list var) equiv))))
- (match exp-key
- (('primcall 'box val)
- (match defs
- ((box)
- (add-def! `(primcall box-ref ,(subst box)) val))))
- (('primcall 'box-set! box val)
- (add-def! `(primcall box-ref ,box) val))
- (('primcall 'cons car cdr)
- (match defs
- ((pair)
- (add-def! `(primcall car ,(subst pair)) car)
- (add-def! `(primcall cdr ,(subst pair)) cdr))))
- (('primcall 'set-car! pair car)
- (add-def! `(primcall car ,pair) car))
- (('primcall 'set-cdr! pair cdr)
- (add-def! `(primcall cdr ,pair) cdr))
- (('primcall (or 'make-vector 'make-vector/immediate) len fill)
- (match defs
- ((vec)
- (add-def! `(primcall vector-length ,(subst vec)) len))))
- (('primcall 'vector-set! vec idx val)
- (add-def! `(primcall vector-ref ,vec ,idx) val))
- (('primcall 'vector-set!/immediate vec idx val)
- (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
- (('primcall (or 'allocate-struct 'allocate-struct/immediate)
- vtable size)
- (match defs
- ((struct)
- (add-def! `(primcall struct-vtable ,(subst struct))
- vtable))))
- (('primcall 'struct-set! struct n val)
- (add-def! `(primcall struct-ref ,struct ,n) val))
- (('primcall 'struct-set!/immediate struct n val)
- (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
- (_ #t))))
-
- (define (visit-label label equiv-labels var-substs)
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (let* ((exp-key (compute-exp-key var-substs exp))
- (equiv (hash-ref equiv-set exp-key '()))
- (fx (intmap-ref effects label))
- (avail (intmap-ref avail label)))
- (define (finish equiv-labels var-substs)
- (define (recurse kfun equiv-labels var-substs)
- (compute-equivalent-subexpressions conts kfun effects
- equiv-labels var-substs))
- ;; If this expression defines auxiliary definitions,
- ;; as `cons' does for the results of `car' and `cdr',
- ;; define those. Do so after finding equivalent
- ;; expressions, so that we can take advantage of
- ;; subst'd output vars.
- (add-auxiliary-definitions! label var-substs exp-key)
- (match exp
- ;; If we see a $fun, recurse to add to the result.
- (($ $fun kfun)
- (recurse kfun equiv-labels var-substs))
- (($ $rec names vars (($ $fun kfun) ...))
- (fold2 recurse kfun equiv-labels var-substs))
- (_
- (values equiv-labels var-substs))))
- (let lp ((candidates equiv))
- (match candidates
- (()
- ;; No matching expressions. Add our expression
- ;; to the equivalence set, if appropriate. Note
- ;; that expressions that allocate a fresh object
- ;; or change the current fluid environment can't
- ;; be eliminated by CSE (though DCE might do it
- ;; if the value proves to be unused, in the
- ;; allocation case).
- (when (and exp-key
- (not (causes-effect? fx &allocation))
- (not (effect-clobbers? fx (&read-object &fluid))))
- (let ((defs (and (intset-ref singly-referenced k)
- (intmap-ref defs label))))
- (when defs
- (hash-set! equiv-set exp-key
- (acons label defs equiv)))))
- (finish equiv-labels var-substs))
- (((and head (candidate . vars)) . candidates)
- (cond
- ((not (intset-ref avail candidate))
- ;; This expression isn't available here; try
- ;; the next one.
- (lp candidates))
- (else
- ;; Yay, a match. Mark expression as equivalent. If
- ;; we provide the definitions for the successor, mark
- ;; the vars for substitution.
- (finish (intmap-add equiv-labels label head)
- (let ((defs (and (intset-ref singly-referenced k)
- (intmap-ref defs label))))
- (if defs
- (fold (lambda (def var var-substs)
- (intmap-add var-substs def var))
- var-substs defs vars)
- var-substs))))))))))
- (_ (values equiv-labels var-substs))))
-
- ;; Traverse the labels in fun in reverse post-order, which will
- ;; visit definitions before uses first.
- (fold2 visit-label
- (compute-reverse-post-order succs kfun)
- equiv-labels
- var-substs)))
-
-(define (apply-cse conts equiv-labels var-substs truthy-labels)
- (define (true-idx idx) (ash idx 1))
- (define (false-idx idx) (1+ (ash idx 1)))
-
- (define (subst-var var)
- (intmap-ref var-substs var (lambda (var) var)))
-
- (define (visit-exp exp)
- (rewrite-exp exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp)
- (($ $call proc args)
- ($call (subst-var proc) ,(map subst-var args)))
- (($ $callk k proc args)
- ($callk k (subst-var proc) ,(map subst-var args)))
- (($ $primcall name args)
- ($primcall name ,(map subst-var args)))
- (($ $branch k exp)
- ($branch k ,(visit-exp exp)))
- (($ $values args)
- ($values ,(map subst-var args)))
- (($ $prompt escape? tag handler)
- ($prompt escape? (subst-var tag) handler))))
-
- (intmap-map
- (lambda (label cont)
- (match cont
- (($ $kargs names vars ($ $continue k src exp))
- (build-cont
- ($kargs names vars
- ,(match (intmap-ref equiv-labels label (lambda (_) #f))
- ((equiv . vars)
- (match exp
- (($ $branch kt exp)
- (let* ((bool (intmap-ref truthy-labels label))
- (t (intset-ref bool (true-idx equiv)))
- (f (intset-ref bool (false-idx equiv))))
- (if (eqv? t f)
- (build-term
- ($continue k src
- ($branch kt ,(visit-exp exp))))
- (build-term
- ($continue (if t kt k) src ($values ()))))))
- (_
- ;; For better or for worse, we only replace primcalls
- ;; if they have an associated VM op, which allows
- ;; them to continue to $kargs and thus we know their
- ;; defs and can use a $values expression instead of a
- ;; values primcall.
- (build-term
- ($continue k src ($values vars))))))
- (#f
- (build-term
- ($continue k src ,(visit-exp exp))))))))
- (_ cont)))
- conts))
-
-(define (eliminate-common-subexpressions conts)
- (call-with-values
- (lambda ()
- (let ((effects (synthesize-definition-effects (compute-effects
conts))))
- (compute-equivalent-subexpressions conts 0 effects
- empty-intmap empty-intmap)))
- (lambda (equiv-labels var-substs)
- (let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap)))
- (apply-cse conts equiv-labels var-substs truthy-labels)))))
diff --git a/module/language/cps2/dce.scm b/module/language/cps2/dce.scm
deleted file mode 100644
index e743bc4..0000000
--- a/module/language/cps2/dce.scm
+++ /dev/null
@@ -1,399 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; This pass kills dead expressions: code that has no side effects, and
-;;; whose value is unused. It does so by marking all live values, and
-;;; then discarding other values as dead. This happens recursively
-;;; through procedures, so it should be possible to elide dead
-;;; procedures as well.
-;;;
-;;; Code:
-
-(define-module (language cps2 dce)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (language cps2)
- #:use-module (language cps2 effects-analysis)
- #:use-module (language cps2 renumber)
- #:use-module (language cps2 types)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (eliminate-dead-code))
-
-(define (elide-type-checks conts kfun effects)
- "Elide &type-check effects from EFFECTS for the function starting at
-KFUN where we can prove that no assertion will be raised at run-time."
- (let ((types (infer-types conts kfun)))
- (define (visit-primcall effects fx label name args)
- (if (primcall-types-check? types label name args)
- (intmap-replace! effects label (logand fx (lognot &type-check)))
- effects))
- (persistent-intmap
- (intmap-fold (lambda (label types effects)
- (let ((fx (intmap-ref effects label)))
- (cond
- ((causes-all-effects? fx) effects)
- ((causes-effect? fx &type-check)
- (match (intmap-ref conts label)
- (($ $kargs _ _ exp)
- (match exp
- (($ $continue k src ($ $primcall name args))
- (visit-primcall effects fx label name args))
- (($ $continue k src
- ($ $branch _ ($primcall name args)))
- (visit-primcall effects fx label name args))
- (_ effects)))
- (_ effects)))
- (else effects))))
- types
- effects))))
-
-(define (compute-effects/elide-type-checks conts)
- (intmap-fold (lambda (label cont effects)
- (match cont
- (($ $kfun) (elide-type-checks conts label effects))
- (_ effects)))
- conts
- (compute-effects conts)))
-
-(define (fold-local-conts proc conts label seed)
- (match (intmap-ref conts label)
- (($ $kfun src meta self tail clause)
- (let lp ((label label) (seed seed))
- (if (<= label tail)
- (lp (1+ label) (proc label (intmap-ref conts label) seed))
- seed)))))
-
-(define (postorder-fold-local-conts2 proc conts label seed0 seed1)
- (match (intmap-ref conts label)
- (($ $kfun src meta self tail clause)
- (let ((start label))
- (let lp ((label tail) (seed0 seed0) (seed1 seed1))
- (if (<= start label)
- (let ((cont (intmap-ref conts label)))
- (call-with-values (lambda () (proc label cont seed0 seed1))
- (lambda (seed0 seed1)
- (lp (1- label) seed0 seed1))))
- (values seed0 seed1)))))))
-
-(define (compute-known-allocations conts effects)
- "Compute the variables bound in CONTS that have known allocation
-sites."
- ;; Compute the set of conts that are called with freshly allocated
- ;; values, and subtract from that set the conts that might be called
- ;; with values with unknown allocation sites. Then convert that set
- ;; of conts into a set of bound variables.
- (call-with-values
- (lambda ()
- (intmap-fold (lambda (label cont known unknown)
- ;; Note that we only need to add labels to the
- ;; known/unknown sets if the labels can bind
- ;; values. So there's no need to add tail,
- ;; clause, branch alternate, or prompt handler
- ;; labels, as they bind no values.
- (match cont
- (($ $kargs _ _ ($ $continue k))
- (let ((fx (intmap-ref effects label)))
- (if (and (not (causes-all-effects? fx))
- (causes-effect? fx &allocation))
- (values (intset-add! known k) unknown)
- (values known (intset-add! unknown k)))))
- (($ $kreceive arity kargs)
- (values known (intset-add! unknown kargs)))
- (($ $kfun src meta self tail clause)
- (values known unknown))
- (($ $kclause arity body alt)
- (values known (intset-add! unknown body)))
- (($ $ktail)
- (values known unknown))))
- conts
- empty-intset
- empty-intset))
- (lambda (known unknown)
- (persistent-intset
- (intset-fold (lambda (label vars)
- (match (intmap-ref conts label)
- (($ $kargs (_) (var)) (intset-add! vars var))
- (_ vars)))
- (intset-subtract (persistent-intset known)
- (persistent-intset unknown))
- empty-intset)))))
-
-(define (compute-live-code conts)
- (let* ((effects (compute-effects/elide-type-checks conts))
- (known-allocations (compute-known-allocations conts effects)))
- (define (adjoin-var var set)
- (intset-add set var))
- (define (adjoin-vars vars set)
- (match vars
- (() set)
- ((var . vars) (adjoin-vars vars (adjoin-var var set)))))
- (define (var-live? var live-vars)
- (intset-ref live-vars var))
- (define (any-var-live? vars live-vars)
- (match vars
- (() #f)
- ((var . vars)
- (or (var-live? var live-vars)
- (any-var-live? vars live-vars)))))
- (define (cont-defs k)
- (match (intmap-ref conts k)
- (($ $kargs _ vars) vars)
- (_ #f)))
-
- (define (visit-live-exp label k exp live-labels live-vars)
- (match exp
- ((or ($ $const) ($ $prim))
- (values live-labels live-vars))
- (($ $fun body)
- (values (intset-add live-labels body) live-vars))
- (($ $closure body)
- (values (intset-add live-labels body) live-vars))
- (($ $rec names vars (($ $fun kfuns) ...))
- (let lp ((vars vars) (kfuns kfuns)
- (live-labels live-labels) (live-vars live-vars))
- (match (vector vars kfuns)
- (#(() ()) (values live-labels live-vars))
- (#((var . vars) (kfun . kfuns))
- (lp vars kfuns
- (if (var-live? var live-vars)
- (intset-add live-labels kfun)
- live-labels)
- live-vars)))))
- (($ $prompt escape? tag handler)
- (values live-labels (adjoin-var tag live-vars)))
- (($ $call proc args)
- (values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
- (($ $callk kfun proc args)
- (values (intset-add live-labels kfun)
- (adjoin-vars args (adjoin-var proc live-vars))))
- (($ $primcall name args)
- (values live-labels (adjoin-vars args live-vars)))
- (($ $branch k ($ $primcall name args))
- (values live-labels (adjoin-vars args live-vars)))
- (($ $branch k ($ $values (arg)))
- (values live-labels (adjoin-var arg live-vars)))
- (($ $values args)
- (values live-labels
- (match (cont-defs k)
- (#f (adjoin-vars args live-vars))
- (defs (fold (lambda (use def live-vars)
- (if (var-live? def live-vars)
- (adjoin-var use live-vars)
- live-vars))
- live-vars args defs)))))))
-
- (define (visit-exp label k exp live-labels live-vars)
- (cond
- ((intset-ref live-labels label)
- ;; Expression live already.
- (visit-live-exp label k exp live-labels live-vars))
- ((let ((defs (cont-defs k))
- (fx (intmap-ref effects label)))
- (or
- ;; No defs; perhaps continuation is $ktail.
- (not defs)
- ;; We don't remove branches.
- (match exp (($ $branch) #t) (_ #f))
- ;; Do we have a live def?
- (any-var-live? defs live-vars)
- ;; Does this expression cause all effects? If so, it's
- ;; definitely live.
- (causes-all-effects? fx)
- ;; Does it cause a type check, but we weren't able to prove
- ;; that the types check?
- (causes-effect? fx &type-check)
- ;; We might have a setter. If the object being assigned to
- ;; is live or was not created by us, then this expression is
- ;; live. Otherwise the value is still dead.
- (and (causes-effect? fx &write)
- (match exp
- (($ $primcall
- (or 'vector-set! 'vector-set!/immediate
- 'set-car! 'set-cdr!
- 'box-set!)
- (obj . _))
- (or (var-live? obj live-vars)
- (not (intset-ref known-allocations obj))))
- (_ #t)))))
- ;; Mark expression as live and visit.
- (visit-live-exp label k exp (intset-add live-labels label) live-vars))
- (else
- ;; Still dead.
- (values live-labels live-vars))))
-
- (define (visit-fun label live-labels live-vars)
- ;; Visit uses before definitions.
- (postorder-fold-local-conts2
- (lambda (label cont live-labels live-vars)
- (match cont
- (($ $kargs _ _ ($ $continue k src exp))
- (visit-exp label k exp live-labels live-vars))
- (($ $kreceive arity kargs)
- (values live-labels live-vars))
- (($ $kclause arity kargs kalt)
- (values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
- (($ $kfun src meta self)
- (values live-labels (adjoin-var self live-vars)))
- (($ $ktail)
- (values live-labels live-vars))))
- conts label live-labels live-vars))
-
- (fixpoint (lambda (live-labels live-vars)
- (let lp ((label 0)
- (live-labels live-labels)
- (live-vars live-vars))
- (match (intset-next live-labels label)
- (#f (values live-labels live-vars))
- (label
- (call-with-values
- (lambda ()
- (match (intmap-ref conts label)
- (($ $kfun)
- (visit-fun label live-labels live-vars))
- (_ (values live-labels live-vars))))
- (lambda (live-labels live-vars)
- (lp (1+ label) live-labels live-vars)))))))
- (intset 0)
- empty-intset)))
-
-(define-syntax adjoin-conts
- (syntax-rules ()
- ((_ (exp ...) clause ...)
- (let ((cps (exp ...)))
- (adjoin-conts cps clause ...)))
- ((_ cps (label cont) clause ...)
- (adjoin-conts (intmap-add! cps label (build-cont cont))
- clause ...))
- ((_ cps)
- cps)))
-
-(define (process-eliminations conts live-labels live-vars)
- (define (label-live? label)
- (intset-ref live-labels label))
- (define (value-live? var)
- (intset-ref live-vars var))
- (define (make-adaptor k src defs)
- (let* ((names (map (lambda (_) 'tmp) defs))
- (vars (map (lambda (_) (fresh-var)) defs))
- (live (filter-map (lambda (def var)
- (and (value-live? def) var))
- defs vars)))
- (build-cont
- ($kargs names vars
- ($continue k src ($values live))))))
- (define (visit-term label term cps)
- (match term
- (($ $continue k src exp)
- (if (label-live? label)
- (match exp
- (($ $fun body)
- (values cps
- term))
- (($ $closure body nfree)
- (values cps
- term))
- (($ $rec names vars funs)
- (match (filter-map (lambda (name var fun)
- (and (value-live? var)
- (list name var fun)))
- names vars funs)
- (()
- (values cps
- (build-term ($continue k src ($values ())))))
- (((names vars funs) ...)
- (values cps
- (build-term ($continue k src
- ($rec names vars funs)))))))
- (_
- (match (intmap-ref conts k)
- (($ $kargs ())
- (values cps term))
- (($ $kargs names ((? value-live?) ...))
- (values cps term))
- (($ $kargs names vars)
- (match exp
- (($ $values args)
- (let ((args (filter-map (lambda (use def)
- (and (value-live? def) use))
- args vars)))
- (values cps
- (build-term
- ($continue k src ($values args))))))
- (_
- (let-fresh (adapt) ()
- (values (adjoin-conts cps
- (adapt ,(make-adaptor k src vars)))
- (build-term
- ($continue adapt src ,exp)))))))
- (_
- (values cps term)))))
- (values cps
- (build-term
- ($continue k src ($values ()))))))))
- (define (visit-cont label cont cps)
- (match cont
- (($ $kargs names vars term)
- (match (filter-map (lambda (name var)
- (and (value-live? var)
- (cons name var)))
- names vars)
- (((names . vars) ...)
- (call-with-values (lambda () (visit-term label term cps))
- (lambda (cps term)
- (adjoin-conts cps
- (label ($kargs names vars ,term))))))))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (let ((defs (match (intmap-ref conts kargs)
- (($ $kargs names vars) vars))))
- (if (and-map value-live? defs)
- (adjoin-conts cps (label ,cont))
- (let-fresh (adapt) ()
- (adjoin-conts cps
- (adapt ,(make-adaptor kargs #f defs))
- (label ($kreceive req rest adapt)))))))
- (_
- (adjoin-conts cps (label ,cont)))))
- (with-fresh-name-state conts
- (persistent-intmap
- (intmap-fold (lambda (label cont cps)
- (match cont
- (($ $kfun)
- (if (label-live? label)
- (fold-local-conts visit-cont conts label cps)
- cps))
- (_ cps)))
- conts
- empty-intmap))))
-
-(define (eliminate-dead-code conts)
- ;; We work on a renumbered program so that we can easily visit uses
- ;; before definitions just by visiting higher-numbered labels before
- ;; lower-numbered labels. Renumbering is also a precondition for type
- ;; inference.
- (let ((conts (renumber conts)))
- (call-with-values (lambda () (compute-live-code conts))
- (lambda (live-labels live-vars)
- (process-eliminations conts live-labels live-vars)))))
-
-;;; Local Variables:
-;;; eval: (put 'adjoin-conts 'scheme-indent-function 1)
-;;; End:
diff --git a/module/language/cps2/effects-analysis.scm
b/module/language/cps2/effects-analysis.scm
deleted file mode 100644
index ef5d8c8..0000000
--- a/module/language/cps2/effects-analysis.scm
+++ /dev/null
@@ -1,484 +0,0 @@
-;;; Effects analysis on CPS
-
-;; Copyright (C) 2011, 2012, 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A helper module to compute the set of effects caused by an
-;;; expression. This information is useful when writing algorithms that
-;;; move code around, while preserving the semantics of an input
-;;; program.
-;;;
-;;; The effects set is represented as an integer with three parts. The
-;;; low 4 bits indicate effects caused by an expression, as a bitfield.
-;;; The next 4 bits indicate the kind of memory accessed by the
-;;; expression, if it accesses mutable memory. Finally the rest of the
-;;; bits indicate the field in the object being accessed, if known, or
-;;; -1 for unknown.
-;;;
-;;; In this way we embed a coarse type-based alias analysis in the
-;;; effects analysis. For example, a "car" call is modelled as causing
-;;; a read to field 0 on a &pair, and causing a &type-check effect. If
-;;; any intervening code sets the car of any pair, that will block
-;;; motion of the "car" call, because any write to field 0 of a pair is
-;;; seen by effects analysis as being a write to field 0 of all pairs.
-;;;
-;;; Code:
-
-(define-module (language cps2 effects-analysis)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:use-module (ice-9 match)
- #:export (expression-effects
- compute-effects
- synthesize-definition-effects
-
- &allocation
- &type-check
- &read
- &write
-
- &fluid
- &prompt
- &car
- &cdr
- &vector
- &box
- &module
- &struct
- &string
- &bytevector
-
- &object
- &field
-
- &allocate
- &read-object
- &read-field
- &write-object
- &write-field
-
- &no-effects
- &all-effects
-
- exclude-effects
- effect-free?
- constant?
- causes-effect?
- causes-all-effects?
- effect-clobbers?))
-
-(define-syntax define-flags
- (lambda (x)
- (syntax-case x ()
- ((_ all shift name ...)
- (let ((count (length #'(name ...))))
- (with-syntax (((n ...) (iota count))
- (count count))
- #'(begin
- (define-syntax name (identifier-syntax (ash 1 n)))
- ...
- (define-syntax all (identifier-syntax (1- (ash 1 count))))
- (define-syntax shift (identifier-syntax count)))))))))
-
-(define-syntax define-enumeration
- (lambda (x)
- (define (count-bits n)
- (let lp ((out 1))
- (if (< n (ash 1 (1- out)))
- out
- (lp (1+ out)))))
- (syntax-case x ()
- ((_ mask shift name ...)
- (let* ((len (length #'(name ...)))
- (bits (count-bits len)))
- (with-syntax (((n ...) (iota len))
- (bits bits))
- #'(begin
- (define-syntax name (identifier-syntax n))
- ...
- (define-syntax mask (identifier-syntax (1- (ash 1 bits))))
- (define-syntax shift (identifier-syntax bits)))))))))
-
-(define-flags &all-effect-kinds &effect-kind-bits
- ;; Indicates that an expression may cause a type check. A type check,
- ;; for the purposes of this analysis, is the possibility of throwing
- ;; an exception the first time an expression is evaluated. If the
- ;; expression did not cause an exception to be thrown, users can
- ;; assume that evaluating the expression again will not cause an
- ;; exception to be thrown.
- ;;
- ;; For example, (+ x y) might throw if X or Y are not numbers. But if
- ;; it doesn't throw, it should be safe to elide a dominated, common
- ;; subexpression (+ x y).
- &type-check
-
- ;; Indicates that an expression may return a fresh object. The kind
- ;; of object is indicated in the object kind field.
- &allocation
-
- ;; Indicates that an expression may cause a read from memory. The
- ;; kind of memory is given in the object kind field. Some object
- ;; kinds have finer-grained fields; those are expressed in the "field"
- ;; part of the effects value. -1 indicates "the whole object".
- &read
-
- ;; Indicates that an expression may cause a write to memory.
- &write)
-
-(define-enumeration &memory-kind-mask &memory-kind-bits
- ;; Indicates than an expression may access unknown kinds of memory.
- &unknown-memory-kinds
-
- ;; Indicates that an expression depends on the value of a fluid
- ;; variable, or on the current fluid environment.
- &fluid
-
- ;; Indicates that an expression depends on the current prompt
- ;; stack.
- &prompt
-
- ;; Indicates that an expression depends on the value of the car or cdr
- ;; of a pair.
- &pair
-
- ;; Indicates that an expression depends on the value of a vector
- ;; field. The effect field indicates the specific field, or zero for
- ;; an unknown field.
- &vector
-
- ;; Indicates that an expression depends on the value of a variable
- ;; cell.
- &box
-
- ;; Indicates that an expression depends on the current module.
- &module
-
- ;; Indicates that an expression depends on the value of a struct
- ;; field. The effect field indicates the specific field, or zero for
- ;; an unknown field.
- &struct
-
- ;; Indicates that an expression depends on the contents of a string.
- &string
-
- ;; Indicates that an expression depends on the contents of a
- ;; bytevector. We cannot be more precise, as bytevectors may alias
- ;; other bytevectors.
- &bytevector)
-
-(define-inlinable (&field kind field)
- (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
-(define-inlinable (&object kind)
- (&field kind -1))
-
-(define-inlinable (&allocate kind)
- (logior &allocation (&object kind)))
-(define-inlinable (&read-field kind field)
- (logior &read (&field kind field)))
-(define-inlinable (&read-object kind)
- (logior &read (&object kind)))
-(define-inlinable (&write-field kind field)
- (logior &write (&field kind field)))
-(define-inlinable (&write-object kind)
- (logior &write (&object kind)))
-
-(define-syntax &no-effects (identifier-syntax 0))
-(define-syntax &all-effects
- (identifier-syntax
- (logior &all-effect-kinds (&object &unknown-memory-kinds))))
-
-(define-inlinable (constant? effects)
- (zero? effects))
-
-(define-inlinable (causes-effect? x effects)
- (not (zero? (logand x effects))))
-
-(define-inlinable (causes-all-effects? x)
- (eqv? x &all-effects))
-
-(define (effect-clobbers? a b)
- "Return true if A clobbers B. This is the case if A is a write, and B
-is or might be a read or a write to the same location as A."
- (define (locations-same?)
- (let ((a (ash a (- &effect-kind-bits)))
- (b (ash b (- &effect-kind-bits))))
- (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
- (eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
- (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
- ;; A negative field indicates "the whole object".
- ;; Non-negative fields indicate only part of the object.
- (or (< a 0) (< b 0) (= a b))))))
- (and (not (zero? (logand a &write)))
- (not (zero? (logand b (logior &read &write))))
- (locations-same?)))
-
-(define-inlinable (indexed-field kind var constants)
- (let ((val (intmap-ref constants var (lambda (_) #f))))
- (if (and (exact-integer? val) (<= 0 val))
- (&field kind val)
- (&object kind))))
-
-(define *primitive-effects* (make-hash-table))
-
-(define-syntax-rule (define-primitive-effects* constants
- ((name . args) effects ...)
- ...)
- (begin
- (hashq-set! *primitive-effects* 'name
- (case-lambda*
- ((constants . args) (logior effects ...))
- (_ &all-effects)))
- ...))
-
-(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
- (define-primitive-effects* constants ((name . args) effects ...) ...))
-
-;; Miscellaneous.
-(define-primitive-effects
- ((values . _)))
-
-;; Generic effect-free predicates.
-(define-primitive-effects
- ((eq? . _))
- ((eqv? . _))
- ((equal? . _))
- ((pair? arg))
- ((null? arg))
- ((nil? arg ))
- ((symbol? arg))
- ((variable? arg))
- ((vector? arg))
- ((struct? arg))
- ((string? arg))
- ((number? arg))
- ((char? arg))
- ((bytevector? arg))
- ((keyword? arg))
- ((bitvector? arg))
- ((procedure? arg))
- ((thunk? arg)))
-
-;; Fluids.
-(define-primitive-effects
- ((fluid-ref f) (&read-object &fluid) &type-check)
- ((fluid-set! f v) (&write-object &fluid) &type-check)
- ((push-fluid f v) (&write-object &fluid) &type-check)
- ((pop-fluid) (&write-object &fluid) &type-check))
-
-;; Prompts.
-(define-primitive-effects
- ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
-
-;; Pairs.
-(define-primitive-effects
- ((cons a b) (&allocate &pair))
- ((list . _) (&allocate &pair))
- ((car x) (&read-field &pair 0) &type-check)
- ((set-car! x y) (&write-field &pair 0) &type-check)
- ((cdr x) (&read-field &pair 1) &type-check)
- ((set-cdr! x y) (&write-field &pair 1) &type-check)
- ((memq x y) (&read-object &pair) &type-check)
- ((memv x y) (&read-object &pair) &type-check)
- ((list? arg) (&read-field &pair 1))
- ((length l) (&read-field &pair 1) &type-check))
-
-;; Variables.
-(define-primitive-effects
- ((box v) (&allocate &box))
- ((box-ref v) (&read-object &box) &type-check)
- ((box-set! v x) (&write-object &box) &type-check))
-
-;; Vectors.
-(define (vector-field n constants)
- (indexed-field &vector n constants))
-(define (read-vector-field n constants)
- (logior &read (vector-field n constants)))
-(define (write-vector-field n constants)
- (logior &write (vector-field n constants)))
-(define-primitive-effects* constants
- ((vector . _) (&allocate &vector))
- ((make-vector n init) (&allocate &vector) &type-check)
- ((make-vector/immediate n init) (&allocate &vector))
- ((vector-ref v n) (read-vector-field n constants) &type-check)
- ((vector-ref/immediate v n) (read-vector-field n constants) &type-check)
- ((vector-set! v n x) (write-vector-field n constants)
&type-check)
- ((vector-set!/immediate v n x) (write-vector-field n constants)
&type-check)
- ((vector-length v) &type-check))
-
-;; Structs.
-(define (struct-field n constants)
- (indexed-field &struct n constants))
-(define (read-struct-field n constants)
- (logior &read (struct-field n constants)))
-(define (write-struct-field n constants)
- (logior &write (struct-field n constants)))
-(define-primitive-effects* constants
- ((allocate-struct vt n) (&allocate &struct) &type-check)
- ((allocate-struct/immediate v n) (&allocate &struct) &type-check)
- ((make-struct vt ntail . _) (&allocate &struct) &type-check)
- ((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
- ((struct-ref s n) (read-struct-field n constants) &type-check)
- ((struct-ref/immediate s n) (read-struct-field n constants) &type-check)
- ((struct-set! s n x) (write-struct-field n constants)
&type-check)
- ((struct-set!/immediate s n x) (write-struct-field n constants)
&type-check)
- ((struct-vtable s) &type-check))
-
-;; Strings.
-(define-primitive-effects
- ((string-ref s n) (&read-object &string) &type-check)
- ((string-set! s n c) (&write-object &string) &type-check)
- ((number->string _) (&allocate &string) &type-check)
- ((string->number _) (&read-object &string) &type-check)
- ((string-length s) &type-check))
-
-;; Bytevectors.
-(define-primitive-effects
- ((bytevector-length _) &type-check)
-
- ((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-u16-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-s16-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-u32-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-s32-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-u64-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-s64-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-f32-ref bv n) (&read-object &bytevector) &type-check)
- ((bv-f64-ref bv n) (&read-object &bytevector) &type-check)
-
- ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
- ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
-
-;; Modules.
-(define-primitive-effects
- ((current-module) (&read-object &module))
- ((cache-current-module! m scope) (&write-object &box))
- ((resolve name bound?) (&read-object &module) &type-check)
- ((cached-toplevel-box scope name bound?) &type-check)
- ((cached-module-box mod name public? bound?) &type-check)
- ((define! name val) (&read-object &module) (&write-object
&box)))
-
-;; Numbers.
-(define-primitive-effects
- ((= . _) &type-check)
- ((< . _) &type-check)
- ((> . _) &type-check)
- ((<= . _) &type-check)
- ((>= . _) &type-check)
- ((zero? . _) &type-check)
- ((add . _) &type-check)
- ((mul . _) &type-check)
- ((sub . _) &type-check)
- ((div . _) &type-check)
- ((sub1 . _) &type-check)
- ((add1 . _) &type-check)
- ((quo . _) &type-check)
- ((rem . _) &type-check)
- ((mod . _) &type-check)
- ((complex? _) &type-check)
- ((real? _) &type-check)
- ((rational? _) &type-check)
- ((inf? _) &type-check)
- ((nan? _) &type-check)
- ((integer? _) &type-check)
- ((exact? _) &type-check)
- ((inexact? _) &type-check)
- ((even? _) &type-check)
- ((odd? _) &type-check)
- ((ash n m) &type-check)
- ((logand . _) &type-check)
- ((logior . _) &type-check)
- ((logxor . _) &type-check)
- ((lognot . _) &type-check)
- ((logtest a b) &type-check)
- ((logbit? a b) &type-check)
- ((sqrt _) &type-check)
- ((abs _) &type-check))
-
-;; Characters.
-(define-primitive-effects
- ((char<? . _) &type-check)
- ((char<=? . _) &type-check)
- ((char>=? . _) &type-check)
- ((char>? . _) &type-check)
- ((integer->char _) &type-check)
- ((char->integer _) &type-check))
-
-(define (primitive-effects constants name args)
- (let ((proc (hashq-ref *primitive-effects* name)))
- (if proc
- (apply proc constants args)
- &all-effects)))
-
-(define (expression-effects exp constants)
- (match exp
- ((or ($ $const) ($ $prim) ($ $values))
- &no-effects)
- ((or ($ $fun) ($ $rec) ($ $closure))
- (&allocate &unknown-memory-kinds))
- (($ $prompt)
- (&write-object &prompt))
- ((or ($ $call) ($ $callk))
- &all-effects)
- (($ $branch k exp)
- (expression-effects exp constants))
- (($ $primcall name args)
- (primitive-effects constants name args))))
-
-(define (compute-effects conts)
- (let ((constants (compute-constant-values conts)))
- (intmap-map
- (lambda (label cont)
- (match cont
- (($ $kargs names syms ($ $continue k src exp))
- (expression-effects exp constants))
- (($ $kreceive arity kargs)
- (match arity
- (($ $arity _ () #f () #f) &type-check)
- (($ $arity () () _ () #f) (&allocate &pair))
- (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
- (($ $kfun) &type-check)
- (($ $kclause) &type-check)
- (($ $ktail) &no-effects)))
- conts)))
-
-;; There is a way to abuse effects analysis in CSE to also do scalar
-;; replacement, effectively adding `car' and `cdr' expressions to `cons'
-;; expressions, and likewise with other constructors and setters. This
-;; routine adds appropriate effects to `cons' and `set-car!' and the
-;; like.
-;;
-;; This doesn't affect CSE's ability to eliminate expressions, given
-;; that allocations aren't eliminated anyway, and the new effects will
-;; just cause the allocations not to commute with e.g. set-car! which
-;; is what we want anyway.
-(define (synthesize-definition-effects effects)
- (intmap-map (lambda (label fx)
- (if (logtest (logior &write &allocation) fx)
- (logior fx &read)
- fx))
- effects))
diff --git a/module/language/cps2/elide-values.scm
b/module/language/cps2/elide-values.scm
deleted file mode 100644
index ff04789..0000000
--- a/module/language/cps2/elide-values.scm
+++ /dev/null
@@ -1,88 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Primcalls that don't correspond to VM instructions are treated as if
-;;; they are calls, and indeed the later reify-primitives pass turns
-;;; them into calls. Because no return arity checking is done for these
-;;; primitives, if a later optimization pass simplifies the primcall to
-;;; a VM operation, the tail of the simplification has to be a
-;;; primcall to 'values. Most of these primcalls can be elided, and
-;;; that is the job of this pass.
-;;;
-;;; Code:
-
-(define-module (language cps2 elide-values)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 with-cps)
- #:use-module (language cps intmap)
- #:export (elide-values))
-
-(define (inline-values cps k src args)
- (match (intmap-ref cps k)
- (($ $ktail)
- (with-cps cps
- (build-term
- ($continue k src ($values args)))))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (cond
- ((and (not rest) (= (length args) (length req)))
- (with-cps cps
- (build-term
- ($continue kargs src ($values args)))))
- ((and rest (>= (length args) (length req)))
- (let ()
- (define (build-rest cps k tail)
- (match tail
- (()
- (with-cps cps
- (build-term ($continue k src ($const '())))))
- ((v . tail)
- (with-cps cps
- (letv rest)
- (letk krest ($kargs ('rest) (rest)
- ($continue k src ($primcall 'cons (v rest)))))
- ($ (build-rest krest tail))))))
- (with-cps cps
- (letv rest)
- (letk krest ($kargs ('rest) (rest)
- ($continue kargs src
- ($values ,(append (list-head args (length req))
- (list rest))))))
- ($ (build-rest krest (list-tail args (length req)))))))
- (else (with-cps cps #f))))))
-
-(define (elide-values conts)
- (with-fresh-name-state conts
- (persistent-intmap
- (intmap-fold
- (lambda (label cont out)
- (match cont
- (($ $kargs names vars ($ $continue k src ($ $primcall 'values args)))
- (call-with-values (lambda () (inline-values out k src args))
- (lambda (out term)
- (if term
- (let ((cont (build-cont ($kargs names vars ,term))))
- (intmap-replace! out label cont))
- out))))
- (_ out)))
- conts
- conts))))
diff --git a/module/language/cps2/optimize.scm
b/module/language/cps2/optimize.scm
deleted file mode 100644
index 9e877b9..0000000
--- a/module/language/cps2/optimize.scm
+++ /dev/null
@@ -1,106 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Optimizations on CPS2.
-;;;
-;;; Code:
-
-(define-module (language cps2 optimize)
- #:use-module (ice-9 match)
- #:use-module (language cps2 constructors)
- #:use-module (language cps2 contification)
- #:use-module (language cps2 cse)
- #:use-module (language cps2 dce)
- #:use-module (language cps2 elide-values)
- #:use-module (language cps2 prune-top-level-scopes)
- #:use-module (language cps2 prune-bailouts)
- #:use-module (language cps2 self-references)
- #:use-module (language cps2 simplify)
- #:use-module (language cps2 specialize-primcalls)
- #:use-module (language cps2 split-rec)
- #:use-module (language cps2 type-fold)
- #:use-module (language cps2 verify)
- #:export (optimize-higher-order-cps
- optimize-first-order-cps))
-
-(define (kw-arg-ref args kw default)
- (match (memq kw args)
- ((_ val . _) val)
- (_ default)))
-
-(define *debug?* #f)
-
-(define (maybe-verify program)
- (if *debug?*
- (verify program)
- program))
-
-(define-syntax-rule (define-optimizer optimize (pass kw default) ...)
- (define* (optimize program #:optional (opts '()))
- ;; This series of assignments to `program' used to be a series of
- ;; let* bindings of `program', as you would imagine. In compiled
- ;; code this is fine because the compiler is able to allocate all
- ;; let*-bound variable to the same slot, which also means that the
- ;; garbage collector doesn't have to retain so many copies of the
- ;; term being optimized. However during bootstrap, the interpreter
- ;; doesn't do this optimization, leading to excessive data retention
- ;; as the terms are rewritten. To marginally improve bootstrap
- ;; memory usage, here we use set! instead. The compiler should
- ;; produce the same code in any case, though currently it does not
- ;; because it doesn't do escape analysis on the box created for the
- ;; set!.
- (maybe-verify program)
- (set! program
- (if (kw-arg-ref opts kw default)
- (maybe-verify (pass program))
- program))
- ...
- (verify program)
- program))
-
-;; Passes that are needed:
-;;
-;; * Abort contification: turning abort primcalls into continuation
-;; calls, and eliding prompts if possible.
-;;
-;; * Loop peeling. Unrolls the first round through a loop if the
-;; loop has effects that CSE can work on. Requires effects
-;; analysis. When run before CSE, loop peeling is the equivalent
-;; of loop-invariant code motion (LICM).
-;;
-(define-optimizer optimize-higher-order-cps
- (split-rec #:split-rec? #t)
- (eliminate-dead-code #:eliminate-dead-code? #t)
- (prune-top-level-scopes #:prune-top-level-scopes? #t)
- (simplify #:simplify? #t)
- (contify #:contify? #t)
- (inline-constructors #:inline-constructors? #t)
- (specialize-primcalls #:specialize-primcalls? #t)
- (elide-values #:elide-values? #t)
- (prune-bailouts #:prune-bailouts? #t)
- (eliminate-common-subexpressions #:cse? #t)
- (type-fold #:type-fold? #t)
- (resolve-self-references #:resolve-self-references? #t)
- (eliminate-dead-code #:eliminate-dead-code? #t)
- (simplify #:simplify? #t))
-
-(define-optimizer optimize-first-order-cps
- (eliminate-dead-code #:eliminate-dead-code? #t)
- (simplify #:simplify? #t))
diff --git a/module/language/cps2/prune-bailouts.scm
b/module/language/cps2/prune-bailouts.scm
deleted file mode 100644
index f33d2ae..0000000
--- a/module/language/cps2/prune-bailouts.scm
+++ /dev/null
@@ -1,86 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A pass that prunes successors of expressions that bail out.
-;;;
-;;; Code:
-
-(define-module (language cps2 prune-bailouts)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 with-cps)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (prune-bailouts))
-
-(define (compute-tails conts)
- "For each LABEL->CONT entry in the intmap CONTS, compute a
-LABEL->TAIL-LABEL indicating the tail continuation of each expression's
-containing function. In some cases TAIL-LABEL might not be available,
-for example if there is a stale $kfun pointing at a body, or for
-unreferenced terms. In that case TAIL-LABEL is either absent or #f."
- (intmap-fold
- (lambda (label cont out)
- (match cont
- (($ $kfun src meta self tail clause)
- (intset-fold (lambda (label out)
- (intmap-add out label tail (lambda (old new) #f)))
- (compute-function-body conts label)
- out))
- (_ out)))
- conts
- empty-intmap))
-
-(define (prune-bailout out tails k src exp)
- (match (intmap-ref out k)
- (($ $ktail)
- (with-cps out #f))
- (_
- (match (intmap-ref tails k (lambda (_) #f))
- (#f
- (with-cps out #f))
- (ktail
- (with-cps out
- (letv prim rest)
- (letk kresult ($kargs ('rest) (rest)
- ($continue ktail src ($values ()))))
- (letk kreceive ($kreceive '() 'rest kresult))
- (build-term ($continue kreceive src ,exp))))))))
-
-(define (prune-bailouts conts)
- (let ((tails (compute-tails conts)))
- (with-fresh-name-state conts
- (persistent-intmap
- (intmap-fold
- (lambda (label cont out)
- (match cont
- (($ $kargs names vars
- ($ $continue k src
- (and exp ($ $primcall (or 'error 'scm-error 'throw)))))
- (call-with-values (lambda () (prune-bailout out tails k src exp))
- (lambda (out term)
- (if term
- (let ((cont (build-cont ($kargs names vars ,term))))
- (intmap-replace! out label cont))
- out))))
- (_ out)))
- conts
- conts)))))
diff --git a/module/language/cps2/prune-top-level-scopes.scm
b/module/language/cps2/prune-top-level-scopes.scm
deleted file mode 100644
index c737534..0000000
--- a/module/language/cps2/prune-top-level-scopes.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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 published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A simple pass to prune unneeded top-level scopes.
-;;;
-;;; Code:
-
-(define-module (language cps2 prune-top-level-scopes)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (prune-top-level-scopes))
-
-(define (compute-used-scopes conts constants)
- (persistent-intset
- (intmap-fold
- (lambda (label cont used-scopes)
- (match cont
- (($ $kargs _ _
- ($ $continue k src
- ($ $primcall 'cached-toplevel-box (scope name bound?))))
- (intset-add! used-scopes (intmap-ref constants scope)))
- (_
- used-scopes)))
- conts
- empty-intset)))
-
-(define (prune-top-level-scopes conts)
- (let* ((constants (compute-constant-values conts))
- (used-scopes (compute-used-scopes conts constants)))
- (intmap-map
- (lambda (label cont)
- (match cont
- (($ $kargs names vars
- ($ $continue k src
- ($ $primcall 'cache-current-module!
- (module (? (lambda (scope)
- (let ((val (intmap-ref constants scope)))
- (not (intset-ref used-scopes val)))))))))
- (build-cont ($kargs names vars
- ($continue k src ($values ())))))
- (_
- cont)))
- conts)))
diff --git a/module/language/cps2/reify-primitives.scm
b/module/language/cps2/reify-primitives.scm
deleted file mode 100644
index 55409bf..0000000
--- a/module/language/cps2/reify-primitives.scm
+++ /dev/null
@@ -1,167 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A pass to reify lone $prim's that were never folded into a
-;;; $primcall, and $primcall's to primitives that don't have a
-;;; corresponding VM op.
-;;;
-;;; Code:
-
-(define-module (language cps2 reify-primitives)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 with-cps)
- #:use-module (language cps primitives)
- #:use-module (language cps intmap)
- #:use-module (language bytecode)
- #:export (reify-primitives))
-
-(define (module-box cps src module name public? bound? val-proc)
- (with-cps cps
- (letv box)
- (let$ body (val-proc box))
- (letk kbox ($kargs ('box) (box) ,body))
- ($ (with-cps-constants ((module module)
- (name name)
- (public? public?)
- (bound? bound?))
- (build-term ($continue kbox src
- ($primcall 'cached-module-box
- (module name public? bound?))))))))
-
-(define (primitive-module name)
- (case name
- ((bytevector?
- bytevector-length
-
- bytevector-u8-ref bytevector-u8-set!
- bytevector-s8-ref bytevector-s8-set!
-
- bytevector-u16-ref bytevector-u16-set!
- bytevector-u16-native-ref bytevector-u16-native-set!
- bytevector-s16-ref bytevector-s16-set!
- bytevector-s16-native-ref bytevector-s16-native-set!
-
- bytevector-u32-ref bytevector-u32-set!
- bytevector-u32-native-ref bytevector-u32-native-set!
- bytevector-s32-ref bytevector-s32-set!
- bytevector-s32-native-ref bytevector-s32-native-set!
-
- bytevector-u64-ref bytevector-u64-set!
- bytevector-u64-native-ref bytevector-u64-native-set!
- bytevector-s64-ref bytevector-s64-set!
- bytevector-s64-native-ref bytevector-s64-native-set!
-
- bytevector-ieee-single-ref bytevector-ieee-single-set!
- bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
- bytevector-ieee-double-ref bytevector-ieee-double-set!
- bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
- '(rnrs bytevectors))
- ((class-of) '(oop goops))
- (else '(guile))))
-
-(define (primitive-ref cps name k src)
- (module-box cps src (primitive-module name) name #f #t
- (lambda (cps box)
- (with-cps cps
- (build-term
- ($continue k src ($primcall 'box-ref (box))))))))
-
-(define (builtin-ref cps idx k src)
- (with-cps cps
- ($ (with-cps-constants ((idx idx))
- (build-term
- ($continue k src ($primcall 'builtin-ref (idx))))))))
-
-(define (reify-clause cps ktail)
- (with-cps cps
- (letv throw)
- (let$ throw-body
- (with-cps-constants ((wna 'wrong-number-of-args)
- (false #f)
- (str "Wrong number of arguments")
- (eol '()))
- (build-term
- ($continue ktail #f
- ($call throw (wna false str eol false))))))
- (letk kthrow ($kargs ('throw) (throw) ,throw-body))
- (let$ body (primitive-ref 'throw kthrow #f))
- (letk kbody ($kargs () () ,body))
- (letk kclause ($kclause ('() '() #f '() #f) kbody #f))
- kclause))
-
-;; A $kreceive continuation should have only one predecessor.
-(define (uniquify-receive cps k)
- (match (intmap-ref cps k)
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (with-cps cps
- (letk k ($kreceive req rest kargs))
- k))
- (_
- (with-cps cps k))))
-
-(define (reify-primitives cps)
- (define (visit-cont label cont cps)
- (define (resolve-prim cps name k src)
- (cond
- ((builtin-name->index name)
- => (lambda (idx) (builtin-ref cps idx k src)))
- (else
- (primitive-ref cps name k src))))
- (match cont
- (($ $kfun src meta self tail #f)
- (with-cps cps
- (let$ clause (reify-clause tail))
- (setk label ($kfun src meta self tail clause))))
- (($ $kargs names vars ($ $continue k src ($ $prim name)))
- (with-cps cps
- (let$ k (uniquify-receive k))
- (let$ body (resolve-prim name k src))
- (setk label ($kargs names vars ,body))))
- (($ $kargs names vars
- ($ $continue k src ($ $primcall 'call-thunk/no-inline (proc))))
- (with-cps cps
- (setk label ($kargs names vars ($continue k src ($call proc ()))))))
- (($ $kargs names vars ($ $continue k src ($ $primcall name args)))
- (if (or (prim-instruction name) (branching-primitive? name))
- ;; Assume arities are correct.
- cps
- (with-cps cps
- (letv proc)
- (let$ k (uniquify-receive k))
- (letk kproc ($kargs ('proc) (proc)
- ($continue k src ($call proc args))))
- (let$ body (resolve-prim name kproc src))
- (setk label ($kargs names vars ,body)))))
- (($ $kargs names vars ($ $continue k src ($ $call proc args)))
- (with-cps cps
- (let$ k (uniquify-receive k))
- (setk label ($kargs names vars
- ($continue k src ($call proc args))))))
- (($ $kargs names vars ($ $continue k src ($ $callk k* proc args)))
- (with-cps cps
- (let$ k (uniquify-receive k))
- (setk label ($kargs names vars
- ($continue k src ($callk k* proc args))))))
- (_ cps)))
-
- (with-fresh-name-state cps
- (persistent-intmap (intmap-fold visit-cont cps cps))))
diff --git a/module/language/cps2/renumber.scm
b/module/language/cps2/renumber.scm
deleted file mode 100644
index 16ed29c..0000000
--- a/module/language/cps2/renumber.scm
+++ /dev/null
@@ -1,217 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A pass to renumber variables and continuation labels so that they
-;;; are contiguous within each function and, in the case of labels,
-;;; topologically sorted.
-;;;
-;;; Code:
-
-(define-module (language cps2 renumber)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intset)
- #:use-module (language cps intmap)
- #:export (renumber))
-
-(define* (compute-tail-path-lengths conts kfun preds)
- (define (add-lengths labels lengths length)
- (intset-fold (lambda (label lengths)
- (intmap-add! lengths label length))
- labels
- lengths))
- (define (compute-next labels lengths)
- (intset-fold (lambda (label labels)
- (fold1 (lambda (pred labels)
- (if (intmap-ref lengths pred (lambda (_) #f))
- labels
- (intset-add! labels pred)))
- (intmap-ref preds label)
- labels))
- labels
- empty-intset))
- (define (visit labels lengths length)
- (let ((lengths (add-lengths labels lengths length)))
- (values (compute-next labels lengths) lengths (1+ length))))
- (match (intmap-ref conts kfun)
- (($ $kfun src meta self tail clause)
- (worklist-fold visit (intset-add empty-intset tail) empty-intmap 0))))
-
-;; Topologically sort the continuation tree starting at k0, using
-;; reverse post-order numbering.
-(define (sort-labels-locally conts k0 path-lengths)
- (define (visit-kf-first? kf kt)
- ;; Visit the successor of a branch with the shortest path length to
- ;; the tail first, so that if the branches are unsorted, the longer
- ;; path length will appear first. This will move a loop exit out of
- ;; a loop.
- (let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f)))
- (kt-len (intmap-ref path-lengths kt (lambda (_) #f))))
- (if kt-len
- (or (not kf-len) (< kf-len kt-len)
- ;; If the path lengths are the same, preserve original
- ;; order to avoid squirreliness.
- (and (= kf-len kt-len) (< kt kf)))
- (if kf-len #f (< kt kf)))))
- (let ((order '())
- (visited empty-intset))
- (let visit ((k k0) (order '()) (visited empty-intset))
- (define (visit2 k0 k1 order visited)
- (let-values (((order visited) (visit k0 order visited)))
- (visit k1 order visited)))
- (if (intset-ref visited k)
- (values order visited)
- (let ((visited (intset-add visited k)))
- (call-with-values
- (lambda ()
- (match (intmap-ref conts k)
- (($ $kargs names syms ($ $continue k src exp))
- (match exp
- (($ $prompt escape? tag handler)
- (visit2 k handler order visited))
- (($ $branch kt)
- (if (visit-kf-first? k kt)
- (visit2 k kt order visited)
- (visit2 kt k order visited)))
- (_
- (visit k order visited))))
- (($ $kreceive arity k) (visit k order visited))
- (($ $kclause arity kbody kalt)
- (if kalt
- (visit2 kalt kbody order visited)
- (visit kbody order visited)))
- (($ $kfun src meta self tail clause)
- (if clause
- (visit2 tail clause order visited)
- (visit tail order visited)))
- (($ $ktail) (values order visited))))
- (lambda (order visited)
- ;; Add k to the reverse post-order.
- (values (cons k order) visited))))))))
-
-(define (compute-renaming conts kfun)
- ;; labels := old -> new
- ;; vars := old -> new
- (define *next-label* -1)
- (define *next-var* -1)
- (define (rename-label label labels)
- (set! *next-label* (1+ *next-label*))
- (intmap-add! labels label *next-label*))
- (define (rename-var sym vars)
- (set! *next-var* (1+ *next-var*))
- (intmap-add! vars sym *next-var*))
- (define (rename label labels vars)
- (values (rename-label label labels)
- (match (intmap-ref conts label)
- (($ $kargs names syms exp)
- (fold1 rename-var syms vars))
- (($ $kfun src meta self tail clause)
- (rename-var self vars))
- (_ vars))))
- (define (maybe-visit-fun kfun labels vars)
- (if (intmap-ref labels kfun (lambda (_) #f))
- (values labels vars)
- (visit-fun kfun labels vars)))
- (define (visit-nested-funs k labels vars)
- (match (intmap-ref conts k)
- (($ $kargs names syms ($ $continue k src ($ $fun kfun)))
- (visit-fun kfun labels vars))
- (($ $kargs names syms ($ $continue k src ($ $rec names* syms*
- (($ $fun kfun) ...))))
- (fold2 visit-fun kfun labels vars))
- (($ $kargs names syms ($ $continue k src ($ $closure kfun nfree)))
- ;; Closures with zero free vars get copy-propagated so it's
- ;; possible to already have visited them.
- (maybe-visit-fun kfun labels vars))
- (($ $kargs names syms ($ $continue k src ($ $callk kfun)))
- ;; Well-known functions never have a $closure created for them
- ;; and are only referenced by their $callk call sites.
- (maybe-visit-fun kfun labels vars))
- (_ (values labels vars))))
- (define (visit-fun kfun labels vars)
- (let* ((preds (compute-predecessors conts kfun))
- (path-lengths (compute-tail-path-lengths conts kfun preds))
- (order (sort-labels-locally conts kfun path-lengths)))
- ;; First rename locally, then recurse on nested functions.
- (let-values (((labels vars) (fold2 rename order labels vars)))
- (fold2 visit-nested-funs order labels vars))))
- (let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
- (values (persistent-intmap labels) (persistent-intmap vars))))
-
-(define* (renumber conts #:optional (kfun 0))
- (let-values (((label-map var-map) (compute-renaming conts kfun)))
- (define (rename-label label) (intmap-ref label-map label))
- (define (rename-var var) (intmap-ref var-map var))
- (define (rename-exp exp)
- (rewrite-exp exp
- ((or ($ $const) ($ $prim)) ,exp)
- (($ $closure k nfree)
- ($closure (rename-label k) nfree))
- (($ $fun body)
- ($fun (rename-label body)))
- (($ $rec names vars funs)
- ($rec names (map rename-var vars) (map rename-exp funs)))
- (($ $values args)
- ($values ,(map rename-var args)))
- (($ $call proc args)
- ($call (rename-var proc) ,(map rename-var args)))
- (($ $callk k proc args)
- ($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
- (($ $branch kt exp)
- ($branch (rename-label kt) ,(rename-exp exp)))
- (($ $primcall name args)
- ($primcall name ,(map rename-var args)))
- (($ $prompt escape? tag handler)
- ($prompt escape? (rename-var tag) (rename-label handler)))))
- (define (rename-arity arity)
- (match arity
- (($ $arity req opt rest () aok?)
- arity)
- (($ $arity req opt rest kw aok?)
- (match kw
- (() arity)
- (((kw kw-name kw-var) ...)
- (let ((kw (map list kw kw-name (map rename-var kw-var))))
- (make-$arity req opt rest kw aok?)))))))
- (persistent-intmap
- (intmap-fold
- (lambda (old-k new-k out)
- (intmap-add!
- out
- new-k
- (rewrite-cont (intmap-ref conts old-k)
- (($ $kargs names syms ($ $continue k src exp))
- ($kargs names (map rename-var syms)
- ($continue (rename-label k) src ,(rename-exp exp))))
- (($ $kreceive ($ $arity req () rest () #f) k)
- ($kreceive req rest (rename-label k)))
- (($ $ktail)
- ($ktail))
- (($ $kfun src meta self tail clause)
- ($kfun src meta (rename-var self) (rename-label tail)
- (and clause (rename-label clause))))
- (($ $kclause arity body alternate)
- ($kclause ,(rename-arity arity) (rename-label body)
- (and alternate (rename-label alternate)))))))
- label-map
- empty-intmap))))
diff --git a/module/language/cps2/self-references.scm
b/module/language/cps2/self-references.scm
deleted file mode 100644
index 20ac56f..0000000
--- a/module/language/cps2/self-references.scm
+++ /dev/null
@@ -1,79 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A pass that replaces free references to recursive functions with
-;;; bound references.
-;;;
-;;; Code:
-
-(define-module (language cps2 self-references)
- #:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (resolve-self-references))
-
-(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap))
- (define (subst var)
- (intmap-ref env var (lambda (var) var)))
-
- (define (rename-exp label cps names vars k src exp)
- (let ((exp (rewrite-exp exp
- ((or ($ $const) ($ $prim)) ,exp)
- (($ $call proc args)
- ($call (subst proc) ,(map subst args)))
- (($ $callk k proc args)
- ($callk k (subst proc) ,(map subst args)))
- (($ $primcall name args)
- ($primcall name ,(map subst args)))
- (($ $branch k ($ $values (arg)))
- ($branch k ($values ((subst arg)))))
- (($ $branch k ($ $primcall name args))
- ($branch k ($primcall name ,(map subst args))))
- (($ $values args)
- ($values ,(map subst args)))
- (($ $prompt escape? tag handler)
- ($prompt escape? (subst tag) handler)))))
- (intmap-replace! cps label
- (build-cont
- ($kargs names vars ($continue k src ,exp))))))
-
- (define (visit-exp cps label names vars k src exp)
- (match exp
- (($ $fun label)
- (resolve-self-references cps label env))
- (($ $rec names vars (($ $fun labels) ...))
- (fold (lambda (label var cps)
- (match (intmap-ref cps label)
- (($ $kfun src meta self)
- (resolve-self-references cps label
- (intmap-add env var self)))))
- cps labels vars))
- (_ (rename-exp label cps names vars k src exp))))
-
- (intset-fold (lambda (label cps)
- (match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-exp cps label names vars k src exp))
- (_ cps)))
- (compute-function-body cps label)
- cps))
diff --git a/module/language/cps2/simplify.scm
b/module/language/cps2/simplify.scm
deleted file mode 100644
index 19d7a17..0000000
--- a/module/language/cps2/simplify.scm
+++ /dev/null
@@ -1,267 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; The fundamental lambda calculus reductions, like beta and eta
-;;; reduction and so on. Pretty lame currently.
-;;;
-;;; Code:
-
-(define-module (language cps2 simplify)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intset)
- #:use-module (language cps intmap)
- #:export (simplify))
-
-(define (intset-maybe-add! set k add?)
- (if add? (intset-add! set k) set))
-
-(define (intset-add* set k*)
- (let lp ((set set) (k* k*))
- (match k*
- ((k . k*) (lp (intset-add set k) k*))
- (() set))))
-
-(define (intset-add*! set k*)
- (fold1 (lambda (k set) (intset-add! set k)) k* set))
-
-(define (fold2* f l1 l2 seed)
- (let lp ((l1 l1) (l2 l2) (seed seed))
- (match (cons l1 l2)
- ((() . ()) seed)
- (((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed))))))
-
-(define (transform-conts f conts)
- (persistent-intmap
- (intmap-fold (lambda (k v out)
- (let ((v* (f k v)))
- (cond
- ((equal? v v*) out)
- (v* (intmap-replace! out k v*))
- (else (intmap-remove out k)))))
- conts
- conts)))
-
-(define (compute-singly-referenced-vars conts)
- (define (visit label cont single multiple)
- (define (add-ref var single multiple)
- (if (intset-ref single var)
- (values single (intset-add! multiple var))
- (values (intset-add! single var) multiple)))
- (define (ref var) (add-ref var single multiple))
- (define (ref* vars) (fold2 add-ref vars single multiple))
- (match cont
- (($ $kargs _ _ ($ $continue _ _ exp))
- (match exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
- (values single multiple))
- (($ $call proc args)
- (ref* (cons proc args)))
- (($ $callk k proc args)
- (ref* (cons proc args)))
- (($ $primcall name args)
- (ref* args))
- (($ $values args)
- (ref* args))
- (($ $branch kt ($ $values (var)))
- (ref var))
- (($ $branch kt ($ $primcall name args))
- (ref* args))
- (($ $prompt escape? tag handler)
- (ref tag))))
- (_
- (values single multiple))))
- (let*-values (((single multiple) (values empty-intset empty-intset))
- ((single multiple) (intmap-fold visit conts single multiple)))
- (intset-subtract (persistent-intset single)
- (persistent-intset multiple))))
-
-;;; Continuations whose values are simply forwarded to another and not
-;;; used in any other way may be elided via eta reduction over labels.
-;;;
-;;; There is an exception however: we must exclude strongly-connected
-;;; components (SCCs). The only kind of SCC we can build out of $values
-;;; expressions are infinite loops.
-;;;
-;;; Condition A below excludes single-node SCCs. Single-node SCCs
-;;; cannot be reduced.
-;;;
-;;; Condition B conservatively excludes edges to labels already marked
-;;; as candidates. This prevents back-edges and so breaks SCCs, and is
-;;; optimal if labels are sorted. If the labels aren't sorted it's
-;;; suboptimal but cheap.
-(define (compute-eta-reductions conts kfun)
- (let ((singly-used (compute-singly-referenced-vars conts)))
- (define (singly-used? vars)
- (match vars
- (() #t)
- ((var . vars)
- (and (intset-ref singly-used var) (singly-used? vars)))))
- (define (visit-fun kfun body eta)
- (define (visit-cont label eta)
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src ($ $values vars)))
- (intset-maybe-add! eta label
- (match (intmap-ref conts k)
- (($ $kargs)
- (and (not (eqv? label k)) ; A
- (not (intset-ref eta label)) ; B
- (singly-used? vars)))
- (_ #f))))
- (_
- eta)))
- (intset-fold visit-cont body eta))
- (persistent-intset
- (intmap-fold visit-fun
- (compute-reachable-functions conts kfun)
- empty-intset))))
-
-(define (eta-reduce conts kfun)
- (let ((label-set (compute-eta-reductions conts kfun)))
- ;; Replace any continuation to a label in LABEL-SET with the label's
- ;; continuation. The label will denote a $kargs continuation, so
- ;; only terms that can continue to $kargs need be taken into
- ;; account.
- (define (subst label)
- (if (intset-ref label-set label)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue k)) (subst k)))
- label))
- (transform-conts
- (lambda (label cont)
- (and (not (intset-ref label-set label))
- (rewrite-cont cont
- (($ $kargs names syms ($ $continue kf src ($ $branch kt exp)))
- ($kargs names syms
- ($continue (subst kf) src ($branch (subst kt) ,exp))))
- (($ $kargs names syms ($ $continue k src exp))
- ($kargs names syms
- ($continue (subst k) src ,exp)))
- (($ $kreceive ($ $arity req () rest () #f) k)
- ($kreceive req rest (subst k)))
- (($ $kclause arity body alt)
- ($kclause ,arity (subst body) alt))
- (_ ,cont))))
- conts)))
-
-(define (compute-singly-referenced-labels conts body)
- (define (add-ref label single multiple)
- (define (ref k single multiple)
- (if (intset-ref single k)
- (values single (intset-add! multiple k))
- (values (intset-add! single k) multiple)))
- (define (ref0) (values single multiple))
- (define (ref1 k) (ref k single multiple))
- (define (ref2 k k*)
- (if k*
- (let-values (((single multiple) (ref k single multiple)))
- (ref k* single multiple))
- (ref1 k)))
- (match (intmap-ref conts label)
- (($ $kreceive arity k) (ref1 k))
- (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
- (($ $ktail) (ref0))
- (($ $kclause arity kbody kalt) (ref2 kbody kalt))
- (($ $kargs names syms ($ $continue k src exp))
- (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
- (let*-values (((single multiple) (values empty-intset empty-intset))
- ((single multiple) (intset-fold add-ref body single multiple)))
- (intset-subtract (persistent-intset single)
- (persistent-intset multiple))))
-
-(define (compute-beta-reductions conts kfun)
- (define (visit-fun kfun body beta)
- (let ((single (compute-singly-referenced-labels conts body)))
- (define (visit-cont label beta)
- (match (intmap-ref conts label)
- ;; A continuation's body can be inlined in place of a $values
- ;; expression if the continuation is a $kargs. It should only
- ;; be inlined if it is used only once, and not recursively.
- (($ $kargs _ _ ($ $continue k src ($ $values)))
- (intset-maybe-add! beta label
- (and (intset-ref single k)
- (match (intmap-ref conts k)
- (($ $kargs) #t)
- (_ #f)))))
- (_
- beta)))
- (intset-fold visit-cont body beta)))
- (persistent-intset
- (intmap-fold visit-fun
- (compute-reachable-functions conts kfun)
- empty-intset)))
-
-(define (compute-beta-var-substitutions conts label-set)
- (define (add-var-substs label var-map)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue k _ ($ $values vals)))
- (match (intmap-ref conts k)
- (($ $kargs names vars)
- (fold2* (lambda (var val var-map)
- (intmap-add! var-map var val))
- vars vals var-map))))))
- (intset-fold add-var-substs label-set empty-intmap))
-
-(define (beta-reduce conts kfun)
- (let* ((label-set (compute-beta-reductions conts kfun))
- (var-map (compute-beta-var-substitutions conts label-set)))
- (define (subst var)
- (match (intmap-ref var-map var (lambda (_) #f))
- (#f var)
- (val (subst val))))
- (define (transform-exp label k src exp)
- (if (intset-ref label-set label)
- (match (intmap-ref conts k)
- (($ $kargs _ _ ($ $continue k* src* exp*))
- (transform-exp k k* src* exp*)))
- (build-term
- ($continue k src
- ,(rewrite-exp exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
- ,exp)
- (($ $call proc args)
- ($call (subst proc) ,(map subst args)))
- (($ $callk k proc args)
- ($callk k (subst proc) ,(map subst args)))
- (($ $primcall name args)
- ($primcall name ,(map subst args)))
- (($ $values args)
- ($values ,(map subst args)))
- (($ $branch kt ($ $values (var)))
- ($branch kt ($values ((subst var)))))
- (($ $branch kt ($ $primcall name args))
- ($branch kt ($primcall name ,(map subst args))))
- (($ $prompt escape? tag handler)
- ($prompt escape? (subst tag) handler)))))))
- (transform-conts
- (lambda (label cont)
- (match cont
- (($ $kargs names syms ($ $continue k src exp))
- (build-cont
- ($kargs names syms ,(transform-exp label k src exp))))
- (_ cont)))
- conts)))
-
-(define (simplify conts)
- (eta-reduce (beta-reduce conts 0) 0))
diff --git a/module/language/cps2/slot-allocation.scm
b/module/language/cps2/slot-allocation.scm
deleted file mode 100644
index 48f5a1f..0000000
--- a/module/language/cps2/slot-allocation.scm
+++ /dev/null
@@ -1,995 +0,0 @@
-;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A module to assign stack slots to variables in a CPS term.
-;;;
-;;; Code:
-
-(define-module (language cps2 slot-allocation)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (allocate-slots
- lookup-slot
- lookup-maybe-slot
- lookup-constant-value
- lookup-maybe-constant-value
- lookup-nlocals
- lookup-call-proc-slot
- lookup-parallel-moves
- lookup-dead-slot-map))
-
-(define-record-type $allocation
- (make-allocation slots constant-values call-allocs shuffles frame-sizes)
- allocation?
-
- ;; A map of VAR to slot allocation. A slot allocation is an integer,
- ;; if the variable has been assigned a slot.
- ;;
- (slots allocation-slots)
-
- ;; A map of VAR to constant value, for variables with constant values.
- ;;
- (constant-values allocation-constant-values)
-
- ;; A map of LABEL to /call allocs/, for expressions that continue to
- ;; $kreceive continuations: non-tail calls and $prompt expressions.
- ;;
- ;; A call alloc contains two pieces of information: the call's /proc
- ;; slot/ and a /dead slot map/. The proc slot indicates the slot of a
- ;; procedure in a procedure call, or where the procedure would be in a
- ;; multiple-value return.
- ;;
- ;; The dead slot map indicates, what slots should be ignored by GC
- ;; when marking the frame. A dead slot map is a bitfield, as an
- ;; integer.
- ;;
- (call-allocs allocation-call-allocs)
-
- ;; A map of LABEL to /parallel moves/. Parallel moves shuffle locals
- ;; into position for a $call, $callk, or $values, or shuffle returned
- ;; values back into place in a $kreceive.
- ;;
- ;; A set of moves is expressed as an ordered list of (SRC . DST)
- ;; moves, where SRC and DST are slots. This may involve a temporary
- ;; variable.
- ;;
- (shuffles allocation-shuffles)
-
- ;; The number of locals for a $kclause.
- ;;
- (frame-sizes allocation-frame-sizes))
-
-(define-record-type $call-alloc
- (make-call-alloc proc-slot dead-slot-map)
- call-alloc?
- (proc-slot call-alloc-proc-slot)
- (dead-slot-map call-alloc-dead-slot-map))
-
-(define (lookup-maybe-slot var allocation)
- (intmap-ref (allocation-slots allocation) var (lambda (_) #f)))
-
-(define (lookup-slot var allocation)
- (intmap-ref (allocation-slots allocation) var))
-
-(define *absent* (list 'absent))
-
-(define (lookup-constant-value var allocation)
- (let ((value (intmap-ref (allocation-constant-values allocation) var
- (lambda (_) *absent*))))
- (when (eq? value *absent*)
- (error "Variable does not have constant value" var))
- value))
-
-(define (lookup-maybe-constant-value var allocation)
- (let ((value (intmap-ref (allocation-constant-values allocation) var
- (lambda (_) *absent*))))
- (if (eq? value *absent*)
- (values #f #f)
- (values #t value))))
-
-(define (lookup-call-alloc k allocation)
- (intmap-ref (allocation-call-allocs allocation) k))
-
-(define (lookup-call-proc-slot k allocation)
- (or (call-alloc-proc-slot (lookup-call-alloc k allocation))
- (error "Call has no proc slot" k)))
-
-(define (lookup-parallel-moves k allocation)
- (intmap-ref (allocation-shuffles allocation) k))
-
-(define (lookup-dead-slot-map k allocation)
- (or (call-alloc-dead-slot-map (lookup-call-alloc k allocation))
- (error "Call has no dead slot map" k)))
-
-(define (lookup-nlocals k allocation)
- (intmap-ref (allocation-frame-sizes allocation) k))
-
-(define (intset-pop set)
- (match (intset-next set)
- (#f (values set #f))
- (i (values (intset-remove set i) i))))
-
-(define (solve-flow-equations succs in out kill gen subtract add meet)
- "Find a fixed point for flow equations for SUCCS, where IN and OUT are
-the initial conditions as intmaps with one key for every node in SUCCS.
-KILL and GEN are intmaps indicating the state that is killed or defined
-at every node, and SUBTRACT, ADD, and MEET operates on that state."
- (define (visit label in out)
- (let* ((in-1 (intmap-ref in label))
- (kill-1 (intmap-ref kill label))
- (gen-1 (intmap-ref gen label))
- (out-1 (intmap-ref out label))
- (out-1* (add (subtract in-1 kill-1) gen-1)))
- (if (eq? out-1 out-1*)
- (values empty-intset in out)
- (let ((out (intmap-replace! out label out-1*)))
- (call-with-values
- (lambda ()
- (intset-fold (lambda (succ in changed)
- (let* ((in-1 (intmap-ref in succ))
- (in-1* (meet in-1 out-1*)))
- (if (eq? in-1 in-1*)
- (values in changed)
- (values (intmap-replace! in succ in-1*)
- (intset-add changed succ)))))
- (intmap-ref succs label) in empty-intset))
- (lambda (in changed)
- (values changed in out)))))))
-
- (let run ((worklist (intmap-keys succs)) (in in) (out out))
- (call-with-values (lambda () (intset-pop worklist))
- (lambda (worklist popped)
- (if popped
- (call-with-values (lambda () (visit popped in out))
- (lambda (changed in out)
- (run (intset-union worklist changed) in out)))
- (values (persistent-intmap in)
- (persistent-intmap out)))))))
-
-(define-syntax-rule (persistent-intmap2 exp)
- (call-with-values (lambda () exp)
- (lambda (a b)
- (values (persistent-intmap a) (persistent-intmap b)))))
-
-(define (compute-defs-and-uses cps)
- "Return two LABEL->VAR... maps indicating values defined at and used
-by a label, respectively."
- (define (vars->intset vars)
- (fold (lambda (var set) (intset-add set var)) empty-intset vars))
- (persistent-intmap2
- (intmap-fold
- (lambda (label cont defs uses)
- (define (get-defs k)
- (match (intmap-ref cps k)
- (($ $kargs names vars) (vars->intset vars))
- (_ empty-intset)))
- (define (return d u)
- (values (intmap-add! defs label d)
- (intmap-add! uses label u)))
- (match cont
- (($ $kfun src meta self)
- (return (intset self) empty-intset))
- (($ $kargs _ _ ($ $continue k src exp))
- (match exp
- ((or ($ $const) ($ $closure))
- (return (get-defs k) empty-intset))
- (($ $call proc args)
- (return (get-defs k) (intset-add (vars->intset args) proc)))
- (($ $callk _ proc args)
- (return (get-defs k) (intset-add (vars->intset args) proc)))
- (($ $primcall name args)
- (return (get-defs k) (vars->intset args)))
- (($ $branch kt ($ $primcall name args))
- (return empty-intset (vars->intset args)))
- (($ $branch kt ($ $values args))
- (return empty-intset (vars->intset args)))
- (($ $values args)
- (return (get-defs k) (vars->intset args)))
- (($ $prompt escape? tag handler)
- (return empty-intset (intset tag)))))
- (($ $kclause arity body alt)
- (return (get-defs body) empty-intset))
- (($ $kreceive arity kargs)
- (return (get-defs kargs) empty-intset))
- (($ $ktail)
- (return empty-intset empty-intset))))
- cps
- empty-intmap
- empty-intmap)))
-
-(define (compute-reverse-control-flow-order preds)
- "Return a LABEL->ORDER bijection where ORDER is a contiguous set of
-integers starting from 0 and incrementing in sort order."
- ;; This is more involved than forward control flow because not all
- ;; live labels are reachable from the tail.
- (persistent-intmap
- (fold2 (lambda (component order n)
- (intset-fold (lambda (label order n)
- (values (intmap-add! order label n)
- (1+ n)))
- component order n))
- (reverse (compute-sorted-strongly-connected-components preds))
- empty-intmap 0)))
-
-(define* (add-prompt-control-flow-edges conts succs #:key complete?)
- "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
-LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
-body continuation in the prompt."
- (define (intset-filter pred set)
- (intset-fold (lambda (i set)
- (if (pred i) set (intset-remove set i)))
- set
- set))
- (define (intset-any pred set)
- (intset-fold (lambda (i res)
- (if (or res (pred i)) #t res))
- set
- #f))
- (define (visit-prompt label handler succs)
- ;; FIXME: It isn't correct to use all continuations reachable from
- ;; the prompt, because that includes continuations outside the
- ;; prompt body. This point is moot if the handler's control flow
- ;; joins with the the body, as is usually but not always the case.
- ;;
- ;; One counter-example is when the handler contifies an infinite
- ;; loop; in that case we compute a too-large prompt body. This
- ;; error is currently innocuous, but we should fix it at some point.
- ;;
- ;; The fix is to end the body at the corresponding "pop" primcall,
- ;; if any.
- (let ((body (intset-subtract (compute-function-body conts label)
- (compute-function-body conts handler))))
- (define (out-or-back-edge? label)
- ;; Most uses of visit-prompt-control-flow don't need every body
- ;; continuation, and would be happy getting called only for
- ;; continuations that postdominate the rest of the body. Unless
- ;; you pass #:complete? #t, we only invoke F on continuations
- ;; that can leave the body, or on back-edges in loops.
- ;;
- ;; You would think that looking for the final "pop" primcall
- ;; would be sufficient, but that is incorrect; it's possible for
- ;; a loop in the prompt body to be contified, and that loop need
- ;; not continue to the pop if it never terminates. The pop could
- ;; even be removed by DCE, in that case.
- (intset-any (lambda (succ)
- (or (not (intset-ref body succ))
- (<= succ label)))
- (intmap-ref succs label)))
- (intset-fold (lambda (pred succs)
- (intmap-replace succs pred handler intset-add))
- (if complete? body (intset-filter out-or-back-edge? body))
- succs)))
- (intmap-fold
- (lambda (label cont succs)
- (match cont
- (($ $kargs _ _
- ($ $continue _ _ ($ $prompt escape? tag handler)))
- (visit-prompt label handler succs))
- (_ succs)))
- conts
- succs))
-
-(define (rename-keys map old->new)
- (persistent-intmap
- (intmap-fold (lambda (k v out)
- (intmap-add! out (intmap-ref old->new k) v))
- map
- empty-intmap)))
-
-(define (rename-intset set old->new)
- (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old)))
- set empty-intset))
-
-(define (rename-graph graph old->new)
- (persistent-intmap
- (intmap-fold (lambda (pred succs out)
- (intmap-add! out
- (intmap-ref old->new pred)
- (rename-intset succs old->new)))
- graph
- empty-intmap)))
-
-(define (compute-live-variables cps defs uses)
- "Compute and return two values mapping LABEL->VAR..., where VAR... are
-the definitions that are live before and after LABEL, as intsets."
- (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps)))
- (preds (invert-graph succs))
- (old->new (compute-reverse-control-flow-order preds)))
- (call-with-values
- (lambda ()
- (let ((init (rename-keys
- (intmap-map (lambda (k v) empty-intset) preds)
- old->new)))
- (solve-flow-equations (rename-graph preds old->new)
- init init
- (rename-keys defs old->new)
- (rename-keys uses old->new)
- intset-subtract intset-union intset-union)))
- (lambda (in out)
- ;; As a reverse control-flow problem, the values flowing into a
- ;; node are actually the live values after the node executes.
- ;; Funny, innit? So we return them in the reverse order.
- (let ((new->old (invert-bijection old->new)))
- (values (rename-keys out new->old)
- (rename-keys in new->old)))))))
-
-(define (compute-needs-slot cps defs uses)
- (define (get-defs k) (intmap-ref defs k))
- (define (get-uses label) (intmap-ref uses label))
- (intmap-fold
- (lambda (label cont needs-slot)
- (intset-union
- needs-slot
- (match cont
- (($ $kargs _ _ ($ $continue k src exp))
- (let ((defs (get-defs label)))
- (define (defs+* uses)
- (intset-union defs uses))
- (define (defs+ use)
- (intset-add defs use))
- (match exp
- (($ $const)
- empty-intset)
- (($ $primcall 'free-ref (closure slot))
- (defs+ closure))
- (($ $primcall 'free-set! (closure slot value))
- (defs+* (intset closure value)))
- (($ $primcall 'cache-current-module! (mod . _))
- (defs+ mod))
- (($ $primcall 'cached-toplevel-box _)
- defs)
- (($ $primcall 'cached-module-box _)
- defs)
- (($ $primcall 'resolve (name bound?))
- (defs+ name))
- (($ $primcall 'make-vector/immediate (len init))
- (defs+ init))
- (($ $primcall 'vector-ref/immediate (v i))
- (defs+ v))
- (($ $primcall 'vector-set!/immediate (v i x))
- (defs+* (intset v x)))
- (($ $primcall 'allocate-struct/immediate (vtable nfields))
- (defs+ vtable))
- (($ $primcall 'struct-ref/immediate (s n))
- (defs+ s))
- (($ $primcall 'struct-set!/immediate (s n x))
- (defs+* (intset s x)))
- (($ $primcall 'builtin-ref (idx))
- defs)
- (_
- (defs+* (get-uses label))))))
- (($ $kreceive arity k)
- ;; Only allocate results of function calls to slots if they are
- ;; used.
- empty-intset)
- (($ $kclause arity body alternate)
- (get-defs label))
- (($ $kfun src meta self)
- (intset self))
- (($ $ktail)
- empty-intset))))
- cps
- empty-intset))
-
-(define (compute-lazy-vars cps live-in live-out defs needs-slot)
- "Compute and return a set of vars whose allocation can be delayed
-until their use is seen. These are \"lazy\" vars. A var is lazy if its
-uses are calls, it is always dead after the calls, and if the uses flow
-to the definition. A flow continues across a node iff the node kills no
-values that need slots, and defines only lazy vars. Calls also kill
-flows; there's no sense in trying to juggle a pending frame while there
-is an active call."
- (define (list->intset list)
- (persistent-intset
- (fold (lambda (i set) (intset-add! set i)) empty-intset list)))
-
- (let* ((succs (compute-successors cps))
- (gens (intmap-map
- (lambda (label cont)
- (match cont
- (($ $kargs _ _ ($ $continue _ _ ($ $call proc args)))
- (intset-subtract (intset-add (list->intset args) proc)
- (intmap-ref live-out label)))
- (($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args)))
- (intset-subtract (intset-add (list->intset args) proc)
- (intmap-ref live-out label)))
- (_ #f)))
- cps))
- (kills (intmap-map
- (lambda (label in)
- (let* ((out (intmap-ref live-out label))
- (killed (intset-subtract in out))
- (killed-slots (intset-intersect killed needs-slot)))
- (and (eq? killed-slots empty-intset)
- ;; Kill output variables that need slots.
- (intset-intersect (intmap-ref defs label)
- needs-slot))))
- live-in))
- (preds (invert-graph succs))
- (old->new (compute-reverse-control-flow-order preds)))
- (define (subtract lazy kill)
- (cond
- ((eq? lazy empty-intset)
- lazy)
- ((not kill)
- empty-intset)
- ((and lazy (eq? empty-intset (intset-subtract kill lazy)))
- (intset-subtract lazy kill))
- (else
- empty-intset)))
- (define (add live gen) (or gen live))
- (define (meet in out)
- ;; Initial in is #f.
- (if in (intset-intersect in out) out))
- (call-with-values
- (lambda ()
- (let ((succs (rename-graph preds old->new))
- (in (rename-keys (intmap-map (lambda (k v) #f) preds)
old->new))
- (out (rename-keys (intmap-map (lambda (k v) #f) preds)
old->new))
- ;(out (rename-keys gens old->new))
- (kills (rename-keys kills old->new))
- (gens (rename-keys gens old->new)))
- (solve-flow-equations succs in out kills gens subtract add meet)))
- (lambda (in out)
- ;; A variable is lazy if its uses reach its definition.
- (intmap-fold (lambda (label out lazy)
- (match (intmap-ref cps label)
- (($ $kargs names vars)
- (let ((defs (list->intset vars)))
- (intset-union lazy (intset-intersect out defs))))
- (_ lazy)))
- (rename-keys out (invert-bijection old->new))
- empty-intset)))))
-
-(define (find-first-zero n)
- ;; Naive implementation.
- (let lp ((slot 0))
- (if (logbit? slot n)
- (lp (1+ slot))
- slot)))
-
-(define (find-first-trailing-zero n)
- (let lp ((slot (let lp ((count 2))
- (if (< n (ash 1 (1- count)))
- count
- ;; Grow upper bound slower than factor 2 to avoid
- ;; needless bignum allocation on 32-bit systems
- ;; when there are more than 16 locals.
- (lp (+ count (ash count -1)))))))
- (if (or (zero? slot) (logbit? (1- slot) n))
- slot
- (lp (1- slot)))))
-
-(define (integers from count)
- (if (zero? count)
- '()
- (cons from (integers (1+ from) (1- count)))))
-
-(define (solve-parallel-move src dst tmp)
- "Solve the parallel move problem between src and dst slot lists, which
-are comparable with eqv?. A tmp slot may be used."
-
- ;; This algorithm is taken from: "Tilting at windmills with Coq:
- ;; formal verification of a compilation algorithm for parallel moves"
- ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
- ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
-
- (define (split-move moves reg)
- (let loop ((revhead '()) (tail moves))
- (match tail
- (((and s+d (s . d)) . rest)
- (if (eqv? s reg)
- (cons d (append-reverse revhead rest))
- (loop (cons s+d revhead) rest)))
- (_ #f))))
-
- (define (replace-last-source reg moves)
- (match moves
- ((moves ... (s . d))
- (append moves (list (cons reg d))))))
-
- (let loop ((to-move (map cons src dst))
- (being-moved '())
- (moved '())
- (last-source #f))
- ;; 'last-source' should always be equivalent to:
- ;; (and (pair? being-moved) (car (last being-moved)))
- (match being-moved
- (() (match to-move
- (() (reverse moved))
- (((and s+d (s . d)) . t1)
- (if (or (eqv? s d) ; idempotent
- (not s)) ; src is a constant and can be loaded directly
- (loop t1 '() moved #f)
- (loop t1 (list s+d) moved s)))))
- (((and s+d (s . d)) . b)
- (match (split-move to-move d)
- ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
- (#f (match b
- (() (loop to-move '() (cons s+d moved) #f))
- (_ (if (eqv? d last-source)
- (loop to-move
- (replace-last-source tmp b)
- (cons s+d (acons d tmp moved))
- tmp)
- (loop to-move b (cons s+d moved) last-source))))))))))
-
-(define (compute-shuffles cps slots call-allocs live-in)
- (define (add-live-slot slot live-slots)
- (logior live-slots (ash 1 slot)))
-
- (define (get-cont label)
- (intmap-ref cps label))
-
- (define (get-slot var)
- (intmap-ref slots var (lambda (_) #f)))
-
- (define (get-slots vars)
- (let lp ((vars vars))
- (match vars
- ((var . vars) (cons (get-slot var) (lp vars)))
- (_ '()))))
-
- (define (get-proc-slot label)
- (call-alloc-proc-slot (intmap-ref call-allocs label)))
-
- (define (compute-live-slots label)
- (intset-fold (lambda (var live)
- (match (get-slot var)
- (#f live)
- (slot (add-live-slot slot live))))
- (intmap-ref live-in label)
- 0))
-
- ;; Although some parallel moves may proceed without a temporary slot,
- ;; in general one is needed. That temporary slot must not be part of
- ;; the source or destination sets, and that slot should not correspond
- ;; to a live variable. Usually the source and destination sets are a
- ;; subset of the union of the live sets before and after the move.
- ;; However for stack slots that don't have names -- those slots that
- ;; correspond to function arguments or to function return values -- it
- ;; could be that they are out of the computed live set. In that case
- ;; they need to be adjoined to the live set, used when choosing a
- ;; temporary slot.
- ;;
- ;; Note that although we reserve slots 253-255 for shuffling operands
- ;; that address less than the full 24-bit range of locals, that
- ;; reservation doesn't apply here, because this temporary itself is
- ;; used while doing parallel assignment via "mov", and "mov" does not
- ;; need shuffling.
- (define (compute-tmp-slot live stack-slots)
- (find-first-zero (fold add-live-slot live stack-slots)))
-
- (define (parallel-move src-slots dst-slots tmp-slot)
- (solve-parallel-move src-slots dst-slots tmp-slot))
-
- (define (compute-receive-shuffles label proc-slot)
- (match (get-cont label)
- (($ $kreceive arity kargs)
- (let* ((results (match (get-cont kargs)
- (($ $kargs names vars) vars)))
- (value-slots (integers (1+ proc-slot) (length results)))
- (result-slots (get-slots results))
- ;; Filter out unused results.
- (value-slots (filter-map (lambda (val result) (and result val))
- value-slots result-slots))
- (result-slots (filter (lambda (x) x) result-slots))
- (live (compute-live-slots kargs)))
- (parallel-move value-slots
- result-slots
- (compute-tmp-slot live value-slots))))))
-
- (define (add-call-shuffles label k args shuffles)
- (match (get-cont k)
- (($ $ktail)
- (let* ((live (compute-live-slots label))
- (tail-slots (integers 0 (length args)))
- (moves (parallel-move (get-slots args)
- tail-slots
- (compute-tmp-slot live tail-slots))))
- (intmap-add! shuffles label moves)))
- (($ $kreceive)
- (let* ((live (compute-live-slots label))
- (proc-slot (get-proc-slot label))
- (call-slots (integers proc-slot (length args)))
- (arg-moves (parallel-move (get-slots args)
- call-slots
- (compute-tmp-slot live call-slots))))
- (intmap-add! (intmap-add! shuffles label arg-moves)
- k (compute-receive-shuffles k proc-slot))))))
-
- (define (add-values-shuffles label k args shuffles)
- (match (get-cont k)
- (($ $ktail)
- (let* ((live (compute-live-slots label))
- (src-slots (get-slots args))
- (dst-slots (integers 1 (length args)))
- (moves (parallel-move src-slots dst-slots
- (compute-tmp-slot live dst-slots))))
- (intmap-add! shuffles label moves)))
- (($ $kargs _ dst-vars)
- (let* ((live (logior (compute-live-slots label)
- (compute-live-slots k)))
- (src-slots (get-slots args))
- (dst-slots (get-slots dst-vars))
- (moves (parallel-move src-slots dst-slots
- (compute-tmp-slot live '()))))
- (intmap-add! shuffles label moves)))))
-
- (define (add-prompt-shuffles label k handler shuffles)
- (intmap-add! shuffles handler
- (compute-receive-shuffles handler (get-proc-slot label))))
-
- (define (compute-shuffles label cont shuffles)
- (match cont
- (($ $kargs names vars ($ $continue k src exp))
- (match exp
- (($ $call proc args)
- (add-call-shuffles label k (cons proc args) shuffles))
- (($ $callk _ proc args)
- (add-call-shuffles label k (cons proc args) shuffles))
- (($ $values args)
- (add-values-shuffles label k args shuffles))
- (($ $prompt escape? tag handler)
- (add-prompt-shuffles label k handler shuffles))
- (_ shuffles)))
- (_ shuffles)))
-
- (persistent-intmap
- (intmap-fold compute-shuffles cps empty-intmap)))
-
-(define (compute-frame-sizes cps slots call-allocs shuffles)
- ;; Minimum frame has one slot: the closure.
- (define minimum-frame-size 1)
- (define (get-shuffles label)
- (intmap-ref shuffles label))
- (define (get-proc-slot label)
- (match (intmap-ref call-allocs label (lambda (_) #f))
- (#f 0) ;; Tail call.
- (($ $call-alloc proc-slot) proc-slot)))
- (define (max-size var size)
- (match (intmap-ref slots var (lambda (_) #f))
- (#f size)
- (slot (max size (1+ slot)))))
- (define (max-size* vars size)
- (fold max-size size vars))
- (define (shuffle-size moves size)
- (match moves
- (() size)
- (((src . dst) . moves)
- (shuffle-size moves (max size (1+ src) (1+ dst))))))
- (define (call-size label nargs size)
- (shuffle-size (get-shuffles label)
- (max (+ (get-proc-slot label) nargs) size)))
- (define (measure-cont label cont frame-sizes clause size)
- (match cont
- (($ $kfun)
- (values #f #f #f))
- (($ $kclause)
- (let ((frame-sizes (if clause
- (intmap-add! frame-sizes clause size)
- empty-intmap)))
- (values frame-sizes label minimum-frame-size)))
- (($ $kargs names vars ($ $continue k src exp))
- (values frame-sizes clause
- (let ((size (max-size* vars size)))
- (match exp
- (($ $call proc args)
- (call-size label (1+ (length args)) size))
- (($ $callk _ proc args)
- (call-size label (1+ (length args)) size))
- (($ $values args)
- (shuffle-size (get-shuffles label) size))
- (_ size)))))
- (($ $kreceive)
- (values frame-sizes clause
- (shuffle-size (get-shuffles label) size)))
- (($ $ktail)
- (values (intmap-add! frame-sizes clause size) #f #f))))
-
- (persistent-intmap (intmap-fold measure-cont cps #f #f #f)))
-
-(define (allocate-args cps)
- (intmap-fold (lambda (label cont slots)
- (match cont
- (($ $kfun src meta self)
- (intmap-add! slots self 0))
- (($ $kclause arity body alt)
- (match (intmap-ref cps body)
- (($ $kargs names vars)
- (let lp ((vars vars) (slots slots) (n 1))
- (match vars
- (() slots)
- ((var . vars)
- (let ((n (if (<= 253 n 255) 256 n)))
- (lp vars
- (intmap-add! slots var n)
- (1+ n)))))))))
- (_ slots)))
- cps empty-intmap))
-
-(define-inlinable (add-live-slot slot live-slots)
- (logior live-slots (ash 1 slot)))
-
-(define-inlinable (kill-dead-slot slot live-slots)
- (logand live-slots (lognot (ash 1 slot))))
-
-(define-inlinable (compute-slot live-slots hint)
- ;; Slots 253-255 are reserved for shuffling; see comments in
- ;; assembler.scm.
- (if (and hint (not (logbit? hint live-slots))
- (or (< hint 253) (> hint 255)))
- hint
- (let ((slot (find-first-zero live-slots)))
- (if (or (< slot 253) (> slot 255))
- slot
- (+ 256 (find-first-zero (ash live-slots -256)))))))
-
-(define (allocate-lazy-vars cps slots call-allocs live-in lazy)
- (define (compute-live-slots slots label)
- (intset-fold (lambda (var live)
- (match (intmap-ref slots var (lambda (_) #f))
- (#f live)
- (slot (add-live-slot slot live))))
- (intmap-ref live-in label)
- 0))
-
- (define (allocate var hint slots live)
- (match (and hint (intmap-ref slots var (lambda (_) #f)))
- (#f (if (intset-ref lazy var)
- (let ((slot (compute-slot live hint)))
- (values (intmap-add! slots var slot)
- (add-live-slot slot live)))
- (values slots live)))
- (slot (values slots (add-live-slot slot live)))))
-
- (define (allocate* vars hints slots live)
- (match (vector vars hints)
- (#(() ()) slots)
- (#((var . vars) (hint . hints))
- (let-values (((slots live) (allocate var hint slots live)))
- (allocate* vars hints slots live)))))
-
- (define (get-proc-slot label)
- (match (intmap-ref call-allocs label (lambda (_) #f))
- (#f 0)
- (call (call-alloc-proc-slot call))))
-
- (define (allocate-call label args slots)
- (allocate* args (integers (get-proc-slot label) (length args))
- slots (compute-live-slots slots label)))
-
- (define (allocate-values label k args slots)
- (match (intmap-ref cps k)
- (($ $ktail)
- (allocate* args (integers 1 (length args))
- slots (compute-live-slots slots label)))
- (($ $kargs names vars)
- (allocate* args
- (map (cut intmap-ref slots <> (lambda (_) #f)) vars)
- slots (compute-live-slots slots label)))))
-
- (define (allocate-lazy label cont slots)
- (match cont
- (($ $kargs names vars ($ $continue k src exp))
- (match exp
- (($ $call proc args)
- (allocate-call label (cons proc args) slots))
- (($ $callk _ proc args)
- (allocate-call label (cons proc args) slots))
- (($ $values args)
- (allocate-values label k args slots))
- (_ slots)))
- (_
- slots)))
-
- ;; Sweep right to left to visit uses before definitions.
- (persistent-intmap
- (intmap-fold-right allocate-lazy cps slots)))
-
-(define (allocate-slots cps)
- (let*-values (((defs uses) (compute-defs-and-uses cps))
- ((live-in live-out) (compute-live-variables cps defs uses))
- ((constants) (compute-constant-values cps))
- ((needs-slot) (compute-needs-slot cps defs uses))
- ((lazy) (compute-lazy-vars cps live-in live-out defs
- needs-slot)))
-
- (define (empty-live-slots)
- #b0)
-
- (define (compute-call-proc-slot live-slots)
- (+ 2 (find-first-trailing-zero live-slots)))
-
- (define (compute-prompt-handler-proc-slot live-slots)
- (if (zero? live-slots)
- 0
- (1- (find-first-trailing-zero live-slots))))
-
- (define (get-cont label)
- (intmap-ref cps label))
-
- (define (get-slot slots var)
- (intmap-ref slots var (lambda (_) #f)))
-
- (define (get-slots slots vars)
- (let lp ((vars vars))
- (match vars
- ((var . vars) (cons (get-slot slots var) (lp vars)))
- (_ '()))))
-
- (define (compute-live-slots* slots label live-vars)
- (intset-fold (lambda (var live)
- (match (get-slot slots var)
- (#f live)
- (slot (add-live-slot slot live))))
- (intmap-ref live-vars label)
- 0))
-
- (define (compute-live-in-slots slots label)
- (compute-live-slots* slots label live-in))
-
- (define (compute-live-out-slots slots label)
- (compute-live-slots* slots label live-out))
-
- (define (allocate var hint slots live)
- (cond
- ((not (intset-ref needs-slot var))
- (values slots live))
- ((get-slot slots var)
- => (lambda (slot)
- (values slots (add-live-slot slot live))))
- ((and (not hint) (intset-ref lazy var))
- (values slots live))
- (else
- (let ((slot (compute-slot live hint)))
- (values (intmap-add! slots var slot)
- (add-live-slot slot live))))))
-
- (define (allocate* vars hints slots live)
- (match (vector vars hints)
- (#(() ()) (values slots live))
- (#((var . vars) (hint . hints))
- (call-with-values (lambda () (allocate var hint slots live))
- (lambda (slots live)
- (allocate* vars hints slots live))))))
-
- (define (allocate-defs label vars slots)
- (let ((live (compute-live-in-slots slots label))
- (live-vars (intmap-ref live-in label)))
- (let lp ((vars vars) (slots slots) (live live))
- (match vars
- (() (values slots live))
- ((var . vars)
- (call-with-values (lambda () (allocate var #f slots live))
- (lambda (slots live)
- (lp vars slots
- (let ((slot (get-slot slots var)))
- (if (and slot (not (intset-ref live-vars var)))
- (kill-dead-slot slot live)
- live))))))))))
-
- ;; PRE-LIVE are the live slots coming into the term. POST-LIVE
- ;; is the subset of PRE-LIVE that is still live after the term
- ;; uses its inputs.
- (define (allocate-call label k args slots call-allocs pre-live)
- (match (get-cont k)
- (($ $ktail)
- (let ((tail-slots (integers 0 (length args))))
- (values (allocate* args tail-slots slots pre-live)
- call-allocs)))
- (($ $kreceive arity kargs)
- (let*-values
- (((post-live) (compute-live-out-slots slots label))
- ((proc-slot) (compute-call-proc-slot post-live))
- ((call-slots) (integers proc-slot (length args)))
- ((slots pre-live) (allocate* args call-slots slots pre-live))
- ;; Allow the first result to be hinted by its use, but
- ;; hint the remaining results to stay in place. This
- ;; strikes a balance between avoiding shuffling,
- ;; especially for unused extra values, and avoiding frame
- ;; size growth due to sparse locals.
- ((slots result-live)
- (match (get-cont kargs)
- (($ $kargs () ())
- (values slots post-live))
- (($ $kargs (_ . _) (_ . results))
- (let ((result-slots (integers (+ proc-slot 2)
- (length results))))
- (allocate* results result-slots slots post-live)))))
- ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
- (lognot post-live)))
- ((call) (make-call-alloc proc-slot dead-slot-map)))
- (values slots
- (intmap-add! call-allocs label call))))))
-
- (define (allocate-values label k args slots call-allocs)
- (match (get-cont k)
- (($ $ktail)
- (values slots call-allocs))
- (($ $kargs (_) (dst))
- ;; When there is only one value in play, we allow the dst to be
- ;; hinted (see compute-lazy-vars). If the src doesn't have a
- ;; slot, then the actual slot for the dst would end up being
- ;; decided by the call that args it. Because we don't know the
- ;; slot, we can't really compute the parallel moves in that
- ;; case, so just bail and rely on the bytecode emitter to
- ;; handle the one-value case specially.
- (match args
- ((src)
- (let ((post-live (compute-live-out-slots slots label)))
- (values (allocate dst (get-slot slots src) slots post-live)
- call-allocs)))))
- (($ $kargs _ dst-vars)
- (let ((src-slots (get-slots slots args))
- (post-live (compute-live-out-slots slots label)))
- (values (allocate* dst-vars src-slots slots post-live)
- call-allocs)))))
-
- (define (allocate-prompt label k handler slots call-allocs)
- (match (get-cont handler)
- (($ $kreceive arity kargs)
- (let*-values
- (((handler-live) (compute-live-in-slots slots handler))
- ((proc-slot) (compute-prompt-handler-proc-slot handler-live))
- ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
- (lognot handler-live)))
- ((result-vars) (match (get-cont kargs)
- (($ $kargs names vars) vars)))
- ((value-slots) (integers (1+ proc-slot) (length result-vars)))
- ((slots result-live) (allocate* result-vars value-slots
- slots handler-live)))
- (values slots
- (intmap-add! call-allocs label
- (make-call-alloc proc-slot dead-slot-map)))))))
-
- (define (allocate-cont label cont slots call-allocs)
- (match cont
- (($ $kargs names vars ($ $continue k src exp))
- (let-values (((slots live) (allocate-defs label vars slots)))
- (match exp
- (($ $call proc args)
- (allocate-call label k (cons proc args) slots call-allocs live))
- (($ $callk _ proc args)
- (allocate-call label k (cons proc args) slots call-allocs live))
- (($ $values args)
- (allocate-values label k args slots call-allocs))
- (($ $prompt escape? tag handler)
- (allocate-prompt label k handler slots call-allocs))
- (_
- (values slots call-allocs)))))
- (_
- (values slots call-allocs))))
-
- (call-with-values (lambda ()
- (let ((slots (allocate-args cps)))
- (intmap-fold allocate-cont cps slots empty-intmap)))
- (lambda (slots calls)
- (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy))
- (shuffles (compute-shuffles cps slots calls live-in))
- (frame-sizes (compute-frame-sizes cps slots calls shuffles)))
- (make-allocation slots constants calls shuffles frame-sizes))))))
diff --git a/module/language/cps2/spec.scm b/module/language/cps2/spec.scm
deleted file mode 100644
index ac8f064..0000000
--- a/module/language/cps2/spec.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 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 published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Code:
-
-(define-module (language cps2 spec)
- #:use-module (system base language)
- #:use-module (language cps2)
- #:use-module (language cps2 compile-bytecode)
- #:export (cps2))
-
-(define* (write-cps exp #:optional (port (current-output-port)))
- (write (unparse-cps exp) port))
-
-(define-language cps2
- #:title "CPS2 Intermediate Language"
- #:reader (lambda (port env) (read port))
- #:printer write-cps
- #:parser parse-cps
- #:compilers `((bytecode . ,compile-bytecode))
- #:for-humans? #f
- )
diff --git a/module/language/cps2/specialize-primcalls.scm
b/module/language/cps2/specialize-primcalls.scm
deleted file mode 100644
index 00d2149..0000000
--- a/module/language/cps2/specialize-primcalls.scm
+++ /dev/null
@@ -1,59 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Some bytecode operations can encode an immediate as an operand.
-;;; This pass tranforms generic primcalls to these specialized
-;;; primcalls, if possible.
-;;;
-;;; Code:
-
-(define-module (language cps2 specialize-primcalls)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:export (specialize-primcalls))
-
-(define (specialize-primcalls conts)
- (let ((constants (compute-constant-values conts)))
- (define (immediate-u8? var)
- (let ((val (intmap-ref constants var (lambda (_) #f))))
- (and (exact-integer? val) (<= 0 val 255))))
- (define (specialize-primcall name args)
- (match (cons name args)
- (('make-vector (? immediate-u8? n) init) 'make-vector/immediate)
- (('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate)
- (('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate)
- (('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate)
- (('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate)
- (('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate)
- (_ #f)))
- (intmap-map
- (lambda (label cont)
- (match cont
- (($ $kargs names vars ($ $continue k src ($ $primcall name args)))
- (let ((name* (specialize-primcall name args)))
- (if name*
- (build-cont
- ($kargs names vars
- ($continue k src ($primcall name* args))))
- cont)))
- (_ cont)))
- conts)))
diff --git a/module/language/cps2/split-rec.scm
b/module/language/cps2/split-rec.scm
deleted file mode 100644
index aeb1c63..0000000
--- a/module/language/cps2/split-rec.scm
+++ /dev/null
@@ -1,174 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Split functions bound in $rec expressions into strongly-connected
-;;; components. The result will be that each $rec binds a
-;;; strongly-connected component of mutually recursive functions.
-;;;
-;;; Code:
-
-(define-module (language cps2 split-rec)
- #:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 with-cps)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:export (split-rec))
-
-(define (compute-free-vars conts kfun)
- "Compute a FUN-LABEL->FREE-VAR... map describing all free variable
-references."
- (define (add-def var defs) (intset-add! defs var))
- (define (add-defs vars defs)
- (match vars
- (() defs)
- ((var . vars) (add-defs vars (add-def var defs)))))
- (define (add-use var uses) (intset-add! uses var))
- (define (add-uses vars uses)
- (match vars
- (() uses)
- ((var . vars) (add-uses vars (add-use var uses)))))
- (define (visit-nested-funs body)
- (intset-fold
- (lambda (label out)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue _ _
- ($ $fun kfun)))
- (intmap-union out (visit-fun kfun)))
- (($ $kargs _ _ ($ $continue _ _
- ($ $rec _ _ (($ $fun kfun) ...))))
- (fold (lambda (kfun out)
- (intmap-union out (visit-fun kfun)))
- out kfun))
- (_ out)))
- body
- empty-intmap))
- (define (visit-fun kfun)
- (let* ((body (compute-function-body conts kfun))
- (free (visit-nested-funs body)))
- (call-with-values
- (lambda ()
- (intset-fold
- (lambda (label defs uses)
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (values
- (add-defs vars defs)
- (match exp
- ((or ($ $const) ($ $prim)) uses)
- (($ $fun kfun)
- (intset-union (persistent-intset uses)
- (intmap-ref free kfun)))
- (($ $rec names vars (($ $fun kfun) ...))
- (fold (lambda (kfun uses)
- (intset-union (persistent-intset uses)
- (intmap-ref free kfun)))
- uses kfun))
- (($ $values args)
- (add-uses args uses))
- (($ $call proc args)
- (add-use proc (add-uses args uses)))
- (($ $branch kt ($ $values (arg)))
- (add-use arg uses))
- (($ $branch kt ($ $primcall name args))
- (add-uses args uses))
- (($ $primcall name args)
- (add-uses args uses))
- (($ $prompt escape? tag handler)
- (add-use tag uses)))))
- (($ $kfun src meta self)
- (values (add-def self defs) uses))
- (_ (values defs uses))))
- body empty-intset empty-intset))
- (lambda (defs uses)
- (intmap-add free kfun (intset-subtract
- (persistent-intset uses)
- (persistent-intset defs)))))))
- (visit-fun kfun))
-
-(define (compute-split fns free-vars)
- (define (get-free kfun)
- ;; It's possible for a fun to have been skipped by
- ;; compute-free-vars, if the fun isn't reachable. Fall back to
- ;; empty-intset for the fun's free vars, in that case.
- (intmap-ref free-vars kfun (lambda (_) empty-intset)))
- (let* ((vars (intmap-keys fns))
- (edges (intmap-map
- (lambda (var kfun)
- (intset-intersect (get-free kfun) vars))
- fns)))
- (compute-sorted-strongly-connected-components edges)))
-
-(define (intmap-acons k v map)
- (intmap-add map k v))
-
-(define (split-rec conts)
- (let ((free (compute-free-vars conts 0)))
- (with-fresh-name-state conts
- (persistent-intmap
- (intmap-fold
- (lambda (label cont out)
- (match cont
- (($ $kargs cont-names cont-vars
- ($ $continue k src ($ $rec names vars (($ $fun kfuns) ...))))
- (let ((fns (fold intmap-acons empty-intmap vars kfuns))
- (fn-names (fold intmap-acons empty-intmap vars names)))
- (match (compute-split fns free)
- (()
- ;; Remove trivial $rec.
- (with-cps out
- (setk label ($kargs cont-names cont-vars
- ($continue k src ($values ()))))))
- ((_)
- ;; Bound functions already form a strongly-connected
- ;; component.
- out)
- (components
- ;; Multiple components. Split them into separate $rec
- ;; expressions.
- (define (build-body out components)
- (match components
- (()
- (match (intmap-ref out k)
- (($ $kargs names vars term)
- (with-cps (intmap-remove out k)
- term))))
- ((vars . components)
- (match (intset-fold
- (lambda (var out)
- (let ((name (intmap-ref fn-names var))
- (fun (build-exp
- ($fun (intmap-ref fns var)))))
- (cons (list name var fun) out)))
- vars '())
- (((name var fun) ...)
- (with-cps out
- (let$ body (build-body components))
- (letk kbody ($kargs name var ,body))
- (build-term
- ($continue kbody src ($rec name var fun)))))))))
- (with-cps out
- (let$ body (build-body components))
- (setk label ($kargs cont-names cont-vars ,body)))))))
- (_ out)))
- conts
- conts)))))
diff --git a/module/language/cps2/type-fold.scm
b/module/language/cps2/type-fold.scm
deleted file mode 100644
index d1bc1aa..0000000
--- a/module/language/cps2/type-fold.scm
+++ /dev/null
@@ -1,425 +0,0 @@
-;;; Abstract constant folding on CPS
-;;; 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
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; This pass uses the abstract interpretation provided by type analysis
-;;; to fold constant values and type predicates. It is most profitably
-;;; run after CSE, to take advantage of scalar replacement.
-;;;
-;;; Code:
-
-(define-module (language cps2 type-fold)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 renumber)
- #:use-module (language cps2 types)
- #:use-module (language cps2 with-cps)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:use-module (system base target)
- #:export (type-fold))
-
-
-
-
-;; Branch folders.
-
-(define &scalar-types
- (logior &exact-integer &flonum &char &unspecified &false &true &nil &null))
-
-(define *branch-folders* (make-hash-table))
-
-(define-syntax-rule (define-branch-folder name f)
- (hashq-set! *branch-folders* 'name f))
-
-(define-syntax-rule (define-branch-folder-alias to from)
- (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
-
-(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
- (define-branch-folder name (lambda (arg min max) body ...)))
-
-(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
- arg1 min1 max1)
- body ...)
- (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body
...)))
-
-(define-syntax-rule (define-unary-type-predicate-folder name &type)
- (define-unary-branch-folder (name type min max)
- (let ((type* (logand type &type)))
- (cond
- ((zero? type*) (values #t #f))
- ((eqv? type type*) (values #t #t))
- (else (values #f #f))))))
-
-;; All the cases that are in compile-bytecode.
-(define-unary-type-predicate-folder pair? &pair)
-(define-unary-type-predicate-folder null? &null)
-(define-unary-type-predicate-folder nil? &nil)
-(define-unary-type-predicate-folder symbol? &symbol)
-(define-unary-type-predicate-folder variable? &box)
-(define-unary-type-predicate-folder vector? &vector)
-(define-unary-type-predicate-folder struct? &struct)
-(define-unary-type-predicate-folder string? &string)
-(define-unary-type-predicate-folder number? &number)
-(define-unary-type-predicate-folder char? &char)
-
-(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
- (cond
- ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
- (values #t #f))
- ((and (eqv? type0 type1)
- (eqv? min0 min1 max0 max1)
- (zero? (logand type0 (1- type0)))
- (not (zero? (logand type0 &scalar-types))))
- (values #t #t))
- (else
- (values #f #f))))
-(define-branch-folder-alias eqv? eq?)
-(define-branch-folder-alias equal? eq?)
-
-(define (compare-ranges type0 min0 max0 type1 min1 max1)
- (and (zero? (logand (logior type0 type1) (lognot &real)))
- (cond ((< max0 min1) '<)
- ((> min0 max1) '>)
- ((= min0 max0 min1 max1) '=)
- ((<= max0 min1) '<=)
- ((>= min0 max1) '>=)
- (else #f))))
-
-(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1)
- (case (compare-ranges type0 min0 max0 type1 min1 max1)
- ((<) (values #t #t))
- ((= >= >) (values #t #f))
- (else (values #f #f))))
-
-(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
- (case (compare-ranges type0 min0 max0 type1 min1 max1)
- ((< <= =) (values #t #t))
- ((>) (values #t #f))
- (else (values #f #f))))
-
-(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
- (case (compare-ranges type0 min0 max0 type1 min1 max1)
- ((=) (values #t #t))
- ((< >) (values #t #f))
- (else (values #f #f))))
-
-(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
- (case (compare-ranges type0 min0 max0 type1 min1 max1)
- ((> >= =) (values #t #t))
- ((<) (values #t #f))
- (else (values #f #f))))
-
-(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
- (case (compare-ranges type0 min0 max0 type1 min1 max1)
- ((>) (values #t #t))
- ((= <= <) (values #t #f))
- (else (values #f #f))))
-
-(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
- (define (logand-min a b)
- (if (< a b 0)
- (min a b)
- 0))
- (define (logand-max a b)
- (if (< a b 0)
- 0
- (max a b)))
- (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer))
- (values #t (logtest min0 min1))
- (values #f #f)))
-
-
-
-
-;; Strength reduction.
-
-(define *primcall-reducers* (make-hash-table))
-
-(define-syntax-rule (define-primcall-reducer name f)
- (hashq-set! *primcall-reducers* 'name f))
-
-(define-syntax-rule (define-unary-primcall-reducer (name cps k src
- arg type min max)
- body ...)
- (define-primcall-reducer name
- (lambda (cps k src arg type min max)
- body ...)))
-
-(define-syntax-rule (define-binary-primcall-reducer (name cps k src
- arg0 type0 min0 max0
- arg1 type1 min1 max1)
- body ...)
- (define-primcall-reducer name
- (lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1)
- body ...)))
-
-(define-binary-primcall-reducer (mul cps k src
- arg0 type0 min0 max0
- arg1 type1 min1 max1)
- (define (fail) (with-cps cps #f))
- (define (negate arg)
- (with-cps cps
- ($ (with-cps-constants ((zero 0))
- (build-term
- ($continue k src ($primcall 'sub (zero arg))))))))
- (define (zero)
- (with-cps cps
- (build-term ($continue k src ($const 0)))))
- (define (identity arg)
- (with-cps cps
- (build-term ($continue k src ($values (arg))))))
- (define (double arg)
- (with-cps cps
- (build-term ($continue k src ($primcall 'add (arg arg))))))
- (define (power-of-two constant arg)
- (let ((n (let lp ((bits 0) (constant constant))
- (if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
- (with-cps cps
- ($ (with-cps-constants ((bits n))
- (build-term ($continue k src ($primcall 'ash (arg bits)))))))))
- (define (mul/constant constant constant-type arg arg-type)
- (cond
- ((not (or (= constant-type &exact-integer) (= constant-type arg-type)))
- (fail))
- ((eqv? constant -1)
- ;; (* arg -1) -> (- 0 arg)
- (negate arg))
- ((eqv? constant 0)
- ;; (* arg 0) -> 0 if arg is not a flonum or complex
- (and (= constant-type &exact-integer)
- (zero? (logand arg-type
- (lognot (logior &flonum &complex))))
- (zero)))
- ((eqv? constant 1)
- ;; (* arg 1) -> arg
- (identity arg))
- ((eqv? constant 2)
- ;; (* arg 2) -> (+ arg arg)
- (double arg))
- ((and (= constant-type arg-type &exact-integer)
- (positive? constant)
- (zero? (logand constant (1- constant))))
- ;; (* arg power-of-2) -> (ash arg (log2 power-of-2
- (power-of-two constant arg))
- (else
- (fail))))
- (cond
- ((logtest (logior type0 type1) (lognot &number)) (fail))
- ((= min0 max0) (mul/constant min0 type0 arg1 type1))
- ((= min1 max1) (mul/constant min1 type1 arg0 type0))
- (else (fail))))
-
-(define-binary-primcall-reducer (logbit? cps k src
- arg0 type0 min0 max0
- arg1 type1 min1 max1)
- (define (convert-to-logtest cps kbool)
- (define (compute-mask cps kmask src)
- (if (eq? min0 max0)
- (with-cps cps
- (build-term
- ($continue kmask src ($const (ash 1 min0)))))
- (with-cps cps
- ($ (with-cps-constants ((one 1))
- (build-term
- ($continue kmask src ($primcall 'ash (one arg0)))))))))
- (with-cps cps
- (letv mask)
- (letk kt ($kargs () ()
- ($continue kbool src ($const #t))))
- (letk kf ($kargs () ()
- ($continue kbool src ($const #f))))
- (letk kmask ($kargs (#f) (mask)
- ($continue kf src
- ($branch kt ($primcall 'logtest (mask arg1))))))
- ($ (compute-mask kmask src))))
- ;; Hairiness because we are converting from a primcall with unknown
- ;; arity to a branching primcall.
- (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
- (if (and (= type0 &exact-integer)
- (<= 0 min0 positive-fixnum-bits)
- (<= 0 max0 positive-fixnum-bits))
- (match (intmap-ref cps k)
- (($ $kreceive arity kargs)
- (match arity
- (($ $arity (_) () (not #f) () #f)
- (with-cps cps
- (letv bool)
- (let$ body (with-cps-constants ((nil '()))
- (build-term
- ($continue kargs src ($values (bool nil))))))
- (letk kbool ($kargs (#f) (bool) ,body))
- ($ (convert-to-logtest kbool))))
- (_
- (with-cps cps
- (letv bool)
- (letk kbool ($kargs (#f) (bool)
- ($continue k src ($primcall 'values (bool)))))
- ($ (convert-to-logtest kbool))))))
- (($ $ktail)
- (with-cps cps
- (letv bool)
- (letk kbool ($kargs (#f) (bool)
- ($continue k src ($primcall 'return (bool)))))
- ($ (convert-to-logtest kbool)))))
- (with-cps cps #f))))
-
-
-
-
-;;
-
-(define (local-type-fold start end cps)
- (define (scalar-value type val)
- (cond
- ((eqv? type &exact-integer) val)
- ((eqv? type &flonum) (exact->inexact val))
- ((eqv? type &char) (integer->char val))
- ((eqv? type &unspecified) *unspecified*)
- ((eqv? type &false) #f)
- ((eqv? type &true) #t)
- ((eqv? type &nil) #nil)
- ((eqv? type &null) '())
- (else (error "unhandled type" type val))))
- (let ((types (infer-types cps start)))
- (define (fold-primcall cps label names vars k src name args def)
- (call-with-values (lambda () (lookup-post-type types label def 0))
- (lambda (type min max)
- (and (not (zero? type))
- (zero? (logand type (1- type)))
- (zero? (logand type (lognot &scalar-types)))
- (eqv? min max)
- (let ((val (scalar-value type min)))
- ;; (pk 'folded src name args val)
- (with-cps cps
- (letv v*)
- (letk k* ($kargs (#f) (v*)
- ($continue k src ($const val))))
- ;; Rely on DCE to elide this expression, if
- ;; possible.
- (setk label
- ($kargs names vars
- ($continue k* src ($primcall name args))))))))))
- (define (reduce-primcall cps label names vars k src name args)
- (and=>
- (hashq-ref *primcall-reducers* name)
- (lambda (reducer)
- (match args
- ((arg0)
- (call-with-values (lambda () (lookup-pre-type types label arg0))
- (lambda (type0 min0 max0)
- (call-with-values (lambda ()
- (reducer cps k src arg0 type0 min0 max0))
- (lambda (cps term)
- (and term
- (with-cps cps
- (setk label ($kargs names vars ,term)))))))))
- ((arg0 arg1)
- (call-with-values (lambda () (lookup-pre-type types label arg0))
- (lambda (type0 min0 max0)
- (call-with-values (lambda () (lookup-pre-type types label
arg1))
- (lambda (type1 min1 max1)
- (call-with-values (lambda ()
- (reducer cps k src arg0 type0 min0 max0
- arg1 type1 min1 max1))
- (lambda (cps term)
- (and term
- (with-cps cps
- (setk label ($kargs names vars ,term)))))))))))
- (_ #f)))))
- (define (fold-unary-branch cps label names vars kf kt src name arg)
- (and=>
- (hashq-ref *branch-folders* name)
- (lambda (folder)
- (call-with-values (lambda () (lookup-pre-type types label arg))
- (lambda (type min max)
- (call-with-values (lambda () (folder type min max))
- (lambda (f? v)
- ;; (when f? (pk 'folded-unary-branch label name arg v))
- (and f?
- (with-cps cps
- (setk label
- ($kargs names vars
- ($continue (if v kt kf) src
- ($values ())))))))))))))
- (define (fold-binary-branch cps label names vars kf kt src name arg0 arg1)
- (and=>
- (hashq-ref *branch-folders* name)
- (lambda (folder)
- (call-with-values (lambda () (lookup-pre-type types label arg0))
- (lambda (type0 min0 max0)
- (call-with-values (lambda () (lookup-pre-type types label arg1))
- (lambda (type1 min1 max1)
- (call-with-values (lambda ()
- (folder type0 min0 max0 type1 min1 max1))
- (lambda (f? v)
- ;; (when f? (pk 'folded-binary-branch label name arg0
arg1 v))
- (and f?
- (with-cps cps
- (setk label
- ($kargs names vars
- ($continue (if v kt kf) src
- ($values ())))))))))))))))
- (define (visit-expression cps label names vars k src exp)
- (match exp
- (($ $primcall name args)
- ;; We might be able to fold primcalls that define a value.
- (match (intmap-ref cps k)
- (($ $kargs (_) (def))
- (or (fold-primcall cps label names vars k src name args def)
- (reduce-primcall cps label names vars k src name args)
- cps))
- (_
- (or (reduce-primcall cps label names vars k src name args)
- cps))))
- (($ $branch kt ($ $primcall name args))
- ;; We might be able to fold primcalls that branch.
- (match args
- ((x)
- (or (fold-unary-branch cps label names vars k kt src name x)
- cps))
- ((x y)
- (or (fold-binary-branch cps label names vars k kt src name x y)
- cps))))
- (_ cps)))
- (let lp ((label start) (cps cps))
- (if (<= label end)
- (lp (1+ label)
- (match (intmap-ref cps label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-expression cps label names vars k src exp))
- (_ cps)))
- cps))))
-
-(define (fold-functions-in-renumbered-program f conts seed)
- (let* ((conts (persistent-intmap conts))
- (end (1+ (intmap-prev conts))))
- (let lp ((label 0) (seed seed))
- (if (eqv? label end)
- seed
- (match (intmap-ref conts label)
- (($ $kfun src meta self tail clause)
- (lp (1+ tail) (f label tail seed))))))))
-
-(define (type-fold conts)
- ;; Type analysis wants a program whose labels are sorted.
- (let ((conts (renumber conts)))
- (with-fresh-name-state conts
- (persistent-intmap
- (fold-functions-in-renumbered-program local-type-fold conts conts)))))
diff --git a/module/language/cps2/types.scm b/module/language/cps2/types.scm
deleted file mode 100644
index 07da3d6..0000000
--- a/module/language/cps2/types.scm
+++ /dev/null
@@ -1,1408 +0,0 @@
-;;; Type analysis on CPS
-;;; 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
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; Type analysis computes the possible types and ranges that values may
-;;; have at all program positions. This analysis can help to prove that
-;;; a primcall has no side-effects, if its arguments have the
-;;; appropriate type and range. It can also enable constant folding of
-;;; type predicates and, in the future, enable the compiler to choose
-;;; untagged, unboxed representations for numbers.
-;;;
-;;; For the purposes of this analysis, a "type" is an aspect of a value
-;;; that will not change. Guile's CPS intermediate language does not
-;;; carry manifest type information that asserts properties about given
-;;; values; instead, we recover this information via flow analysis,
-;;; garnering properties from type predicates, constant literals,
-;;; primcall results, and primcalls that assert that their arguments are
-;;; of particular types.
-;;;
-;;; A range denotes a subset of the set of values in a type, bounded by
-;;; a minimum and a maximum. The precise meaning of a range depends on
-;;; the type. For real numbers, the range indicates an inclusive lower
-;;; and upper bound on the integer value of a type. For vectors, the
-;;; range indicates the length of the vector. The range is limited to a
-;;; signed 32-bit value, with the smallest and largest values indicating
-;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the
-;;; concept of "range" makes no sense. In these cases we consider the
-;;; range to be -inf.0 to +inf.0.
-;;;
-;;; Types are represented as a bitfield. Fewer bits means a more precise
-;;; type. Although normally only values that have a single type will
-;;; have an associated range, this is not enforced. The range applies
-;;; to all types in the bitfield. When control flow meets, the types and
-;;; ranges meet with the union operator.
-;;;
-;;; It is not practical to precisely compute value ranges in all cases.
-;;; For example, in the following case:
-;;;
-;;; (let lp ((n 0)) (when (foo) (lp (1+ n))))
-;;;
-;;; The first time that range analysis visits the program, N is
-;;; determined to be the exact integer 0. The second time, it is an
-;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on.
-;;; This analysis will terminate, but only after the positive half of
-;;; the 32-bit range has been fully explored and we decide that the
-;;; range of N is [0, +inf.0]. At the same time, we want to do range
-;;; analysis and type analysis at the same time, as there are
-;;; interactions between them, notably in the case of `sqrt' which
-;;; returns a complex number if its argument cannot be proven to be
-;;; non-negative. So what we do instead is to precisely propagate types
-;;; and ranges when propagating forward, but after the first backwards
-;;; branch is seen, we cause backward branches that would expand the
-;;; range of a value to saturate that range towards positive or negative
-;;; infinity (as appropriate).
-;;;
-;;; A naive approach to type analysis would build up a table that has
-;;; entries for all variables at all program points, but this has
-;;; N-squared complexity and quickly grows unmanageable. Instead, we
-;;; use _intmaps_ from (language cps intmap) to share state between
-;;; connected program points.
-;;;
-;;; Code:
-
-(define-module (language cps2 types)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:use-module (rnrs bytevectors)
- #:use-module (srfi srfi-11)
- #:export (;; Specific types.
- &exact-integer
- &flonum
- &complex
- &fraction
-
- &char
- &unspecified
- &unbound
- &false
- &true
- &nil
- &null
- &symbol
- &keyword
-
- &procedure
-
- &pointer
- &fluid
- &pair
- &vector
- &box
- &struct
- &string
- &bytevector
- &bitvector
- &array
- &hash-table
-
- ;; Union types.
- &number &real
-
- infer-types
- lookup-pre-type
- lookup-post-type
- primcall-types-check?))
-
-(define-syntax define-flags
- (lambda (x)
- (syntax-case x ()
- ((_ all shift name ...)
- (let ((count (length #'(name ...))))
- (with-syntax (((n ...) (iota count))
- (count count))
- #'(begin
- (define-syntax name (identifier-syntax (ash 1 n)))
- ...
- (define-syntax all (identifier-syntax (1- (ash 1 count))))
- (define-syntax shift (identifier-syntax count)))))))))
-
-;; More precise types have fewer bits.
-(define-flags &all-types &type-bits
- &exact-integer
- &flonum
- &complex
- &fraction
-
- &char
- &unspecified
- &unbound
- &false
- &true
- &nil
- &null
- &symbol
- &keyword
-
- &procedure
-
- &pointer
- &fluid
- &pair
- &vector
- &box
- &struct
- &string
- &bytevector
- &bitvector
- &array
- &hash-table)
-
-(define-syntax &no-type (identifier-syntax 0))
-
-(define-syntax &number
- (identifier-syntax (logior &exact-integer &flonum &complex &fraction)))
-(define-syntax &real
- (identifier-syntax (logior &exact-integer &flonum &fraction)))
-
-(define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1)))
-(define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31))))
-
-;; Versions of min and max that do not coerce exact numbers to become
-;; inexact.
-(define min
- (case-lambda
- ((a b) (if (< a b) a b))
- ((a b c) (min (min a b) c))
- ((a b c d) (min (min a b) c d))))
-(define max
- (case-lambda
- ((a b) (if (> a b) a b))
- ((a b c) (max (max a b) c))
- ((a b c d) (max (max a b) c d))))
-
-
-
-(define-syntax-rule (define-compile-time-value name val)
- (define-syntax name
- (make-variable-transformer
- (lambda (x)
- (syntax-case x (set!)
- (var (identifier? #'var)
- (datum->syntax #'var val)))))))
-
-(define-compile-time-value min-fixnum most-negative-fixnum)
-(define-compile-time-value max-fixnum most-positive-fixnum)
-
-(define-inlinable (make-unclamped-type-entry type min max)
- (vector type min max))
-(define-inlinable (type-entry-type tentry)
- (vector-ref tentry 0))
-(define-inlinable (type-entry-clamped-min tentry)
- (vector-ref tentry 1))
-(define-inlinable (type-entry-clamped-max tentry)
- (vector-ref tentry 2))
-
-(define-syntax-rule (clamp-range val)
- (cond
- ((< val min-fixnum) min-fixnum)
- ((< max-fixnum val) max-fixnum)
- (else val)))
-
-(define-inlinable (make-type-entry type min max)
- (vector type (clamp-range min) (clamp-range max)))
-(define-inlinable (type-entry-min tentry)
- (let ((min (type-entry-clamped-min tentry)))
- (if (eq? min min-fixnum) -inf.0 min)))
-(define-inlinable (type-entry-max tentry)
- (let ((max (type-entry-clamped-max tentry)))
- (if (eq? max max-fixnum) +inf.0 max)))
-
-(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0))
-
-(define* (var-type-entry typeset var #:optional (default all-types-entry))
- (intmap-ref typeset var (lambda (_) default)))
-
-(define (var-type typeset var)
- (type-entry-type (var-type-entry typeset var)))
-(define (var-min typeset var)
- (type-entry-min (var-type-entry typeset var)))
-(define (var-max typeset var)
- (type-entry-max (var-type-entry typeset var)))
-
-;; Is the type entry A contained entirely within B?
-(define (type-entry<=? a b)
- (match (cons a b)
- ((#(a-type a-min a-max) . #(b-type b-min b-max))
- (and (eqv? b-type (logior a-type b-type))
- (<= b-min a-min)
- (>= b-max a-max)))))
-
-(define (type-entry-union a b)
- (cond
- ((type-entry<=? b a) a)
- ((type-entry<=? a b) b)
- (else (make-type-entry
- (logior (type-entry-type a) (type-entry-type b))
- (min (type-entry-clamped-min a) (type-entry-clamped-min b))
- (max (type-entry-clamped-max a) (type-entry-clamped-max b))))))
-
-(define (type-entry-saturating-union a b)
- (cond
- ((type-entry<=? b a) a)
- (else
- (make-type-entry
- (logior (type-entry-type a) (type-entry-type b))
- (let ((a-min (type-entry-clamped-min a))
- (b-min (type-entry-clamped-min b)))
- (if (< b-min a-min) min-fixnum a-min))
- (let ((a-max (type-entry-clamped-max a))
- (b-max (type-entry-clamped-max b)))
- (if (> b-max a-max) max-fixnum a-max))))))
-
-(define (type-entry-intersection a b)
- (cond
- ((type-entry<=? a b) a)
- ((type-entry<=? b a) b)
- (else (make-type-entry
- (logand (type-entry-type a) (type-entry-type b))
- (max (type-entry-clamped-min a) (type-entry-clamped-min b))
- (min (type-entry-clamped-max a) (type-entry-clamped-max b))))))
-
-(define (adjoin-var typeset var entry)
- (intmap-add typeset var entry type-entry-union))
-
-(define (restrict-var typeset var entry)
- (intmap-add typeset var entry type-entry-intersection))
-
-(define (constant-type val)
- "Compute the type and range of VAL. Return three values: the type,
-minimum, and maximum."
- (define (return type val)
- (if val
- (make-type-entry type val val)
- (make-type-entry type -inf.0 +inf.0)))
- (cond
- ((number? val)
- (cond
- ((exact-integer? val) (return &exact-integer val))
- ((eqv? (imag-part val) 0)
- (if (nan? val)
- (make-type-entry &flonum -inf.0 +inf.0)
- (make-type-entry
- (if (exact? val) &fraction &flonum)
- (if (rational? val) (inexact->exact (floor val)) val)
- (if (rational? val) (inexact->exact (ceiling val)) val))))
- (else (return &complex #f))))
- ((eq? val '()) (return &null #f))
- ((eq? val #nil) (return &nil #f))
- ((eq? val #t) (return &true #f))
- ((eq? val #f) (return &false #f))
- ((char? val) (return &char (char->integer val)))
- ((eqv? val *unspecified*) (return &unspecified #f))
- ((symbol? val) (return &symbol #f))
- ((keyword? val) (return &keyword #f))
- ((pair? val) (return &pair #f))
- ((vector? val) (return &vector (vector-length val)))
- ((string? val) (return &string (string-length val)))
- ((bytevector? val) (return &bytevector (bytevector-length val)))
- ((bitvector? val) (return &bitvector (bitvector-length val)))
- ((array? val) (return &array (array-rank val)))
- ((not (variable-bound? (make-variable val))) (return &unbound #f))
-
- (else (error "unhandled constant" val))))
-
-(define *type-checkers* (make-hash-table))
-(define *type-inferrers* (make-hash-table))
-
-(define-syntax-rule (define-type-helper name)
- (define-syntax-parameter name
- (lambda (stx)
- (syntax-violation 'name
- "macro used outside of define-type"
- stx))))
-(define-type-helper define!)
-(define-type-helper restrict!)
-(define-type-helper &type)
-(define-type-helper &min)
-(define-type-helper &max)
-
-(define-syntax-rule (define-type-checker (name arg ...) body ...)
- (hashq-set!
- *type-checkers*
- 'name
- (lambda (typeset arg ...)
- (syntax-parameterize
- ((&type (syntax-rules () ((_ val) (var-type typeset val))))
- (&min (syntax-rules () ((_ val) (var-min typeset val))))
- (&max (syntax-rules () ((_ val) (var-max typeset val)))))
- body ...))))
-
-(define-syntax-rule (check-type arg type min max)
- ;; If the arg is negative, it is a closure variable.
- (and (>= arg 0)
- (zero? (logand (lognot type) (&type arg)))
- (<= min (&min arg))
- (<= (&max arg) max)))
-
-(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...)
- (hashq-set!
- *type-inferrers*
- 'name
- (lambda (in succ var ...)
- (let ((out in))
- (syntax-parameterize
- ((define!
- (syntax-rules ()
- ((_ val type min max)
- (set! out (adjoin-var out val
- (make-type-entry type min max))))))
- (restrict!
- (syntax-rules ()
- ((_ val type min max)
- (set! out (restrict-var out val
- (make-type-entry type min max))))))
- (&type (syntax-rules () ((_ val) (var-type in val))))
- (&min (syntax-rules () ((_ val) (var-min in val))))
- (&max (syntax-rules () ((_ val) (var-max in val)))))
- body ...
- out)))))
-
-(define-syntax-rule (define-type-inferrer (name arg ...) body ...)
- (define-type-inferrer* (name succ arg ...) body ...))
-
-(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...)
- (define-type-inferrer* (name succ arg ...)
- (let ((true? (not (zero? succ))))
- body ...)))
-
-(define-syntax define-simple-type-checker
- (lambda (x)
- (define (parse-spec l)
- (syntax-case l ()
- (() '())
- (((type min max) . l) (cons #'(type min max) (parse-spec #'l)))
- (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l)))
- ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l)))))
- (syntax-case x ()
- ((_ (name arg-spec ...) result-spec ...)
- (with-syntax
- (((arg ...) (generate-temporaries #'(arg-spec ...)))
- (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))))
- #'(define-type-checker (name arg ...)
- (and (check-type arg arg-type arg-min arg-max)
- ...)))))))
-
-(define-syntax define-simple-type-inferrer
- (lambda (x)
- (define (parse-spec l)
- (syntax-case l ()
- (() '())
- (((type min max) . l) (cons #'(type min max) (parse-spec #'l)))
- (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l)))
- ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l)))))
- (syntax-case x ()
- ((_ (name arg-spec ...) result-spec ...)
- (with-syntax
- (((arg ...) (generate-temporaries #'(arg-spec ...)))
- (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))
- ((res ...) (generate-temporaries #'(result-spec ...)))
- (((res-type res-min res-max) ...) (parse-spec #'(result-spec
...))))
- #'(define-type-inferrer (name arg ... res ...)
- (restrict! arg arg-type arg-min arg-max)
- ...
- (define! res res-type res-min res-max)
- ...))))))
-
-(define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...)
- (begin
- (define-simple-type-checker (name arg-spec ...))
- (define-simple-type-inferrer (name arg-spec ...) result-spec ...)))
-
-(define-syntax-rule (define-simple-types
- ((name arg-spec ...) result-spec ...)
- ...)
- (begin
- (define-simple-type (name arg-spec ...) result-spec ...)
- ...))
-
-(define-syntax-rule (define-type-checker-aliases orig alias ...)
- (let ((check (hashq-ref *type-checkers* 'orig)))
- (hashq-set! *type-checkers* 'alias check)
- ...))
-(define-syntax-rule (define-type-inferrer-aliases orig alias ...)
- (let ((check (hashq-ref *type-inferrers* 'orig)))
- (hashq-set! *type-inferrers* 'alias check)
- ...))
-(define-syntax-rule (define-type-aliases orig alias ...)
- (begin
- (define-type-checker-aliases orig alias ...)
- (define-type-inferrer-aliases orig alias ...)))
-
-
-
-
-;;; This list of primcall type definitions follows the order of
-;;; effects-analysis.scm; please keep it in a similar order.
-;;;
-;;; There is no need to add checker definitions for expressions that do
-;;; not exhibit the &type-check effect, as callers should not ask if
-;;; such an expression does or does not type-check. For those that do
-;;; exhibit &type-check, you should define a type inferrer unless the
-;;; primcall will never typecheck.
-;;;
-;;; Likewise there is no need to define inferrers for primcalls which
-;;; return &all-types values and which never raise exceptions from which
-;;; we can infer the types of incoming values.
-
-
-
-
-;;;
-;;; Generic effect-free predicates.
-;;;
-
-(define-predicate-inferrer (eq? a b true?)
- ;; We can only propagate information down the true leg.
- (when true?
- (let ((type (logand (&type a) (&type b)))
- (min (max (&min a) (&min b)))
- (max (min (&max a) (&max b))))
- (restrict! a type min max)
- (restrict! b type min max))))
-(define-type-inferrer-aliases eq? eqv? equal?)
-
-(define-syntax-rule (define-simple-predicate-inferrer predicate type)
- (define-predicate-inferrer (predicate val true?)
- (let ((type (if true?
- type
- (logand (&type val) (lognot type)))))
- (restrict! val type -inf.0 +inf.0))))
-(define-simple-predicate-inferrer pair? &pair)
-(define-simple-predicate-inferrer null? &null)
-(define-simple-predicate-inferrer nil? &nil)
-(define-simple-predicate-inferrer symbol? &symbol)
-(define-simple-predicate-inferrer variable? &box)
-(define-simple-predicate-inferrer vector? &vector)
-(define-simple-predicate-inferrer struct? &struct)
-(define-simple-predicate-inferrer string? &string)
-(define-simple-predicate-inferrer bytevector? &bytevector)
-(define-simple-predicate-inferrer bitvector? &bitvector)
-(define-simple-predicate-inferrer keyword? &keyword)
-(define-simple-predicate-inferrer number? &number)
-(define-simple-predicate-inferrer char? &char)
-(define-simple-predicate-inferrer procedure? &procedure)
-(define-simple-predicate-inferrer thunk? &procedure)
-
-
-
-;;;
-;;; Fluids. Note that we can't track bound-ness of fluids, as pop-fluid
-;;; can change boundness.
-;;;
-
-(define-simple-types
- ((fluid-ref (&fluid 1)) &all-types)
- ((fluid-set! (&fluid 0 1) &all-types))
- ((push-fluid (&fluid 0 1) &all-types))
- ((pop-fluid)))
-
-
-
-
-;;;
-;;; Prompts. (Nothing to do.)
-;;;
-
-
-
-
-;;;
-;;; Pairs.
-;;;
-
-(define-simple-types
- ((cons &all-types &all-types) &pair)
- ((car &pair) &all-types)
- ((set-car! &pair &all-types))
- ((cdr &pair) &all-types)
- ((set-cdr! &pair &all-types)))
-
-
-
-
-;;;
-;;; Variables.
-;;;
-
-(define-simple-types
- ((box &all-types) (&box 1))
- ((box-ref (&box 1)) &all-types))
-
-(define-simple-type-checker (box-set! (&box 0 1) &all-types))
-(define-type-inferrer (box-set! box val)
- (restrict! box &box 1 1))
-
-
-
-
-;;;
-;;; Vectors.
-;;;
-
-;; This max-vector-len computation is a hack.
-(define *max-vector-len* (ash most-positive-fixnum -5))
-
-(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*)
- &all-types))
-(define-type-inferrer (make-vector size init result)
- (restrict! size &exact-integer 0 *max-vector-len*)
- (define! result &vector (max (&min size) 0) (&max size)))
-
-(define-type-checker (vector-ref v idx)
- (and (check-type v &vector 0 *max-vector-len*)
- (check-type idx &exact-integer 0 (1- (&min v)))))
-(define-type-inferrer (vector-ref v idx result)
- (restrict! v &vector (1+ (&min idx)) +inf.0)
- (restrict! idx &exact-integer 0 (1- (&max v)))
- (define! result &all-types -inf.0 +inf.0))
-
-(define-type-checker (vector-set! v idx val)
- (and (check-type v &vector 0 *max-vector-len*)
- (check-type idx &exact-integer 0 (1- (&min v)))))
-(define-type-inferrer (vector-set! v idx val)
- (restrict! v &vector (1+ (&min idx)) +inf.0)
- (restrict! idx &exact-integer 0 (1- (&max v))))
-
-(define-type-aliases make-vector make-vector/immediate)
-(define-type-aliases vector-ref vector-ref/immediate)
-(define-type-aliases vector-set! vector-set!/immediate)
-
-(define-simple-type-checker (vector-length &vector))
-(define-type-inferrer (vector-length v result)
- (restrict! v &vector 0 *max-vector-len*)
- (define! result &exact-integer (max (&min v) 0)
- (min (&max v) *max-vector-len*)))
-
-
-
-
-;;;
-;;; Structs.
-;;;
-
-;; No type-checker for allocate-struct, as we can't currently check that
-;; vt is actually a vtable.
-(define-type-inferrer (allocate-struct vt size result)
- (restrict! vt &struct vtable-offset-user +inf.0)
- (restrict! size &exact-integer 0 +inf.0)
- (define! result &struct (max (&min size) 0) (&max size)))
-
-(define-type-checker (struct-ref s idx)
- (and (check-type s &struct 0 +inf.0)
- (check-type idx &exact-integer 0 +inf.0)
- ;; FIXME: is the field readable?
- (< (&max idx) (&min s))))
-(define-type-inferrer (struct-ref s idx result)
- (restrict! s &struct (1+ (&min idx)) +inf.0)
- (restrict! idx &exact-integer 0 (1- (&max s)))
- (define! result &all-types -inf.0 +inf.0))
-
-(define-type-checker (struct-set! s idx val)
- (and (check-type s &struct 0 +inf.0)
- (check-type idx &exact-integer 0 +inf.0)
- ;; FIXME: is the field writable?
- (< (&max idx) (&min s))))
-(define-type-inferrer (struct-set! s idx val)
- (restrict! s &struct (1+ (&min idx)) +inf.0)
- (restrict! idx &exact-integer 0 (1- (&max s))))
-
-(define-type-aliases allocate-struct allocate-struct/immediate)
-(define-type-aliases struct-ref struct-ref/immediate)
-(define-type-aliases struct-set! struct-set!/immediate)
-
-(define-simple-type (struct-vtable (&struct 0 +inf.0))
- (&struct vtable-offset-user +inf.0))
-
-
-
-
-;;;
-;;; Strings.
-;;;
-
-(define *max-char* (1- (ash 1 24)))
-
-(define-type-checker (string-ref s idx)
- (and (check-type s &string 0 +inf.0)
- (check-type idx &exact-integer 0 +inf.0)
- (< (&max idx) (&min s))))
-(define-type-inferrer (string-ref s idx result)
- (restrict! s &string (1+ (&min idx)) +inf.0)
- (restrict! idx &exact-integer 0 (1- (&max s)))
- (define! result &char 0 *max-char*))
-
-(define-type-checker (string-set! s idx val)
- (and (check-type s &string 0 +inf.0)
- (check-type idx &exact-integer 0 +inf.0)
- (check-type val &char 0 *max-char*)
- (< (&max idx) (&min s))))
-(define-type-inferrer (string-set! s idx val)
- (restrict! s &string (1+ (&min idx)) +inf.0)
- (restrict! idx &exact-integer 0 (1- (&max s)))
- (restrict! val &char 0 *max-char*))
-
-(define-simple-type-checker (string-length &string))
-(define-type-inferrer (string-length s result)
- (restrict! s &string 0 +inf.0)
- (define! result &exact-integer (max (&min s) 0) (&max s)))
-
-(define-simple-type (number->string &number) (&string 0 +inf.0))
-(define-simple-type (string->number (&string 0 +inf.0))
- ((logior &number &false) -inf.0 +inf.0))
-
-
-
-
-;;;
-;;; Bytevectors.
-;;;
-
-(define-simple-type-checker (bytevector-length &bytevector))
-(define-type-inferrer (bytevector-length bv result)
- (restrict! bv &bytevector 0 +inf.0)
- (define! result &exact-integer (max (&min bv) 0) (&max bv)))
-
-(define-syntax-rule (define-bytevector-accessors ref set type size min max)
- (begin
- (define-type-checker (ref bv idx)
- (and (check-type bv &bytevector 0 +inf.0)
- (check-type idx &exact-integer 0 +inf.0)
- (< (&max idx) (- (&min bv) size))))
- (define-type-inferrer (ref bv idx result)
- (restrict! bv &bytevector (+ (&min idx) size) +inf.0)
- (restrict! idx &exact-integer 0 (- (&max bv) size))
- (define! result type min max))
- (define-type-checker (set bv idx val)
- (and (check-type bv &bytevector 0 +inf.0)
- (check-type idx &exact-integer 0 +inf.0)
- (check-type val type min max)
- (< (&max idx) (- (&min bv) size))))
- (define-type-inferrer (set! bv idx val)
- (restrict! bv &bytevector (+ (&min idx) size) +inf.0)
- (restrict! idx &exact-integer 0 (- (&max bv) size))
- (restrict! val type min max))))
-
-(define-syntax-rule (define-short-bytevector-accessors ref set size signed?)
- (define-bytevector-accessors ref set &exact-integer size
- (if signed? (- (ash 1 (1- (* size 8)))) 0)
- (1- (ash 1 (if signed? (1- (* size 8)) (* size 8))))))
-
-(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f)
-(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t)
-(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f)
-(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t)
-
-;; The range analysis only works on signed 32-bit values, so some limits
-;; are out of range.
-(define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0)
-(define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0
+inf.0)
-(define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0)
-(define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0
+inf.0)
-(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0)
-(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0)
-
-
-
-
-;;;
-;;; Numbers.
-;;;
-
-;; First, branching primitives with no results.
-(define-simple-type-checker (= &number &number))
-(define-predicate-inferrer (= a b true?)
- (when (and true?
- (zero? (logand (logior (&type a) (&type b)) (lognot &number))))
- (let ((min (max (&min a) (&min b)))
- (max (min (&max a) (&max b))))
- (restrict! a &number min max)
- (restrict! b &number min max))))
-
-(define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1)
- (define (infer-integer-ranges)
- (match op
- ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
- ('<= (values min0 (min max0 max1) (max min0 min1) max1))
- ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
- ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
- (define (infer-real-ranges)
- (match op
- ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1))
- ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1)))))
- (if (= (logior type0 type1) &exact-integer)
- (infer-integer-ranges)
- (infer-real-ranges)))
-
-(define-syntax-rule (define-comparison-inferrer (op inverse))
- (define-predicate-inferrer (op a b true?)
- (when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
- (call-with-values
- (lambda ()
- (restricted-comparison-ranges (if true? 'op 'inverse)
- (&type a) (&min a) (&max a)
- (&type b) (&min b) (&max b)))
- (lambda (min0 max0 min1 max1)
- (restrict! a &real min0 max0)
- (restrict! b &real min1 max1))))))
-
-(define-simple-type-checker (< &real &real))
-(define-comparison-inferrer (< >=))
-
-(define-simple-type-checker (<= &real &real))
-(define-comparison-inferrer (<= >))
-
-(define-simple-type-checker (>= &real &real))
-(define-comparison-inferrer (>= <))
-
-(define-simple-type-checker (> &real &real))
-(define-comparison-inferrer (> <=))
-
-;; Arithmetic.
-(define-syntax-rule (define-unary-result! a result min max)
- (let ((min* min)
- (max* max)
- (type (logand (&type a) &number)))
- (cond
- ((not (= type (&type a)))
- ;; Not a number. Punt and do nothing.
- (define! result &all-types -inf.0 +inf.0))
- ;; Complex numbers don't have a range.
- ((eqv? type &complex)
- (define! result &complex -inf.0 +inf.0))
- (else
- (define! result type min* max*)))))
-
-(define-syntax-rule (define-binary-result! a b result closed? min max)
- (let ((min* min)
- (max* max)
- (a-type (logand (&type a) &number))
- (b-type (logand (&type b) &number)))
- (cond
- ((or (not (= a-type (&type a))) (not (= b-type (&type b))))
- ;; One input not a number. Perhaps we end up dispatching to
- ;; GOOPS.
- (define! result &all-types -inf.0 +inf.0))
- ;; Complex and floating-point numbers are contagious.
- ((or (eqv? a-type &complex) (eqv? b-type &complex))
- (define! result &complex -inf.0 +inf.0))
- ((or (eqv? a-type &flonum) (eqv? b-type &flonum))
- (define! result &flonum min* max*))
- ;; Exact integers are closed under some operations.
- ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer))
- (define! result &exact-integer min* max*))
- (else
- ;; Fractions may become integers.
- (let ((type (logior a-type b-type)))
- (define! result
- (if (zero? (logand type &fraction))
- type
- (logior type &exact-integer))
- min* max*))))))
-
-(define-simple-type-checker (add &number &number))
-(define-type-inferrer (add a b result)
- (define-binary-result! a b result #t
- (+ (&min a) (&min b))
- (+ (&max a) (&max b))))
-
-(define-simple-type-checker (sub &number &number))
-(define-type-inferrer (sub a b result)
- (define-binary-result! a b result #t
- (- (&min a) (&max b))
- (- (&max a) (&min b))))
-
-(define-simple-type-checker (mul &number &number))
-(define-type-inferrer (mul a b result)
- (let ((min-a (&min a)) (max-a (&max a))
- (min-b (&min b)) (max-b (&max b))
- ;; We only really get +inf.0 at runtime for flonums and
- ;; compnums. If we have inferred that the arguments are not
- ;; flonums and not compnums, then the result of (* +inf.0 0) at
- ;; range inference time is 0 and not +nan.0.
- (nan-impossible? (not (logtest (logior (&type a) (&type b))
- (logior &flonum &complex)))))
- (define (nan* a b)
- (if (and (or (and (inf? a) (zero? b))
- (and (zero? a) (inf? b)))
- nan-impossible?)
- 0
- (* a b)))
- (let ((-- (nan* min-a min-b))
- (-+ (nan* min-a max-b))
- (++ (nan* max-a max-b))
- (+- (nan* max-a min-b)))
- (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-))))
- (define-binary-result! a b result #t
- (cond
- ((eqv? a b) 0)
- (has-nan? -inf.0)
- (else (min -- -+ ++ +-)))
- (if has-nan?
- +inf.0
- (max -- -+ ++ +-)))))))
-
-(define-type-checker (div a b)
- (and (check-type a &number -inf.0 +inf.0)
- (check-type b &number -inf.0 +inf.0)
- ;; We only know that there will not be an exception if b is not
- ;; zero.
- (not (<= (&min b) 0 (&max b)))))
-(define-type-inferrer (div a b result)
- (let ((min-a (&min a)) (max-a (&max a))
- (min-b (&min b)) (max-b (&max b)))
- (call-with-values
- (lambda ()
- (if (<= min-b 0 max-b)
- ;; If the range of the divisor crosses 0, the result spans
- ;; the whole range.
- (values -inf.0 +inf.0)
- ;; Otherwise min-b and max-b have the same sign, and cannot both
- ;; be infinity.
- (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b)))
- (-+- (if (inf? max-b) 0 (floor/ min-a max-b)))
- (++- (if (inf? max-b) 0 (floor/ max-a max-b)))
- (+-- (if (inf? min-b) 0 (floor/ max-a min-b)))
- (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b)))
- (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b)))
- (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b)))
- (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b))))
- (values (min (min --- -+- ++- +--)
- (min --+ -++ +++ +-+))
- (max (max --- -+- ++- +--)
- (max --+ -++ +++ +-+))))))
- (lambda (min max)
- (define-binary-result! a b result #f min max)))))
-
-(define-simple-type-checker (add1 &number))
-(define-type-inferrer (add1 a result)
- (define-unary-result! a result (1+ (&min a)) (1+ (&max a))))
-
-(define-simple-type-checker (sub1 &number))
-(define-type-inferrer (sub1 a result)
- (define-unary-result! a result (1- (&min a)) (1- (&max a))))
-
-(define-type-checker (quo a b)
- (and (check-type a &exact-integer -inf.0 +inf.0)
- (check-type b &exact-integer -inf.0 +inf.0)
- ;; We only know that there will not be an exception if b is not
- ;; zero.
- (not (<= (&min b) 0 (&max b)))))
-(define-type-inferrer (quo a b result)
- (restrict! a &exact-integer -inf.0 +inf.0)
- (restrict! b &exact-integer -inf.0 +inf.0)
- (define! result &exact-integer -inf.0 +inf.0))
-
-(define-type-checker-aliases quo rem)
-(define-type-inferrer (rem a b result)
- (restrict! a &exact-integer -inf.0 +inf.0)
- (restrict! b &exact-integer -inf.0 +inf.0)
- ;; Same sign as A.
- (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b))))))
- (cond
- ((< (&min a) 0)
- (if (< 0 (&max a))
- (define! result &exact-integer (- max-abs-rem) max-abs-rem)
- (define! result &exact-integer (- max-abs-rem) 0)))
- (else
- (define! result &exact-integer 0 max-abs-rem)))))
-
-(define-type-checker-aliases quo mod)
-(define-type-inferrer (mod a b result)
- (restrict! a &exact-integer -inf.0 +inf.0)
- (restrict! b &exact-integer -inf.0 +inf.0)
- ;; Same sign as B.
- (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b))))))
- (cond
- ((< (&min b) 0)
- (if (< 0 (&max b))
- (define! result &exact-integer (- max-abs-mod) max-abs-mod)
- (define! result &exact-integer (- max-abs-mod) 0)))
- (else
- (define! result &exact-integer 0 max-abs-mod)))))
-
-;; Predicates.
-(define-syntax-rule (define-number-kind-predicate-inferrer name type)
- (define-type-inferrer (name val result)
- (cond
- ((zero? (logand (&type val) type))
- (define! result &false 0 0))
- ((zero? (logand (&type val) (lognot type)))
- (define! result &true 0 0))
- (else
- (define! result (logior &true &false) 0 0)))))
-(define-number-kind-predicate-inferrer complex? &number)
-(define-number-kind-predicate-inferrer real? &real)
-(define-number-kind-predicate-inferrer rational?
- (logior &exact-integer &fraction))
-(define-number-kind-predicate-inferrer integer?
- (logior &exact-integer &flonum))
-(define-number-kind-predicate-inferrer exact-integer?
- &exact-integer)
-
-(define-simple-type-checker (exact? &number))
-(define-type-inferrer (exact? val result)
- (restrict! val &number -inf.0 +inf.0)
- (cond
- ((zero? (logand (&type val) (logior &exact-integer &fraction)))
- (define! result &false 0 0))
- ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction))))
- (define! result &true 0 0))
- (else
- (define! result (logior &true &false) 0 0))))
-
-(define-simple-type-checker (inexact? &number))
-(define-type-inferrer (inexact? val result)
- (restrict! val &number -inf.0 +inf.0)
- (cond
- ((zero? (logand (&type val) (logior &flonum &complex)))
- (define! result &false 0 0))
- ((zero? (logand (&type val) (logand &number
- (lognot (logior &flonum &complex)))))
- (define! result &true 0 0))
- (else
- (define! result (logior &true &false) 0 0))))
-
-(define-simple-type-checker (inf? &real))
-(define-type-inferrer (inf? val result)
- (restrict! val &real -inf.0 +inf.0)
- (cond
- ((or (zero? (logand (&type val) (logior &flonum &complex)))
- (and (not (inf? (&min val))) (not (inf? (&max val)))))
- (define! result &false 0 0))
- (else
- (define! result (logior &true &false) 0 0))))
-
-(define-type-aliases inf? nan?)
-
-(define-simple-type (even? &exact-integer)
- ((logior &true &false) 0 0))
-(define-type-aliases even? odd?)
-
-;; Bit operations.
-(define-simple-type-checker (ash &exact-integer &exact-integer))
-(define-type-inferrer (ash val count result)
- (define (ash* val count)
- ;; As we can only represent a 32-bit range, don't bother inferring
- ;; shifts that might exceed that range.
- (cond
- ((inf? val) val) ; Preserves sign.
- ((< -32 count 32) (ash val count))
- ((zero? val) 0)
- ((positive? val) +inf.0)
- (else -inf.0)))
- (restrict! val &exact-integer -inf.0 +inf.0)
- (restrict! count &exact-integer -inf.0 +inf.0)
- (let ((-- (ash* (&min val) (&min count)))
- (-+ (ash* (&min val) (&max count)))
- (++ (ash* (&max val) (&max count)))
- (+- (ash* (&max val) (&min count))))
- (define! result &exact-integer
- (min -- -+ ++ +-)
- (max -- -+ ++ +-))))
-
-(define (next-power-of-two n)
- (let lp ((out 1))
- (if (< n out)
- out
- (lp (ash out 1)))))
-
-(define-simple-type-checker (logand &exact-integer &exact-integer))
-(define-type-inferrer (logand a b result)
- (define (logand-min a b)
- (if (and (negative? a) (negative? b))
- (min a b)
- 0))
- (define (logand-max a b)
- (if (and (positive? a) (positive? b))
- (min a b)
- 0))
- (restrict! a &exact-integer -inf.0 +inf.0)
- (restrict! b &exact-integer -inf.0 +inf.0)
- (define! result &exact-integer
- (logand-min (&min a) (&min b))
- (logand-max (&max a) (&max b))))
-
-(define-simple-type-checker (logior &exact-integer &exact-integer))
-(define-type-inferrer (logior a b result)
- ;; Saturate all bits of val.
- (define (saturate val)
- (1- (next-power-of-two val)))
- (define (logior-min a b)
- (cond ((and (< a 0) (<= 0 b)) a)
- ((and (< b 0) (<= 0 a)) b)
- (else (max a b))))
- (define (logior-max a b)
- ;; If either operand is negative, just assume the max is -1.
- (cond
- ((or (< a 0) (< b 0)) -1)
- ((or (inf? a) (inf? b)) +inf.0)
- (else (saturate (logior a b)))))
- (restrict! a &exact-integer -inf.0 +inf.0)
- (restrict! b &exact-integer -inf.0 +inf.0)
- (define! result &exact-integer
- (logior-min (&min a) (&min b))
- (logior-max (&max a) (&max b))))
-
-;; For our purposes, treat logxor the same as logior.
-(define-type-aliases logior logxor)
-
-(define-simple-type-checker (lognot &exact-integer))
-(define-type-inferrer (lognot a result)
- (restrict! a &exact-integer -inf.0 +inf.0)
- (define! result &exact-integer
- (- -1 (&max a))
- (- -1 (&min a))))
-
-(define-simple-type-checker (logtest &exact-integer &exact-integer))
-(define-predicate-inferrer (logtest a b true?)
- (restrict! a &exact-integer -inf.0 +inf.0)
- (restrict! b &exact-integer -inf.0 +inf.0))
-
-(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
-(define-type-inferrer (logbit? a b result)
- (let ((a-min (&min a))
- (a-max (&max a))
- (b-min (&min b))
- (b-max (&max b)))
- (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min))
- (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min)))
- (let ((type (if (logbit? a-min b-min) &true &false)))
- (define! result type 0 0))
- (define! result (logior &true &false) 0 0))))
-
-;; Flonums.
-(define-simple-type-checker (sqrt &number))
-(define-type-inferrer (sqrt x result)
- (let ((type (&type x)))
- (cond
- ((and (zero? (logand type &complex)) (<= 0 (&min x)))
- (define! result
- (logior type &flonum)
- (inexact->exact (floor (sqrt (&min x))))
- (if (inf? (&max x))
- +inf.0
- (inexact->exact (ceiling (sqrt (&max x)))))))
- (else
- (define! result (logior type &flonum &complex) -inf.0 +inf.0)))))
-
-(define-simple-type-checker (abs &real))
-(define-type-inferrer (abs x result)
- (let ((type (&type x)))
- (cond
- ((eqv? type (logand type &number))
- (restrict! x &real -inf.0 +inf.0)
- (define! result (logand type &real)
- (min (abs (&min x)) (abs (&max x)))
- (max (abs (&min x)) (abs (&max x)))))
- (else
- (define! result (logior (logand (&type x) (lognot &number))
- (logand (&type x) &real))
- (max (&min x) 0)
- (max (abs (&min x)) (abs (&max x))))))))
-
-
-
-
-;;;
-;;; Characters.
-;;;
-
-(define-simple-type (char<? &char &char)
- ((logior &true &false) 0 0))
-(define-type-aliases char<? char<=? char>=? char>?)
-
-(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff)))
-(define-type-inferrer (integer->char i result)
- (restrict! i &exact-integer 0 #x10ffff)
- (define! result &char (max (&min i) 0) (min (&max i) #x10ffff)))
-
-(define-simple-type-checker (char->integer &char))
-(define-type-inferrer (char->integer c result)
- (restrict! c &char 0 #x10ffff)
- (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff)))
-
-
-
-
-;;;
-;;; Type flow analysis: the meet (ahem) of the algorithm.
-;;;
-
-(define (successor-count cont)
- (match cont
- (($ $kargs _ _ ($ $continue k src exp))
- (match exp
- ((or ($ $branch) ($ $prompt)) 2)
- (_ 1)))
- (($ $kfun src meta self tail clause) (if clause 1 0))
- (($ $kclause arity body alt) (if alt 2 1))
- (($ $kreceive) 1)
- (($ $ktail) 0)))
-
-(define (intset-pop set)
- (match (intset-next set)
- (#f (values set #f))
- (i (values (intset-remove set i) i))))
-
-(define-syntax-rule (make-worklist-folder* seed ...)
- (lambda (f worklist seed ...)
- (let lp ((worklist worklist) (seed seed) ...)
- (call-with-values (lambda () (intset-pop worklist))
- (lambda (worklist i)
- (if i
- (call-with-values (lambda () (f i seed ...))
- (lambda (i* seed ...)
- (let add ((i* i*) (worklist worklist))
- (match i*
- (() (lp worklist seed ...))
- ((i . i*) (add i* (intset-add worklist i)))))))
- (values seed ...)))))))
-
-(define worklist-fold*
- (case-lambda
- ((f worklist seed)
- ((make-worklist-folder* seed) f worklist seed))))
-
-(define intmap-ensure
- (let* ((*absent* (list 'absent))
- (not-found (lambda (i) *absent*)))
- (lambda (map i ensure)
- (let ((val (intmap-ref map i not-found)))
- (if (eq? val *absent*)
- (let ((val (ensure i)))
- (values (intmap-add map i val) val))
- (values map val))))))
-
-;; For best results, the labels in the function starting should be
-;; topologically sorted (renumbered). Otherwise the backward branch
-;; detection mentioned in the module commentary will trigger for
-;; ordinary forward branches.
-(define (infer-types conts kfun)
- "Compute types for all variables bound in the function labelled
address@hidden, from @var{conts}. Returns an intmap mapping labels to type
-entries.
-
-A type entry is a vector that describes the types of the values that
-flow into and out of a labelled expressoin. The first slot in the type
-entry vector corresponds to the types that flow in, and the rest of the
-slots correspond to the types that flow out. Each element of the type
-entry vector is an intmap mapping variable name to the variable's
-inferred type. An inferred type is a 3-vector of type, minimum, and
-maximum, where type is a bitset as a fixnum."
- (define (get-entry typev label) (intmap-ref typev label))
- (define (entry-not-found label)
- (make-vector (1+ (successor-count (intmap-ref conts label))) #f))
- (define (ensure-entry typev label)
- (intmap-ensure typev label entry-not-found))
-
- (define (compute-initial-state)
- (let ((entry (entry-not-found kfun)))
- ;; Nothing flows in to the first label.
- (vector-set! entry 0 empty-intmap)
- (intmap-add empty-intmap kfun entry)))
-
- (define (adjoin-vars types vars entry)
- (match vars
- (() types)
- ((var . vars)
- (adjoin-vars (adjoin-var types var entry) vars entry))))
-
- (define (infer-primcall types succ name args result)
- (cond
- ((hashq-ref *type-inferrers* name)
- => (lambda (inferrer)
- ;; FIXME: remove the apply?
- ;; (pk 'primcall name args result)
- (apply inferrer types succ
- (if result
- (append args (list result))
- args))))
- (result
- (adjoin-var types result all-types-entry))
- (else
- types)))
-
- (define (vector-replace vec idx val)
- (let ((vec (vector-copy vec)))
- (vector-set! vec idx val)
- vec))
-
- (define (update-out-types label typev types succ-idx)
- (let* ((entry (get-entry typev label))
- (old-types (vector-ref entry (1+ succ-idx))))
- (if (eq? types old-types)
- (values typev #f)
- (let ((entry (vector-replace entry (1+ succ-idx) types))
- (first? (not old-types)))
- (values (intmap-replace typev label entry) first?)))))
-
- (define (update-in-types label typev types saturate?)
- (let*-values (((typev entry) (ensure-entry typev label))
- ((old-types) (vector-ref entry 0))
- ;; TODO: If the label has only one predecessor, we can
- ;; avoid the meet.
- ((types) (if (not old-types)
- types
- (let ((meet (if saturate?
- type-entry-saturating-union
- type-entry-union)))
- (intmap-intersect old-types types meet)))))
- (if (eq? old-types types)
- (values typev #f)
- (let ((entry (vector-replace entry 0 types)))
- (values (intmap-replace typev label entry) #t)))))
-
- (define (propagate-types label typev succ-idx succ-label types)
- (let*-values
- (((typev first?) (update-out-types label typev types succ-idx))
- ((saturate?) (and (not first?) (<= succ-label label)))
- ((typev changed?) (update-in-types succ-label typev types saturate?)))
- (values (if changed? (list succ-label) '()) typev)))
-
- (define (visit-exp label typev k types exp)
- (define (propagate1 succ-label types)
- (propagate-types label typev 0 succ-label types))
- (define (propagate2 succ0-label types0 succ1-label types1)
- (let*-values (((changed0 typev)
- (propagate-types label typev 0 succ0-label types0))
- ((changed1 typev)
- (propagate-types label typev 1 succ1-label types1)))
- (values (append changed0 changed1) typev)))
- ;; Each of these branches must propagate to its successors.
- (match exp
- (($ $branch kt ($ $values (arg)))
- ;; The "normal" continuation is the #f branch.
- (let ((kf-types (restrict-var types arg
- (make-type-entry (logior &false &nil)
- 0
- 0)))
- (kt-types (restrict-var types arg
- (make-type-entry
- (logand &all-types
- (lognot (logior &false &nil)))
- -inf.0 +inf.0))))
- (propagate2 k kf-types kt kt-types)))
- (($ $branch kt ($ $primcall name args))
- ;; The "normal" continuation is the #f branch.
- (let ((kf-types (infer-primcall types 0 name args #f))
- (kt-types (infer-primcall types 1 name args #f)))
- (propagate2 k kf-types kt kt-types)))
- (($ $prompt escape? tag handler)
- ;; The "normal" continuation enters the prompt.
- (propagate2 k types handler types))
- (($ $primcall name args)
- (propagate1 k
- (match (intmap-ref conts k)
- (($ $kargs _ defs)
- (infer-primcall types 0 name args
- (match defs ((var) var) (() #f))))
- (_
- ;; (pk 'warning-no-restrictions name)
- types))))
- (($ $values args)
- (match (intmap-ref conts k)
- (($ $kargs _ defs)
- (let ((in types))
- (let lp ((defs defs) (args args) (out types))
- (match (cons defs args)
- ((() . ())
- (propagate1 k out))
- (((def . defs) . (arg . args))
- (lp defs args
- (adjoin-var out def (var-type-entry in arg))))))))
- (_
- (propagate1 k types))))
- ((or ($ $call) ($ $callk))
- (propagate1 k types))
- (($ $rec names vars funs)
- (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0)))
- (propagate1 k (adjoin-vars types vars proc-type))))
- (_
- (match (intmap-ref conts k)
- (($ $kargs (_) (var))
- (let ((entry (match exp
- (($ $const val)
- (constant-type val))
- ((or ($ $prim) ($ $fun) ($ $closure))
- ;; Could be more precise here.
- (make-type-entry &procedure -inf.0 +inf.0)))))
- (propagate1 k (adjoin-var types var entry))))))))
-
- (define (visit-cont label typev)
- (let ((types (vector-ref (intmap-ref typev label) 0)))
- (define (propagate0)
- (values '() typev))
- (define (propagate1 succ-label types)
- (propagate-types label typev 0 succ-label types))
- (define (propagate2 succ0-label types0 succ1-label types1)
- (let*-values (((changed0 typev)
- (propagate-types label typev 0 succ0-label types0))
- ((changed1 typev)
- (propagate-types label typev 1 succ1-label types1)))
- (values (append changed0 changed1) typev)))
-
- ;; Add types for new definitions, and restrict types of
- ;; existing variables due to side effects.
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-exp label typev k types exp))
- (($ $kreceive arity k)
- (match (intmap-ref conts k)
- (($ $kargs names vars)
- (propagate1 k (adjoin-vars types vars all-types-entry)))))
- (($ $kfun src meta self tail clause)
- (if clause
- (propagate1 clause (adjoin-var types self all-types-entry))
- (propagate0)))
- (($ $kclause arity kbody kalt)
- (match (intmap-ref conts kbody)
- (($ $kargs _ defs)
- (let ((body-types (adjoin-vars types defs all-types-entry)))
- (if kalt
- (propagate2 kbody body-types kalt types)
- (propagate1 kbody body-types))))))
- (($ $ktail) (propagate0)))))
-
- (worklist-fold* visit-cont
- (intset-add empty-intset kfun)
- (compute-initial-state)))
-
-(define (lookup-pre-type types label def)
- (let* ((entry (intmap-ref types label))
- (tentry (var-type-entry (vector-ref entry 0) def)))
- (values (type-entry-type tentry)
- (type-entry-min tentry)
- (type-entry-max tentry))))
-
-(define (lookup-post-type types label def succ-idx)
- (let* ((entry (intmap-ref types label))
- (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def)))
- (values (type-entry-type tentry)
- (type-entry-min tentry)
- (type-entry-max tentry))))
-
-(define (primcall-types-check? types label name args)
- (match (hashq-ref *type-checkers* name)
- (#f #f)
- (checker
- (let ((entry (intmap-ref types label)))
- (apply checker (vector-ref entry 0) args)))))
diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm
deleted file mode 100644
index eae6b69..0000000
--- a/module/language/cps2/utils.scm
+++ /dev/null
@@ -1,477 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Helper facilities for working with CPS.
-;;;
-;;; Code:
-
-(define-module (language cps2 utils)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
- #:use-module (language cps2)
- #:use-module (language cps intset)
- #:use-module (language cps intmap)
- #:export (;; Fresh names.
- label-counter var-counter
- fresh-label fresh-var
- with-fresh-name-state compute-max-label-and-var
- let-fresh
-
- ;; Various utilities.
- fold1 fold2
- trivial-intset
- intmap-map
- intmap-keys
- invert-bijection invert-partition
- intset->intmap
- worklist-fold
- fixpoint
-
- ;; Flow analysis.
- compute-constant-values
- compute-function-body
- compute-reachable-functions
- compute-successors
- invert-graph
- compute-predecessors
- compute-reverse-post-order
- compute-strongly-connected-components
- compute-sorted-strongly-connected-components
- compute-idoms
- compute-dom-edges
- ))
-
-(define label-counter (make-parameter #f))
-(define var-counter (make-parameter #f))
-
-(define (fresh-label)
- (let ((count (or (label-counter)
- (error "fresh-label outside with-fresh-name-state"))))
- (label-counter (1+ count))
- count))
-
-(define (fresh-var)
- (let ((count (or (var-counter)
- (error "fresh-var outside with-fresh-name-state"))))
- (var-counter (1+ count))
- count))
-
-(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
- (let* ((label (fresh-label)) ...
- (var (fresh-var)) ...)
- body ...))
-
-(define-syntax-rule (with-fresh-name-state fun body ...)
- (call-with-values (lambda () (compute-max-label-and-var fun))
- (lambda (max-label max-var)
- (parameterize ((label-counter (1+ max-label))
- (var-counter (1+ max-var)))
- body ...))))
-
-(define (compute-max-label-and-var conts)
- (values (or (intmap-prev conts) -1)
- (intmap-fold (lambda (k cont max-var)
- (match cont
- (($ $kargs names syms body)
- (apply max max-var syms))
- (($ $kfun src meta self)
- (max max-var self))
- (_ max-var)))
- conts
- -1)))
-
-(define-inlinable (fold1 f l s0)
- (let lp ((l l) (s0 s0))
- (match l
- (() s0)
- ((elt . l) (lp l (f elt s0))))))
-
-(define-inlinable (fold2 f l s0 s1)
- (let lp ((l l) (s0 s0) (s1 s1))
- (match l
- (() (values s0 s1))
- ((elt . l)
- (call-with-values (lambda () (f elt s0 s1))
- (lambda (s0 s1)
- (lp l s0 s1)))))))
-
-(define (trivial-intset set)
- "Returns the sole member of @var{set}, if @var{set} has exactly one
-member, or @code{#f} otherwise."
- (let ((first (intset-next set)))
- (and first
- (not (intset-next set (1+ first)))
- first)))
-
-(define (intmap-map proc map)
- (persistent-intmap
- (intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v)))
- map
- map)))
-
-(define (intmap-keys map)
- "Return an intset of the keys in @var{map}."
- (persistent-intset
- (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
-
-(define (invert-bijection map)
- "Assuming the values of @var{map} are integers and are unique, compute
-a map in which each value maps to its key. If the values are not
-unique, an error will be signalled."
- (intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap))
-
-(define (invert-partition map)
- "Assuming the values of @var{map} are disjoint intsets, compute a map
-in which each member of each set maps to its key. If the values are not
-disjoint, an error will be signalled."
- (intmap-fold (lambda (k v* out)
- (intset-fold (lambda (v out) (intmap-add out v k)) v* out))
- map empty-intmap))
-
-(define (intset->intmap f set)
- (persistent-intmap
- (intset-fold (lambda (label preds)
- (intmap-add! preds label (f label)))
- set empty-intmap)))
-
-(define worklist-fold
- (case-lambda
- ((f in out)
- (let lp ((in in) (out out))
- (if (eq? in empty-intset)
- out
- (call-with-values (lambda () (f in out)) lp))))
- ((f in out0 out1)
- (let lp ((in in) (out0 out0) (out1 out1))
- (if (eq? in empty-intset)
- (values out0 out1)
- (call-with-values (lambda () (f in out0 out1)) lp))))))
-
-(define fixpoint
- (case-lambda
- ((f x)
- (let lp ((x x))
- (let ((x* (f x)))
- (if (eq? x x*) x* (lp x*)))))
- ((f x0 x1)
- (let lp ((x0 x0) (x1 x1))
- (call-with-values (lambda () (f x0 x1))
- (lambda (x0* x1*)
- (if (and (eq? x0 x0*) (eq? x1 x1*))
- (values x0* x1*)
- (lp x0* x1*))))))))
-
-(define (compute-defining-expressions conts)
- (define (meet-defining-expressions old new)
- ;; If there are multiple definitions, punt and
- ;; record #f.
- #f)
- (persistent-intmap
- (intmap-fold (lambda (label cont defs)
- (match cont
- (($ $kargs _ _ ($ $continue k src exp))
- (match (intmap-ref conts k)
- (($ $kargs (_) (var))
- (intmap-add! defs var exp meet-defining-expressions))
- (_ defs)))
- (_ defs)))
- conts
- empty-intmap)))
-
-(define (compute-constant-values conts)
- (persistent-intmap
- (intmap-fold (lambda (var exp out)
- (match exp
- (($ $const val)
- (intmap-add! out var val))
- (_ out)))
- (compute-defining-expressions conts)
- empty-intmap)))
-
-(define (compute-function-body conts kfun)
- (persistent-intset
- (let visit-cont ((label kfun) (labels empty-intset))
- (cond
- ((intset-ref labels label) labels)
- (else
- (let ((labels (intset-add! labels label)))
- (match (intmap-ref conts label)
- (($ $kreceive arity k) (visit-cont k labels))
- (($ $kfun src meta self ktail kclause)
- (let ((labels (visit-cont ktail labels)))
- (if kclause
- (visit-cont kclause labels)
- labels)))
- (($ $ktail) labels)
- (($ $kclause arity kbody kalt)
- (if kalt
- (visit-cont kalt (visit-cont kbody labels))
- (visit-cont kbody labels)))
- (($ $kargs names syms ($ $continue k src exp))
- (visit-cont k (match exp
- (($ $branch k)
- (visit-cont k labels))
- (($ $prompt escape? tag k)
- (visit-cont k labels))
- (_ labels)))))))))))
-
-(define (compute-reachable-functions conts kfun)
- "Compute a mapping LABEL->LABEL..., where each key is a reachable
-$kfun and each associated value is the body of the function, as an
-intset."
- (define (intset-cons i set) (intset-add set i))
- (define (visit-fun kfun body to-visit)
- (intset-fold
- (lambda (label to-visit)
- (define (return kfun*) (fold intset-cons to-visit kfun*))
- (define (return1 kfun) (intset-add to-visit kfun))
- (define (return0) to-visit)
- (match (intmap-ref conts label)
- (($ $kargs _ _ ($ $continue _ _ exp))
- (match exp
- (($ $fun label) (return1 label))
- (($ $rec _ _ (($ $fun labels) ...)) (return labels))
- (($ $closure label nfree) (return1 label))
- (($ $callk label) (return1 label))
- (_ (return0))))
- (_ (return0))))
- body
- to-visit))
- (let lp ((to-visit (intset kfun)) (visited empty-intmap))
- (let ((to-visit (intset-subtract to-visit (intmap-keys visited))))
- (if (eq? to-visit empty-intset)
- visited
- (call-with-values
- (lambda ()
- (intset-fold
- (lambda (kfun to-visit visited)
- (let ((body (compute-function-body conts kfun)))
- (values (visit-fun kfun body to-visit)
- (intmap-add visited kfun body))))
- to-visit
- empty-intset
- visited))
- lp)))))
-
-(define* (compute-successors conts #:optional (kfun (intmap-next conts)))
- (define (visit label succs)
- (let visit ((label kfun) (succs empty-intmap))
- (define (propagate0)
- (intmap-add! succs label empty-intset))
- (define (propagate1 succ)
- (visit succ (intmap-add! succs label (intset succ))))
- (define (propagate2 succ0 succ1)
- (let ((succs (intmap-add! succs label (intset succ0 succ1))))
- (visit succ1 (visit succ0 succs))))
- (if (intmap-ref succs label (lambda (_) #f))
- succs
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (match exp
- (($ $branch kt) (propagate2 k kt))
- (($ $prompt escape? tag handler) (propagate2 k handler))
- (_ (propagate1 k))))
- (($ $kreceive arity k)
- (propagate1 k))
- (($ $kfun src meta self tail clause)
- (if clause
- (propagate2 clause tail)
- (propagate1 tail)))
- (($ $kclause arity kbody kalt)
- (if kalt
- (propagate2 kbody kalt)
- (propagate1 kbody)))
- (($ $ktail) (propagate0))))))
- (persistent-intmap (visit kfun empty-intmap)))
-
-(define* (compute-predecessors conts kfun #:key
- (labels (compute-function-body conts kfun)))
- (define (meet cdr car)
- (cons car cdr))
- (define (add-preds label preds)
- (define (add-pred k preds)
- (intmap-add! preds k label meet))
- (match (intmap-ref conts label)
- (($ $kreceive arity k)
- (add-pred k preds))
- (($ $kfun src meta self ktail kclause)
- (add-pred ktail (if kclause (add-pred kclause preds) preds)))
- (($ $ktail)
- preds)
- (($ $kclause arity kbody kalt)
- (add-pred kbody (if kalt (add-pred kalt preds) preds)))
- (($ $kargs names syms ($ $continue k src exp))
- (add-pred k
- (match exp
- (($ $branch k) (add-pred k preds))
- (($ $prompt _ _ k) (add-pred k preds))
- (_ preds))))))
- (persistent-intmap
- (intset-fold add-preds labels
- (intset->intmap (lambda (label) '()) labels))))
-
-(define (compute-reverse-post-order succs start)
- "Compute a reverse post-order numbering for a depth-first walk over
-nodes reachable from the start node."
- (let visit ((label start) (order '()) (visited empty-intset))
- (call-with-values
- (lambda ()
- (intset-fold (lambda (succ order visited)
- (if (intset-ref visited succ)
- (values order visited)
- (visit succ order visited)))
- (intmap-ref succs label)
- order
- (intset-add! visited label)))
- (lambda (order visited)
- ;; After visiting successors, add label to the reverse post-order.
- (values (cons label order) visited)))))
-
-(define (invert-graph succs)
- "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an
-intset of successors, return a graph SUCC->PRED...."
- (intmap-fold (lambda (pred succs preds)
- (intset-fold
- (lambda (succ preds)
- (intmap-add preds succ pred intset-add))
- succs
- preds))
- succs
- (intmap-map (lambda (label _) empty-intset) succs)))
-
-(define (compute-strongly-connected-components succs start)
- "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
-partitioning the labels into strongly connected components (SCCs)."
- (let ((preds (invert-graph succs)))
- (define (visit-scc scc sccs-by-label)
- (let visit ((label scc) (sccs-by-label sccs-by-label))
- (if (intmap-ref sccs-by-label label (lambda (_) #f))
- sccs-by-label
- (intset-fold visit
- (intmap-ref preds label)
- (intmap-add sccs-by-label label scc)))))
- (intmap-fold
- (lambda (label scc sccs)
- (let ((labels (intset-add empty-intset label)))
- (intmap-add sccs scc labels intset-union)))
- (fold visit-scc empty-intmap (compute-reverse-post-order succs start))
- empty-intmap)))
-
-(define (compute-sorted-strongly-connected-components edges)
- "Given a LABEL->SUCCESSOR... graph, return a list of strongly
-connected components in sorted order."
- (define nodes
- (intmap-keys edges))
- ;; Add a "start" node that links to all nodes in the graph, and then
- ;; remove it from the result.
- (define start
- (if (eq? nodes empty-intset)
- 0
- (1+ (intset-prev nodes))))
- (define components
- (intmap-remove
- (compute-strongly-connected-components (intmap-add edges start nodes)
- start)
- start))
- (define node-components
- (intmap-fold (lambda (id nodes out)
- (intset-fold (lambda (node out) (intmap-add out node id))
- nodes out))
- components
- empty-intmap))
- (define (node-component node)
- (intmap-ref node-components node))
- (define (component-successors id nodes)
- (intset-remove
- (intset-fold (lambda (node out)
- (intset-fold
- (lambda (successor out)
- (intset-add out (node-component successor)))
- (intmap-ref edges node)
- out))
- nodes
- empty-intset)
- id))
- (define component-edges
- (intmap-map component-successors components))
- (define preds
- (invert-graph component-edges))
- (define roots
- (intmap-fold (lambda (id succs out)
- (if (eq? empty-intset succs)
- (intset-add out id)
- out))
- component-edges
- empty-intset))
- ;; As above, add a "start" node that links to the roots, and remove it
- ;; from the result.
- (match (compute-reverse-post-order (intmap-add preds start roots) start)
- (((? (lambda (id) (eqv? id start))) . ids)
- (map (lambda (id) (intmap-ref components id)) ids))))
-
-;; Precondition: For each function in CONTS, the continuation names are
-;; topologically sorted.
-(define (compute-idoms conts kfun)
- ;; This is the iterative O(n^2) fixpoint algorithm, originally from
- ;; Allen and Cocke ("Graph-theoretic constructs for program flow
- ;; analysis", 1972). See the discussion in Cooper, Harvey, and
- ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
- (let ((preds-map (compute-predecessors conts kfun)))
- (define (compute-idom idoms preds)
- (define (idom-ref label)
- (intmap-ref idoms label (lambda (_) #f)))
- (match preds
- (() -1)
- ((pred) pred) ; Shortcut.
- ((pred . preds)
- (define (common-idom d0 d1)
- ;; We exploit the fact that a reverse post-order is a
- ;; topological sort, and so the idom of a node is always
- ;; numerically less than the node itself.
- (let lp ((d0 d0) (d1 d1))
- (cond
- ;; d0 or d1 can be false on the first iteration.
- ((not d0) d1)
- ((not d1) d0)
- ((= d0 d1) d0)
- ((< d0 d1) (lp d0 (idom-ref d1)))
- (else (lp (idom-ref d0) d1)))))
- (fold1 common-idom preds pred))))
- (define (adjoin-idom label preds idoms)
- (let ((idom (compute-idom idoms preds)))
- ;; Don't use intmap-add! here.
- (intmap-add idoms label idom (lambda (old new) new))))
- (fixpoint (lambda (idoms)
- (intmap-fold adjoin-idom preds-map idoms))
- empty-intmap)))
-
-;; Compute a vector containing, for each node, a list of the nodes that
-;; it immediately dominates. These are the "D" edges in the DJ tree.
-(define (compute-dom-edges idoms)
- (define (snoc cdr car) (cons car cdr))
- (persistent-intmap
- (intmap-fold (lambda (label idom doms)
- (let ((doms (intmap-add! doms label '())))
- (cond
- ((< idom 0) doms) ;; No edge to entry.
- (else (intmap-add! doms idom label snoc)))))
- idoms
- empty-intmap)))
diff --git a/module/language/cps2/verify.scm b/module/language/cps2/verify.scm
deleted file mode 100644
index 79b43f4..0000000
--- a/module/language/cps2/verify.scm
+++ /dev/null
@@ -1,306 +0,0 @@
-;;; Diagnostic checker for CPS
-;;; 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
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; A routine to detect invalid CPS.
-;;;
-;;; Code:
-
-(define-module (language cps2 verify)
- #:use-module (ice-9 match)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:use-module (language cps intset)
- #:use-module (language cps primitives)
- #:use-module (srfi srfi-11)
- #:export (verify))
-
-(define (intset-pop set)
- (match (intset-next set)
- (#f (values set #f))
- (i (values (intset-remove set i) i))))
-
-(define-syntax-rule (make-worklist-folder* seed ...)
- (lambda (f worklist seed ...)
- (let lp ((worklist worklist) (seed seed) ...)
- (call-with-values (lambda () (intset-pop worklist))
- (lambda (worklist i)
- (if i
- (call-with-values (lambda () (f i seed ...))
- (lambda (i* seed ...)
- (let add ((i* i*) (worklist worklist))
- (match i*
- (() (lp worklist seed ...))
- ((i . i*) (add i* (intset-add worklist i)))))))
- (values seed ...)))))))
-
-(define worklist-fold*
- (case-lambda
- ((f worklist seed)
- ((make-worklist-folder* seed) f worklist seed))))
-
-(define (check-distinct-vars conts)
- (define (adjoin-def var seen)
- (when (intset-ref seen var)
- (error "duplicate var name" seen var))
- (intset-add seen var))
- (intmap-fold
- (lambda (label cont seen)
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (fold1 adjoin-def vars seen))
- (($ $kfun src meta self tail clause)
- (adjoin-def self seen))
- (_ seen))
- )
- conts
- empty-intset))
-
-(define (compute-available-definitions conts kfun)
- "Compute and return a map of LABEL->VAR..., where VAR... are the
-definitions that are available at LABEL."
- (define (adjoin-def var defs)
- (when (intset-ref defs var)
- (error "var already present in defs" defs var))
- (intset-add defs var))
-
- (define (propagate defs succ out)
- (let* ((in (intmap-ref defs succ (lambda (_) #f)))
- (in* (if in (intset-intersect in out) out)))
- (if (eq? in in*)
- (values '() defs)
- (values (list succ)
- (intmap-add defs succ in* (lambda (old new) new))))))
-
- (define (visit-cont label defs)
- (let ((in (intmap-ref defs label)))
- (define (propagate0 out)
- (values '() defs))
- (define (propagate1 succ out)
- (propagate defs succ out))
- (define (propagate2 succ0 succ1 out)
- (let*-values (((changed0 defs) (propagate defs succ0 out))
- ((changed1 defs) (propagate defs succ1 out)))
- (values (append changed0 changed1) defs)))
-
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (let ((out (fold1 adjoin-def vars in)))
- (match exp
- (($ $branch kt) (propagate2 k kt out))
- (($ $prompt escape? tag handler) (propagate2 k handler out))
- (_ (propagate1 k out)))))
- (($ $kreceive arity k)
- (propagate1 k in))
- (($ $kfun src meta self tail clause)
- (let ((out (adjoin-def self in)))
- (if clause
- (propagate1 clause out)
- (propagate0 out))))
- (($ $kclause arity kbody kalt)
- (if kalt
- (propagate2 kbody kalt in)
- (propagate1 kbody in)))
- (($ $ktail) (propagate0 in)))))
-
- (worklist-fold* visit-cont
- (intset kfun)
- (intmap-add empty-intmap kfun empty-intset)))
-
-(define (intmap-for-each f map)
- (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
-
-(define (check-valid-var-uses conts kfun)
- (define (adjoin-def var defs) (intset-add defs var))
- (let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset))
- (define (visit-exp exp bound first-order)
- (define (check-use var)
- (unless (intset-ref bound var)
- (error "unbound var" var)))
- (define (visit-first-order kfun)
- (if (intset-ref first-order kfun)
- first-order
- (visit-fun kfun empty-intset (intset-add first-order kfun))))
- (match exp
- ((or ($ $const) ($ $prim)) first-order)
- ;; todo: $closure
- (($ $fun kfun)
- (visit-fun kfun bound first-order))
- (($ $closure kfun)
- (visit-first-order kfun))
- (($ $rec names vars (($ $fun kfuns) ...))
- (let ((bound (fold1 adjoin-def vars bound)))
- (fold1 (lambda (kfun first-order)
- (visit-fun kfun bound first-order))
- kfuns first-order)))
- (($ $values args)
- (for-each check-use args)
- first-order)
- (($ $call proc args)
- (check-use proc)
- (for-each check-use args)
- first-order)
- (($ $callk kfun proc args)
- (check-use proc)
- (for-each check-use args)
- (visit-first-order kfun))
- (($ $branch kt ($ $values (arg)))
- (check-use arg)
- first-order)
- (($ $branch kt ($ $primcall name args))
- (for-each check-use args)
- first-order)
- (($ $primcall name args)
- (for-each check-use args)
- first-order)
- (($ $prompt escape? tag handler)
- (check-use tag)
- first-order)))
- (intmap-fold
- (lambda (label bound first-order)
- (let ((bound (intset-union free bound)))
- (match (intmap-ref conts label)
- (($ $kargs names vars ($ $continue k src exp))
- (visit-exp exp (fold1 adjoin-def vars bound) first-order))
- (_ first-order))))
- (compute-available-definitions conts kfun)
- first-order)))
-
-(define (check-label-partition conts kfun)
- ;; A continuation can only belong to one function.
- (intmap-fold
- (lambda (kfun body seen)
- (intset-fold
- (lambda (label seen)
- (intmap-add seen label kfun
- (lambda (old new)
- (error "label used by two functions" label old new))))
- body
- seen))
- (compute-reachable-functions conts kfun)
- empty-intmap))
-
-(define (compute-reachable-labels conts kfun)
- (intmap-fold (lambda (kfun body seen) (intset-union seen body))
- (compute-reachable-functions conts kfun)
- empty-intset))
-
-(define (check-arities conts kfun)
- (define (check-arity exp cont)
- (define (assert-unary)
- (match cont
- (($ $kargs (_) (_)) #t)
- (_ (error "expected unary continuation" cont))))
- (define (assert-nullary)
- (match cont
- (($ $kargs () ()) #t)
- (_ (error "expected unary continuation" cont))))
- (define (assert-n-ary n)
- (match cont
- (($ $kargs names vars)
- (unless (= (length vars) n)
- (error "expected n-ary continuation" n cont)))
- (_ (error "expected $kargs continuation" cont))))
- (define (assert-kreceive-or-ktail)
- (match cont
- ((or ($ $kreceive) ($ $ktail)) #t)
- (_ (error "expected $kreceive or $ktail continuation" cont))))
- (match exp
- ((or ($ $const) ($ $prim) ($ $closure) ($ $fun))
- (assert-unary))
- (($ $rec names vars funs)
- (unless (= (length names) (length vars) (length funs))
- (error "invalid $rec" exp))
- (assert-n-ary (length names))
- (match cont
- (($ $kargs names vars*)
- (unless (equal? vars* vars)
- (error "bound variable mismatch" vars vars*)))))
- (($ $values args)
- (match cont
- (($ $ktail) #t)
- (_ (assert-n-ary (length args)))))
- (($ $call proc args)
- (assert-kreceive-or-ktail))
- (($ $callk k proc args)
- (assert-kreceive-or-ktail))
- (($ $branch kt exp)
- (assert-nullary)
- (match (intmap-ref conts kt)
- (($ $kargs () ()) #t)
- (cont (error "bad kt" cont))))
- (($ $primcall name args)
- (match cont
- (($ $kargs names)
- (match (prim-arity name)
- ((out . in)
- (unless (= in (length args))
- (error "bad arity to primcall" name args in))
- (unless (= out (length names))
- (error "bad return arity from primcall" name names out)))))
- (($ $kreceive)
- (when (false-if-exception (prim-arity name))
- (error "primitive should continue to $kargs, not $kreceive" name)))
- (($ $ktail)
- (unless (eq? name 'return)
- (when (false-if-exception (prim-arity name))
- (error "primitive should continue to $kargs, not $ktail"
name))))))
- (($ $prompt escape? tag handler)
- (assert-nullary)
- (match (intmap-ref conts handler)
- (($ $kreceive) #t)
- (cont (error "bad handler" cont))))))
- (let ((reachable (compute-reachable-labels conts kfun)))
- (intmap-for-each
- (lambda (label cont)
- (when (intset-ref reachable label)
- (match cont
- (($ $kargs names vars ($ $continue k src exp))
- (unless (= (length names) (length vars))
- (error "broken $kargs" label names vars))
- (check-arity exp (intmap-ref conts k)))
- (_ #t))))
- conts)))
-
-(define (check-functions-bound-once conts kfun)
- (let ((reachable (compute-reachable-labels conts kfun)))
- (define (add-fun fun functions)
- (when (intset-ref functions fun)
- (error "function already bound" fun))
- (intset-add functions fun))
- (intmap-fold
- (lambda (label cont functions)
- (if (intset-ref reachable label)
- (match cont
- (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
- (add-fun kfun functions))
- (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns)
...))))
- (fold1 add-fun kfuns functions))
- (_ functions))
- functions))
- conts
- empty-intset)))
-
-(define (verify conts)
- (check-distinct-vars conts)
- (check-label-partition conts 0)
- (check-valid-var-uses conts 0)
- (check-arities conts 0)
- (check-functions-bound-once conts 0)
- conts)
diff --git a/module/language/cps2/with-cps.scm
b/module/language/cps2/with-cps.scm
deleted file mode 100644
index f14eb93..0000000
--- a/module/language/cps2/with-cps.scm
+++ /dev/null
@@ -1,145 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Guile's CPS language is a label->cont mapping, which seems simple
-;;; enough. However it's often cumbersome to thread around the output
-;;; CPS program when doing non-trivial transformations, or when building
-;;; a CPS program from scratch. For example, when visiting an
-;;; expression during CPS conversion, we usually already know the label
-;;; and the $kargs wrapper for the cont, and just need to know the body
-;;; of that cont. However when building the body of that possibly
-;;; nested Tree-IL expression we will also need to add conts to the
-;;; result, so really it's a process that takes an incoming program,
-;;; adds conts to that program, and returns the result program and the
-;;; result term.
-;;;
-;;; It's a bit treacherous to do in a functional style as once you start
-;;; adding to a program, you shouldn't add to previous versions of that
-;;; program. Getting that right in the context of this program seed
-;;; that is threaded through the conversion requires the use of a
-;;; pattern, with-cps.
-;;;
-;;; with-cps goes like this:
-;;;
-;;; (with-cps cps clause ... tail-clause)
-;;;
-;;; Valid clause kinds are:
-;;;
-;;; (letk LABEL CONT)
-;;; (setk LABEL CONT)
-;;; (letv VAR ...)
-;;; (let$ X (PROC ARG ...))
-;;;
-;;; letk and letv create fresh CPS labels and variable names,
-;;; respectively. Labels and vars bound by letk and letv are in scope
-;;; from their point of definition onward. letv just creates fresh
-;;; variable names for use in other parts of with-cps, while letk binds
-;;; fresh labels to values and adds them to the resulting program. The
-;;; right-hand-side of letk, CONT, is passed to build-cont, so it should
-;;; be a valid production of that language. setk is like letk but it
-;;; doesn't create a fresh label name.
-;;;
-;;; let$ delegates processing to a sub-computation. The form (PROC ARG
-;;; ...) is syntactically altered to be (PROC CPS ARG ...), where CPS is
-;;; the value of the program being built, at that point in the
-;;; left-to-right with-cps execution. That form is is expected to
-;;; evaluate to two values: the new CPS term, and the value to bind to
-;;; X. X is in scope for the following with-cps clauses. The name was
-;;; chosen because the $ is reminiscent of the $ in CPS data types.
-;;;
-;;; The result of the with-cps form is determined by the tail clause,
-;;; which may be of these kinds:
-;;;
-;;; ($ (PROC ARG ...))
-;;; (setk LABEL CONT)
-;;; EXP
-;;;
-;;; $ is like let$, but in tail position. If the tail clause is setk,
-;;; then only one value is returned, the resulting CPS program.
-;;; Otherwise EXP is any kind of expression, which should not add to the
-;;; resulting program. Ending the with-cps with EXP is equivalant to
-;;; returning (values CPS EXP).
-;;;
-;;; It's a bit of a monad, innit? Don't tell anyone though!
-;;;
-;;; Sometimes you need to just bind some constants to CPS values.
-;;; with-cps-constants is there for you. For example:
-;;;
-;;; (with-cps-constants cps ((foo 34))
-;;; (build-term ($values (foo))))
-;;;
-;;; The body of with-cps-constants is a with-cps clause, or a sequence
-;;; of such clauses. But usually you will want with-cps-constants
-;;; inside a with-cps, so it usually looks like this:
-;;;
-;;; (with-cps cps
-;;; ...
-;;; ($ (with-cps-constants ((foo 34))
-;;; (build-term ($values (foo))))))
-;;;
-;;; which is to say that the $ or the let$ adds the CPS argument for us.
-;;;
-;;; Code:
-
-(define-module (language cps2 with-cps)
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps intmap)
- #:export (with-cps with-cps-constants))
-
-(define-syntax with-cps
- (syntax-rules (letk setk letv let$ $)
- ((_ (exp ...) clause ...)
- (let ((cps (exp ...)))
- (with-cps cps clause ...)))
- ((_ cps (letk label cont) clause ...)
- (let-fresh (label) ()
- (with-cps (intmap-add! cps label (build-cont cont))
- clause ...)))
- ((_ cps (setk label cont))
- (intmap-add! cps label (build-cont cont)
- (lambda (old new) new)))
- ((_ cps (setk label cont) clause ...)
- (with-cps (with-cps cps (setk label cont))
- clause ...))
- ((_ cps (letv v ...) clause ...)
- (let-fresh () (v ...)
- (with-cps cps clause ...)))
- ((_ cps (let$ var (proc arg ...)) clause ...)
- (call-with-values (lambda () (proc cps arg ...))
- (lambda (cps var)
- (with-cps cps clause ...))))
- ((_ cps ($ (proc arg ...)))
- (proc cps arg ...))
- ((_ cps exp)
- (values cps exp))))
-
-(define-syntax with-cps-constants
- (syntax-rules ()
- ((_ cps () clause ...)
- (with-cps cps clause ...))
- ((_ cps ((var val) (var* val*) ...) clause ...)
- (let ((x val))
- (with-cps cps
- (letv var)
- (let$ body (with-cps-constants ((var* val*) ...)
- clause ...))
- (letk label ($kargs ('var) (var) ,body))
- (build-term ($continue label #f ($const x))))))))
diff --git a/module/language/tree-il/compile-cps2.scm
b/module/language/tree-il/compile-cps.scm
similarity index 99%
rename from module/language/tree-il/compile-cps2.scm
rename to module/language/tree-il/compile-cps.scm
index 932a49d..59d2d7d 100644
--- a/module/language/tree-il/compile-cps2.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -49,20 +49,20 @@
;;;
;;; Code:
-(define-module (language tree-il compile-cps2)
+(define-module (language tree-il compile-cps)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold filter-map))
#:use-module (srfi srfi-26)
#:use-module ((system foreign) #:select (make-pointer pointer->scm))
- #:use-module (language cps2)
- #:use-module (language cps2 utils)
- #:use-module (language cps2 with-cps)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps with-cps)
#:use-module (language cps primitives)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
#:use-module (language tree-il)
#:use-module (language cps intmap)
- #:export (compile-cps2))
+ #:export (compile-cps))
;;; Guile's semantics are that a toplevel lambda captures a reference on
;;; the current module, and that all contained lambdas use that module
@@ -931,7 +931,7 @@ integer."
(_ exp)))
exp))
-(define (compile-cps2 exp env opts)
+(define (compile-cps exp env opts)
(values (cps-convert/thunk
(canonicalize (optimize-tree-il exp env opts)))
env
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index d1c7326..10c20a0 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -1,6 +1,6 @@
;;; Tree Intermediate Language
-;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2013, 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
@@ -22,7 +22,7 @@
#:use-module (system base language)
#:use-module (system base pmatch)
#:use-module (language tree-il)
- #:use-module (language tree-il compile-cps2)
+ #:use-module (language tree-il compile-cps)
#:export (tree-il))
(define (write-tree-il exp . port)
@@ -42,5 +42,5 @@
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
- #:compilers `((cps2 . ,compile-cps2))
+ #:compilers `((cps . ,compile-cps))
#:for-humans? #f)
- [Guile-commits] 03/13: Utils refactors, (continued)
- [Guile-commits] 03/13: Utils refactors, Andy Wingo, 2015/07/22
- [Guile-commits] 07/13: Fix bad return shuffles for multiply-used $kreceive conts, Andy Wingo, 2015/07/22
- [Guile-commits] 01/13: Reify primitives in CPS2, Andy Wingo, 2015/07/22
- [Guile-commits] 09/13: Fix CPS2 compute-successors, Andy Wingo, 2015/07/22
- [Guile-commits] 06/13: Fix error printing some wrong-num-args backtraces, Andy Wingo, 2015/07/22
- [Guile-commits] 02/13: Add intset-prev and intset-fold-right, Andy Wingo, 2015/07/22
- [Guile-commits] 11/13: Compile CPS2 directly to bytecode, Andy Wingo, 2015/07/22
- [Guile-commits] 08/13: intset-intersect bugfix, Andy Wingo, 2015/07/22
- [Guile-commits] 10/13: Slot allocation and bytecode compilation from CPS2., Andy Wingo, 2015/07/22
- [Guile-commits] 12/13: Remove CPS1 language, Andy Wingo, 2015/07/22
- [Guile-commits] 13/13: Rename CPS2 to CPS,
Andy Wingo <=