mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Add missing files

Browse source 
Last commit meant to rename files, not delete them.  Whoops!
This commit is contained in:
Andy Wingo 2015-07-22 18:27:37 +02:00
parent aa7f0e25ac
commit 4aabc205cc
25 changed files with 8619 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

358
module/language/cps.scm Normal file
View file

@ -0,0 +1,358 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; This is the continuation-passing style (CPS) intermediate language
;;; (IL) for Guile.
;;;
;;; In CPS, a term is a labelled expression that calls a continuation.
;;; A function is a collection of terms. No term belongs to more than
;;; one function. The function is identified by the label of its entry
;;; term, and its body is composed of those terms that are reachable
;;; from the entry term. A program is a collection of functions,
;;; identified by the entry label of the entry function.
;;;
;;; Terms are themselves wrapped in continuations, which specify how
;;; predecessors may continue to them. For example, a $kargs
;;; continuation specifies that the term may be called with a specific
;;; number of values, and that those values will then be bound to
;;; lexical variables. $kreceive specifies that some number of values
;;; will be passed on the stack, as from a multiple-value return. Those
;;; values will be passed to a $kargs, if the number of values is
;;; compatible with the $kreceive's arity. $kfun is an entry point to a
;;; function, and receives arguments according to a well-known calling
;;; convention (currently, on the stack) and the stack before
;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and
;;; only appears within a $kfun; it checks the incoming values for the
;;; correct arity and dispatches to a $kargs, or to the next clause.
;;; Finally, $ktail is the tail continuation for a function, and
;;; contains no term.
;;;
;;; Each continuation has a label that is unique in the program. As an
;;; implementation detail, the labels are integers, which allows us to
;;; easily sort them topologically. A program is a map from integers to
;;; continuations, where continuation 0 in the map is the entry point
;;; for the program, and is a $kfun of no arguments.
;;;
;;; $continue nodes call continuations. The expression contained in the
;;; $continue node determines the value or values that are passed to the
;;; target continuation: $const to pass a constant value, $values to
;;; pass multiple named values, etc. $continue nodes also record the
;;; source location corresponding to the expression.
;;;
;;; As mentioned above, a $kargs continuation can bind variables, if it
;;; receives incoming values. $kfun also binds a value, corresponding
;;; to the closure being called. A traditional CPS implementation will
;;; nest terms in each other, binding them in "let" forms, ensuring that
;;; continuations are declared and bound within the scope of the values
;;; that they may use. In this way, the scope tree is a proof that
;;; variables are defined before they are used. However, this proof is
;;; conservative; it is possible for a variable to always be defined
;;; before it is used, but not to be in scope:
;;;
;;; (letrec ((k1 (lambda (v1) (k2)))
;;; (k2 (lambda () v1)))
;;; (k1 0))
;;;
;;; This example is invalid, as v1 is used outside its scope. However
;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside
;;; k1:
;;;
;;; (letrec ((k1 (lambda (v1)
;;; (letrec ((k2 (lambda () v1)))
;;; (k2))))
;;; (k1 0))
;;;
;;; Because program transformation usually uses flow-based analysis,
;;; having to update the scope tree to manifestly prove a transformation
;;; that has already proven correct is needless overhead, and in the
;;; worst case can prevent optimizations from occuring. For that
;;; reason, Guile's CPS language does not nest terms. Instead, we use
;;; the invariant that definitions must dominate uses. To check the
;;; validity of a CPS program is thus more involved than checking for a
;;; well-scoped tree; you have to do flow analysis to determine a
;;; dominator tree. However the flexibility that this grants us is
;;; worth the cost of throwing away the embedded proof of the scope
;;; tree.
;;;
;;; This particular formulation of CPS was inspired by Andrew Kennedy's
;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
;;; hackers should read that excellent paper! As in Kennedy's paper,
;;; continuations are second-class, and may be thought of as basic block
;;; labels. All values are bound to variables using continuation calls:
;;; even constants!
;;;
;;; Finally, note that there are two flavors of CPS: higher-order and
;;; first-order. By "higher-order", we mean that variables may be free
;;; across function boundaries. Higher-order CPS contains $fun and $rec
;;; expressions that declare functions in the scope of their term.
;;; Closure conversion results in first-order CPS, where closure
;;; representations have been explicitly chosen, and all variables used
;;; in a function are bound. Higher-order CPS is good for
;;; interprocedural optimizations like contification and beta reduction,
;;; while first-order CPS is better for instruction selection, register
;;; allocation, and code generation.
;;;
;;; See (language tree-il compile-cps) for details on how Tree-IL
;;; converts to CPS.
;;;
;;; Code:
(define-module (language cps)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:export (;; Helper.
$arity
make-$arity
;; Continuations.
$kreceive $kargs $kfun $ktail $kclause
;; Terms.
$continue
;; Expressions.
$const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt
;; Building macros.
build-cont build-term build-exp
rewrite-cont rewrite-term rewrite-exp
;; External representation.
parse-cps unparse-cps))
;; FIXME: Use SRFI-99, when Guile adds it.
(define-syntax define-record-type*
(lambda (x)
(define (id-append ctx . syms)
(datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
(syntax-case x ()
((_ name field ...)
(and (identifier? #'name) (and-map identifier? #'(field ...)))
(with-syntax ((cons (id-append #'name #'make- #'name))
(pred (id-append #'name #'name #'?))
((getter ...) (map (lambda (f)
(id-append f #'name #'- f))
#'(field ...))))
#'(define-record-type name
(cons field ...)
pred
(field getter)
...))))))
(define-syntax-rule (define-cps-type name field ...)
(begin
(define-record-type* name field ...)
(set-record-type-printer! name print-cps)))
(define (print-cps exp port)
(format port "#<cps ~S>" (unparse-cps exp)))
;; Helper.
(define-record-type* $arity req opt rest kw allow-other-keys?)
;; Continuations
(define-cps-type $kreceive arity kbody)
(define-cps-type $kargs names syms term)
(define-cps-type $kfun src meta self ktail kclause)
(define-cps-type $ktail)
(define-cps-type $kclause arity kbody kalternate)
;; Terms.
(define-cps-type $continue k src exp)
;; Expressions.
(define-cps-type $const val)
(define-cps-type $prim name)
(define-cps-type $fun body) ; Higher-order.
(define-cps-type $rec names syms funs) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order.
(define-cps-type $branch kt exp)
(define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name args)
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
(define-syntax build-arity
(syntax-rules (unquote)
((_ (unquote exp)) exp)
((_ (req opt rest kw allow-other-keys?))
(make-$arity req opt rest kw allow-other-keys?))))
(define-syntax build-cont
(syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
((_ (unquote exp))
exp)
((_ ($kreceive req rest kargs))
(make-$kreceive (make-$arity req '() rest '() #f) kargs))
((_ ($kargs (name ...) (unquote syms) body))
(make-$kargs (list name ...) syms (build-term body)))
((_ ($kargs (name ...) (sym ...) body))
(make-$kargs (list name ...) (list sym ...) (build-term body)))
((_ ($kargs names syms body))
(make-$kargs names syms (build-term body)))
((_ ($kfun src meta self ktail kclause))
(make-$kfun src meta self ktail kclause))
((_ ($ktail))
(make-$ktail))
((_ ($kclause arity kbody kalternate))
(make-$kclause (build-arity arity) kbody kalternate))))
(define-syntax build-term
(syntax-rules (unquote $rec $continue)
((_ (unquote exp))
exp)
((_ ($continue k src exp))
(make-$continue k src (build-exp exp)))))
(define-syntax build-exp
(syntax-rules (unquote
$const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt)
((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
((_ ($fun kentry)) (make-$fun kentry))
((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
((_ ($closure k nfree)) (make-$closure k nfree))
((_ ($call proc (unquote args))) (make-$call proc args))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args))
((_ ($callk k proc (unquote args))) (make-$callk k proc args))
((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
((_ ($callk k proc args)) (make-$callk k proc args))
((_ ($primcall name (unquote args))) (make-$primcall name args))
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
((_ ($primcall name args)) (make-$primcall name args))
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
((_ ($prompt escape? tag handler))
(make-$prompt escape? tag handler))))
(define-syntax-rule (rewrite-cont x (pat cont) ...)
(match x
(pat (build-cont cont)) ...))
(define-syntax-rule (rewrite-term x (pat term) ...)
(match x
(pat (build-term term)) ...))
(define-syntax-rule (rewrite-exp x (pat body) ...)
(match x
(pat (build-exp body)) ...))
(define (parse-cps exp)
(define (src exp)
(let ((props (source-properties exp)))
(and (pair? props) props)))
(match exp
;; Continuations.
(('kreceive req rest k)
(build-cont ($kreceive req rest k)))
(('kargs names syms body)
(build-cont ($kargs names syms ,(parse-cps body))))
(('kfun src meta self ktail kclause)
(build-cont ($kfun (src exp) meta self ktail kclause)))
(('ktail)
(build-cont ($ktail)))
(('kclause (req opt rest kw allow-other-keys?) kbody)
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f)))
(('kclause (req opt rest kw allow-other-keys?) kbody kalt)
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
;; Calls.
(('continue k exp)
(build-term ($continue k (src exp) ,(parse-cps exp))))
(('unspecified)
(build-exp ($const *unspecified*)))
(('const exp)
(build-exp ($const exp)))
(('prim name)
(build-exp ($prim name)))
(('fun kbody)
(build-exp ($fun kbody)))
(('closure k nfree)
(build-exp ($closure k nfree)))
(('rec (name sym fun) ...)
(build-exp ($rec name sym (map parse-cps fun))))
(('call proc arg ...)
(build-exp ($call proc arg)))
(('callk k proc arg ...)
(build-exp ($callk k proc arg)))
(('primcall name arg ...)
(build-exp ($primcall name arg)))
(('branch k exp)
(build-exp ($branch k ,(parse-cps exp))))
(('values arg ...)
(build-exp ($values arg)))
(('prompt escape? tag handler)
(build-exp ($prompt escape? tag handler)))
(_
(error "unexpected cps" exp))))
(define (unparse-cps exp)
(match exp
;; Continuations.
(($ $kreceive ($ $arity req () rest () #f) k)
`(kreceive ,req ,rest ,k))
(($ $kargs names syms body)
`(kargs ,names ,syms ,(unparse-cps body)))
(($ $kfun src meta self ktail kclause)
`(kfun ,meta ,self ,ktail ,kclause))
(($ $ktail)
`(ktail))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
. ,(if kalternate (list kalternate) '())))
;; Calls.
(($ $continue k src exp)
`(continue ,k ,(unparse-cps exp)))
(($ $const val)
(if (unspecified? val)
'(unspecified)
`(const ,val)))
(($ $prim name)
`(prim ,name))
(($ $fun kbody)
`(fun ,kbody))
(($ $closure k nfree)
`(closure ,k ,nfree))
(($ $rec names syms funs)
`(rec ,@(map (lambda (name sym fun)
(list name sym (unparse-cps fun)))
names syms funs)))
(($ $call proc args)
`(call ,proc ,@args))
(($ $callk k proc args)
`(callk ,k ,proc ,@args))
(($ $primcall name args)
`(primcall ,name ,@args))
(($ $branch k exp)
`(branch ,k ,(unparse-cps exp)))
(($ $values args)
`(values ,@args))
(($ $prompt escape? tag handler)
`(prompt ,escape? ,tag ,handler))
(_
(error "unexpected cps" exp))))

824
module/language/cps/closure-conversion.scm Normal file
View file

@ -0,0 +1,824 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; This pass converts a CPS term in such a way that no function has any
;;; free variables. Instead, closures are built explicitly with
;;; make-closure primcalls, and free variables are referenced through
;;; the closure.
;;;
;;; Closure conversion also removes any $rec expressions that
;;; contification did not handle. See (language cps) for a further
;;; discussion of $rec.
;;;
;;; Code:
(define-module (language cps closure-conversion)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold
filter-map
))
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (convert-closures))
(define (compute-function-bodies conts kfun)
"Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in
conts."
(let visit-fun ((kfun kfun) (out empty-intmap))
(let ((body (compute-function-body conts kfun)))
(intset-fold
(lambda (label out)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
(visit-fun kfun out))
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
(fold visit-fun out kfun))
(_ out)))
body
(intmap-add out kfun body)))))
(define (compute-program-body functions)
(intmap-fold (lambda (label body out) (intset-union body out))
functions
empty-intset))
(define (filter-reachable conts functions)
(let ((reachable (compute-program-body functions)))
(intmap-fold
(lambda (label cont out)
(if (intset-ref reachable label)
out
(intmap-remove out label)))
conts conts)))
(define (compute-non-operator-uses conts)
(persistent-intset
(intmap-fold
(lambda (label cont uses)
(define (add-use var uses) (intset-add! uses var))
(define (add-uses vars uses)
(match vars
(() uses)
((var . vars) (add-uses vars (add-use var uses)))))
(match cont
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses)
(($ $values args)
(add-uses args uses))
(($ $call proc args)
(add-uses args uses))
(($ $branch kt ($ $values (arg)))
(add-use arg uses))
(($ $branch kt ($ $primcall name args))
(add-uses args uses))
(($ $primcall name args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses))))
(_ uses)))
conts
empty-intset)))
(define (compute-singly-referenced-labels conts body)
(define (add-ref label single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match (intmap-ref conts label)
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (compute-function-names conts functions)
"Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function
whose bound vars we know."
(define (add-named-fun var kfun out)
(let ((self (match (intmap-ref conts kfun)
(($ $kfun src meta self) self))))
(intmap-add out kfun (intset var self))))
(intmap-fold
(lambda (label body out)
(let ((single (compute-singly-referenced-labels conts body)))
(intset-fold
(lambda (label out)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue k _ ($ $fun kfun)))
(if (intset-ref single k)
(match (intmap-ref conts k)
(($ $kargs (_) (var)) (add-named-fun var kfun out))
(_ out))
out))
(($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun) ...))))
(unless (intset-ref single k)
(error "$rec continuation has multiple predecessors??"))
(fold add-named-fun out vars kfun))
(_ out)))
body
out)))
functions
empty-intmap))
(define (compute-well-known-functions conts bound->label)
"Compute a set of labels indicating the well-known functions in
@var{conts}. A well-known function is a function whose bound names we
know and which is never used in a non-operator position."
(intset-subtract
(persistent-intset
(intmap-fold (lambda (bound label candidates)
(intset-add! candidates label))
bound->label
empty-intset))
(persistent-intset
(intset-fold (lambda (var not-well-known)
(match (intmap-ref bound->label var (lambda (_) #f))
(#f not-well-known)
(label (intset-add! not-well-known label))))
(compute-non-operator-uses conts)
empty-intset))))
(define (intset-cons i set)
(intset-add set i))
(define (compute-shared-closures conts well-known)
"Compute a map LABEL->VAR indicating the sets of functions that will
share a closure. If a functions's label is in the map, it is shared.
The entries indicate the var of the shared closure, which will be one of
the bound vars of the closure."
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs _ _
($ $continue _ _ ($ $rec names vars (($ $fun kfuns) ...))))
;; The split-rec pass should have ensured that this $rec forms a
;; strongly-connected component, so the free variables from all of
;; the functions will be alive as long as one of the closures is
;; alive. For that reason we can consider storing all free
;; variables in one closure and sharing it.
(let* ((kfuns-set (fold intset-cons empty-intset kfuns))
(unknown-kfuns (intset-subtract kfuns-set well-known)))
(cond
((or (eq? empty-intset kfuns-set) (trivial-intset kfuns-set))
;; There is only zero or one function bound here. Trivially
;; shared already.
out)
((eq? empty-intset unknown-kfuns)
;; All functions are well-known; we can share a closure. Use
;; the first bound variable.
(let ((closure (car vars)))
(intset-fold (lambda (kfun out)
(intmap-add out kfun closure))
kfuns-set out)))
((trivial-intset unknown-kfuns)
=> (lambda (unknown-kfun)
;; Only one function is not-well-known. Use that
;; function's closure as the shared closure.
(let ((closure (assq-ref (map cons kfuns vars) unknown-kfun)))
(intset-fold (lambda (kfun out)
(intmap-add out kfun closure))
kfuns-set out))))
(else
;; More than one not-well-known function means we need more
;; than one proper closure, so we can't share.
out))))
(_ out)))
conts
empty-intmap))
(define* (rewrite-shared-closure-calls cps functions label->bound shared kfun)
"Rewrite CPS such that every call to a function with a shared closure
instead is a $callk to that label, but passing the shared closure as the
proc argument. For recursive calls, use the appropriate 'self'
variable, if possible. Also rewrite uses of the non-well-known but
shared closures to use the appropriate 'self' variable, if possible."
;; env := var -> (var . label)
(define (rewrite-fun kfun cps env)
(define (subst var)
(match (intmap-ref env var (lambda (_) #f))
(#f var)
((var . label) var)))
(define (rename-exp label cps names vars k src exp)
(intmap-replace!
cps label
(build-cont
($kargs names vars
($continue k src
,(rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $call proc args)
,(let ((args (map subst args)))
(rewrite-exp (intmap-ref env proc (lambda (_) #f))
(#f ($call proc ,args))
((closure . label) ($callk label closure ,args)))))
(($ $primcall name args)
($primcall name ,(map subst args)))
(($ $branch k ($ $values (arg)))
($branch k ($values ((subst arg)))))
(($ $branch k ($ $primcall name args))
($branch k ($primcall name ,(map subst args))))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler))))))))
(define (visit-exp label cps names vars k src exp)
(define (compute-env label bound self rec-bound rec-labels env)
(define (add-bound-var bound label env)
(intmap-add env bound (cons self label) (lambda (old new) new)))
(if (intmap-ref shared label (lambda (_) #f))
;; Within a function with a shared closure, rewrite
;; references to bound vars to use the "self" var.
(fold add-bound-var env rec-bound rec-labels)
;; Otherwise be sure to use "self" references in any
;; closure.
(add-bound-var bound label env)))
(match exp
(($ $fun label)
(rewrite-fun label cps env))
(($ $rec names vars (($ $fun labels) ...))
(fold (lambda (label var cps)
(match (intmap-ref cps label)
(($ $kfun src meta self)
(rewrite-fun label cps
(compute-env label var self vars labels
env)))))
cps labels vars))
(_ (rename-exp label cps names vars k src exp))))
(define (rewrite-cont label cps)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp label cps names vars k src exp))
(_ cps)))
(intset-fold rewrite-cont (intmap-ref functions kfun) cps))
;; Initial environment is bound-var -> (shared-var . label) map for
;; functions with shared closures.
(let ((env (intmap-fold (lambda (label shared env)
(intset-fold (lambda (bound env)
(intmap-add env bound
(cons shared label)))
(intset-remove
(intmap-ref label->bound label)
(match (intmap-ref cps label)
(($ $kfun src meta self) self)))
env))
shared
empty-intmap)))
(persistent-intmap (rewrite-fun kfun cps env))))
(define (compute-free-vars conts kfun shared)
"Compute a FUN-LABEL->FREE-VAR... map describing all free variable
references."
(define (add-def var defs) (intset-add! defs var))
(define (add-defs vars defs)
(match vars
(() defs)
((var . vars) (add-defs vars (add-def var defs)))))
(define (add-use var uses)
(intset-add! uses var))
(define (add-uses vars uses)
(match vars
(() uses)
((var . vars) (add-uses vars (add-use var uses)))))
(define (visit-nested-funs body)
(intset-fold
(lambda (label out)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _
($ $fun kfun)))
(intmap-union out (visit-fun kfun)))
(($ $kargs _ _ ($ $continue _ _
($ $rec _ _ (($ $fun labels) ...))))
(let* ((out (fold (lambda (kfun out)
(intmap-union out (visit-fun kfun)))
out labels))
(free (fold (lambda (kfun free)
(intset-union free (intmap-ref out kfun)))
empty-intset labels)))
(fold (lambda (kfun out)
;; For functions that share a closure, the free
;; variables for one will be the union of the free
;; variables for all.
(if (intmap-ref shared kfun (lambda (_) #f))
(intmap-replace out kfun free)
out))
out
labels)))
(_ out)))
body
empty-intmap))
(define (visit-fun kfun)
(let* ((body (compute-function-body conts kfun))
(free (visit-nested-funs body)))
(call-with-values
(lambda ()
(intset-fold
(lambda (label defs uses)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(values
(add-defs vars defs)
(match exp
((or ($ $const) ($ $prim)) uses)
(($ $fun kfun)
(intset-union (persistent-intset uses)
(intmap-ref free kfun)))
(($ $rec names vars (($ $fun kfun) ...))
(fold (lambda (kfun uses)
(intset-union (persistent-intset uses)
(intmap-ref free kfun)))
uses kfun))
(($ $values args)
(add-uses args uses))
(($ $call proc args)
(add-use proc (add-uses args uses)))
(($ $callk label proc args)
(add-use proc (add-uses args uses)))
(($ $branch kt ($ $values (arg)))
(add-use arg uses))
(($ $branch kt ($ $primcall name args))
(add-uses args uses))
(($ $primcall name args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses)))))
(($ $kfun src meta self)
(values (add-def self defs) uses))
(_ (values defs uses))))
body empty-intset empty-intset))
(lambda (defs uses)
(intmap-add free kfun (intset-subtract
(persistent-intset uses)
(persistent-intset defs)))))))
(visit-fun kfun))
(define (eliminate-closure? label free-vars)
(eq? (intmap-ref free-vars label) empty-intset))
(define (closure-label label shared bound->label)
(cond
((intmap-ref shared label (lambda (_) #f))
=> (lambda (closure)
(intmap-ref bound->label closure)))
(else label)))
(define (closure-alias label well-known free-vars)
(and (intset-ref well-known label)
(trivial-intset (intmap-ref free-vars label))))
(define (prune-free-vars free-vars bound->label well-known shared)
"Given the label->bound-var map @var{free-vars}, remove free variables
that are known functions with zero free variables, and replace
references to well-known functions with one free variable with that free
variable, until we reach a fixed point on the free-vars map."
(define (prune-free in-label free free-vars)
(intset-fold (lambda (var free)
(match (intmap-ref bound->label var (lambda (_) #f))
(#f free)
(label
(cond
((eliminate-closure? label free-vars)
(intset-remove free var))
((closure-alias (closure-label label shared bound->label)
well-known free-vars)
=> (lambda (alias)
;; If VAR is free in LABEL, then ALIAS must
;; also be free because its definition must
;; precede VAR's definition.
(intset-add (intset-remove free var) alias)))
(else free)))))
free free))
(fixpoint (lambda (free-vars)
(intmap-fold (lambda (label free free-vars)
(intmap-replace free-vars label
(prune-free label free free-vars)))
free-vars
free-vars))
free-vars))
(define (intset-find set i)
(let lp ((idx 0) (start #f))
(let ((start (intset-next set start)))
(cond
((not start) (error "not found" set i))
((= start i) idx)
(else (lp (1+ idx) (1+ start)))))))
(define (intset-count set)
(intset-fold (lambda (_ count) (1+ count)) set 0))
(define (convert-one cps label body free-vars bound->label well-known shared)
(define (well-known? label)
(intset-ref well-known label))
(let* ((free (intmap-ref free-vars label))
(nfree (intset-count free))
(self-known? (well-known? (closure-label label shared bound->label)))
(self (match (intmap-ref cps label) (($ $kfun _ _ self) self))))
(define (convert-arg cps var k)
"Convert one possibly free variable reference to a bound reference.
If @var{var} is free, it is replaced by a closure reference via a
@code{free-ref} primcall, and @var{k} is called with the new var.
Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
;; We know that var is not the name of a well-known function.
(cond
((and=> (intmap-ref bound->label var (lambda (_) #f))
(lambda (kfun)
(and (eq? empty-intset (intmap-ref free-vars kfun))
kfun)))
;; A not-well-known function with zero free vars. Copy as a
;; constant, relying on the linker to reify just one copy.
=> (lambda (kfun)
(with-cps cps
(letv var*)
(let$ body (k var*))
(letk k* ($kargs (#f) (var*) ,body))
(build-term ($continue k* #f ($closure kfun 0))))))
((intset-ref free var)
(match (vector self-known? nfree)
(#(#t 1)
;; A reference to the one free var of a well-known function.
(with-cps cps
($ (k self))))
(#(#t 2)
;; A reference to one of the two free vars in a well-known
;; function.
(let ((op (if (= var (intset-next free)) 'car 'cdr)))
(with-cps cps
(letv var*)
(let$ body (k var*))
(letk k* ($kargs (#f) (var*) ,body))
(build-term ($continue k* #f ($primcall op (self)))))))
(_
(let* ((idx (intset-find free var))
(op (cond
((not self-known?) 'free-ref)
((<= idx #xff) 'vector-ref/immediate)
(else 'vector-ref))))
(with-cps cps
(letv var*)
(let$ body (k var*))
(letk k* ($kargs (#f) (var*) ,body))
($ (with-cps-constants ((idx idx))
(build-term
($continue k* #f ($primcall op (self idx)))))))))))
(else
(with-cps cps
($ (k var))))))
(define (convert-args cps vars k)
"Convert a number of possibly free references to bound references.
@var{k} is called with the bound references, and should return the
term."
(match vars
(()
(with-cps cps
($ (k '()))))
((var . vars)
(convert-arg cps var
(lambda (cps var)
(convert-args cps vars
(lambda (cps vars)
(with-cps cps
($ (k (cons var vars)))))))))))
(define (allocate-closure cps k src label known? nfree)
"Allocate a new closure, and pass it to $var{k}."
(match (vector known? nfree)
(#(#f nfree)
;; The call sites cannot be enumerated; allocate a closure.
(with-cps cps
(build-term ($continue k src ($closure label nfree)))))
(#(#t 2)
;; Well-known closure with two free variables; the closure is a
;; pair.
(with-cps cps
($ (with-cps-constants ((false #f))
(build-term
($continue k src ($primcall 'cons (false false))))))))
;; Well-known callee with more than two free variables; the closure
;; is a vector.
(#(#t nfree)
(unless (> nfree 2)
(error "unexpected well-known nullary, unary, or binary closure"))
(let ((op (if (<= nfree #xff) 'make-vector/immediate 'make-vector)))
(with-cps cps
($ (with-cps-constants ((nfree nfree)
(false #f))
(build-term
($continue k src ($primcall op (nfree false)))))))))))
(define (init-closure cps k src var known? free)
"Initialize the free variables @var{closure-free} in a closure
bound to @var{var}, and continue to @var{k}."
(match (vector known? (intset-count free))
;; Well-known callee with zero or one free variables; no
;; initialization necessary.
(#(#t (or 0 1))
(with-cps cps
(build-term ($continue k src ($values ())))))
;; Well-known callee with two free variables; do a set-car! and
;; set-cdr!.
(#(#t 2)
(let* ((free0 (intset-next free))
(free1 (intset-next free (1+ free0))))
(convert-arg cps free0
(lambda (cps v0)
(with-cps cps
(let$ body
(convert-arg free1
(lambda (cps v1)
(with-cps cps
(build-term
($continue k src
($primcall 'set-cdr! (var v1))))))))
(letk kcdr ($kargs () () ,body))
(build-term
($continue kcdr src ($primcall 'set-car! (var v0)))))))))
;; Otherwise residualize a sequence of vector-set! or free-set!,
;; depending on whether the callee is well-known or not.
(_
(let lp ((cps cps) (prev #f) (idx 0))
(match (intset-next free prev)
(#f (with-cps cps
(build-term ($continue k src ($values ())))))
(v (with-cps cps
(let$ body (lp (1+ v) (1+ idx)))
(letk k ($kargs () () ,body))
($ (convert-arg v
(lambda (cps v)
(with-cps cps
($ (with-cps-constants ((idx idx))
(let ((op (cond
((not known?) 'free-set!)
((<= idx #xff) 'vector-set!/immediate)
(else 'vector-set!))))
(build-term
($continue k src
($primcall op (var idx v))))))))))))))))))
(define (make-single-closure cps k src kfun)
(let ((free (intmap-ref free-vars kfun)))
(match (vector (well-known? kfun) (intset-count free))
(#(#f 0)
(with-cps cps
(build-term ($continue k src ($closure kfun 0)))))
(#(#t 0)
(with-cps cps
(build-term ($continue k src ($const #f)))))
(#(#t 1)
;; A well-known closure of one free variable is replaced
;; at each use with the free variable itself, so we don't
;; need a binding at all; and yet, the continuation
;; expects one value, so give it something. DCE should
;; clean up later.
(with-cps cps
(build-term ($continue k src ($const #f)))))
(#(well-known? nfree)
;; A bit of a mess, but beta conversion should remove the
;; final $values if possible.
(with-cps cps
(letv closure)
(letk k* ($kargs () () ($continue k src ($values (closure)))))
(let$ init (init-closure k* src closure well-known? free))
(letk knew ($kargs (#f) (closure) ,init))
($ (allocate-closure knew src kfun well-known? nfree)))))))
;; The callee is known, but not necessarily well-known.
(define (convert-known-proc-call cps k src label closure args)
(define (have-closure cps closure)
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src ($callk label closure args)))))))
(cond
((eq? (intmap-ref free-vars label) empty-intset)
;; Known call, no free variables; no closure needed.
;; Pass #f as closure argument.
(with-cps cps
($ (with-cps-constants ((false #f))
($ (have-closure false))))))
((and (well-known? (closure-label label shared bound->label))
(trivial-intset (intmap-ref free-vars label)))
;; Well-known closures with one free variable are
;; replaced at their use sites by uses of the one free
;; variable.
=> (lambda (var)
(convert-arg cps var have-closure)))
(else
;; Otherwise just load the proc.
(convert-arg cps closure have-closure))))
(define (visit-term cps term)
(match term
(($ $continue k src (or ($ $const) ($ $prim)))
(with-cps cps
term))
(($ $continue k src ($ $fun kfun))
(with-cps cps
($ (make-single-closure k src kfun))))
;; Remove letrec.
(($ $continue k src ($ $rec names vars (($ $fun kfuns) ...)))
(match (vector names vars kfuns)
(#(() () ())
;; Trivial empty case.
(with-cps cps
(build-term ($continue k src ($values ())))))
(#((name) (var) (kfun))
;; Trivial single case. We have already proven that K has
;; only LABEL as its predecessor, so we have been able
;; already to rewrite free references to the bound name with
;; the self name.
(with-cps cps
($ (make-single-closure k src kfun))))
(#(_ _ (kfun0 . _))
;; A non-trivial strongly-connected component. Does it have
;; a shared closure?
(match (intmap-ref shared kfun0 (lambda (_) #f))
(#f
;; Nope. Allocate closures for each function.
(let lp ((cps (match (intmap-ref cps k)
;; Steal declarations from the continuation.
(($ $kargs names vals body)
(intmap-replace cps k
(build-cont
($kargs () () ,body))))))
(in (map vector names vars kfuns))
(init (lambda (cps)
(with-cps cps
(build-term
($continue k src ($values ())))))))
(match in
(() (init cps))
((#(name var kfun) . in)
(let* ((known? (well-known? kfun))
(free (intmap-ref free-vars kfun))
(nfree (intset-count free)))
(define (next-init cps)
(with-cps cps
(let$ body (init))
(letk k ($kargs () () ,body))
($ (init-closure k src var known? free))))
(with-cps cps
(let$ body (lp in next-init))
(letk k ($kargs (name) (var) ,body))
($ (allocate-closure k src kfun known? nfree))))))))
(shared
;; If shared is in the bound->var map, that means one of
;; the functions is not well-known. Otherwise use kfun0
;; as the function label, but just so make-single-closure
;; can find the free vars, not for embedding in the
;; closure.
(let* ((kfun (intmap-ref bound->label shared (lambda (_) kfun0)))
(cps (match (intmap-ref cps k)
;; Make continuation declare only the shared
;; closure.
(($ $kargs names vals body)
(intmap-replace cps k
(build-cont
($kargs (#f) (shared) ,body)))))))
(with-cps cps
($ (make-single-closure k src kfun)))))))))
(($ $continue k src ($ $call proc args))
(match (intmap-ref bound->label proc (lambda (_) #f))
(#f
(convert-arg cps proc
(lambda (cps proc)
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src ($call proc args)))))))))
(label
(convert-known-proc-call cps k src label proc args))))
(($ $continue k src ($ $callk label proc args))
(convert-known-proc-call cps k src label proc args))
(($ $continue k src ($ $primcall name args))
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src ($primcall name args)))))))
(($ $continue k src ($ $branch kt ($ $primcall name args)))
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src
($branch kt ($primcall name args))))))))
(($ $continue k src ($ $branch kt ($ $values (arg))))
(convert-arg cps arg
(lambda (cps arg)
(with-cps cps
(build-term
($continue k src
($branch kt ($values (arg)))))))))
(($ $continue k src ($ $values args))
(convert-args cps args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src ($values args)))))))
(($ $continue k src ($ $prompt escape? tag handler))
(convert-arg cps tag
(lambda (cps tag)
(with-cps cps
(build-term
($continue k src
($prompt escape? tag handler)))))))))
(intset-fold (lambda (label cps)
(match (intmap-ref cps label (lambda (_) #f))
(($ $kargs names vars term)
(with-cps cps
(let$ term (visit-term term))
(setk label ($kargs names vars ,term))))
(_ cps)))
body
cps)))
(define (convert-closures cps)
"Convert free reference in @var{cps} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
(let* ((kfun 0) ;; Ass-u-me.
;; label -> body-label...
(functions (compute-function-bodies cps kfun))
(cps (filter-reachable cps functions))
;; label -> bound-var...
(label->bound (compute-function-names cps functions))
;; bound-var -> label
(bound->label (invert-partition label->bound))
;; label...
(well-known (compute-well-known-functions cps bound->label))
;; label -> closure-var
(shared (compute-shared-closures cps well-known))
(cps (rewrite-shared-closure-calls cps functions label->bound shared
kfun))
;; label -> free-var...
(free-vars (compute-free-vars cps kfun shared))
(free-vars (prune-free-vars free-vars bound->label well-known shared)))
(let ((free-in-program (intmap-ref free-vars kfun)))
(unless (eq? empty-intset free-in-program)
(error "Expected no free vars in program" free-in-program)))
(with-fresh-name-state cps
(persistent-intmap
(intmap-fold
(lambda (label body cps)
(convert-one cps label body free-vars bound->label well-known shared))
functions
cps)))))
;;; Local Variables:
;;; eval: (put 'convert-arg 'scheme-indent-function 2)
;;; eval: (put 'convert-args 'scheme-indent-function 2)
;;; End:

433
module/language/cps/compile-bytecode.scm Normal file
View file

@ -0,0 +1,433 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Compiling CPS to bytecode. The result is in the bytecode language,
;;; which happens to be an ELF image as a bytecode.
;;;
;;; Code:
(define-module (language cps compile-bytecode)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps)
#:use-module (language cps primitives)
#:use-module (language cps slot-allocation)
#:use-module (language cps utils)
#:use-module (language cps closure-conversion)
#:use-module (language cps optimize)
#:use-module (language cps reify-primitives)
#:use-module (language cps renumber)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system vm assembler)
#:export (compile-bytecode))
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define (intmap-for-each f map)
(intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
(define (intmap-select map set)
(persistent-intmap
(intset-fold
(lambda (k out)
(intmap-add! out k (intmap-ref map k)))
set
empty-intmap)))
(define (compile-function cps asm)
(let ((allocation (allocate-slots cps))
(frame-size #f))
(define (maybe-slot sym)
(lookup-maybe-slot sym allocation))
(define (slot sym)
(lookup-slot sym allocation))
(define (constant sym)
(lookup-constant-value sym allocation))
(define (maybe-mov dst src)
(unless (= dst src)
(emit-mov asm dst src)))
(define (compile-tail label exp)
;; There are only three kinds of expressions in tail position:
;; tail calls, multiple-value returns, and single-value returns.
(match exp
(($ $call proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-tail-call asm (1+ (length args))))
(($ $callk k proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-tail-call-label asm (1+ (length args)) k))
(($ $values ())
(emit-reset-frame asm 1)
(emit-return-values asm))
(($ $values (arg))
(if (maybe-slot arg)
(emit-return asm (slot arg))
(begin
(emit-load-constant asm 1 (constant arg))
(emit-return asm 1))))
(($ $values args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-reset-frame asm (1+ (length args)))
(emit-return-values asm))
(($ $primcall 'return (arg))
(emit-return asm (slot arg)))))
(define (compile-value label exp dst)
(match exp
(($ $values (arg))
(maybe-mov dst (slot arg)))
(($ $const exp)
(emit-load-constant asm dst exp))
(($ $closure k 0)
(emit-load-static-procedure asm dst k))
(($ $closure k nfree)
(emit-make-closure asm dst k nfree))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
(emit-cached-toplevel-box asm dst (constant scope) (constant name)
(constant bound?)))
(($ $primcall 'cached-module-box (mod name public? bound?))
(emit-cached-module-box asm dst (constant mod) (constant name)
(constant public?) (constant bound?)))
(($ $primcall 'resolve (name bound?))
(emit-resolve asm dst (constant bound?) (slot name)))
(($ $primcall 'free-ref (closure idx))
(emit-free-ref asm dst (slot closure) (constant idx)))
(($ $primcall 'vector-ref (vector index))
(emit-vector-ref asm dst (slot vector) (slot index)))
(($ $primcall 'make-vector (length init))
(emit-make-vector asm dst (slot length) (slot init)))
(($ $primcall 'make-vector/immediate (length init))
(emit-make-vector/immediate asm dst (constant length) (slot init)))
(($ $primcall 'vector-ref/immediate (vector index))
(emit-vector-ref/immediate asm dst (slot vector) (constant index)))
(($ $primcall 'allocate-struct (vtable nfields))
(emit-allocate-struct asm dst (slot vtable) (slot nfields)))
(($ $primcall 'allocate-struct/immediate (vtable nfields))
(emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
(($ $primcall 'struct-ref (struct n))
(emit-struct-ref asm dst (slot struct) (slot n)))
(($ $primcall 'struct-ref/immediate (struct n))
(emit-struct-ref/immediate asm dst (slot struct) (constant n)))
(($ $primcall 'builtin-ref (name))
(emit-builtin-ref asm dst (constant name)))
(($ $primcall 'bv-u8-ref (bv idx))
(emit-bv-u8-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s8-ref (bv idx))
(emit-bv-s8-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u16-ref (bv idx))
(emit-bv-u16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s16-ref (bv idx))
(emit-bv-s16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u32-ref (bv idx val))
(emit-bv-u32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s32-ref (bv idx val))
(emit-bv-s32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u64-ref (bv idx val))
(emit-bv-u64-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s64-ref (bv idx val))
(emit-bv-s64-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-f32-ref (bv idx val))
(emit-bv-f32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-f64-ref (bv idx val))
(emit-bv-f64-ref asm dst (slot bv) (slot idx)))
(($ $primcall name args)
;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name)))
(emit-text asm `((,inst ,dst ,@(map slot args))))))))
(define (compile-effect label exp k)
(match exp
(($ $values ()) #f)
(($ $prompt escape? tag handler)
(match (intmap-ref cps handler)
(($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (slot tag) escape? proc-slot receive-args)
(emit-br asm k)
(emit-label asm receive-args)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
(match (intmap-ref cps khandler-body)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size)
(emit-br asm khandler-body)))))
(($ $primcall 'cache-current-module! (sym scope))
(emit-cache-current-module! asm (slot sym) (constant scope)))
(($ $primcall 'free-set! (closure idx value))
(emit-free-set! asm (slot closure) (slot value) (constant idx)))
(($ $primcall 'box-set! (box value))
(emit-box-set! asm (slot box) (slot value)))
(($ $primcall 'struct-set! (struct index value))
(emit-struct-set! asm (slot struct) (slot index) (slot value)))
(($ $primcall 'struct-set!/immediate (struct index value))
(emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
(($ $primcall 'vector-set! (vector index value))
(emit-vector-set! asm (slot vector) (slot index) (slot value)))
(($ $primcall 'vector-set!/immediate (vector index value))
(emit-vector-set!/immediate asm (slot vector) (constant index)
(slot value)))
(($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value)))
(($ $primcall 'set-cdr! (pair value))
(emit-set-cdr! asm (slot pair) (slot value)))
(($ $primcall 'define! (sym value))
(emit-define! asm (slot sym) (slot value)))
(($ $primcall 'push-fluid (fluid val))
(emit-push-fluid asm (slot fluid) (slot val)))
(($ $primcall 'pop-fluid ())
(emit-pop-fluid asm))
(($ $primcall 'wind (winder unwinder))
(emit-wind asm (slot winder) (slot unwinder)))
(($ $primcall 'bv-u8-set! (bv idx val))
(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s8-set! (bv idx val))
(emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u16-set! (bv idx val))
(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s16-set! (bv idx val))
(emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u32-set! (bv idx val))
(emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s32-set! (bv idx val))
(emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u64-set! (bv idx val))
(emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s64-set! (bv idx val))
(emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-f32-set! (bv idx val))
(emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-f64-set! (bv idx val))
(emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'unwind ())
(emit-unwind asm))))
(define (compile-values label exp syms)
(match exp
(($ $values args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation)))))
(define (compile-test label exp kt kf next-label)
(define (unary op sym)
(cond
((eq? kt next-label)
(op asm (slot sym) #t kf))
(else
(op asm (slot sym) #f kt)
(unless (eq? kf next-label)
(emit-br asm kf)))))
(define (binary op a b)
(cond
((eq? kt next-label)
(op asm (slot a) (slot b) #t kf))
(else
(op asm (slot a) (slot b) #f kt)
(unless (eq? kf next-label)
(emit-br asm kf)))))
(match exp
(($ $values (sym))
(call-with-values (lambda ()
(lookup-maybe-constant-value sym allocation))
(lambda (has-const? val)
(if has-const?
(if val
(unless (eq? kt next-label)
(emit-br asm kt))
(unless (eq? kf next-label)
(emit-br asm kf)))
(unary emit-br-if-true sym)))))
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
(($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
(($ $primcall 'char? (a)) (unary emit-br-if-char a))
(($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
(($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
(($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
(($ $primcall 'string? (a)) (unary emit-br-if-string a))
(($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
(($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a))
(($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a))
;; Add more TC7 tests here. Keep in sync with
;; *branching-primcall-arities* in (language cps primitives) and
;; the set of macro-instructions in assembly.scm.
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
(($ $primcall '< (a b)) (binary emit-br-if-< a b))
(($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
(($ $primcall '= (a b)) (binary emit-br-if-= a b))
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))
(($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
(let* ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (1+ (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-call asm proc-slot nargs)
(emit-dead-slot-map asm proc-slot
(lookup-dead-slot-map label allocation))
(cond
((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
(match (lookup-parallel-moves k allocation)
((((? (lambda (src) (= src (1+ proc-slot))) src)
. dst)) dst)
(_ #f)))
;; The usual case: one required live return value, ignoring
;; any additional values.
=> (lambda (dst)
(emit-receive asm dst proc-slot frame-size)))
(else
(unless (and (zero? nreq) rest-var)
(emit-receive-values asm proc-slot (->bool rest-var) nreq))
(when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves k allocation))
(emit-reset-frame asm frame-size)))))
(match exp
(($ $call proc args)
(do-call proc args
(lambda (asm proc-slot nargs)
(emit-call asm proc-slot nargs))))
(($ $callk k proc args)
(do-call proc args
(lambda (asm proc-slot nargs)
(emit-call-label asm proc-slot nargs k))))))
(define (compile-expression label k exp)
(let* ((fallthrough? (= k (1+ label))))
(define (maybe-emit-jump)
(unless fallthrough?
(emit-br asm k)))
(match (intmap-ref cps k)
(($ $ktail)
(compile-tail label exp))
(($ $kargs (name) (sym))
(let ((dst (maybe-slot sym)))
(when dst
(compile-value label exp dst)))
(maybe-emit-jump))
(($ $kargs () ())
(match exp
(($ $branch kt exp)
(compile-test label exp kt k (1+ label)))
(_
(compile-effect label exp k)
(maybe-emit-jump))))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req)
(and rest
(match (intmap-ref cps kargs)
(($ $kargs names (_ ... rest)) rest))))
(unless (and fallthrough? (= kargs (1+ k)))
(emit-br asm kargs))))))
(define (compile-cont label cont)
(match cont
(($ $kfun src meta self tail clause)
(when src
(emit-source asm src))
(emit-begin-program asm label meta))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt)
(let ((first? (match (intmap-ref cps (1- label))
(($ $kfun) #t)
(_ #f)))
(kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
kw)))
(unless first?
(emit-end-arity asm))
(emit-label asm label)
(set! frame-size (lookup-nlocals label allocation))
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
frame-size alt)))
(($ $kargs names vars ($ $continue k src exp))
(emit-label asm label)
(for-each (lambda (name var)
(let ((slot (maybe-slot var)))
(when slot
(emit-definition asm name slot))))
names vars)
(when src
(emit-source asm src))
(compile-expression label k exp))
(($ $kreceive arity kargs)
(emit-label asm label))
(($ $ktail)
(emit-end-arity asm)
(emit-end-program asm))))
(intmap-for-each compile-cont cps)))
(define (emit-bytecode exp env opts)
(let ((asm (make-assembler)))
(intmap-for-each (lambda (kfun body)
(compile-function (intmap-select exp body) asm))
(compute-reachable-functions exp 0))
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))
(define (lower-cps exp opts)
(set! exp (optimize-higher-order-cps exp opts))
(set! exp (convert-closures exp))
(set! exp (optimize-first-order-cps exp opts))
(set! exp (reify-primitives exp))
(renumber exp))
(define (compile-bytecode exp env opts)
(set! exp (lower-cps exp opts))
(emit-bytecode exp env opts))

98
module/language/cps/constructors.scm Normal file
View file

@ -0,0 +1,98 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Constructor inlining turns "list" primcalls into a series of conses,
;;; and does similar transformations for "vector".
;;;
;;; Code:
(define-module (language cps constructors)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:export (inline-constructors))
(define (inline-list out k src args)
(define (build-list out args k)
(match args
(()
(with-cps out
(build-term ($continue k src ($const '())))))
((arg . args)
(with-cps out
(letv tail)
(letk ktail ($kargs ('tail) (tail)
($continue k src
($primcall 'cons (arg tail)))))
($ (build-list args ktail))))))
(with-cps out
(letv val)
(letk kvalues ($kargs ('val) (val)
($continue k src
($primcall 'values (val)))))
($ (build-list args kvalues))))
(define (inline-vector out k src args)
(define (initialize out vec args n)
(match args
(()
(with-cps out
(build-term ($continue k src ($primcall 'values (vec))))))
((arg . args)
(with-cps out
(let$ next (initialize vec args (1+ n)))
(letk knext ($kargs () () ,next))
($ (with-cps-constants ((idx n))
(build-term ($continue knext src
($primcall 'vector-set! (vec idx arg))))))))))
(with-cps out
(letv vec)
(let$ body (initialize vec args 0))
(letk kalloc ($kargs ('vec) (vec) ,body))
($ (with-cps-constants ((len (length args))
(init #f))
(build-term ($continue kalloc src
($primcall 'make-vector (len init))))))))
(define (find-constructor-inliner name)
(match name
('list inline-list)
('vector inline-vector)
(_ #f)))
(define (inline-constructors conts)
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
(let ((inline (find-constructor-inliner name)))
(if inline
(call-with-values (lambda () (inline out k src args))
(lambda (out term)
(intmap-replace! out label
(build-cont ($kargs names vars ,term)))))
out)))
(_ out)))
conts
conts))))

475
module/language/cps/contification.scm Normal file
View file

@ -0,0 +1,475 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Contification is a pass that turns $fun instances into $cont
;;; instances if all calls to the $fun return to the same continuation.
;;; This is a more rigorous variant of our old "fixpoint labels
;;; allocation" optimization.
;;;
;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
;;; and Weeks's "Contification using Dominators".
;;;
;;; Code:
(define-module (language cps contification)
#:use-module (ice-9 match)
#:use-module (srfi srfi-11)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps)
#:use-module (language cps renumber)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (contify))
(define (compute-singly-referenced-labels conts)
"Compute the set of labels in CONTS that have exactly one
predecessor."
(define (add-ref label cont single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match cont
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (compute-functions conts)
"Compute a map from $kfun label to bound variable names for all
functions in CONTS. Functions have two bound variable names: their self
binding, and the name they are given in their continuation. If their
continuation has more than one predecessor, then the bound variable name
doesn't uniquely identify the function, so we exclude that function from
the set."
(define (function-self label)
(match (intmap-ref conts label)
(($ $kfun src meta self) self)))
(let ((single (compute-singly-referenced-labels conts)))
(intmap-fold (lambda (label cont functions)
(match cont
(($ $kargs _ _ ($ $continue k src ($ $fun kfun)))
(if (intset-ref single k)
(match (intmap-ref conts k)
(($ $kargs (name) (var))
(intmap-add functions kfun
(intset var (function-self kfun)))))
functions))
(($ $kargs _ _ ($ $continue k src
($ $rec _ vars (($ $fun kfuns) ...))))
(if (intset-ref single k)
(fold (lambda (var kfun functions)
(intmap-add functions kfun
(intset var (function-self kfun))))
functions vars kfuns)
functions))
(_ functions)))
conts
empty-intmap)))
(define (compute-multi-clause conts)
"Compute an set containing all labels that are part of a multi-clause
case-lambda. See the note in compute-contification-candidates."
(define (multi-clause? clause)
(and clause
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
alt))))
(intmap-fold (lambda (label cont multi)
(match cont
(($ $kfun src meta self tail clause)
(if (multi-clause? clause)
(intset-union multi (compute-function-body conts label))
multi))
(_ multi)))
conts
empty-intset))
(define (compute-arities conts functions)
"Given the map FUNCTIONS whose keys are $kfun labels, return a map
from label to arities."
(define (clause-arities clause)
(if clause
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
(cons arity (clause-arities alt))))
'()))
(intmap-map (lambda (label vars)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(clause-arities clause))))
functions))
;; For now, we don't contify functions with optional, keyword, or rest
;; arguments.
(define (contifiable-arity? arity)
(match arity
(($ $arity req () #f () aok?)
#t)
(_
#f)))
(define (arity-matches? arity nargs)
(match arity
(($ $arity req () #f () aok?)
(= nargs (length req)))
(_
#f)))
(define (compute-contification-candidates conts)
"Compute and return a label -> (variable ...) map describing all
functions with known uses that are only ever used as the operator of a
$call, and are always called with a compatible arity."
(let* ((functions (compute-functions conts))
(multi-clause (compute-multi-clause conts))
(vars (intmap-fold (lambda (label vars out)
(intset-fold (lambda (var out)
(intmap-add out var label))
vars out))
functions
empty-intmap))
(arities (compute-arities conts functions)))
(define (restrict-arity functions proc nargs)
(match (intmap-ref vars proc (lambda (_) #f))
(#f functions)
(label
(let lp ((arities (intmap-ref arities label)))
(match arities
(() (intmap-remove functions label))
((arity . arities)
(cond
((not (contifiable-arity? arity)) (lp '()))
((arity-matches? arity nargs) functions)
(else (lp arities)))))))))
(define (visit-cont label cont functions)
(define (exclude-var functions var)
(match (intmap-ref vars var (lambda (_) #f))
(#f functions)
(label (intmap-remove functions label))))
(define (exclude-vars functions vars)
(match vars
(() functions)
((var . vars)
(exclude-vars (exclude-var functions var) vars))))
(match cont
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec))
functions)
(($ $values args)
(exclude-vars functions args))
(($ $call proc args)
(let ((functions (exclude-vars functions args)))
;; This contification algorithm is happy to contify the
;; `lp' in this example into a shared tail between clauses:
;;
;; (letrec ((lp (lambda () (lp))))
;; (case-lambda
;; ((a) (lp))
;; ((a b) (lp))))
;;
;; However because the current compilation pipeline has to
;; re-nest continuations into old CPS, there would be no
;; scope in which the tail would be valid. So, until the
;; old compilation pipeline is completely replaced,
;; conservatively exclude contifiable fucntions called
;; from multi-clause procedures.
(if (intset-ref multi-clause label)
(exclude-var functions proc)
(restrict-arity functions proc (length args)))))
(($ $callk k proc args)
(exclude-vars functions (cons proc args)))
(($ $branch kt ($ $primcall name args))
(exclude-vars functions args))
(($ $branch kt ($ $values (arg)))
(exclude-var functions arg))
(($ $primcall name args)
(exclude-vars functions args))
(($ $prompt escape? tag handler)
(exclude-var functions tag))))
(_ functions)))
(intmap-fold visit-cont conts functions)))
(define (compute-call-graph conts labels vars)
"Given the set of contifiable functions LABELS and associated bound
variables VARS, compute and return two values: a map
LABEL->LABEL... indicating the contifiable functions called by a
function, and a map LABEL->LABEL... indicating the return continuations
for a function. The first return value also has an entry
0->LABEL... indicating all contifiable functions called by
non-contifiable functions. We assume that 0 is not in the contifiable
function set."
(let ((bodies
;; label -> fun-label for all labels in bodies of contifiable
;; functions
(intset-fold (lambda (fun-label bodies)
(intset-fold (lambda (label bodies)
(intmap-add bodies label fun-label))
(compute-function-body conts fun-label)
bodies))
labels
empty-intmap)))
(when (intset-ref labels 0)
(error "internal error: label 0 should not be contifiable"))
(intmap-fold
(lambda (label cont calls returns)
(match cont
(($ $kargs _ _ ($ $continue k src ($ $call proc)))
(match (intmap-ref vars proc (lambda (_) #f))
(#f (values calls returns))
(callee
(let ((caller (intmap-ref bodies label (lambda (_) 0))))
(values (intmap-add calls caller callee intset-add)
(intmap-add returns callee k intset-add))))))
(_ (values calls returns))))
conts
(intset->intmap (lambda (label) empty-intset) (intset-add labels 0))
(intset->intmap (lambda (label) empty-intset) labels))))
(define (tail-label conts label)
(match (intmap-ref conts label)
(($ $kfun src meta self tail body)
tail)))
(define (compute-return-labels labels tails returns return-substs)
(define (subst k)
(match (intmap-ref return-substs k (lambda (_) #f))
(#f k)
(k (subst k))))
;; Compute all return labels, then subtract tail labels of the
;; functions in question.
(intset-subtract
;; Return labels for all calls to these labels.
(intset-fold (lambda (label out)
(intset-fold (lambda (k out)
(intset-add out (subst k)))
(intmap-ref returns label)
out))
labels
empty-intset)
(intset-fold (lambda (label out)
(intset-add out (intmap-ref tails label)))
labels
empty-intset)))
(define (intmap->intset map)
(define (add-key label cont labels)
(intset-add labels label))
(intmap-fold add-key map empty-intset))
(define (filter-contifiable contified groups)
(intmap-fold (lambda (id labels groups)
(let ((labels (intset-subtract labels contified)))
(if (eq? empty-intset labels)
groups
(intmap-add groups id labels))))
groups
empty-intmap))
(define (trivial-set set)
(let ((first (intset-next set)))
(and first
(not (intset-next set (1+ first)))
first)))
(define (compute-contification conts)
(let*-values
(;; label -> (var ...)
((candidates) (compute-contification-candidates conts))
((labels) (intmap->intset candidates))
;; var -> label
((vars) (intmap-fold (lambda (label vars out)
(intset-fold (lambda (var out)
(intmap-add out var label))
vars out))
candidates
empty-intmap))
;; caller-label -> callee-label..., callee-label -> return-label...
((calls returns) (compute-call-graph conts labels vars))
;; callee-label -> tail-label
((tails) (intset-fold
(lambda (label tails)
(intmap-add tails label (tail-label conts label)))
labels
empty-intmap))
;; Strongly connected components, allowing us to contify mutually
;; tail-recursive functions. Since `compute-call-graph' added on
;; a synthetic 0->LABEL... entry for contifiable functions called
;; by non-contifiable functions, we need to remove that entry
;; from the partition. It will be in its own component, as it
;; has no predecessors.
;;
;; id -> label...
((groups) (intmap-remove
(compute-strongly-connected-components calls 0)
0)))
;; todo: thread groups through contification
(define (attempt-contification labels contified return-substs)
(let ((returns (compute-return-labels labels tails returns
return-substs)))
(cond
((trivial-set returns)
=> (lambda (k)
;; Success!
(values (intset-union contified labels)
(intset-fold (lambda (label return-substs)
(let ((tail (intmap-ref tails label)))
(intmap-add return-substs tail k)))
labels return-substs))))
((trivial-set labels)
;; Single-label SCC failed to contify.
(values contified return-substs))
(else
;; Multi-label SCC failed to contify. Try instead to contify
;; each one.
(intset-fold
(lambda (label contified return-substs)
(let ((labels (intset-add empty-intset label)))
(attempt-contification labels contified return-substs)))
labels contified return-substs)))))
(call-with-values
(lambda ()
(fixpoint
(lambda (contified return-substs)
(intmap-fold
(lambda (id group contified return-substs)
(attempt-contification group contified return-substs))
(filter-contifiable contified groups)
contified
return-substs))
empty-intset
empty-intmap))
(lambda (contified return-substs)
(values (intset-fold (lambda (label call-substs)
(intset-fold
(lambda (var call-substs)
(intmap-add call-substs var label))
(intmap-ref candidates label)
call-substs))
contified
empty-intmap)
return-substs)))))
(define (apply-contification conts call-substs return-substs)
(define (call-subst proc)
(intmap-ref call-substs proc (lambda (_) #f)))
(define (return-subst k)
(intmap-ref return-substs k (lambda (_) #f)))
(define (find-body kfun nargs)
(match (intmap-ref conts kfun)
(($ $kfun src meta self tail clause)
(let lp ((clause clause))
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
(if (arity-matches? arity nargs)
body
(lp alt))))))))
(define (continue k src exp)
(define (lookup-return-cont k)
(match (return-subst k)
(#f k)
(k (lookup-return-cont k))))
(let ((k* (lookup-return-cont k)))
(if (eq? k k*)
(build-term ($continue k src ,exp))
;; We are contifying this return. It must be a call, a
;; $values expression, or a return primcall. k* will be
;; either a $ktail or a $kreceive continuation. CPS has this
;; thing though where $kreceive can't be the target of a
;; $values expression, and "return" can only continue to a
;; tail continuation, so we might have to rewrite to a
;; "values" primcall.
(build-term
($continue k* src
,(match (intmap-ref conts k*)
(($ $kreceive)
(match exp
(($ $primcall 'return (val))
(build-exp ($primcall 'values (val))))
(($ $call) exp)
;; Except for 'return, a primcall that can continue
;; to $ktail can also continue to $kreceive. TODO:
;; replace 'return with 'values, for consistency.
(($ $primcall) exp)
(($ $values vals)
(build-exp ($primcall 'values vals)))))
(($ $ktail) exp)))))))
(define (visit-exp k src exp)
(match exp
(($ $call proc args)
;; If proc is contifiable, replace call with jump.
(match (call-subst proc)
(#f (continue k src exp))
(kfun
(let ((body (find-body kfun (length args))))
(build-term ($continue body src ($values args)))))))
(($ $fun kfun)
;; If the function's tail continuation has been
;; substituted, that means it has been contified.
(if (return-subst (tail-label conts kfun))
(continue k src (build-exp ($values ())))
(continue k src exp)))
(($ $rec names vars funs)
(match (filter (match-lambda ((n v f) (not (call-subst v))))
(map list names vars funs))
(() (continue k src (build-exp ($values ()))))
(((names vars funs) ...)
(continue k src (build-exp ($rec names vars funs))))))
(_ (continue k src exp))))
;; Renumbering is not strictly necessary but some passes may not be
;; equipped to deal with stale $kfun nodes whose bodies have been
;; wired into other functions.
(renumber
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src exp))
;; Remove bindings for functions that have been contified.
(match (filter (match-lambda ((name var) (not (call-subst var))))
(map list names vars))
(((names vars) ...)
(build-cont
($kargs names vars ,(visit-exp k src exp))))))
(_ cont)))
conts)))
(define (contify conts)
;; FIXME: Renumbering isn't really needed but dead continuations may
;; cause compute-singly-referenced-labels to spuriously mark some
;; conts as irreducible. For now we punt and renumber so that there
;; are only live conts.
(let ((conts (renumber conts)))
(let-values (((call-substs return-substs) (compute-contification conts)))
(apply-contification conts call-substs return-substs))))

449
module/language/cps/cse.scm Normal file
View file

@ -0,0 +1,449 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Common subexpression elimination for CPS.
;;;
;;; Code:
(define-module (language cps cse)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps effects-analysis)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (eliminate-common-subexpressions))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(define-syntax-rule (make-worklist-folder* seed ...)
(lambda (f worklist seed ...)
(let lp ((worklist worklist) (seed seed) ...)
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist i)
(if i
(call-with-values (lambda () (f i seed ...))
(lambda (i* seed ...)
(let add ((i* i*) (worklist worklist))
(match i*
(() (lp worklist seed ...))
((i . i*) (add i* (intset-add worklist i)))))))
(values seed ...)))))))
(define worklist-fold*
(case-lambda
((f worklist seed)
((make-worklist-folder* seed) f worklist seed))))
(define (compute-available-expressions conts kfun effects)
"Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
an intset containing ancestor labels whose value is available at LABEL."
(define (propagate avail succ out)
(let* ((in (intmap-ref avail succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(if (eq? in in*)
(values '() avail)
(values (list succ)
(intmap-add avail succ in* (lambda (old new) new))))))
(define (clobber label in)
(let ((fx (intmap-ref effects label)))
(cond
((not (causes-effect? fx &write))
;; Fast-path if this expression clobbers nothing.
in)
(else
;; Kill clobbered expressions. FIXME: there is no need to check
;; on any label before than the last dominating label that
;; clobbered everything. Another way to speed things up would
;; be to compute a clobber set per-effect, which we could
;; subtract from "in".
(let lp ((label 0) (in in))
(cond
((intset-next in label)
=> (lambda (label)
(if (effect-clobbers? fx (intmap-ref effects label))
(lp (1+ label) (intset-remove in label))
(lp (1+ label) in))))
(else in)))))))
(define (visit-cont label avail)
(let* ((in (intmap-ref avail label))
(out (intset-add (clobber label in) label)))
(define (propagate0)
(values '() avail))
(define (propagate1 succ)
(propagate avail succ out))
(define (propagate2 succ0 succ1)
(let*-values (((changed0 avail) (propagate avail succ0 out))
((changed1 avail) (propagate avail succ1 out)))
(values (append changed0 changed1) avail)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $branch kt) (propagate2 k kt))
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
(if clause
(propagate1 clause)
(propagate0)))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt)
(propagate1 kbody)))
(($ $ktail) (propagate0)))))
(worklist-fold* visit-cont
(intset kfun)
(intmap-add empty-intmap kfun empty-intset)))
(define (compute-truthy-expressions conts kfun boolv)
"Compute a \"truth map\", indicating which expressions can be shown to
be true and/or false at each label in the function starting at KFUN..
Returns an intmap of intsets. The even elements of the intset indicate
labels that may be true, and the odd ones indicate those that may be
false. It could be that both true and false proofs are available."
(define (true-idx label) (ash label 1))
(define (false-idx label) (1+ (ash label 1)))
(define (propagate boolv succ out)
(let* ((in (intmap-ref boolv succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(if (eq? in in*)
(values '() boolv)
(values (list succ)
(intmap-add boolv succ in* (lambda (old new) new))))))
(define (visit-cont label boolv)
(let ((in (intmap-ref boolv label)))
(define (propagate0)
(values '() boolv))
(define (propagate1 succ)
(propagate boolv succ in))
(define (propagate2 succ0 succ1)
(let*-values (((changed0 boolv) (propagate boolv succ0 in))
((changed1 boolv) (propagate boolv succ1 in)))
(values (append changed0 changed1) boolv)))
(define (propagate-branch succ0 succ1)
(let*-values (((changed0 boolv)
(propagate boolv succ0
(intset-add in (false-idx label))))
((changed1 boolv)
(propagate boolv succ1
(intset-add in (true-idx label)))))
(values (append changed0 changed1) boolv)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $branch kt) (propagate-branch k kt))
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
(if clause
(propagate1 clause)
(propagate0)))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt)
(propagate1 kbody)))
(($ $ktail) (propagate0)))))
(let ((boolv (worklist-fold* visit-cont
(intset kfun)
(intmap-add boolv kfun empty-intset))))
;; Now visit nested functions. We don't do this in the worklist
;; folder because that would be exponential.
(define (recurse kfun boolv)
(compute-truthy-expressions conts kfun boolv))
(intset-fold
(lambda (label boolv)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
(($ $fun kfun) (recurse kfun boolv))
(($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun))
(_ boolv)))
(_ boolv)))
(compute-function-body conts kfun)
boolv)))
(define (intset-map f set)
(persistent-intmap
(intset-fold (lambda (i out) (intmap-add! out i (f i)))
set
empty-intmap)))
;; Returns a map of label-idx -> (var-idx ...) indicating the variables
;; defined by a given labelled expression.
(define (compute-defs conts kfun)
(intset-map (lambda (label)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(list self))
(($ $kclause arity body alt)
(match (intmap-ref conts body)
(($ $kargs names vars) vars)))
(($ $kreceive arity kargs)
(match (intmap-ref conts kargs)
(($ $kargs names vars) vars)))
(($ $ktail)
'())
(($ $kargs names vars ($ $continue k))
(match (intmap-ref conts k)
(($ $kargs names vars) vars)
(_ #f)))))
(compute-function-body conts kfun)))
(define (compute-singly-referenced succs)
(define (visit label succs single multiple)
(intset-fold (lambda (label single multiple)
(if (intset-ref single label)
(values single (intset-add! multiple label))
(values (intset-add! single label) multiple)))
succs single multiple))
(call-with-values (lambda ()
(intmap-fold visit succs empty-intset empty-intset))
(lambda (single multiple)
(intset-subtract (persistent-intset single)
(persistent-intset multiple)))))
(define (compute-equivalent-subexpressions conts kfun effects
equiv-labels var-substs)
(let* ((succs (compute-successors conts kfun))
(singly-referenced (compute-singly-referenced succs))
(avail (compute-available-expressions conts kfun effects))
(defs (compute-defs conts kfun))
(equiv-set (make-hash-table)))
(define (subst-var var-substs var)
(intmap-ref var-substs var (lambda (var) var)))
(define (subst-vars var-substs vars)
(let lp ((vars vars))
(match vars
(() '())
((var . vars) (cons (subst-var var-substs var) (lp vars))))))
(define (compute-exp-key var-substs exp)
(match exp
(($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name))
(($ $fun body) #f)
(($ $rec names syms funs) #f)
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name args)
(cons* 'primcall name (subst-vars var-substs args)))
(($ $branch _ ($ $primcall name args))
(cons* 'primcall name (subst-vars var-substs args)))
(($ $branch) #f)
(($ $values args) #f)
(($ $prompt escape? tag handler) #f)))
(define (add-auxiliary-definitions! label var-substs exp-key)
(define (subst var)
(subst-var var-substs var))
(let ((defs (intmap-ref defs label)))
(define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '())))
(hash-set! equiv-set aux-key
(acons label (list var) equiv))))
(match exp-key
(('primcall 'box val)
(match defs
((box)
(add-def! `(primcall box-ref ,(subst box)) val))))
(('primcall 'box-set! box val)
(add-def! `(primcall box-ref ,box) val))
(('primcall 'cons car cdr)
(match defs
((pair)
(add-def! `(primcall car ,(subst pair)) car)
(add-def! `(primcall cdr ,(subst pair)) cdr))))
(('primcall 'set-car! pair car)
(add-def! `(primcall car ,pair) car))
(('primcall 'set-cdr! pair cdr)
(add-def! `(primcall cdr ,pair) cdr))
(('primcall (or 'make-vector 'make-vector/immediate) len fill)
(match defs
((vec)
(add-def! `(primcall vector-length ,(subst vec)) len))))
(('primcall 'vector-set! vec idx val)
(add-def! `(primcall vector-ref ,vec ,idx) val))
(('primcall 'vector-set!/immediate vec idx val)
(add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
(('primcall (or 'allocate-struct 'allocate-struct/immediate)
vtable size)
(match defs
((struct)
(add-def! `(primcall struct-vtable ,(subst struct))
vtable))))
(('primcall 'struct-set! struct n val)
(add-def! `(primcall struct-ref ,struct ,n) val))
(('primcall 'struct-set!/immediate struct n val)
(add-def! `(primcall struct-ref/immediate ,struct ,n) val))
(_ #t))))
(define (visit-label label equiv-labels var-substs)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(let* ((exp-key (compute-exp-key var-substs exp))
(equiv (hash-ref equiv-set exp-key '()))
(fx (intmap-ref effects label))
(avail (intmap-ref avail label)))
(define (finish equiv-labels var-substs)
(define (recurse kfun equiv-labels var-substs)
(compute-equivalent-subexpressions conts kfun effects
equiv-labels var-substs))
;; If this expression defines auxiliary definitions,
;; as `cons' does for the results of `car' and `cdr',
;; define those. Do so after finding equivalent
;; expressions, so that we can take advantage of
;; subst'd output vars.
(add-auxiliary-definitions! label var-substs exp-key)
(match exp
;; If we see a $fun, recurse to add to the result.
(($ $fun kfun)
(recurse kfun equiv-labels var-substs))
(($ $rec names vars (($ $fun kfun) ...))
(fold2 recurse kfun equiv-labels var-substs))
(_
(values equiv-labels var-substs))))
(let lp ((candidates equiv))
(match candidates
(()
;; No matching expressions. Add our expression
;; to the equivalence set, if appropriate. Note
;; that expressions that allocate a fresh object
;; or change the current fluid environment can't
;; be eliminated by CSE (though DCE might do it
;; if the value proves to be unused, in the
;; allocation case).
(when (and exp-key
(not (causes-effect? fx &allocation))
(not (effect-clobbers? fx (&read-object &fluid))))
(let ((defs (and (intset-ref singly-referenced k)
(intmap-ref defs label))))
(when defs
(hash-set! equiv-set exp-key
(acons label defs equiv)))))
(finish equiv-labels var-substs))
(((and head (candidate . vars)) . candidates)
(cond
((not (intset-ref avail candidate))
;; This expression isn't available here; try
;; the next one.
(lp candidates))
(else
;; Yay, a match. Mark expression as equivalent. If
;; we provide the definitions for the successor, mark
;; the vars for substitution.
(finish (intmap-add equiv-labels label head)
(let ((defs (and (intset-ref singly-referenced k)
(intmap-ref defs label))))
(if defs
(fold (lambda (def var var-substs)
(intmap-add var-substs def var))
var-substs defs vars)
var-substs))))))))))
(_ (values equiv-labels var-substs))))
;; Traverse the labels in fun in reverse post-order, which will
;; visit definitions before uses first.
(fold2 visit-label
(compute-reverse-post-order succs kfun)
equiv-labels
var-substs)))
(define (apply-cse conts equiv-labels var-substs truthy-labels)
(define (true-idx idx) (ash idx 1))
(define (false-idx idx) (1+ (ash idx 1)))
(define (subst-var var)
(intmap-ref var-substs var (lambda (var) var)))
(define (visit-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp)
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name args)
($primcall name ,(map subst-var args)))
(($ $branch k exp)
($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler))))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(build-cont
($kargs names vars
,(match (intmap-ref equiv-labels label (lambda (_) #f))
((equiv . vars)
(match exp
(($ $branch kt exp)
(let* ((bool (intmap-ref truthy-labels label))
(t (intset-ref bool (true-idx equiv)))
(f (intset-ref bool (false-idx equiv))))
(if (eqv? t f)
(build-term
($continue k src
($branch kt ,(visit-exp exp))))
(build-term
($continue (if t kt k) src ($values ()))))))
(_
;; For better or for worse, we only replace primcalls
;; if they have an associated VM op, which allows
;; them to continue to $kargs and thus we know their
;; defs and can use a $values expression instead of a
;; values primcall.
(build-term
($continue k src ($values vars))))))
(#f
(build-term
($continue k src ,(visit-exp exp))))))))
(_ cont)))
conts))
(define (eliminate-common-subexpressions conts)
(call-with-values
(lambda ()
(let ((effects (synthesize-definition-effects (compute-effects conts))))
(compute-equivalent-subexpressions conts 0 effects
empty-intmap empty-intmap)))
(lambda (equiv-labels var-substs)
(let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap)))
(apply-cse conts equiv-labels var-substs truthy-labels)))))

399
module/language/cps/dce.scm Normal file
View file

@ -0,0 +1,399 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; This pass kills dead expressions: code that has no side effects, and
;;; whose value is unused. It does so by marking all live values, and
;;; then discarding other values as dead. This happens recursively
;;; through procedures, so it should be possible to elide dead
;;; procedures as well.
;;;
;;; Code:
(define-module (language cps dce)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps)
#:use-module (language cps effects-analysis)
#:use-module (language cps renumber)
#:use-module (language cps types)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (eliminate-dead-code))
(define (elide-type-checks conts kfun effects)
"Elide &type-check effects from EFFECTS for the function starting at
KFUN where we can prove that no assertion will be raised at run-time."
(let ((types (infer-types conts kfun)))
(define (visit-primcall effects fx label name args)
(if (primcall-types-check? types label name args)
(intmap-replace! effects label (logand fx (lognot &type-check)))
effects))
(persistent-intmap
(intmap-fold (lambda (label types effects)
(let ((fx (intmap-ref effects label)))
(cond
((causes-all-effects? fx) effects)
((causes-effect? fx &type-check)
(match (intmap-ref conts label)
(($ $kargs _ _ exp)
(match exp
(($ $continue k src ($ $primcall name args))
(visit-primcall effects fx label name args))
(($ $continue k src
($ $branch _ ($primcall name args)))
(visit-primcall effects fx label name args))
(_ effects)))
(_ effects)))
(else effects))))
types
effects))))
(define (compute-effects/elide-type-checks conts)
(intmap-fold (lambda (label cont effects)
(match cont
(($ $kfun) (elide-type-checks conts label effects))
(_ effects)))
conts
(compute-effects conts)))
(define (fold-local-conts proc conts label seed)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(let lp ((label label) (seed seed))
(if (<= label tail)
(lp (1+ label) (proc label (intmap-ref conts label) seed))
seed)))))
(define (postorder-fold-local-conts2 proc conts label seed0 seed1)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(let ((start label))
(let lp ((label tail) (seed0 seed0) (seed1 seed1))
(if (<= start label)
(let ((cont (intmap-ref conts label)))
(call-with-values (lambda () (proc label cont seed0 seed1))
(lambda (seed0 seed1)
(lp (1- label) seed0 seed1))))
(values seed0 seed1)))))))
(define (compute-known-allocations conts effects)
"Compute the variables bound in CONTS that have known allocation
sites."
;; Compute the set of conts that are called with freshly allocated
;; values, and subtract from that set the conts that might be called
;; with values with unknown allocation sites. Then convert that set
;; of conts into a set of bound variables.
(call-with-values
(lambda ()
(intmap-fold (lambda (label cont known unknown)
;; Note that we only need to add labels to the
;; known/unknown sets if the labels can bind
;; values. So there's no need to add tail,
;; clause, branch alternate, or prompt handler
;; labels, as they bind no values.
(match cont
(($ $kargs _ _ ($ $continue k))
(let ((fx (intmap-ref effects label)))
(if (and (not (causes-all-effects? fx))
(causes-effect? fx &allocation))
(values (intset-add! known k) unknown)
(values known (intset-add! unknown k)))))
(($ $kreceive arity kargs)
(values known (intset-add! unknown kargs)))
(($ $kfun src meta self tail clause)
(values known unknown))
(($ $kclause arity body alt)
(values known (intset-add! unknown body)))
(($ $ktail)
(values known unknown))))
conts
empty-intset
empty-intset))
(lambda (known unknown)
(persistent-intset
(intset-fold (lambda (label vars)
(match (intmap-ref conts label)
(($ $kargs (_) (var)) (intset-add! vars var))
(_ vars)))
(intset-subtract (persistent-intset known)
(persistent-intset unknown))
empty-intset)))))
(define (compute-live-code conts)
(let* ((effects (compute-effects/elide-type-checks conts))
(known-allocations (compute-known-allocations conts effects)))
(define (adjoin-var var set)
(intset-add set var))
(define (adjoin-vars vars set)
(match vars
(() set)
((var . vars) (adjoin-vars vars (adjoin-var var set)))))
(define (var-live? var live-vars)
(intset-ref live-vars var))
(define (any-var-live? vars live-vars)
(match vars
(() #f)
((var . vars)
(or (var-live? var live-vars)
(any-var-live? vars live-vars)))))
(define (cont-defs k)
(match (intmap-ref conts k)
(($ $kargs _ vars) vars)
(_ #f)))
(define (visit-live-exp label k exp live-labels live-vars)
(match exp
((or ($ $const) ($ $prim))
(values live-labels live-vars))
(($ $fun body)
(values (intset-add live-labels body) live-vars))
(($ $closure body)
(values (intset-add live-labels body) live-vars))
(($ $rec names vars (($ $fun kfuns) ...))
(let lp ((vars vars) (kfuns kfuns)
(live-labels live-labels) (live-vars live-vars))
(match (vector vars kfuns)
(#(() ()) (values live-labels live-vars))
(#((var . vars) (kfun . kfuns))
(lp vars kfuns
(if (var-live? var live-vars)
(intset-add live-labels kfun)
live-labels)
live-vars)))))
(($ $prompt escape? tag handler)
(values live-labels (adjoin-var tag live-vars)))
(($ $call proc args)
(values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk kfun proc args)
(values (intset-add live-labels kfun)
(adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name args)
(values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name args))
(values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $values (arg)))
(values live-labels (adjoin-var arg live-vars)))
(($ $values args)
(values live-labels
(match (cont-defs k)
(#f (adjoin-vars args live-vars))
(defs (fold (lambda (use def live-vars)
(if (var-live? def live-vars)
(adjoin-var use live-vars)
live-vars))
live-vars args defs)))))))
(define (visit-exp label k exp live-labels live-vars)
(cond
((intset-ref live-labels label)
;; Expression live already.
(visit-live-exp label k exp live-labels live-vars))
((let ((defs (cont-defs k))
(fx (intmap-ref effects label)))
(or
;; No defs; perhaps continuation is $ktail.
(not defs)
;; We don't remove branches.
(match exp (($ $branch) #t) (_ #f))
;; Do we have a live def?
(any-var-live? defs live-vars)
;; Does this expression cause all effects? If so, it's
;; definitely live.
(causes-all-effects? fx)
;; Does it cause a type check, but we weren't able to prove
;; that the types check?
(causes-effect? fx &type-check)
;; We might have a setter. If the object being assigned to
;; is live or was not created by us, then this expression is
;; live. Otherwise the value is still dead.
(and (causes-effect? fx &write)
(match exp
(($ $primcall
(or 'vector-set! 'vector-set!/immediate
'set-car! 'set-cdr!
'box-set!)
(obj . _))
(or (var-live? obj live-vars)
(not (intset-ref known-allocations obj))))
(_ #t)))))
;; Mark expression as live and visit.
(visit-live-exp label k exp (intset-add live-labels label) live-vars))
(else
;; Still dead.
(values live-labels live-vars))))
(define (visit-fun label live-labels live-vars)
;; Visit uses before definitions.
(postorder-fold-local-conts2
(lambda (label cont live-labels live-vars)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(visit-exp label k exp live-labels live-vars))
(($ $kreceive arity kargs)
(values live-labels live-vars))
(($ $kclause arity kargs kalt)
(values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
(($ $kfun src meta self)
(values live-labels (adjoin-var self live-vars)))
(($ $ktail)
(values live-labels live-vars))))
conts label live-labels live-vars))
(fixpoint (lambda (live-labels live-vars)
(let lp ((label 0)
(live-labels live-labels)
(live-vars live-vars))
(match (intset-next live-labels label)
(#f (values live-labels live-vars))
(label
(call-with-values
(lambda ()
(match (intmap-ref conts label)
(($ $kfun)
(visit-fun label live-labels live-vars))
(_ (values live-labels live-vars))))
(lambda (live-labels live-vars)
(lp (1+ label) live-labels live-vars)))))))
(intset 0)
empty-intset)))
(define-syntax adjoin-conts
(syntax-rules ()
((_ (exp ...) clause ...)
(let ((cps (exp ...)))
(adjoin-conts cps clause ...)))
((_ cps (label cont) clause ...)
(adjoin-conts (intmap-add! cps label (build-cont cont))
clause ...))
((_ cps)
cps)))
(define (process-eliminations conts live-labels live-vars)
(define (label-live? label)
(intset-ref live-labels label))
(define (value-live? var)
(intset-ref live-vars var))
(define (make-adaptor k src defs)
(let* ((names (map (lambda (_) 'tmp) defs))
(vars (map (lambda (_) (fresh-var)) defs))
(live (filter-map (lambda (def var)
(and (value-live? def) var))
defs vars)))
(build-cont
($kargs names vars
($continue k src ($values live))))))
(define (visit-term label term cps)
(match term
(($ $continue k src exp)
(if (label-live? label)
(match exp
(($ $fun body)
(values cps
term))
(($ $closure body nfree)
(values cps
term))
(($ $rec names vars funs)
(match (filter-map (lambda (name var fun)
(and (value-live? var)
(list name var fun)))
names vars funs)
(()
(values cps
(build-term ($continue k src ($values ())))))
(((names vars funs) ...)
(values cps
(build-term ($continue k src
($rec names vars funs)))))))
(_
(match (intmap-ref conts k)
(($ $kargs ())
(values cps term))
(($ $kargs names ((? value-live?) ...))
(values cps term))
(($ $kargs names vars)
(match exp
(($ $values args)
(let ((args (filter-map (lambda (use def)
(and (value-live? def) use))
args vars)))
(values cps
(build-term
($continue k src ($values args))))))
(_
(let-fresh (adapt) ()
(values (adjoin-conts cps
(adapt ,(make-adaptor k src vars)))
(build-term
($continue adapt src ,exp)))))))
(_
(values cps term)))))
(values cps
(build-term
($continue k src ($values ()))))))))
(define (visit-cont label cont cps)
(match cont
(($ $kargs names vars term)
(match (filter-map (lambda (name var)
(and (value-live? var)
(cons name var)))
names vars)
(((names . vars) ...)
(call-with-values (lambda () (visit-term label term cps))
(lambda (cps term)
(adjoin-conts cps
(label ($kargs names vars ,term))))))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(let ((defs (match (intmap-ref conts kargs)
(($ $kargs names vars) vars))))
(if (and-map value-live? defs)
(adjoin-conts cps (label ,cont))
(let-fresh (adapt) ()
(adjoin-conts cps
(adapt ,(make-adaptor kargs #f defs))
(label ($kreceive req rest adapt)))))))
(_
(adjoin-conts cps (label ,cont)))))
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold (lambda (label cont cps)
(match cont
(($ $kfun)
(if (label-live? label)
(fold-local-conts visit-cont conts label cps)
cps))
(_ cps)))
conts
empty-intmap))))
(define (eliminate-dead-code conts)
;; We work on a renumbered program so that we can easily visit uses
;; before definitions just by visiting higher-numbered labels before
;; lower-numbered labels. Renumbering is also a precondition for type
;; inference.
(let ((conts (renumber conts)))
(call-with-values (lambda () (compute-live-code conts))
(lambda (live-labels live-vars)
(process-eliminations conts live-labels live-vars)))))
;;; Local Variables:
;;; eval: (put 'adjoin-conts 'scheme-indent-function 1)
;;; End:

484
module/language/cps/effects-analysis.scm Normal file
View file

@ -0,0 +1,484 @@
;;; Effects analysis on CPS
;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; A helper module to compute the set of effects caused by an
;;; expression. This information is useful when writing algorithms that
;;; move code around, while preserving the semantics of an input
;;; program.
;;;
;;; The effects set is represented as an integer with three parts. The
;;; low 4 bits indicate effects caused by an expression, as a bitfield.
;;; The next 4 bits indicate the kind of memory accessed by the
;;; expression, if it accesses mutable memory. Finally the rest of the
;;; bits indicate the field in the object being accessed, if known, or
;;; -1 for unknown.
;;;
;;; In this way we embed a coarse type-based alias analysis in the
;;; effects analysis. For example, a "car" call is modelled as causing
;;; a read to field 0 on a &pair, and causing a &type-check effect. If
;;; any intervening code sets the car of any pair, that will block
;;; motion of the "car" call, because any write to field 0 of a pair is
;;; seen by effects analysis as being a write to field 0 of all pairs.
;;;
;;; Code:
(define-module (language cps effects-analysis)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (ice-9 match)
#:export (expression-effects
compute-effects
synthesize-definition-effects
&allocation
&type-check
&read
&write
&fluid
&prompt
&car
&cdr
&vector
&box
&module
&struct
&string
&bytevector
&object
&field
&allocate
&read-object
&read-field
&write-object
&write-field
&no-effects
&all-effects
exclude-effects
effect-free?
constant?
causes-effect?
causes-all-effects?
effect-clobbers?))
(define-syntax define-flags
(lambda (x)
(syntax-case x ()
((_ all shift name ...)
(let ((count (length #'(name ...))))
(with-syntax (((n ...) (iota count))
(count count))
#'(begin
(define-syntax name (identifier-syntax (ash 1 n)))
...
(define-syntax all (identifier-syntax (1- (ash 1 count))))
(define-syntax shift (identifier-syntax count)))))))))
(define-syntax define-enumeration
(lambda (x)
(define (count-bits n)
(let lp ((out 1))
(if (< n (ash 1 (1- out)))
out
(lp (1+ out)))))
(syntax-case x ()
((_ mask shift name ...)
(let* ((len (length #'(name ...)))
(bits (count-bits len)))
(with-syntax (((n ...) (iota len))
(bits bits))
#'(begin
(define-syntax name (identifier-syntax n))
...
(define-syntax mask (identifier-syntax (1- (ash 1 bits))))
(define-syntax shift (identifier-syntax bits)))))))))
(define-flags &all-effect-kinds &effect-kind-bits
;; Indicates that an expression may cause a type check. A type check,
;; for the purposes of this analysis, is the possibility of throwing
;; an exception the first time an expression is evaluated. If the
;; expression did not cause an exception to be thrown, users can
;; assume that evaluating the expression again will not cause an
;; exception to be thrown.
;;
;; For example, (+ x y) might throw if X or Y are not numbers. But if
;; it doesn't throw, it should be safe to elide a dominated, common
;; subexpression (+ x y).
&type-check
;; Indicates that an expression may return a fresh object. The kind
;; of object is indicated in the object kind field.
&allocation
;; Indicates that an expression may cause a read from memory. The
;; kind of memory is given in the object kind field. Some object
;; kinds have finer-grained fields; those are expressed in the "field"
;; part of the effects value. -1 indicates "the whole object".
&read
;; Indicates that an expression may cause a write to memory.
&write)
(define-enumeration &memory-kind-mask &memory-kind-bits
;; Indicates than an expression may access unknown kinds of memory.
&unknown-memory-kinds
;; Indicates that an expression depends on the value of a fluid
;; variable, or on the current fluid environment.
&fluid
;; Indicates that an expression depends on the current prompt
;; stack.
&prompt
;; Indicates that an expression depends on the value of the car or cdr
;; of a pair.
&pair
;; Indicates that an expression depends on the value of a vector
;; field. The effect field indicates the specific field, or zero for
;; an unknown field.
&vector
;; Indicates that an expression depends on the value of a variable
;; cell.
&box
;; Indicates that an expression depends on the current module.
&module
;; Indicates that an expression depends on the value of a struct
;; field. The effect field indicates the specific field, or zero for
;; an unknown field.
&struct
;; Indicates that an expression depends on the contents of a string.
&string
;; Indicates that an expression depends on the contents of a
;; bytevector. We cannot be more precise, as bytevectors may alias
;; other bytevectors.
&bytevector)
(define-inlinable (&field kind field)
(ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
(define-inlinable (&object kind)
(&field kind -1))
(define-inlinable (&allocate kind)
(logior &allocation (&object kind)))
(define-inlinable (&read-field kind field)
(logior &read (&field kind field)))
(define-inlinable (&read-object kind)
(logior &read (&object kind)))
(define-inlinable (&write-field kind field)
(logior &write (&field kind field)))
(define-inlinable (&write-object kind)
(logior &write (&object kind)))
(define-syntax &no-effects (identifier-syntax 0))
(define-syntax &all-effects
(identifier-syntax
(logior &all-effect-kinds (&object &unknown-memory-kinds))))
(define-inlinable (constant? effects)
(zero? effects))
(define-inlinable (causes-effect? x effects)
(not (zero? (logand x effects))))
(define-inlinable (causes-all-effects? x)
(eqv? x &all-effects))
(define (effect-clobbers? a b)
"Return true if A clobbers B. This is the case if A is a write, and B
is or might be a read or a write to the same location as A."
(define (locations-same?)
(let ((a (ash a (- &effect-kind-bits)))
(b (ash b (- &effect-kind-bits))))
(or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
(eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
(and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
;; A negative field indicates "the whole object".
;; Non-negative fields indicate only part of the object.
(or (< a 0) (< b 0) (= a b))))))
(and (not (zero? (logand a &write)))
(not (zero? (logand b (logior &read &write))))
(locations-same?)))
(define-inlinable (indexed-field kind var constants)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(if (and (exact-integer? val) (<= 0 val))
(&field kind val)
(&object kind))))
(define *primitive-effects* (make-hash-table))
(define-syntax-rule (define-primitive-effects* constants
((name . args) effects ...)
...)
(begin
(hashq-set! *primitive-effects* 'name
(case-lambda*
((constants . args) (logior effects ...))
(_ &all-effects)))
...))
(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
(define-primitive-effects* constants ((name . args) effects ...) ...))
;; Miscellaneous.
(define-primitive-effects
((values . _)))
;; Generic effect-free predicates.
(define-primitive-effects
((eq? . _))
((eqv? . _))
((equal? . _))
((pair? arg))
((null? arg))
((nil? arg ))
((symbol? arg))
((variable? arg))
((vector? arg))
((struct? arg))
((string? arg))
((number? arg))
((char? arg))
((bytevector? arg))
((keyword? arg))
((bitvector? arg))
((procedure? arg))
((thunk? arg)))
;; Fluids.
(define-primitive-effects
((fluid-ref f) (&read-object &fluid) &type-check)
((fluid-set! f v) (&write-object &fluid) &type-check)
((push-fluid f v) (&write-object &fluid) &type-check)
((pop-fluid) (&write-object &fluid) &type-check))
;; Prompts.
(define-primitive-effects
((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
;; Pairs.
(define-primitive-effects
((cons a b) (&allocate &pair))
((list . _) (&allocate &pair))
((car x) (&read-field &pair 0) &type-check)
((set-car! x y) (&write-field &pair 0) &type-check)
((cdr x) (&read-field &pair 1) &type-check)
((set-cdr! x y) (&write-field &pair 1) &type-check)
((memq x y) (&read-object &pair) &type-check)
((memv x y) (&read-object &pair) &type-check)
((list? arg) (&read-field &pair 1))
((length l) (&read-field &pair 1) &type-check))
;; Variables.
(define-primitive-effects
((box v) (&allocate &box))
((box-ref v) (&read-object &box) &type-check)
((box-set! v x) (&write-object &box) &type-check))
;; Vectors.
(define (vector-field n constants)
(indexed-field &vector n constants))
(define (read-vector-field n constants)
(logior &read (vector-field n constants)))
(define (write-vector-field n constants)
(logior &write (vector-field n constants)))
(define-primitive-effects* constants
((vector . _) (&allocate &vector))
((make-vector n init) (&allocate &vector) &type-check)
((make-vector/immediate n init) (&allocate &vector))
((vector-ref v n) (read-vector-field n constants) &type-check)
((vector-ref/immediate v n) (read-vector-field n constants) &type-check)
((vector-set! v n x) (write-vector-field n constants) &type-check)
((vector-set!/immediate v n x) (write-vector-field n constants) &type-check)
((vector-length v) &type-check))
;; Structs.
(define (struct-field n constants)
(indexed-field &struct n constants))
(define (read-struct-field n constants)
(logior &read (struct-field n constants)))
(define (write-struct-field n constants)
(logior &write (struct-field n constants)))
(define-primitive-effects* constants
((allocate-struct vt n) (&allocate &struct) &type-check)
((allocate-struct/immediate v n) (&allocate &struct) &type-check)
((make-struct vt ntail . _) (&allocate &struct) &type-check)
((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
((struct-ref s n) (read-struct-field n constants) &type-check)
((struct-ref/immediate s n) (read-struct-field n constants) &type-check)
((struct-set! s n x) (write-struct-field n constants) &type-check)
((struct-set!/immediate s n x) (write-struct-field n constants) &type-check)
((struct-vtable s) &type-check))
;; Strings.
(define-primitive-effects
((string-ref s n) (&read-object &string) &type-check)
((string-set! s n c) (&write-object &string) &type-check)
((number->string _) (&allocate &string) &type-check)
((string->number _) (&read-object &string) &type-check)
((string-length s) &type-check))
;; Bytevectors.
(define-primitive-effects
((bytevector-length _) &type-check)
((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
((bv-u16-ref bv n) (&read-object &bytevector) &type-check)
((bv-s16-ref bv n) (&read-object &bytevector) &type-check)
((bv-u32-ref bv n) (&read-object &bytevector) &type-check)
((bv-s32-ref bv n) (&read-object &bytevector) &type-check)
((bv-u64-ref bv n) (&read-object &bytevector) &type-check)
((bv-s64-ref bv n) (&read-object &bytevector) &type-check)
((bv-f32-ref bv n) (&read-object &bytevector) &type-check)
((bv-f64-ref bv n) (&read-object &bytevector) &type-check)
((bv-u8-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s8-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u16-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s16-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u64-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s64-set! bv n x) (&write-object &bytevector) &type-check)
((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
;; Modules.
(define-primitive-effects
((current-module) (&read-object &module))
((cache-current-module! m scope) (&write-object &box))
((resolve name bound?) (&read-object &module) &type-check)
((cached-toplevel-box scope name bound?) &type-check)
((cached-module-box mod name public? bound?) &type-check)
((define! name val) (&read-object &module) (&write-object &box)))
;; Numbers.
(define-primitive-effects
((= . _) &type-check)
((< . _) &type-check)
((> . _) &type-check)
((<= . _) &type-check)
((>= . _) &type-check)
((zero? . _) &type-check)
((add . _) &type-check)
((mul . _) &type-check)
((sub . _) &type-check)
((div . _) &type-check)
((sub1 . _) &type-check)
((add1 . _) &type-check)
((quo . _) &type-check)
((rem . _) &type-check)
((mod . _) &type-check)
((complex? _) &type-check)
((real? _) &type-check)
((rational? _) &type-check)
((inf? _) &type-check)
((nan? _) &type-check)
((integer? _) &type-check)
((exact? _) &type-check)
((inexact? _) &type-check)
((even? _) &type-check)
((odd? _) &type-check)
((ash n m) &type-check)
((logand . _) &type-check)
((logior . _) &type-check)
((logxor . _) &type-check)
((lognot . _) &type-check)
((logtest a b) &type-check)
((logbit? a b) &type-check)
((sqrt _) &type-check)
((abs _) &type-check))
;; Characters.
(define-primitive-effects
((char<? . _) &type-check)
((char<=? . _) &type-check)
((char>=? . _) &type-check)
((char>? . _) &type-check)
((integer->char _) &type-check)
((char->integer _) &type-check))
(define (primitive-effects constants name args)
(let ((proc (hashq-ref *primitive-effects* name)))
(if proc
(apply proc constants args)
&all-effects)))
(define (expression-effects exp constants)
(match exp
((or ($ $const) ($ $prim) ($ $values))
&no-effects)
((or ($ $fun) ($ $rec) ($ $closure))
(&allocate &unknown-memory-kinds))
(($ $prompt)
(&write-object &prompt))
((or ($ $call) ($ $callk))
&all-effects)
(($ $branch k exp)
(expression-effects exp constants))
(($ $primcall name args)
(primitive-effects constants name args))))
(define (compute-effects conts)
(let ((constants (compute-constant-values conts)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names syms ($ $continue k src exp))
(expression-effects exp constants))
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)
(($ $arity () () _ () #f) (&allocate &pair))
(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
(($ $kfun) &type-check)
(($ $kclause) &type-check)
(($ $ktail) &no-effects)))
conts)))
;; There is a way to abuse effects analysis in CSE to also do scalar
;; replacement, effectively adding `car' and `cdr' expressions to `cons'
;; expressions, and likewise with other constructors and setters. This
;; routine adds appropriate effects to `cons' and `set-car!' and the
;; like.
;;
;; This doesn't affect CSE's ability to eliminate expressions, given
;; that allocations aren't eliminated anyway, and the new effects will
;; just cause the allocations not to commute with e.g. set-car! which
;; is what we want anyway.
(define (synthesize-definition-effects effects)
(intmap-map (lambda (label fx)
(if (logtest (logior &write &allocation) fx)
(logior fx &read)
fx))
effects))

88
module/language/cps/elide-values.scm Normal file
View file

@ -0,0 +1,88 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Primcalls that don't correspond to VM instructions are treated as if
;;; they are calls, and indeed the later reify-primitives pass turns
;;; them into calls. Because no return arity checking is done for these
;;; primitives, if a later optimization pass simplifies the primcall to
;;; a VM operation, the tail of the simplification has to be a
;;; primcall to 'values. Most of these primcalls can be elided, and
;;; that is the job of this pass.
;;;
;;; Code:
(define-module (language cps elide-values)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:export (elide-values))
(define (inline-values cps k src args)
(match (intmap-ref cps k)
(($ $ktail)
(with-cps cps
(build-term
($continue k src ($values args)))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(cond
((and (not rest) (= (length args) (length req)))
(with-cps cps
(build-term
($continue kargs src ($values args)))))
((and rest (>= (length args) (length req)))
(let ()
(define (build-rest cps k tail)
(match tail
(()
(with-cps cps
(build-term ($continue k src ($const '())))))
((v . tail)
(with-cps cps
(letv rest)
(letk krest ($kargs ('rest) (rest)
($continue k src ($primcall 'cons (v rest)))))
($ (build-rest krest tail))))))
(with-cps cps
(letv rest)
(letk krest ($kargs ('rest) (rest)
($continue kargs src
($values ,(append (list-head args (length req))
(list rest))))))
($ (build-rest krest (list-tail args (length req)))))))
(else (with-cps cps #f))))))
(define (elide-values conts)
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall 'values args)))
(call-with-values (lambda () (inline-values out k src args))
(lambda (out term)
(if term
(let ((cont (build-cont ($kargs names vars ,term))))
(intmap-replace! out label cont))
out))))
(_ out)))
conts
conts))))

106
module/language/cps/optimize.scm Normal file
View file

@ -0,0 +1,106 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Optimizations on CPS.
;;;
;;; Code:
(define-module (language cps optimize)
#:use-module (ice-9 match)
#:use-module (language cps constructors)
#:use-module (language cps contification)
#:use-module (language cps cse)
#:use-module (language cps dce)
#:use-module (language cps elide-values)
#:use-module (language cps prune-top-level-scopes)
#:use-module (language cps prune-bailouts)
#:use-module (language cps self-references)
#:use-module (language cps simplify)
#:use-module (language cps specialize-primcalls)
#:use-module (language cps split-rec)
#:use-module (language cps type-fold)
#:use-module (language cps verify)
#:export (optimize-higher-order-cps
optimize-first-order-cps))
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define *debug?* #f)
(define (maybe-verify program)
(if *debug?*
(verify program)
program))
(define-syntax-rule (define-optimizer optimize (pass kw default) ...)
(define* (optimize program #:optional (opts '()))
;; This series of assignments to `program' used to be a series of
;; let* bindings of `program', as you would imagine. In compiled
;; code this is fine because the compiler is able to allocate all
;; let*-bound variable to the same slot, which also means that the
;; garbage collector doesn't have to retain so many copies of the
;; term being optimized. However during bootstrap, the interpreter
;; doesn't do this optimization, leading to excessive data retention
;; as the terms are rewritten. To marginally improve bootstrap
;; memory usage, here we use set! instead. The compiler should
;; produce the same code in any case, though currently it does not
;; because it doesn't do escape analysis on the box created for the
;; set!.
(maybe-verify program)
(set! program
(if (kw-arg-ref opts kw default)
(maybe-verify (pass program))
program))
...
(verify program)
program))
;; Passes that are needed:
;;
;; * Abort contification: turning abort primcalls into continuation
;; calls, and eliding prompts if possible.
;;
;; * Loop peeling. Unrolls the first round through a loop if the
;; loop has effects that CSE can work on. Requires effects
;; analysis. When run before CSE, loop peeling is the equivalent
;; of loop-invariant code motion (LICM).
;;
(define-optimizer optimize-higher-order-cps
(split-rec #:split-rec? #t)
(eliminate-dead-code #:eliminate-dead-code? #t)
(prune-top-level-scopes #:prune-top-level-scopes? #t)
(simplify #:simplify? #t)
(contify #:contify? #t)
(inline-constructors #:inline-constructors? #t)
(specialize-primcalls #:specialize-primcalls? #t)
(elide-values #:elide-values? #t)
(prune-bailouts #:prune-bailouts? #t)
(eliminate-common-subexpressions #:cse? #t)
(type-fold #:type-fold? #t)
(resolve-self-references #:resolve-self-references? #t)
(eliminate-dead-code #:eliminate-dead-code? #t)
(simplify #:simplify? #t))
(define-optimizer optimize-first-order-cps
(eliminate-dead-code #:eliminate-dead-code? #t)
(simplify #:simplify? #t))

86
module/language/cps/prune-bailouts.scm Normal file
View file

@ -0,0 +1,86 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; A pass that prunes successors of expressions that bail out.
;;;
;;; Code:
(define-module (language cps prune-bailouts)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (prune-bailouts))
(define (compute-tails conts)
"For each LABEL->CONT entry in the intmap CONTS, compute a
LABEL->TAIL-LABEL indicating the tail continuation of each expression's
containing function. In some cases TAIL-LABEL might not be available,
for example if there is a stale $kfun pointing at a body, or for
unreferenced terms. In that case TAIL-LABEL is either absent or #f."
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kfun src meta self tail clause)
(intset-fold (lambda (label out)
(intmap-add out label tail (lambda (old new) #f)))
(compute-function-body conts label)
out))
(_ out)))
conts
empty-intmap))
(define (prune-bailout out tails k src exp)
(match (intmap-ref out k)
(($ $ktail)
(with-cps out #f))
(_
(match (intmap-ref tails k (lambda (_) #f))
(#f
(with-cps out #f))
(ktail
(with-cps out
(letv prim rest)
(letk kresult ($kargs ('rest) (rest)
($continue ktail src ($values ()))))
(letk kreceive ($kreceive '() 'rest kresult))
(build-term ($continue kreceive src ,exp))))))))
(define (prune-bailouts conts)
(let ((tails (compute-tails conts)))
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars
($ $continue k src
(and exp ($ $primcall (or 'error 'scm-error 'throw)))))
(call-with-values (lambda () (prune-bailout out tails k src exp))
(lambda (out term)
(if term
(let ((cont (build-cont ($kargs names vars ,term))))
(intmap-replace! out label cont))
out))))
(_ out)))
conts
conts)))))

63
module/language/cps/prune-top-level-scopes.scm Normal file
View file

@ -0,0 +1,63 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; A simple pass to prune unneeded top-level scopes.
;;;
;;; Code:
(define-module (language cps prune-top-level-scopes)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (prune-top-level-scopes))
(define (compute-used-scopes conts constants)
(persistent-intset
(intmap-fold
(lambda (label cont used-scopes)
(match cont
(($ $kargs _ _
($ $continue k src
($ $primcall 'cached-toplevel-box (scope name bound?))))
(intset-add! used-scopes (intmap-ref constants scope)))
(_
used-scopes)))
conts
empty-intset)))
(define (prune-top-level-scopes conts)
(let* ((constants (compute-constant-values conts))
(used-scopes (compute-used-scopes conts constants)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars
($ $continue k src
($ $primcall 'cache-current-module!
(module (? (lambda (scope)
(let ((val (intmap-ref constants scope)))
(not (intset-ref used-scopes val)))))))))
(build-cont ($kargs names vars
($continue k src ($values ())))))
(_
cont)))
conts)))

167
module/language/cps/reify-primitives.scm Normal file
View file

@ -0,0 +1,167 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; A pass to reify lone $prim's that were never folded into a
;;; $primcall, and $primcall's to primitives that don't have a
;;; corresponding VM op.
;;;
;;; Code:
(define-module (language cps reify-primitives)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps primitives)
#:use-module (language cps intmap)
#:use-module (language bytecode)
#:export (reify-primitives))
(define (module-box cps src module name public? bound? val-proc)
(with-cps cps
(letv box)
(let$ body (val-proc box))
(letk kbox ($kargs ('box) (box) ,body))
($ (with-cps-constants ((module module)
(name name)
(public? public?)
(bound? bound?))
(build-term ($continue kbox src
($primcall 'cached-module-box
(module name public? bound?))))))))
(define (primitive-module name)
(case name
((bytevector?
bytevector-length
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
bytevector-u16-ref bytevector-u16-set!
bytevector-u16-native-ref bytevector-u16-native-set!
bytevector-s16-ref bytevector-s16-set!
bytevector-s16-native-ref bytevector-s16-native-set!
bytevector-u32-ref bytevector-u32-set!
bytevector-u32-native-ref bytevector-u32-native-set!
bytevector-s32-ref bytevector-s32-set!
bytevector-s32-native-ref bytevector-s32-native-set!
bytevector-u64-ref bytevector-u64-set!
bytevector-u64-native-ref bytevector-u64-native-set!
bytevector-s64-ref bytevector-s64-set!
bytevector-s64-native-ref bytevector-s64-native-set!
bytevector-ieee-single-ref bytevector-ieee-single-set!
bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
bytevector-ieee-double-ref bytevector-ieee-double-set!
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
'(rnrs bytevectors))
((class-of) '(oop goops))
(else '(guile))))
(define (primitive-ref cps name k src)
(module-box cps src (primitive-module name) name #f #t
(lambda (cps box)
(with-cps cps
(build-term
($continue k src ($primcall 'box-ref (box))))))))
(define (builtin-ref cps idx k src)
(with-cps cps
($ (with-cps-constants ((idx idx))
(build-term
($continue k src ($primcall 'builtin-ref (idx))))))))
(define (reify-clause cps ktail)
(with-cps cps
(letv throw)
(let$ throw-body
(with-cps-constants ((wna 'wrong-number-of-args)
(false #f)
(str "Wrong number of arguments")
(eol '()))
(build-term
($continue ktail #f
($call throw (wna false str eol false))))))
(letk kthrow ($kargs ('throw) (throw) ,throw-body))
(let$ body (primitive-ref 'throw kthrow #f))
(letk kbody ($kargs () () ,body))
(letk kclause ($kclause ('() '() #f '() #f) kbody #f))
kclause))
;; A $kreceive continuation should have only one predecessor.
(define (uniquify-receive cps k)
(match (intmap-ref cps k)
(($ $kreceive ($ $arity req () rest () #f) kargs)
(with-cps cps
(letk k ($kreceive req rest kargs))
k))
(_
(with-cps cps k))))
(define (reify-primitives cps)
(define (visit-cont label cont cps)
(define (resolve-prim cps name k src)
(cond
((builtin-name->index name)
=> (lambda (idx) (builtin-ref cps idx k src)))
(else
(primitive-ref cps name k src))))
(match cont
(($ $kfun src meta self tail #f)
(with-cps cps
(let$ clause (reify-clause tail))
(setk label ($kfun src meta self tail clause))))
(($ $kargs names vars ($ $continue k src ($ $prim name)))
(with-cps cps
(let$ k (uniquify-receive k))
(let$ body (resolve-prim name k src))
(setk label ($kargs names vars ,body))))
(($ $kargs names vars
($ $continue k src ($ $primcall 'call-thunk/no-inline (proc))))
(with-cps cps
(setk label ($kargs names vars ($continue k src ($call proc ()))))))
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
(if (or (prim-instruction name) (branching-primitive? name))
;; Assume arities are correct.
cps
(with-cps cps
(letv proc)
(let$ k (uniquify-receive k))
(letk kproc ($kargs ('proc) (proc)
($continue k src ($call proc args))))
(let$ body (resolve-prim name kproc src))
(setk label ($kargs names vars ,body)))))
(($ $kargs names vars ($ $continue k src ($ $call proc args)))
(with-cps cps
(let$ k (uniquify-receive k))
(setk label ($kargs names vars
($continue k src ($call proc args))))))
(($ $kargs names vars ($ $continue k src ($ $callk k* proc args)))
(with-cps cps
(let$ k (uniquify-receive k))
(setk label ($kargs names vars
($continue k src ($callk k* proc args))))))
(_ cps)))
(with-fresh-name-state cps
(persistent-intmap (intmap-fold visit-cont cps cps))))

217
module/language/cps/renumber.scm Normal file
View file

@ -0,0 +1,217 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; A pass to renumber variables and continuation labels so that they
;;; are contiguous within each function and, in the case of labels,
;;; topologically sorted.
;;;
;;; Code:
(define-module (language cps renumber)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (renumber))
(define* (compute-tail-path-lengths conts kfun preds)
(define (add-lengths labels lengths length)
(intset-fold (lambda (label lengths)
(intmap-add! lengths label length))
labels
lengths))
(define (compute-next labels lengths)
(intset-fold (lambda (label labels)
(fold1 (lambda (pred labels)
(if (intmap-ref lengths pred (lambda (_) #f))
labels
(intset-add! labels pred)))
(intmap-ref preds label)
labels))
labels
empty-intset))
(define (visit labels lengths length)
(let ((lengths (add-lengths labels lengths length)))
(values (compute-next labels lengths) lengths (1+ length))))
(match (intmap-ref conts kfun)
(($ $kfun src meta self tail clause)
(worklist-fold visit (intset-add empty-intset tail) empty-intmap 0))))
;; Topologically sort the continuation tree starting at k0, using
;; reverse post-order numbering.
(define (sort-labels-locally conts k0 path-lengths)
(define (visit-kf-first? kf kt)
;; Visit the successor of a branch with the shortest path length to
;; the tail first, so that if the branches are unsorted, the longer
;; path length will appear first. This will move a loop exit out of
;; a loop.
(let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f)))
(kt-len (intmap-ref path-lengths kt (lambda (_) #f))))
(if kt-len
(or (not kf-len) (< kf-len kt-len)
;; If the path lengths are the same, preserve original
;; order to avoid squirreliness.
(and (= kf-len kt-len) (< kt kf)))
(if kf-len #f (< kt kf)))))
(let ((order '())
(visited empty-intset))
(let visit ((k k0) (order '()) (visited empty-intset))
(define (visit2 k0 k1 order visited)
(let-values (((order visited) (visit k0 order visited)))
(visit k1 order visited)))
(if (intset-ref visited k)
(values order visited)
(let ((visited (intset-add visited k)))
(call-with-values
(lambda ()
(match (intmap-ref conts k)
(($ $kargs names syms ($ $continue k src exp))
(match exp
(($ $prompt escape? tag handler)
(visit2 k handler order visited))
(($ $branch kt)
(if (visit-kf-first? k kt)
(visit2 k kt order visited)
(visit2 kt k order visited)))
(_
(visit k order visited))))
(($ $kreceive arity k) (visit k order visited))
(($ $kclause arity kbody kalt)
(if kalt
(visit2 kalt kbody order visited)
(visit kbody order visited)))
(($ $kfun src meta self tail clause)
(if clause
(visit2 tail clause order visited)
(visit tail order visited)))
(($ $ktail) (values order visited))))
(lambda (order visited)
;; Add k to the reverse post-order.
(values (cons k order) visited))))))))
(define (compute-renaming conts kfun)
;; labels := old -> new
;; vars := old -> new
(define *next-label* -1)
(define *next-var* -1)
(define (rename-label label labels)
(set! *next-label* (1+ *next-label*))
(intmap-add! labels label *next-label*))
(define (rename-var sym vars)
(set! *next-var* (1+ *next-var*))
(intmap-add! vars sym *next-var*))
(define (rename label labels vars)
(values (rename-label label labels)
(match (intmap-ref conts label)
(($ $kargs names syms exp)
(fold1 rename-var syms vars))
(($ $kfun src meta self tail clause)
(rename-var self vars))
(_ vars))))
(define (maybe-visit-fun kfun labels vars)
(if (intmap-ref labels kfun (lambda (_) #f))
(values labels vars)
(visit-fun kfun labels vars)))
(define (visit-nested-funs k labels vars)
(match (intmap-ref conts k)
(($ $kargs names syms ($ $continue k src ($ $fun kfun)))
(visit-fun kfun labels vars))
(($ $kargs names syms ($ $continue k src ($ $rec names* syms*
(($ $fun kfun) ...))))
(fold2 visit-fun kfun labels vars))
(($ $kargs names syms ($ $continue k src ($ $closure kfun nfree)))
;; Closures with zero free vars get copy-propagated so it's
;; possible to already have visited them.
(maybe-visit-fun kfun labels vars))
(($ $kargs names syms ($ $continue k src ($ $callk kfun)))
;; Well-known functions never have a $closure created for them
;; and are only referenced by their $callk call sites.
(maybe-visit-fun kfun labels vars))
(_ (values labels vars))))
(define (visit-fun kfun labels vars)
(let* ((preds (compute-predecessors conts kfun))
(path-lengths (compute-tail-path-lengths conts kfun preds))
(order (sort-labels-locally conts kfun path-lengths)))
;; First rename locally, then recurse on nested functions.
(let-values (((labels vars) (fold2 rename order labels vars)))
(fold2 visit-nested-funs order labels vars))))
(let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
(values (persistent-intmap labels) (persistent-intmap vars))))
(define* (renumber conts #:optional (kfun 0))
(let-values (((label-map var-map) (compute-renaming conts kfun)))
(define (rename-label label) (intmap-ref label-map label))
(define (rename-var var) (intmap-ref var-map var))
(define (rename-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $closure k nfree)
($closure (rename-label k) nfree))
(($ $fun body)
($fun (rename-label body)))
(($ $rec names vars funs)
($rec names (map rename-var vars) (map rename-exp funs)))
(($ $values args)
($values ,(map rename-var args)))
(($ $call proc args)
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
(($ $branch kt exp)
($branch (rename-label kt) ,(rename-exp exp)))
(($ $primcall name args)
($primcall name ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
(define (rename-arity arity)
(match arity
(($ $arity req opt rest () aok?)
arity)
(($ $arity req opt rest kw aok?)
(match kw
(() arity)
(((kw kw-name kw-var) ...)
(let ((kw (map list kw kw-name (map rename-var kw-var))))
(make-$arity req opt rest kw aok?)))))))
(persistent-intmap
(intmap-fold
(lambda (old-k new-k out)
(intmap-add!
out
new-k
(rewrite-cont (intmap-ref conts old-k)
(($ $kargs names syms ($ $continue k src exp))
($kargs names (map rename-var syms)
($continue (rename-label k) src ,(rename-exp exp))))
(($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (rename-label k)))
(($ $ktail)
($ktail))
(($ $kfun src meta self tail clause)
($kfun src meta (rename-var self) (rename-label tail)
(and clause (rename-label clause))))
(($ $kclause arity body alternate)
($kclause ,(rename-arity arity) (rename-label body)
(and alternate (rename-label alternate)))))))
label-map
empty-intmap))))

79
module/language/cps/self-references.scm Normal file
View file

@ -0,0 +1,79 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; A pass that replaces free references to recursive functions with
;;; bound references.
;;;
;;; Code:
(define-module (language cps self-references)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (resolve-self-references))
(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap))
(define (subst var)
(intmap-ref env var (lambda (var) var)))
(define (rename-exp label cps names vars k src exp)
(let ((exp (rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
(($ $primcall name args)
($primcall name ,(map subst args)))
(($ $branch k ($ $values (arg)))
($branch k ($values ((subst arg)))))
(($ $branch k ($ $primcall name args))
($branch k ($primcall name ,(map subst args))))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))
(intmap-replace! cps label
(build-cont
($kargs names vars ($continue k src ,exp))))))
(define (visit-exp cps label names vars k src exp)
(match exp
(($ $fun label)
(resolve-self-references cps label env))
(($ $rec names vars (($ $fun labels) ...))
(fold (lambda (label var cps)
(match (intmap-ref cps label)
(($ $kfun src meta self)
(resolve-self-references cps label
(intmap-add env var self)))))
cps labels vars))
(_ (rename-exp label cps names vars k src exp))))
(intset-fold (lambda (label cps)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp cps label names vars k src exp))
(_ cps)))
(compute-function-body cps label)
cps))

267
module/language/cps/simplify.scm Normal file
View file

@ -0,0 +1,267 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; The fundamental lambda calculus reductions, like beta and eta
;;; reduction and so on. Pretty lame currently.
;;;
;;; Code:
(define-module (language cps simplify)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (simplify))
(define (intset-maybe-add! set k add?)
(if add? (intset-add! set k) set))
(define (intset-add* set k*)
(let lp ((set set) (k* k*))
(match k*
((k . k*) (lp (intset-add set k) k*))
(() set))))
(define (intset-add*! set k*)
(fold1 (lambda (k set) (intset-add! set k)) k* set))
(define (fold2* f l1 l2 seed)
(let lp ((l1 l1) (l2 l2) (seed seed))
(match (cons l1 l2)
((() . ()) seed)
(((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed))))))
(define (transform-conts f conts)
(persistent-intmap
(intmap-fold (lambda (k v out)
(let ((v* (f k v)))
(cond
((equal? v v*) out)
(v* (intmap-replace! out k v*))
(else (intmap-remove out k)))))
conts
conts)))
(define (compute-singly-referenced-vars conts)
(define (visit label cont single multiple)
(define (add-ref var single multiple)
(if (intset-ref single var)
(values single (intset-add! multiple var))
(values (intset-add! single var) multiple)))
(define (ref var) (add-ref var single multiple))
(define (ref* vars) (fold2 add-ref vars single multiple))
(match cont
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
(values single multiple))
(($ $call proc args)
(ref* (cons proc args)))
(($ $callk k proc args)
(ref* (cons proc args)))
(($ $primcall name args)
(ref* args))
(($ $values args)
(ref* args))
(($ $branch kt ($ $values (var)))
(ref var))
(($ $branch kt ($ $primcall name args))
(ref* args))
(($ $prompt escape? tag handler)
(ref tag))))
(_
(values single multiple))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold visit conts single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
;;; Continuations whose values are simply forwarded to another and not
;;; used in any other way may be elided via eta reduction over labels.
;;;
;;; There is an exception however: we must exclude strongly-connected
;;; components (SCCs). The only kind of SCC we can build out of $values
;;; expressions are infinite loops.
;;;
;;; Condition A below excludes single-node SCCs. Single-node SCCs
;;; cannot be reduced.
;;;
;;; Condition B conservatively excludes edges to labels already marked
;;; as candidates. This prevents back-edges and so breaks SCCs, and is
;;; optimal if labels are sorted. If the labels aren't sorted it's
;;; suboptimal but cheap.
(define (compute-eta-reductions conts kfun)
(let ((singly-used (compute-singly-referenced-vars conts)))
(define (singly-used? vars)
(match vars
(() #t)
((var . vars)
(and (intset-ref singly-used var) (singly-used? vars)))))
(define (visit-fun kfun body eta)
(define (visit-cont label eta)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src ($ $values vars)))
(intset-maybe-add! eta label
(match (intmap-ref conts k)
(($ $kargs)
(and (not (eqv? label k)) ; A
(not (intset-ref eta label)) ; B
(singly-used? vars)))
(_ #f))))
(_
eta)))
(intset-fold visit-cont body eta))
(persistent-intset
(intmap-fold visit-fun
(compute-reachable-functions conts kfun)
empty-intset))))
(define (eta-reduce conts kfun)
(let ((label-set (compute-eta-reductions conts kfun)))
;; Replace any continuation to a label in LABEL-SET with the label's
;; continuation. The label will denote a $kargs continuation, so
;; only terms that can continue to $kargs need be taken into
;; account.
(define (subst label)
(if (intset-ref label-set label)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue k)) (subst k)))
label))
(transform-conts
(lambda (label cont)
(and (not (intset-ref label-set label))
(rewrite-cont cont
(($ $kargs names syms ($ $continue kf src ($ $branch kt exp)))
($kargs names syms
($continue (subst kf) src ($branch (subst kt) ,exp))))
(($ $kargs names syms ($ $continue k src exp))
($kargs names syms
($continue (subst k) src ,exp)))
(($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (subst k)))
(($ $kclause arity body alt)
($kclause ,arity (subst body) alt))
(_ ,cont))))
conts)))
(define (compute-singly-referenced-labels conts body)
(define (add-ref label single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match (intmap-ref conts label)
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (compute-beta-reductions conts kfun)
(define (visit-fun kfun body beta)
(let ((single (compute-singly-referenced-labels conts body)))
(define (visit-cont label beta)
(match (intmap-ref conts label)
;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only
;; be inlined if it is used only once, and not recursively.
(($ $kargs _ _ ($ $continue k src ($ $values)))
(intset-maybe-add! beta label
(and (intset-ref single k)
(match (intmap-ref conts k)
(($ $kargs) #t)
(_ #f)))))
(_
beta)))
(intset-fold visit-cont body beta)))
(persistent-intset
(intmap-fold visit-fun
(compute-reachable-functions conts kfun)
empty-intset)))
(define (compute-beta-var-substitutions conts label-set)
(define (add-var-substs label var-map)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue k _ ($ $values vals)))
(match (intmap-ref conts k)
(($ $kargs names vars)
(fold2* (lambda (var val var-map)
(intmap-add! var-map var val))
vars vals var-map))))))
(intset-fold add-var-substs label-set empty-intmap))
(define (beta-reduce conts kfun)
(let* ((label-set (compute-beta-reductions conts kfun))
(var-map (compute-beta-var-substitutions conts label-set)))
(define (subst var)
(match (intmap-ref var-map var (lambda (_) #f))
(#f var)
(val (subst val))))
(define (transform-exp label k src exp)
(if (intset-ref label-set label)
(match (intmap-ref conts k)
(($ $kargs _ _ ($ $continue k* src* exp*))
(transform-exp k k* src* exp*)))
(build-term
($continue k src
,(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
,exp)
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
(($ $primcall name args)
($primcall name ,(map subst args)))
(($ $values args)
($values ,(map subst args)))
(($ $branch kt ($ $values (var)))
($branch kt ($values ((subst var)))))
(($ $branch kt ($ $primcall name args))
($branch kt ($primcall name ,(map subst args))))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))))
(transform-conts
(lambda (label cont)
(match cont
(($ $kargs names syms ($ $continue k src exp))
(build-cont
($kargs names syms ,(transform-exp label k src exp))))
(_ cont)))
conts)))
(define (simplify conts)
(eta-reduce (beta-reduce conts 0) 0))

995
module/language/cps/slot-allocation.scm Normal file
View file

@ -0,0 +1,995 @@
;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; A module to assign stack slots to variables in a CPS term.
;;;
;;; Code:
(define-module (language cps slot-allocation)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (allocate-slots
lookup-slot
lookup-maybe-slot
lookup-constant-value
lookup-maybe-constant-value
lookup-nlocals
lookup-call-proc-slot
lookup-parallel-moves
lookup-dead-slot-map))
(define-record-type $allocation
(make-allocation slots constant-values call-allocs shuffles frame-sizes)
allocation?
;; A map of VAR to slot allocation. A slot allocation is an integer,
;; if the variable has been assigned a slot.
;;
(slots allocation-slots)
;; A map of VAR to constant value, for variables with constant values.
;;
(constant-values allocation-constant-values)
;; A map of LABEL to /call allocs/, for expressions that continue to
;; $kreceive continuations: non-tail calls and $prompt expressions.
;;
;; A call alloc contains two pieces of information: the call's /proc
;; slot/ and a /dead slot map/. The proc slot indicates the slot of a
;; procedure in a procedure call, or where the procedure would be in a
;; multiple-value return.
;;
;; The dead slot map indicates, what slots should be ignored by GC
;; when marking the frame. A dead slot map is a bitfield, as an
;; integer.
;;
(call-allocs allocation-call-allocs)
;; A map of LABEL to /parallel moves/. Parallel moves shuffle locals
;; into position for a $call, $callk, or $values, or shuffle returned
;; values back into place in a $kreceive.
;;
;; A set of moves is expressed as an ordered list of (SRC . DST)
;; moves, where SRC and DST are slots. This may involve a temporary
;; variable.
;;
(shuffles allocation-shuffles)
;; The number of locals for a $kclause.
;;
(frame-sizes allocation-frame-sizes))
(define-record-type $call-alloc
(make-call-alloc proc-slot dead-slot-map)
call-alloc?
(proc-slot call-alloc-proc-slot)
(dead-slot-map call-alloc-dead-slot-map))
(define (lookup-maybe-slot var allocation)
(intmap-ref (allocation-slots allocation) var (lambda (_) #f)))
(define (lookup-slot var allocation)
(intmap-ref (allocation-slots allocation) var))
(define *absent* (list 'absent))
(define (lookup-constant-value var allocation)
(let ((value (intmap-ref (allocation-constant-values allocation) var
(lambda (_) *absent*))))
(when (eq? value *absent*)
(error "Variable does not have constant value" var))
value))
(define (lookup-maybe-constant-value var allocation)
(let ((value (intmap-ref (allocation-constant-values allocation) var
(lambda (_) *absent*))))
(if (eq? value *absent*)
(values #f #f)
(values #t value))))
(define (lookup-call-alloc k allocation)
(intmap-ref (allocation-call-allocs allocation) k))
(define (lookup-call-proc-slot k allocation)
(or (call-alloc-proc-slot (lookup-call-alloc k allocation))
(error "Call has no proc slot" k)))
(define (lookup-parallel-moves k allocation)
(intmap-ref (allocation-shuffles allocation) k))
(define (lookup-dead-slot-map k allocation)
(or (call-alloc-dead-slot-map (lookup-call-alloc k allocation))
(error "Call has no dead slot map" k)))
(define (lookup-nlocals k allocation)
(intmap-ref (allocation-frame-sizes allocation) k))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(define (solve-flow-equations succs in out kill gen subtract add meet)
"Find a fixed point for flow equations for SUCCS, where IN and OUT are
the initial conditions as intmaps with one key for every node in SUCCS.
KILL and GEN are intmaps indicating the state that is killed or defined
at every node, and SUBTRACT, ADD, and MEET operates on that state."
(define (visit label in out)
(let* ((in-1 (intmap-ref in label))
(kill-1 (intmap-ref kill label))
(gen-1 (intmap-ref gen label))
(out-1 (intmap-ref out label))
(out-1* (add (subtract in-1 kill-1) gen-1)))
(if (eq? out-1 out-1*)
(values empty-intset in out)
(let ((out (intmap-replace! out label out-1*)))
(call-with-values
(lambda ()
(intset-fold (lambda (succ in changed)
(let* ((in-1 (intmap-ref in succ))
(in-1* (meet in-1 out-1*)))
(if (eq? in-1 in-1*)
(values in changed)
(values (intmap-replace! in succ in-1*)
(intset-add changed succ)))))
(intmap-ref succs label) in empty-intset))
(lambda (in changed)
(values changed in out)))))))
(let run ((worklist (intmap-keys succs)) (in in) (out out))
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist popped)
(if popped
(call-with-values (lambda () (visit popped in out))
(lambda (changed in out)
(run (intset-union worklist changed) in out)))
(values (persistent-intmap in)
(persistent-intmap out)))))))
(define-syntax-rule (persistent-intmap2 exp)
(call-with-values (lambda () exp)
(lambda (a b)
(values (persistent-intmap a) (persistent-intmap b)))))
(define (compute-defs-and-uses cps)
"Return two LABEL->VAR... maps indicating values defined at and used
by a label, respectively."
(define (vars->intset vars)
(fold (lambda (var set) (intset-add set var)) empty-intset vars))
(persistent-intmap2
(intmap-fold
(lambda (label cont defs uses)
(define (get-defs k)
(match (intmap-ref cps k)
(($ $kargs names vars) (vars->intset vars))
(_ empty-intset)))
(define (return d u)
(values (intmap-add! defs label d)
(intmap-add! uses label u)))
(match cont
(($ $kfun src meta self)
(return (intset self) empty-intset))
(($ $kargs _ _ ($ $continue k src exp))
(match exp
((or ($ $const) ($ $closure))
(return (get-defs k) empty-intset))
(($ $call proc args)
(return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $callk _ proc args)
(return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $primcall name args)
(return (get-defs k) (vars->intset args)))
(($ $branch kt ($ $primcall name args))
(return empty-intset (vars->intset args)))
(($ $branch kt ($ $values args))
(return empty-intset (vars->intset args)))
(($ $values args)
(return (get-defs k) (vars->intset args)))
(($ $prompt escape? tag handler)
(return empty-intset (intset tag)))))
(($ $kclause arity body alt)
(return (get-defs body) empty-intset))
(($ $kreceive arity kargs)
(return (get-defs kargs) empty-intset))
(($ $ktail)
(return empty-intset empty-intset))))
cps
empty-intmap
empty-intmap)))
(define (compute-reverse-control-flow-order preds)
"Return a LABEL->ORDER bijection where ORDER is a contiguous set of
integers starting from 0 and incrementing in sort order."
;; This is more involved than forward control flow because not all
;; live labels are reachable from the tail.
(persistent-intmap
(fold2 (lambda (component order n)
(intset-fold (lambda (label order n)
(values (intmap-add! order label n)
(1+ n)))
component order n))
(reverse (compute-sorted-strongly-connected-components preds))
empty-intmap 0)))
(define* (add-prompt-control-flow-edges conts succs #:key complete?)
"For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
body continuation in the prompt."
(define (intset-filter pred set)
(intset-fold (lambda (i set)
(if (pred i) set (intset-remove set i)))
set
set))
(define (intset-any pred set)
(intset-fold (lambda (i res)
(if (or res (pred i)) #t res))
set
#f))
(define (visit-prompt label handler succs)
;; FIXME: It isn't correct to use all continuations reachable from
;; the prompt, because that includes continuations outside the
;; prompt body. This point is moot if the handler's control flow
;; joins with the the body, as is usually but not always the case.
;;
;; One counter-example is when the handler contifies an infinite
;; loop; in that case we compute a too-large prompt body. This
;; error is currently innocuous, but we should fix it at some point.
;;
;; The fix is to end the body at the corresponding "pop" primcall,
;; if any.
(let ((body (intset-subtract (compute-function-body conts label)
(compute-function-body conts handler))))
(define (out-or-back-edge? label)
;; Most uses of visit-prompt-control-flow don't need every body
;; continuation, and would be happy getting called only for
;; continuations that postdominate the rest of the body. Unless
;; you pass #:complete? #t, we only invoke F on continuations
;; that can leave the body, or on back-edges in loops.
;;
;; You would think that looking for the final "pop" primcall
;; would be sufficient, but that is incorrect; it's possible for
;; a loop in the prompt body to be contified, and that loop need
;; not continue to the pop if it never terminates. The pop could
;; even be removed by DCE, in that case.
(intset-any (lambda (succ)
(or (not (intset-ref body succ))
(<= succ label)))
(intmap-ref succs label)))
(intset-fold (lambda (pred succs)
(intmap-replace succs pred handler intset-add))
(if complete? body (intset-filter out-or-back-edge? body))
succs)))
(intmap-fold
(lambda (label cont succs)
(match cont
(($ $kargs _ _
($ $continue _ _ ($ $prompt escape? tag handler)))
(visit-prompt label handler succs))
(_ succs)))
conts
succs))
(define (rename-keys map old->new)
(persistent-intmap
(intmap-fold (lambda (k v out)
(intmap-add! out (intmap-ref old->new k) v))
map
empty-intmap)))
(define (rename-intset set old->new)
(intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old)))
set empty-intset))
(define (rename-graph graph old->new)
(persistent-intmap
(intmap-fold (lambda (pred succs out)
(intmap-add! out
(intmap-ref old->new pred)
(rename-intset succs old->new)))
graph
empty-intmap)))
(define (compute-live-variables cps defs uses)
"Compute and return two values mapping LABEL->VAR..., where VAR... are
the definitions that are live before and after LABEL, as intsets."
(let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps)))
(preds (invert-graph succs))
(old->new (compute-reverse-control-flow-order preds)))
(call-with-values
(lambda ()
(let ((init (rename-keys
(intmap-map (lambda (k v) empty-intset) preds)
old->new)))
(solve-flow-equations (rename-graph preds old->new)
init init
(rename-keys defs old->new)
(rename-keys uses old->new)
intset-subtract intset-union intset-union)))
(lambda (in out)
;; As a reverse control-flow problem, the values flowing into a
;; node are actually the live values after the node executes.
;; Funny, innit? So we return them in the reverse order.
(let ((new->old (invert-bijection old->new)))
(values (rename-keys out new->old)
(rename-keys in new->old)))))))
(define (compute-needs-slot cps defs uses)
(define (get-defs k) (intmap-ref defs k))
(define (get-uses label) (intmap-ref uses label))
(intmap-fold
(lambda (label cont needs-slot)
(intset-union
needs-slot
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(let ((defs (get-defs label)))
(define (defs+* uses)
(intset-union defs uses))
(define (defs+ use)
(intset-add defs use))
(match exp
(($ $const)
empty-intset)
(($ $primcall 'free-ref (closure slot))
(defs+ closure))
(($ $primcall 'free-set! (closure slot value))
(defs+* (intset closure value)))
(($ $primcall 'cache-current-module! (mod . _))
(defs+ mod))
(($ $primcall 'cached-toplevel-box _)
defs)
(($ $primcall 'cached-module-box _)
defs)
(($ $primcall 'resolve (name bound?))
(defs+ name))
(($ $primcall 'make-vector/immediate (len init))
(defs+ init))
(($ $primcall 'vector-ref/immediate (v i))
(defs+ v))
(($ $primcall 'vector-set!/immediate (v i x))
(defs+* (intset v x)))
(($ $primcall 'allocate-struct/immediate (vtable nfields))
(defs+ vtable))
(($ $primcall 'struct-ref/immediate (s n))
(defs+ s))
(($ $primcall 'struct-set!/immediate (s n x))
(defs+* (intset s x)))
(($ $primcall 'builtin-ref (idx))
defs)
(_
(defs+* (get-uses label))))))
(($ $kreceive arity k)
;; Only allocate results of function calls to slots if they are
;; used.
empty-intset)
(($ $kclause arity body alternate)
(get-defs label))
(($ $kfun src meta self)
(intset self))
(($ $ktail)
empty-intset))))
cps
empty-intset))
(define (compute-lazy-vars cps live-in live-out defs needs-slot)
"Compute and return a set of vars whose allocation can be delayed
until their use is seen. These are \"lazy\" vars. A var is lazy if its
uses are calls, it is always dead after the calls, and if the uses flow
to the definition. A flow continues across a node iff the node kills no
values that need slots, and defines only lazy vars. Calls also kill
flows; there's no sense in trying to juggle a pending frame while there
is an active call."
(define (list->intset list)
(persistent-intset
(fold (lambda (i set) (intset-add! set i)) empty-intset list)))
(let* ((succs (compute-successors cps))
(gens (intmap-map
(lambda (label cont)
(match cont
(($ $kargs _ _ ($ $continue _ _ ($ $call proc args)))
(intset-subtract (intset-add (list->intset args) proc)
(intmap-ref live-out label)))
(($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args)))
(intset-subtract (intset-add (list->intset args) proc)
(intmap-ref live-out label)))
(_ #f)))
cps))
(kills (intmap-map
(lambda (label in)
(let* ((out (intmap-ref live-out label))
(killed (intset-subtract in out))
(killed-slots (intset-intersect killed needs-slot)))
(and (eq? killed-slots empty-intset)
;; Kill output variables that need slots.
(intset-intersect (intmap-ref defs label)
needs-slot))))
live-in))
(preds (invert-graph succs))
(old->new (compute-reverse-control-flow-order preds)))
(define (subtract lazy kill)
(cond
((eq? lazy empty-intset)
lazy)
((not kill)
empty-intset)
((and lazy (eq? empty-intset (intset-subtract kill lazy)))
(intset-subtract lazy kill))
(else
empty-intset)))
(define (add live gen) (or gen live))
(define (meet in out)
;; Initial in is #f.
(if in (intset-intersect in out) out))
(call-with-values
(lambda ()
(let ((succs (rename-graph preds old->new))
(in (rename-keys (intmap-map (lambda (k v) #f) preds) old->new))
(out (rename-keys (intmap-map (lambda (k v) #f) preds) old->new))
;(out (rename-keys gens old->new))
(kills (rename-keys kills old->new))
(gens (rename-keys gens old->new)))
(solve-flow-equations succs in out kills gens subtract add meet)))
(lambda (in out)
;; A variable is lazy if its uses reach its definition.
(intmap-fold (lambda (label out lazy)
(match (intmap-ref cps label)
(($ $kargs names vars)
(let ((defs (list->intset vars)))
(intset-union lazy (intset-intersect out defs))))
(_ lazy)))
(rename-keys out (invert-bijection old->new))
empty-intset)))))
(define (find-first-zero n)
;; Naive implementation.
(let lp ((slot 0))
(if (logbit? slot n)
(lp (1+ slot))
slot)))
(define (find-first-trailing-zero n)
(let lp ((slot (let lp ((count 2))
(if (< n (ash 1 (1- count)))
count
;; Grow upper bound slower than factor 2 to avoid
;; needless bignum allocation on 32-bit systems
;; when there are more than 16 locals.
(lp (+ count (ash count -1)))))))
(if (or (zero? slot) (logbit? (1- slot) n))
slot
(lp (1- slot)))))
(define (integers from count)
(if (zero? count)
'()
(cons from (integers (1+ from) (1- count)))))
(define (solve-parallel-move src dst tmp)
"Solve the parallel move problem between src and dst slot lists, which
are comparable with eqv?. A tmp slot may be used."
;; This algorithm is taken from: "Tilting at windmills with Coq:
;; formal verification of a compilation algorithm for parallel moves"
;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
(define (split-move moves reg)
(let loop ((revhead '()) (tail moves))
(match tail
(((and s+d (s . d)) . rest)
(if (eqv? s reg)
(cons d (append-reverse revhead rest))
(loop (cons s+d revhead) rest)))
(_ #f))))
(define (replace-last-source reg moves)
(match moves
((moves ... (s . d))
(append moves (list (cons reg d))))))
(let loop ((to-move (map cons src dst))
(being-moved '())
(moved '())
(last-source #f))
;; 'last-source' should always be equivalent to:
;; (and (pair? being-moved) (car (last being-moved)))
(match being-moved
(() (match to-move
(() (reverse moved))
(((and s+d (s . d)) . t1)
(if (or (eqv? s d) ; idempotent
(not s)) ; src is a constant and can be loaded directly
(loop t1 '() moved #f)
(loop t1 (list s+d) moved s)))))
(((and s+d (s . d)) . b)
(match (split-move to-move d)
((r . t1) (loop t1 (acons d r being-moved) moved last-source))
(#f (match b
(() (loop to-move '() (cons s+d moved) #f))
(_ (if (eqv? d last-source)
(loop to-move
(replace-last-source tmp b)
(cons s+d (acons d tmp moved))
tmp)
(loop to-move b (cons s+d moved) last-source))))))))))
(define (compute-shuffles cps slots call-allocs live-in)
(define (add-live-slot slot live-slots)
(logior live-slots (ash 1 slot)))
(define (get-cont label)
(intmap-ref cps label))
(define (get-slot var)
(intmap-ref slots var (lambda (_) #f)))
(define (get-slots vars)
(let lp ((vars vars))
(match vars
((var . vars) (cons (get-slot var) (lp vars)))
(_ '()))))
(define (get-proc-slot label)
(call-alloc-proc-slot (intmap-ref call-allocs label)))
(define (compute-live-slots label)
(intset-fold (lambda (var live)
(match (get-slot var)
(#f live)
(slot (add-live-slot slot live))))
(intmap-ref live-in label)
0))
;; Although some parallel moves may proceed without a temporary slot,
;; in general one is needed. That temporary slot must not be part of
;; the source or destination sets, and that slot should not correspond
;; to a live variable. Usually the source and destination sets are a
;; subset of the union of the live sets before and after the move.
;; However for stack slots that don't have names -- those slots that
;; correspond to function arguments or to function return values -- it
;; could be that they are out of the computed live set. In that case
;; they need to be adjoined to the live set, used when choosing a
;; temporary slot.
;;
;; Note that although we reserve slots 253-255 for shuffling operands
;; that address less than the full 24-bit range of locals, that
;; reservation doesn't apply here, because this temporary itself is
;; used while doing parallel assignment via "mov", and "mov" does not
;; need shuffling.
(define (compute-tmp-slot live stack-slots)
(find-first-zero (fold add-live-slot live stack-slots)))
(define (parallel-move src-slots dst-slots tmp-slot)
(solve-parallel-move src-slots dst-slots tmp-slot))
(define (compute-receive-shuffles label proc-slot)
(match (get-cont label)
(($ $kreceive arity kargs)
(let* ((results (match (get-cont kargs)
(($ $kargs names vars) vars)))
(value-slots (integers (1+ proc-slot) (length results)))
(result-slots (get-slots results))
;; Filter out unused results.
(value-slots (filter-map (lambda (val result) (and result val))
value-slots result-slots))
(result-slots (filter (lambda (x) x) result-slots))
(live (compute-live-slots kargs)))
(parallel-move value-slots
result-slots
(compute-tmp-slot live value-slots))))))
(define (add-call-shuffles label k args shuffles)
(match (get-cont k)
(($ $ktail)
(let* ((live (compute-live-slots label))
(tail-slots (integers 0 (length args)))
(moves (parallel-move (get-slots args)
tail-slots
(compute-tmp-slot live tail-slots))))
(intmap-add! shuffles label moves)))
(($ $kreceive)
(let* ((live (compute-live-slots label))
(proc-slot (get-proc-slot label))
(call-slots (integers proc-slot (length args)))
(arg-moves (parallel-move (get-slots args)
call-slots
(compute-tmp-slot live call-slots))))
(intmap-add! (intmap-add! shuffles label arg-moves)
k (compute-receive-shuffles k proc-slot))))))
(define (add-values-shuffles label k args shuffles)
(match (get-cont k)
(($ $ktail)
(let* ((live (compute-live-slots label))
(src-slots (get-slots args))
(dst-slots (integers 1 (length args)))
(moves (parallel-move src-slots dst-slots
(compute-tmp-slot live dst-slots))))
(intmap-add! shuffles label moves)))
(($ $kargs _ dst-vars)
(let* ((live (logior (compute-live-slots label)
(compute-live-slots k)))
(src-slots (get-slots args))
(dst-slots (get-slots dst-vars))
(moves (parallel-move src-slots dst-slots
(compute-tmp-slot live '()))))
(intmap-add! shuffles label moves)))))
(define (add-prompt-shuffles label k handler shuffles)
(intmap-add! shuffles handler
(compute-receive-shuffles handler (get-proc-slot label))))
(define (compute-shuffles label cont shuffles)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $call proc args)
(add-call-shuffles label k (cons proc args) shuffles))
(($ $callk _ proc args)
(add-call-shuffles label k (cons proc args) shuffles))
(($ $values args)
(add-values-shuffles label k args shuffles))
(($ $prompt escape? tag handler)
(add-prompt-shuffles label k handler shuffles))
(_ shuffles)))
(_ shuffles)))
(persistent-intmap
(intmap-fold compute-shuffles cps empty-intmap)))
(define (compute-frame-sizes cps slots call-allocs shuffles)
;; Minimum frame has one slot: the closure.
(define minimum-frame-size 1)
(define (get-shuffles label)
(intmap-ref shuffles label))
(define (get-proc-slot label)
(match (intmap-ref call-allocs label (lambda (_) #f))
(#f 0) ;; Tail call.
(($ $call-alloc proc-slot) proc-slot)))
(define (max-size var size)
(match (intmap-ref slots var (lambda (_) #f))
(#f size)
(slot (max size (1+ slot)))))
(define (max-size* vars size)
(fold max-size size vars))
(define (shuffle-size moves size)
(match moves
(() size)
(((src . dst) . moves)
(shuffle-size moves (max size (1+ src) (1+ dst))))))
(define (call-size label nargs size)
(shuffle-size (get-shuffles label)
(max (+ (get-proc-slot label) nargs) size)))
(define (measure-cont label cont frame-sizes clause size)
(match cont
(($ $kfun)
(values #f #f #f))
(($ $kclause)
(let ((frame-sizes (if clause
(intmap-add! frame-sizes clause size)
empty-intmap)))
(values frame-sizes label minimum-frame-size)))
(($ $kargs names vars ($ $continue k src exp))
(values frame-sizes clause
(let ((size (max-size* vars size)))
(match exp
(($ $call proc args)
(call-size label (1+ (length args)) size))
(($ $callk _ proc args)
(call-size label (1+ (length args)) size))
(($ $values args)
(shuffle-size (get-shuffles label) size))
(_ size)))))
(($ $kreceive)
(values frame-sizes clause
(shuffle-size (get-shuffles label) size)))
(($ $ktail)
(values (intmap-add! frame-sizes clause size) #f #f))))
(persistent-intmap (intmap-fold measure-cont cps #f #f #f)))
(define (allocate-args cps)
(intmap-fold (lambda (label cont slots)
(match cont
(($ $kfun src meta self)
(intmap-add! slots self 0))
(($ $kclause arity body alt)
(match (intmap-ref cps body)
(($ $kargs names vars)
(let lp ((vars vars) (slots slots) (n 1))
(match vars
(() slots)
((var . vars)
(let ((n (if (<= 253 n 255) 256 n)))
(lp vars
(intmap-add! slots var n)
(1+ n)))))))))
(_ slots)))
cps empty-intmap))
(define-inlinable (add-live-slot slot live-slots)
(logior live-slots (ash 1 slot)))
(define-inlinable (kill-dead-slot slot live-slots)
(logand live-slots (lognot (ash 1 slot))))
(define-inlinable (compute-slot live-slots hint)
;; Slots 253-255 are reserved for shuffling; see comments in
;; assembler.scm.
(if (and hint (not (logbit? hint live-slots))
(or (< hint 253) (> hint 255)))
hint
(let ((slot (find-first-zero live-slots)))
(if (or (< slot 253) (> slot 255))
slot
(+ 256 (find-first-zero (ash live-slots -256)))))))
(define (allocate-lazy-vars cps slots call-allocs live-in lazy)
(define (compute-live-slots slots label)
(intset-fold (lambda (var live)
(match (intmap-ref slots var (lambda (_) #f))
(#f live)
(slot (add-live-slot slot live))))
(intmap-ref live-in label)
0))
(define (allocate var hint slots live)
(match (and hint (intmap-ref slots var (lambda (_) #f)))
(#f (if (intset-ref lazy var)
(let ((slot (compute-slot live hint)))
(values (intmap-add! slots var slot)
(add-live-slot slot live)))
(values slots live)))
(slot (values slots (add-live-slot slot live)))))
(define (allocate* vars hints slots live)
(match (vector vars hints)
(#(() ()) slots)
(#((var . vars) (hint . hints))
(let-values (((slots live) (allocate var hint slots live)))
(allocate* vars hints slots live)))))
(define (get-proc-slot label)
(match (intmap-ref call-allocs label (lambda (_) #f))
(#f 0)
(call (call-alloc-proc-slot call))))
(define (allocate-call label args slots)
(allocate* args (integers (get-proc-slot label) (length args))
slots (compute-live-slots slots label)))
(define (allocate-values label k args slots)
(match (intmap-ref cps k)
(($ $ktail)
(allocate* args (integers 1 (length args))
slots (compute-live-slots slots label)))
(($ $kargs names vars)
(allocate* args
(map (cut intmap-ref slots <> (lambda (_) #f)) vars)
slots (compute-live-slots slots label)))))
(define (allocate-lazy label cont slots)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $call proc args)
(allocate-call label (cons proc args) slots))
(($ $callk _ proc args)
(allocate-call label (cons proc args) slots))
(($ $values args)
(allocate-values label k args slots))
(_ slots)))
(_
slots)))
;; Sweep right to left to visit uses before definitions.
(persistent-intmap
(intmap-fold-right allocate-lazy cps slots)))
(define (allocate-slots cps)
(let*-values (((defs uses) (compute-defs-and-uses cps))
((live-in live-out) (compute-live-variables cps defs uses))
((constants) (compute-constant-values cps))
((needs-slot) (compute-needs-slot cps defs uses))
((lazy) (compute-lazy-vars cps live-in live-out defs
needs-slot)))
(define (empty-live-slots)
#b0)
(define (compute-call-proc-slot live-slots)
(+ 2 (find-first-trailing-zero live-slots)))
(define (compute-prompt-handler-proc-slot live-slots)
(if (zero? live-slots)
0
(1- (find-first-trailing-zero live-slots))))
(define (get-cont label)
(intmap-ref cps label))
(define (get-slot slots var)
(intmap-ref slots var (lambda (_) #f)))
(define (get-slots slots vars)
(let lp ((vars vars))
(match vars
((var . vars) (cons (get-slot slots var) (lp vars)))
(_ '()))))
(define (compute-live-slots* slots label live-vars)
(intset-fold (lambda (var live)
(match (get-slot slots var)
(#f live)
(slot (add-live-slot slot live))))
(intmap-ref live-vars label)
0))
(define (compute-live-in-slots slots label)
(compute-live-slots* slots label live-in))
(define (compute-live-out-slots slots label)
(compute-live-slots* slots label live-out))
(define (allocate var hint slots live)
(cond
((not (intset-ref needs-slot var))
(values slots live))
((get-slot slots var)
=> (lambda (slot)
(values slots (add-live-slot slot live))))
((and (not hint) (intset-ref lazy var))
(values slots live))
(else
(let ((slot (compute-slot live hint)))
(values (intmap-add! slots var slot)
(add-live-slot slot live))))))
(define (allocate* vars hints slots live)
(match (vector vars hints)
(#(() ()) (values slots live))
(#((var . vars) (hint . hints))
(call-with-values (lambda () (allocate var hint slots live))
(lambda (slots live)
(allocate* vars hints slots live))))))
(define (allocate-defs label vars slots)
(let ((live (compute-live-in-slots slots label))
(live-vars (intmap-ref live-in label)))
(let lp ((vars vars) (slots slots) (live live))
(match vars
(() (values slots live))
((var . vars)
(call-with-values (lambda () (allocate var #f slots live))
(lambda (slots live)
(lp vars slots
(let ((slot (get-slot slots var)))
(if (and slot (not (intset-ref live-vars var)))
(kill-dead-slot slot live)
live))))))))))
;; PRE-LIVE are the live slots coming into the term. POST-LIVE
;; is the subset of PRE-LIVE that is still live after the term
;; uses its inputs.
(define (allocate-call label k args slots call-allocs pre-live)
(match (get-cont k)
(($ $ktail)
(let ((tail-slots (integers 0 (length args))))
(values (allocate* args tail-slots slots pre-live)
call-allocs)))
(($ $kreceive arity kargs)
(let*-values
(((post-live) (compute-live-out-slots slots label))
((proc-slot) (compute-call-proc-slot post-live))
((call-slots) (integers proc-slot (length args)))
((slots pre-live) (allocate* args call-slots slots pre-live))
;; Allow the first result to be hinted by its use, but
;; hint the remaining results to stay in place. This
;; strikes a balance between avoiding shuffling,
;; especially for unused extra values, and avoiding frame
;; size growth due to sparse locals.
((slots result-live)
(match (get-cont kargs)
(($ $kargs () ())
(values slots post-live))
(($ $kargs (_ . _) (_ . results))
(let ((result-slots (integers (+ proc-slot 2)
(length results))))
(allocate* results result-slots slots post-live)))))
((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
(lognot post-live)))
((call) (make-call-alloc proc-slot dead-slot-map)))
(values slots
(intmap-add! call-allocs label call))))))
(define (allocate-values label k args slots call-allocs)
(match (get-cont k)
(($ $ktail)
(values slots call-allocs))
(($ $kargs (_) (dst))
;; When there is only one value in play, we allow the dst to be
;; hinted (see compute-lazy-vars). If the src doesn't have a
;; slot, then the actual slot for the dst would end up being
;; decided by the call that args it. Because we don't know the
;; slot, we can't really compute the parallel moves in that
;; case, so just bail and rely on the bytecode emitter to
;; handle the one-value case specially.
(match args
((src)
(let ((post-live (compute-live-out-slots slots label)))
(values (allocate dst (get-slot slots src) slots post-live)
call-allocs)))))
(($ $kargs _ dst-vars)
(let ((src-slots (get-slots slots args))
(post-live (compute-live-out-slots slots label)))
(values (allocate* dst-vars src-slots slots post-live)
call-allocs)))))
(define (allocate-prompt label k handler slots call-allocs)
(match (get-cont handler)
(($ $kreceive arity kargs)
(let*-values
(((handler-live) (compute-live-in-slots slots handler))
((proc-slot) (compute-prompt-handler-proc-slot handler-live))
((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
(lognot handler-live)))
((result-vars) (match (get-cont kargs)
(($ $kargs names vars) vars)))
((value-slots) (integers (1+ proc-slot) (length result-vars)))
((slots result-live) (allocate* result-vars value-slots
slots handler-live)))
(values slots
(intmap-add! call-allocs label
(make-call-alloc proc-slot dead-slot-map)))))))
(define (allocate-cont label cont slots call-allocs)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(let-values (((slots live) (allocate-defs label vars slots)))
(match exp
(($ $call proc args)
(allocate-call label k (cons proc args) slots call-allocs live))
(($ $callk _ proc args)
(allocate-call label k (cons proc args) slots call-allocs live))
(($ $values args)
(allocate-values label k args slots call-allocs))
(($ $prompt escape? tag handler)
(allocate-prompt label k handler slots call-allocs))
(_
(values slots call-allocs)))))
(_
(values slots call-allocs))))
(call-with-values (lambda ()
(let ((slots (allocate-args cps)))
(intmap-fold allocate-cont cps slots empty-intmap)))
(lambda (slots calls)
(let* ((slots (allocate-lazy-vars cps slots calls live-in lazy))
(shuffles (compute-shuffles cps slots calls live-in))
(frame-sizes (compute-frame-sizes cps slots calls shuffles)))
(make-allocation slots constants calls shuffles frame-sizes))))))

37
module/language/cps/spec.scm Normal file
View file

@ -0,0 +1,37 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language cps spec)
#:use-module (system base language)
#:use-module (language cps)
#:use-module (language cps compile-bytecode)
#:export (cps))
(define* (write-cps exp #:optional (port (current-output-port)))
(write (unparse-cps exp) port))
(define-language cps
#:title "CPS Intermediate Language"
#:reader (lambda (port env) (read port))
#:printer write-cps
#:parser parse-cps
#:compilers `((bytecode . ,compile-bytecode))
#:for-humans? #f
)

59
module/language/cps/specialize-primcalls.scm Normal file
View file

@ -0,0 +1,59 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Some bytecode operations can encode an immediate as an operand.
;;; This pass tranforms generic primcalls to these specialized
;;; primcalls, if possible.
;;;
;;; Code:
(define-module (language cps specialize-primcalls)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:export (specialize-primcalls))
(define (specialize-primcalls conts)
(let ((constants (compute-constant-values conts)))
(define (immediate-u8? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val) (<= 0 val 255))))
(define (specialize-primcall name args)
(match (cons name args)
(('make-vector (? immediate-u8? n) init) 'make-vector/immediate)
(('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate)
(('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate)
(('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate)
(('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate)
(('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate)
(_ #f)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
(let ((name* (specialize-primcall name args)))
(if name*
(build-cont
($kargs names vars
($continue k src ($primcall name* args))))
cont)))
(_ cont)))
conts)))

174
module/language/cps/split-rec.scm Normal file
View file

@ -0,0 +1,174 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Split functions bound in $rec expressions into strongly-connected
;;; components. The result will be that each $rec binds a
;;; strongly-connected component of mutually recursive functions.
;;;
;;; Code:
(define-module (language cps split-rec)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (split-rec))
(define (compute-free-vars conts kfun)
"Compute a FUN-LABEL->FREE-VAR... map describing all free variable
references."
(define (add-def var defs) (intset-add! defs var))
(define (add-defs vars defs)
(match vars
(() defs)
((var . vars) (add-defs vars (add-def var defs)))))
(define (add-use var uses) (intset-add! uses var))
(define (add-uses vars uses)
(match vars
(() uses)
((var . vars) (add-uses vars (add-use var uses)))))
(define (visit-nested-funs body)
(intset-fold
(lambda (label out)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _
($ $fun kfun)))
(intmap-union out (visit-fun kfun)))
(($ $kargs _ _ ($ $continue _ _
($ $rec _ _ (($ $fun kfun) ...))))
(fold (lambda (kfun out)
(intmap-union out (visit-fun kfun)))
out kfun))
(_ out)))
body
empty-intmap))
(define (visit-fun kfun)
(let* ((body (compute-function-body conts kfun))
(free (visit-nested-funs body)))
(call-with-values
(lambda ()
(intset-fold
(lambda (label defs uses)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(values
(add-defs vars defs)
(match exp
((or ($ $const) ($ $prim)) uses)
(($ $fun kfun)
(intset-union (persistent-intset uses)
(intmap-ref free kfun)))
(($ $rec names vars (($ $fun kfun) ...))
(fold (lambda (kfun uses)
(intset-union (persistent-intset uses)
(intmap-ref free kfun)))
uses kfun))
(($ $values args)
(add-uses args uses))
(($ $call proc args)
(add-use proc (add-uses args uses)))
(($ $branch kt ($ $values (arg)))
(add-use arg uses))
(($ $branch kt ($ $primcall name args))
(add-uses args uses))
(($ $primcall name args)
(add-uses args uses))
(($ $prompt escape? tag handler)
(add-use tag uses)))))
(($ $kfun src meta self)
(values (add-def self defs) uses))
(_ (values defs uses))))
body empty-intset empty-intset))
(lambda (defs uses)
(intmap-add free kfun (intset-subtract
(persistent-intset uses)
(persistent-intset defs)))))))
(visit-fun kfun))
(define (compute-split fns free-vars)
(define (get-free kfun)
;; It's possible for a fun to have been skipped by
;; compute-free-vars, if the fun isn't reachable. Fall back to
;; empty-intset for the fun's free vars, in that case.
(intmap-ref free-vars kfun (lambda (_) empty-intset)))
(let* ((vars (intmap-keys fns))
(edges (intmap-map
(lambda (var kfun)
(intset-intersect (get-free kfun) vars))
fns)))
(compute-sorted-strongly-connected-components edges)))
(define (intmap-acons k v map)
(intmap-add map k v))
(define (split-rec conts)
(let ((free (compute-free-vars conts 0)))
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs cont-names cont-vars
($ $continue k src ($ $rec names vars (($ $fun kfuns) ...))))
(let ((fns (fold intmap-acons empty-intmap vars kfuns))
(fn-names (fold intmap-acons empty-intmap vars names)))
(match (compute-split fns free)
(()
;; Remove trivial $rec.
(with-cps out
(setk label ($kargs cont-names cont-vars
($continue k src ($values ()))))))
((_)
;; Bound functions already form a strongly-connected
;; component.
out)
(components
;; Multiple components. Split them into separate $rec
;; expressions.
(define (build-body out components)
(match components
(()
(match (intmap-ref out k)
(($ $kargs names vars term)
(with-cps (intmap-remove out k)
term))))
((vars . components)
(match (intset-fold
(lambda (var out)
(let ((name (intmap-ref fn-names var))
(fun (build-exp
($fun (intmap-ref fns var)))))
(cons (list name var fun) out)))
vars '())
(((name var fun) ...)
(with-cps out
(let$ body (build-body components))
(letk kbody ($kargs name var ,body))
(build-term
($continue kbody src ($rec name var fun)))))))))
(with-cps out
(let$ body (build-body components))
(setk label ($kargs cont-names cont-vars ,body)))))))
(_ out)))
conts
conts)))))

425
module/language/cps/type-fold.scm Normal file
View file

@ -0,0 +1,425 @@
;;; Abstract constant folding on CPS
;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
;;; This pass uses the abstract interpretation provided by type analysis
;;; to fold constant values and type predicates. It is most profitably
;;; run after CSE, to take advantage of scalar replacement.
;;;
;;; Code:
(define-module (language cps type-fold)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps renumber)
#:use-module (language cps types)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system base target)
#:export (type-fold))
;; Branch folders.
(define &scalar-types
(logior &exact-integer &flonum &char &unspecified &false &true &nil &null))
(define *branch-folders* (make-hash-table))
(define-syntax-rule (define-branch-folder name f)
(hashq-set! *branch-folders* 'name f))
(define-syntax-rule (define-branch-folder-alias to from)
(hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
(define-branch-folder name (lambda (arg min max) body ...)))
(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
arg1 min1 max1)
body ...)
(define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...)))
(define-syntax-rule (define-unary-type-predicate-folder name &type)
(define-unary-branch-folder (name type min max)
(let ((type* (logand type &type)))
(cond
((zero? type*) (values #t #f))
((eqv? type type*) (values #t #t))
(else (values #f #f))))))
;; All the cases that are in compile-bytecode.
(define-unary-type-predicate-folder pair? &pair)
(define-unary-type-predicate-folder null? &null)
(define-unary-type-predicate-folder nil? &nil)
(define-unary-type-predicate-folder symbol? &symbol)
(define-unary-type-predicate-folder variable? &box)
(define-unary-type-predicate-folder vector? &vector)
(define-unary-type-predicate-folder struct? &struct)
(define-unary-type-predicate-folder string? &string)
(define-unary-type-predicate-folder number? &number)
(define-unary-type-predicate-folder char? &char)
(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
(cond
((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
(values #t #f))
((and (eqv? type0 type1)
(eqv? min0 min1 max0 max1)
(zero? (logand type0 (1- type0)))
(not (zero? (logand type0 &scalar-types))))
(values #t #t))
(else
(values #f #f))))
(define-branch-folder-alias eqv? eq?)
(define-branch-folder-alias equal? eq?)
(define (compare-ranges type0 min0 max0 type1 min1 max1)
(and (zero? (logand (logior type0 type1) (lognot &real)))
(cond ((< max0 min1) '<)
((> min0 max1) '>)
((= min0 max0 min1 max1) '=)
((<= max0 min1) '<=)
((>= min0 max1) '>=)
(else #f))))
(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((<) (values #t #t))
((= >= >) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((< <= =) (values #t #t))
((>) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((=) (values #t #t))
((< >) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((> >= =) (values #t #t))
((<) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((>) (values #t #t))
((= <= <) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
(define (logand-min a b)
(if (< a b 0)
(min a b)
0))
(define (logand-max a b)
(if (< a b 0)
0
(max a b)))
(if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer))
(values #t (logtest min0 min1))
(values #f #f)))
;; Strength reduction.
(define *primcall-reducers* (make-hash-table))
(define-syntax-rule (define-primcall-reducer name f)
(hashq-set! *primcall-reducers* 'name f))
(define-syntax-rule (define-unary-primcall-reducer (name cps k src
arg type min max)
body ...)
(define-primcall-reducer name
(lambda (cps k src arg type min max)
body ...)))
(define-syntax-rule (define-binary-primcall-reducer (name cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
body ...)
(define-primcall-reducer name
(lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1)
body ...)))
(define-binary-primcall-reducer (mul cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
(define (fail) (with-cps cps #f))
(define (negate arg)
(with-cps cps
($ (with-cps-constants ((zero 0))
(build-term
($continue k src ($primcall 'sub (zero arg))))))))
(define (zero)
(with-cps cps
(build-term ($continue k src ($const 0)))))
(define (identity arg)
(with-cps cps
(build-term ($continue k src ($values (arg))))))
(define (double arg)
(with-cps cps
(build-term ($continue k src ($primcall 'add (arg arg))))))
(define (power-of-two constant arg)
(let ((n (let lp ((bits 0) (constant constant))
(if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
(with-cps cps
($ (with-cps-constants ((bits n))
(build-term ($continue k src ($primcall 'ash (arg bits)))))))))
(define (mul/constant constant constant-type arg arg-type)
(cond
((not (or (= constant-type &exact-integer) (= constant-type arg-type)))
(fail))
((eqv? constant -1)
;; (* arg -1) -> (- 0 arg)
(negate arg))
((eqv? constant 0)
;; (* arg 0) -> 0 if arg is not a flonum or complex
(and (= constant-type &exact-integer)
(zero? (logand arg-type
(lognot (logior &flonum &complex))))
(zero)))
((eqv? constant 1)
;; (* arg 1) -> arg
(identity arg))
((eqv? constant 2)
;; (* arg 2) -> (+ arg arg)
(double arg))
((and (= constant-type arg-type &exact-integer)
(positive? constant)
(zero? (logand constant (1- constant))))
;; (* arg power-of-2) -> (ash arg (log2 power-of-2
(power-of-two constant arg))
(else
(fail))))
(cond
((logtest (logior type0 type1) (lognot &number)) (fail))
((= min0 max0) (mul/constant min0 type0 arg1 type1))
((= min1 max1) (mul/constant min1 type1 arg0 type0))
(else (fail))))
(define-binary-primcall-reducer (logbit? cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
(define (convert-to-logtest cps kbool)
(define (compute-mask cps kmask src)
(if (eq? min0 max0)
(with-cps cps
(build-term
($continue kmask src ($const (ash 1 min0)))))
(with-cps cps
($ (with-cps-constants ((one 1))
(build-term
($continue kmask src ($primcall 'ash (one arg0)))))))))
(with-cps cps
(letv mask)
(letk kt ($kargs () ()
($continue kbool src ($const #t))))
(letk kf ($kargs () ()
($continue kbool src ($const #f))))
(letk kmask ($kargs (#f) (mask)
($continue kf src
($branch kt ($primcall 'logtest (mask arg1))))))
($ (compute-mask kmask src))))
;; Hairiness because we are converting from a primcall with unknown
;; arity to a branching primcall.
(let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
(if (and (= type0 &exact-integer)
(<= 0 min0 positive-fixnum-bits)
(<= 0 max0 positive-fixnum-bits))
(match (intmap-ref cps k)
(($ $kreceive arity kargs)
(match arity
(($ $arity (_) () (not #f) () #f)
(with-cps cps
(letv bool)
(let$ body (with-cps-constants ((nil '()))
(build-term
($continue kargs src ($values (bool nil))))))
(letk kbool ($kargs (#f) (bool) ,body))
($ (convert-to-logtest kbool))))
(_
(with-cps cps
(letv bool)
(letk kbool ($kargs (#f) (bool)
($continue k src ($primcall 'values (bool)))))
($ (convert-to-logtest kbool))))))
(($ $ktail)
(with-cps cps
(letv bool)
(letk kbool ($kargs (#f) (bool)
($continue k src ($primcall 'return (bool)))))
($ (convert-to-logtest kbool)))))
(with-cps cps #f))))
;;
(define (local-type-fold start end cps)
(define (scalar-value type val)
(cond
((eqv? type &exact-integer) val)
((eqv? type &flonum) (exact->inexact val))
((eqv? type &char) (integer->char val))
((eqv? type &unspecified) *unspecified*)
((eqv? type &false) #f)
((eqv? type &true) #t)
((eqv? type &nil) #nil)
((eqv? type &null) '())
(else (error "unhandled type" type val))))
(let ((types (infer-types cps start)))
(define (fold-primcall cps label names vars k src name args def)
(call-with-values (lambda () (lookup-post-type types label def 0))
(lambda (type min max)
(and (not (zero? type))
(zero? (logand type (1- type)))
(zero? (logand type (lognot &scalar-types)))
(eqv? min max)
(let ((val (scalar-value type min)))
;; (pk 'folded src name args val)
(with-cps cps
(letv v*)
(letk k* ($kargs (#f) (v*)
($continue k src ($const val))))
;; Rely on DCE to elide this expression, if
;; possible.
(setk label
($kargs names vars
($continue k* src ($primcall name args))))))))))
(define (reduce-primcall cps label names vars k src name args)
(and=>
(hashq-ref *primcall-reducers* name)
(lambda (reducer)
(match args
((arg0)
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda ()
(reducer cps k src arg0 type0 min0 max0))
(lambda (cps term)
(and term
(with-cps cps
(setk label ($kargs names vars ,term)))))))))
((arg0 arg1)
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1)
(call-with-values (lambda ()
(reducer cps k src arg0 type0 min0 max0
arg1 type1 min1 max1))
(lambda (cps term)
(and term
(with-cps cps
(setk label ($kargs names vars ,term)))))))))))
(_ #f)))))
(define (fold-unary-branch cps label names vars kf kt src name arg)
(and=>
(hashq-ref *branch-folders* name)
(lambda (folder)
(call-with-values (lambda () (lookup-pre-type types label arg))
(lambda (type min max)
(call-with-values (lambda () (folder type min max))
(lambda (f? v)
;; (when f? (pk 'folded-unary-branch label name arg v))
(and f?
(with-cps cps
(setk label
($kargs names vars
($continue (if v kt kf) src
($values ())))))))))))))
(define (fold-binary-branch cps label names vars kf kt src name arg0 arg1)
(and=>
(hashq-ref *branch-folders* name)
(lambda (folder)
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1)
(call-with-values (lambda ()
(folder type0 min0 max0 type1 min1 max1))
(lambda (f? v)
;; (when f? (pk 'folded-binary-branch label name arg0 arg1 v))
(and f?
(with-cps cps
(setk label
($kargs names vars
($continue (if v kt kf) src
($values ())))))))))))))))
(define (visit-expression cps label names vars k src exp)
(match exp
(($ $primcall name args)
;; We might be able to fold primcalls that define a value.
(match (intmap-ref cps k)
(($ $kargs (_) (def))
(or (fold-primcall cps label names vars k src name args def)
(reduce-primcall cps label names vars k src name args)
cps))
(_
(or (reduce-primcall cps label names vars k src name args)
cps))))
(($ $branch kt ($ $primcall name args))
;; We might be able to fold primcalls that branch.
(match args
((x)
(or (fold-unary-branch cps label names vars k kt src name x)
cps))
((x y)
(or (fold-binary-branch cps label names vars k kt src name x y)
cps))))
(_ cps)))
(let lp ((label start) (cps cps))
(if (<= label end)
(lp (1+ label)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(visit-expression cps label names vars k src exp))
(_ cps)))
cps))))
(define (fold-functions-in-renumbered-program f conts seed)
(let* ((conts (persistent-intmap conts))
(end (1+ (intmap-prev conts))))
(let lp ((label 0) (seed seed))
(if (eqv? label end)
seed
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(lp (1+ tail) (f label tail seed))))))))
(define (type-fold conts)
;; Type analysis wants a program whose labels are sorted.
(let ((conts (renumber conts)))
(with-fresh-name-state conts
(persistent-intmap
(fold-functions-in-renumbered-program local-type-fold conts conts)))))

1408
module/language/cps/types.scm Normal file
View file

File diff suppressed because it is too large Load diff

477
module/language/cps/utils.scm Normal file
View file

@ -0,0 +1,477 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Helper facilities for working with CPS.
;;;
;;; Code:
(define-module (language cps utils)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (;; Fresh names.
label-counter var-counter
fresh-label fresh-var
with-fresh-name-state compute-max-label-and-var
let-fresh
;; Various utilities.
fold1 fold2
trivial-intset
intmap-map
intmap-keys
invert-bijection invert-partition
intset->intmap
worklist-fold
fixpoint
;; Flow analysis.
compute-constant-values
compute-function-body
compute-reachable-functions
compute-successors
invert-graph
compute-predecessors
compute-reverse-post-order
compute-strongly-connected-components
compute-sorted-strongly-connected-components
compute-idoms
compute-dom-edges
))
(define label-counter (make-parameter #f))
(define var-counter (make-parameter #f))
(define (fresh-label)
(let ((count (or (label-counter)
(error "fresh-label outside with-fresh-name-state"))))
(label-counter (1+ count))
count))
(define (fresh-var)
(let ((count (or (var-counter)
(error "fresh-var outside with-fresh-name-state"))))
(var-counter (1+ count))
count))
(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
(let* ((label (fresh-label)) ...
(var (fresh-var)) ...)
body ...))
(define-syntax-rule (with-fresh-name-state fun body ...)
(call-with-values (lambda () (compute-max-label-and-var fun))
(lambda (max-label max-var)
(parameterize ((label-counter (1+ max-label))
(var-counter (1+ max-var)))
body ...))))
(define (compute-max-label-and-var conts)
(values (or (intmap-prev conts) -1)
(intmap-fold (lambda (k cont max-var)
(match cont
(($ $kargs names syms body)
(apply max max-var syms))
(($ $kfun src meta self)
(max max-var self))
(_ max-var)))
conts
-1)))
(define-inlinable (fold1 f l s0)
(let lp ((l l) (s0 s0))
(match l
(() s0)
((elt . l) (lp l (f elt s0))))))
(define-inlinable (fold2 f l s0 s1)
(let lp ((l l) (s0 s0) (s1 s1))
(match l
(() (values s0 s1))
((elt . l)
(call-with-values (lambda () (f elt s0 s1))
(lambda (s0 s1)
(lp l s0 s1)))))))
(define (trivial-intset set)
"Returns the sole member of @var{set}, if @var{set} has exactly one
member, or @code{#f} otherwise."
(let ((first (intset-next set)))
(and first
(not (intset-next set (1+ first)))
first)))
(define (intmap-map proc map)
(persistent-intmap
(intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v)))
map
map)))
(define (intmap-keys map)
"Return an intset of the keys in @var{map}."
(persistent-intset
(intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
(define (invert-bijection map)
"Assuming the values of @var{map} are integers and are unique, compute
a map in which each value maps to its key. If the values are not
unique, an error will be signalled."
(intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap))
(define (invert-partition map)
"Assuming the values of @var{map} are disjoint intsets, compute a map
in which each member of each set maps to its key. If the values are not
disjoint, an error will be signalled."
(intmap-fold (lambda (k v* out)
(intset-fold (lambda (v out) (intmap-add out v k)) v* out))
map empty-intmap))
(define (intset->intmap f set)
(persistent-intmap
(intset-fold (lambda (label preds)
(intmap-add! preds label (f label)))
set empty-intmap)))
(define worklist-fold
(case-lambda
((f in out)
(let lp ((in in) (out out))
(if (eq? in empty-intset)
out
(call-with-values (lambda () (f in out)) lp))))
((f in out0 out1)
(let lp ((in in) (out0 out0) (out1 out1))
(if (eq? in empty-intset)
(values out0 out1)
(call-with-values (lambda () (f in out0 out1)) lp))))))
(define fixpoint
(case-lambda
((f x)
(let lp ((x x))
(let ((x* (f x)))
(if (eq? x x*) x* (lp x*)))))
((f x0 x1)
(let lp ((x0 x0) (x1 x1))
(call-with-values (lambda () (f x0 x1))
(lambda (x0* x1*)
(if (and (eq? x0 x0*) (eq? x1 x1*))
(values x0* x1*)
(lp x0* x1*))))))))
(define (compute-defining-expressions conts)
(define (meet-defining-expressions old new)
;; If there are multiple definitions, punt and
;; record #f.
#f)
(persistent-intmap
(intmap-fold (lambda (label cont defs)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(match (intmap-ref conts k)
(($ $kargs (_) (var))
(intmap-add! defs var exp meet-defining-expressions))
(_ defs)))
(_ defs)))
conts
empty-intmap)))
(define (compute-constant-values conts)
(persistent-intmap
(intmap-fold (lambda (var exp out)
(match exp
(($ $const val)
(intmap-add! out var val))
(_ out)))
(compute-defining-expressions conts)
empty-intmap)))
(define (compute-function-body conts kfun)
(persistent-intset
(let visit-cont ((label kfun) (labels empty-intset))
(cond
((intset-ref labels label) labels)
(else
(let ((labels (intset-add! labels label)))
(match (intmap-ref conts label)
(($ $kreceive arity k) (visit-cont k labels))
(($ $kfun src meta self ktail kclause)
(let ((labels (visit-cont ktail labels)))
(if kclause
(visit-cont kclause labels)
labels)))
(($ $ktail) labels)
(($ $kclause arity kbody kalt)
(if kalt
(visit-cont kalt (visit-cont kbody labels))
(visit-cont kbody labels)))
(($ $kargs names syms ($ $continue k src exp))
(visit-cont k (match exp
(($ $branch k)
(visit-cont k labels))
(($ $prompt escape? tag k)
(visit-cont k labels))
(_ labels)))))))))))
(define (compute-reachable-functions conts kfun)
"Compute a mapping LABEL->LABEL..., where each key is a reachable
$kfun and each associated value is the body of the function, as an
intset."
(define (intset-cons i set) (intset-add set i))
(define (visit-fun kfun body to-visit)
(intset-fold
(lambda (label to-visit)
(define (return kfun*) (fold intset-cons to-visit kfun*))
(define (return1 kfun) (intset-add to-visit kfun))
(define (return0) to-visit)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
(($ $fun label) (return1 label))
(($ $rec _ _ (($ $fun labels) ...)) (return labels))
(($ $closure label nfree) (return1 label))
(($ $callk label) (return1 label))
(_ (return0))))
(_ (return0))))
body
to-visit))
(let lp ((to-visit (intset kfun)) (visited empty-intmap))
(let ((to-visit (intset-subtract to-visit (intmap-keys visited))))
(if (eq? to-visit empty-intset)
visited
(call-with-values
(lambda ()
(intset-fold
(lambda (kfun to-visit visited)
(let ((body (compute-function-body conts kfun)))
(values (visit-fun kfun body to-visit)
(intmap-add visited kfun body))))
to-visit
empty-intset
visited))
lp)))))
(define* (compute-successors conts #:optional (kfun (intmap-next conts)))
(define (visit label succs)
(let visit ((label kfun) (succs empty-intmap))
(define (propagate0)
(intmap-add! succs label empty-intset))
(define (propagate1 succ)
(visit succ (intmap-add! succs label (intset succ))))
(define (propagate2 succ0 succ1)
(let ((succs (intmap-add! succs label (intset succ0 succ1))))
(visit succ1 (visit succ0 succs))))
(if (intmap-ref succs label (lambda (_) #f))
succs
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $branch kt) (propagate2 k kt))
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
(if clause
(propagate2 clause tail)
(propagate1 tail)))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt)
(propagate1 kbody)))
(($ $ktail) (propagate0))))))
(persistent-intmap (visit kfun empty-intmap)))
(define* (compute-predecessors conts kfun #:key
(labels (compute-function-body conts kfun)))
(define (meet cdr car)
(cons car cdr))
(define (add-preds label preds)
(define (add-pred k preds)
(intmap-add! preds k label meet))
(match (intmap-ref conts label)
(($ $kreceive arity k)
(add-pred k preds))
(($ $kfun src meta self ktail kclause)
(add-pred ktail (if kclause (add-pred kclause preds) preds)))
(($ $ktail)
preds)
(($ $kclause arity kbody kalt)
(add-pred kbody (if kalt (add-pred kalt preds) preds)))
(($ $kargs names syms ($ $continue k src exp))
(add-pred k
(match exp
(($ $branch k) (add-pred k preds))
(($ $prompt _ _ k) (add-pred k preds))
(_ preds))))))
(persistent-intmap
(intset-fold add-preds labels
(intset->intmap (lambda (label) '()) labels))))
(define (compute-reverse-post-order succs start)
"Compute a reverse post-order numbering for a depth-first walk over
nodes reachable from the start node."
(let visit ((label start) (order '()) (visited empty-intset))
(call-with-values
(lambda ()
(intset-fold (lambda (succ order visited)
(if (intset-ref visited succ)
(values order visited)
(visit succ order visited)))
(intmap-ref succs label)
order
(intset-add! visited label)))
(lambda (order visited)
;; After visiting successors, add label to the reverse post-order.
(values (cons label order) visited)))))
(define (invert-graph succs)
"Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an
intset of successors, return a graph SUCC->PRED...."
(intmap-fold (lambda (pred succs preds)
(intset-fold
(lambda (succ preds)
(intmap-add preds succ pred intset-add))
succs
preds))
succs
(intmap-map (lambda (label _) empty-intset) succs)))
(define (compute-strongly-connected-components succs start)
"Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
partitioning the labels into strongly connected components (SCCs)."
(let ((preds (invert-graph succs)))
(define (visit-scc scc sccs-by-label)
(let visit ((label scc) (sccs-by-label sccs-by-label))
(if (intmap-ref sccs-by-label label (lambda (_) #f))
sccs-by-label
(intset-fold visit
(intmap-ref preds label)
(intmap-add sccs-by-label label scc)))))
(intmap-fold
(lambda (label scc sccs)
(let ((labels (intset-add empty-intset label)))
(intmap-add sccs scc labels intset-union)))
(fold visit-scc empty-intmap (compute-reverse-post-order succs start))
empty-intmap)))
(define (compute-sorted-strongly-connected-components edges)
"Given a LABEL->SUCCESSOR... graph, return a list of strongly
connected components in sorted order."
(define nodes
(intmap-keys edges))
;; Add a "start" node that links to all nodes in the graph, and then
;; remove it from the result.
(define start
(if (eq? nodes empty-intset)
0
(1+ (intset-prev nodes))))
(define components
(intmap-remove
(compute-strongly-connected-components (intmap-add edges start nodes)
start)
start))
(define node-components
(intmap-fold (lambda (id nodes out)
(intset-fold (lambda (node out) (intmap-add out node id))
nodes out))
components
empty-intmap))
(define (node-component node)
(intmap-ref node-components node))
(define (component-successors id nodes)
(intset-remove
(intset-fold (lambda (node out)
(intset-fold
(lambda (successor out)
(intset-add out (node-component successor)))
(intmap-ref edges node)
out))
nodes
empty-intset)
id))
(define component-edges
(intmap-map component-successors components))
(define preds
(invert-graph component-edges))
(define roots
(intmap-fold (lambda (id succs out)
(if (eq? empty-intset succs)
(intset-add out id)
out))
component-edges
empty-intset))
;; As above, add a "start" node that links to the roots, and remove it
;; from the result.
(match (compute-reverse-post-order (intmap-add preds start roots) start)
(((? (lambda (id) (eqv? id start))) . ids)
(map (lambda (id) (intmap-ref components id)) ids))))
;; Precondition: For each function in CONTS, the continuation names are
;; topologically sorted.
(define (compute-idoms conts kfun)
;; This is the iterative O(n^2) fixpoint algorithm, originally from
;; Allen and Cocke ("Graph-theoretic constructs for program flow
;; analysis", 1972). See the discussion in Cooper, Harvey, and
;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
(let ((preds-map (compute-predecessors conts kfun)))
(define (compute-idom idoms preds)
(define (idom-ref label)
(intmap-ref idoms label (lambda (_) #f)))
(match preds
(() -1)
((pred) pred) ; Shortcut.
((pred . preds)
(define (common-idom d0 d1)
;; We exploit the fact that a reverse post-order is a
;; topological sort, and so the idom of a node is always
;; numerically less than the node itself.
(let lp ((d0 d0) (d1 d1))
(cond
;; d0 or d1 can be false on the first iteration.
((not d0) d1)
((not d1) d0)
((= d0 d1) d0)
((< d0 d1) (lp d0 (idom-ref d1)))
(else (lp (idom-ref d0) d1)))))
(fold1 common-idom preds pred))))
(define (adjoin-idom label preds idoms)
(let ((idom (compute-idom idoms preds)))
;; Don't use intmap-add! here.
(intmap-add idoms label idom (lambda (old new) new))))
(fixpoint (lambda (idoms)
(intmap-fold adjoin-idom preds-map idoms))
empty-intmap)))
;; Compute a vector containing, for each node, a list of the nodes that
;; it immediately dominates. These are the "D" edges in the DJ tree.
(define (compute-dom-edges idoms)
(define (snoc cdr car) (cons car cdr))
(persistent-intmap
(intmap-fold (lambda (label idom doms)
(let ((doms (intmap-add! doms label '())))
(cond
((< idom 0) doms) ;; No edge to entry.
(else (intmap-add! doms idom label snoc)))))
idoms
empty-intmap)))

306
module/language/cps/verify.scm Normal file
View file

@ -0,0 +1,306 @@
;;; Diagnostic checker for CPS
;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
;;; A routine to detect invalid CPS.
;;;
;;; Code:
(define-module (language cps verify)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (language cps primitives)
#:use-module (srfi srfi-11)
#:export (verify))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(define-syntax-rule (make-worklist-folder* seed ...)
(lambda (f worklist seed ...)
(let lp ((worklist worklist) (seed seed) ...)
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist i)
(if i
(call-with-values (lambda () (f i seed ...))
(lambda (i* seed ...)
(let add ((i* i*) (worklist worklist))
(match i*
(() (lp worklist seed ...))
((i . i*) (add i* (intset-add worklist i)))))))
(values seed ...)))))))
(define worklist-fold*
(case-lambda
((f worklist seed)
((make-worklist-folder* seed) f worklist seed))))
(define (check-distinct-vars conts)
(define (adjoin-def var seen)
(when (intset-ref seen var)
(error "duplicate var name" seen var))
(intset-add seen var))
(intmap-fold
(lambda (label cont seen)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(fold1 adjoin-def vars seen))
(($ $kfun src meta self tail clause)
(adjoin-def self seen))
(_ seen))
)
conts
empty-intset))
(define (compute-available-definitions conts kfun)
"Compute and return a map of LABEL->VAR..., where VAR... are the
definitions that are available at LABEL."
(define (adjoin-def var defs)
(when (intset-ref defs var)
(error "var already present in defs" defs var))
(intset-add defs var))
(define (propagate defs succ out)
(let* ((in (intmap-ref defs succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(if (eq? in in*)
(values '() defs)
(values (list succ)
(intmap-add defs succ in* (lambda (old new) new))))))
(define (visit-cont label defs)
(let ((in (intmap-ref defs label)))
(define (propagate0 out)
(values '() defs))
(define (propagate1 succ out)
(propagate defs succ out))
(define (propagate2 succ0 succ1 out)
(let*-values (((changed0 defs) (propagate defs succ0 out))
((changed1 defs) (propagate defs succ1 out)))
(values (append changed0 changed1) defs)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(let ((out (fold1 adjoin-def vars in)))
(match exp
(($ $branch kt) (propagate2 k kt out))
(($ $prompt escape? tag handler) (propagate2 k handler out))
(_ (propagate1 k out)))))
(($ $kreceive arity k)
(propagate1 k in))
(($ $kfun src meta self tail clause)
(let ((out (adjoin-def self in)))
(if clause
(propagate1 clause out)
(propagate0 out))))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt in)
(propagate1 kbody in)))
(($ $ktail) (propagate0 in)))))
(worklist-fold* visit-cont
(intset kfun)
(intmap-add empty-intmap kfun empty-intset)))
(define (intmap-for-each f map)
(intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
(define (check-valid-var-uses conts kfun)
(define (adjoin-def var defs) (intset-add defs var))
(let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset))
(define (visit-exp exp bound first-order)
(define (check-use var)
(unless (intset-ref bound var)
(error "unbound var" var)))
(define (visit-first-order kfun)
(if (intset-ref first-order kfun)
first-order
(visit-fun kfun empty-intset (intset-add first-order kfun))))
(match exp
((or ($ $const) ($ $prim)) first-order)
;; todo: $closure
(($ $fun kfun)
(visit-fun kfun bound first-order))
(($ $closure kfun)
(visit-first-order kfun))
(($ $rec names vars (($ $fun kfuns) ...))
(let ((bound (fold1 adjoin-def vars bound)))
(fold1 (lambda (kfun first-order)
(visit-fun kfun bound first-order))
kfuns first-order)))
(($ $values args)
(for-each check-use args)
first-order)
(($ $call proc args)
(check-use proc)
(for-each check-use args)
first-order)
(($ $callk kfun proc args)
(check-use proc)
(for-each check-use args)
(visit-first-order kfun))
(($ $branch kt ($ $values (arg)))
(check-use arg)
first-order)
(($ $branch kt ($ $primcall name args))
(for-each check-use args)
first-order)
(($ $primcall name args)
(for-each check-use args)
first-order)
(($ $prompt escape? tag handler)
(check-use tag)
first-order)))
(intmap-fold
(lambda (label bound first-order)
(let ((bound (intset-union free bound)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp exp (fold1 adjoin-def vars bound) first-order))
(_ first-order))))
(compute-available-definitions conts kfun)
first-order)))
(define (check-label-partition conts kfun)
;; A continuation can only belong to one function.
(intmap-fold
(lambda (kfun body seen)
(intset-fold
(lambda (label seen)
(intmap-add seen label kfun
(lambda (old new)
(error "label used by two functions" label old new))))
body
seen))
(compute-reachable-functions conts kfun)
empty-intmap))
(define (compute-reachable-labels conts kfun)
(intmap-fold (lambda (kfun body seen) (intset-union seen body))
(compute-reachable-functions conts kfun)
empty-intset))
(define (check-arities conts kfun)
(define (check-arity exp cont)
(define (assert-unary)
(match cont
(($ $kargs (_) (_)) #t)
(_ (error "expected unary continuation" cont))))
(define (assert-nullary)
(match cont
(($ $kargs () ()) #t)
(_ (error "expected unary continuation" cont))))
(define (assert-n-ary n)
(match cont
(($ $kargs names vars)
(unless (= (length vars) n)
(error "expected n-ary continuation" n cont)))
(_ (error "expected $kargs continuation" cont))))
(define (assert-kreceive-or-ktail)
(match cont
((or ($ $kreceive) ($ $ktail)) #t)
(_ (error "expected $kreceive or $ktail continuation" cont))))
(match exp
((or ($ $const) ($ $prim) ($ $closure) ($ $fun))
(assert-unary))
(($ $rec names vars funs)
(unless (= (length names) (length vars) (length funs))
(error "invalid $rec" exp))
(assert-n-ary (length names))
(match cont
(($ $kargs names vars*)
(unless (equal? vars* vars)
(error "bound variable mismatch" vars vars*)))))
(($ $values args)
(match cont
(($ $ktail) #t)
(_ (assert-n-ary (length args)))))
(($ $call proc args)
(assert-kreceive-or-ktail))
(($ $callk k proc args)
(assert-kreceive-or-ktail))
(($ $branch kt exp)
(assert-nullary)
(match (intmap-ref conts kt)
(($ $kargs () ()) #t)
(cont (error "bad kt" cont))))
(($ $primcall name args)
(match cont
(($ $kargs names)
(match (prim-arity name)
((out . in)
(unless (= in (length args))
(error "bad arity to primcall" name args in))
(unless (= out (length names))
(error "bad return arity from primcall" name names out)))))
(($ $kreceive)
(when (false-if-exception (prim-arity name))
(error "primitive should continue to $kargs, not $kreceive" name)))
(($ $ktail)
(unless (eq? name 'return)
(when (false-if-exception (prim-arity name))
(error "primitive should continue to $kargs, not $ktail" name))))))
(($ $prompt escape? tag handler)
(assert-nullary)
(match (intmap-ref conts handler)
(($ $kreceive) #t)
(cont (error "bad handler" cont))))))
(let ((reachable (compute-reachable-labels conts kfun)))
(intmap-for-each
(lambda (label cont)
(when (intset-ref reachable label)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(unless (= (length names) (length vars))
(error "broken $kargs" label names vars))
(check-arity exp (intmap-ref conts k)))
(_ #t))))
conts)))
(define (check-functions-bound-once conts kfun)
(let ((reachable (compute-reachable-labels conts kfun)))
(define (add-fun fun functions)
(when (intset-ref functions fun)
(error "function already bound" fun))
(intset-add functions fun))
(intmap-fold
(lambda (label cont functions)
(if (intset-ref reachable label)
(match cont
(($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
(add-fun kfun functions))
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...))))
(fold1 add-fun kfuns functions))
(_ functions))
functions))
conts
empty-intset)))
(define (verify conts)
(check-distinct-vars conts)
(check-label-partition conts 0)
(check-valid-var-uses conts 0)
(check-arities conts 0)
(check-functions-bound-once conts 0)
conts)

145
module/language/cps/with-cps.scm Normal file
View file

@ -0,0 +1,145 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Guile's CPS language is a label->cont mapping, which seems simple
;;; enough. However it's often cumbersome to thread around the output
;;; CPS program when doing non-trivial transformations, or when building
;;; a CPS program from scratch. For example, when visiting an
;;; expression during CPS conversion, we usually already know the label
;;; and the $kargs wrapper for the cont, and just need to know the body
;;; of that cont. However when building the body of that possibly
;;; nested Tree-IL expression we will also need to add conts to the
;;; result, so really it's a process that takes an incoming program,
;;; adds conts to that program, and returns the result program and the
;;; result term.
;;;
;;; It's a bit treacherous to do in a functional style as once you start
;;; adding to a program, you shouldn't add to previous versions of that
;;; program. Getting that right in the context of this program seed
;;; that is threaded through the conversion requires the use of a
;;; pattern, with-cps.
;;;
;;; with-cps goes like this:
;;;
;;; (with-cps cps clause ... tail-clause)
;;;
;;; Valid clause kinds are:
;;;
;;; (letk LABEL CONT)
;;; (setk LABEL CONT)
;;; (letv VAR ...)
;;; (let$ X (PROC ARG ...))
;;;
;;; letk and letv create fresh CPS labels and variable names,
;;; respectively. Labels and vars bound by letk and letv are in scope
;;; from their point of definition onward. letv just creates fresh
;;; variable names for use in other parts of with-cps, while letk binds
;;; fresh labels to values and adds them to the resulting program. The
;;; right-hand-side of letk, CONT, is passed to build-cont, so it should
;;; be a valid production of that language. setk is like letk but it
;;; doesn't create a fresh label name.
;;;
;;; let$ delegates processing to a sub-computation. The form (PROC ARG
;;; ...) is syntactically altered to be (PROC CPS ARG ...), where CPS is
;;; the value of the program being built, at that point in the
;;; left-to-right with-cps execution. That form is is expected to
;;; evaluate to two values: the new CPS term, and the value to bind to
;;; X. X is in scope for the following with-cps clauses. The name was
;;; chosen because the $ is reminiscent of the $ in CPS data types.
;;;
;;; The result of the with-cps form is determined by the tail clause,
;;; which may be of these kinds:
;;;
;;; ($ (PROC ARG ...))
;;; (setk LABEL CONT)
;;; EXP
;;;
;;; $ is like let$, but in tail position. If the tail clause is setk,
;;; then only one value is returned, the resulting CPS program.
;;; Otherwise EXP is any kind of expression, which should not add to the
;;; resulting program. Ending the with-cps with EXP is equivalant to
;;; returning (values CPS EXP).
;;;
;;; It's a bit of a monad, innit? Don't tell anyone though!
;;;
;;; Sometimes you need to just bind some constants to CPS values.
;;; with-cps-constants is there for you. For example:
;;;
;;; (with-cps-constants cps ((foo 34))
;;; (build-term ($values (foo))))
;;;
;;; The body of with-cps-constants is a with-cps clause, or a sequence
;;; of such clauses. But usually you will want with-cps-constants
;;; inside a with-cps, so it usually looks like this:
;;;
;;; (with-cps cps
;;; ...
;;; ($ (with-cps-constants ((foo 34))
;;; (build-term ($values (foo))))))
;;;
;;; which is to say that the $ or the let$ adds the CPS argument for us.
;;;
;;; Code:
(define-module (language cps with-cps)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:export (with-cps with-cps-constants))
(define-syntax with-cps
(syntax-rules (letk setk letv let$ $)
((_ (exp ...) clause ...)
(let ((cps (exp ...)))
(with-cps cps clause ...)))
((_ cps (letk label cont) clause ...)
(let-fresh (label) ()
(with-cps (intmap-add! cps label (build-cont cont))
clause ...)))
((_ cps (setk label cont))
(intmap-add! cps label (build-cont cont)
(lambda (old new) new)))
((_ cps (setk label cont) clause ...)
(with-cps (with-cps cps (setk label cont))
clause ...))
((_ cps (letv v ...) clause ...)
(let-fresh () (v ...)
(with-cps cps clause ...)))
((_ cps (let$ var (proc arg ...)) clause ...)
(call-with-values (lambda () (proc cps arg ...))
(lambda (cps var)
(with-cps cps clause ...))))
((_ cps ($ (proc arg ...)))
(proc cps arg ...))
((_ cps exp)
(values cps exp))))
(define-syntax with-cps-constants
(syntax-rules ()
((_ cps () clause ...)
(with-cps cps clause ...))
((_ cps ((var val) (var* val*) ...) clause ...)
(let ((x val))
(with-cps cps
(letv var)
(let$ body (with-cps-constants ((var* val*) ...)
clause ...))
(letk label ($kargs ('var) (var) ,body))
(build-term ($continue label #f ($const x))))))))