[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 09/10: Remove CPS optimization passes and closure conver
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 09/10: Remove CPS optimization passes and closure conversion |
|
Date: |
Thu, 16 Jul 2015 08:06:31 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 420423f9a09902cf5a839a0d9df4ca8d79611fea
Author: Andy Wingo <address@hidden>
Date: Thu Jul 16 07:58:36 2015 +0200
Remove CPS optimization passes and closure conversion
* module/language/cps/closure-conversion.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/type-fold.scm:
* module/language/cps/types.scm: Remove these files, obsoleted by CPS2.
* module/Makefile.am: Update.
---
module/Makefile.am | 14 -
module/language/cps/closure-conversion.scm | 565 ----------
module/language/cps/constructors.scm | 104 --
module/language/cps/contification.scm | 414 -------
module/language/cps/cse.scm | 545 ---------
module/language/cps/dce.scm | 363 ------
module/language/cps/effects-analysis.scm | 499 ---------
module/language/cps/elide-values.scm | 109 --
module/language/cps/prune-bailouts.scm | 101 --
module/language/cps/prune-top-level-scopes.scm | 114 --
module/language/cps/self-references.scm | 79 --
module/language/cps/simplify.scm | 328 ------
module/language/cps/specialize-primcalls.scm | 107 --
module/language/cps/type-fold.scm | 443 --------
module/language/cps/types.scm | 1424 ------------------------
15 files changed, 0 insertions(+), 5209 deletions(-)
diff --git a/module/Makefile.am b/module/Makefile.am
index 270699b..188cc76 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -123,27 +123,13 @@ TREE_IL_LANG_SOURCES =
\
CPS_LANG_SOURCES = \
language/cps.scm \
- language/cps/closure-conversion.scm \
language/cps/compile-bytecode.scm \
- language/cps/constructors.scm \
- language/cps/contification.scm \
- language/cps/cse.scm \
- language/cps/dce.scm \
language/cps/dfg.scm \
- language/cps/effects-analysis.scm \
- language/cps/elide-values.scm \
language/cps/primitives.scm \
- language/cps/prune-bailouts.scm \
- language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
language/cps/renumber.scm \
- language/cps/self-references.scm \
language/cps/slot-allocation.scm \
- language/cps/simplify.scm \
language/cps/spec.scm \
- language/cps/specialize-primcalls.scm \
- language/cps/type-fold.scm \
- language/cps/types.scm \
language/cps/verify.scm
CPS2_LANG_SOURCES = \
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
deleted file mode 100644
index 49ff30f..0000000
--- a/module/language/cps/closure-conversion.scm
+++ /dev/null
@@ -1,565 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; This pass converts a CPS term in such a way that no function has any
-;;; free variables. Instead, closures are built explicitly with
-;;; make-closure primcalls, and free variables are referenced through
-;;; the closure.
-;;;
-;;; Closure conversion also removes any $rec expressions that
-;;; contification did not handle. See (language cps) for a further
-;;; discussion of $rec.
-;;;
-;;; Code:
-
-(define-module (language cps closure-conversion)
- #:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (fold
- filter-map
- lset-union lset-difference
- list-index))
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-26)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:export (convert-closures))
-
-;; free := var ...
-
-(define (analyze-closures exp dfg)
- "Compute the set of free variables for all $fun instances in
address@hidden"
- (let ((bound-vars (make-hash-table))
- (free-vars (make-hash-table))
- (named-funs (make-hash-table))
- (well-known-vars (make-bitvector (var-counter) #t))
- (letrec-conts (make-hash-table)))
- (define (add-named-fun! var cont)
- (hashq-set! named-funs var cont)
- (match cont
- (($ $cont label ($ $kfun src meta self))
- (unless (eq? var self)
- (hashq-set! bound-vars label var)))))
- (define (clear-well-known! var)
- (bitvector-set! well-known-vars var #f))
- (define (compute-well-known-labels)
- (let ((bv (make-bitvector (label-counter) #f)))
- (hash-for-each
- (lambda (var cont)
- (match cont
- (($ $cont label ($ $kfun src meta self))
- (unless (equal? var self)
- (bitvector-set! bv label
- (and (bitvector-ref well-known-vars var)
- (bitvector-ref well-known-vars self)))))))
- named-funs)
- bv))
- (define (union a b)
- (lset-union eq? a b))
- (define (difference a b)
- (lset-difference eq? a b))
- (define (visit-cont cont bound)
- (match cont
- (($ $cont label ($ $kargs names vars body))
- (visit-term body (append vars bound)))
- (($ $cont label ($ $kfun src meta self tail clause))
- (add-named-fun! self cont)
- (let ((free (if clause
- (visit-cont clause (list self))
- '())))
- (hashq-set! free-vars label free)
- (difference free bound)))
- (($ $cont label ($ $kclause arity body alternate))
- (let ((free (visit-cont body bound)))
- (if alternate
- (union (visit-cont alternate bound) free)
- free)))
- (($ $cont) '())))
- (define (visit-term term bound)
- (match term
- (($ $letk conts body)
- (fold (lambda (cont free)
- (union (visit-cont cont bound) free))
- (visit-term body bound)
- conts))
- (($ $continue k src ($ $fun body))
- (match (lookup-predecessors k dfg)
- ((_) (match (lookup-cont k dfg)
- (($ $kargs (name) (var))
- (add-named-fun! var body))))
- (_ #f))
- (visit-cont body bound))
- (($ $continue k src ($ $rec names vars (($ $fun cont) ...)))
- (hashq-set! letrec-conts k (lookup-cont k dfg))
- (let ((bound (append vars bound)))
- (for-each add-named-fun! vars cont)
- (fold (lambda (cont free)
- (union (visit-cont cont bound) free))
- '()
- cont)))
- (($ $continue k src exp)
- (visit-exp exp bound))))
- (define (visit-exp exp bound)
- (define (adjoin var free)
- (if (or (memq var bound) (memq var free))
- free
- (cons var free)))
- (match exp
- ((or ($ $const) ($ $prim)) '())
- (($ $call proc args)
- (for-each clear-well-known! args)
- (fold adjoin (adjoin proc '()) args))
- (($ $primcall name args)
- (for-each clear-well-known! args)
- (fold adjoin '() args))
- (($ $branch kt exp)
- (visit-exp exp bound))
- (($ $values args)
- (for-each clear-well-known! args)
- (fold adjoin '() args))
- (($ $prompt escape? tag handler)
- (clear-well-known! tag)
- (adjoin tag '()))))
-
- (let ((free (visit-cont exp '())))
- (unless (null? free)
- (error "Expected no free vars in toplevel thunk" free exp))
- (values bound-vars free-vars named-funs (compute-well-known-labels)
- letrec-conts))))
-
-(define (prune-free-vars free-vars named-funs well-known var-aliases)
- (define (well-known? label)
- (bitvector-ref well-known label))
- (let ((eliminated (make-bitvector (label-counter) #f))
- (label-aliases (make-vector (label-counter) #f)))
- (let lp ((label 0))
- (let ((label (bit-position #t well-known label)))
- (when label
- (match (hashq-ref free-vars label)
- ;; Mark all well-known closures that have no free variables
- ;; for elimination.
- (() (bitvector-set! eliminated label #t))
- ;; Replace well-known closures that have just one free
- ;; variable by references to that free variable.
- ((var)
- (vector-set! label-aliases label var))
- (_ #f))
- (lp (1+ label)))))
- ;; Iterative free variable elimination.
- (let lp ()
- (let ((recurse? #f))
- (define (adjoin elt list)
- ;; Normally you wouldn't see duplicates in a free variable
- ;; list, but with aliases that is possible.
- (if (memq elt list) list (cons elt list)))
- (define (prune-free closure-label free)
- (match free
- (() '())
- ((var . free)
- (let lp ((var var) (alias-stack '()))
- (match (hashq-ref named-funs var)
- (($ $cont label)
- (cond
- ((bitvector-ref eliminated label)
- (prune-free closure-label free))
- ((vector-ref label-aliases label)
- => (lambda (var)
- (cond
- ((memq label alias-stack)
- ;; We have found a set of mutually recursive
- ;; well-known procedures, each of which only
- ;; closes over one of the others. Mark them
- ;; all for elimination.
- (for-each (lambda (label)
- (bitvector-set! eliminated label #t)
- (set! recurse? #t))
- alias-stack)
- (prune-free closure-label free))
- (else
- (lp var (cons label alias-stack))))))
- ((eq? closure-label label)
- ;; Eliminate self-reference.
- (prune-free closure-label free))
- (else
- (adjoin var (prune-free closure-label free)))))
- (_ (adjoin var (prune-free closure-label free))))))))
- (hash-for-each-handle
- (lambda (pair)
- (match pair
- ((label . ()) #t)
- ((label . free)
- (let ((orig-nfree (length free))
- (free (prune-free label free)))
- (set-cdr! pair free)
- ;; If we managed to eliminate one or more free variables
- ;; from a well-known function, it could be that we can
- ;; eliminate or alias this function as well.
- (when (and (well-known? label)
- (< (length free) orig-nfree))
- (match free
- (()
- (bitvector-set! eliminated label #t)
- (set! recurse? #t))
- ((var)
- (vector-set! label-aliases label var)
- (set! recurse? #t))
- (_ #t)))))))
- free-vars)
- ;; Iterate to fixed point.
- (when recurse? (lp))))
- ;; Populate var-aliases from label-aliases.
- (hash-for-each (lambda (var cont)
- (match cont
- (($ $cont label)
- (let ((alias (vector-ref label-aliases label)))
- (when alias
- (vector-set! var-aliases var alias))))))
- named-funs)))
-
-(define (convert-one bound label fun free-vars named-funs well-known aliases
- letrec-conts)
- (define (well-known? label)
- (bitvector-ref well-known label))
-
- (let ((free (hashq-ref free-vars label))
- (self-known? (well-known? label))
- (self (match fun (($ $kfun _ _ self) self))))
- (define (convert-free-var 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}."
- (cond
- ((list-index (cut eq? <> var) free)
- => (lambda (free-idx)
- (match (cons self-known? free)
- ;; A reference to the one free var of a well-known function.
- ((#t _) (k self))
- ;; A reference to one of the two free vars in a well-known
- ;; function.
- ((#t _ _)
- (let-fresh (k*) (var*)
- (build-cps-term
- ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
- ($continue k* #f
- ($primcall (match free-idx (0 'car) (1 'cdr))
(self)))))))
- (_
- (let-fresh (k* kidx) (idx var*)
- (build-cps-term
- ($letk ((kidx ($kargs ('idx) (idx)
- ($letk ((k* ($kargs (var*) (var*) ,(k
var*))))
- ($continue k* #f
- ($primcall
- (cond
- ((not self-known?) 'free-ref)
- ((<= free-idx #xff)
'vector-ref/immediate)
- (else 'vector-ref))
- (self idx)))))))
- ($continue kidx #f ($const free-idx)))))))))
- ((eq? var bound) (k self))
- (else (k var))))
-
- (define (convert-free-vars 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
- (() (k '()))
- ((var . vars)
- (convert-free-var var
- (lambda (var)
- (convert-free-vars vars
- (lambda (vars)
- (k (cons var vars)))))))))
-
- (define (allocate-closure src name var label known? free body)
- "Allocate a new closure."
- (match (cons known? free)
- ((#f . _)
- (let-fresh (k*) ()
- (build-cps-term
- ($letk ((k* ($kargs (name) (var) ,body)))
- ($continue k* src
- ($closure label (length free)))))))
- ((#t)
- ;; Well-known closure with no free variables; elide the
- ;; binding entirely.
- body)
- ((#t _)
- ;; Well-known closure with one free variable; the free var is the
- ;; closure, and no new binding need be made.
- body)
- ((#t _ _)
- ;; Well-known closure with two free variables; the closure is a
- ;; pair.
- (let-fresh (kinit kfalse) (false)
- (build-cps-term
- ($letk ((kinit ($kargs (name) (var)
- ,body))
- (kfalse ($kargs ('false) (false)
- ($continue kinit src
- ($primcall 'cons (false false))))))
- ($continue kfalse src ($const #f))))))
- ;; Well-known callee with more than two free variables; the closure
- ;; is a vector.
- ((#t . _)
- (let ((nfree (length free)))
- (let-fresh (kinit klen kfalse) (false len-var)
- (build-cps-term
- ($letk ((kinit ($kargs (name) (var) ,body))
- (kfalse
- ($kargs ('false) (false)
- ($letk ((klen
- ($kargs ('len) (len-var)
- ($continue kinit src
- ($primcall (if (<= nfree #xff)
- 'make-vector/immediate
- 'make-vector)
- (len-var false))))))
- ($continue klen src ($const nfree))))))
- ($continue kfalse src ($const #f)))))))))
-
- (define (init-closure src var known? closure-free body)
- "Initialize the free variables @var{closure-free} in a closure
-bound to @var{var}, and continue with @var{body}."
- (match (cons known? closure-free)
- ;; Well-known callee with no free variables; no initialization
- ;; necessary.
- ((#t) body)
- ;; Well-known callee with one free variable; no initialization
- ;; necessary.
- ((#t _) body)
- ;; Well-known callee with two free variables; do a set-car! and
- ;; set-cdr!.
- ((#t v0 v1)
- (let-fresh (kcar kcdr) ()
- (convert-free-var
- v0
- (lambda (v0)
- (build-cps-term
- ($letk ((kcar ($kargs () ()
- ,(convert-free-var
- v1
- (lambda (v1)
- (build-cps-term
- ($letk ((kcdr ($kargs () () ,body)))
- ($continue kcdr src
- ($primcall 'set-cdr! (var
v1))))))))))
- ($continue kcar 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.
- (_
- (fold (lambda (free idx body)
- (let-fresh (k) (idxvar)
- (build-cps-term
- ($letk ((k ($kargs () () ,body)))
- ,(convert-free-var
- free
- (lambda (free)
- (build-cps-term
- ($letconst (('idx idxvar idx))
- ($continue k src
- ($primcall (cond
- ((not known?) 'free-set!)
- ((<= idx #xff)
'vector-set!/immediate)
- (else 'vector-set!))
- (var idxvar free)))))))))))
- body
- closure-free
- (iota (length closure-free))))))
-
- ;; Load the closure for a known call. The callee may or may not be
- ;; known at all call sites.
- (define (convert-known-proc-call var label self self-known? free k)
- ;; Well-known closures with one free variable are replaced at their
- ;; use sites by uses of the one free variable. The use sites of a
- ;; well-known closures are only in well-known proc calls, and in
- ;; free lists of other closures. Here we handle the call case; the
- ;; free list case is handled by prune-free-vars.
- (define (rename var)
- (let ((var* (vector-ref aliases var)))
- (if var*
- (rename var*)
- var)))
- (match (cons (well-known? label)
- (hashq-ref free-vars label))
- ((#t)
- ;; Calling a well-known procedure with no free variables; pass #f
- ;; as the closure.
- (let-fresh (k*) (v*)
- (build-cps-term
- ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
- ($continue k* #f ($const #f))))))
- ((#t _)
- ;; Calling a well-known procedure with one free variable; pass
- ;; the free variable as the closure.
- (convert-free-var (rename var) k))
- (_
- (convert-free-var var k))))
-
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kargs names vars body))
- (label ($kargs names vars ,(visit-term body))))
- (($ $cont label ($ $kfun src meta self tail clause))
- (label ($kfun src meta self ,tail
- ,(and clause (visit-cont clause)))))
- (($ $cont label ($ $kclause arity body alternate))
- (label ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont) ,cont)))
- (define (maybe-visit-cont cont)
- (match cont
- ;; We will inline the $kargs that binds letrec vars in place of
- ;; the $rec expression.
- (($ $cont label)
- (and (not (hashq-ref letrec-conts label))
- (visit-cont cont)))))
- (define (visit-term term)
- (match term
- (($ $letk conts body)
- (build-cps-term
- ($letk ,(filter-map maybe-visit-cont conts) ,(visit-term body))))
-
- (($ $continue k src (or ($ $const) ($ $prim)))
- term)
-
- (($ $continue k src ($ $fun ($ $cont kfun)))
- (let ((fun-free (hashq-ref free-vars kfun)))
- (match (cons (well-known? kfun) fun-free)
- ((known?)
- (build-cps-term
- ($continue k src ,(if known?
- (build-cps-exp ($const #f))
- (build-cps-exp ($closure kfun 0))))))
- ((#t _)
- ;; 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.
- (build-cps-term
- ($continue k src ,(build-cps-exp ($const #f)))))
- (_
- (let-fresh () (var)
- (allocate-closure
- src #f var kfun (well-known? kfun) fun-free
- (init-closure
- src var (well-known? kfun) fun-free
- (build-cps-term ($continue k src ($values (var)))))))))))
-
- ;; Remove letrec.
- (($ $continue k src ($ $rec names vars funs))
- (let lp ((in (map list names vars funs))
- (bindings (lambda (body) body))
- (body (match (hashq-ref letrec-conts k)
- ;; Remove these letrec bindings, as we're
- ;; going to inline the body after building
- ;; each closure separately.
- (($ $kargs names syms body)
- (visit-term body)))))
- (match in
- (() (bindings body))
- (((name var ($ $fun
- (and fun-body
- ($ $cont kfun ($ $kfun src))))) . in)
- (let ((fun-free (hashq-ref free-vars kfun)))
- (lp in
- (lambda (body)
- (allocate-closure
- src name var kfun (well-known? kfun) fun-free
- (bindings body)))
- (init-closure
- src var (well-known? kfun) fun-free
- body)))))))
-
- (($ $continue k src ($ $call proc args))
- (match (hashq-ref named-funs proc)
- (($ $cont kfun)
- (convert-known-proc-call
- proc kfun self self-known? free
- (lambda (proc)
- (convert-free-vars args
- (lambda (args)
- (build-cps-term
- ($continue k src
- ($callk kfun proc args))))))))
- (#f
- (convert-free-vars (cons proc args)
- (match-lambda
- ((proc . args)
- (build-cps-term
- ($continue k src
- ($call proc args)))))))))
-
- (($ $continue k src ($ $primcall name args))
- (convert-free-vars args
- (lambda (args)
- (build-cps-term
- ($continue k src ($primcall name args))))))
-
- (($ $continue k src ($ $branch kt ($ $primcall name args)))
- (convert-free-vars args
- (lambda (args)
- (build-cps-term
- ($continue k src
- ($branch kt ($primcall name args)))))))
-
- (($ $continue k src ($ $branch kt ($ $values (arg))))
- (convert-free-var arg
- (lambda (arg)
- (build-cps-term
- ($continue k src
- ($branch kt ($values (arg))))))))
-
- (($ $continue k src ($ $values args))
- (convert-free-vars args
- (lambda (args)
- (build-cps-term
- ($continue k src ($values args))))))
-
- (($ $continue k src ($ $prompt escape? tag handler))
- (convert-free-var tag
- (lambda (tag)
- (build-cps-term
- ($continue k src
- ($prompt escape? tag handler))))))))
- (visit-cont (build-cps-cont (label ,fun)))))
-
-(define (convert-closures fun)
- "Convert free reference in @var{exp} to primcalls to @code{free-ref},
-and allocate and initialize flat closures."
- (let ((dfg (compute-dfg fun)))
- (with-fresh-name-state-from-dfg dfg
- (call-with-values (lambda () (analyze-closures fun dfg))
- (lambda (bound-vars free-vars named-funs well-known letrec-conts)
- (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
- (aliases (make-vector (var-counter) #f)))
- (prune-free-vars free-vars named-funs well-known aliases)
- (build-cps-term
- ($program
- ,(map (lambda (label)
- (convert-one (hashq-ref bound-vars label) label
- (lookup-cont label dfg)
- free-vars named-funs well-known aliases
- letrec-conts))
- labels)))))))))
diff --git a/module/language/cps/constructors.scm
b/module/language/cps/constructors.scm
deleted file mode 100644
index bbe779d..0000000
--- a/module/language/cps/constructors.scm
+++ /dev/null
@@ -1,104 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Constructor inlining turns "list" primcalls into a series of conses,
-;;; and does similar transformations for "vector".
-;;;
-;;; Code:
-
-(define-module (language cps constructors)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-26)
- #:use-module (language cps)
- #:export (inline-constructors))
-
-(define (inline-constructors* fun)
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont sym ($ $kargs names syms body))
- (sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
- (($ $cont sym ($ $kclause arity body alternate))
- (sym ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont)
- ,cont)))
- (define (visit-term term)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map visit-cont conts)
- ,(visit-term body)))
- (($ $continue k src ($ $primcall 'list args))
- ,(let-fresh (kvalues) (val)
- (build-cps-term
- ($letk ((kvalues ($kargs ('val) (val)
- ($continue k src
- ($primcall 'values (val))))))
- ,(let lp ((args args) (k kvalues))
- (match args
- (()
- (build-cps-term
- ($continue k src ($const '()))))
- ((arg . args)
- (let-fresh (ktail) (tail)
- (build-cps-term
- ($letk ((ktail ($kargs ('tail) (tail)
- ($continue k src
- ($primcall 'cons (arg tail))))))
- ,(lp args ktail)))))))))))
- (($ $continue k src ($ $primcall 'vector args))
- ,(let-fresh (kalloc) (vec len init)
- (define (initialize args n)
- (match args
- (()
- (build-cps-term
- ($continue k src ($primcall 'values (vec)))))
- ((arg . args)
- (let-fresh (knext) (idx)
- (build-cps-term
- ($letk ((knext ($kargs () ()
- ,(initialize args (1+ n)))))
- ($letconst (('idx idx n))
- ($continue knext src
- ($primcall 'vector-set! (vec idx arg))))))))))
- (build-cps-term
- ($letk ((kalloc ($kargs ('vec) (vec)
- ,(initialize args 0))))
- ($letconst (('len len (length args))
- ('init init #f))
- ($continue kalloc src
- ($primcall 'make-vector (len init))))))))
- (($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(visit-fun fun)))
- (($ $continue k src ($ $rec names syms funs))
- ($continue k src ($rec names syms (map visit-fun funs))))
- (($ $continue)
- ,term)))
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(inline-constructors* body)))))
-
- (visit-cont fun))
-
-(define (inline-constructors fun)
- (with-fresh-name-state fun
- (inline-constructors* fun)))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
deleted file mode 100644
index 1f70231..0000000
--- a/module/language/cps/contification.scm
+++ /dev/null
@@ -1,414 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Contification is a pass that turns $fun instances into $cont
-;;; instances if all calls to the $fun return to the same continuation.
-;;; This is a more rigorous variant of our old "fixpoint labels
-;;; allocation" optimization.
-;;;
-;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
-;;; and Weeks's "Contification using Dominators".
-;;;
-;;; Code:
-
-(define-module (language cps contification)
- #:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (concatenate filter-map))
- #:use-module (srfi srfi-26)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:use-module (language cps primitives)
- #:use-module (language bytecode)
- #:export (contify))
-
-(define (compute-contification fun)
- (let* ((dfg (compute-dfg fun))
- (scope-table (make-hash-table))
- (call-substs '())
- (cont-substs '())
- (cont-splices (make-hash-table)))
- (define (subst-call! sym arities body-ks)
- (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
- (define (subst-return! old-tail new-tail)
- (set! cont-substs (acons old-tail new-tail cont-substs)))
- (define (splice-conts! scope conts)
- (for-each (match-lambda
- (($ $cont k) (hashq-set! scope-table k scope)))
- conts)
- (hashq-set! cont-splices scope
- (append conts (hashq-ref cont-splices scope '()))))
-
- (define (lookup-return-cont k)
- (match (assq-ref cont-substs k)
- (#f k)
- (k (lookup-return-cont k))))
-
- ;; If K is a continuation that binds one variable, and it has only
- ;; one predecessor, return that variable.
- (define (bound-symbol k)
- (match (lookup-cont k dfg)
- (($ $kargs (_) (sym))
- (match (lookup-predecessors k dfg)
- ((_)
- ;; K has one predecessor, the one that defined SYM.
- sym)
- (_ #f)))
- (_ #f)))
-
- (define (extract-arities clause)
- (match clause
- (($ $cont _ ($ $kclause arity body alternate))
- (cons arity (extract-arities alternate)))
- (#f '())))
- (define (extract-bodies clause)
- (match clause
- (($ $cont _ ($ $kclause arity body alternate))
- (cons body (extract-bodies alternate)))
- (#f '())))
-
- (define (contify-fun term-k sym self tail arities bodies)
- (contify-funs term-k
- (list sym) (list self) (list tail)
- (list arities) (list bodies)))
-
- ;; Given a set of mutually recursive functions bound to local
- ;; variables SYMS, with self symbols SELFS, tail continuations
- ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
- ;; contify them if we can prove that they all return to the same
- ;; continuation. Returns a true value on success, and false
- ;; otherwise.
- (define (contify-funs term-k syms selfs tails arities bodies)
- (define (unused? sym)
- (null? (lookup-uses sym dfg)))
-
- ;; Are the given args compatible with any of the arities?
- (define (applicable? proc args)
- (let lp ((arities (assq-ref (map cons syms arities) proc)))
- (match arities
- ((($ $arity req () #f () #f) . arities)
- (or (= (length args) (length req))
- (lp arities)))
- ;; If we reached the end of the arities, fail. Also fail if
- ;; the next arity in the list has optional, keyword, or rest
- ;; arguments.
- (_ #f))))
-
- ;; If the use of PROC in continuation USE is a call to PROC that
- ;; is compatible with one of the procedure's arities, return the
- ;; target continuation. Otherwise return #f.
- (define (call-target use proc)
- (match (find-call (lookup-cont use dfg))
- (($ $continue k src ($ $call proc* args))
- (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
- ;; Converge more quickly by resolving already-contified
- ;; call targets.
- (lookup-return-cont k)))
- (_ #f)))
-
- ;; If this set of functions is always called with one
- ;; continuation, not counting tail calls between the functions,
- ;; return that continuation.
- (define (find-common-continuation)
- (let visit-syms ((syms syms) (k #f))
- (match syms
- (() k)
- ((sym . syms)
- (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
- (match uses
- (() (visit-syms syms k))
- ((use . uses)
- (and=> (call-target use sym)
- (lambda (k*)
- (cond
- ((memq k* tails) (visit-uses uses k))
- ((not k) (visit-uses uses k*))
- ((eq? k k*) (visit-uses uses k))
- (else #f)))))))))))
-
- ;; Given that the functions are called with the common
- ;; continuation K, determine the scope at which to contify the
- ;; functions. If K is in scope in the term, we go ahead and
- ;; contify them there. Otherwise the scope is inside the letrec
- ;; body, and so choose the scope in which the continuation is
- ;; defined, whose free variables are a superset of the free
- ;; variables of the functions.
- ;;
- ;; There is some slight trickiness here. Call-target already uses
- ;; the information we compute within this pass. Previous
- ;; contifications may cause functions to be contified not at their
- ;; point of definition but at their point of non-recursive use.
- ;; That will cause the scope nesting to change. (It may
- ;; effectively push a function deeper down the tree -- the second
- ;; case above, a call within the letrec body.) What if we contify
- ;; to the tail of a previously contified function? We have to
- ;; track what the new scope tree will be when asking whether K
- ;; will be bound in TERM-K's scope, not the scope tree that
- ;; existed when we started the pass.
- ;;
- ;; FIXME: Does this choose the right scope for contified let-bound
- ;; functions?
- (define (find-contification-scope k)
- (define (scope-contains? scope k)
- (let ((k-scope (or (hashq-ref scope-table k)
- (let ((k-scope (lookup-block-scope k dfg)))
- (hashq-set! scope-table k k-scope)
- k-scope))))
- (or (eq? scope k-scope)
- (and k-scope (scope-contains? scope k-scope)))))
-
- ;; Find the scope of K.
- (define (continuation-scope k)
- (or (hashq-ref scope-table k)
- (let ((scope (lookup-block-scope k dfg)))
- (hashq-set! scope-table k scope)
- scope)))
-
- (let ((k-scope (continuation-scope k)))
- (if (scope-contains? k-scope term-k)
- term-k
- (match (lookup-cont k-scope dfg)
- (($ $kfun src meta self tail clause)
- ;; K is the tail of some function. If that function
- ;; has just one clause, return that clause. Otherwise
- ;; bail.
- (match clause
- (($ $cont _ ($ $kclause arity ($ $cont kargs) #f))
- kargs)
- (_ #f)))
- (_ k-scope)))))
-
- ;; We are going to contify. Mark all SYMs for replacement in
- ;; calls, and mark the tail continuations for replacement by K.
- ;; Arrange for the continuations to be spliced into SCOPE.
- (define (enqueue-contification! k scope)
- (for-each (lambda (sym tail arities bodies)
- (match bodies
- ((($ $cont body-k) ...)
- (subst-call! sym arities body-k)))
- (subst-return! tail k))
- syms tails arities bodies)
- (splice-conts! scope (concatenate bodies))
- #t)
-
- ;; "Call me maybe"
- (and (and-map unused? selfs)
- (and=> (find-common-continuation)
- (lambda (k)
- (and=> (find-contification-scope k)
- (cut enqueue-contification! k <>))))))
-
- (define (visit-fun term)
- (match term
- (($ $fun body)
- (visit-cont body))))
- (define (visit-cont cont)
- (match cont
- (($ $cont sym ($ $kargs _ _ body))
- (visit-term body sym))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (when clause (visit-cont clause)))
- (($ $cont sym ($ $kclause arity body alternate))
- (visit-cont body)
- (when alternate (visit-cont alternate)))
- (($ $cont)
- #t)))
- (define (visit-term term term-k)
- (match term
- (($ $letk conts body)
- (for-each visit-cont conts)
- (visit-term body term-k))
- (($ $continue k src exp)
- (match exp
- (($ $fun
- ($ $cont fun-k
- ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause)))
- (if (and=> (bound-symbol k)
- (lambda (sym)
- (contify-fun term-k sym self tail-k
- (extract-arities clause)
- (extract-bodies clause))))
- (begin
- (for-each visit-cont (extract-bodies clause)))
- (visit-fun exp)))
- (($ $rec names syms funs)
- (define (split-components nsf)
- ;; FIXME: Compute strongly-connected components. Currently
- ;; we just put non-recursive functions in their own
- ;; components, and lump everything else in the remaining
- ;; component.
- (define (recursive? k)
- (or-map (cut variable-free-in? <> k dfg) syms))
- (let lp ((nsf nsf) (rec '()))
- (match nsf
- (()
- (if (null? rec)
- '()
- (list rec)))
- (((and elt (n s ($ $fun ($ $cont kfun))))
- . nsf)
- (if (recursive? kfun)
- (lp nsf (cons elt rec))
- (cons (list elt) (lp nsf rec)))))))
- (define (extract-arities+bodies clauses)
- (values (map extract-arities clauses)
- (map extract-bodies clauses)))
- (define (visit-component component)
- (match component
- (((name sym fun) ...)
- (match fun
- ((($ $fun
- ($ $cont fun-k
- ($ $kfun src meta self ($ $cont tail-k ($ $ktail))
- clause)))
- ...)
- (call-with-values (lambda () (extract-arities+bodies
clause))
- (lambda (arities bodies)
- ;; Technically the procedures are created in
- ;; term-k but bound for use in k. But, there is
- ;; a tight link between term-k and k, as they
- ;; are in the same block. Mark k as the
- ;; contification scope, because that's where
- ;; they'll be used. Perhaps we can fix this
- ;; with the new CPS dialect that doesn't have
- ;; $letk.
- (if (contify-funs k sym self tail-k arities bodies)
- (for-each (cut for-each visit-cont <>) bodies)
- (for-each visit-fun fun)))))))))
- (for-each visit-component
- (split-components (map list names syms funs))))
- (_ #t)))))
-
- (visit-cont fun)
- (values call-substs cont-substs cont-splices)))
-
-(define (apply-contification fun call-substs cont-substs cont-splices)
- (define (contify-call src proc args)
- (and=> (assq-ref call-substs proc)
- (lambda (clauses)
- (let lp ((clauses clauses))
- (match clauses
- (() (error "invalid contification"))
- (((($ $arity req () #f () #f) . k) . clauses)
- (if (= (length req) (length args))
- (build-cps-term
- ($continue k src
- ($values args)))
- (lp clauses)))
- ((_ . clauses) (lp clauses)))))))
- (define (continue k src exp)
- (define (lookup-return-cont k)
- (match (assq-ref cont-substs k)
- (#f k)
- (k (lookup-return-cont k))))
- (let ((k* (lookup-return-cont k)))
- ;; We are contifying this return. It must be a call or a
- ;; primcall to values, return, or return-values.
- (if (eq? k k*)
- (build-cps-term ($continue k src ,exp))
- (rewrite-cps-term exp
- (($ $primcall 'return (val))
- ($continue k* src ($primcall 'values (val))))
- (($ $values vals)
- ($continue k* src ($primcall 'values vals)))
- (_ ($continue k* src ,exp))))))
- (define (splice-continuations term-k term)
- (match (hashq-ref cont-splices term-k)
- (#f term)
- ((cont ...)
- (let lp ((term term))
- (rewrite-cps-term term
- (($ $letk conts* body)
- ($letk ,(append conts* (filter-map visit-cont cont))
- ,body))
- (body
- ($letk ,(filter-map visit-cont cont)
- ,body)))))))
- (define (visit-fun term)
- (rewrite-cps-exp term
- (($ $fun body)
- ($fun ,(visit-cont body)))))
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kargs names syms body))
- ;; Remove bindings for functions that have been contified.
- ,(rewrite-cps-cont (filter (match-lambda
- ((name sym) (not (assq sym call-substs))))
- (map list names syms))
- (((names syms) ...)
- (label ($kargs names syms ,(visit-term body label))))))
- (($ $cont label ($ $kfun src meta self tail clause))
- (label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
- (($ $cont label ($ $kclause arity body alternate))
- (label ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont)
- ,cont)))
- (define (visit-term term term-k)
- (match term
- (($ $letk conts body)
- ;; Visit the body first, so we rewrite depth-first.
- (let lp ((body (visit-term body term-k)))
- ;; Because we attach contified functions on a particular
- ;; term-k, and one term-k can correspond to an arbitrarily
- ;; nested sequence of $letk instances, normalize so that all
- ;; continuations are bound by one $letk -- guaranteeing that
- ;; they are in the same scope.
- (rewrite-cps-term body
- (($ $letk conts* body)
- ($letk ,(append conts* (filter-map visit-cont conts))
- ,body))
- (body
- ($letk ,(filter-map visit-cont conts)
- ,body)))))
- (($ $continue k src exp)
- (splice-continuations
- term-k
- (match exp
- (($ $fun
- ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k))))
- ;; If the function's tail continuation has been substituted,
- ;; that means it has been contified.
- (continue k src
- (if (assq tail-k cont-substs)
- (build-cps-exp ($values ()))
- (visit-fun exp))))
- (($ $rec names syms funs)
- (match (filter (match-lambda
- ((n s f) (not (assq s call-substs))))
- (map list names syms funs))
- (() (continue k src (build-cps-exp ($values ()))))
- (((names syms funs) ...)
- (continue k src
- (build-cps-exp
- ($rec names syms (map visit-fun funs)))))))
- (($ $call proc args)
- (or (contify-call src proc args)
- (continue k src exp)))
- (_ (continue k src exp)))))))
- (visit-cont fun))
-
-(define (contify fun)
- (call-with-values (lambda () (compute-contification fun))
- (lambda (call-substs cont-substs cont-splices)
- (if (null? call-substs)
- fun
- ;; Iterate to fixed point.
- (contify
- (apply-contification fun call-substs cont-substs cont-splices))))))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
deleted file mode 100644
index c8a57ca..0000000
--- a/module/language/cps/cse.scm
+++ /dev/null
@@ -1,545 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Common subexpression elimination for CPS.
-;;;
-;;; Code:
-
-(define-module (language cps cse)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:use-module (language cps effects-analysis)
- #:use-module (language cps renumber)
- #:use-module (language cps intset)
- #:use-module (rnrs bytevectors)
- #:export (eliminate-common-subexpressions))
-
-(define (cont-successors cont)
- (match cont
- (($ $kargs names syms body)
- (let lp ((body body))
- (match body
- (($ $letk conts body) (lp body))
- (($ $continue k src exp)
- (match exp
- (($ $prompt escape? tag handler) (list k handler))
- (($ $branch kt) (list k kt))
- (_ (list k)))))))
-
- (($ $kreceive arity k) (list k))
-
- (($ $kclause arity ($ $cont kbody)) (list kbody))
-
- (($ $kfun src meta self tail clause)
- (let lp ((clause clause))
- (match clause
- (($ $cont kclause ($ $kclause _ _ alt))
- (cons kclause (lp alt)))
- (#f '()))))
-
- (($ $kfun src meta self tail #f) '())
-
- (($ $ktail) '())))
-
-(define (compute-available-expressions dfg min-label label-count idoms)
- "Compute and return the continuations that may be reached if flow
-reaches a continuation N. Returns a vector of intsets, whose first
-index corresponds to MIN-LABEL, and so on."
- (let* ((effects (compute-effects dfg min-label label-count))
- ;; Vector of intsets, indicating that at a continuation N, the
- ;; values from continuations M... are available.
- (avail (make-vector label-count #f))
- (revisit-label #f))
-
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (define (get-effects label) (vector-ref effects (label->idx label)))
-
- (define (propagate! pred succ out)
- (let* ((succ-idx (label->idx succ))
- (in (match (lookup-predecessors succ dfg)
- ;; Fast path: normal control flow.
- ((_) out)
- ;; Slow path: control-flow join.
- (_ (cond
- ((vector-ref avail succ-idx)
- => (lambda (in)
- (intset-intersect in out)))
- (else out))))))
- (when (and (<= succ pred)
- (or (not revisit-label) (< succ revisit-label))
- (not (eq? in (vector-ref avail succ-idx))))
- ;; Arrange to revisit if this is not a forward edge and the
- ;; available set changed.
- (set! revisit-label succ))
- (vector-set! avail succ-idx in)))
-
- (define (clobber label in)
- (let ((fx (get-effects label)))
- (cond
- ((not (causes-effect? fx &write))
- ;; Fast-path if this expression clobbers nothing.
- in)
- (else
- ;; Kill clobbered expressions. There is no need to check on
- ;; any label before than the last dominating label that
- ;; clobbered everything.
- (let ((first (let lp ((dom label))
- (let* ((dom (vector-ref idoms (label->idx dom))))
- (and (< min-label dom)
- (let ((fx (vector-ref effects (label->idx
dom))))
- (if (causes-all-effects? fx)
- dom
- (lp dom))))))))
- (let lp ((i first) (in in))
- (cond
- ((intset-next in i)
- => (lambda (i)
- (if (effect-clobbers? fx (vector-ref effects (label->idx
i)))
- (lp (1+ i) (intset-remove in i))
- (lp (1+ i) in))))
- (else in))))))))
-
- (synthesize-definition-effects! effects dfg min-label label-count)
-
- (vector-set! avail 0 empty-intset)
-
- (let lp ((n 0))
- (cond
- ((< n label-count)
- (let* ((label (idx->label n))
- ;; It's possible for "in" to be #f if it has no
- ;; predecessors, as is the case for the ktail of a
- ;; function with an iloop.
- (in (or (vector-ref avail n) empty-intset))
- (out (intset-add (clobber label in) label)))
- (lookup-predecessors label dfg)
- (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
- (match succs
- (() (lp (1+ n)))
- ((succ . succs)
- (propagate! label succ out)
- (visit-succs succs))))))
- (revisit-label
- (let ((n (label->idx revisit-label)))
- (set! revisit-label #f)
- (lp n)))
- (else
- (values avail effects))))))
-
-(define (compute-truthy-expressions dfg min-label label-count)
- "Compute a \"truth map\", indicating which expressions can be shown to
-be true and/or false at each of LABEL-COUNT expressions in DFG, starting
-from MIN-LABEL. Returns a vector of intsets, each intset twice as long
-as LABEL-COUNT. 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."
- (let ((boolv (make-vector label-count #f))
- (revisit-label #f))
- (define (label->idx label) (- label min-label))
- (define (idx->label idx) (+ idx min-label))
- (define (true-idx idx) (ash idx 1))
- (define (false-idx idx) (1+ (ash idx 1)))
-
- (define (propagate! pred succ out)
- (let* ((succ-idx (label->idx succ))
- (in (match (lookup-predecessors succ dfg)
- ;; Fast path: normal control flow.
- ((_) out)
- ;; Slow path: control-flow join.
- (_ (cond
- ((vector-ref boolv succ-idx)
- => (lambda (in)
- (intset-intersect in out)))
- (else out))))))
- (when (and (<= succ pred)
- (or (not revisit-label) (< succ revisit-label))
- (not (eq? in (vector-ref boolv succ-idx))))
- (set! revisit-label succ))
- (vector-set! boolv succ-idx in)))
-
- (vector-set! boolv 0 empty-intset)
-
- (let lp ((n 0))
- (cond
- ((< n label-count)
- (let* ((label (idx->label n))
- ;; It's possible for "in" to be #f if it has no
- ;; predecessors, as is the case for the ktail of a
- ;; function with an iloop.
- (in (or (vector-ref boolv n) empty-intset)))
- (define (default-propagate)
- (let visit-succs ((succs (cont-successors (lookup-cont label
dfg))))
- (match succs
- (() (lp (1+ n)))
- ((succ . succs)
- (propagate! label succ in)
- (visit-succs succs)))))
- (match (lookup-cont label dfg)
- (($ $kargs names syms body)
- (match (find-call body)
- (($ $continue k src ($ $branch kt))
- (propagate! label k (intset-add in (false-idx n)))
- (propagate! label kt (intset-add in (true-idx n)))
- (lp (1+ n)))
- (_ (default-propagate))))
- (_ (default-propagate)))))
- (revisit-label
- (let ((n (label->idx revisit-label)))
- (set! revisit-label #f)
- (lp n)))
- (else boolv)))))
-
-;; Returns a map of label-idx -> (var-idx ...) indicating the variables
-;; defined by a given labelled expression.
-(define (compute-defs dfg min-label label-count)
- (define (cont-defs k)
- (match (lookup-cont k dfg)
- (($ $kargs names vars) vars)
- (_ '())))
- (define (idx->label idx) (+ idx min-label))
- (let ((defs (make-vector label-count '())))
- (let lp ((n 0))
- (when (< n label-count)
- (vector-set!
- defs
- n
- (match (lookup-cont (idx->label n) dfg)
- (($ $kargs _ _ body)
- (match (find-call body)
- (($ $continue k) (cont-defs k))))
- (($ $kreceive arity kargs)
- (cont-defs kargs))
- (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
- syms)
- (($ $kfun src meta self) (list self))
- (($ $ktail) '())))
- (lp (1+ n))))
- defs))
-
-(define (compute-label-and-var-ranges fun)
- (match fun
- (($ $cont kfun ($ $kfun src meta self))
- ((make-local-cont-folder min-label label-count min-var var-count)
- (lambda (k cont min-label label-count min-var var-count)
- (let ((min-label (min k min-label))
- (label-count (1+ label-count)))
- (match cont
- (($ $kargs names vars body)
- (values min-label label-count
- (fold min min-var vars) (+ var-count (length vars))))
- (($ $kfun src meta self)
- (values min-label label-count (min self min-var) (1+ var-count)))
- (_
- (values min-label label-count min-var var-count)))))
- fun kfun 0 self 0))))
-
-;; 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-equivalent-subexpressions fun dfg)
- (define (compute min-label label-count min-var var-count idoms avail effects)
- (let ((defs (compute-defs dfg min-label label-count))
- (var-substs (make-vector var-count #f))
- (equiv-labels (make-vector label-count #f))
- (equiv-set (make-hash-table)))
- (define (idx->label idx) (+ idx min-label))
- (define (label->idx label) (- label min-label))
- (define (idx->var idx) (+ idx min-var))
- (define (var->idx var) (- var min-var))
-
- (define (for-each/2 f l1 l2)
- (unless (= (length l1) (length l2))
- (error "bad lengths" l1 l2))
- (let lp ((l1 l1) (l2 l2))
- (when (pair? l1)
- (f (car l1) (car l2))
- (lp (cdr l1) (cdr l2)))))
-
- (define (subst-var var)
- ;; It could be that the var is free in this function; if so, its
- ;; name will be less than min-var.
- (let ((idx (var->idx var)))
- (if (<= 0 idx)
- (vector-ref var-substs idx)
- var)))
-
- (define (compute-exp-key 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 (map subst-var args)))
- (($ $branch _ ($ $primcall name args))
- (cons* 'primcall name (map subst-var args)))
- (($ $branch) #f)
- (($ $values args) #f)
- (($ $prompt escape? tag handler) #f)))
-
- (define (add-auxiliary-definitions! label exp-key)
- (let ((defs (vector-ref defs (label->idx 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-var 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-var pair)) car)
- (add-def! `(primcall cdr ,(subst-var 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-var 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
- (() #f) ;; allocate-struct in tail or kreceive position.
- ((struct)
- (add-def! `(primcall struct-vtable ,(subst-var 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))))
-
- ;; The initial substs vector is the identity map.
- (let lp ((var min-var))
- (when (< (var->idx var) var-count)
- (vector-set! var-substs (var->idx var) var)
- (lp (1+ var))))
-
- ;; Traverse the labels in fun in forward order, which will visit
- ;; dominators first.
- (let lp ((label min-label))
- (when (< (label->idx label) label-count)
- (match (lookup-cont label dfg)
- (($ $kargs names vars body)
- (match (find-call body)
- (($ $continue k src exp)
- (let* ((exp-key (compute-exp-key exp))
- (equiv (hash-ref equiv-set exp-key '()))
- (lidx (label->idx label))
- (fx (vector-ref effects lidx))
- (avail (vector-ref avail lidx)))
- (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))))
- (hash-set! equiv-set exp-key
- (acons label (vector-ref defs lidx)
- equiv))))
- (((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.
- (vector-set! equiv-labels lidx head)
- ;; If we dominate the successor, mark vars
- ;; for substitution.
- (when (= label (vector-ref idoms (label->idx k)))
- (for-each/2
- (lambda (var subst-var)
- (vector-set! var-substs (var->idx var)
subst-var))
- (vector-ref defs lidx)
- vars)))))))
- ;; 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 exp-key)))))
- (_ #f))
- (lp (1+ label))))
- (values (compute-dom-edges idoms min-label)
- equiv-labels min-label var-substs min-var)))
-
- (call-with-values (lambda () (compute-label-and-var-ranges fun))
- (lambda (min-label label-count min-var var-count)
- (let ((idoms (compute-idoms dfg min-label label-count)))
- (call-with-values
- (lambda ()
- (compute-available-expressions dfg min-label label-count idoms))
- (lambda (avail effects)
- (compute min-label label-count min-var var-count
- idoms avail effects)))))))
-
-(define (apply-cse fun dfg
- doms equiv-labels min-label var-substs min-var boolv)
- (define (idx->label idx) (+ idx min-label))
- (define (label->idx label) (- label min-label))
- (define (idx->var idx) (+ idx min-var))
- (define (var->idx var) (- var min-var))
- (define (true-idx idx) (ash idx 1))
- (define (false-idx idx) (1+ (ash idx 1)))
-
- (define (subst-var var)
- ;; It could be that the var is free in this function; if so,
- ;; its name will be less than min-var.
- (let ((idx (var->idx var)))
- (if (<= 0 idx)
- (vector-ref var-substs idx)
- var)))
-
- (define (visit-fun-cont cont)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kfun src meta self tail clause))
- (label ($kfun src meta self ,tail
- ,(and clause (visit-fun-cont clause)))))
- (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
- (label ($kclause ,arity ,(visit-cont kbody body)
- ,(and alternate (visit-fun-cont alternate)))))))
-
- (define (visit-cont label cont)
- (rewrite-cps-cont cont
- (($ $kargs names vars body)
- (label ($kargs names vars ,(visit-term body label))))
- (_ (label ,cont))))
-
- (define (visit-term term label)
- (define (visit-exp exp)
- ;; We shouldn't see $fun here.
- (rewrite-cps-exp exp
- ((or ($ $const) ($ $prim)) ,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))))
-
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(cse body dfg)))))
-
- (define (visit-exp* k src exp)
- (match exp
- (($ $fun)
- (build-cps-term
- ($continue k src ,(visit-fun exp))))
- (($ $rec names syms funs)
- (build-cps-term
- ($continue k src ($rec names syms (map visit-fun funs)))))
- (_
- (cond
- ((vector-ref equiv-labels (label->idx label))
- => (match-lambda
- ((equiv . vars)
- (let* ((eidx (label->idx equiv)))
- (match exp
- (($ $branch kt exp)
- (let* ((bool (vector-ref boolv (label->idx label)))
- (t (intset-ref bool (true-idx eidx)))
- (f (intset-ref bool (false-idx eidx))))
- (if (eqv? t f)
- (build-cps-term
- ($continue k src
- ($branch kt ,(visit-exp exp))))
- (build-cps-term
- ($continue (if t kt k) src ($values ()))))))
- (_
- ;; FIXME: can we always continue with $values? why
- ;; or why not?
- (rewrite-cps-term (lookup-cont k dfg)
- (($ $kargs)
- ($continue k src ($values vars)))
- (_
- ($continue k src ,(visit-exp exp))))))))))
- (else
- (build-cps-term
- ($continue k src ,(visit-exp exp))))))))
-
- (define (visit-dom-conts label)
- (let ((cont (lookup-cont label dfg)))
- (match cont
- (($ $ktail) '())
- (($ $kargs) (list (visit-cont label cont)))
- (else
- (cons (visit-cont label cont)
- (append-map visit-dom-conts
- (vector-ref doms (label->idx label))))))))
-
- (rewrite-cps-term term
- (($ $letk conts body)
- ,(visit-term body label))
- (($ $continue k src exp)
- ,(let ((conts (append-map visit-dom-conts
- (vector-ref doms (label->idx label)))))
- (if (null? conts)
- (visit-exp* k src exp)
- (build-cps-term
- ($letk ,conts ,(visit-exp* k src exp))))))))
-
- (visit-fun-cont fun))
-
-(define (cse fun dfg)
- (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
- (lambda (doms equiv-labels min-label var-substs min-var)
- (apply-cse fun dfg doms equiv-labels min-label var-substs min-var
- (compute-truthy-expressions dfg
- min-label (vector-length
doms))))))
-
-(define (eliminate-common-subexpressions fun)
- (call-with-values (lambda () (renumber fun))
- (lambda (fun nlabels nvars)
- (cse fun (compute-dfg fun)))))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
deleted file mode 100644
index 34ffc3a..0000000
--- a/module/language/cps/dce.scm
+++ /dev/null
@@ -1,363 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Various optimizations can inline calls from one continuation to some
-;;; other continuation, usually in response to information about the
-;;; return arity of the call. That leaves us with dangling
-;;; continuations that aren't reachable any more from the procedure
-;;; entry. This pass will remove them.
-;;;
-;;; This pass also 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 (srfi srfi-9)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:use-module (language cps effects-analysis)
- #:use-module (language cps renumber)
- #:use-module (language cps types)
- #:export (eliminate-dead-code))
-
-(define-record-type $fun-data
- (make-fun-data min-label effects live-conts defs)
- fun-data?
- (min-label fun-data-min-label)
- (effects fun-data-effects)
- (live-conts fun-data-live-conts)
- (defs fun-data-defs))
-
-(define (compute-defs dfg min-label label-count)
- (define (cont-defs k)
- (match (lookup-cont k dfg)
- (($ $kargs names vars) vars)
- (_ #f)))
- (define (idx->label idx) (+ idx min-label))
- (let ((defs (make-vector label-count #f)))
- (let lp ((n 0))
- (when (< n label-count)
- (vector-set!
- defs
- n
- (match (lookup-cont (idx->label n) dfg)
- (($ $kargs _ _ body)
- (match (find-call body)
- (($ $continue k src exp)
- (match exp
- (($ $branch) #f)
- (_ (cont-defs k))))))
- (($ $kreceive arity kargs)
- (cont-defs kargs))
- (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
- syms)
- (($ $kfun src meta self) (list self))
- (($ $ktail) #f)))
- (lp (1+ n))))
- defs))
-
-(define (elide-type-checks! fun dfg effects min-label label-count)
- (match fun
- (($ $cont kfun ($ $kfun src meta min-var))
- (let ((typev (infer-types fun dfg)))
- (define (idx->label idx) (+ idx min-label))
- (define (var->idx var) (- var min-var))
- (define (visit-primcall lidx fx name args)
- (when (primcall-types-check? typev (idx->label lidx) name args)
- (vector-set! effects lidx
- (logand fx (lognot &type-check)))))
- (let lp ((lidx 0))
- (when (< lidx label-count)
- (let ((fx (vector-ref effects lidx)))
- (unless (causes-all-effects? fx)
- (when (causes-effect? fx &type-check)
- (match (lookup-cont (idx->label lidx) dfg)
- (($ $kargs _ _ term)
- (match (find-call term)
- (($ $continue k src ($ $primcall name args))
- (visit-primcall lidx fx name args))
- (($ $continue k src ($ $branch _ ($primcall name args)))
- (visit-primcall lidx fx name args))
- (_ #f)))
- (_ #f)))))
- (lp (1+ lidx))))))))
-
-(define (compute-live-code fun)
- (let* ((fun-data-table (make-hash-table))
- (dfg (compute-dfg fun #:global? #t))
- (live-vars (make-bitvector (dfg-var-count dfg) #f))
- (changed? #f))
- (define (mark-live! var)
- (unless (value-live? var)
- (set! changed? #t)
- (bitvector-set! live-vars var #t)))
- (define (value-live? var)
- (bitvector-ref live-vars var))
- (define (ensure-fun-data fun)
- (or (hashq-ref fun-data-table fun)
- (call-with-values (lambda ()
- ((make-local-cont-folder label-count max-label)
- (lambda (k cont label-count max-label)
- (values (1+ label-count) (max k max-label)))
- fun 0 -1))
- (lambda (label-count max-label)
- (let* ((min-label (- (1+ max-label) label-count))
- (effects (compute-effects dfg min-label label-count))
- (live-conts (make-bitvector label-count #f))
- (defs (compute-defs dfg min-label label-count))
- (fun-data (make-fun-data
- min-label effects live-conts defs)))
- (elide-type-checks! fun dfg effects min-label label-count)
- (hashq-set! fun-data-table fun fun-data)
- (set! changed? #t)
- fun-data)))))
- (define (visit-fun fun)
- (match (ensure-fun-data fun)
- (($ $fun-data min-label effects live-conts defs)
- (define (idx->label idx) (+ idx min-label))
- (define (label->idx label) (- label min-label))
- (define (known-allocation? var dfg)
- (match (lookup-predecessors (lookup-def var dfg) dfg)
- ((def-exp-k)
- (match (lookup-cont def-exp-k dfg)
- (($ $kargs _ _ term)
- (match (find-call term)
- (($ $continue k src ($ $values (var)))
- (known-allocation? var dfg))
- (($ $continue k src ($ $primcall))
- (let ((kidx (label->idx def-exp-k)))
- (and (>= kidx 0)
- (causes-effect? (vector-ref effects kidx)
- &allocation))))
- (_ #f)))
- (_ #f)))
- (_ #f)))
- (define (visit-grey-exp n exp)
- (let ((defs (vector-ref defs n))
- (fx (vector-ref effects n)))
- (or
- ;; No defs; perhaps continuation is $ktail.
- (not defs)
- ;; Do we have a live def?
- (or-map value-live? defs)
- ;; 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 (value-live? obj)
- (not (known-allocation? obj dfg))))
- (_ #t))))))
- (let lp ((n (1- (vector-length effects))))
- (unless (< n 0)
- (let ((cont (lookup-cont (idx->label n) dfg)))
- (match cont
- (($ $kargs _ _ body)
- (let lp ((body body))
- (match body
- (($ $letk conts body) (lp body))
- (($ $continue k src exp)
- (unless (bitvector-ref live-conts n)
- (when (visit-grey-exp n exp)
- (set! changed? #t)
- (bitvector-set! live-conts n #t)))
- (when (bitvector-ref live-conts n)
- (match exp
- ((or ($ $const) ($ $prim))
- #f)
- (($ $fun body)
- (visit-fun body))
- (($ $rec names syms funs)
- (for-each (lambda (sym fun)
- (when (value-live? sym)
- (match fun
- (($ $fun body)
- (visit-fun body)))))
- syms funs))
- (($ $prompt escape? tag handler)
- (mark-live! tag))
- (($ $call proc args)
- (mark-live! proc)
- (for-each mark-live! args))
- (($ $callk k proc args)
- (mark-live! proc)
- (for-each mark-live! args))
- (($ $primcall name args)
- (for-each mark-live! args))
- (($ $branch k ($ $primcall name args))
- (for-each mark-live! args))
- (($ $branch k ($ $values (arg)))
- (mark-live! arg))
- (($ $values args)
- (match (vector-ref defs n)
- (#f (for-each mark-live! args))
- (defs (for-each (lambda (use def)
- (when (value-live? def)
- (mark-live! use)))
- args defs))))))))))
- (($ $kreceive arity kargs) #f)
- (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
- (for-each mark-live! syms))
- (($ $kfun src meta self)
- (mark-live! self))
- (($ $ktail) #f))
- (lp (1- n))))))))
- (unless (= (dfg-var-count dfg) (var-counter))
- (error "internal error" (dfg-var-count dfg) (var-counter)))
- (let lp ()
- (set! changed? #f)
- (visit-fun fun)
- (when changed? (lp)))
- (values fun-data-table live-vars)))
-
-(define (process-eliminations fun fun-data-table live-vars)
- (define (value-live? var)
- (bitvector-ref live-vars var))
- (define (make-adaptor name k defs)
- (let* ((names (map (lambda (_) 'tmp) defs))
- (syms (map (lambda (_) (fresh-var)) defs))
- (live (filter-map (lambda (def sym)
- (and (value-live? def)
- sym))
- defs syms)))
- (build-cps-cont
- (name ($kargs names syms
- ($continue k #f ($values live)))))))
- (define (visit-fun fun)
- (match (hashq-ref fun-data-table fun)
- (($ $fun-data min-label effects live-conts defs)
- (define (label->idx label) (- label min-label))
- (define (visit-cont cont)
- (match (visit-cont* cont)
- ((cont) cont)))
- (define (visit-cont* cont)
- (match cont
- (($ $cont label cont)
- (match cont
- (($ $kargs names syms body)
- (match (filter-map (lambda (name sym)
- (and (value-live? sym)
- (cons name sym)))
- names syms)
- (((names . syms) ...)
- (list
- (build-cps-cont
- (label ($kargs names syms
- ,(visit-term body label))))))))
- (($ $kfun src meta self tail clause)
- (list
- (build-cps-cont
- (label ($kfun src meta self ,tail
- ,(and clause (visit-cont clause)))))))
- (($ $kclause arity body alternate)
- (list
- (build-cps-cont
- (label ($kclause ,arity
- ,(visit-cont body)
- ,(and alternate
- (visit-cont alternate)))))))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (let ((defs (vector-ref defs (label->idx label))))
- (if (and-map value-live? defs)
- (list (build-cps-cont (label ,cont)))
- (let-fresh (adapt) ()
- (list (make-adaptor adapt kargs defs)
- (build-cps-cont
- (label ($kreceive req rest adapt))))))))
- (_ (list (build-cps-cont (label ,cont))))))))
- (define (visit-conts conts)
- (append-map visit-cont* conts))
- (define (visit-term term term-k)
- (match term
- (($ $letk conts body)
- (let ((body (visit-term body term-k)))
- (match (visit-conts conts)
- (() body)
- (conts (build-cps-term ($letk ,conts ,body))))))
- (($ $continue k src ($ $values args))
- (match (vector-ref defs (label->idx term-k))
- (#f term)
- (defs
- (let ((args (filter-map (lambda (use def)
- (and (value-live? def) use))
- args defs)))
- (build-cps-term
- ($continue k src ($values args)))))))
- (($ $continue k src exp)
- (if (bitvector-ref live-conts (label->idx term-k))
- (match exp
- (($ $fun body)
- (build-cps-term
- ($continue k src ($fun ,(visit-fun body)))))
- (($ $rec names syms funs)
- (rewrite-cps-term
- (filter-map
- (lambda (name sym fun)
- (and (value-live? sym)
- (match fun
- (($ $fun body)
- (list name
- sym
- (build-cps-exp
- ($fun ,(visit-fun body))))))))
- names syms funs)
- (()
- ($continue k src ($values ())))
- (((names syms funs) ...)
- ($continue k src ($rec names syms funs)))))
- (_
- (match (vector-ref defs (label->idx term-k))
- ((or #f ((? value-live?) ...))
- (build-cps-term
- ($continue k src ,exp)))
- (syms
- (let-fresh (adapt) ()
- (build-cps-term
- ($letk (,(make-adaptor adapt k syms))
- ($continue adapt src ,exp))))))))
- (build-cps-term ($continue k src ($values ())))))))
- (visit-cont fun))))
- (visit-fun fun))
-
-(define (eliminate-dead-code fun)
- (call-with-values (lambda () (renumber fun))
- (lambda (fun nlabels nvars)
- (parameterize ((label-counter nlabels)
- (var-counter nvars))
- (call-with-values (lambda () (compute-live-code fun))
- (lambda (fun-data-table live-vars)
- (process-eliminations fun fun-data-table live-vars)))))))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
deleted file mode 100644
index 7a49f86..0000000
--- a/module/language/cps/effects-analysis.scm
+++ /dev/null
@@ -1,499 +0,0 @@
-;;; Effects analysis on CPS
-
-;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A helper module to compute the set of effects caused by an
-;;; expression. This information is useful when writing algorithms that
-;;; move code around, while preserving the semantics of an input
-;;; program.
-;;;
-;;; The effects set is represented as an integer with three parts. The
-;;; low 4 bits indicate effects caused by an expression, as a bitfield.
-;;; The next 4 bits indicate the kind of memory accessed by the
-;;; expression, if it accesses mutable memory. Finally the rest of the
-;;; bits indicate the field in the object being accessed, if known, or
-;;; -1 for unknown.
-;;;
-;;; In this way we embed a coarse type-based alias analysis in the
-;;; effects analysis. For example, a "car" call is modelled as causing
-;;; a read to field 0 on a &pair, and causing a &type-check effect. If
-;;; any intervening code sets the car of any pair, that will block
-;;; motion of the "car" call, because any write to field 0 of a pair is
-;;; seen by effects analysis as being a write to field 0 of all pairs.
-;;;
-;;; Code:
-
-(define-module (language cps effects-analysis)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #: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 (lookup-constant-index sym dfg)
- (call-with-values (lambda () (find-constant-value sym dfg))
- (lambda (has-const? val)
- (and has-const? (integer? val) (exact? val) (<= 0 val) val))))
-
-(define-inlinable (indexed-field kind n dfg)
- (cond
- ((lookup-constant-index n dfg)
- => (lambda (idx)
- (&field kind idx)))
- (else (&object kind))))
-
-(define *primitive-effects* (make-hash-table))
-
-(define-syntax-rule (define-primitive-effects* dfg
- ((name . args) effects ...)
- ...)
- (begin
- (hashq-set! *primitive-effects* 'name
- (case-lambda*
- ((dfg . args) (logior effects ...))
- (_ &all-effects)))
- ...))
-
-(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
- (define-primitive-effects* dfg ((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 dfg)
- (indexed-field &vector n dfg))
-(define (read-vector-field n dfg)
- (logior &read (vector-field n dfg)))
-(define (write-vector-field n dfg)
- (logior &write (vector-field n dfg)))
-(define-primitive-effects* dfg
- ((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 dfg) &type-check)
- ((vector-ref/immediate v n) (read-vector-field n dfg) &type-check)
- ((vector-set! v n x) (write-vector-field n dfg) &type-check)
- ((vector-set!/immediate v n x) (write-vector-field n dfg) &type-check)
- ((vector-length v) &type-check))
-
-;; Structs.
-(define (struct-field n dfg)
- (indexed-field &struct n dfg))
-(define (read-struct-field n dfg)
- (logior &read (struct-field n dfg)))
-(define (write-struct-field n dfg)
- (logior &write (struct-field n dfg)))
-(define-primitive-effects* dfg
- ((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 dfg) &type-check)
- ((struct-ref/immediate s n) (read-struct-field n dfg) &type-check)
- ((struct-set! s n x) (write-struct-field n dfg) &type-check)
- ((struct-set!/immediate s n x) (write-struct-field n dfg) &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 dfg name args)
- (let ((proc (hashq-ref *primitive-effects* name)))
- (if proc
- (apply proc dfg args)
- &all-effects)))
-
-(define (expression-effects exp dfg)
- (match exp
- ((or ($ $const) ($ $prim) ($ $values))
- &no-effects)
- ((or ($ $fun) ($ $rec))
- (&allocate &unknown-memory-kinds))
- (($ $prompt)
- (&write-object &prompt))
- ((or ($ $call) ($ $callk))
- &all-effects)
- (($ $branch k exp)
- (expression-effects exp dfg))
- (($ $primcall name args)
- (primitive-effects dfg name args))))
-
-(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
- (label-count (dfg-label-count dfg)))
- (let ((effects (make-vector label-count &no-effects)))
- (define (idx->label idx) (+ idx min-label))
- (let lp ((n 0))
- (when (< n label-count)
- (vector-set!
- effects
- n
- (match (lookup-cont (idx->label n) dfg)
- (($ $kargs names syms body)
- (expression-effects (find-expression body) dfg))
- (($ $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)))
- (lp (1+ n))))
- effects))
-
-;; 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 dfg min-label #:optional
- (label-count (vector-length effects)))
- (define (label->idx label) (- label min-label))
- (let lp ((label min-label))
- (when (< label (+ min-label label-count))
- (let* ((lidx (label->idx label))
- (fx (vector-ref effects lidx)))
- (unless (zero? (logand (logior &write &allocation) fx))
- (vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
- (lp (1+ label))))))
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
deleted file mode 100644
index dadbd40..0000000
--- a/module/language/cps/elide-values.scm
+++ /dev/null
@@ -1,109 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Primcalls that don't correspond to VM instructions are treated as if
-;;; they are calls, and indeed the later reify-primitives pass turns
-;;; them into calls. Because no return arity checking is done for these
-;;; primitives, if a later optimization pass simplifies the primcall to
-;;; a VM operation, the tail of the simplification has to be a
-;;; primcall to 'values. Most of these primcalls can be elided, and
-;;; that is the job of this pass.
-;;;
-;;; Code:
-
-(define-module (language cps elide-values)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-26)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:export (elide-values))
-
-(define (elide-values* fun conts)
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont sym ($ $kargs names syms body))
- (sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
- (($ $cont sym ($ $kclause arity body alternate))
- (sym ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont)
- ,cont)))
- (define (visit-term term)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map visit-cont conts)
- ,(visit-term body)))
- (($ $continue k src ($ $primcall 'values vals))
- ,(rewrite-cps-term (vector-ref conts k)
- (($ $ktail)
- ($continue k src ($values vals)))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- ,(cond
- ((and (not rest) (= (length vals) (length req)))
- (build-cps-term
- ($continue kargs src ($values vals))))
- ((and rest (>= (length vals) (length req)))
- (let-fresh (krest) (rest)
- (let ((vals* (append (list-head vals (length req))
- (list rest))))
- (build-cps-term
- ($letk ((krest ($kargs ('rest) (rest)
- ($continue kargs src
- ($values vals*)))))
- ,(let lp ((tail (list-tail vals (length req)))
- (k krest))
- (match tail
- (()
- (build-cps-term ($continue k src
- ($const '()))))
- ((v . tail)
- (let-fresh (krest) (rest)
- (build-cps-term
- ($letk ((krest ($kargs ('rest) (rest)
- ($continue k src
- ($primcall 'cons
- (v rest))))))
- ,(lp tail krest))))))))))))
- (else term)))
- (($ $kargs args)
- ,(if (< (length vals) (length args))
- term
- (let ((vals (list-head vals (length args))))
- (build-cps-term
- ($continue k src ($values vals))))))))
- (($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(visit-fun fun)))
- (($ $continue k src ($ $rec names syms funs))
- ($continue k src ($rec names syms (map visit-fun funs))))
- (($ $continue)
- ,term)))
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun cont)
- ($fun ,(visit-cont cont)))))
-
- (visit-cont fun))
-
-(define (elide-values fun)
- (with-fresh-name-state fun
- (let ((conts (build-cont-table fun)))
- (elide-values* fun conts))))
diff --git a/module/language/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
deleted file mode 100644
index c224f45..0000000
--- a/module/language/cps/prune-bailouts.scm
+++ /dev/null
@@ -1,101 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A pass that prunes successors of expressions that bail out.
-;;;
-;;; Code:
-
-(define-module (language cps prune-bailouts)
- #:use-module (ice-9 match)
- #:use-module (language cps)
- #:export (prune-bailouts))
-
-(define (module-box src module name public? bound? val-proc)
- (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
- (build-cps-term
- ($letconst (('module module-sym module)
- ('name name-sym name)
- ('public? public?-sym public?)
- ('bound? bound?-sym bound?))
- ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
- ($continue kbox src
- ($primcall 'cached-module-box
- (module-sym name-sym public?-sym bound?-sym))))))))
-
-(define (primitive-ref name k src)
- (module-box #f '(guile) name #f #t
- (lambda (box)
- (build-cps-term
- ($continue k src ($primcall 'box-ref (box)))))))
-
-(define (prune-bailouts* fun)
- (define (visit-cont cont ktail)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kargs names vars body))
- (label ($kargs names vars ,(visit-term body ktail))))
- (($ $cont label ($ $kfun src meta self tail clause))
- (label ($kfun src meta self ,tail
- ,(and clause (visit-cont clause ktail)))))
- (($ $cont label ($ $kclause arity body alternate))
- (label ($kclause ,arity ,(visit-cont body ktail)
- ,(and alternate (visit-cont alternate ktail)))))
- (_ ,cont)))
-
- (define (visit-term term ktail)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
- ,(visit-term body ktail)))
- (($ $continue k src exp)
- ,(visit-exp k src exp ktail))))
-
- (define (visit-exp k src exp ktail)
- (rewrite-cps-term exp
- (($ $fun) ($continue k src ,(visit-fun exp)))
- (($ $rec names vars funs)
- ($continue k src ($rec names vars (map visit-fun funs))))
- (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
- ,(if (eq? k ktail)
- (build-cps-term ($continue k src ,exp))
- (let-fresh (kprim kresult kreceive) (prim rest)
- (build-cps-term
- ($letk ((kresult ($kargs ('rest) (rest)
- ($continue ktail src ($values ()))))
- (kreceive ($kreceive '() 'rest kresult))
- (kprim ($kargs ('prim) (prim)
- ($continue kreceive src
- ($call prim args)))))
- ,(primitive-ref name kprim src))))))
- (_ ($continue k src ,exp))))
-
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(prune-bailouts* body)))))
-
- (rewrite-cps-cont fun
- (($ $cont kfun
- ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
- (kfun ($kfun src meta self (ktail ($ktail))
- ,(and clause (visit-cont clause ktail)))))))
-
-(define (prune-bailouts fun)
- (with-fresh-name-state fun
- (prune-bailouts* fun)))
diff --git a/module/language/cps/prune-top-level-scopes.scm
b/module/language/cps/prune-top-level-scopes.scm
deleted file mode 100644
index 4839b71..0000000
--- a/module/language/cps/prune-top-level-scopes.scm
+++ /dev/null
@@ -1,114 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A simple pass to prune unneeded top-level scopes.
-;;;
-;;; Code:
-
-(define-module (language cps prune-top-level-scopes)
- #:use-module (ice-9 match)
- #:use-module (language cps)
- #:export (prune-top-level-scopes))
-
-(define (compute-referenced-scopes fun)
- (let ((scope-name->used? (make-hash-table))
- (scope-var->used? (make-hash-table))
- (k->scope-var (make-hash-table)))
- ;; Visit uses before defs. That way we know when visiting defs
- ;; whether the scope is used or not.
- (define (visit-cont cont)
- (match cont
- (($ $cont k ($ $kargs (name) (var) body))
- (visit-term body)
- (when (hashq-get-handle scope-var->used? var)
- (hashq-set! k->scope-var k var)))
- (($ $cont k ($ $kargs names syms body))
- (visit-term body))
- (($ $cont k ($ $kfun src meta self tail clause))
- (when clause (visit-cont clause)))
- (($ $cont k ($ $kclause arity body alternate))
- (visit-cont body)
- (when alternate (visit-cont alternate)))
- (($ $cont k ($ $kreceive))
- #t)))
- (define (visit-term term)
- (match term
- (($ $letk conts body)
- (for-each visit-cont conts)
- (visit-term body))
- (($ $continue k src exp)
- (match exp
- (($ $fun) (visit-fun exp))
- (($ $rec names syms funs)
- (for-each visit-fun funs))
- (($ $primcall 'cached-toplevel-box (scope name bound?))
- (hashq-set! scope-var->used? scope #t))
- (($ $primcall 'cache-current-module! (module scope))
- (hashq-set! scope-var->used? scope #f))
- (($ $const val)
- ;; If there is an entry in the table for "k", it means "val"
- ;; is a scope symbol, bound for use by cached-toplevel-box
- ;; or cache-current-module!, or possibly both (though this
- ;; is not currently the case).
- (and=> (hashq-ref k->scope-var k)
- (lambda (scope-var)
- (when (hashq-ref scope-var->used? scope-var)
- ;; We have a use via cached-toplevel-box. Mark
- ;; this scope as used.
- (hashq-set! scope-name->used? val #t))
- (when (and (hashq-ref scope-name->used? val)
- (not (hashq-ref scope-var->used? scope-var)))
- ;; There is a use, and this sym is used by
- ;; cache-current-module!.
- (hashq-set! scope-var->used? scope-var #t)))))
- (_ #t)))))
- (define (visit-fun fun)
- (match fun
- (($ $fun body)
- (visit-cont body))))
-
- (visit-cont fun)
- scope-var->used?))
-
-(define (prune-top-level-scopes fun)
- (let ((scope-var->used? (compute-referenced-scopes fun)))
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont sym ($ $kargs names syms body))
- (sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
- (($ $cont sym ($ $kclause arity body alternate))
- (sym ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont sym ($ $kreceive))
- ,cont)))
- (define (visit-term term)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map visit-cont conts) ,(visit-term body)))
- (($ $continue k src
- (and ($ $primcall 'cache-current-module! (module scope))
- (? (lambda _
- (not (hashq-ref scope-var->used? scope))))))
- ($continue k src ($primcall 'values ())))
- (($ $continue)
- ,term)))
- (visit-cont fun)))
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
deleted file mode 100644
index 45e2389..0000000
--- a/module/language/cps/self-references.scm
+++ /dev/null
@@ -1,79 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; A pass that prunes successors of expressions that bail out.
-;;;
-;;; Code:
-
-(define-module (language cps self-references)
- #:use-module (ice-9 match)
- #:use-module (language cps)
- #:export (resolve-self-references))
-
-(define* (resolve-self-references fun #:optional (env '()))
- (define (subst var)
- (or (assq-ref env var) var))
-
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kargs names vars body))
- (label ($kargs names vars ,(visit-term body))))
- (($ $cont label ($ $kfun src meta self tail clause))
- (label ($kfun src meta self ,tail
- ,(and clause (visit-cont clause)))))
- (($ $cont label ($ $kclause arity body alternate))
- (label ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (_ ,cont)))
-
- (define (visit-term term)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map visit-cont conts)
- ,(visit-term body)))
- (($ $continue k src exp)
- ($continue k src ,(visit-exp exp)))))
-
- (define (visit-exp exp)
- (rewrite-cps-exp exp
- ((or ($ $const) ($ $prim)) ,exp)
- (($ $fun body)
- ($fun ,(resolve-self-references body env)))
- (($ $rec names vars funs)
- ($rec names vars (map visit-recursive-fun funs vars)))
- (($ $call proc args)
- ($call (subst proc) ,(map subst args)))
- (($ $callk k proc args)
- ($callk k (subst proc) ,(map subst args)))
- (($ $primcall name args)
- ($primcall name ,(map subst args)))
- (($ $branch k exp)
- ($branch k ,(visit-exp exp)))
- (($ $values args)
- ($values ,(map subst args)))
- (($ $prompt escape? tag handler)
- ($prompt escape? (subst tag) handler))))
-
- (define (visit-recursive-fun fun var)
- (rewrite-cps-exp fun
- (($ $fun (and cont ($ $cont _ ($ $kfun src meta self))))
- ($fun ,(resolve-self-references cont (acons var self env))))))
-
- (visit-cont fun))
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
deleted file mode 100644
index 10e9d0a..0000000
--- a/module/language/cps/simplify.scm
+++ /dev/null
@@ -1,328 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; The fundamental lambda calculus reductions, like beta and eta
-;;; reduction and so on. Pretty lame currently.
-;;;
-;;; Code:
-
-(define-module (language 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 dfg)
- #:use-module (language cps renumber)
- #:export (simplify))
-
-(define (compute-eta-reductions fun)
- (let ((table (make-hash-table)))
- (define (visit-cont cont)
- (match cont
- (($ $cont sym ($ $kargs names syms body))
- (visit-term body sym syms))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (when clause (visit-cont clause)))
- (($ $cont sym ($ $kclause arity body alternate))
- (visit-cont body)
- (when alternate (visit-cont alternate)))
- (($ $cont sym _) #f)))
- (define (visit-term term term-k term-args)
- (match term
- (($ $letk conts body)
- (for-each visit-cont conts)
- (visit-term body term-k term-args))
- (($ $continue k src ($ $values args))
- (when (and (equal? term-args args) (not (eq? k term-k)))
- (hashq-set! table term-k k)))
- (($ $continue k src (and fun ($ $fun)))
- (visit-fun fun))
- (($ $continue k src ($ $rec names syms funs))
- (for-each visit-fun funs))
- (($ $continue k src _)
- #f)))
- (define (visit-fun fun)
- (match fun
- (($ $fun body)
- (visit-cont body))))
- (visit-cont fun)
- table))
-
-(define (eta-reduce fun)
- (let ((table (compute-eta-reductions fun))
- (dfg (compute-dfg fun)))
- (define (reduce* k scope values?)
- (match (hashq-ref table k)
- (#f k)
- (k*
- (if (and (continuation-bound-in? k* scope dfg)
- (or values?
- (match (lookup-cont k* dfg)
- (($ $kargs) #t)
- (_ #f))))
- (reduce* k* scope values?)
- k))))
- (define (reduce k scope)
- (reduce* k scope #f))
- (define (reduce-values k scope)
- (reduce* k scope #t))
- (define (reduce-const k src scope const)
- (let lp ((k k) (seen '()) (const const))
- (match (lookup-cont k dfg)
- (($ $kargs (_) (arg) term)
- (match (find-call term)
- (($ $continue k* src* ($ $values (arg*)))
- (and (eqv? arg arg*)
- (not (memq k* seen))
- (lp k* (cons k seen) const)))
- (($ $continue k* src* ($ $primcall 'not (arg*)))
- (and (eqv? arg arg*)
- (not (memq k* seen))
- (lp k* (cons k seen) (not const))))
- (($ $continue k* src* ($ $branch kt ($ $values (arg*))))
- (and (eqv? arg arg*)
- (let ((k* (if const kt k*)))
- (and (continuation-bound-in? k* scope dfg)
- (build-cps-term
- ($continue k* src ($values ())))))))
- (_
- (and (continuation-bound-in? k scope dfg)
- (build-cps-term
- ($continue k src ($const const)))))))
- (_ #f))))
- (define (visit-cont cont scope)
- (rewrite-cps-cont cont
- (($ $cont sym ($ $kargs names syms body))
- (sym ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (sym ($kfun src meta self ,tail
- ,(and clause (visit-cont clause sym)))))
- (($ $cont sym ($ $kclause arity body alternate))
- (sym ($kclause ,arity ,(visit-cont body sym)
- ,(and alternate (visit-cont alternate sym)))))
- (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
- (sym ($kreceive req rest (reduce kargs scope))))))
- (define (visit-term term scope)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map (cut visit-cont <> scope) conts)
- ,(visit-term body scope)))
- (($ $continue k src ($ $values args))
- ($continue (reduce-values k scope) src ($values args)))
- (($ $continue k src (and fun ($ $fun)))
- ($continue (reduce k scope) src ,(visit-fun fun)))
- (($ $continue k src ($ $rec names syms funs))
- ($continue k src ($rec names syms (map visit-fun funs))))
- (($ $continue k src ($ $const const))
- ,(let ((k (reduce k scope)))
- (or (reduce-const k src scope const)
- (build-cps-term ($continue k src ($const const))))))
- (($ $continue k src exp)
- ($continue (reduce k scope) src ,exp))))
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(visit-cont body #f)))))
- (visit-cont fun #f)))
-
-(define (compute-beta-reductions fun)
- ;; 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.
- (let ((var-table (make-hash-table))
- (k-table (make-hash-table))
- (dfg (compute-dfg fun)))
- (define (visit-cont cont)
- (match cont
- (($ $cont sym ($ $kargs names syms body))
- (visit-term body))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (when clause (visit-cont clause)))
- (($ $cont sym ($ $kclause arity body alternate))
- (visit-cont body)
- (when alternate (visit-cont alternate)))
- (($ $cont sym (or ($ $ktail) ($ $kreceive)))
- #f)))
- (define (visit-term term)
- (match term
- (($ $letk conts body)
- (for-each visit-cont conts)
- (visit-term body))
- (($ $continue k src ($ $values args))
- (match (lookup-cont k dfg)
- (($ $kargs names syms body)
- (match (lookup-predecessors k dfg)
- ((_)
- ;; There is only one use, and it is this use. We assume
- ;; it's not recursive, as there would to be some other
- ;; use for control flow to reach this loop. Store the k
- ;; -> body mapping in the table. Also store the
- ;; substitutions for the variables bound by the inlined
- ;; continuation.
- (for-each (cut hashq-set! var-table <> <>) syms args)
- (hashq-set! k-table k body))
- (_ #f)))
- (_ #f)))
- (($ $continue k src (and fun ($ $fun)))
- (visit-fun fun))
- (($ $continue k src ($ $rec names syms funs))
- (for-each visit-fun funs))
- (($ $continue k src _)
- #f)))
- (define (visit-fun fun)
- (match fun
- (($ $fun body)
- (visit-cont body))))
- (visit-cont fun)
- (values var-table k-table)))
-
-(define (beta-reduce fun)
- (let-values (((var-table k-table) (compute-beta-reductions fun)))
- (define (subst var)
- (cond ((hashq-ref var-table var) => subst)
- (else var)))
- (define (must-visit-cont cont)
- (or (visit-cont cont)
- (error "continuation must not be inlined" cont)))
- (define (visit-cont cont)
- (match cont
- (($ $cont sym cont)
- (and (not (hashq-ref k-table sym))
- (rewrite-cps-cont cont
- (($ $kargs names syms body)
- (sym ($kargs names syms ,(visit-term body))))
- (($ $kfun src meta self tail clause)
- (sym ($kfun src meta self ,tail
- ,(and clause (must-visit-cont clause)))))
- (($ $kclause arity body alternate)
- (sym ($kclause ,arity ,(must-visit-cont body)
- ,(and alternate (must-visit-cont alternate)))))
- (($ $kreceive)
- (sym ,cont)))))))
- (define (visit-term term)
- (match term
- (($ $letk conts body)
- (match (filter-map visit-cont conts)
- (() (visit-term body))
- (conts (build-cps-term
- ($letk ,conts ,(visit-term body))))))
- (($ $continue k src exp)
- (cond
- ((hashq-ref k-table k) => visit-term)
- (else
- (build-cps-term ($continue k src ,(visit-exp exp))))))))
- (define (visit-exp exp)
- (match exp
- ((or ($ $const) ($ $prim)) exp)
- (($ $fun) (visit-fun exp))
- (($ $rec names syms funs)
- (build-cps-exp ($rec names (map subst syms) (map visit-fun funs))))
- (($ $call proc args)
- (let ((args (map subst args)))
- (build-cps-exp ($call (subst proc) args))))
- (($ $callk k proc args)
- (let ((args (map subst args)))
- (build-cps-exp ($callk k (subst proc) args))))
- (($ $primcall name args)
- (let ((args (map subst args)))
- (build-cps-exp ($primcall name args))))
- (($ $values args)
- (let ((args (map subst args)))
- (build-cps-exp ($values args))))
- (($ $branch kt exp)
- (build-cps-exp ($branch kt ,(visit-exp exp))))
- (($ $prompt escape? tag handler)
- (build-cps-exp ($prompt escape? (subst tag) handler)))))
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(must-visit-cont body)))))
- (must-visit-cont fun)))
-
-;; Rewrite the scope tree to reflect the dominator tree. Precondition:
-;; the fun has been renumbered, its min-label is 0, and its labels are
-;; packed.
-(define (redominate fun)
- (let* ((dfg (compute-dfg fun))
- (idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
- (doms (compute-dom-edges idoms 0)))
- (define (visit-fun-cont cont)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kfun src meta self tail clause))
- (label ($kfun src meta self ,tail
- ,(and clause (visit-fun-cont clause)))))
- (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
- (label ($kclause ,arity ,(visit-cont kbody body)
- ,(and alternate (visit-fun-cont alternate)))))))
-
- (define (visit-cont label cont)
- (rewrite-cps-cont cont
- (($ $kargs names vars body)
- (label ($kargs names vars ,(visit-term body label))))
- (_ (label ,cont))))
-
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(visit-fun-cont body)))))
-
- (define (visit-exp k src exp)
- (rewrite-cps-term exp
- (($ $fun body)
- ($continue k src ,(visit-fun exp)))
- (($ $rec names syms funs)
- ($continue k src ($rec names syms (map visit-fun funs))))
- (_
- ($continue k src ,exp))))
-
- (define (visit-term term label)
- (define (visit-dom-conts label)
- (let ((cont (lookup-cont label dfg)))
- (match cont
- (($ $ktail) '())
- (($ $kargs) (list (visit-cont label cont)))
- (else
- (cons (visit-cont label cont)
- (visit-dom-conts* (vector-ref doms label)))))))
-
- (define (visit-dom-conts* labels)
- (match labels
- (() '())
- ((label . labels)
- (append (visit-dom-conts label)
- (visit-dom-conts* labels)))))
-
- (rewrite-cps-term term
- (($ $letk conts body)
- ,(visit-term body label))
- (($ $continue k src exp)
- ,(let ((conts (visit-dom-conts* (vector-ref doms label))))
- (if (null? conts)
- (visit-exp k src exp)
- (build-cps-term
- ($letk ,conts ,(visit-exp k src exp))))))))
-
- (visit-fun-cont fun)))
-
-(define (simplify fun)
- ;; Renumbering prunes continuations that are made unreachable by
- ;; eta/beta reductions.
- (redominate (renumber (eta-reduce (beta-reduce fun)))))
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
deleted file mode 100644
index e5b76fb..0000000
--- a/module/language/cps/specialize-primcalls.scm
+++ /dev/null
@@ -1,107 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; Commentary:
-;;;
-;;; Some bytecode operations can encode an immediate as an operand.
-;;; This pass tranforms generic primcalls to these specialized
-;;; primcalls, if possible.
-;;;
-;;; Code:
-
-(define-module (language cps specialize-primcalls)
- #:use-module (ice-9 match)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:export (specialize-primcalls))
-
-(define (specialize-primcalls fun)
- (let ((dfg (compute-dfg fun #:global? #t)))
- (with-fresh-name-state-from-dfg dfg
- (define (immediate-u8? sym)
- (call-with-values (lambda () (find-constant-value sym dfg))
- (lambda (has-const? val)
- (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont sym ($ $kargs names syms body))
- (sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kfun src meta self tail clause))
- (sym ($kfun src meta self ,tail
- ,(and clause (visit-cont clause)))))
- (($ $cont sym ($ $kclause arity body alternate))
- (sym ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont)
- ,cont)))
- (define (visit-term term)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map visit-cont conts)
- ,(visit-term body)))
- (($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(visit-fun fun)))
- (($ $continue k src ($ $rec names syms funs))
- ($continue k src ($rec names syms (map visit-fun funs))))
- (($ $continue k src ($ $primcall name args))
- ,(visit-primcall k src name args))
- (($ $continue)
- ,term)))
- (define (visit-primcall k src name args)
- ;; If we introduce a VM op from a primcall without a VM op, we
- ;; will need to ensure that the return arity matches. Rely on the
- ;; elide-values pass to clean up.
- (define-syntax-rule (adapt-void exp)
- (let-fresh (k* kvoid) (val)
- (build-cps-term
- ($letk ((k* ($kargs ('val) (val)
- ($continue k src ($primcall 'values (val)))))
- (kvoid ($kargs () ()
- ($continue k* src ($const *unspecified*)))))
- ($continue kvoid src exp)))))
- (define-syntax-rule (adapt-val exp)
- (let-fresh (k*) (val)
- (build-cps-term
- ($letk ((k* ($kargs ('val) (val)
- ($continue k src ($primcall 'values (val))))))
- ($continue k* src exp)))))
- (match (cons name args)
- (('make-vector (? immediate-u8? n) init)
- (adapt-val ($primcall 'make-vector/immediate (n init))))
- (('vector-ref v (? immediate-u8? n))
- (build-cps-term
- ($continue k src ($primcall 'vector-ref/immediate (v n)))))
- (('vector-set! v (? immediate-u8? n) x)
- (build-cps-term
- ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
- (('allocate-struct v (? immediate-u8? n))
- (adapt-val ($primcall 'allocate-struct/immediate (v n))))
- (('struct-ref s (? immediate-u8? n))
- (adapt-val ($primcall 'struct-ref/immediate (s n))))
- (('struct-set! s (? immediate-u8? n) x)
- (build-cps-term
- ($continue k src ($primcall 'struct-set!/immediate (s n x)))))
- (_
- (build-cps-term ($continue k src ($primcall name args))))))
-
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(visit-cont body)))))
-
- (visit-cont fun))))
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
deleted file mode 100644
index ba66ec3..0000000
--- a/module/language/cps/type-fold.scm
+++ /dev/null
@@ -1,443 +0,0 @@
-;;; Abstract constant folding on CPS
-;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
-;;;
-;;; This library is free software: you can redistribute it and/or modify
-;;; it under the terms of the GNU Lesser General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; This pass uses the abstract interpretation provided by type analysis
-;;; to fold constant values and type predicates. It is most profitably
-;;; run after CSE, to take advantage of scalar replacement.
-;;;
-;;; Code:
-
-(define-module (language cps type-fold)
- #:use-module (ice-9 match)
- #:use-module (language cps)
- #:use-module (language cps dfg)
- #:use-module (language cps renumber)
- #:use-module (language cps types)
- #: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 dfg k src
- arg type min max)
- body ...)
- (define-primcall-reducer name
- (lambda (dfg k src arg type min max) body ...)))
-
-(define-syntax-rule (define-binary-primcall-reducer (name dfg k src
- arg0 type0 min0 max0
- arg1 type1 min1 max1)
- body ...)
- (define-primcall-reducer name
- (lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...)))
-
-(define-binary-primcall-reducer (mul dfg k src
- arg0 type0 min0 max0
- arg1 type1 min1 max1)
- (define (negate arg)
- (let-fresh (kzero) (zero)
- (build-cps-term
- ($letk ((kzero ($kargs (#f) (zero)
- ($continue k src ($primcall 'sub (zero arg))))))
- ($continue kzero src ($const 0))))))
- (define (zero)
- (build-cps-term ($continue k src ($const 0))))
- (define (identity arg)
- (build-cps-term ($continue k src ($values (arg)))))
- (define (double arg)
- (build-cps-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))))))
- (let-fresh (kbits) (bits)
- (build-cps-term
- ($letk ((kbits ($kargs (#f) (bits)
- ($continue k src ($primcall 'ash (arg bits))))))
- ($continue kbits src ($const n)))))))
- (define (mul/constant constant constant-type arg arg-type)
- (and (or (= constant-type &exact-integer) (= constant-type arg-type))
- (case constant
- ;; (* arg -1) -> (- 0 arg)
- ((-1) (negate arg))
- ;; (* arg 0) -> 0 if arg is not a flonum or complex
- ((0) (and (= constant-type &exact-integer)
- (zero? (logand arg-type
- (lognot (logior &flonum &complex))))
- (zero)))
- ;; (* arg 1) -> arg
- ((1) (identity arg))
- ;; (* arg 2) -> (+ arg arg)
- ((2) (double arg))
- (else (and (= constant-type arg-type &exact-integer)
- (positive? constant)
- (zero? (logand constant (1- constant)))
- (power-of-two constant arg))))))
- (cond
- ((logtest (logior type0 type1) (lognot &number)) #f)
- ((= min0 max0) (mul/constant min0 type0 arg1 type1))
- ((= min1 max1) (mul/constant min1 type1 arg0 type0))
- (else #f)))
-
-(define-binary-primcall-reducer (logbit? dfg k src
- arg0 type0 min0 max0
- arg1 type1 min1 max1)
- (define (convert-to-logtest bool-term)
- (let-fresh (kt kf kmask kbool) (mask bool)
- (build-cps-term
- ($letk ((kt ($kargs () ()
- ($continue kbool src ($const #t))))
- (kf ($kargs () ()
- ($continue kbool src ($const #f))))
- (kbool ($kargs (#f) (bool)
- ,(bool-term bool)))
- (kmask ($kargs (#f) (mask)
- ($continue kf src
- ($branch kt ($primcall 'logtest (mask arg1)))))))
- ,(if (eq? min0 max0)
- ($continue kmask src ($const (ash 1 min0)))
- (let-fresh (kone) (one)
- (build-cps-term
- ($letk ((kone ($kargs (#f) (one)
- ($continue kmask src
- ($primcall 'ash (one arg0))))))
- ($continue kone src ($const 1))))))))))
- ;; Hairiness because we are converting from a primcall with unknown
- ;; arity to a branching primcall.
- (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
- (and (= type0 &exact-integer)
- (<= 0 min0 positive-fixnum-bits)
- (<= 0 max0 positive-fixnum-bits)
- (match (lookup-cont k dfg)
- (($ $kreceive arity kargs)
- (match arity
- (($ $arity (_) () (not #f) () #f)
- (convert-to-logtest
- (lambda (bool)
- (let-fresh (knil) (nil)
- (build-cps-term
- ($letk ((knil ($kargs (#f) (nil)
- ($continue kargs src
- ($values (bool nil))))))
- ($continue knil src ($const '()))))))))
- (_
- (convert-to-logtest
- (lambda (bool)
- (build-cps-term
- ($continue k src ($primcall 'values (bool)))))))))
- (($ $ktail)
- (convert-to-logtest
- (lambda (bool)
- (build-cps-term
- ($continue k src ($primcall 'return (bool)))))))))))
-
-
-
-
-;;
-
-(define (fold-and-reduce fun dfg min-label min-var)
- (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* ((typev (infer-types fun dfg))
- (label-count ((make-local-cont-folder label-count)
- (lambda (k cont label-count) (1+ label-count))
- fun 0))
- (folded? (make-bitvector label-count #f))
- (folded-values (make-vector label-count #f))
- (reduced-terms (make-vector label-count #f)))
- (define (label->idx label) (- label min-label))
- (define (var->idx var) (- var min-var))
- (define (maybe-reduce-primcall! label k src name args)
- (let* ((reducer (hashq-ref *primcall-reducers* name)))
- (when reducer
- (vector-set!
- reduced-terms
- (label->idx label)
- (match args
- ((arg0)
- (call-with-values (lambda () (lookup-pre-type typev label arg0))
- (lambda (type0 min0 max0)
- (reducer dfg k src arg0 type0 min0 max0))))
- ((arg0 arg1)
- (call-with-values (lambda () (lookup-pre-type typev label arg0))
- (lambda (type0 min0 max0)
- (call-with-values (lambda () (lookup-pre-type typev label
arg1))
- (lambda (type1 min1 max1)
- (reducer dfg k src arg0 type0 min0 max0
- arg1 type1 min1 max1))))))
- (_ #f))))))
- (define (maybe-fold-value! label name def)
- (call-with-values (lambda () (lookup-post-type typev label def 0))
- (lambda (type min max)
- (cond
- ((and (not (zero? type))
- (zero? (logand type (1- type)))
- (zero? (logand type (lognot &scalar-types)))
- (eqv? min max))
- (bitvector-set! folded? (label->idx label) #t)
- (vector-set! folded-values (label->idx label)
- (scalar-value type min))
- #t)
- (else #f)))))
- (define (maybe-fold-unary-branch! label name arg)
- (let* ((folder (hashq-ref *branch-folders* name)))
- (when folder
- (call-with-values (lambda () (lookup-pre-type typev label arg))
- (lambda (type min max)
- (call-with-values (lambda () (folder type min max))
- (lambda (f? v)
- (bitvector-set! folded? (label->idx label) f?)
- (vector-set! folded-values (label->idx label) v))))))))
- (define (maybe-fold-binary-branch! label name arg0 arg1)
- (let* ((folder (hashq-ref *branch-folders* name)))
- (when folder
- (call-with-values (lambda () (lookup-pre-type typev label arg0))
- (lambda (type0 min0 max0)
- (call-with-values (lambda () (lookup-pre-type typev label arg1))
- (lambda (type1 min1 max1)
- (call-with-values (lambda ()
- (folder type0 min0 max0 type1 min1 max1))
- (lambda (f? v)
- (bitvector-set! folded? (label->idx label) f?)
- (vector-set! folded-values (label->idx label) v))))))))))
- (define (visit-cont cont)
- (match cont
- (($ $cont label ($ $kargs _ _ body))
- (visit-term body label))
- (($ $cont label ($ $kclause arity body alternate))
- (visit-cont body)
- (visit-cont alternate))
- (_ #f)))
- (define (visit-term term label)
- (match term
- (($ $letk conts body)
- (for-each visit-cont conts)
- (visit-term body label))
- (($ $continue k src ($ $primcall name args))
- ;; We might be able to fold primcalls that define a value.
- (match (lookup-cont k dfg)
- (($ $kargs (_) (def))
- ;(pk 'maybe-fold-value src name args)
- (unless (maybe-fold-value! label name def)
- (maybe-reduce-primcall! label k src name args)))
- (_
- (maybe-reduce-primcall! label k src name args))))
- (($ $continue kf src ($ $branch kt ($ $primcall name args)))
- ;; We might be able to fold primcalls that branch.
- ;(pk 'maybe-fold-branch label src name args)
- (match args
- ((arg)
- (maybe-fold-unary-branch! label name arg))
- ((arg0 arg1)
- (maybe-fold-binary-branch! label name arg0 arg1))))
- (_ #f)))
- (when typev
- (match fun
- (($ $cont kfun ($ $kfun src meta self tail clause))
- (visit-cont clause))))
- (values folded? folded-values reduced-terms)))
-
-(define (fold-constants* fun dfg)
- (match fun
- (($ $cont min-label ($ $kfun _ _ min-var))
- (call-with-values (lambda () (fold-and-reduce fun dfg min-label min-var))
- (lambda (folded? folded-values reduced-terms)
- (define (label->idx label) (- label min-label))
- (define (var->idx var) (- var min-var))
- (define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kargs names syms body))
- (label ($kargs names syms ,(visit-term body label))))
- (($ $cont label ($ $kclause arity body alternate))
- (label ($kclause ,arity ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (_ ,cont)))
- (define (visit-term term label)
- (rewrite-cps-term term
- (($ $letk conts body)
- ($letk ,(map visit-cont conts)
- ,(visit-term body label)))
- (($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(visit-fun fun)))
- (($ $continue k src ($ $rec names vars funs))
- ($continue k src ($rec names vars (map visit-fun funs))))
- (($ $continue k src (and primcall ($ $primcall name args)))
- ,(cond
- ((bitvector-ref folded? (label->idx label))
- (let ((val (vector-ref folded-values (label->idx label))))
- ;; Uncomment for debugging.
- ;; (pk 'folded src primcall val)
- (let-fresh (k*) (v*)
- ;; Rely on DCE to elide this expression, if
- ;; possible.
- (build-cps-term
- ($letk ((k* ($kargs (#f) (v*)
- ($continue k src ($const val)))))
- ($continue k* src ,primcall))))))
- (else
- (or (vector-ref reduced-terms (label->idx label))
- term))))
- (($ $continue kf src ($ $branch kt ($ $primcall)))
- ,(if (bitvector-ref folded? (label->idx label))
- ;; Folded branch.
- (let ((val (vector-ref folded-values (label->idx label))))
- (build-cps-term
- ($continue (if val kt kf) src ($values ()))))
- term))
- (_ ,term)))
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun body)
- ($fun ,(fold-constants* body dfg)))))
- (rewrite-cps-cont fun
- (($ $cont kfun ($ $kfun src meta self tail clause))
- (kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))
-
-(define (type-fold fun)
- (let* ((fun (renumber fun))
- (dfg (compute-dfg fun)))
- (with-fresh-name-state-from-dfg dfg
- (fold-constants* fun dfg))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
deleted file mode 100644
index 5e0b2d0..0000000
--- a/module/language/cps/types.scm
+++ /dev/null
@@ -1,1424 +0,0 @@
-;;; Type analysis on CPS
-;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
-;;;
-;;; This library is free software: you can redistribute it and/or modify
-;;; it under the terms of the GNU Lesser General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this program. If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;;
-;;; Type analysis computes the possible types and ranges that values may
-;;; have at all program positions. This analysis can help to prove that
-;;; a primcall has no side-effects, if its arguments have the
-;;; appropriate type and range. It can also enable constant folding of
-;;; type predicates and, in the future, enable the compiler to choose
-;;; untagged, unboxed representations for numbers.
-;;;
-;;; For the purposes of this analysis, a "type" is an aspect of a value
-;;; that will not change. Guile's CPS intermediate language does not
-;;; carry manifest type information that asserts properties about given
-;;; values; instead, we recover this information via flow analysis,
-;;; garnering properties from type predicates, constant literals,
-;;; primcall results, and primcalls that assert that their arguments are
-;;; of particular types.
-;;;
-;;; A range denotes a subset of the set of values in a type, bounded by
-;;; a minimum and a maximum. The precise meaning of a range depends on
-;;; the type. For real numbers, the range indicates an inclusive lower
-;;; and upper bound on the integer value of a type. For vectors, the
-;;; range indicates the length of the vector. The range is limited to a
-;;; signed 32-bit value, with the smallest and largest values indicating
-;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the
-;;; concept of "range" makes no sense. In these cases we consider the
-;;; range to be -inf.0 to +inf.0.
-;;;
-;;; Types are represented as a bitfield. Fewer bits means a more precise
-;;; type. Although normally only values that have a single type will
-;;; have an associated range, this is not enforced. The range applies
-;;; to all types in the bitfield. When control flow meets, the types and
-;;; ranges meet with the union operator.
-;;;
-;;; It is not practical to precisely compute value ranges in all cases.
-;;; For example, in the following case:
-;;;
-;;; (let lp ((n 0)) (when (foo) (lp (1+ n))))
-;;;
-;;; The first time that range analysis visits the program, N is
-;;; determined to be the exact integer 0. The second time, it is an
-;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on.
-;;; This analysis will terminate, but only after the positive half of
-;;; the 32-bit range has been fully explored and we decide that the
-;;; range of N is [0, +inf.0]. At the same time, we want to do range
-;;; analysis and type analysis at the same time, as there are
-;;; interactions between them, notably in the case of `sqrt' which
-;;; returns a complex number if its argument cannot be proven to be
-;;; non-negative. So what we do is, once the types reach a fixed point,
-;;; we cause control-flow joins that would expand the range of a value
-;;; to saturate that range towards positive or 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 dfg)
- #:use-module (language cps intmap)
- #:use-module (rnrs bytevectors)
- #:use-module (srfi srfi-9)
- #: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-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)))
- (define (nan* a 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.
- (if (and (or (and (inf? a) (zero? b))
- (and (zero? a) (inf? b)))
- (not (logtest (logior (&type a) (&type b))
- (logior &flonum &complex))))
- 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 (infer-types* dfg min-label label-count)
- "Compute types for all variables in @var{fun}. Returns a hash table
-mapping symbols to types."
- (let ((typev (make-vector label-count))
- (idoms (compute-idoms dfg min-label label-count))
- (revisit-label #f)
- (types-changed? #f)
- (saturate-ranges? #f))
- (define (label->idx label) (- label min-label))
-
- (define (get-entry label) (vector-ref typev (label->idx label)))
-
- (define (in-types entry) (vector-ref entry 0))
- (define (out-types entry succ) (vector-ref entry (1+ succ)))
-
- (define (update-in-types! entry types)
- (vector-set! entry 0 types))
- (define (update-out-types! entry succ types)
- (vector-set! entry (1+ succ) types))
-
- (define (prepare-initial-state!)
- ;; The result is a vector with an entry for each label. Each entry
- ;; is a vector. The first slot in the entry vector corresponds to
- ;; the types that flow into the labelled expression. The following
- ;; slot is for the types that flow out to the first successor, and
- ;; so on for additional successors.
- (let lp ((label min-label))
- (when (< label (+ min-label label-count))
- (let* ((nsuccs (match (lookup-cont label dfg)
- (($ $kargs _ _ term)
- (match (find-call term)
- (($ $continue k src (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)))
- (entry (make-vector (1+ nsuccs) #f)))
- (vector-set! typev (label->idx label) entry)
- (lp (1+ label)))))
-
- ;; Initial state: nothing flows into the $kfun.
- (let ((entry (get-entry min-label)))
- (update-in-types! entry empty-intmap)))
-
- (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 (type-entry-saturating-union a b)
- (cond
- ((type-entry<=? b a) a)
- #;
- ((and (not saturate-ranges?)
- (eqv? (a-type ))
- (type-entry<=? a b)) b)
- (else (make-type-entry
- (let* ((a-type (type-entry-type a))
- (b-type (type-entry-type b))
- (type (logior a-type b-type)))
- (unless (eqv? a-type type)
- (set! types-changed? #t))
- type)
- (let ((a-min (type-entry-clamped-min a))
- (b-min (type-entry-clamped-min b)))
- (if (< b-min a-min)
- (if saturate-ranges? min-fixnum b-min)
- a-min))
- (let ((a-max (type-entry-clamped-max a))
- (b-max (type-entry-clamped-max b)))
- (if (> b-max a-max)
- (if saturate-ranges? max-fixnum b-max)
- a-max))))))
-
- (define (propagate-types! pred-label pred-entry succ-idx succ-label out)
- ;; Update "in" set of continuation.
- (let ((succ-entry (get-entry succ-label)))
- (match (lookup-predecessors succ-label dfg)
- ((_)
- ;; A normal edge.
- (update-in-types! succ-entry out))
- (_
- ;; A control-flow join.
- (let* ((succ-dom-label (vector-ref idoms (label->idx succ-label)))
- (succ-dom-entry (get-entry succ-dom-label))
- (old-in (in-types succ-entry))
- (in (if old-in
- (intmap-intersect old-in out
- type-entry-saturating-union)
- out)))
- ;; If the "in" set changed, update the entry and possibly
- ;; arrange to iterate again.
- (unless (eq? old-in in)
- (update-in-types! succ-entry in)
- ;; If the changed successor is a back-edge, ensure that
- ;; we revisit the function.
- (when (<= succ-label pred-label)
- (unless (and revisit-label (<= revisit-label succ-label))
- ;; (pk 'marking-revisit pred-label succ-label)
- (set! revisit-label succ-label))))))))
- ;; Finally update "out" set for current expression.
- (update-out-types! pred-entry succ-idx out))
-
- (define (visit-exp label entry k types exp)
- (define (propagate! succ-idx succ-label types)
- (propagate-types! label entry succ-idx succ-label types))
- ;; Each of these branches must propagate! to its successors.
- (match exp
- (($ $branch kt ($ $values (arg)))
- ;; The "normal" continuation is the #f branch.
- (let ((types (restrict-var types arg
- (make-type-entry (logior &false &nil)
- 0
- 0))))
- (propagate! 0 k types))
- (let ((types (restrict-var types arg
- (make-type-entry
- (logand &all-types
- (lognot (logior &false &nil)))
- -inf.0 +inf.0))))
- (propagate! 1 kt types)))
- (($ $branch kt ($ $primcall name args))
- ;; The "normal" continuation is the #f branch.
- (let ((types (infer-primcall types 0 name args #f)))
- (propagate! 0 k types))
- (let ((types (infer-primcall types 1 name args #f)))
- (propagate! 1 kt types)))
- (($ $prompt escape? tag handler)
- ;; The "normal" continuation enters the prompt.
- (propagate! 0 k types)
- (propagate! 1 handler types))
- (($ $primcall name args)
- (propagate! 0 k
- (match (lookup-cont k dfg)
- (($ $kargs _ defs)
- (infer-primcall types 0 name args
- (match defs ((var) var) (() #f))))
- (_
- ;(pk 'warning-no-restrictions name)
- types))))
- (($ $values args)
- (match (lookup-cont k dfg)
- (($ $kargs _ defs)
- (let ((in types))
- (let lp ((defs defs) (args args) (out types))
- (match (cons defs args)
- ((() . ())
- (propagate! 0 k out))
- (((def . defs) . (arg . args))
- (lp defs args
- (adjoin-var out def (var-type-entry in arg))))))))
- (_
- (propagate! 0 k types))))
- ((or ($ $call) ($ $callk))
- (propagate! 0 k types))
- (($ $rec names vars funs)
- (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0)))
- (propagate! 0 k (adjoin-vars types vars proc-type))))
- (_
- (match (lookup-cont k dfg)
- (($ $kargs (_) (var))
- (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)))))
- (propagate! 0 k (adjoin-var types var entry))))))))
-
- (prepare-initial-state!)
-
- ;; Iterate over all labelled expressions in the function,
- ;; propagating types and ranges to all successors.
- (let lp ((label min-label))
- ;(pk 'visit label)
- (cond
- ((< label (+ min-label label-count))
- (let* ((entry (vector-ref typev (label->idx label)))
- (types (in-types entry)))
- (define (propagate! succ-idx succ-label types)
- (propagate-types! label entry succ-idx succ-label types))
- ;; Add types for new definitions, and restrict types of
- ;; existing variables due to side effects.
- (match (lookup-cont label dfg)
- (($ $kargs names vars term)
- (let visit-term ((term term) (types types))
- (match term
- (($ $letk conts term)
- (visit-term term types))
- (($ $continue k src exp)
- (visit-exp label entry k types exp)))))
- (($ $kreceive arity k)
- (match (lookup-cont k dfg)
- (($ $kargs names vars)
- (propagate! 0 k
- (adjoin-vars types vars all-types-entry)))))
- (($ $kfun src meta self tail clause)
- (let ((types (adjoin-var types self all-types-entry)))
- (match clause
- (#f #f)
- (($ $cont kclause)
- (propagate! 0 kclause types)))))
- (($ $kclause arity ($ $cont kbody ($ $kargs names vars)) alt)
- (propagate! 0 kbody
- (adjoin-vars types vars all-types-entry))
- (match alt
- (#f #f)
- (($ $cont kclause)
- (propagate! 1 kclause types))))
- (($ $ktail) #t)))
-
- ;; And loop.
- (lp (1+ label)))
-
- ;; Iterate until we reach a fixed point.
- (revisit-label
- ;; Once the types have a fixed point, iterate until ranges also
- ;; reach a fixed point, saturating ranges to accelerate
- ;; convergence.
- (unless types-changed?
- (set! saturate-ranges? #t))
- (set! types-changed? #f)
- (let ((label revisit-label))
- (set! revisit-label #f)
- ;(pk 'looping)
- (lp label)))
-
- ;; All done! Return the computed types.
- (else typev)))))
-
-(define-record-type <type-analysis>
- (make-type-analysis min-label label-count types)
- type-analysis?
- (min-label type-analysis-min-label)
- (label-count type-analysis-label-count)
- (types type-analysis-types))
-
-(define (infer-types fun dfg)
- ;; Fun must be renumbered.
- (match fun
- (($ $cont min-label ($ $kfun))
- (let ((label-count ((make-local-cont-folder label-count)
- (lambda (k cont label-count) (1+ label-count))
- fun 0)))
- (make-type-analysis min-label label-count
- (infer-types* dfg min-label label-count))))))
-
-(define (lookup-pre-type analysis label def)
- (match analysis
- (($ <type-analysis> min-label label-count typev)
- (let* ((entry (vector-ref typev (- label min-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 analysis label def succ-idx)
- (match analysis
- (($ <type-analysis> min-label label-count typev)
- (let* ((entry (vector-ref typev (- label min-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? analysis label name args)
- (match (hashq-ref *type-checkers* name)
- (#f #f)
- (checker
- (match analysis
- (($ <type-analysis> min-label label-count typev)
- (let ((entry (vector-ref typev (- label min-label))))
- (apply checker (vector-ref entry 0) args)))))))
- [Guile-commits] branch master updated (981802c -> 90aabcc), Andy Wingo, 2015/07/16
- [Guile-commits] 01/10: closure-conversion docstring tweak, Andy Wingo, 2015/07/16
- [Guile-commits] 02/10: CPS2 closure conversion bugfixes, Andy Wingo, 2015/07/16
- [Guile-commits] 03/10: Enable CPS2 closure conversion, Andy Wingo, 2015/07/16
- [Guile-commits] 04/10: Prepare DCE pass for first-order CPS2, Andy Wingo, 2015/07/16
- [Guile-commits] 06/10: DCE works on first-order CPS, Andy Wingo, 2015/07/16
- [Guile-commits] 05/10: compute-reachable-functions refactor, Andy Wingo, 2015/07/16
- [Guile-commits] 10/10: Fix type/range inference for mul, Andy Wingo, 2015/07/16
- [Guile-commits] 07/10: Beta reduction over first-order CPS, Andy Wingo, 2015/07/16
- [Guile-commits] 08/10: Optimize first-order CPS, Andy Wingo, 2015/07/16
- [Guile-commits] 09/10: Remove CPS optimization passes and closure conversion,
Andy Wingo <=