[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Add missing files
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Add missing files |
|
Date: |
Wed, 22 Jul 2015 16:27:43 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 4aabc205cc488a5440a637a7ec4d842ea8647be6
Author: Andy Wingo <address@hidden>
Date: Wed Jul 22 18:27:37 2015 +0200
Add missing files
Last commit meant to rename files, not delete them. Whoops!
---
module/language/cps.scm | 358 ++++++
module/language/cps/closure-conversion.scm | 824 ++++++++++++++
module/language/cps/compile-bytecode.scm | 433 ++++++++
module/language/cps/constructors.scm | 98 ++
module/language/cps/contification.scm | 475 ++++++++
module/language/cps/cse.scm | 449 ++++++++
module/language/cps/dce.scm | 399 +++++++
module/language/cps/effects-analysis.scm | 484 ++++++++
module/language/cps/elide-values.scm | 88 ++
module/language/cps/optimize.scm | 106 ++
module/language/cps/prune-bailouts.scm | 86 ++
module/language/cps/prune-top-level-scopes.scm | 63 ++
module/language/cps/reify-primitives.scm | 167 +++
module/language/cps/renumber.scm | 217 ++++
module/language/cps/self-references.scm | 79 ++
module/language/cps/simplify.scm | 267 +++++
module/language/cps/slot-allocation.scm | 995 +++++++++++++++++
module/language/cps/spec.scm | 37 +
module/language/cps/specialize-primcalls.scm | 59 +
module/language/cps/split-rec.scm | 174 +++
module/language/cps/type-fold.scm | 425 +++++++
module/language/cps/types.scm | 1408 ++++++++++++++++++++++++
module/language/cps/utils.scm | 477 ++++++++
module/language/cps/verify.scm | 306 +++++
module/language/cps/with-cps.scm | 145 +++
25 files changed, 8619 insertions(+), 0 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
new file mode 100644
index 0000000..b66bc38
--- /dev/null
+++ b/module/language/cps.scm
@@ -0,0 +1,358 @@
+;;; 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 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 cps)
+ #: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/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
new file mode 100644
index 0000000..29577a9
--- /dev/null
+++ b/module/language/cps/closure-conversion.scm
@@ -0,0 +1,824 @@
+;;; 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 cps closure-conversion)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold
+ filter-map
+ ))
+ #:use-module (srfi srfi-11)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps with-cps)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
+ #:export (convert-closures))
+
+(define (compute-function-bodies conts kfun)
+ "Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in
+conts."
+ (let visit-fun ((kfun kfun) (out empty-intmap))
+ (let ((body (compute-function-body conts kfun)))
+ (intset-fold
+ (lambda (label out)
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
+ (visit-fun kfun out))
+ (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
+ (fold visit-fun out kfun))
+ (_ out)))
+ body
+ (intmap-add out kfun body)))))
+
+(define (compute-program-body functions)
+ (intmap-fold (lambda (label body out) (intset-union body out))
+ functions
+ empty-intset))
+
+(define (filter-reachable conts functions)
+ (let ((reachable (compute-program-body functions)))
+ (intmap-fold
+ (lambda (label cont out)
+ (if (intset-ref reachable label)
+ out
+ (intmap-remove out label)))
+ conts conts)))
+
+(define (compute-non-operator-uses conts)
+ (persistent-intset
+ (intmap-fold
+ (lambda (label cont uses)
+ (define (add-use var uses) (intset-add! uses var))
+ (define (add-uses vars uses)
+ (match vars
+ (() uses)
+ ((var . vars) (add-uses vars (add-use var uses)))))
+ (match cont
+ (($ $kargs _ _ ($ $continue _ _ exp))
+ (match exp
+ ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses)
+ (($ $values args)
+ (add-uses args uses))
+ (($ $call proc args)
+ (add-uses args uses))
+ (($ $branch kt ($ $values (arg)))
+ (add-use arg uses))
+ (($ $branch kt ($ $primcall name args))
+ (add-uses args uses))
+ (($ $primcall name args)
+ (add-uses args uses))
+ (($ $prompt escape? tag handler)
+ (add-use tag uses))))
+ (_ uses)))
+ conts
+ empty-intset)))
+
+(define (compute-singly-referenced-labels conts body)
+ (define (add-ref label single multiple)
+ (define (ref k single multiple)
+ (if (intset-ref single k)
+ (values single (intset-add! multiple k))
+ (values (intset-add! single k) multiple)))
+ (define (ref0) (values single multiple))
+ (define (ref1 k) (ref k single multiple))
+ (define (ref2 k k*)
+ (if k*
+ (let-values (((single multiple) (ref k single multiple)))
+ (ref k* single multiple))
+ (ref1 k)))
+ (match (intmap-ref conts label)
+ (($ $kreceive arity k) (ref1 k))
+ (($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
+ (($ $ktail) (ref0))
+ (($ $kclause arity kbody kalt) (ref2 kbody kalt))
+ (($ $kargs names syms ($ $continue k src exp))
+ (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
+ (let*-values (((single multiple) (values empty-intset empty-intset))
+ ((single multiple) (intset-fold add-ref body single multiple)))
+ (intset-subtract (persistent-intset single)
+ (persistent-intset multiple))))
+
+(define (compute-function-names conts functions)
+ "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function
+whose bound vars we know."
+ (define (add-named-fun var kfun out)
+ (let ((self (match (intmap-ref conts kfun)
+ (($ $kfun src meta self) self))))
+ (intmap-add out kfun (intset var self))))
+ (intmap-fold
+ (lambda (label body out)
+ (let ((single (compute-singly-referenced-labels conts body)))
+ (intset-fold
+ (lambda (label out)
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue k _ ($ $fun kfun)))
+ (if (intset-ref single k)
+ (match (intmap-ref conts k)
+ (($ $kargs (_) (var)) (add-named-fun var kfun out))
+ (_ out))
+ out))
+ (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun)
...))))
+ (unless (intset-ref single k)
+ (error "$rec continuation has multiple predecessors??"))
+ (fold add-named-fun out vars kfun))
+ (_ out)))
+ body
+ out)))
+ functions
+ empty-intmap))
+
+(define (compute-well-known-functions conts bound->label)
+ "Compute a set of labels indicating the well-known functions in
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/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
new file mode 100644
index 0000000..61f1e07
--- /dev/null
+++ b/module/language/cps/compile-bytecode.scm
@@ -0,0 +1,433 @@
+;;; 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 cps compile-bytecode)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:use-module (language cps primitives)
+ #:use-module (language cps slot-allocation)
+ #:use-module (language cps utils)
+ #:use-module (language cps closure-conversion)
+ #:use-module (language cps optimize)
+ #:use-module (language cps reify-primitives)
+ #:use-module (language cps 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/cps/constructors.scm
b/module/language/cps/constructors.scm
new file mode 100644
index 0000000..f860951
--- /dev/null
+++ b/module/language/cps/constructors.scm
@@ -0,0 +1,98 @@
+;;; 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 cps constructors)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps 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/cps/contification.scm
b/module/language/cps/contification.scm
new file mode 100644
index 0000000..4a398d7
--- /dev/null
+++ b/module/language/cps/contification.scm
@@ -0,0 +1,475 @@
+;;; 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 cps contification)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-11)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (language cps)
+ #:use-module (language cps renumber)
+ #:use-module (language cps 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. CPS 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/cps/cse.scm b/module/language/cps/cse.scm
new file mode 100644
index 0000000..def5420
--- /dev/null
+++ b/module/language/cps/cse.scm
@@ -0,0 +1,449 @@
+;;; 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 cps cse)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps 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/cps/dce.scm b/module/language/cps/dce.scm
new file mode 100644
index 0000000..5463f5b
--- /dev/null
+++ b/module/language/cps/dce.scm
@@ -0,0 +1,399 @@
+;;; 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 cps dce)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:use-module (language cps effects-analysis)
+ #:use-module (language cps renumber)
+ #:use-module (language cps types)
+ #:use-module (language cps 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/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
new file mode 100644
index 0000000..874eb78
--- /dev/null
+++ b/module/language/cps/effects-analysis.scm
@@ -0,0 +1,484 @@
+;;; 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 cps effects-analysis)
+ #:use-module (language cps)
+ #:use-module (language cps 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/cps/elide-values.scm
b/module/language/cps/elide-values.scm
new file mode 100644
index 0000000..81ccfc2
--- /dev/null
+++ b/module/language/cps/elide-values.scm
@@ -0,0 +1,88 @@
+;;; 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 cps elide-values)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps 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/cps/optimize.scm b/module/language/cps/optimize.scm
new file mode 100644
index 0000000..83a3f2d
--- /dev/null
+++ b/module/language/cps/optimize.scm
@@ -0,0 +1,106 @@
+;;; 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 CPS.
+;;;
+;;; Code:
+
+(define-module (language cps optimize)
+ #:use-module (ice-9 match)
+ #:use-module (language cps constructors)
+ #:use-module (language cps contification)
+ #:use-module (language cps cse)
+ #:use-module (language cps dce)
+ #:use-module (language cps elide-values)
+ #:use-module (language cps prune-top-level-scopes)
+ #:use-module (language cps prune-bailouts)
+ #:use-module (language cps self-references)
+ #:use-module (language cps simplify)
+ #:use-module (language cps specialize-primcalls)
+ #:use-module (language cps split-rec)
+ #:use-module (language cps type-fold)
+ #:use-module (language cps 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/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
new file mode 100644
index 0000000..7c10319
--- /dev/null
+++ b/module/language/cps/prune-bailouts.scm
@@ -0,0 +1,86 @@
+;;; 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 cps prune-bailouts)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps with-cps)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
+ #:export (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/cps/prune-top-level-scopes.scm
b/module/language/cps/prune-top-level-scopes.scm
new file mode 100644
index 0000000..1970d1b
--- /dev/null
+++ b/module/language/cps/prune-top-level-scopes.scm
@@ -0,0 +1,63 @@
+;;; 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 cps prune-top-level-scopes)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps 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/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
new file mode 100644
index 0000000..014593a
--- /dev/null
+++ b/module/language/cps/reify-primitives.scm
@@ -0,0 +1,167 @@
+;;; 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 cps reify-primitives)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps 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/cps/renumber.scm b/module/language/cps/renumber.scm
new file mode 100644
index 0000000..8bab863
--- /dev/null
+++ b/module/language/cps/renumber.scm
@@ -0,0 +1,217 @@
+;;; 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 cps renumber)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language cps)
+ #:use-module (language cps 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/cps/self-references.scm
b/module/language/cps/self-references.scm
new file mode 100644
index 0000000..cbdaaa1
--- /dev/null
+++ b/module/language/cps/self-references.scm
@@ -0,0 +1,79 @@
+;;; 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 cps self-references)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (language cps)
+ #:use-module (language cps 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/cps/simplify.scm b/module/language/cps/simplify.scm
new file mode 100644
index 0000000..a53bdbf
--- /dev/null
+++ b/module/language/cps/simplify.scm
@@ -0,0 +1,267 @@
+;;; 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 cps simplify)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps 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/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
new file mode 100644
index 0000000..74e71c4
--- /dev/null
+++ b/module/language/cps/slot-allocation.scm
@@ -0,0 +1,995 @@
+;; 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 cps 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 cps)
+ #:use-module (language cps 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/cps/spec.scm b/module/language/cps/spec.scm
new file mode 100644
index 0000000..7330885
--- /dev/null
+++ b/module/language/cps/spec.scm
@@ -0,0 +1,37 @@
+;;; 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 cps spec)
+ #:use-module (system base language)
+ #:use-module (language cps)
+ #:use-module (language cps compile-bytecode)
+ #:export (cps))
+
+(define* (write-cps exp #:optional (port (current-output-port)))
+ (write (unparse-cps exp) port))
+
+(define-language cps
+ #:title "CPS 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/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
new file mode 100644
index 0000000..c15fbdb
--- /dev/null
+++ b/module/language/cps/specialize-primcalls.scm
@@ -0,0 +1,59 @@
+;;; 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 cps specialize-primcalls)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps 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/cps/split-rec.scm
b/module/language/cps/split-rec.scm
new file mode 100644
index 0000000..2551ac6
--- /dev/null
+++ b/module/language/cps/split-rec.scm
@@ -0,0 +1,174 @@
+;;; 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 cps split-rec)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps with-cps)
+ #:use-module (language cps intmap)
+ #:use-module (language cps intset)
+ #:export (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/cps/type-fold.scm
b/module/language/cps/type-fold.scm
new file mode 100644
index 0000000..2104b09
--- /dev/null
+++ b/module/language/cps/type-fold.scm
@@ -0,0 +1,425 @@
+;;; 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 cps type-fold)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps utils)
+ #:use-module (language cps renumber)
+ #:use-module (language cps types)
+ #:use-module (language cps 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/cps/types.scm b/module/language/cps/types.scm
new file mode 100644
index 0000000..55cde27
--- /dev/null
+++ b/module/language/cps/types.scm
@@ -0,0 +1,1408 @@
+;;; 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 cps types)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps 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/cps/utils.scm b/module/language/cps/utils.scm
new file mode 100644
index 0000000..fa4673c
--- /dev/null
+++ b/module/language/cps/utils.scm
@@ -0,0 +1,477 @@
+;;; 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 cps utils)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language cps)
+ #: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/cps/verify.scm b/module/language/cps/verify.scm
new file mode 100644
index 0000000..f4413af
--- /dev/null
+++ b/module/language/cps/verify.scm
@@ -0,0 +1,306 @@
+;;; 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 cps verify)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps 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/cps/with-cps.scm b/module/language/cps/with-cps.scm
new file mode 100644
index 0000000..45cb9c4
--- /dev/null
+++ b/module/language/cps/with-cps.scm
@@ -0,0 +1,145 @@
+;;; 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 cps with-cps)
+ #:use-module (language cps)
+ #:use-module (language cps 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))))))))