diff options
author | Andy Wingo <wingo@pobox.com> | 2015-07-22 18:27:37 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-07-22 18:27:37 +0200 |
commit | 4aabc205cc488a5440a637a7ec4d842ea8647be6 (patch) | |
tree | 7b40d8505e694a6f397d2aa4e150f0e4f9047e5e | |
parent | aa7f0e25ac8ea8340745f6aa337a9f0c64f00881 (diff) | |
download | guile-4aabc205cc488a5440a637a7ec4d842ea8647be6.tar.gz |
Add missing files
Last commit meant to rename files, not delete them. Whoops!
25 files changed, 8619 insertions, 0 deletions
diff --git a/module/language/cps.scm b/module/language/cps.scm new file mode 100644 index 000000000..b66bc38c0 --- /dev/null +++ b/module/language/cps.scm @@ -0,0 +1,358 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This is the continuation-passing style (CPS) intermediate language +;;; (IL) for Guile. +;;; +;;; In CPS, a term is a labelled expression that calls a continuation. +;;; A function is a collection of terms. No term belongs to more than +;;; one function. The function is identified by the label of its entry +;;; term, and its body is composed of those terms that are reachable +;;; from the entry term. A program is a collection of functions, +;;; identified by the entry label of the entry function. +;;; +;;; Terms are themselves wrapped in continuations, which specify how +;;; predecessors may continue to them. For example, a $kargs +;;; continuation specifies that the term may be called with a specific +;;; number of values, and that those values will then be bound to +;;; lexical variables. $kreceive specifies that some number of values +;;; will be passed on the stack, as from a multiple-value return. Those +;;; values will be passed to a $kargs, if the number of values is +;;; compatible with the $kreceive's arity. $kfun is an entry point to a +;;; function, and receives arguments according to a well-known calling +;;; convention (currently, on the stack) and the stack before +;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and +;;; only appears within a $kfun; it checks the incoming values for the +;;; correct arity and dispatches to a $kargs, or to the next clause. +;;; Finally, $ktail is the tail continuation for a function, and +;;; contains no term. +;;; +;;; Each continuation has a label that is unique in the program. As an +;;; implementation detail, the labels are integers, which allows us to +;;; easily sort them topologically. A program is a map from integers to +;;; continuations, where continuation 0 in the map is the entry point +;;; for the program, and is a $kfun of no arguments. +;;; +;;; $continue nodes call continuations. The expression contained in the +;;; $continue node determines the value or values that are passed to the +;;; target continuation: $const to pass a constant value, $values to +;;; pass multiple named values, etc. $continue nodes also record the +;;; source location corresponding to the expression. +;;; +;;; As mentioned above, a $kargs continuation can bind variables, if it +;;; receives incoming values. $kfun also binds a value, corresponding +;;; to the closure being called. A traditional CPS implementation will +;;; nest terms in each other, binding them in "let" forms, ensuring that +;;; continuations are declared and bound within the scope of the values +;;; that they may use. In this way, the scope tree is a proof that +;;; variables are defined before they are used. However, this proof is +;;; conservative; it is possible for a variable to always be defined +;;; before it is used, but not to be in scope: +;;; +;;; (letrec ((k1 (lambda (v1) (k2))) +;;; (k2 (lambda () v1))) +;;; (k1 0)) +;;; +;;; This example is invalid, as v1 is used outside its scope. However +;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside +;;; k1: +;;; +;;; (letrec ((k1 (lambda (v1) +;;; (letrec ((k2 (lambda () v1))) +;;; (k2)))) +;;; (k1 0)) +;;; +;;; Because program transformation usually uses flow-based analysis, +;;; having to update the scope tree to manifestly prove a transformation +;;; that has already proven correct is needless overhead, and in the +;;; worst case can prevent optimizations from occuring. For that +;;; reason, Guile's CPS language does not nest terms. Instead, we use +;;; the invariant that definitions must dominate uses. To check the +;;; validity of a CPS program is thus more involved than checking for a +;;; well-scoped tree; you have to do flow analysis to determine a +;;; dominator tree. However the flexibility that this grants us is +;;; worth the cost of throwing away the embedded proof of the scope +;;; tree. +;;; +;;; This particular formulation of CPS was inspired by Andrew Kennedy's +;;; 2007 paper, "Compiling with Continuations, Continued". All Guile +;;; hackers should read that excellent paper! As in Kennedy's paper, +;;; continuations are second-class, and may be thought of as basic block +;;; labels. All values are bound to variables using continuation calls: +;;; even constants! +;;; +;;; Finally, note that there are two flavors of CPS: higher-order and +;;; first-order. By "higher-order", we mean that variables may be free +;;; across function boundaries. Higher-order CPS contains $fun and $rec +;;; expressions that declare functions in the scope of their term. +;;; Closure conversion results in first-order CPS, where closure +;;; representations have been explicitly chosen, and all variables used +;;; in a function are bound. Higher-order CPS is good for +;;; interprocedural optimizations like contification and beta reduction, +;;; while first-order CPS is better for instruction selection, register +;;; allocation, and code generation. +;;; +;;; See (language tree-il compile-cps) for details on how Tree-IL +;;; converts to CPS. +;;; +;;; Code: + +(define-module (language cps) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:export (;; Helper. + $arity + make-$arity + + ;; Continuations. + $kreceive $kargs $kfun $ktail $kclause + + ;; Terms. + $continue + + ;; Expressions. + $const $prim $fun $rec $closure $branch + $call $callk $primcall $values $prompt + + ;; Building macros. + build-cont build-term build-exp + rewrite-cont rewrite-term rewrite-exp + + ;; External representation. + parse-cps unparse-cps)) + +;; FIXME: Use SRFI-99, when Guile adds it. +(define-syntax define-record-type* + (lambda (x) + (define (id-append ctx . syms) + (datum->syntax ctx (apply symbol-append (map syntax->datum syms)))) + (syntax-case x () + ((_ name field ...) + (and (identifier? #'name) (and-map identifier? #'(field ...))) + (with-syntax ((cons (id-append #'name #'make- #'name)) + (pred (id-append #'name #'name #'?)) + ((getter ...) (map (lambda (f) + (id-append f #'name #'- f)) + #'(field ...)))) + #'(define-record-type name + (cons field ...) + pred + (field getter) + ...)))))) + +(define-syntax-rule (define-cps-type name field ...) + (begin + (define-record-type* name field ...) + (set-record-type-printer! name print-cps))) + +(define (print-cps exp port) + (format port "#<cps ~S>" (unparse-cps exp))) + +;; Helper. +(define-record-type* $arity req opt rest kw allow-other-keys?) + +;; Continuations +(define-cps-type $kreceive arity kbody) +(define-cps-type $kargs names syms term) +(define-cps-type $kfun src meta self ktail kclause) +(define-cps-type $ktail) +(define-cps-type $kclause arity kbody kalternate) + +;; Terms. +(define-cps-type $continue k src exp) + +;; Expressions. +(define-cps-type $const val) +(define-cps-type $prim name) +(define-cps-type $fun body) ; Higher-order. +(define-cps-type $rec names syms funs) ; Higher-order. +(define-cps-type $closure label nfree) ; First-order. +(define-cps-type $branch kt exp) +(define-cps-type $call proc args) +(define-cps-type $callk k proc args) ; First-order. +(define-cps-type $primcall name args) +(define-cps-type $values args) +(define-cps-type $prompt escape? tag handler) + +(define-syntax build-arity + (syntax-rules (unquote) + ((_ (unquote exp)) exp) + ((_ (req opt rest kw allow-other-keys?)) + (make-$arity req opt rest kw allow-other-keys?)))) + +(define-syntax build-cont + (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause) + ((_ (unquote exp)) + exp) + ((_ ($kreceive req rest kargs)) + (make-$kreceive (make-$arity req '() rest '() #f) kargs)) + ((_ ($kargs (name ...) (unquote syms) body)) + (make-$kargs (list name ...) syms (build-term body))) + ((_ ($kargs (name ...) (sym ...) body)) + (make-$kargs (list name ...) (list sym ...) (build-term body))) + ((_ ($kargs names syms body)) + (make-$kargs names syms (build-term body))) + ((_ ($kfun src meta self ktail kclause)) + (make-$kfun src meta self ktail kclause)) + ((_ ($ktail)) + (make-$ktail)) + ((_ ($kclause arity kbody kalternate)) + (make-$kclause (build-arity arity) kbody kalternate)))) + +(define-syntax build-term + (syntax-rules (unquote $rec $continue) + ((_ (unquote exp)) + exp) + ((_ ($continue k src exp)) + (make-$continue k src (build-exp exp))))) + +(define-syntax build-exp + (syntax-rules (unquote + $const $prim $fun $rec $closure $branch + $call $callk $primcall $values $prompt) + ((_ (unquote exp)) exp) + ((_ ($const val)) (make-$const val)) + ((_ ($prim name)) (make-$prim name)) + ((_ ($fun kentry)) (make-$fun kentry)) + ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs)) + ((_ ($closure k nfree)) (make-$closure k nfree)) + ((_ ($call proc (unquote args))) (make-$call proc args)) + ((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) + ((_ ($call proc args)) (make-$call proc args)) + ((_ ($callk k proc (unquote args))) (make-$callk k proc args)) + ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...))) + ((_ ($callk k proc args)) (make-$callk k proc args)) + ((_ ($primcall name (unquote args))) (make-$primcall name args)) + ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...))) + ((_ ($primcall name args)) (make-$primcall name args)) + ((_ ($values (unquote args))) (make-$values args)) + ((_ ($values (arg ...))) (make-$values (list arg ...))) + ((_ ($values args)) (make-$values args)) + ((_ ($branch kt exp)) (make-$branch kt (build-exp exp))) + ((_ ($prompt escape? tag handler)) + (make-$prompt escape? tag handler)))) + +(define-syntax-rule (rewrite-cont x (pat cont) ...) + (match x + (pat (build-cont cont)) ...)) +(define-syntax-rule (rewrite-term x (pat term) ...) + (match x + (pat (build-term term)) ...)) +(define-syntax-rule (rewrite-exp x (pat body) ...) + (match x + (pat (build-exp body)) ...)) + +(define (parse-cps exp) + (define (src exp) + (let ((props (source-properties exp))) + (and (pair? props) props))) + (match exp + ;; Continuations. + (('kreceive req rest k) + (build-cont ($kreceive req rest k))) + (('kargs names syms body) + (build-cont ($kargs names syms ,(parse-cps body)))) + (('kfun src meta self ktail kclause) + (build-cont ($kfun (src exp) meta self ktail kclause))) + (('ktail) + (build-cont ($ktail))) + (('kclause (req opt rest kw allow-other-keys?) kbody) + (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f))) + (('kclause (req opt rest kw allow-other-keys?) kbody kalt) + (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt))) + + ;; Calls. + (('continue k exp) + (build-term ($continue k (src exp) ,(parse-cps exp)))) + (('unspecified) + (build-exp ($const *unspecified*))) + (('const exp) + (build-exp ($const exp))) + (('prim name) + (build-exp ($prim name))) + (('fun kbody) + (build-exp ($fun kbody))) + (('closure k nfree) + (build-exp ($closure k nfree))) + (('rec (name sym fun) ...) + (build-exp ($rec name sym (map parse-cps fun)))) + (('call proc arg ...) + (build-exp ($call proc arg))) + (('callk k proc arg ...) + (build-exp ($callk k proc arg))) + (('primcall name arg ...) + (build-exp ($primcall name arg))) + (('branch k exp) + (build-exp ($branch k ,(parse-cps exp)))) + (('values arg ...) + (build-exp ($values arg))) + (('prompt escape? tag handler) + (build-exp ($prompt escape? tag handler))) + (_ + (error "unexpected cps" exp)))) + +(define (unparse-cps exp) + (match exp + ;; Continuations. + (($ $kreceive ($ $arity req () rest () #f) k) + `(kreceive ,req ,rest ,k)) + (($ $kargs names syms body) + `(kargs ,names ,syms ,(unparse-cps body))) + (($ $kfun src meta self ktail kclause) + `(kfun ,meta ,self ,ktail ,kclause)) + (($ $ktail) + `(ktail)) + (($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate) + `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody + . ,(if kalternate (list kalternate) '()))) + + ;; Calls. + (($ $continue k src exp) + `(continue ,k ,(unparse-cps exp))) + (($ $const val) + (if (unspecified? val) + '(unspecified) + `(const ,val))) + (($ $prim name) + `(prim ,name)) + (($ $fun kbody) + `(fun ,kbody)) + (($ $closure k nfree) + `(closure ,k ,nfree)) + (($ $rec names syms funs) + `(rec ,@(map (lambda (name sym fun) + (list name sym (unparse-cps fun))) + names syms funs))) + (($ $call proc args) + `(call ,proc ,@args)) + (($ $callk k proc args) + `(callk ,k ,proc ,@args)) + (($ $primcall name args) + `(primcall ,name ,@args)) + (($ $branch k exp) + `(branch ,k ,(unparse-cps exp))) + (($ $values args) + `(values ,@args)) + (($ $prompt escape? tag handler) + `(prompt ,escape? ,tag ,handler)) + (_ + (error "unexpected cps" exp)))) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm new file mode 100644 index 000000000..29577a99c --- /dev/null +++ b/module/language/cps/closure-conversion.scm @@ -0,0 +1,824 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This pass converts a CPS term in such a way that no function has any +;;; free variables. Instead, closures are built explicitly with +;;; make-closure primcalls, and free variables are referenced through +;;; the closure. +;;; +;;; Closure conversion also removes any $rec expressions that +;;; contification did not handle. See (language cps) for a further +;;; discussion of $rec. +;;; +;;; Code: + +(define-module (language cps closure-conversion) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold + filter-map + )) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (convert-closures)) + +(define (compute-function-bodies conts kfun) + "Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in +conts." + (let visit-fun ((kfun kfun) (out empty-intmap)) + (let ((body (compute-function-body conts kfun))) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) + (visit-fun kfun out)) + (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...)))) + (fold visit-fun out kfun)) + (_ out))) + body + (intmap-add out kfun body))))) + +(define (compute-program-body functions) + (intmap-fold (lambda (label body out) (intset-union body out)) + functions + empty-intset)) + +(define (filter-reachable conts functions) + (let ((reachable (compute-program-body functions))) + (intmap-fold + (lambda (label cont out) + (if (intset-ref reachable label) + out + (intmap-remove out label))) + conts conts))) + +(define (compute-non-operator-uses conts) + (persistent-intset + (intmap-fold + (lambda (label cont uses) + (define (add-use var uses) (intset-add! uses var)) + (define (add-uses vars uses) + (match vars + (() uses) + ((var . vars) (add-uses vars (add-use var uses))))) + (match cont + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-uses args uses)) + (($ $branch kt ($ $values (arg))) + (add-use arg uses)) + (($ $branch kt ($ $primcall name args)) + (add-uses args uses)) + (($ $primcall name args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses)))) + (_ uses))) + conts + empty-intset))) + +(define (compute-singly-referenced-labels conts body) + (define (add-ref label single multiple) + (define (ref k single multiple) + (if (intset-ref single k) + (values single (intset-add! multiple k)) + (values (intset-add! single k) multiple))) + (define (ref0) (values single multiple)) + (define (ref1 k) (ref k single multiple)) + (define (ref2 k k*) + (if k* + (let-values (((single multiple) (ref k single multiple))) + (ref k* single multiple)) + (ref1 k))) + (match (intmap-ref conts label) + (($ $kreceive arity k) (ref1 k)) + (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) + (($ $ktail) (ref0)) + (($ $kclause arity kbody kalt) (ref2 kbody kalt)) + (($ $kargs names syms ($ $continue k src exp)) + (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intset-fold add-ref body single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +(define (compute-function-names conts functions) + "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function +whose bound vars we know." + (define (add-named-fun var kfun out) + (let ((self (match (intmap-ref conts kfun) + (($ $kfun src meta self) self)))) + (intmap-add out kfun (intset var self)))) + (intmap-fold + (lambda (label body out) + (let ((single (compute-singly-referenced-labels conts body))) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue k _ ($ $fun kfun))) + (if (intset-ref single k) + (match (intmap-ref conts k) + (($ $kargs (_) (var)) (add-named-fun var kfun out)) + (_ out)) + out)) + (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun) ...)))) + (unless (intset-ref single k) + (error "$rec continuation has multiple predecessors??")) + (fold add-named-fun out vars kfun)) + (_ out))) + body + out))) + functions + empty-intmap)) + +(define (compute-well-known-functions conts bound->label) + "Compute a set of labels indicating the well-known functions in +@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: diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm new file mode 100644 index 000000000..61f1e0781 --- /dev/null +++ b/module/language/cps/compile-bytecode.scm @@ -0,0 +1,433 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Compiling CPS to bytecode. The result is in the bytecode language, +;;; which happens to be an ELF image as a bytecode. +;;; +;;; Code: + +(define-module (language cps compile-bytecode) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (language cps) + #:use-module (language cps primitives) + #:use-module (language cps slot-allocation) + #:use-module (language cps utils) + #:use-module (language cps closure-conversion) + #:use-module (language cps optimize) + #:use-module (language cps reify-primitives) + #:use-module (language cps renumber) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (system vm assembler) + #:export (compile-bytecode)) + +(define (kw-arg-ref args kw default) + (match (memq kw args) + ((_ val . _) val) + (_ default))) + +(define (intmap-for-each f map) + (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) + +(define (intmap-select map set) + (persistent-intmap + (intset-fold + (lambda (k out) + (intmap-add! out k (intmap-ref map k))) + set + empty-intmap))) + +(define (compile-function cps asm) + (let ((allocation (allocate-slots cps)) + (frame-size #f)) + (define (maybe-slot sym) + (lookup-maybe-slot sym allocation)) + + (define (slot sym) + (lookup-slot sym allocation)) + + (define (constant sym) + (lookup-constant-value sym allocation)) + + (define (maybe-mov dst src) + (unless (= dst src) + (emit-mov asm dst src))) + + (define (compile-tail label exp) + ;; There are only three kinds of expressions in tail position: + ;; tail calls, multiple-value returns, and single-value returns. + (match exp + (($ $call proc args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-tail-call asm (1+ (length args)))) + (($ $callk k proc args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-tail-call-label asm (1+ (length args)) k)) + (($ $values ()) + (emit-reset-frame asm 1) + (emit-return-values asm)) + (($ $values (arg)) + (if (maybe-slot arg) + (emit-return asm (slot arg)) + (begin + (emit-load-constant asm 1 (constant arg)) + (emit-return asm 1)))) + (($ $values args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-reset-frame asm (1+ (length args))) + (emit-return-values asm)) + (($ $primcall 'return (arg)) + (emit-return asm (slot arg))))) + + (define (compile-value label exp dst) + (match exp + (($ $values (arg)) + (maybe-mov dst (slot arg))) + (($ $const exp) + (emit-load-constant asm dst exp)) + (($ $closure k 0) + (emit-load-static-procedure asm dst k)) + (($ $closure k nfree) + (emit-make-closure asm dst k nfree)) + (($ $primcall 'current-module) + (emit-current-module asm dst)) + (($ $primcall 'cached-toplevel-box (scope name bound?)) + (emit-cached-toplevel-box asm dst (constant scope) (constant name) + (constant bound?))) + (($ $primcall 'cached-module-box (mod name public? bound?)) + (emit-cached-module-box asm dst (constant mod) (constant name) + (constant public?) (constant bound?))) + (($ $primcall 'resolve (name bound?)) + (emit-resolve asm dst (constant bound?) (slot name))) + (($ $primcall 'free-ref (closure idx)) + (emit-free-ref asm dst (slot closure) (constant idx))) + (($ $primcall 'vector-ref (vector index)) + (emit-vector-ref asm dst (slot vector) (slot index))) + (($ $primcall 'make-vector (length init)) + (emit-make-vector asm dst (slot length) (slot init))) + (($ $primcall 'make-vector/immediate (length init)) + (emit-make-vector/immediate asm dst (constant length) (slot init))) + (($ $primcall 'vector-ref/immediate (vector index)) + (emit-vector-ref/immediate asm dst (slot vector) (constant index))) + (($ $primcall 'allocate-struct (vtable nfields)) + (emit-allocate-struct asm dst (slot vtable) (slot nfields))) + (($ $primcall 'allocate-struct/immediate (vtable nfields)) + (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields))) + (($ $primcall 'struct-ref (struct n)) + (emit-struct-ref asm dst (slot struct) (slot n))) + (($ $primcall 'struct-ref/immediate (struct n)) + (emit-struct-ref/immediate asm dst (slot struct) (constant n))) + (($ $primcall 'builtin-ref (name)) + (emit-builtin-ref asm dst (constant name))) + (($ $primcall 'bv-u8-ref (bv idx)) + (emit-bv-u8-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s8-ref (bv idx)) + (emit-bv-s8-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u16-ref (bv idx)) + (emit-bv-u16-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s16-ref (bv idx)) + (emit-bv-s16-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u32-ref (bv idx val)) + (emit-bv-u32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s32-ref (bv idx val)) + (emit-bv-s32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u64-ref (bv idx val)) + (emit-bv-u64-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s64-ref (bv idx val)) + (emit-bv-s64-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-f32-ref (bv idx val)) + (emit-bv-f32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-f64-ref (bv idx val)) + (emit-bv-f64-ref asm dst (slot bv) (slot idx))) + (($ $primcall name args) + ;; FIXME: Inline all the cases. + (let ((inst (prim-instruction name))) + (emit-text asm `((,inst ,dst ,@(map slot args)))))))) + + (define (compile-effect label exp k) + (match exp + (($ $values ()) #f) + (($ $prompt escape? tag handler) + (match (intmap-ref cps handler) + (($ $kreceive ($ $arity req () rest () #f) khandler-body) + (let ((receive-args (gensym "handler")) + (nreq (length req)) + (proc-slot (lookup-call-proc-slot label allocation))) + (emit-prompt asm (slot tag) escape? proc-slot receive-args) + (emit-br asm k) + (emit-label asm receive-args) + (unless (and rest (zero? nreq)) + (emit-receive-values asm proc-slot (->bool rest) nreq)) + (when (and rest + (match (intmap-ref cps khandler-body) + (($ $kargs names (_ ... rest)) + (maybe-slot rest)))) + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves handler allocation)) + (emit-reset-frame asm frame-size) + (emit-br asm khandler-body))))) + (($ $primcall 'cache-current-module! (sym scope)) + (emit-cache-current-module! asm (slot sym) (constant scope))) + (($ $primcall 'free-set! (closure idx value)) + (emit-free-set! asm (slot closure) (slot value) (constant idx))) + (($ $primcall 'box-set! (box value)) + (emit-box-set! asm (slot box) (slot value))) + (($ $primcall 'struct-set! (struct index value)) + (emit-struct-set! asm (slot struct) (slot index) (slot value))) + (($ $primcall 'struct-set!/immediate (struct index value)) + (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value))) + (($ $primcall 'vector-set! (vector index value)) + (emit-vector-set! asm (slot vector) (slot index) (slot value))) + (($ $primcall 'vector-set!/immediate (vector index value)) + (emit-vector-set!/immediate asm (slot vector) (constant index) + (slot value))) + (($ $primcall 'set-car! (pair value)) + (emit-set-car! asm (slot pair) (slot value))) + (($ $primcall 'set-cdr! (pair value)) + (emit-set-cdr! asm (slot pair) (slot value))) + (($ $primcall 'define! (sym value)) + (emit-define! asm (slot sym) (slot value))) + (($ $primcall 'push-fluid (fluid val)) + (emit-push-fluid asm (slot fluid) (slot val))) + (($ $primcall 'pop-fluid ()) + (emit-pop-fluid asm)) + (($ $primcall 'wind (winder unwinder)) + (emit-wind asm (slot winder) (slot unwinder))) + (($ $primcall 'bv-u8-set! (bv idx val)) + (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s8-set! (bv idx val)) + (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u16-set! (bv idx val)) + (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s16-set! (bv idx val)) + (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u32-set! (bv idx val)) + (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s32-set! (bv idx val)) + (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u64-set! (bv idx val)) + (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s64-set! (bv idx val)) + (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-f32-set! (bv idx val)) + (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-f64-set! (bv idx val)) + (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'unwind ()) + (emit-unwind asm)))) + + (define (compile-values label exp syms) + (match exp + (($ $values args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation))))) + + (define (compile-test label exp kt kf next-label) + (define (unary op sym) + (cond + ((eq? kt next-label) + (op asm (slot sym) #t kf)) + (else + (op asm (slot sym) #f kt) + (unless (eq? kf next-label) + (emit-br asm kf))))) + (define (binary op a b) + (cond + ((eq? kt next-label) + (op asm (slot a) (slot b) #t kf)) + (else + (op asm (slot a) (slot b) #f kt) + (unless (eq? kf next-label) + (emit-br asm kf))))) + (match exp + (($ $values (sym)) + (call-with-values (lambda () + (lookup-maybe-constant-value sym allocation)) + (lambda (has-const? val) + (if has-const? + (if val + (unless (eq? kt next-label) + (emit-br asm kt)) + (unless (eq? kf next-label) + (emit-br asm kf))) + (unary emit-br-if-true sym))))) + (($ $primcall 'null? (a)) (unary emit-br-if-null a)) + (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) + (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) + (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) + (($ $primcall 'char? (a)) (unary emit-br-if-char a)) + (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) + (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) + (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) + (($ $primcall 'string? (a)) (unary emit-br-if-string a)) + (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) + (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) + (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) + ;; Add more TC7 tests here. Keep in sync with + ;; *branching-primcall-arities* in (language cps primitives) and + ;; the set of macro-instructions in assembly.scm. + (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) + (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) + (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) + (($ $primcall '< (a b)) (binary emit-br-if-< a b)) + (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) + (($ $primcall '= (a b)) (binary emit-br-if-= a b)) + (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) + (($ $primcall '> (a b)) (binary emit-br-if-< b a)) + (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) + + (define (compile-trunc label k exp nreq rest-var) + (define (do-call proc args emit-call) + (let* ((proc-slot (lookup-call-proc-slot label allocation)) + (nargs (1+ (length args))) + (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-call asm proc-slot nargs) + (emit-dead-slot-map asm proc-slot + (lookup-dead-slot-map label allocation)) + (cond + ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var)) + (match (lookup-parallel-moves k allocation) + ((((? (lambda (src) (= src (1+ proc-slot))) src) + . dst)) dst) + (_ #f))) + ;; The usual case: one required live return value, ignoring + ;; any additional values. + => (lambda (dst) + (emit-receive asm dst proc-slot frame-size))) + (else + (unless (and (zero? nreq) rest-var) + (emit-receive-values asm proc-slot (->bool rest-var) nreq)) + (when (and rest-var (maybe-slot rest-var)) + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves k allocation)) + (emit-reset-frame asm frame-size))))) + (match exp + (($ $call proc args) + (do-call proc args + (lambda (asm proc-slot nargs) + (emit-call asm proc-slot nargs)))) + (($ $callk k proc args) + (do-call proc args + (lambda (asm proc-slot nargs) + (emit-call-label asm proc-slot nargs k)))))) + + (define (compile-expression label k exp) + (let* ((fallthrough? (= k (1+ label)))) + (define (maybe-emit-jump) + (unless fallthrough? + (emit-br asm k))) + (match (intmap-ref cps k) + (($ $ktail) + (compile-tail label exp)) + (($ $kargs (name) (sym)) + (let ((dst (maybe-slot sym))) + (when dst + (compile-value label exp dst))) + (maybe-emit-jump)) + (($ $kargs () ()) + (match exp + (($ $branch kt exp) + (compile-test label exp kt k (1+ label))) + (_ + (compile-effect label exp k) + (maybe-emit-jump)))) + (($ $kargs names syms) + (compile-values label exp syms) + (maybe-emit-jump)) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (compile-trunc label k exp (length req) + (and rest + (match (intmap-ref cps kargs) + (($ $kargs names (_ ... rest)) rest)))) + (unless (and fallthrough? (= kargs (1+ k))) + (emit-br asm kargs)))))) + + (define (compile-cont label cont) + (match cont + (($ $kfun src meta self tail clause) + (when src + (emit-source asm src)) + (emit-begin-program asm label meta)) + (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt) + (let ((first? (match (intmap-ref cps (1- label)) + (($ $kfun) #t) + (_ #f))) + (kw-indices (map (match-lambda + ((key name sym) + (cons key (lookup-slot sym allocation)))) + kw))) + (unless first? + (emit-end-arity asm)) + (emit-label asm label) + (set! frame-size (lookup-nlocals label allocation)) + (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? + frame-size alt))) + (($ $kargs names vars ($ $continue k src exp)) + (emit-label asm label) + (for-each (lambda (name var) + (let ((slot (maybe-slot var))) + (when slot + (emit-definition asm name slot)))) + names vars) + (when src + (emit-source asm src)) + (compile-expression label k exp)) + (($ $kreceive arity kargs) + (emit-label asm label)) + (($ $ktail) + (emit-end-arity asm) + (emit-end-program asm)))) + + (intmap-for-each compile-cont cps))) + +(define (emit-bytecode exp env opts) + (let ((asm (make-assembler))) + (intmap-for-each (lambda (kfun body) + (compile-function (intmap-select exp body) asm)) + (compute-reachable-functions exp 0)) + (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) + env + env))) + +(define (lower-cps exp opts) + (set! exp (optimize-higher-order-cps exp opts)) + (set! exp (convert-closures exp)) + (set! exp (optimize-first-order-cps exp opts)) + (set! exp (reify-primitives exp)) + (renumber exp)) + +(define (compile-bytecode exp env opts) + (set! exp (lower-cps exp opts)) + (emit-bytecode exp env opts)) diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm new file mode 100644 index 000000000..f86095198 --- /dev/null +++ b/module/language/cps/constructors.scm @@ -0,0 +1,98 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Constructor inlining turns "list" primcalls into a series of conses, +;;; and does similar transformations for "vector". +;;; +;;; Code: + +(define-module (language cps constructors) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:export (inline-constructors)) + +(define (inline-list out k src args) + (define (build-list out args k) + (match args + (() + (with-cps out + (build-term ($continue k src ($const '()))))) + ((arg . args) + (with-cps out + (letv tail) + (letk ktail ($kargs ('tail) (tail) + ($continue k src + ($primcall 'cons (arg tail))))) + ($ (build-list args ktail)))))) + (with-cps out + (letv val) + (letk kvalues ($kargs ('val) (val) + ($continue k src + ($primcall 'values (val))))) + ($ (build-list args kvalues)))) + +(define (inline-vector out k src args) + (define (initialize out vec args n) + (match args + (() + (with-cps out + (build-term ($continue k src ($primcall 'values (vec)))))) + ((arg . args) + (with-cps out + (let$ next (initialize vec args (1+ n))) + (letk knext ($kargs () () ,next)) + ($ (with-cps-constants ((idx n)) + (build-term ($continue knext src + ($primcall 'vector-set! (vec idx arg)))))))))) + (with-cps out + (letv vec) + (let$ body (initialize vec args 0)) + (letk kalloc ($kargs ('vec) (vec) ,body)) + ($ (with-cps-constants ((len (length args)) + (init #f)) + (build-term ($continue kalloc src + ($primcall 'make-vector (len init)))))))) + +(define (find-constructor-inliner name) + (match name + ('list inline-list) + ('vector inline-vector) + (_ #f))) + +(define (inline-constructors conts) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs names vars ($ $continue k src ($ $primcall name args))) + (let ((inline (find-constructor-inliner name))) + (if inline + (call-with-values (lambda () (inline out k src args)) + (lambda (out term) + (intmap-replace! out label + (build-cont ($kargs names vars ,term))))) + out))) + (_ out))) + conts + conts)))) diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm new file mode 100644 index 000000000..4a398d7e5 --- /dev/null +++ b/module/language/cps/contification.scm @@ -0,0 +1,475 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Contification is a pass that turns $fun instances into $cont +;;; instances if all calls to the $fun return to the same continuation. +;;; This is a more rigorous variant of our old "fixpoint labels +;;; allocation" optimization. +;;; +;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet +;;; and Weeks's "Contification using Dominators". +;;; +;;; Code: + +(define-module (language cps contification) + #:use-module (ice-9 match) + #:use-module (srfi srfi-11) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (language cps) + #:use-module (language cps renumber) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (contify)) + +(define (compute-singly-referenced-labels conts) + "Compute the set of labels in CONTS that have exactly one +predecessor." + (define (add-ref label cont single multiple) + (define (ref k single multiple) + (if (intset-ref single k) + (values single (intset-add! multiple k)) + (values (intset-add! single k) multiple))) + (define (ref0) (values single multiple)) + (define (ref1 k) (ref k single multiple)) + (define (ref2 k k*) + (if k* + (let-values (((single multiple) (ref k single multiple))) + (ref k* single multiple)) + (ref1 k))) + (match cont + (($ $kreceive arity k) (ref1 k)) + (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) + (($ $ktail) (ref0)) + (($ $kclause arity kbody kalt) (ref2 kbody kalt)) + (($ $kargs names syms ($ $continue k src exp)) + (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intmap-fold add-ref conts single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +(define (compute-functions conts) + "Compute a map from $kfun label to bound variable names for all +functions in CONTS. Functions have two bound variable names: their self +binding, and the name they are given in their continuation. If their +continuation has more than one predecessor, then the bound variable name +doesn't uniquely identify the function, so we exclude that function from +the set." + (define (function-self label) + (match (intmap-ref conts label) + (($ $kfun src meta self) self))) + (let ((single (compute-singly-referenced-labels conts))) + (intmap-fold (lambda (label cont functions) + (match cont + (($ $kargs _ _ ($ $continue k src ($ $fun kfun))) + (if (intset-ref single k) + (match (intmap-ref conts k) + (($ $kargs (name) (var)) + (intmap-add functions kfun + (intset var (function-self kfun))))) + functions)) + (($ $kargs _ _ ($ $continue k src + ($ $rec _ vars (($ $fun kfuns) ...)))) + (if (intset-ref single k) + (fold (lambda (var kfun functions) + (intmap-add functions kfun + (intset var (function-self kfun)))) + functions vars kfuns) + functions)) + (_ functions))) + conts + empty-intmap))) + +(define (compute-multi-clause conts) + "Compute an set containing all labels that are part of a multi-clause +case-lambda. See the note in compute-contification-candidates." + (define (multi-clause? clause) + (and clause + (match (intmap-ref conts clause) + (($ $kclause arity body alt) + alt)))) + (intmap-fold (lambda (label cont multi) + (match cont + (($ $kfun src meta self tail clause) + (if (multi-clause? clause) + (intset-union multi (compute-function-body conts label)) + multi)) + (_ multi))) + conts + empty-intset)) + +(define (compute-arities conts functions) + "Given the map FUNCTIONS whose keys are $kfun labels, return a map +from label to arities." + (define (clause-arities clause) + (if clause + (match (intmap-ref conts clause) + (($ $kclause arity body alt) + (cons arity (clause-arities alt)))) + '())) + (intmap-map (lambda (label vars) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (clause-arities clause)))) + functions)) + +;; For now, we don't contify functions with optional, keyword, or rest +;; arguments. +(define (contifiable-arity? arity) + (match arity + (($ $arity req () #f () aok?) + #t) + (_ + #f))) + +(define (arity-matches? arity nargs) + (match arity + (($ $arity req () #f () aok?) + (= nargs (length req))) + (_ + #f))) + +(define (compute-contification-candidates conts) + "Compute and return a label -> (variable ...) map describing all +functions with known uses that are only ever used as the operator of a +$call, and are always called with a compatible arity." + (let* ((functions (compute-functions conts)) + (multi-clause (compute-multi-clause conts)) + (vars (intmap-fold (lambda (label vars out) + (intset-fold (lambda (var out) + (intmap-add out var label)) + vars out)) + functions + empty-intmap)) + (arities (compute-arities conts functions))) + (define (restrict-arity functions proc nargs) + (match (intmap-ref vars proc (lambda (_) #f)) + (#f functions) + (label + (let lp ((arities (intmap-ref arities label))) + (match arities + (() (intmap-remove functions label)) + ((arity . arities) + (cond + ((not (contifiable-arity? arity)) (lp '())) + ((arity-matches? arity nargs) functions) + (else (lp arities))))))))) + (define (visit-cont label cont functions) + (define (exclude-var functions var) + (match (intmap-ref vars var (lambda (_) #f)) + (#f functions) + (label (intmap-remove functions label)))) + (define (exclude-vars functions vars) + (match vars + (() functions) + ((var . vars) + (exclude-vars (exclude-var functions var) vars)))) + (match cont + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + ((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec)) + functions) + (($ $values args) + (exclude-vars functions args)) + (($ $call proc args) + (let ((functions (exclude-vars functions args))) + ;; This contification algorithm is happy to contify the + ;; `lp' in this example into a shared tail between clauses: + ;; + ;; (letrec ((lp (lambda () (lp)))) + ;; (case-lambda + ;; ((a) (lp)) + ;; ((a b) (lp)))) + ;; + ;; However because the current compilation pipeline has to + ;; re-nest continuations into old CPS, there would be no + ;; scope in which the tail would be valid. So, until the + ;; old compilation pipeline is completely replaced, + ;; conservatively exclude contifiable fucntions called + ;; from multi-clause procedures. + (if (intset-ref multi-clause label) + (exclude-var functions proc) + (restrict-arity functions proc (length args))))) + (($ $callk k proc args) + (exclude-vars functions (cons proc args))) + (($ $branch kt ($ $primcall name args)) + (exclude-vars functions args)) + (($ $branch kt ($ $values (arg))) + (exclude-var functions arg)) + (($ $primcall name args) + (exclude-vars functions args)) + (($ $prompt escape? tag handler) + (exclude-var functions tag)))) + (_ functions))) + (intmap-fold visit-cont conts functions))) + +(define (compute-call-graph conts labels vars) + "Given the set of contifiable functions LABELS and associated bound +variables VARS, compute and return two values: a map +LABEL->LABEL... indicating the contifiable functions called by a +function, and a map LABEL->LABEL... indicating the return continuations +for a function. The first return value also has an entry +0->LABEL... indicating all contifiable functions called by +non-contifiable functions. We assume that 0 is not in the contifiable +function set." + (let ((bodies + ;; label -> fun-label for all labels in bodies of contifiable + ;; functions + (intset-fold (lambda (fun-label bodies) + (intset-fold (lambda (label bodies) + (intmap-add bodies label fun-label)) + (compute-function-body conts fun-label) + bodies)) + labels + empty-intmap))) + (when (intset-ref labels 0) + (error "internal error: label 0 should not be contifiable")) + (intmap-fold + (lambda (label cont calls returns) + (match cont + (($ $kargs _ _ ($ $continue k src ($ $call proc))) + (match (intmap-ref vars proc (lambda (_) #f)) + (#f (values calls returns)) + (callee + (let ((caller (intmap-ref bodies label (lambda (_) 0)))) + (values (intmap-add calls caller callee intset-add) + (intmap-add returns callee k intset-add)))))) + (_ (values calls returns)))) + conts + (intset->intmap (lambda (label) empty-intset) (intset-add labels 0)) + (intset->intmap (lambda (label) empty-intset) labels)))) + +(define (tail-label conts label) + (match (intmap-ref conts label) + (($ $kfun src meta self tail body) + tail))) + +(define (compute-return-labels labels tails returns return-substs) + (define (subst k) + (match (intmap-ref return-substs k (lambda (_) #f)) + (#f k) + (k (subst k)))) + ;; Compute all return labels, then subtract tail labels of the + ;; functions in question. + (intset-subtract + ;; Return labels for all calls to these labels. + (intset-fold (lambda (label out) + (intset-fold (lambda (k out) + (intset-add out (subst k))) + (intmap-ref returns label) + out)) + labels + empty-intset) + (intset-fold (lambda (label out) + (intset-add out (intmap-ref tails label))) + labels + empty-intset))) + +(define (intmap->intset map) + (define (add-key label cont labels) + (intset-add labels label)) + (intmap-fold add-key map empty-intset)) + +(define (filter-contifiable contified groups) + (intmap-fold (lambda (id labels groups) + (let ((labels (intset-subtract labels contified))) + (if (eq? empty-intset labels) + groups + (intmap-add groups id labels)))) + groups + empty-intmap)) + +(define (trivial-set set) + (let ((first (intset-next set))) + (and first + (not (intset-next set (1+ first))) + first))) + +(define (compute-contification conts) + (let*-values + (;; label -> (var ...) + ((candidates) (compute-contification-candidates conts)) + ((labels) (intmap->intset candidates)) + ;; var -> label + ((vars) (intmap-fold (lambda (label vars out) + (intset-fold (lambda (var out) + (intmap-add out var label)) + vars out)) + candidates + empty-intmap)) + ;; caller-label -> callee-label..., callee-label -> return-label... + ((calls returns) (compute-call-graph conts labels vars)) + ;; callee-label -> tail-label + ((tails) (intset-fold + (lambda (label tails) + (intmap-add tails label (tail-label conts label))) + labels + empty-intmap)) + ;; Strongly connected components, allowing us to contify mutually + ;; tail-recursive functions. Since `compute-call-graph' added on + ;; a synthetic 0->LABEL... entry for contifiable functions called + ;; by non-contifiable functions, we need to remove that entry + ;; from the partition. It will be in its own component, as it + ;; has no predecessors. + ;; + ;; id -> label... + ((groups) (intmap-remove + (compute-strongly-connected-components calls 0) + 0))) + ;; todo: thread groups through contification + (define (attempt-contification labels contified return-substs) + (let ((returns (compute-return-labels labels tails returns + return-substs))) + (cond + ((trivial-set returns) + => (lambda (k) + ;; Success! + (values (intset-union contified labels) + (intset-fold (lambda (label return-substs) + (let ((tail (intmap-ref tails label))) + (intmap-add return-substs tail k))) + labels return-substs)))) + ((trivial-set labels) + ;; Single-label SCC failed to contify. + (values contified return-substs)) + (else + ;; Multi-label SCC failed to contify. Try instead to contify + ;; each one. + (intset-fold + (lambda (label contified return-substs) + (let ((labels (intset-add empty-intset label))) + (attempt-contification labels contified return-substs))) + labels contified return-substs))))) + (call-with-values + (lambda () + (fixpoint + (lambda (contified return-substs) + (intmap-fold + (lambda (id group contified return-substs) + (attempt-contification group contified return-substs)) + (filter-contifiable contified groups) + contified + return-substs)) + empty-intset + empty-intmap)) + (lambda (contified return-substs) + (values (intset-fold (lambda (label call-substs) + (intset-fold + (lambda (var call-substs) + (intmap-add call-substs var label)) + (intmap-ref candidates label) + call-substs)) + contified + empty-intmap) + return-substs))))) + +(define (apply-contification conts call-substs return-substs) + (define (call-subst proc) + (intmap-ref call-substs proc (lambda (_) #f))) + (define (return-subst k) + (intmap-ref return-substs k (lambda (_) #f))) + (define (find-body kfun nargs) + (match (intmap-ref conts kfun) + (($ $kfun src meta self tail clause) + (let lp ((clause clause)) + (match (intmap-ref conts clause) + (($ $kclause arity body alt) + (if (arity-matches? arity nargs) + body + (lp alt)))))))) + (define (continue k src exp) + (define (lookup-return-cont k) + (match (return-subst k) + (#f k) + (k (lookup-return-cont k)))) + (let ((k* (lookup-return-cont k))) + (if (eq? k k*) + (build-term ($continue k src ,exp)) + ;; We are contifying this return. It must be a call, a + ;; $values expression, or a return primcall. k* will be + ;; either a $ktail or a $kreceive continuation. CPS has this + ;; thing though where $kreceive can't be the target of a + ;; $values expression, and "return" can only continue to a + ;; tail continuation, so we might have to rewrite to a + ;; "values" primcall. + (build-term + ($continue k* src + ,(match (intmap-ref conts k*) + (($ $kreceive) + (match exp + (($ $primcall 'return (val)) + (build-exp ($primcall 'values (val)))) + (($ $call) exp) + ;; Except for 'return, a primcall that can continue + ;; to $ktail can also continue to $kreceive. TODO: + ;; replace 'return with 'values, for consistency. + (($ $primcall) exp) + (($ $values vals) + (build-exp ($primcall 'values vals))))) + (($ $ktail) exp))))))) + (define (visit-exp k src exp) + (match exp + (($ $call proc args) + ;; If proc is contifiable, replace call with jump. + (match (call-subst proc) + (#f (continue k src exp)) + (kfun + (let ((body (find-body kfun (length args)))) + (build-term ($continue body src ($values args))))))) + (($ $fun kfun) + ;; If the function's tail continuation has been + ;; substituted, that means it has been contified. + (if (return-subst (tail-label conts kfun)) + (continue k src (build-exp ($values ()))) + (continue k src exp))) + (($ $rec names vars funs) + (match (filter (match-lambda ((n v f) (not (call-subst v)))) + (map list names vars funs)) + (() (continue k src (build-exp ($values ())))) + (((names vars funs) ...) + (continue k src (build-exp ($rec names vars funs)))))) + (_ (continue k src exp)))) + + ;; Renumbering is not strictly necessary but some passes may not be + ;; equipped to deal with stale $kfun nodes whose bodies have been + ;; wired into other functions. + (renumber + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + ;; Remove bindings for functions that have been contified. + (match (filter (match-lambda ((name var) (not (call-subst var)))) + (map list names vars)) + (((names vars) ...) + (build-cont + ($kargs names vars ,(visit-exp k src exp)))))) + (_ cont))) + conts))) + +(define (contify conts) + ;; FIXME: Renumbering isn't really needed but dead continuations may + ;; cause compute-singly-referenced-labels to spuriously mark some + ;; conts as irreducible. For now we punt and renumber so that there + ;; are only live conts. + (let ((conts (renumber conts))) + (let-values (((call-substs return-substs) (compute-contification conts))) + (apply-contification conts call-substs return-substs)))) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm new file mode 100644 index 000000000..def542063 --- /dev/null +++ b/module/language/cps/cse.scm @@ -0,0 +1,449 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Common subexpression elimination for CPS. +;;; +;;; Code: + +(define-module (language cps cse) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps effects-analysis) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (eliminate-common-subexpressions)) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define-syntax-rule (make-worklist-folder* seed ...) + (lambda (f worklist seed ...) + (let lp ((worklist worklist) (seed seed) ...) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist i) + (if i + (call-with-values (lambda () (f i seed ...)) + (lambda (i* seed ...) + (let add ((i* i*) (worklist worklist)) + (match i* + (() (lp worklist seed ...)) + ((i . i*) (add i* (intset-add worklist i))))))) + (values seed ...))))))) + +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) + +(define (compute-available-expressions conts kfun effects) + "Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is +an intset containing ancestor labels whose value is available at LABEL." + (define (propagate avail succ out) + (let* ((in (intmap-ref avail succ (lambda (_) #f))) + (in* (if in (intset-intersect in out) out))) + (if (eq? in in*) + (values '() avail) + (values (list succ) + (intmap-add avail succ in* (lambda (old new) new)))))) + + (define (clobber label in) + (let ((fx (intmap-ref effects label))) + (cond + ((not (causes-effect? fx &write)) + ;; Fast-path if this expression clobbers nothing. + in) + (else + ;; Kill clobbered expressions. FIXME: there is no need to check + ;; on any label before than the last dominating label that + ;; clobbered everything. Another way to speed things up would + ;; be to compute a clobber set per-effect, which we could + ;; subtract from "in". + (let lp ((label 0) (in in)) + (cond + ((intset-next in label) + => (lambda (label) + (if (effect-clobbers? fx (intmap-ref effects label)) + (lp (1+ label) (intset-remove in label)) + (lp (1+ label) in)))) + (else in))))))) + + (define (visit-cont label avail) + (let* ((in (intmap-ref avail label)) + (out (intset-add (clobber label in) label))) + (define (propagate0) + (values '() avail)) + (define (propagate1 succ) + (propagate avail succ out)) + (define (propagate2 succ0 succ1) + (let*-values (((changed0 avail) (propagate avail succ0 out)) + ((changed1 avail) (propagate avail succ1 out))) + (values (append changed0 changed1) avail))) + + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $branch kt) (propagate2 k kt)) + (($ $prompt escape? tag handler) (propagate2 k handler)) + (_ (propagate1 k)))) + (($ $kreceive arity k) + (propagate1 k)) + (($ $kfun src meta self tail clause) + (if clause + (propagate1 clause) + (propagate0))) + (($ $kclause arity kbody kalt) + (if kalt + (propagate2 kbody kalt) + (propagate1 kbody))) + (($ $ktail) (propagate0))))) + + (worklist-fold* visit-cont + (intset kfun) + (intmap-add empty-intmap kfun empty-intset))) + +(define (compute-truthy-expressions conts kfun boolv) + "Compute a \"truth map\", indicating which expressions can be shown to +be true and/or false at each label in the function starting at KFUN.. +Returns an intmap of intsets. The even elements of the intset indicate +labels that may be true, and the odd ones indicate those that may be +false. It could be that both true and false proofs are available." + (define (true-idx label) (ash label 1)) + (define (false-idx label) (1+ (ash label 1))) + + (define (propagate boolv succ out) + (let* ((in (intmap-ref boolv succ (lambda (_) #f))) + (in* (if in (intset-intersect in out) out))) + (if (eq? in in*) + (values '() boolv) + (values (list succ) + (intmap-add boolv succ in* (lambda (old new) new)))))) + + (define (visit-cont label boolv) + (let ((in (intmap-ref boolv label))) + (define (propagate0) + (values '() boolv)) + (define (propagate1 succ) + (propagate boolv succ in)) + (define (propagate2 succ0 succ1) + (let*-values (((changed0 boolv) (propagate boolv succ0 in)) + ((changed1 boolv) (propagate boolv succ1 in))) + (values (append changed0 changed1) boolv))) + (define (propagate-branch succ0 succ1) + (let*-values (((changed0 boolv) + (propagate boolv succ0 + (intset-add in (false-idx label)))) + ((changed1 boolv) + (propagate boolv succ1 + (intset-add in (true-idx label))))) + (values (append changed0 changed1) boolv))) + + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $branch kt) (propagate-branch k kt)) + (($ $prompt escape? tag handler) (propagate2 k handler)) + (_ (propagate1 k)))) + (($ $kreceive arity k) + (propagate1 k)) + (($ $kfun src meta self tail clause) + (if clause + (propagate1 clause) + (propagate0))) + (($ $kclause arity kbody kalt) + (if kalt + (propagate2 kbody kalt) + (propagate1 kbody))) + (($ $ktail) (propagate0))))) + + (let ((boolv (worklist-fold* visit-cont + (intset kfun) + (intmap-add boolv kfun empty-intset)))) + ;; Now visit nested functions. We don't do this in the worklist + ;; folder because that would be exponential. + (define (recurse kfun boolv) + (compute-truthy-expressions conts kfun boolv)) + (intset-fold + (lambda (label boolv) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + (($ $fun kfun) (recurse kfun boolv)) + (($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun)) + (_ boolv))) + (_ boolv))) + (compute-function-body conts kfun) + boolv))) + +(define (intset-map f set) + (persistent-intmap + (intset-fold (lambda (i out) (intmap-add! out i (f i))) + set + empty-intmap))) + +;; Returns a map of label-idx -> (var-idx ...) indicating the variables +;; defined by a given labelled expression. +(define (compute-defs conts kfun) + (intset-map (lambda (label) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (list self)) + (($ $kclause arity body alt) + (match (intmap-ref conts body) + (($ $kargs names vars) vars))) + (($ $kreceive arity kargs) + (match (intmap-ref conts kargs) + (($ $kargs names vars) vars))) + (($ $ktail) + '()) + (($ $kargs names vars ($ $continue k)) + (match (intmap-ref conts k) + (($ $kargs names vars) vars) + (_ #f))))) + (compute-function-body conts kfun))) + +(define (compute-singly-referenced succs) + (define (visit label succs single multiple) + (intset-fold (lambda (label single multiple) + (if (intset-ref single label) + (values single (intset-add! multiple label)) + (values (intset-add! single label) multiple))) + succs single multiple)) + (call-with-values (lambda () + (intmap-fold visit succs empty-intset empty-intset)) + (lambda (single multiple) + (intset-subtract (persistent-intset single) + (persistent-intset multiple))))) + +(define (compute-equivalent-subexpressions conts kfun effects + equiv-labels var-substs) + (let* ((succs (compute-successors conts kfun)) + (singly-referenced (compute-singly-referenced succs)) + (avail (compute-available-expressions conts kfun effects)) + (defs (compute-defs conts kfun)) + (equiv-set (make-hash-table))) + (define (subst-var var-substs var) + (intmap-ref var-substs var (lambda (var) var))) + (define (subst-vars var-substs vars) + (let lp ((vars vars)) + (match vars + (() '()) + ((var . vars) (cons (subst-var var-substs var) (lp vars)))))) + + (define (compute-exp-key var-substs exp) + (match exp + (($ $const val) (cons 'const val)) + (($ $prim name) (cons 'prim name)) + (($ $fun body) #f) + (($ $rec names syms funs) #f) + (($ $call proc args) #f) + (($ $callk k proc args) #f) + (($ $primcall name args) + (cons* 'primcall name (subst-vars var-substs args))) + (($ $branch _ ($ $primcall name args)) + (cons* 'primcall name (subst-vars var-substs args))) + (($ $branch) #f) + (($ $values args) #f) + (($ $prompt escape? tag handler) #f))) + + (define (add-auxiliary-definitions! label var-substs exp-key) + (define (subst var) + (subst-var var-substs var)) + (let ((defs (intmap-ref defs label))) + (define (add-def! aux-key var) + (let ((equiv (hash-ref equiv-set aux-key '()))) + (hash-set! equiv-set aux-key + (acons label (list var) equiv)))) + (match exp-key + (('primcall 'box val) + (match defs + ((box) + (add-def! `(primcall box-ref ,(subst box)) val)))) + (('primcall 'box-set! box val) + (add-def! `(primcall box-ref ,box) val)) + (('primcall 'cons car cdr) + (match defs + ((pair) + (add-def! `(primcall car ,(subst pair)) car) + (add-def! `(primcall cdr ,(subst pair)) cdr)))) + (('primcall 'set-car! pair car) + (add-def! `(primcall car ,pair) car)) + (('primcall 'set-cdr! pair cdr) + (add-def! `(primcall cdr ,pair) cdr)) + (('primcall (or 'make-vector 'make-vector/immediate) len fill) + (match defs + ((vec) + (add-def! `(primcall vector-length ,(subst vec)) len)))) + (('primcall 'vector-set! vec idx val) + (add-def! `(primcall vector-ref ,vec ,idx) val)) + (('primcall 'vector-set!/immediate vec idx val) + (add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) + (('primcall (or 'allocate-struct 'allocate-struct/immediate) + vtable size) + (match defs + ((struct) + (add-def! `(primcall struct-vtable ,(subst struct)) + vtable)))) + (('primcall 'struct-set! struct n val) + (add-def! `(primcall struct-ref ,struct ,n) val)) + (('primcall 'struct-set!/immediate struct n val) + (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) + (_ #t)))) + + (define (visit-label label equiv-labels var-substs) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (let* ((exp-key (compute-exp-key var-substs exp)) + (equiv (hash-ref equiv-set exp-key '())) + (fx (intmap-ref effects label)) + (avail (intmap-ref avail label))) + (define (finish equiv-labels var-substs) + (define (recurse kfun equiv-labels var-substs) + (compute-equivalent-subexpressions conts kfun effects + equiv-labels var-substs)) + ;; If this expression defines auxiliary definitions, + ;; as `cons' does for the results of `car' and `cdr', + ;; define those. Do so after finding equivalent + ;; expressions, so that we can take advantage of + ;; subst'd output vars. + (add-auxiliary-definitions! label var-substs exp-key) + (match exp + ;; If we see a $fun, recurse to add to the result. + (($ $fun kfun) + (recurse kfun equiv-labels var-substs)) + (($ $rec names vars (($ $fun kfun) ...)) + (fold2 recurse kfun equiv-labels var-substs)) + (_ + (values equiv-labels var-substs)))) + (let lp ((candidates equiv)) + (match candidates + (() + ;; No matching expressions. Add our expression + ;; to the equivalence set, if appropriate. Note + ;; that expressions that allocate a fresh object + ;; or change the current fluid environment can't + ;; be eliminated by CSE (though DCE might do it + ;; if the value proves to be unused, in the + ;; allocation case). + (when (and exp-key + (not (causes-effect? fx &allocation)) + (not (effect-clobbers? fx (&read-object &fluid)))) + (let ((defs (and (intset-ref singly-referenced k) + (intmap-ref defs label)))) + (when defs + (hash-set! equiv-set exp-key + (acons label defs equiv))))) + (finish equiv-labels var-substs)) + (((and head (candidate . vars)) . candidates) + (cond + ((not (intset-ref avail candidate)) + ;; This expression isn't available here; try + ;; the next one. + (lp candidates)) + (else + ;; Yay, a match. Mark expression as equivalent. If + ;; we provide the definitions for the successor, mark + ;; the vars for substitution. + (finish (intmap-add equiv-labels label head) + (let ((defs (and (intset-ref singly-referenced k) + (intmap-ref defs label)))) + (if defs + (fold (lambda (def var var-substs) + (intmap-add var-substs def var)) + var-substs defs vars) + var-substs)))))))))) + (_ (values equiv-labels var-substs)))) + + ;; Traverse the labels in fun in reverse post-order, which will + ;; visit definitions before uses first. + (fold2 visit-label + (compute-reverse-post-order succs kfun) + equiv-labels + var-substs))) + +(define (apply-cse conts equiv-labels var-substs truthy-labels) + (define (true-idx idx) (ash idx 1)) + (define (false-idx idx) (1+ (ash idx 1))) + + (define (subst-var var) + (intmap-ref var-substs var (lambda (var) var))) + + (define (visit-exp exp) + (rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp) + (($ $call proc args) + ($call (subst-var proc) ,(map subst-var args))) + (($ $callk k proc args) + ($callk k (subst-var proc) ,(map subst-var args))) + (($ $primcall name args) + ($primcall name ,(map subst-var args))) + (($ $branch k exp) + ($branch k ,(visit-exp exp))) + (($ $values args) + ($values ,(map subst-var args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst-var tag) handler)))) + + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (build-cont + ($kargs names vars + ,(match (intmap-ref equiv-labels label (lambda (_) #f)) + ((equiv . vars) + (match exp + (($ $branch kt exp) + (let* ((bool (intmap-ref truthy-labels label)) + (t (intset-ref bool (true-idx equiv))) + (f (intset-ref bool (false-idx equiv)))) + (if (eqv? t f) + (build-term + ($continue k src + ($branch kt ,(visit-exp exp)))) + (build-term + ($continue (if t kt k) src ($values ())))))) + (_ + ;; For better or for worse, we only replace primcalls + ;; if they have an associated VM op, which allows + ;; them to continue to $kargs and thus we know their + ;; defs and can use a $values expression instead of a + ;; values primcall. + (build-term + ($continue k src ($values vars)))))) + (#f + (build-term + ($continue k src ,(visit-exp exp)))))))) + (_ cont))) + conts)) + +(define (eliminate-common-subexpressions conts) + (call-with-values + (lambda () + (let ((effects (synthesize-definition-effects (compute-effects conts)))) + (compute-equivalent-subexpressions conts 0 effects + empty-intmap empty-intmap))) + (lambda (equiv-labels var-substs) + (let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap))) + (apply-cse conts equiv-labels var-substs truthy-labels))))) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm new file mode 100644 index 000000000..5463f5b1e --- /dev/null +++ b/module/language/cps/dce.scm @@ -0,0 +1,399 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This pass kills dead expressions: code that has no side effects, and +;;; whose value is unused. It does so by marking all live values, and +;;; then discarding other values as dead. This happens recursively +;;; through procedures, so it should be possible to elide dead +;;; procedures as well. +;;; +;;; Code: + +(define-module (language cps dce) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (language cps) + #:use-module (language cps effects-analysis) + #:use-module (language cps renumber) + #:use-module (language cps types) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (eliminate-dead-code)) + +(define (elide-type-checks conts kfun effects) + "Elide &type-check effects from EFFECTS for the function starting at +KFUN where we can prove that no assertion will be raised at run-time." + (let ((types (infer-types conts kfun))) + (define (visit-primcall effects fx label name args) + (if (primcall-types-check? types label name args) + (intmap-replace! effects label (logand fx (lognot &type-check))) + effects)) + (persistent-intmap + (intmap-fold (lambda (label types effects) + (let ((fx (intmap-ref effects label))) + (cond + ((causes-all-effects? fx) effects) + ((causes-effect? fx &type-check) + (match (intmap-ref conts label) + (($ $kargs _ _ exp) + (match exp + (($ $continue k src ($ $primcall name args)) + (visit-primcall effects fx label name args)) + (($ $continue k src + ($ $branch _ ($primcall name args))) + (visit-primcall effects fx label name args)) + (_ effects))) + (_ effects))) + (else effects)))) + types + effects)))) + +(define (compute-effects/elide-type-checks conts) + (intmap-fold (lambda (label cont effects) + (match cont + (($ $kfun) (elide-type-checks conts label effects)) + (_ effects))) + conts + (compute-effects conts))) + +(define (fold-local-conts proc conts label seed) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (let lp ((label label) (seed seed)) + (if (<= label tail) + (lp (1+ label) (proc label (intmap-ref conts label) seed)) + seed))))) + +(define (postorder-fold-local-conts2 proc conts label seed0 seed1) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (let ((start label)) + (let lp ((label tail) (seed0 seed0) (seed1 seed1)) + (if (<= start label) + (let ((cont (intmap-ref conts label))) + (call-with-values (lambda () (proc label cont seed0 seed1)) + (lambda (seed0 seed1) + (lp (1- label) seed0 seed1)))) + (values seed0 seed1))))))) + +(define (compute-known-allocations conts effects) + "Compute the variables bound in CONTS that have known allocation +sites." + ;; Compute the set of conts that are called with freshly allocated + ;; values, and subtract from that set the conts that might be called + ;; with values with unknown allocation sites. Then convert that set + ;; of conts into a set of bound variables. + (call-with-values + (lambda () + (intmap-fold (lambda (label cont known unknown) + ;; Note that we only need to add labels to the + ;; known/unknown sets if the labels can bind + ;; values. So there's no need to add tail, + ;; clause, branch alternate, or prompt handler + ;; labels, as they bind no values. + (match cont + (($ $kargs _ _ ($ $continue k)) + (let ((fx (intmap-ref effects label))) + (if (and (not (causes-all-effects? fx)) + (causes-effect? fx &allocation)) + (values (intset-add! known k) unknown) + (values known (intset-add! unknown k))))) + (($ $kreceive arity kargs) + (values known (intset-add! unknown kargs))) + (($ $kfun src meta self tail clause) + (values known unknown)) + (($ $kclause arity body alt) + (values known (intset-add! unknown body))) + (($ $ktail) + (values known unknown)))) + conts + empty-intset + empty-intset)) + (lambda (known unknown) + (persistent-intset + (intset-fold (lambda (label vars) + (match (intmap-ref conts label) + (($ $kargs (_) (var)) (intset-add! vars var)) + (_ vars))) + (intset-subtract (persistent-intset known) + (persistent-intset unknown)) + empty-intset))))) + +(define (compute-live-code conts) + (let* ((effects (compute-effects/elide-type-checks conts)) + (known-allocations (compute-known-allocations conts effects))) + (define (adjoin-var var set) + (intset-add set var)) + (define (adjoin-vars vars set) + (match vars + (() set) + ((var . vars) (adjoin-vars vars (adjoin-var var set))))) + (define (var-live? var live-vars) + (intset-ref live-vars var)) + (define (any-var-live? vars live-vars) + (match vars + (() #f) + ((var . vars) + (or (var-live? var live-vars) + (any-var-live? vars live-vars))))) + (define (cont-defs k) + (match (intmap-ref conts k) + (($ $kargs _ vars) vars) + (_ #f))) + + (define (visit-live-exp label k exp live-labels live-vars) + (match exp + ((or ($ $const) ($ $prim)) + (values live-labels live-vars)) + (($ $fun body) + (values (intset-add live-labels body) live-vars)) + (($ $closure body) + (values (intset-add live-labels body) live-vars)) + (($ $rec names vars (($ $fun kfuns) ...)) + (let lp ((vars vars) (kfuns kfuns) + (live-labels live-labels) (live-vars live-vars)) + (match (vector vars kfuns) + (#(() ()) (values live-labels live-vars)) + (#((var . vars) (kfun . kfuns)) + (lp vars kfuns + (if (var-live? var live-vars) + (intset-add live-labels kfun) + live-labels) + live-vars))))) + (($ $prompt escape? tag handler) + (values live-labels (adjoin-var tag live-vars))) + (($ $call proc args) + (values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) + (($ $callk kfun proc args) + (values (intset-add live-labels kfun) + (adjoin-vars args (adjoin-var proc live-vars)))) + (($ $primcall name args) + (values live-labels (adjoin-vars args live-vars))) + (($ $branch k ($ $primcall name args)) + (values live-labels (adjoin-vars args live-vars))) + (($ $branch k ($ $values (arg))) + (values live-labels (adjoin-var arg live-vars))) + (($ $values args) + (values live-labels + (match (cont-defs k) + (#f (adjoin-vars args live-vars)) + (defs (fold (lambda (use def live-vars) + (if (var-live? def live-vars) + (adjoin-var use live-vars) + live-vars)) + live-vars args defs))))))) + + (define (visit-exp label k exp live-labels live-vars) + (cond + ((intset-ref live-labels label) + ;; Expression live already. + (visit-live-exp label k exp live-labels live-vars)) + ((let ((defs (cont-defs k)) + (fx (intmap-ref effects label))) + (or + ;; No defs; perhaps continuation is $ktail. + (not defs) + ;; We don't remove branches. + (match exp (($ $branch) #t) (_ #f)) + ;; Do we have a live def? + (any-var-live? defs live-vars) + ;; Does this expression cause all effects? If so, it's + ;; definitely live. + (causes-all-effects? fx) + ;; Does it cause a type check, but we weren't able to prove + ;; that the types check? + (causes-effect? fx &type-check) + ;; We might have a setter. If the object being assigned to + ;; is live or was not created by us, then this expression is + ;; live. Otherwise the value is still dead. + (and (causes-effect? fx &write) + (match exp + (($ $primcall + (or 'vector-set! 'vector-set!/immediate + 'set-car! 'set-cdr! + 'box-set!) + (obj . _)) + (or (var-live? obj live-vars) + (not (intset-ref known-allocations obj)))) + (_ #t))))) + ;; Mark expression as live and visit. + (visit-live-exp label k exp (intset-add live-labels label) live-vars)) + (else + ;; Still dead. + (values live-labels live-vars)))) + + (define (visit-fun label live-labels live-vars) + ;; Visit uses before definitions. + (postorder-fold-local-conts2 + (lambda (label cont live-labels live-vars) + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (visit-exp label k exp live-labels live-vars)) + (($ $kreceive arity kargs) + (values live-labels live-vars)) + (($ $kclause arity kargs kalt) + (values live-labels (adjoin-vars (cont-defs kargs) live-vars))) + (($ $kfun src meta self) + (values live-labels (adjoin-var self live-vars))) + (($ $ktail) + (values live-labels live-vars)))) + conts label live-labels live-vars)) + + (fixpoint (lambda (live-labels live-vars) + (let lp ((label 0) + (live-labels live-labels) + (live-vars live-vars)) + (match (intset-next live-labels label) + (#f (values live-labels live-vars)) + (label + (call-with-values + (lambda () + (match (intmap-ref conts label) + (($ $kfun) + (visit-fun label live-labels live-vars)) + (_ (values live-labels live-vars)))) + (lambda (live-labels live-vars) + (lp (1+ label) live-labels live-vars))))))) + (intset 0) + empty-intset))) + +(define-syntax adjoin-conts + (syntax-rules () + ((_ (exp ...) clause ...) + (let ((cps (exp ...))) + (adjoin-conts cps clause ...))) + ((_ cps (label cont) clause ...) + (adjoin-conts (intmap-add! cps label (build-cont cont)) + clause ...)) + ((_ cps) + cps))) + +(define (process-eliminations conts live-labels live-vars) + (define (label-live? label) + (intset-ref live-labels label)) + (define (value-live? var) + (intset-ref live-vars var)) + (define (make-adaptor k src defs) + (let* ((names (map (lambda (_) 'tmp) defs)) + (vars (map (lambda (_) (fresh-var)) defs)) + (live (filter-map (lambda (def var) + (and (value-live? def) var)) + defs vars))) + (build-cont + ($kargs names vars + ($continue k src ($values live)))))) + (define (visit-term label term cps) + (match term + (($ $continue k src exp) + (if (label-live? label) + (match exp + (($ $fun body) + (values cps + term)) + (($ $closure body nfree) + (values cps + term)) + (($ $rec names vars funs) + (match (filter-map (lambda (name var fun) + (and (value-live? var) + (list name var fun))) + names vars funs) + (() + (values cps + (build-term ($continue k src ($values ()))))) + (((names vars funs) ...) + (values cps + (build-term ($continue k src + ($rec names vars funs))))))) + (_ + (match (intmap-ref conts k) + (($ $kargs ()) + (values cps term)) + (($ $kargs names ((? value-live?) ...)) + (values cps term)) + (($ $kargs names vars) + (match exp + (($ $values args) + (let ((args (filter-map (lambda (use def) + (and (value-live? def) use)) + args vars))) + (values cps + (build-term + ($continue k src ($values args)))))) + (_ + (let-fresh (adapt) () + (values (adjoin-conts cps + (adapt ,(make-adaptor k src vars))) + (build-term + ($continue adapt src ,exp))))))) + (_ + (values cps term))))) + (values cps + (build-term + ($continue k src ($values ())))))))) + (define (visit-cont label cont cps) + (match cont + (($ $kargs names vars term) + (match (filter-map (lambda (name var) + (and (value-live? var) + (cons name var))) + names vars) + (((names . vars) ...) + (call-with-values (lambda () (visit-term label term cps)) + (lambda (cps term) + (adjoin-conts cps + (label ($kargs names vars ,term)))))))) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (let ((defs (match (intmap-ref conts kargs) + (($ $kargs names vars) vars)))) + (if (and-map value-live? defs) + (adjoin-conts cps (label ,cont)) + (let-fresh (adapt) () + (adjoin-conts cps + (adapt ,(make-adaptor kargs #f defs)) + (label ($kreceive req rest adapt))))))) + (_ + (adjoin-conts cps (label ,cont))))) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold (lambda (label cont cps) + (match cont + (($ $kfun) + (if (label-live? label) + (fold-local-conts visit-cont conts label cps) + cps)) + (_ cps))) + conts + empty-intmap)))) + +(define (eliminate-dead-code conts) + ;; We work on a renumbered program so that we can easily visit uses + ;; before definitions just by visiting higher-numbered labels before + ;; lower-numbered labels. Renumbering is also a precondition for type + ;; inference. + (let ((conts (renumber conts))) + (call-with-values (lambda () (compute-live-code conts)) + (lambda (live-labels live-vars) + (process-eliminations conts live-labels live-vars))))) + +;;; Local Variables: +;;; eval: (put 'adjoin-conts 'scheme-indent-function 1) +;;; End: diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm new file mode 100644 index 000000000..874eb7829 --- /dev/null +++ b/module/language/cps/effects-analysis.scm @@ -0,0 +1,484 @@ +;;; Effects analysis on CPS + +;; Copyright (C) 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A helper module to compute the set of effects caused by an +;;; expression. This information is useful when writing algorithms that +;;; move code around, while preserving the semantics of an input +;;; program. +;;; +;;; The effects set is represented as an integer with three parts. The +;;; low 4 bits indicate effects caused by an expression, as a bitfield. +;;; The next 4 bits indicate the kind of memory accessed by the +;;; expression, if it accesses mutable memory. Finally the rest of the +;;; bits indicate the field in the object being accessed, if known, or +;;; -1 for unknown. +;;; +;;; In this way we embed a coarse type-based alias analysis in the +;;; effects analysis. For example, a "car" call is modelled as causing +;;; a read to field 0 on a &pair, and causing a &type-check effect. If +;;; any intervening code sets the car of any pair, that will block +;;; motion of the "car" call, because any write to field 0 of a pair is +;;; seen by effects analysis as being a write to field 0 of all pairs. +;;; +;;; Code: + +(define-module (language cps effects-analysis) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (ice-9 match) + #:export (expression-effects + compute-effects + synthesize-definition-effects + + &allocation + &type-check + &read + &write + + &fluid + &prompt + &car + &cdr + &vector + &box + &module + &struct + &string + &bytevector + + &object + &field + + &allocate + &read-object + &read-field + &write-object + &write-field + + &no-effects + &all-effects + + exclude-effects + effect-free? + constant? + causes-effect? + causes-all-effects? + effect-clobbers?)) + +(define-syntax define-flags + (lambda (x) + (syntax-case x () + ((_ all shift name ...) + (let ((count (length #'(name ...)))) + (with-syntax (((n ...) (iota count)) + (count count)) + #'(begin + (define-syntax name (identifier-syntax (ash 1 n))) + ... + (define-syntax all (identifier-syntax (1- (ash 1 count)))) + (define-syntax shift (identifier-syntax count))))))))) + +(define-syntax define-enumeration + (lambda (x) + (define (count-bits n) + (let lp ((out 1)) + (if (< n (ash 1 (1- out))) + out + (lp (1+ out))))) + (syntax-case x () + ((_ mask shift name ...) + (let* ((len (length #'(name ...))) + (bits (count-bits len))) + (with-syntax (((n ...) (iota len)) + (bits bits)) + #'(begin + (define-syntax name (identifier-syntax n)) + ... + (define-syntax mask (identifier-syntax (1- (ash 1 bits)))) + (define-syntax shift (identifier-syntax bits))))))))) + +(define-flags &all-effect-kinds &effect-kind-bits + ;; Indicates that an expression may cause a type check. A type check, + ;; for the purposes of this analysis, is the possibility of throwing + ;; an exception the first time an expression is evaluated. If the + ;; expression did not cause an exception to be thrown, users can + ;; assume that evaluating the expression again will not cause an + ;; exception to be thrown. + ;; + ;; For example, (+ x y) might throw if X or Y are not numbers. But if + ;; it doesn't throw, it should be safe to elide a dominated, common + ;; subexpression (+ x y). + &type-check + + ;; Indicates that an expression may return a fresh object. The kind + ;; of object is indicated in the object kind field. + &allocation + + ;; Indicates that an expression may cause a read from memory. The + ;; kind of memory is given in the object kind field. Some object + ;; kinds have finer-grained fields; those are expressed in the "field" + ;; part of the effects value. -1 indicates "the whole object". + &read + + ;; Indicates that an expression may cause a write to memory. + &write) + +(define-enumeration &memory-kind-mask &memory-kind-bits + ;; Indicates than an expression may access unknown kinds of memory. + &unknown-memory-kinds + + ;; Indicates that an expression depends on the value of a fluid + ;; variable, or on the current fluid environment. + &fluid + + ;; Indicates that an expression depends on the current prompt + ;; stack. + &prompt + + ;; Indicates that an expression depends on the value of the car or cdr + ;; of a pair. + &pair + + ;; Indicates that an expression depends on the value of a vector + ;; field. The effect field indicates the specific field, or zero for + ;; an unknown field. + &vector + + ;; Indicates that an expression depends on the value of a variable + ;; cell. + &box + + ;; Indicates that an expression depends on the current module. + &module + + ;; Indicates that an expression depends on the value of a struct + ;; field. The effect field indicates the specific field, or zero for + ;; an unknown field. + &struct + + ;; Indicates that an expression depends on the contents of a string. + &string + + ;; Indicates that an expression depends on the contents of a + ;; bytevector. We cannot be more precise, as bytevectors may alias + ;; other bytevectors. + &bytevector) + +(define-inlinable (&field kind field) + (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits)) +(define-inlinable (&object kind) + (&field kind -1)) + +(define-inlinable (&allocate kind) + (logior &allocation (&object kind))) +(define-inlinable (&read-field kind field) + (logior &read (&field kind field))) +(define-inlinable (&read-object kind) + (logior &read (&object kind))) +(define-inlinable (&write-field kind field) + (logior &write (&field kind field))) +(define-inlinable (&write-object kind) + (logior &write (&object kind))) + +(define-syntax &no-effects (identifier-syntax 0)) +(define-syntax &all-effects + (identifier-syntax + (logior &all-effect-kinds (&object &unknown-memory-kinds)))) + +(define-inlinable (constant? effects) + (zero? effects)) + +(define-inlinable (causes-effect? x effects) + (not (zero? (logand x effects)))) + +(define-inlinable (causes-all-effects? x) + (eqv? x &all-effects)) + +(define (effect-clobbers? a b) + "Return true if A clobbers B. This is the case if A is a write, and B +is or might be a read or a write to the same location as A." + (define (locations-same?) + (let ((a (ash a (- &effect-kind-bits))) + (b (ash b (- &effect-kind-bits)))) + (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask)) + (eqv? &unknown-memory-kinds (logand b &memory-kind-mask)) + (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask)) + ;; A negative field indicates "the whole object". + ;; Non-negative fields indicate only part of the object. + (or (< a 0) (< b 0) (= a b)))))) + (and (not (zero? (logand a &write))) + (not (zero? (logand b (logior &read &write)))) + (locations-same?))) + +(define-inlinable (indexed-field kind var constants) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (if (and (exact-integer? val) (<= 0 val)) + (&field kind val) + (&object kind)))) + +(define *primitive-effects* (make-hash-table)) + +(define-syntax-rule (define-primitive-effects* constants + ((name . args) effects ...) + ...) + (begin + (hashq-set! *primitive-effects* 'name + (case-lambda* + ((constants . args) (logior effects ...)) + (_ &all-effects))) + ...)) + +(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...) + (define-primitive-effects* constants ((name . args) effects ...) ...)) + +;; Miscellaneous. +(define-primitive-effects + ((values . _))) + +;; Generic effect-free predicates. +(define-primitive-effects + ((eq? . _)) + ((eqv? . _)) + ((equal? . _)) + ((pair? arg)) + ((null? arg)) + ((nil? arg )) + ((symbol? arg)) + ((variable? arg)) + ((vector? arg)) + ((struct? arg)) + ((string? arg)) + ((number? arg)) + ((char? arg)) + ((bytevector? arg)) + ((keyword? arg)) + ((bitvector? arg)) + ((procedure? arg)) + ((thunk? arg))) + +;; Fluids. +(define-primitive-effects + ((fluid-ref f) (&read-object &fluid) &type-check) + ((fluid-set! f v) (&write-object &fluid) &type-check) + ((push-fluid f v) (&write-object &fluid) &type-check) + ((pop-fluid) (&write-object &fluid) &type-check)) + +;; Prompts. +(define-primitive-effects + ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds))) + +;; Pairs. +(define-primitive-effects + ((cons a b) (&allocate &pair)) + ((list . _) (&allocate &pair)) + ((car x) (&read-field &pair 0) &type-check) + ((set-car! x y) (&write-field &pair 0) &type-check) + ((cdr x) (&read-field &pair 1) &type-check) + ((set-cdr! x y) (&write-field &pair 1) &type-check) + ((memq x y) (&read-object &pair) &type-check) + ((memv x y) (&read-object &pair) &type-check) + ((list? arg) (&read-field &pair 1)) + ((length l) (&read-field &pair 1) &type-check)) + +;; Variables. +(define-primitive-effects + ((box v) (&allocate &box)) + ((box-ref v) (&read-object &box) &type-check) + ((box-set! v x) (&write-object &box) &type-check)) + +;; Vectors. +(define (vector-field n constants) + (indexed-field &vector n constants)) +(define (read-vector-field n constants) + (logior &read (vector-field n constants))) +(define (write-vector-field n constants) + (logior &write (vector-field n constants))) +(define-primitive-effects* constants + ((vector . _) (&allocate &vector)) + ((make-vector n init) (&allocate &vector) &type-check) + ((make-vector/immediate n init) (&allocate &vector)) + ((vector-ref v n) (read-vector-field n constants) &type-check) + ((vector-ref/immediate v n) (read-vector-field n constants) &type-check) + ((vector-set! v n x) (write-vector-field n constants) &type-check) + ((vector-set!/immediate v n x) (write-vector-field n constants) &type-check) + ((vector-length v) &type-check)) + +;; Structs. +(define (struct-field n constants) + (indexed-field &struct n constants)) +(define (read-struct-field n constants) + (logior &read (struct-field n constants))) +(define (write-struct-field n constants) + (logior &write (struct-field n constants))) +(define-primitive-effects* constants + ((allocate-struct vt n) (&allocate &struct) &type-check) + ((allocate-struct/immediate v n) (&allocate &struct) &type-check) + ((make-struct vt ntail . _) (&allocate &struct) &type-check) + ((make-struct/no-tail vt . _) (&allocate &struct) &type-check) + ((struct-ref s n) (read-struct-field n constants) &type-check) + ((struct-ref/immediate s n) (read-struct-field n constants) &type-check) + ((struct-set! s n x) (write-struct-field n constants) &type-check) + ((struct-set!/immediate s n x) (write-struct-field n constants) &type-check) + ((struct-vtable s) &type-check)) + +;; Strings. +(define-primitive-effects + ((string-ref s n) (&read-object &string) &type-check) + ((string-set! s n c) (&write-object &string) &type-check) + ((number->string _) (&allocate &string) &type-check) + ((string->number _) (&read-object &string) &type-check) + ((string-length s) &type-check)) + +;; Bytevectors. +(define-primitive-effects + ((bytevector-length _) &type-check) + + ((bv-u8-ref bv n) (&read-object &bytevector) &type-check) + ((bv-s8-ref bv n) (&read-object &bytevector) &type-check) + ((bv-u16-ref bv n) (&read-object &bytevector) &type-check) + ((bv-s16-ref bv n) (&read-object &bytevector) &type-check) + ((bv-u32-ref bv n) (&read-object &bytevector) &type-check) + ((bv-s32-ref bv n) (&read-object &bytevector) &type-check) + ((bv-u64-ref bv n) (&read-object &bytevector) &type-check) + ((bv-s64-ref bv n) (&read-object &bytevector) &type-check) + ((bv-f32-ref bv n) (&read-object &bytevector) &type-check) + ((bv-f64-ref bv n) (&read-object &bytevector) &type-check) + + ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check)) + +;; Modules. +(define-primitive-effects + ((current-module) (&read-object &module)) + ((cache-current-module! m scope) (&write-object &box)) + ((resolve name bound?) (&read-object &module) &type-check) + ((cached-toplevel-box scope name bound?) &type-check) + ((cached-module-box mod name public? bound?) &type-check) + ((define! name val) (&read-object &module) (&write-object &box))) + +;; Numbers. +(define-primitive-effects + ((= . _) &type-check) + ((< . _) &type-check) + ((> . _) &type-check) + ((<= . _) &type-check) + ((>= . _) &type-check) + ((zero? . _) &type-check) + ((add . _) &type-check) + ((mul . _) &type-check) + ((sub . _) &type-check) + ((div . _) &type-check) + ((sub1 . _) &type-check) + ((add1 . _) &type-check) + ((quo . _) &type-check) + ((rem . _) &type-check) + ((mod . _) &type-check) + ((complex? _) &type-check) + ((real? _) &type-check) + ((rational? _) &type-check) + ((inf? _) &type-check) + ((nan? _) &type-check) + ((integer? _) &type-check) + ((exact? _) &type-check) + ((inexact? _) &type-check) + ((even? _) &type-check) + ((odd? _) &type-check) + ((ash n m) &type-check) + ((logand . _) &type-check) + ((logior . _) &type-check) + ((logxor . _) &type-check) + ((lognot . _) &type-check) + ((logtest a b) &type-check) + ((logbit? a b) &type-check) + ((sqrt _) &type-check) + ((abs _) &type-check)) + +;; Characters. +(define-primitive-effects + ((char<? . _) &type-check) + ((char<=? . _) &type-check) + ((char>=? . _) &type-check) + ((char>? . _) &type-check) + ((integer->char _) &type-check) + ((char->integer _) &type-check)) + +(define (primitive-effects constants name args) + (let ((proc (hashq-ref *primitive-effects* name))) + (if proc + (apply proc constants args) + &all-effects))) + +(define (expression-effects exp constants) + (match exp + ((or ($ $const) ($ $prim) ($ $values)) + &no-effects) + ((or ($ $fun) ($ $rec) ($ $closure)) + (&allocate &unknown-memory-kinds)) + (($ $prompt) + (&write-object &prompt)) + ((or ($ $call) ($ $callk)) + &all-effects) + (($ $branch k exp) + (expression-effects exp constants)) + (($ $primcall name args) + (primitive-effects constants name args)))) + +(define (compute-effects conts) + (let ((constants (compute-constant-values conts))) + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names syms ($ $continue k src exp)) + (expression-effects exp constants)) + (($ $kreceive arity kargs) + (match arity + (($ $arity _ () #f () #f) &type-check) + (($ $arity () () _ () #f) (&allocate &pair)) + (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check)))) + (($ $kfun) &type-check) + (($ $kclause) &type-check) + (($ $ktail) &no-effects))) + conts))) + +;; There is a way to abuse effects analysis in CSE to also do scalar +;; replacement, effectively adding `car' and `cdr' expressions to `cons' +;; expressions, and likewise with other constructors and setters. This +;; routine adds appropriate effects to `cons' and `set-car!' and the +;; like. +;; +;; This doesn't affect CSE's ability to eliminate expressions, given +;; that allocations aren't eliminated anyway, and the new effects will +;; just cause the allocations not to commute with e.g. set-car! which +;; is what we want anyway. +(define (synthesize-definition-effects effects) + (intmap-map (lambda (label fx) + (if (logtest (logior &write &allocation) fx) + (logior fx &read) + fx)) + effects)) diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm new file mode 100644 index 000000000..81ccfc200 --- /dev/null +++ b/module/language/cps/elide-values.scm @@ -0,0 +1,88 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Primcalls that don't correspond to VM instructions are treated as if +;;; they are calls, and indeed the later reify-primitives pass turns +;;; them into calls. Because no return arity checking is done for these +;;; primitives, if a later optimization pass simplifies the primcall to +;;; a VM operation, the tail of the simplification has to be a +;;; primcall to 'values. Most of these primcalls can be elided, and +;;; that is the job of this pass. +;;; +;;; Code: + +(define-module (language cps elide-values) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:export (elide-values)) + +(define (inline-values cps k src args) + (match (intmap-ref cps k) + (($ $ktail) + (with-cps cps + (build-term + ($continue k src ($values args))))) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (cond + ((and (not rest) (= (length args) (length req))) + (with-cps cps + (build-term + ($continue kargs src ($values args))))) + ((and rest (>= (length args) (length req))) + (let () + (define (build-rest cps k tail) + (match tail + (() + (with-cps cps + (build-term ($continue k src ($const '()))))) + ((v . tail) + (with-cps cps + (letv rest) + (letk krest ($kargs ('rest) (rest) + ($continue k src ($primcall 'cons (v rest))))) + ($ (build-rest krest tail)))))) + (with-cps cps + (letv rest) + (letk krest ($kargs ('rest) (rest) + ($continue kargs src + ($values ,(append (list-head args (length req)) + (list rest)))))) + ($ (build-rest krest (list-tail args (length req))))))) + (else (with-cps cps #f)))))) + +(define (elide-values conts) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs names vars ($ $continue k src ($ $primcall 'values args))) + (call-with-values (lambda () (inline-values out k src args)) + (lambda (out term) + (if term + (let ((cont (build-cont ($kargs names vars ,term)))) + (intmap-replace! out label cont)) + out)))) + (_ out))) + conts + conts)))) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm new file mode 100644 index 000000000..83a3f2dfe --- /dev/null +++ b/module/language/cps/optimize.scm @@ -0,0 +1,106 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Optimizations on CPS. +;;; +;;; Code: + +(define-module (language cps optimize) + #:use-module (ice-9 match) + #:use-module (language cps constructors) + #:use-module (language cps contification) + #:use-module (language cps cse) + #:use-module (language cps dce) + #:use-module (language cps elide-values) + #:use-module (language cps prune-top-level-scopes) + #:use-module (language cps prune-bailouts) + #:use-module (language cps self-references) + #:use-module (language cps simplify) + #:use-module (language cps specialize-primcalls) + #:use-module (language cps split-rec) + #:use-module (language cps type-fold) + #:use-module (language cps verify) + #:export (optimize-higher-order-cps + optimize-first-order-cps)) + +(define (kw-arg-ref args kw default) + (match (memq kw args) + ((_ val . _) val) + (_ default))) + +(define *debug?* #f) + +(define (maybe-verify program) + (if *debug?* + (verify program) + program)) + +(define-syntax-rule (define-optimizer optimize (pass kw default) ...) + (define* (optimize program #:optional (opts '())) + ;; This series of assignments to `program' used to be a series of + ;; let* bindings of `program', as you would imagine. In compiled + ;; code this is fine because the compiler is able to allocate all + ;; let*-bound variable to the same slot, which also means that the + ;; garbage collector doesn't have to retain so many copies of the + ;; term being optimized. However during bootstrap, the interpreter + ;; doesn't do this optimization, leading to excessive data retention + ;; as the terms are rewritten. To marginally improve bootstrap + ;; memory usage, here we use set! instead. The compiler should + ;; produce the same code in any case, though currently it does not + ;; because it doesn't do escape analysis on the box created for the + ;; set!. + (maybe-verify program) + (set! program + (if (kw-arg-ref opts kw default) + (maybe-verify (pass program)) + program)) + ... + (verify program) + program)) + +;; Passes that are needed: +;; +;; * Abort contification: turning abort primcalls into continuation +;; calls, and eliding prompts if possible. +;; +;; * Loop peeling. Unrolls the first round through a loop if the +;; loop has effects that CSE can work on. Requires effects +;; analysis. When run before CSE, loop peeling is the equivalent +;; of loop-invariant code motion (LICM). +;; +(define-optimizer optimize-higher-order-cps + (split-rec #:split-rec? #t) + (eliminate-dead-code #:eliminate-dead-code? #t) + (prune-top-level-scopes #:prune-top-level-scopes? #t) + (simplify #:simplify? #t) + (contify #:contify? #t) + (inline-constructors #:inline-constructors? #t) + (specialize-primcalls #:specialize-primcalls? #t) + (elide-values #:elide-values? #t) + (prune-bailouts #:prune-bailouts? #t) + (eliminate-common-subexpressions #:cse? #t) + (type-fold #:type-fold? #t) + (resolve-self-references #:resolve-self-references? #t) + (eliminate-dead-code #:eliminate-dead-code? #t) + (simplify #:simplify? #t)) + +(define-optimizer optimize-first-order-cps + (eliminate-dead-code #:eliminate-dead-code? #t) + (simplify #:simplify? #t)) diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm new file mode 100644 index 000000000..7c10319e8 --- /dev/null +++ b/module/language/cps/prune-bailouts.scm @@ -0,0 +1,86 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass that prunes successors of expressions that bail out. +;;; +;;; Code: + +(define-module (language cps prune-bailouts) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (prune-bailouts)) + +(define (compute-tails conts) + "For each LABEL->CONT entry in the intmap CONTS, compute a +LABEL->TAIL-LABEL indicating the tail continuation of each expression's +containing function. In some cases TAIL-LABEL might not be available, +for example if there is a stale $kfun pointing at a body, or for +unreferenced terms. In that case TAIL-LABEL is either absent or #f." + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kfun src meta self tail clause) + (intset-fold (lambda (label out) + (intmap-add out label tail (lambda (old new) #f))) + (compute-function-body conts label) + out)) + (_ out))) + conts + empty-intmap)) + +(define (prune-bailout out tails k src exp) + (match (intmap-ref out k) + (($ $ktail) + (with-cps out #f)) + (_ + (match (intmap-ref tails k (lambda (_) #f)) + (#f + (with-cps out #f)) + (ktail + (with-cps out + (letv prim rest) + (letk kresult ($kargs ('rest) (rest) + ($continue ktail src ($values ())))) + (letk kreceive ($kreceive '() 'rest kresult)) + (build-term ($continue kreceive src ,exp)))))))) + +(define (prune-bailouts conts) + (let ((tails (compute-tails conts))) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs names vars + ($ $continue k src + (and exp ($ $primcall (or 'error 'scm-error 'throw))))) + (call-with-values (lambda () (prune-bailout out tails k src exp)) + (lambda (out term) + (if term + (let ((cont (build-cont ($kargs names vars ,term)))) + (intmap-replace! out label cont)) + out)))) + (_ out))) + conts + conts))))) diff --git a/module/language/cps/prune-top-level-scopes.scm b/module/language/cps/prune-top-level-scopes.scm new file mode 100644 index 000000000..1970d1bc3 --- /dev/null +++ b/module/language/cps/prune-top-level-scopes.scm @@ -0,0 +1,63 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A simple pass to prune unneeded top-level scopes. +;;; +;;; Code: + +(define-module (language cps prune-top-level-scopes) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (prune-top-level-scopes)) + +(define (compute-used-scopes conts constants) + (persistent-intset + (intmap-fold + (lambda (label cont used-scopes) + (match cont + (($ $kargs _ _ + ($ $continue k src + ($ $primcall 'cached-toplevel-box (scope name bound?)))) + (intset-add! used-scopes (intmap-ref constants scope))) + (_ + used-scopes))) + conts + empty-intset))) + +(define (prune-top-level-scopes conts) + (let* ((constants (compute-constant-values conts)) + (used-scopes (compute-used-scopes conts constants))) + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars + ($ $continue k src + ($ $primcall 'cache-current-module! + (module (? (lambda (scope) + (let ((val (intmap-ref constants scope))) + (not (intset-ref used-scopes val))))))))) + (build-cont ($kargs names vars + ($continue k src ($values ()))))) + (_ + cont))) + conts))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm new file mode 100644 index 000000000..014593a9a --- /dev/null +++ b/module/language/cps/reify-primitives.scm @@ -0,0 +1,167 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass to reify lone $prim's that were never folded into a +;;; $primcall, and $primcall's to primitives that don't have a +;;; corresponding VM op. +;;; +;;; Code: + +(define-module (language cps reify-primitives) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps primitives) + #:use-module (language cps intmap) + #:use-module (language bytecode) + #:export (reify-primitives)) + +(define (module-box cps src module name public? bound? val-proc) + (with-cps cps + (letv box) + (let$ body (val-proc box)) + (letk kbox ($kargs ('box) (box) ,body)) + ($ (with-cps-constants ((module module) + (name name) + (public? public?) + (bound? bound?)) + (build-term ($continue kbox src + ($primcall 'cached-module-box + (module name public? bound?)))))))) + +(define (primitive-module name) + (case name + ((bytevector? + bytevector-length + + bytevector-u8-ref bytevector-u8-set! + bytevector-s8-ref bytevector-s8-set! + + bytevector-u16-ref bytevector-u16-set! + bytevector-u16-native-ref bytevector-u16-native-set! + bytevector-s16-ref bytevector-s16-set! + bytevector-s16-native-ref bytevector-s16-native-set! + + bytevector-u32-ref bytevector-u32-set! + bytevector-u32-native-ref bytevector-u32-native-set! + bytevector-s32-ref bytevector-s32-set! + bytevector-s32-native-ref bytevector-s32-native-set! + + bytevector-u64-ref bytevector-u64-set! + bytevector-u64-native-ref bytevector-u64-native-set! + bytevector-s64-ref bytevector-s64-set! + bytevector-s64-native-ref bytevector-s64-native-set! + + bytevector-ieee-single-ref bytevector-ieee-single-set! + bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! + bytevector-ieee-double-ref bytevector-ieee-double-set! + bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) + '(rnrs bytevectors)) + ((class-of) '(oop goops)) + (else '(guile)))) + +(define (primitive-ref cps name k src) + (module-box cps src (primitive-module name) name #f #t + (lambda (cps box) + (with-cps cps + (build-term + ($continue k src ($primcall 'box-ref (box)))))))) + +(define (builtin-ref cps idx k src) + (with-cps cps + ($ (with-cps-constants ((idx idx)) + (build-term + ($continue k src ($primcall 'builtin-ref (idx)))))))) + +(define (reify-clause cps ktail) + (with-cps cps + (letv throw) + (let$ throw-body + (with-cps-constants ((wna 'wrong-number-of-args) + (false #f) + (str "Wrong number of arguments") + (eol '())) + (build-term + ($continue ktail #f + ($call throw (wna false str eol false)))))) + (letk kthrow ($kargs ('throw) (throw) ,throw-body)) + (let$ body (primitive-ref 'throw kthrow #f)) + (letk kbody ($kargs () () ,body)) + (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) + kclause)) + +;; A $kreceive continuation should have only one predecessor. +(define (uniquify-receive cps k) + (match (intmap-ref cps k) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (with-cps cps + (letk k ($kreceive req rest kargs)) + k)) + (_ + (with-cps cps k)))) + +(define (reify-primitives cps) + (define (visit-cont label cont cps) + (define (resolve-prim cps name k src) + (cond + ((builtin-name->index name) + => (lambda (idx) (builtin-ref cps idx k src))) + (else + (primitive-ref cps name k src)))) + (match cont + (($ $kfun src meta self tail #f) + (with-cps cps + (let$ clause (reify-clause tail)) + (setk label ($kfun src meta self tail clause)))) + (($ $kargs names vars ($ $continue k src ($ $prim name))) + (with-cps cps + (let$ k (uniquify-receive k)) + (let$ body (resolve-prim name k src)) + (setk label ($kargs names vars ,body)))) + (($ $kargs names vars + ($ $continue k src ($ $primcall 'call-thunk/no-inline (proc)))) + (with-cps cps + (setk label ($kargs names vars ($continue k src ($call proc ())))))) + (($ $kargs names vars ($ $continue k src ($ $primcall name args))) + (if (or (prim-instruction name) (branching-primitive? name)) + ;; Assume arities are correct. + cps + (with-cps cps + (letv proc) + (let$ k (uniquify-receive k)) + (letk kproc ($kargs ('proc) (proc) + ($continue k src ($call proc args)))) + (let$ body (resolve-prim name kproc src)) + (setk label ($kargs names vars ,body))))) + (($ $kargs names vars ($ $continue k src ($ $call proc args))) + (with-cps cps + (let$ k (uniquify-receive k)) + (setk label ($kargs names vars + ($continue k src ($call proc args)))))) + (($ $kargs names vars ($ $continue k src ($ $callk k* proc args))) + (with-cps cps + (let$ k (uniquify-receive k)) + (setk label ($kargs names vars + ($continue k src ($callk k* proc args)))))) + (_ cps))) + + (with-fresh-name-state cps + (persistent-intmap (intmap-fold visit-cont cps cps)))) diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm new file mode 100644 index 000000000..8bab8634d --- /dev/null +++ b/module/language/cps/renumber.scm @@ -0,0 +1,217 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass to renumber variables and continuation labels so that they +;;; are contiguous within each function and, in the case of labels, +;;; topologically sorted. +;;; +;;; Code: + +(define-module (language cps renumber) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:export (renumber)) + +(define* (compute-tail-path-lengths conts kfun preds) + (define (add-lengths labels lengths length) + (intset-fold (lambda (label lengths) + (intmap-add! lengths label length)) + labels + lengths)) + (define (compute-next labels lengths) + (intset-fold (lambda (label labels) + (fold1 (lambda (pred labels) + (if (intmap-ref lengths pred (lambda (_) #f)) + labels + (intset-add! labels pred))) + (intmap-ref preds label) + labels)) + labels + empty-intset)) + (define (visit labels lengths length) + (let ((lengths (add-lengths labels lengths length))) + (values (compute-next labels lengths) lengths (1+ length)))) + (match (intmap-ref conts kfun) + (($ $kfun src meta self tail clause) + (worklist-fold visit (intset-add empty-intset tail) empty-intmap 0)))) + +;; Topologically sort the continuation tree starting at k0, using +;; reverse post-order numbering. +(define (sort-labels-locally conts k0 path-lengths) + (define (visit-kf-first? kf kt) + ;; Visit the successor of a branch with the shortest path length to + ;; the tail first, so that if the branches are unsorted, the longer + ;; path length will appear first. This will move a loop exit out of + ;; a loop. + (let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f))) + (kt-len (intmap-ref path-lengths kt (lambda (_) #f)))) + (if kt-len + (or (not kf-len) (< kf-len kt-len) + ;; If the path lengths are the same, preserve original + ;; order to avoid squirreliness. + (and (= kf-len kt-len) (< kt kf))) + (if kf-len #f (< kt kf))))) + (let ((order '()) + (visited empty-intset)) + (let visit ((k k0) (order '()) (visited empty-intset)) + (define (visit2 k0 k1 order visited) + (let-values (((order visited) (visit k0 order visited))) + (visit k1 order visited))) + (if (intset-ref visited k) + (values order visited) + (let ((visited (intset-add visited k))) + (call-with-values + (lambda () + (match (intmap-ref conts k) + (($ $kargs names syms ($ $continue k src exp)) + (match exp + (($ $prompt escape? tag handler) + (visit2 k handler order visited)) + (($ $branch kt) + (if (visit-kf-first? k kt) + (visit2 k kt order visited) + (visit2 kt k order visited))) + (_ + (visit k order visited)))) + (($ $kreceive arity k) (visit k order visited)) + (($ $kclause arity kbody kalt) + (if kalt + (visit2 kalt kbody order visited) + (visit kbody order visited))) + (($ $kfun src meta self tail clause) + (if clause + (visit2 tail clause order visited) + (visit tail order visited))) + (($ $ktail) (values order visited)))) + (lambda (order visited) + ;; Add k to the reverse post-order. + (values (cons k order) visited)))))))) + +(define (compute-renaming conts kfun) + ;; labels := old -> new + ;; vars := old -> new + (define *next-label* -1) + (define *next-var* -1) + (define (rename-label label labels) + (set! *next-label* (1+ *next-label*)) + (intmap-add! labels label *next-label*)) + (define (rename-var sym vars) + (set! *next-var* (1+ *next-var*)) + (intmap-add! vars sym *next-var*)) + (define (rename label labels vars) + (values (rename-label label labels) + (match (intmap-ref conts label) + (($ $kargs names syms exp) + (fold1 rename-var syms vars)) + (($ $kfun src meta self tail clause) + (rename-var self vars)) + (_ vars)))) + (define (maybe-visit-fun kfun labels vars) + (if (intmap-ref labels kfun (lambda (_) #f)) + (values labels vars) + (visit-fun kfun labels vars))) + (define (visit-nested-funs k labels vars) + (match (intmap-ref conts k) + (($ $kargs names syms ($ $continue k src ($ $fun kfun))) + (visit-fun kfun labels vars)) + (($ $kargs names syms ($ $continue k src ($ $rec names* syms* + (($ $fun kfun) ...)))) + (fold2 visit-fun kfun labels vars)) + (($ $kargs names syms ($ $continue k src ($ $closure kfun nfree))) + ;; Closures with zero free vars get copy-propagated so it's + ;; possible to already have visited them. + (maybe-visit-fun kfun labels vars)) + (($ $kargs names syms ($ $continue k src ($ $callk kfun))) + ;; Well-known functions never have a $closure created for them + ;; and are only referenced by their $callk call sites. + (maybe-visit-fun kfun labels vars)) + (_ (values labels vars)))) + (define (visit-fun kfun labels vars) + (let* ((preds (compute-predecessors conts kfun)) + (path-lengths (compute-tail-path-lengths conts kfun preds)) + (order (sort-labels-locally conts kfun path-lengths))) + ;; First rename locally, then recurse on nested functions. + (let-values (((labels vars) (fold2 rename order labels vars))) + (fold2 visit-nested-funs order labels vars)))) + (let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap))) + (values (persistent-intmap labels) (persistent-intmap vars)))) + +(define* (renumber conts #:optional (kfun 0)) + (let-values (((label-map var-map) (compute-renaming conts kfun))) + (define (rename-label label) (intmap-ref label-map label)) + (define (rename-var var) (intmap-ref var-map var)) + (define (rename-exp exp) + (rewrite-exp exp + ((or ($ $const) ($ $prim)) ,exp) + (($ $closure k nfree) + ($closure (rename-label k) nfree)) + (($ $fun body) + ($fun (rename-label body))) + (($ $rec names vars funs) + ($rec names (map rename-var vars) (map rename-exp funs))) + (($ $values args) + ($values ,(map rename-var args))) + (($ $call proc args) + ($call (rename-var proc) ,(map rename-var args))) + (($ $callk k proc args) + ($callk (rename-label k) (rename-var proc) ,(map rename-var args))) + (($ $branch kt exp) + ($branch (rename-label kt) ,(rename-exp exp))) + (($ $primcall name args) + ($primcall name ,(map rename-var args))) + (($ $prompt escape? tag handler) + ($prompt escape? (rename-var tag) (rename-label handler))))) + (define (rename-arity arity) + (match arity + (($ $arity req opt rest () aok?) + arity) + (($ $arity req opt rest kw aok?) + (match kw + (() arity) + (((kw kw-name kw-var) ...) + (let ((kw (map list kw kw-name (map rename-var kw-var)))) + (make-$arity req opt rest kw aok?))))))) + (persistent-intmap + (intmap-fold + (lambda (old-k new-k out) + (intmap-add! + out + new-k + (rewrite-cont (intmap-ref conts old-k) + (($ $kargs names syms ($ $continue k src exp)) + ($kargs names (map rename-var syms) + ($continue (rename-label k) src ,(rename-exp exp)))) + (($ $kreceive ($ $arity req () rest () #f) k) + ($kreceive req rest (rename-label k))) + (($ $ktail) + ($ktail)) + (($ $kfun src meta self tail clause) + ($kfun src meta (rename-var self) (rename-label tail) + (and clause (rename-label clause)))) + (($ $kclause arity body alternate) + ($kclause ,(rename-arity arity) (rename-label body) + (and alternate (rename-label alternate))))))) + label-map + empty-intmap)))) diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm new file mode 100644 index 000000000..cbdaaa107 --- /dev/null +++ b/module/language/cps/self-references.scm @@ -0,0 +1,79 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass that replaces free references to recursive functions with +;;; bound references. +;;; +;;; Code: + +(define-module (language cps self-references) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (resolve-self-references)) + +(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap)) + (define (subst var) + (intmap-ref env var (lambda (var) var))) + + (define (rename-exp label cps names vars k src exp) + (let ((exp (rewrite-exp exp + ((or ($ $const) ($ $prim)) ,exp) + (($ $call proc args) + ($call (subst proc) ,(map subst args))) + (($ $callk k proc args) + ($callk k (subst proc) ,(map subst args))) + (($ $primcall name args) + ($primcall name ,(map subst args))) + (($ $branch k ($ $values (arg))) + ($branch k ($values ((subst arg))))) + (($ $branch k ($ $primcall name args)) + ($branch k ($primcall name ,(map subst args)))) + (($ $values args) + ($values ,(map subst args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler))))) + (intmap-replace! cps label + (build-cont + ($kargs names vars ($continue k src ,exp)))))) + + (define (visit-exp cps label names vars k src exp) + (match exp + (($ $fun label) + (resolve-self-references cps label env)) + (($ $rec names vars (($ $fun labels) ...)) + (fold (lambda (label var cps) + (match (intmap-ref cps label) + (($ $kfun src meta self) + (resolve-self-references cps label + (intmap-add env var self))))) + cps labels vars)) + (_ (rename-exp label cps names vars k src exp)))) + + (intset-fold (lambda (label cps) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-exp cps label names vars k src exp)) + (_ cps))) + (compute-function-body cps label) + cps)) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm new file mode 100644 index 000000000..a53bdbff6 --- /dev/null +++ b/module/language/cps/simplify.scm @@ -0,0 +1,267 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; The fundamental lambda calculus reductions, like beta and eta +;;; reduction and so on. Pretty lame currently. +;;; +;;; Code: + +(define-module (language cps simplify) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:export (simplify)) + +(define (intset-maybe-add! set k add?) + (if add? (intset-add! set k) set)) + +(define (intset-add* set k*) + (let lp ((set set) (k* k*)) + (match k* + ((k . k*) (lp (intset-add set k) k*)) + (() set)))) + +(define (intset-add*! set k*) + (fold1 (lambda (k set) (intset-add! set k)) k* set)) + +(define (fold2* f l1 l2 seed) + (let lp ((l1 l1) (l2 l2) (seed seed)) + (match (cons l1 l2) + ((() . ()) seed) + (((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed)))))) + +(define (transform-conts f conts) + (persistent-intmap + (intmap-fold (lambda (k v out) + (let ((v* (f k v))) + (cond + ((equal? v v*) out) + (v* (intmap-replace! out k v*)) + (else (intmap-remove out k))))) + conts + conts))) + +(define (compute-singly-referenced-vars conts) + (define (visit label cont single multiple) + (define (add-ref var single multiple) + (if (intset-ref single var) + (values single (intset-add! multiple var)) + (values (intset-add! single var) multiple))) + (define (ref var) (add-ref var single multiple)) + (define (ref* vars) (fold2 add-ref vars single multiple)) + (match cont + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) + (values single multiple)) + (($ $call proc args) + (ref* (cons proc args))) + (($ $callk k proc args) + (ref* (cons proc args))) + (($ $primcall name args) + (ref* args)) + (($ $values args) + (ref* args)) + (($ $branch kt ($ $values (var))) + (ref var)) + (($ $branch kt ($ $primcall name args)) + (ref* args)) + (($ $prompt escape? tag handler) + (ref tag)))) + (_ + (values single multiple)))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intmap-fold visit conts single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +;;; Continuations whose values are simply forwarded to another and not +;;; used in any other way may be elided via eta reduction over labels. +;;; +;;; There is an exception however: we must exclude strongly-connected +;;; components (SCCs). The only kind of SCC we can build out of $values +;;; expressions are infinite loops. +;;; +;;; Condition A below excludes single-node SCCs. Single-node SCCs +;;; cannot be reduced. +;;; +;;; Condition B conservatively excludes edges to labels already marked +;;; as candidates. This prevents back-edges and so breaks SCCs, and is +;;; optimal if labels are sorted. If the labels aren't sorted it's +;;; suboptimal but cheap. +(define (compute-eta-reductions conts kfun) + (let ((singly-used (compute-singly-referenced-vars conts))) + (define (singly-used? vars) + (match vars + (() #t) + ((var . vars) + (and (intset-ref singly-used var) (singly-used? vars))))) + (define (visit-fun kfun body eta) + (define (visit-cont label eta) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src ($ $values vars))) + (intset-maybe-add! eta label + (match (intmap-ref conts k) + (($ $kargs) + (and (not (eqv? label k)) ; A + (not (intset-ref eta label)) ; B + (singly-used? vars))) + (_ #f)))) + (_ + eta))) + (intset-fold visit-cont body eta)) + (persistent-intset + (intmap-fold visit-fun + (compute-reachable-functions conts kfun) + empty-intset)))) + +(define (eta-reduce conts kfun) + (let ((label-set (compute-eta-reductions conts kfun))) + ;; Replace any continuation to a label in LABEL-SET with the label's + ;; continuation. The label will denote a $kargs continuation, so + ;; only terms that can continue to $kargs need be taken into + ;; account. + (define (subst label) + (if (intset-ref label-set label) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue k)) (subst k))) + label)) + (transform-conts + (lambda (label cont) + (and (not (intset-ref label-set label)) + (rewrite-cont cont + (($ $kargs names syms ($ $continue kf src ($ $branch kt exp))) + ($kargs names syms + ($continue (subst kf) src ($branch (subst kt) ,exp)))) + (($ $kargs names syms ($ $continue k src exp)) + ($kargs names syms + ($continue (subst k) src ,exp))) + (($ $kreceive ($ $arity req () rest () #f) k) + ($kreceive req rest (subst k))) + (($ $kclause arity body alt) + ($kclause ,arity (subst body) alt)) + (_ ,cont)))) + conts))) + +(define (compute-singly-referenced-labels conts body) + (define (add-ref label single multiple) + (define (ref k single multiple) + (if (intset-ref single k) + (values single (intset-add! multiple k)) + (values (intset-add! single k) multiple))) + (define (ref0) (values single multiple)) + (define (ref1 k) (ref k single multiple)) + (define (ref2 k k*) + (if k* + (let-values (((single multiple) (ref k single multiple))) + (ref k* single multiple)) + (ref1 k))) + (match (intmap-ref conts label) + (($ $kreceive arity k) (ref1 k)) + (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) + (($ $ktail) (ref0)) + (($ $kclause arity kbody kalt) (ref2 kbody kalt)) + (($ $kargs names syms ($ $continue k src exp)) + (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intset-fold add-ref body single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +(define (compute-beta-reductions conts kfun) + (define (visit-fun kfun body beta) + (let ((single (compute-singly-referenced-labels conts body))) + (define (visit-cont label beta) + (match (intmap-ref conts label) + ;; A continuation's body can be inlined in place of a $values + ;; expression if the continuation is a $kargs. It should only + ;; be inlined if it is used only once, and not recursively. + (($ $kargs _ _ ($ $continue k src ($ $values))) + (intset-maybe-add! beta label + (and (intset-ref single k) + (match (intmap-ref conts k) + (($ $kargs) #t) + (_ #f))))) + (_ + beta))) + (intset-fold visit-cont body beta))) + (persistent-intset + (intmap-fold visit-fun + (compute-reachable-functions conts kfun) + empty-intset))) + +(define (compute-beta-var-substitutions conts label-set) + (define (add-var-substs label var-map) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue k _ ($ $values vals))) + (match (intmap-ref conts k) + (($ $kargs names vars) + (fold2* (lambda (var val var-map) + (intmap-add! var-map var val)) + vars vals var-map)))))) + (intset-fold add-var-substs label-set empty-intmap)) + +(define (beta-reduce conts kfun) + (let* ((label-set (compute-beta-reductions conts kfun)) + (var-map (compute-beta-var-substitutions conts label-set))) + (define (subst var) + (match (intmap-ref var-map var (lambda (_) #f)) + (#f var) + (val (subst val)))) + (define (transform-exp label k src exp) + (if (intset-ref label-set label) + (match (intmap-ref conts k) + (($ $kargs _ _ ($ $continue k* src* exp*)) + (transform-exp k k* src* exp*))) + (build-term + ($continue k src + ,(rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) + ,exp) + (($ $call proc args) + ($call (subst proc) ,(map subst args))) + (($ $callk k proc args) + ($callk k (subst proc) ,(map subst args))) + (($ $primcall name args) + ($primcall name ,(map subst args))) + (($ $values args) + ($values ,(map subst args))) + (($ $branch kt ($ $values (var))) + ($branch kt ($values ((subst var))))) + (($ $branch kt ($ $primcall name args)) + ($branch kt ($primcall name ,(map subst args)))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler))))))) + (transform-conts + (lambda (label cont) + (match cont + (($ $kargs names syms ($ $continue k src exp)) + (build-cont + ($kargs names syms ,(transform-exp label k src exp)))) + (_ cont))) + conts))) + +(define (simplify conts) + (eta-reduce (beta-reduce conts 0) 0)) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm new file mode 100644 index 000000000..74e71c487 --- /dev/null +++ b/module/language/cps/slot-allocation.scm @@ -0,0 +1,995 @@ +;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A module to assign stack slots to variables in a CPS term. +;;; +;;; Code: + +(define-module (language cps slot-allocation) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (allocate-slots + lookup-slot + lookup-maybe-slot + lookup-constant-value + lookup-maybe-constant-value + lookup-nlocals + lookup-call-proc-slot + lookup-parallel-moves + lookup-dead-slot-map)) + +(define-record-type $allocation + (make-allocation slots constant-values call-allocs shuffles frame-sizes) + allocation? + + ;; A map of VAR to slot allocation. A slot allocation is an integer, + ;; if the variable has been assigned a slot. + ;; + (slots allocation-slots) + + ;; A map of VAR to constant value, for variables with constant values. + ;; + (constant-values allocation-constant-values) + + ;; A map of LABEL to /call allocs/, for expressions that continue to + ;; $kreceive continuations: non-tail calls and $prompt expressions. + ;; + ;; A call alloc contains two pieces of information: the call's /proc + ;; slot/ and a /dead slot map/. The proc slot indicates the slot of a + ;; procedure in a procedure call, or where the procedure would be in a + ;; multiple-value return. + ;; + ;; The dead slot map indicates, what slots should be ignored by GC + ;; when marking the frame. A dead slot map is a bitfield, as an + ;; integer. + ;; + (call-allocs allocation-call-allocs) + + ;; A map of LABEL to /parallel moves/. Parallel moves shuffle locals + ;; into position for a $call, $callk, or $values, or shuffle returned + ;; values back into place in a $kreceive. + ;; + ;; A set of moves is expressed as an ordered list of (SRC . DST) + ;; moves, where SRC and DST are slots. This may involve a temporary + ;; variable. + ;; + (shuffles allocation-shuffles) + + ;; The number of locals for a $kclause. + ;; + (frame-sizes allocation-frame-sizes)) + +(define-record-type $call-alloc + (make-call-alloc proc-slot dead-slot-map) + call-alloc? + (proc-slot call-alloc-proc-slot) + (dead-slot-map call-alloc-dead-slot-map)) + +(define (lookup-maybe-slot var allocation) + (intmap-ref (allocation-slots allocation) var (lambda (_) #f))) + +(define (lookup-slot var allocation) + (intmap-ref (allocation-slots allocation) var)) + +(define *absent* (list 'absent)) + +(define (lookup-constant-value var allocation) + (let ((value (intmap-ref (allocation-constant-values allocation) var + (lambda (_) *absent*)))) + (when (eq? value *absent*) + (error "Variable does not have constant value" var)) + value)) + +(define (lookup-maybe-constant-value var allocation) + (let ((value (intmap-ref (allocation-constant-values allocation) var + (lambda (_) *absent*)))) + (if (eq? value *absent*) + (values #f #f) + (values #t value)))) + +(define (lookup-call-alloc k allocation) + (intmap-ref (allocation-call-allocs allocation) k)) + +(define (lookup-call-proc-slot k allocation) + (or (call-alloc-proc-slot (lookup-call-alloc k allocation)) + (error "Call has no proc slot" k))) + +(define (lookup-parallel-moves k allocation) + (intmap-ref (allocation-shuffles allocation) k)) + +(define (lookup-dead-slot-map k allocation) + (or (call-alloc-dead-slot-map (lookup-call-alloc k allocation)) + (error "Call has no dead slot map" k))) + +(define (lookup-nlocals k allocation) + (intmap-ref (allocation-frame-sizes allocation) k)) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define (solve-flow-equations succs in out kill gen subtract add meet) + "Find a fixed point for flow equations for SUCCS, where IN and OUT are +the initial conditions as intmaps with one key for every node in SUCCS. +KILL and GEN are intmaps indicating the state that is killed or defined +at every node, and SUBTRACT, ADD, and MEET operates on that state." + (define (visit label in out) + (let* ((in-1 (intmap-ref in label)) + (kill-1 (intmap-ref kill label)) + (gen-1 (intmap-ref gen label)) + (out-1 (intmap-ref out label)) + (out-1* (add (subtract in-1 kill-1) gen-1))) + (if (eq? out-1 out-1*) + (values empty-intset in out) + (let ((out (intmap-replace! out label out-1*))) + (call-with-values + (lambda () + (intset-fold (lambda (succ in changed) + (let* ((in-1 (intmap-ref in succ)) + (in-1* (meet in-1 out-1*))) + (if (eq? in-1 in-1*) + (values in changed) + (values (intmap-replace! in succ in-1*) + (intset-add changed succ))))) + (intmap-ref succs label) in empty-intset)) + (lambda (in changed) + (values changed in out))))))) + + (let run ((worklist (intmap-keys succs)) (in in) (out out)) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist popped) + (if popped + (call-with-values (lambda () (visit popped in out)) + (lambda (changed in out) + (run (intset-union worklist changed) in out))) + (values (persistent-intmap in) + (persistent-intmap out))))))) + +(define-syntax-rule (persistent-intmap2 exp) + (call-with-values (lambda () exp) + (lambda (a b) + (values (persistent-intmap a) (persistent-intmap b))))) + +(define (compute-defs-and-uses cps) + "Return two LABEL->VAR... maps indicating values defined at and used +by a label, respectively." + (define (vars->intset vars) + (fold (lambda (var set) (intset-add set var)) empty-intset vars)) + (persistent-intmap2 + (intmap-fold + (lambda (label cont defs uses) + (define (get-defs k) + (match (intmap-ref cps k) + (($ $kargs names vars) (vars->intset vars)) + (_ empty-intset))) + (define (return d u) + (values (intmap-add! defs label d) + (intmap-add! uses label u))) + (match cont + (($ $kfun src meta self) + (return (intset self) empty-intset)) + (($ $kargs _ _ ($ $continue k src exp)) + (match exp + ((or ($ $const) ($ $closure)) + (return (get-defs k) empty-intset)) + (($ $call proc args) + (return (get-defs k) (intset-add (vars->intset args) proc))) + (($ $callk _ proc args) + (return (get-defs k) (intset-add (vars->intset args) proc))) + (($ $primcall name args) + (return (get-defs k) (vars->intset args))) + (($ $branch kt ($ $primcall name args)) + (return empty-intset (vars->intset args))) + (($ $branch kt ($ $values args)) + (return empty-intset (vars->intset args))) + (($ $values args) + (return (get-defs k) (vars->intset args))) + (($ $prompt escape? tag handler) + (return empty-intset (intset tag))))) + (($ $kclause arity body alt) + (return (get-defs body) empty-intset)) + (($ $kreceive arity kargs) + (return (get-defs kargs) empty-intset)) + (($ $ktail) + (return empty-intset empty-intset)))) + cps + empty-intmap + empty-intmap))) + +(define (compute-reverse-control-flow-order preds) + "Return a LABEL->ORDER bijection where ORDER is a contiguous set of +integers starting from 0 and incrementing in sort order." + ;; This is more involved than forward control flow because not all + ;; live labels are reachable from the tail. + (persistent-intmap + (fold2 (lambda (component order n) + (intset-fold (lambda (label order n) + (values (intmap-add! order label n) + (1+ n))) + component order n)) + (reverse (compute-sorted-strongly-connected-components preds)) + empty-intmap 0))) + +(define* (add-prompt-control-flow-edges conts succs #:key complete?) + "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL + +LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each +body continuation in the prompt." + (define (intset-filter pred set) + (intset-fold (lambda (i set) + (if (pred i) set (intset-remove set i))) + set + set)) + (define (intset-any pred set) + (intset-fold (lambda (i res) + (if (or res (pred i)) #t res)) + set + #f)) + (define (visit-prompt label handler succs) + ;; FIXME: It isn't correct to use all continuations reachable from + ;; the prompt, because that includes continuations outside the + ;; prompt body. This point is moot if the handler's control flow + ;; joins with the the body, as is usually but not always the case. + ;; + ;; One counter-example is when the handler contifies an infinite + ;; loop; in that case we compute a too-large prompt body. This + ;; error is currently innocuous, but we should fix it at some point. + ;; + ;; The fix is to end the body at the corresponding "pop" primcall, + ;; if any. + (let ((body (intset-subtract (compute-function-body conts label) + (compute-function-body conts handler)))) + (define (out-or-back-edge? label) + ;; Most uses of visit-prompt-control-flow don't need every body + ;; continuation, and would be happy getting called only for + ;; continuations that postdominate the rest of the body. Unless + ;; you pass #:complete? #t, we only invoke F on continuations + ;; that can leave the body, or on back-edges in loops. + ;; + ;; You would think that looking for the final "pop" primcall + ;; would be sufficient, but that is incorrect; it's possible for + ;; a loop in the prompt body to be contified, and that loop need + ;; not continue to the pop if it never terminates. The pop could + ;; even be removed by DCE, in that case. + (intset-any (lambda (succ) + (or (not (intset-ref body succ)) + (<= succ label))) + (intmap-ref succs label))) + (intset-fold (lambda (pred succs) + (intmap-replace succs pred handler intset-add)) + (if complete? body (intset-filter out-or-back-edge? body)) + succs))) + (intmap-fold + (lambda (label cont succs) + (match cont + (($ $kargs _ _ + ($ $continue _ _ ($ $prompt escape? tag handler))) + (visit-prompt label handler succs)) + (_ succs))) + conts + succs)) + +(define (rename-keys map old->new) + (persistent-intmap + (intmap-fold (lambda (k v out) + (intmap-add! out (intmap-ref old->new k) v)) + map + empty-intmap))) + +(define (rename-intset set old->new) + (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old))) + set empty-intset)) + +(define (rename-graph graph old->new) + (persistent-intmap + (intmap-fold (lambda (pred succs out) + (intmap-add! out + (intmap-ref old->new pred) + (rename-intset succs old->new))) + graph + empty-intmap))) + +(define (compute-live-variables cps defs uses) + "Compute and return two values mapping LABEL->VAR..., where VAR... are +the definitions that are live before and after LABEL, as intsets." + (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps))) + (preds (invert-graph succs)) + (old->new (compute-reverse-control-flow-order preds))) + (call-with-values + (lambda () + (let ((init (rename-keys + (intmap-map (lambda (k v) empty-intset) preds) + old->new))) + (solve-flow-equations (rename-graph preds old->new) + init init + (rename-keys defs old->new) + (rename-keys uses old->new) + intset-subtract intset-union intset-union))) + (lambda (in out) + ;; As a reverse control-flow problem, the values flowing into a + ;; node are actually the live values after the node executes. + ;; Funny, innit? So we return them in the reverse order. + (let ((new->old (invert-bijection old->new))) + (values (rename-keys out new->old) + (rename-keys in new->old))))))) + +(define (compute-needs-slot cps defs uses) + (define (get-defs k) (intmap-ref defs k)) + (define (get-uses label) (intmap-ref uses label)) + (intmap-fold + (lambda (label cont needs-slot) + (intset-union + needs-slot + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (let ((defs (get-defs label))) + (define (defs+* uses) + (intset-union defs uses)) + (define (defs+ use) + (intset-add defs use)) + (match exp + (($ $const) + empty-intset) + (($ $primcall 'free-ref (closure slot)) + (defs+ closure)) + (($ $primcall 'free-set! (closure slot value)) + (defs+* (intset closure value))) + (($ $primcall 'cache-current-module! (mod . _)) + (defs+ mod)) + (($ $primcall 'cached-toplevel-box _) + defs) + (($ $primcall 'cached-module-box _) + defs) + (($ $primcall 'resolve (name bound?)) + (defs+ name)) + (($ $primcall 'make-vector/immediate (len init)) + (defs+ init)) + (($ $primcall 'vector-ref/immediate (v i)) + (defs+ v)) + (($ $primcall 'vector-set!/immediate (v i x)) + (defs+* (intset v x))) + (($ $primcall 'allocate-struct/immediate (vtable nfields)) + (defs+ vtable)) + (($ $primcall 'struct-ref/immediate (s n)) + (defs+ s)) + (($ $primcall 'struct-set!/immediate (s n x)) + (defs+* (intset s x))) + (($ $primcall 'builtin-ref (idx)) + defs) + (_ + (defs+* (get-uses label)))))) + (($ $kreceive arity k) + ;; Only allocate results of function calls to slots if they are + ;; used. + empty-intset) + (($ $kclause arity body alternate) + (get-defs label)) + (($ $kfun src meta self) + (intset self)) + (($ $ktail) + empty-intset)))) + cps + empty-intset)) + +(define (compute-lazy-vars cps live-in live-out defs needs-slot) + "Compute and return a set of vars whose allocation can be delayed +until their use is seen. These are \"lazy\" vars. A var is lazy if its +uses are calls, it is always dead after the calls, and if the uses flow +to the definition. A flow continues across a node iff the node kills no +values that need slots, and defines only lazy vars. Calls also kill +flows; there's no sense in trying to juggle a pending frame while there +is an active call." + (define (list->intset list) + (persistent-intset + (fold (lambda (i set) (intset-add! set i)) empty-intset list))) + + (let* ((succs (compute-successors cps)) + (gens (intmap-map + (lambda (label cont) + (match cont + (($ $kargs _ _ ($ $continue _ _ ($ $call proc args))) + (intset-subtract (intset-add (list->intset args) proc) + (intmap-ref live-out label))) + (($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args))) + (intset-subtract (intset-add (list->intset args) proc) + (intmap-ref live-out label))) + (_ #f))) + cps)) + (kills (intmap-map + (lambda (label in) + (let* ((out (intmap-ref live-out label)) + (killed (intset-subtract in out)) + (killed-slots (intset-intersect killed needs-slot))) + (and (eq? killed-slots empty-intset) + ;; Kill output variables that need slots. + (intset-intersect (intmap-ref defs label) + needs-slot)))) + live-in)) + (preds (invert-graph succs)) + (old->new (compute-reverse-control-flow-order preds))) + (define (subtract lazy kill) + (cond + ((eq? lazy empty-intset) + lazy) + ((not kill) + empty-intset) + ((and lazy (eq? empty-intset (intset-subtract kill lazy))) + (intset-subtract lazy kill)) + (else + empty-intset))) + (define (add live gen) (or gen live)) + (define (meet in out) + ;; Initial in is #f. + (if in (intset-intersect in out) out)) + (call-with-values + (lambda () + (let ((succs (rename-graph preds old->new)) + (in (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) + (out (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) + ;(out (rename-keys gens old->new)) + (kills (rename-keys kills old->new)) + (gens (rename-keys gens old->new))) + (solve-flow-equations succs in out kills gens subtract add meet))) + (lambda (in out) + ;; A variable is lazy if its uses reach its definition. + (intmap-fold (lambda (label out lazy) + (match (intmap-ref cps label) + (($ $kargs names vars) + (let ((defs (list->intset vars))) + (intset-union lazy (intset-intersect out defs)))) + (_ lazy))) + (rename-keys out (invert-bijection old->new)) + empty-intset))))) + +(define (find-first-zero n) + ;; Naive implementation. + (let lp ((slot 0)) + (if (logbit? slot n) + (lp (1+ slot)) + slot))) + +(define (find-first-trailing-zero n) + (let lp ((slot (let lp ((count 2)) + (if (< n (ash 1 (1- count))) + count + ;; Grow upper bound slower than factor 2 to avoid + ;; needless bignum allocation on 32-bit systems + ;; when there are more than 16 locals. + (lp (+ count (ash count -1))))))) + (if (or (zero? slot) (logbit? (1- slot) n)) + slot + (lp (1- slot))))) + +(define (integers from count) + (if (zero? count) + '() + (cons from (integers (1+ from) (1- count))))) + +(define (solve-parallel-move src dst tmp) + "Solve the parallel move problem between src and dst slot lists, which +are comparable with eqv?. A tmp slot may be used." + + ;; This algorithm is taken from: "Tilting at windmills with Coq: + ;; formal verification of a compilation algorithm for parallel moves" + ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy + ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf> + + (define (split-move moves reg) + (let loop ((revhead '()) (tail moves)) + (match tail + (((and s+d (s . d)) . rest) + (if (eqv? s reg) + (cons d (append-reverse revhead rest)) + (loop (cons s+d revhead) rest))) + (_ #f)))) + + (define (replace-last-source reg moves) + (match moves + ((moves ... (s . d)) + (append moves (list (cons reg d)))))) + + (let loop ((to-move (map cons src dst)) + (being-moved '()) + (moved '()) + (last-source #f)) + ;; 'last-source' should always be equivalent to: + ;; (and (pair? being-moved) (car (last being-moved))) + (match being-moved + (() (match to-move + (() (reverse moved)) + (((and s+d (s . d)) . t1) + (if (or (eqv? s d) ; idempotent + (not s)) ; src is a constant and can be loaded directly + (loop t1 '() moved #f) + (loop t1 (list s+d) moved s))))) + (((and s+d (s . d)) . b) + (match (split-move to-move d) + ((r . t1) (loop t1 (acons d r being-moved) moved last-source)) + (#f (match b + (() (loop to-move '() (cons s+d moved) #f)) + (_ (if (eqv? d last-source) + (loop to-move + (replace-last-source tmp b) + (cons s+d (acons d tmp moved)) + tmp) + (loop to-move b (cons s+d moved) last-source)))))))))) + +(define (compute-shuffles cps slots call-allocs live-in) + (define (add-live-slot slot live-slots) + (logior live-slots (ash 1 slot))) + + (define (get-cont label) + (intmap-ref cps label)) + + (define (get-slot var) + (intmap-ref slots var (lambda (_) #f))) + + (define (get-slots vars) + (let lp ((vars vars)) + (match vars + ((var . vars) (cons (get-slot var) (lp vars))) + (_ '())))) + + (define (get-proc-slot label) + (call-alloc-proc-slot (intmap-ref call-allocs label))) + + (define (compute-live-slots label) + (intset-fold (lambda (var live) + (match (get-slot var) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-in label) + 0)) + + ;; Although some parallel moves may proceed without a temporary slot, + ;; in general one is needed. That temporary slot must not be part of + ;; the source or destination sets, and that slot should not correspond + ;; to a live variable. Usually the source and destination sets are a + ;; subset of the union of the live sets before and after the move. + ;; However for stack slots that don't have names -- those slots that + ;; correspond to function arguments or to function return values -- it + ;; could be that they are out of the computed live set. In that case + ;; they need to be adjoined to the live set, used when choosing a + ;; temporary slot. + ;; + ;; Note that although we reserve slots 253-255 for shuffling operands + ;; that address less than the full 24-bit range of locals, that + ;; reservation doesn't apply here, because this temporary itself is + ;; used while doing parallel assignment via "mov", and "mov" does not + ;; need shuffling. + (define (compute-tmp-slot live stack-slots) + (find-first-zero (fold add-live-slot live stack-slots))) + + (define (parallel-move src-slots dst-slots tmp-slot) + (solve-parallel-move src-slots dst-slots tmp-slot)) + + (define (compute-receive-shuffles label proc-slot) + (match (get-cont label) + (($ $kreceive arity kargs) + (let* ((results (match (get-cont kargs) + (($ $kargs names vars) vars))) + (value-slots (integers (1+ proc-slot) (length results))) + (result-slots (get-slots results)) + ;; Filter out unused results. + (value-slots (filter-map (lambda (val result) (and result val)) + value-slots result-slots)) + (result-slots (filter (lambda (x) x) result-slots)) + (live (compute-live-slots kargs))) + (parallel-move value-slots + result-slots + (compute-tmp-slot live value-slots)))))) + + (define (add-call-shuffles label k args shuffles) + (match (get-cont k) + (($ $ktail) + (let* ((live (compute-live-slots label)) + (tail-slots (integers 0 (length args))) + (moves (parallel-move (get-slots args) + tail-slots + (compute-tmp-slot live tail-slots)))) + (intmap-add! shuffles label moves))) + (($ $kreceive) + (let* ((live (compute-live-slots label)) + (proc-slot (get-proc-slot label)) + (call-slots (integers proc-slot (length args))) + (arg-moves (parallel-move (get-slots args) + call-slots + (compute-tmp-slot live call-slots)))) + (intmap-add! (intmap-add! shuffles label arg-moves) + k (compute-receive-shuffles k proc-slot)))))) + + (define (add-values-shuffles label k args shuffles) + (match (get-cont k) + (($ $ktail) + (let* ((live (compute-live-slots label)) + (src-slots (get-slots args)) + (dst-slots (integers 1 (length args))) + (moves (parallel-move src-slots dst-slots + (compute-tmp-slot live dst-slots)))) + (intmap-add! shuffles label moves))) + (($ $kargs _ dst-vars) + (let* ((live (logior (compute-live-slots label) + (compute-live-slots k))) + (src-slots (get-slots args)) + (dst-slots (get-slots dst-vars)) + (moves (parallel-move src-slots dst-slots + (compute-tmp-slot live '())))) + (intmap-add! shuffles label moves))))) + + (define (add-prompt-shuffles label k handler shuffles) + (intmap-add! shuffles handler + (compute-receive-shuffles handler (get-proc-slot label)))) + + (define (compute-shuffles label cont shuffles) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $call proc args) + (add-call-shuffles label k (cons proc args) shuffles)) + (($ $callk _ proc args) + (add-call-shuffles label k (cons proc args) shuffles)) + (($ $values args) + (add-values-shuffles label k args shuffles)) + (($ $prompt escape? tag handler) + (add-prompt-shuffles label k handler shuffles)) + (_ shuffles))) + (_ shuffles))) + + (persistent-intmap + (intmap-fold compute-shuffles cps empty-intmap))) + +(define (compute-frame-sizes cps slots call-allocs shuffles) + ;; Minimum frame has one slot: the closure. + (define minimum-frame-size 1) + (define (get-shuffles label) + (intmap-ref shuffles label)) + (define (get-proc-slot label) + (match (intmap-ref call-allocs label (lambda (_) #f)) + (#f 0) ;; Tail call. + (($ $call-alloc proc-slot) proc-slot))) + (define (max-size var size) + (match (intmap-ref slots var (lambda (_) #f)) + (#f size) + (slot (max size (1+ slot))))) + (define (max-size* vars size) + (fold max-size size vars)) + (define (shuffle-size moves size) + (match moves + (() size) + (((src . dst) . moves) + (shuffle-size moves (max size (1+ src) (1+ dst)))))) + (define (call-size label nargs size) + (shuffle-size (get-shuffles label) + (max (+ (get-proc-slot label) nargs) size))) + (define (measure-cont label cont frame-sizes clause size) + (match cont + (($ $kfun) + (values #f #f #f)) + (($ $kclause) + (let ((frame-sizes (if clause + (intmap-add! frame-sizes clause size) + empty-intmap))) + (values frame-sizes label minimum-frame-size))) + (($ $kargs names vars ($ $continue k src exp)) + (values frame-sizes clause + (let ((size (max-size* vars size))) + (match exp + (($ $call proc args) + (call-size label (1+ (length args)) size)) + (($ $callk _ proc args) + (call-size label (1+ (length args)) size)) + (($ $values args) + (shuffle-size (get-shuffles label) size)) + (_ size))))) + (($ $kreceive) + (values frame-sizes clause + (shuffle-size (get-shuffles label) size))) + (($ $ktail) + (values (intmap-add! frame-sizes clause size) #f #f)))) + + (persistent-intmap (intmap-fold measure-cont cps #f #f #f))) + +(define (allocate-args cps) + (intmap-fold (lambda (label cont slots) + (match cont + (($ $kfun src meta self) + (intmap-add! slots self 0)) + (($ $kclause arity body alt) + (match (intmap-ref cps body) + (($ $kargs names vars) + (let lp ((vars vars) (slots slots) (n 1)) + (match vars + (() slots) + ((var . vars) + (let ((n (if (<= 253 n 255) 256 n))) + (lp vars + (intmap-add! slots var n) + (1+ n))))))))) + (_ slots))) + cps empty-intmap)) + +(define-inlinable (add-live-slot slot live-slots) + (logior live-slots (ash 1 slot))) + +(define-inlinable (kill-dead-slot slot live-slots) + (logand live-slots (lognot (ash 1 slot)))) + +(define-inlinable (compute-slot live-slots hint) + ;; Slots 253-255 are reserved for shuffling; see comments in + ;; assembler.scm. + (if (and hint (not (logbit? hint live-slots)) + (or (< hint 253) (> hint 255))) + hint + (let ((slot (find-first-zero live-slots))) + (if (or (< slot 253) (> slot 255)) + slot + (+ 256 (find-first-zero (ash live-slots -256))))))) + +(define (allocate-lazy-vars cps slots call-allocs live-in lazy) + (define (compute-live-slots slots label) + (intset-fold (lambda (var live) + (match (intmap-ref slots var (lambda (_) #f)) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-in label) + 0)) + + (define (allocate var hint slots live) + (match (and hint (intmap-ref slots var (lambda (_) #f))) + (#f (if (intset-ref lazy var) + (let ((slot (compute-slot live hint))) + (values (intmap-add! slots var slot) + (add-live-slot slot live))) + (values slots live))) + (slot (values slots (add-live-slot slot live))))) + + (define (allocate* vars hints slots live) + (match (vector vars hints) + (#(() ()) slots) + (#((var . vars) (hint . hints)) + (let-values (((slots live) (allocate var hint slots live))) + (allocate* vars hints slots live))))) + + (define (get-proc-slot label) + (match (intmap-ref call-allocs label (lambda (_) #f)) + (#f 0) + (call (call-alloc-proc-slot call)))) + + (define (allocate-call label args slots) + (allocate* args (integers (get-proc-slot label) (length args)) + slots (compute-live-slots slots label))) + + (define (allocate-values label k args slots) + (match (intmap-ref cps k) + (($ $ktail) + (allocate* args (integers 1 (length args)) + slots (compute-live-slots slots label))) + (($ $kargs names vars) + (allocate* args + (map (cut intmap-ref slots <> (lambda (_) #f)) vars) + slots (compute-live-slots slots label))))) + + (define (allocate-lazy label cont slots) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $call proc args) + (allocate-call label (cons proc args) slots)) + (($ $callk _ proc args) + (allocate-call label (cons proc args) slots)) + (($ $values args) + (allocate-values label k args slots)) + (_ slots))) + (_ + slots))) + + ;; Sweep right to left to visit uses before definitions. + (persistent-intmap + (intmap-fold-right allocate-lazy cps slots))) + +(define (allocate-slots cps) + (let*-values (((defs uses) (compute-defs-and-uses cps)) + ((live-in live-out) (compute-live-variables cps defs uses)) + ((constants) (compute-constant-values cps)) + ((needs-slot) (compute-needs-slot cps defs uses)) + ((lazy) (compute-lazy-vars cps live-in live-out defs + needs-slot))) + + (define (empty-live-slots) + #b0) + + (define (compute-call-proc-slot live-slots) + (+ 2 (find-first-trailing-zero live-slots))) + + (define (compute-prompt-handler-proc-slot live-slots) + (if (zero? live-slots) + 0 + (1- (find-first-trailing-zero live-slots)))) + + (define (get-cont label) + (intmap-ref cps label)) + + (define (get-slot slots var) + (intmap-ref slots var (lambda (_) #f))) + + (define (get-slots slots vars) + (let lp ((vars vars)) + (match vars + ((var . vars) (cons (get-slot slots var) (lp vars))) + (_ '())))) + + (define (compute-live-slots* slots label live-vars) + (intset-fold (lambda (var live) + (match (get-slot slots var) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-vars label) + 0)) + + (define (compute-live-in-slots slots label) + (compute-live-slots* slots label live-in)) + + (define (compute-live-out-slots slots label) + (compute-live-slots* slots label live-out)) + + (define (allocate var hint slots live) + (cond + ((not (intset-ref needs-slot var)) + (values slots live)) + ((get-slot slots var) + => (lambda (slot) + (values slots (add-live-slot slot live)))) + ((and (not hint) (intset-ref lazy var)) + (values slots live)) + (else + (let ((slot (compute-slot live hint))) + (values (intmap-add! slots var slot) + (add-live-slot slot live)))))) + + (define (allocate* vars hints slots live) + (match (vector vars hints) + (#(() ()) (values slots live)) + (#((var . vars) (hint . hints)) + (call-with-values (lambda () (allocate var hint slots live)) + (lambda (slots live) + (allocate* vars hints slots live)))))) + + (define (allocate-defs label vars slots) + (let ((live (compute-live-in-slots slots label)) + (live-vars (intmap-ref live-in label))) + (let lp ((vars vars) (slots slots) (live live)) + (match vars + (() (values slots live)) + ((var . vars) + (call-with-values (lambda () (allocate var #f slots live)) + (lambda (slots live) + (lp vars slots + (let ((slot (get-slot slots var))) + (if (and slot (not (intset-ref live-vars var))) + (kill-dead-slot slot live) + live)))))))))) + + ;; PRE-LIVE are the live slots coming into the term. POST-LIVE + ;; is the subset of PRE-LIVE that is still live after the term + ;; uses its inputs. + (define (allocate-call label k args slots call-allocs pre-live) + (match (get-cont k) + (($ $ktail) + (let ((tail-slots (integers 0 (length args)))) + (values (allocate* args tail-slots slots pre-live) + call-allocs))) + (($ $kreceive arity kargs) + (let*-values + (((post-live) (compute-live-out-slots slots label)) + ((proc-slot) (compute-call-proc-slot post-live)) + ((call-slots) (integers proc-slot (length args))) + ((slots pre-live) (allocate* args call-slots slots pre-live)) + ;; Allow the first result to be hinted by its use, but + ;; hint the remaining results to stay in place. This + ;; strikes a balance between avoiding shuffling, + ;; especially for unused extra values, and avoiding frame + ;; size growth due to sparse locals. + ((slots result-live) + (match (get-cont kargs) + (($ $kargs () ()) + (values slots post-live)) + (($ $kargs (_ . _) (_ . results)) + (let ((result-slots (integers (+ proc-slot 2) + (length results)))) + (allocate* results result-slots slots post-live))))) + ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) + (lognot post-live))) + ((call) (make-call-alloc proc-slot dead-slot-map))) + (values slots + (intmap-add! call-allocs label call)))))) + + (define (allocate-values label k args slots call-allocs) + (match (get-cont k) + (($ $ktail) + (values slots call-allocs)) + (($ $kargs (_) (dst)) + ;; When there is only one value in play, we allow the dst to be + ;; hinted (see compute-lazy-vars). If the src doesn't have a + ;; slot, then the actual slot for the dst would end up being + ;; decided by the call that args it. Because we don't know the + ;; slot, we can't really compute the parallel moves in that + ;; case, so just bail and rely on the bytecode emitter to + ;; handle the one-value case specially. + (match args + ((src) + (let ((post-live (compute-live-out-slots slots label))) + (values (allocate dst (get-slot slots src) slots post-live) + call-allocs))))) + (($ $kargs _ dst-vars) + (let ((src-slots (get-slots slots args)) + (post-live (compute-live-out-slots slots label))) + (values (allocate* dst-vars src-slots slots post-live) + call-allocs))))) + + (define (allocate-prompt label k handler slots call-allocs) + (match (get-cont handler) + (($ $kreceive arity kargs) + (let*-values + (((handler-live) (compute-live-in-slots slots handler)) + ((proc-slot) (compute-prompt-handler-proc-slot handler-live)) + ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) + (lognot handler-live))) + ((result-vars) (match (get-cont kargs) + (($ $kargs names vars) vars))) + ((value-slots) (integers (1+ proc-slot) (length result-vars))) + ((slots result-live) (allocate* result-vars value-slots + slots handler-live))) + (values slots + (intmap-add! call-allocs label + (make-call-alloc proc-slot dead-slot-map))))))) + + (define (allocate-cont label cont slots call-allocs) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (let-values (((slots live) (allocate-defs label vars slots))) + (match exp + (($ $call proc args) + (allocate-call label k (cons proc args) slots call-allocs live)) + (($ $callk _ proc args) + (allocate-call label k (cons proc args) slots call-allocs live)) + (($ $values args) + (allocate-values label k args slots call-allocs)) + (($ $prompt escape? tag handler) + (allocate-prompt label k handler slots call-allocs)) + (_ + (values slots call-allocs))))) + (_ + (values slots call-allocs)))) + + (call-with-values (lambda () + (let ((slots (allocate-args cps))) + (intmap-fold allocate-cont cps slots empty-intmap))) + (lambda (slots calls) + (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy)) + (shuffles (compute-shuffles cps slots calls live-in)) + (frame-sizes (compute-frame-sizes cps slots calls shuffles))) + (make-allocation slots constants calls shuffles frame-sizes)))))) diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm new file mode 100644 index 000000000..7330885ab --- /dev/null +++ b/module/language/cps/spec.scm @@ -0,0 +1,37 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language cps spec) + #:use-module (system base language) + #:use-module (language cps) + #:use-module (language cps compile-bytecode) + #:export (cps)) + +(define* (write-cps exp #:optional (port (current-output-port))) + (write (unparse-cps exp) port)) + +(define-language cps + #:title "CPS Intermediate Language" + #:reader (lambda (port env) (read port)) + #:printer write-cps + #:parser parse-cps + #:compilers `((bytecode . ,compile-bytecode)) + #:for-humans? #f + ) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm new file mode 100644 index 000000000..c15fbdb3b --- /dev/null +++ b/module/language/cps/specialize-primcalls.scm @@ -0,0 +1,59 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Some bytecode operations can encode an immediate as an operand. +;;; This pass tranforms generic primcalls to these specialized +;;; primcalls, if possible. +;;; +;;; Code: + +(define-module (language cps specialize-primcalls) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:export (specialize-primcalls)) + +(define (specialize-primcalls conts) + (let ((constants (compute-constant-values conts))) + (define (immediate-u8? var) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (and (exact-integer? val) (<= 0 val 255)))) + (define (specialize-primcall name args) + (match (cons name args) + (('make-vector (? immediate-u8? n) init) 'make-vector/immediate) + (('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate) + (('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate) + (('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate) + (('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate) + (('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate) + (_ #f))) + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars ($ $continue k src ($ $primcall name args))) + (let ((name* (specialize-primcall name args))) + (if name* + (build-cont + ($kargs names vars + ($continue k src ($primcall name* args)))) + cont))) + (_ cont))) + conts))) diff --git a/module/language/cps/split-rec.scm b/module/language/cps/split-rec.scm new file mode 100644 index 000000000..2551ac643 --- /dev/null +++ b/module/language/cps/split-rec.scm @@ -0,0 +1,174 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Split functions bound in $rec expressions into strongly-connected +;;; components. The result will be that each $rec binds a +;;; strongly-connected component of mutually recursive functions. +;;; +;;; Code: + +(define-module (language cps split-rec) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (split-rec)) + +(define (compute-free-vars conts kfun) + "Compute a FUN-LABEL->FREE-VAR... map describing all free variable +references." + (define (add-def var defs) (intset-add! defs var)) + (define (add-defs vars defs) + (match vars + (() defs) + ((var . vars) (add-defs vars (add-def var defs))))) + (define (add-use var uses) (intset-add! uses var)) + (define (add-uses vars uses) + (match vars + (() uses) + ((var . vars) (add-uses vars (add-use var uses))))) + (define (visit-nested-funs body) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ + ($ $fun kfun))) + (intmap-union out (visit-fun kfun))) + (($ $kargs _ _ ($ $continue _ _ + ($ $rec _ _ (($ $fun kfun) ...)))) + (fold (lambda (kfun out) + (intmap-union out (visit-fun kfun))) + out kfun)) + (_ out))) + body + empty-intmap)) + (define (visit-fun kfun) + (let* ((body (compute-function-body conts kfun)) + (free (visit-nested-funs body))) + (call-with-values + (lambda () + (intset-fold + (lambda (label defs uses) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (values + (add-defs vars defs) + (match exp + ((or ($ $const) ($ $prim)) uses) + (($ $fun kfun) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + (($ $rec names vars (($ $fun kfun) ...)) + (fold (lambda (kfun uses) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + uses kfun)) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-use proc (add-uses args uses))) + (($ $branch kt ($ $values (arg))) + (add-use arg uses)) + (($ $branch kt ($ $primcall name args)) + (add-uses args uses)) + (($ $primcall name args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses))))) + (($ $kfun src meta self) + (values (add-def self defs) uses)) + (_ (values defs uses)))) + body empty-intset empty-intset)) + (lambda (defs uses) + (intmap-add free kfun (intset-subtract + (persistent-intset uses) + (persistent-intset defs))))))) + (visit-fun kfun)) + +(define (compute-split fns free-vars) + (define (get-free kfun) + ;; It's possible for a fun to have been skipped by + ;; compute-free-vars, if the fun isn't reachable. Fall back to + ;; empty-intset for the fun's free vars, in that case. + (intmap-ref free-vars kfun (lambda (_) empty-intset))) + (let* ((vars (intmap-keys fns)) + (edges (intmap-map + (lambda (var kfun) + (intset-intersect (get-free kfun) vars)) + fns))) + (compute-sorted-strongly-connected-components edges))) + +(define (intmap-acons k v map) + (intmap-add map k v)) + +(define (split-rec conts) + (let ((free (compute-free-vars conts 0))) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs cont-names cont-vars + ($ $continue k src ($ $rec names vars (($ $fun kfuns) ...)))) + (let ((fns (fold intmap-acons empty-intmap vars kfuns)) + (fn-names (fold intmap-acons empty-intmap vars names))) + (match (compute-split fns free) + (() + ;; Remove trivial $rec. + (with-cps out + (setk label ($kargs cont-names cont-vars + ($continue k src ($values ())))))) + ((_) + ;; Bound functions already form a strongly-connected + ;; component. + out) + (components + ;; Multiple components. Split them into separate $rec + ;; expressions. + (define (build-body out components) + (match components + (() + (match (intmap-ref out k) + (($ $kargs names vars term) + (with-cps (intmap-remove out k) + term)))) + ((vars . components) + (match (intset-fold + (lambda (var out) + (let ((name (intmap-ref fn-names var)) + (fun (build-exp + ($fun (intmap-ref fns var))))) + (cons (list name var fun) out))) + vars '()) + (((name var fun) ...) + (with-cps out + (let$ body (build-body components)) + (letk kbody ($kargs name var ,body)) + (build-term + ($continue kbody src ($rec name var fun))))))))) + (with-cps out + (let$ body (build-body components)) + (setk label ($kargs cont-names cont-vars ,body))))))) + (_ out))) + conts + conts))))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm new file mode 100644 index 000000000..2104b09ef --- /dev/null +++ b/module/language/cps/type-fold.scm @@ -0,0 +1,425 @@ +;;; Abstract constant folding on CPS +;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; This pass uses the abstract interpretation provided by type analysis +;;; to fold constant values and type predicates. It is most profitably +;;; run after CSE, to take advantage of scalar replacement. +;;; +;;; Code: + +(define-module (language cps type-fold) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps renumber) + #:use-module (language cps types) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (system base target) + #:export (type-fold)) + + + + +;; Branch folders. + +(define &scalar-types + (logior &exact-integer &flonum &char &unspecified &false &true &nil &null)) + +(define *branch-folders* (make-hash-table)) + +(define-syntax-rule (define-branch-folder name f) + (hashq-set! *branch-folders* 'name f)) + +(define-syntax-rule (define-branch-folder-alias to from) + (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from))) + +(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...) + (define-branch-folder name (lambda (arg min max) body ...))) + +(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0 + arg1 min1 max1) + body ...) + (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...))) + +(define-syntax-rule (define-unary-type-predicate-folder name &type) + (define-unary-branch-folder (name type min max) + (let ((type* (logand type &type))) + (cond + ((zero? type*) (values #t #f)) + ((eqv? type type*) (values #t #t)) + (else (values #f #f)))))) + +;; All the cases that are in compile-bytecode. +(define-unary-type-predicate-folder pair? &pair) +(define-unary-type-predicate-folder null? &null) +(define-unary-type-predicate-folder nil? &nil) +(define-unary-type-predicate-folder symbol? &symbol) +(define-unary-type-predicate-folder variable? &box) +(define-unary-type-predicate-folder vector? &vector) +(define-unary-type-predicate-folder struct? &struct) +(define-unary-type-predicate-folder string? &string) +(define-unary-type-predicate-folder number? &number) +(define-unary-type-predicate-folder char? &char) + +(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1) + (cond + ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0)) + (values #t #f)) + ((and (eqv? type0 type1) + (eqv? min0 min1 max0 max1) + (zero? (logand type0 (1- type0))) + (not (zero? (logand type0 &scalar-types)))) + (values #t #t)) + (else + (values #f #f)))) +(define-branch-folder-alias eqv? eq?) +(define-branch-folder-alias equal? eq?) + +(define (compare-ranges type0 min0 max0 type1 min1 max1) + (and (zero? (logand (logior type0 type1) (lognot &real))) + (cond ((< max0 min1) '<) + ((> min0 max1) '>) + ((= min0 max0 min1 max1) '=) + ((<= max0 min1) '<=) + ((>= min0 max1) '>=) + (else #f)))) + +(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((<) (values #t #t)) + ((= >= >) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((< <= =) (values #t #t)) + ((>) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((=) (values #t #t)) + ((< >) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((> >= =) (values #t #t)) + ((<) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((>) (values #t #t)) + ((= <= <) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1) + (define (logand-min a b) + (if (< a b 0) + (min a b) + 0)) + (define (logand-max a b) + (if (< a b 0) + 0 + (max a b))) + (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer)) + (values #t (logtest min0 min1)) + (values #f #f))) + + + + +;; Strength reduction. + +(define *primcall-reducers* (make-hash-table)) + +(define-syntax-rule (define-primcall-reducer name f) + (hashq-set! *primcall-reducers* 'name f)) + +(define-syntax-rule (define-unary-primcall-reducer (name cps k src + arg type min max) + body ...) + (define-primcall-reducer name + (lambda (cps k src arg type min max) + body ...))) + +(define-syntax-rule (define-binary-primcall-reducer (name cps k src + arg0 type0 min0 max0 + arg1 type1 min1 max1) + body ...) + (define-primcall-reducer name + (lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1) + body ...))) + +(define-binary-primcall-reducer (mul cps k src + arg0 type0 min0 max0 + arg1 type1 min1 max1) + (define (fail) (with-cps cps #f)) + (define (negate arg) + (with-cps cps + ($ (with-cps-constants ((zero 0)) + (build-term + ($continue k src ($primcall 'sub (zero arg)))))))) + (define (zero) + (with-cps cps + (build-term ($continue k src ($const 0))))) + (define (identity arg) + (with-cps cps + (build-term ($continue k src ($values (arg)))))) + (define (double arg) + (with-cps cps + (build-term ($continue k src ($primcall 'add (arg arg)))))) + (define (power-of-two constant arg) + (let ((n (let lp ((bits 0) (constant constant)) + (if (= constant 1) bits (lp (1+ bits) (ash constant -1)))))) + (with-cps cps + ($ (with-cps-constants ((bits n)) + (build-term ($continue k src ($primcall 'ash (arg bits))))))))) + (define (mul/constant constant constant-type arg arg-type) + (cond + ((not (or (= constant-type &exact-integer) (= constant-type arg-type))) + (fail)) + ((eqv? constant -1) + ;; (* arg -1) -> (- 0 arg) + (negate arg)) + ((eqv? constant 0) + ;; (* arg 0) -> 0 if arg is not a flonum or complex + (and (= constant-type &exact-integer) + (zero? (logand arg-type + (lognot (logior &flonum &complex)))) + (zero))) + ((eqv? constant 1) + ;; (* arg 1) -> arg + (identity arg)) + ((eqv? constant 2) + ;; (* arg 2) -> (+ arg arg) + (double arg)) + ((and (= constant-type arg-type &exact-integer) + (positive? constant) + (zero? (logand constant (1- constant)))) + ;; (* arg power-of-2) -> (ash arg (log2 power-of-2 + (power-of-two constant arg)) + (else + (fail)))) + (cond + ((logtest (logior type0 type1) (lognot &number)) (fail)) + ((= min0 max0) (mul/constant min0 type0 arg1 type1)) + ((= min1 max1) (mul/constant min1 type1 arg0 type0)) + (else (fail)))) + +(define-binary-primcall-reducer (logbit? cps k src + arg0 type0 min0 max0 + arg1 type1 min1 max1) + (define (convert-to-logtest cps kbool) + (define (compute-mask cps kmask src) + (if (eq? min0 max0) + (with-cps cps + (build-term + ($continue kmask src ($const (ash 1 min0))))) + (with-cps cps + ($ (with-cps-constants ((one 1)) + (build-term + ($continue kmask src ($primcall 'ash (one arg0))))))))) + (with-cps cps + (letv mask) + (letk kt ($kargs () () + ($continue kbool src ($const #t)))) + (letk kf ($kargs () () + ($continue kbool src ($const #f)))) + (letk kmask ($kargs (#f) (mask) + ($continue kf src + ($branch kt ($primcall 'logtest (mask arg1)))))) + ($ (compute-mask kmask src)))) + ;; Hairiness because we are converting from a primcall with unknown + ;; arity to a branching primcall. + (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3))) + (if (and (= type0 &exact-integer) + (<= 0 min0 positive-fixnum-bits) + (<= 0 max0 positive-fixnum-bits)) + (match (intmap-ref cps k) + (($ $kreceive arity kargs) + (match arity + (($ $arity (_) () (not #f) () #f) + (with-cps cps + (letv bool) + (let$ body (with-cps-constants ((nil '())) + (build-term + ($continue kargs src ($values (bool nil)))))) + (letk kbool ($kargs (#f) (bool) ,body)) + ($ (convert-to-logtest kbool)))) + (_ + (with-cps cps + (letv bool) + (letk kbool ($kargs (#f) (bool) + ($continue k src ($primcall 'values (bool))))) + ($ (convert-to-logtest kbool)))))) + (($ $ktail) + (with-cps cps + (letv bool) + (letk kbool ($kargs (#f) (bool) + ($continue k src ($primcall 'return (bool))))) + ($ (convert-to-logtest kbool))))) + (with-cps cps #f)))) + + + + +;; + +(define (local-type-fold start end cps) + (define (scalar-value type val) + (cond + ((eqv? type &exact-integer) val) + ((eqv? type &flonum) (exact->inexact val)) + ((eqv? type &char) (integer->char val)) + ((eqv? type &unspecified) *unspecified*) + ((eqv? type &false) #f) + ((eqv? type &true) #t) + ((eqv? type &nil) #nil) + ((eqv? type &null) '()) + (else (error "unhandled type" type val)))) + (let ((types (infer-types cps start))) + (define (fold-primcall cps label names vars k src name args def) + (call-with-values (lambda () (lookup-post-type types label def 0)) + (lambda (type min max) + (and (not (zero? type)) + (zero? (logand type (1- type))) + (zero? (logand type (lognot &scalar-types))) + (eqv? min max) + (let ((val (scalar-value type min))) + ;; (pk 'folded src name args val) + (with-cps cps + (letv v*) + (letk k* ($kargs (#f) (v*) + ($continue k src ($const val)))) + ;; Rely on DCE to elide this expression, if + ;; possible. + (setk label + ($kargs names vars + ($continue k* src ($primcall name args)))))))))) + (define (reduce-primcall cps label names vars k src name args) + (and=> + (hashq-ref *primcall-reducers* name) + (lambda (reducer) + (match args + ((arg0) + (call-with-values (lambda () (lookup-pre-type types label arg0)) + (lambda (type0 min0 max0) + (call-with-values (lambda () + (reducer cps k src arg0 type0 min0 max0)) + (lambda (cps term) + (and term + (with-cps cps + (setk label ($kargs names vars ,term))))))))) + ((arg0 arg1) + (call-with-values (lambda () (lookup-pre-type types label arg0)) + (lambda (type0 min0 max0) + (call-with-values (lambda () (lookup-pre-type types label arg1)) + (lambda (type1 min1 max1) + (call-with-values (lambda () + (reducer cps k src arg0 type0 min0 max0 + arg1 type1 min1 max1)) + (lambda (cps term) + (and term + (with-cps cps + (setk label ($kargs names vars ,term))))))))))) + (_ #f))))) + (define (fold-unary-branch cps label names vars kf kt src name arg) + (and=> + (hashq-ref *branch-folders* name) + (lambda (folder) + (call-with-values (lambda () (lookup-pre-type types label arg)) + (lambda (type min max) + (call-with-values (lambda () (folder type min max)) + (lambda (f? v) + ;; (when f? (pk 'folded-unary-branch label name arg v)) + (and f? + (with-cps cps + (setk label + ($kargs names vars + ($continue (if v kt kf) src + ($values ()))))))))))))) + (define (fold-binary-branch cps label names vars kf kt src name arg0 arg1) + (and=> + (hashq-ref *branch-folders* name) + (lambda (folder) + (call-with-values (lambda () (lookup-pre-type types label arg0)) + (lambda (type0 min0 max0) + (call-with-values (lambda () (lookup-pre-type types label arg1)) + (lambda (type1 min1 max1) + (call-with-values (lambda () + (folder type0 min0 max0 type1 min1 max1)) + (lambda (f? v) + ;; (when f? (pk 'folded-binary-branch label name arg0 arg1 v)) + (and f? + (with-cps cps + (setk label + ($kargs names vars + ($continue (if v kt kf) src + ($values ()))))))))))))))) + (define (visit-expression cps label names vars k src exp) + (match exp + (($ $primcall name args) + ;; We might be able to fold primcalls that define a value. + (match (intmap-ref cps k) + (($ $kargs (_) (def)) + (or (fold-primcall cps label names vars k src name args def) + (reduce-primcall cps label names vars k src name args) + cps)) + (_ + (or (reduce-primcall cps label names vars k src name args) + cps)))) + (($ $branch kt ($ $primcall name args)) + ;; We might be able to fold primcalls that branch. + (match args + ((x) + (or (fold-unary-branch cps label names vars k kt src name x) + cps)) + ((x y) + (or (fold-binary-branch cps label names vars k kt src name x y) + cps)))) + (_ cps))) + (let lp ((label start) (cps cps)) + (if (<= label end) + (lp (1+ label) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-expression cps label names vars k src exp)) + (_ cps))) + cps)))) + +(define (fold-functions-in-renumbered-program f conts seed) + (let* ((conts (persistent-intmap conts)) + (end (1+ (intmap-prev conts)))) + (let lp ((label 0) (seed seed)) + (if (eqv? label end) + seed + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (lp (1+ tail) (f label tail seed)))))))) + +(define (type-fold conts) + ;; Type analysis wants a program whose labels are sorted. + (let ((conts (renumber conts))) + (with-fresh-name-state conts + (persistent-intmap + (fold-functions-in-renumbered-program local-type-fold conts conts))))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm new file mode 100644 index 000000000..55cde2744 --- /dev/null +++ b/module/language/cps/types.scm @@ -0,0 +1,1408 @@ +;;; Type analysis on CPS +;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; Type analysis computes the possible types and ranges that values may +;;; have at all program positions. This analysis can help to prove that +;;; a primcall has no side-effects, if its arguments have the +;;; appropriate type and range. It can also enable constant folding of +;;; type predicates and, in the future, enable the compiler to choose +;;; untagged, unboxed representations for numbers. +;;; +;;; For the purposes of this analysis, a "type" is an aspect of a value +;;; that will not change. Guile's CPS intermediate language does not +;;; carry manifest type information that asserts properties about given +;;; values; instead, we recover this information via flow analysis, +;;; garnering properties from type predicates, constant literals, +;;; primcall results, and primcalls that assert that their arguments are +;;; of particular types. +;;; +;;; A range denotes a subset of the set of values in a type, bounded by +;;; a minimum and a maximum. The precise meaning of a range depends on +;;; the type. For real numbers, the range indicates an inclusive lower +;;; and upper bound on the integer value of a type. For vectors, the +;;; range indicates the length of the vector. The range is limited to a +;;; signed 32-bit value, with the smallest and largest values indicating +;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the +;;; concept of "range" makes no sense. In these cases we consider the +;;; range to be -inf.0 to +inf.0. +;;; +;;; Types are represented as a bitfield. Fewer bits means a more precise +;;; type. Although normally only values that have a single type will +;;; have an associated range, this is not enforced. The range applies +;;; to all types in the bitfield. When control flow meets, the types and +;;; ranges meet with the union operator. +;;; +;;; It is not practical to precisely compute value ranges in all cases. +;;; For example, in the following case: +;;; +;;; (let lp ((n 0)) (when (foo) (lp (1+ n)))) +;;; +;;; The first time that range analysis visits the program, N is +;;; determined to be the exact integer 0. The second time, it is an +;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on. +;;; This analysis will terminate, but only after the positive half of +;;; the 32-bit range has been fully explored and we decide that the +;;; range of N is [0, +inf.0]. At the same time, we want to do range +;;; analysis and type analysis at the same time, as there are +;;; interactions between them, notably in the case of `sqrt' which +;;; returns a complex number if its argument cannot be proven to be +;;; non-negative. So what we do instead is to precisely propagate types +;;; and ranges when propagating forward, but after the first backwards +;;; branch is seen, we cause backward branches that would expand the +;;; range of a value to saturate that range towards positive or negative +;;; infinity (as appropriate). +;;; +;;; A naive approach to type analysis would build up a table that has +;;; entries for all variables at all program points, but this has +;;; N-squared complexity and quickly grows unmanageable. Instead, we +;;; use _intmaps_ from (language cps intmap) to share state between +;;; connected program points. +;;; +;;; Code: + +(define-module (language cps types) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-11) + #:export (;; Specific types. + &exact-integer + &flonum + &complex + &fraction + + &char + &unspecified + &unbound + &false + &true + &nil + &null + &symbol + &keyword + + &procedure + + &pointer + &fluid + &pair + &vector + &box + &struct + &string + &bytevector + &bitvector + &array + &hash-table + + ;; Union types. + &number &real + + infer-types + lookup-pre-type + lookup-post-type + primcall-types-check?)) + +(define-syntax define-flags + (lambda (x) + (syntax-case x () + ((_ all shift name ...) + (let ((count (length #'(name ...)))) + (with-syntax (((n ...) (iota count)) + (count count)) + #'(begin + (define-syntax name (identifier-syntax (ash 1 n))) + ... + (define-syntax all (identifier-syntax (1- (ash 1 count)))) + (define-syntax shift (identifier-syntax count))))))))) + +;; More precise types have fewer bits. +(define-flags &all-types &type-bits + &exact-integer + &flonum + &complex + &fraction + + &char + &unspecified + &unbound + &false + &true + &nil + &null + &symbol + &keyword + + &procedure + + &pointer + &fluid + &pair + &vector + &box + &struct + &string + &bytevector + &bitvector + &array + &hash-table) + +(define-syntax &no-type (identifier-syntax 0)) + +(define-syntax &number + (identifier-syntax (logior &exact-integer &flonum &complex &fraction))) +(define-syntax &real + (identifier-syntax (logior &exact-integer &flonum &fraction))) + +(define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1))) +(define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31)))) + +;; Versions of min and max that do not coerce exact numbers to become +;; inexact. +(define min + (case-lambda + ((a b) (if (< a b) a b)) + ((a b c) (min (min a b) c)) + ((a b c d) (min (min a b) c d)))) +(define max + (case-lambda + ((a b) (if (> a b) a b)) + ((a b c) (max (max a b) c)) + ((a b c d) (max (max a b) c d)))) + + + +(define-syntax-rule (define-compile-time-value name val) + (define-syntax name + (make-variable-transformer + (lambda (x) + (syntax-case x (set!) + (var (identifier? #'var) + (datum->syntax #'var val))))))) + +(define-compile-time-value min-fixnum most-negative-fixnum) +(define-compile-time-value max-fixnum most-positive-fixnum) + +(define-inlinable (make-unclamped-type-entry type min max) + (vector type min max)) +(define-inlinable (type-entry-type tentry) + (vector-ref tentry 0)) +(define-inlinable (type-entry-clamped-min tentry) + (vector-ref tentry 1)) +(define-inlinable (type-entry-clamped-max tentry) + (vector-ref tentry 2)) + +(define-syntax-rule (clamp-range val) + (cond + ((< val min-fixnum) min-fixnum) + ((< max-fixnum val) max-fixnum) + (else val))) + +(define-inlinable (make-type-entry type min max) + (vector type (clamp-range min) (clamp-range max))) +(define-inlinable (type-entry-min tentry) + (let ((min (type-entry-clamped-min tentry))) + (if (eq? min min-fixnum) -inf.0 min))) +(define-inlinable (type-entry-max tentry) + (let ((max (type-entry-clamped-max tentry))) + (if (eq? max max-fixnum) +inf.0 max))) + +(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0)) + +(define* (var-type-entry typeset var #:optional (default all-types-entry)) + (intmap-ref typeset var (lambda (_) default))) + +(define (var-type typeset var) + (type-entry-type (var-type-entry typeset var))) +(define (var-min typeset var) + (type-entry-min (var-type-entry typeset var))) +(define (var-max typeset var) + (type-entry-max (var-type-entry typeset var))) + +;; Is the type entry A contained entirely within B? +(define (type-entry<=? a b) + (match (cons a b) + ((#(a-type a-min a-max) . #(b-type b-min b-max)) + (and (eqv? b-type (logior a-type b-type)) + (<= b-min a-min) + (>= b-max a-max))))) + +(define (type-entry-union a b) + (cond + ((type-entry<=? b a) a) + ((type-entry<=? a b) b) + (else (make-type-entry + (logior (type-entry-type a) (type-entry-type b)) + (min (type-entry-clamped-min a) (type-entry-clamped-min b)) + (max (type-entry-clamped-max a) (type-entry-clamped-max b)))))) + +(define (type-entry-saturating-union a b) + (cond + ((type-entry<=? b a) a) + (else + (make-type-entry + (logior (type-entry-type a) (type-entry-type b)) + (let ((a-min (type-entry-clamped-min a)) + (b-min (type-entry-clamped-min b))) + (if (< b-min a-min) min-fixnum a-min)) + (let ((a-max (type-entry-clamped-max a)) + (b-max (type-entry-clamped-max b))) + (if (> b-max a-max) max-fixnum a-max)))))) + +(define (type-entry-intersection a b) + (cond + ((type-entry<=? a b) a) + ((type-entry<=? b a) b) + (else (make-type-entry + (logand (type-entry-type a) (type-entry-type b)) + (max (type-entry-clamped-min a) (type-entry-clamped-min b)) + (min (type-entry-clamped-max a) (type-entry-clamped-max b)))))) + +(define (adjoin-var typeset var entry) + (intmap-add typeset var entry type-entry-union)) + +(define (restrict-var typeset var entry) + (intmap-add typeset var entry type-entry-intersection)) + +(define (constant-type val) + "Compute the type and range of VAL. Return three values: the type, +minimum, and maximum." + (define (return type val) + (if val + (make-type-entry type val val) + (make-type-entry type -inf.0 +inf.0))) + (cond + ((number? val) + (cond + ((exact-integer? val) (return &exact-integer val)) + ((eqv? (imag-part val) 0) + (if (nan? val) + (make-type-entry &flonum -inf.0 +inf.0) + (make-type-entry + (if (exact? val) &fraction &flonum) + (if (rational? val) (inexact->exact (floor val)) val) + (if (rational? val) (inexact->exact (ceiling val)) val)))) + (else (return &complex #f)))) + ((eq? val '()) (return &null #f)) + ((eq? val #nil) (return &nil #f)) + ((eq? val #t) (return &true #f)) + ((eq? val #f) (return &false #f)) + ((char? val) (return &char (char->integer val))) + ((eqv? val *unspecified*) (return &unspecified #f)) + ((symbol? val) (return &symbol #f)) + ((keyword? val) (return &keyword #f)) + ((pair? val) (return &pair #f)) + ((vector? val) (return &vector (vector-length val))) + ((string? val) (return &string (string-length val))) + ((bytevector? val) (return &bytevector (bytevector-length val))) + ((bitvector? val) (return &bitvector (bitvector-length val))) + ((array? val) (return &array (array-rank val))) + ((not (variable-bound? (make-variable val))) (return &unbound #f)) + + (else (error "unhandled constant" val)))) + +(define *type-checkers* (make-hash-table)) +(define *type-inferrers* (make-hash-table)) + +(define-syntax-rule (define-type-helper name) + (define-syntax-parameter name + (lambda (stx) + (syntax-violation 'name + "macro used outside of define-type" + stx)))) +(define-type-helper define!) +(define-type-helper restrict!) +(define-type-helper &type) +(define-type-helper &min) +(define-type-helper &max) + +(define-syntax-rule (define-type-checker (name arg ...) body ...) + (hashq-set! + *type-checkers* + 'name + (lambda (typeset arg ...) + (syntax-parameterize + ((&type (syntax-rules () ((_ val) (var-type typeset val)))) + (&min (syntax-rules () ((_ val) (var-min typeset val)))) + (&max (syntax-rules () ((_ val) (var-max typeset val))))) + body ...)))) + +(define-syntax-rule (check-type arg type min max) + ;; If the arg is negative, it is a closure variable. + (and (>= arg 0) + (zero? (logand (lognot type) (&type arg))) + (<= min (&min arg)) + (<= (&max arg) max))) + +(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...) + (hashq-set! + *type-inferrers* + 'name + (lambda (in succ var ...) + (let ((out in)) + (syntax-parameterize + ((define! + (syntax-rules () + ((_ val type min max) + (set! out (adjoin-var out val + (make-type-entry type min max)))))) + (restrict! + (syntax-rules () + ((_ val type min max) + (set! out (restrict-var out val + (make-type-entry type min max)))))) + (&type (syntax-rules () ((_ val) (var-type in val)))) + (&min (syntax-rules () ((_ val) (var-min in val)))) + (&max (syntax-rules () ((_ val) (var-max in val))))) + body ... + out))))) + +(define-syntax-rule (define-type-inferrer (name arg ...) body ...) + (define-type-inferrer* (name succ arg ...) body ...)) + +(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...) + (define-type-inferrer* (name succ arg ...) + (let ((true? (not (zero? succ)))) + body ...))) + +(define-syntax define-simple-type-checker + (lambda (x) + (define (parse-spec l) + (syntax-case l () + (() '()) + (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) + (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) + ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) + (syntax-case x () + ((_ (name arg-spec ...) result-spec ...) + (with-syntax + (((arg ...) (generate-temporaries #'(arg-spec ...))) + (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))) + #'(define-type-checker (name arg ...) + (and (check-type arg arg-type arg-min arg-max) + ...))))))) + +(define-syntax define-simple-type-inferrer + (lambda (x) + (define (parse-spec l) + (syntax-case l () + (() '()) + (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) + (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) + ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) + (syntax-case x () + ((_ (name arg-spec ...) result-spec ...) + (with-syntax + (((arg ...) (generate-temporaries #'(arg-spec ...))) + (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))) + ((res ...) (generate-temporaries #'(result-spec ...))) + (((res-type res-min res-max) ...) (parse-spec #'(result-spec ...)))) + #'(define-type-inferrer (name arg ... res ...) + (restrict! arg arg-type arg-min arg-max) + ... + (define! res res-type res-min res-max) + ...)))))) + +(define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...) + (begin + (define-simple-type-checker (name arg-spec ...)) + (define-simple-type-inferrer (name arg-spec ...) result-spec ...))) + +(define-syntax-rule (define-simple-types + ((name arg-spec ...) result-spec ...) + ...) + (begin + (define-simple-type (name arg-spec ...) result-spec ...) + ...)) + +(define-syntax-rule (define-type-checker-aliases orig alias ...) + (let ((check (hashq-ref *type-checkers* 'orig))) + (hashq-set! *type-checkers* 'alias check) + ...)) +(define-syntax-rule (define-type-inferrer-aliases orig alias ...) + (let ((check (hashq-ref *type-inferrers* 'orig))) + (hashq-set! *type-inferrers* 'alias check) + ...)) +(define-syntax-rule (define-type-aliases orig alias ...) + (begin + (define-type-checker-aliases orig alias ...) + (define-type-inferrer-aliases orig alias ...))) + + + + +;;; This list of primcall type definitions follows the order of +;;; effects-analysis.scm; please keep it in a similar order. +;;; +;;; There is no need to add checker definitions for expressions that do +;;; not exhibit the &type-check effect, as callers should not ask if +;;; such an expression does or does not type-check. For those that do +;;; exhibit &type-check, you should define a type inferrer unless the +;;; primcall will never typecheck. +;;; +;;; Likewise there is no need to define inferrers for primcalls which +;;; return &all-types values and which never raise exceptions from which +;;; we can infer the types of incoming values. + + + + +;;; +;;; Generic effect-free predicates. +;;; + +(define-predicate-inferrer (eq? a b true?) + ;; We can only propagate information down the true leg. + (when true? + (let ((type (logand (&type a) (&type b))) + (min (max (&min a) (&min b))) + (max (min (&max a) (&max b)))) + (restrict! a type min max) + (restrict! b type min max)))) +(define-type-inferrer-aliases eq? eqv? equal?) + +(define-syntax-rule (define-simple-predicate-inferrer predicate type) + (define-predicate-inferrer (predicate val true?) + (let ((type (if true? + type + (logand (&type val) (lognot type))))) + (restrict! val type -inf.0 +inf.0)))) +(define-simple-predicate-inferrer pair? &pair) +(define-simple-predicate-inferrer null? &null) +(define-simple-predicate-inferrer nil? &nil) +(define-simple-predicate-inferrer symbol? &symbol) +(define-simple-predicate-inferrer variable? &box) +(define-simple-predicate-inferrer vector? &vector) +(define-simple-predicate-inferrer struct? &struct) +(define-simple-predicate-inferrer string? &string) +(define-simple-predicate-inferrer bytevector? &bytevector) +(define-simple-predicate-inferrer bitvector? &bitvector) +(define-simple-predicate-inferrer keyword? &keyword) +(define-simple-predicate-inferrer number? &number) +(define-simple-predicate-inferrer char? &char) +(define-simple-predicate-inferrer procedure? &procedure) +(define-simple-predicate-inferrer thunk? &procedure) + + + +;;; +;;; Fluids. Note that we can't track bound-ness of fluids, as pop-fluid +;;; can change boundness. +;;; + +(define-simple-types + ((fluid-ref (&fluid 1)) &all-types) + ((fluid-set! (&fluid 0 1) &all-types)) + ((push-fluid (&fluid 0 1) &all-types)) + ((pop-fluid))) + + + + +;;; +;;; Prompts. (Nothing to do.) +;;; + + + + +;;; +;;; Pairs. +;;; + +(define-simple-types + ((cons &all-types &all-types) &pair) + ((car &pair) &all-types) + ((set-car! &pair &all-types)) + ((cdr &pair) &all-types) + ((set-cdr! &pair &all-types))) + + + + +;;; +;;; Variables. +;;; + +(define-simple-types + ((box &all-types) (&box 1)) + ((box-ref (&box 1)) &all-types)) + +(define-simple-type-checker (box-set! (&box 0 1) &all-types)) +(define-type-inferrer (box-set! box val) + (restrict! box &box 1 1)) + + + + +;;; +;;; Vectors. +;;; + +;; This max-vector-len computation is a hack. +(define *max-vector-len* (ash most-positive-fixnum -5)) + +(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*) + &all-types)) +(define-type-inferrer (make-vector size init result) + (restrict! size &exact-integer 0 *max-vector-len*) + (define! result &vector (max (&min size) 0) (&max size))) + +(define-type-checker (vector-ref v idx) + (and (check-type v &vector 0 *max-vector-len*) + (check-type idx &exact-integer 0 (1- (&min v))))) +(define-type-inferrer (vector-ref v idx result) + (restrict! v &vector (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max v))) + (define! result &all-types -inf.0 +inf.0)) + +(define-type-checker (vector-set! v idx val) + (and (check-type v &vector 0 *max-vector-len*) + (check-type idx &exact-integer 0 (1- (&min v))))) +(define-type-inferrer (vector-set! v idx val) + (restrict! v &vector (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max v)))) + +(define-type-aliases make-vector make-vector/immediate) +(define-type-aliases vector-ref vector-ref/immediate) +(define-type-aliases vector-set! vector-set!/immediate) + +(define-simple-type-checker (vector-length &vector)) +(define-type-inferrer (vector-length v result) + (restrict! v &vector 0 *max-vector-len*) + (define! result &exact-integer (max (&min v) 0) + (min (&max v) *max-vector-len*))) + + + + +;;; +;;; Structs. +;;; + +;; No type-checker for allocate-struct, as we can't currently check that +;; vt is actually a vtable. +(define-type-inferrer (allocate-struct vt size result) + (restrict! vt &struct vtable-offset-user +inf.0) + (restrict! size &exact-integer 0 +inf.0) + (define! result &struct (max (&min size) 0) (&max size))) + +(define-type-checker (struct-ref s idx) + (and (check-type s &struct 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + ;; FIXME: is the field readable? + (< (&max idx) (&min s)))) +(define-type-inferrer (struct-ref s idx result) + (restrict! s &struct (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max s))) + (define! result &all-types -inf.0 +inf.0)) + +(define-type-checker (struct-set! s idx val) + (and (check-type s &struct 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + ;; FIXME: is the field writable? + (< (&max idx) (&min s)))) +(define-type-inferrer (struct-set! s idx val) + (restrict! s &struct (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max s)))) + +(define-type-aliases allocate-struct allocate-struct/immediate) +(define-type-aliases struct-ref struct-ref/immediate) +(define-type-aliases struct-set! struct-set!/immediate) + +(define-simple-type (struct-vtable (&struct 0 +inf.0)) + (&struct vtable-offset-user +inf.0)) + + + + +;;; +;;; Strings. +;;; + +(define *max-char* (1- (ash 1 24))) + +(define-type-checker (string-ref s idx) + (and (check-type s &string 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + (< (&max idx) (&min s)))) +(define-type-inferrer (string-ref s idx result) + (restrict! s &string (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max s))) + (define! result &char 0 *max-char*)) + +(define-type-checker (string-set! s idx val) + (and (check-type s &string 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + (check-type val &char 0 *max-char*) + (< (&max idx) (&min s)))) +(define-type-inferrer (string-set! s idx val) + (restrict! s &string (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max s))) + (restrict! val &char 0 *max-char*)) + +(define-simple-type-checker (string-length &string)) +(define-type-inferrer (string-length s result) + (restrict! s &string 0 +inf.0) + (define! result &exact-integer (max (&min s) 0) (&max s))) + +(define-simple-type (number->string &number) (&string 0 +inf.0)) +(define-simple-type (string->number (&string 0 +inf.0)) + ((logior &number &false) -inf.0 +inf.0)) + + + + +;;; +;;; Bytevectors. +;;; + +(define-simple-type-checker (bytevector-length &bytevector)) +(define-type-inferrer (bytevector-length bv result) + (restrict! bv &bytevector 0 +inf.0) + (define! result &exact-integer (max (&min bv) 0) (&max bv))) + +(define-syntax-rule (define-bytevector-accessors ref set type size min max) + (begin + (define-type-checker (ref bv idx) + (and (check-type bv &bytevector 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + (< (&max idx) (- (&min bv) size)))) + (define-type-inferrer (ref bv idx result) + (restrict! bv &bytevector (+ (&min idx) size) +inf.0) + (restrict! idx &exact-integer 0 (- (&max bv) size)) + (define! result type min max)) + (define-type-checker (set bv idx val) + (and (check-type bv &bytevector 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + (check-type val type min max) + (< (&max idx) (- (&min bv) size)))) + (define-type-inferrer (set! bv idx val) + (restrict! bv &bytevector (+ (&min idx) size) +inf.0) + (restrict! idx &exact-integer 0 (- (&max bv) size)) + (restrict! val type min max)))) + +(define-syntax-rule (define-short-bytevector-accessors ref set size signed?) + (define-bytevector-accessors ref set &exact-integer size + (if signed? (- (ash 1 (1- (* size 8)))) 0) + (1- (ash 1 (if signed? (1- (* size 8)) (* size 8)))))) + +(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f) +(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t) +(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f) +(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t) + +;; The range analysis only works on signed 32-bit values, so some limits +;; are out of range. +(define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0) +(define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0) +(define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0) +(define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0) +(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0) +(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0) + + + + +;;; +;;; Numbers. +;;; + +;; First, branching primitives with no results. +(define-simple-type-checker (= &number &number)) +(define-predicate-inferrer (= a b true?) + (when (and true? + (zero? (logand (logior (&type a) (&type b)) (lognot &number)))) + (let ((min (max (&min a) (&min b))) + (max (min (&max a) (&max b)))) + (restrict! a &number min max) + (restrict! b &number min max)))) + +(define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1) + (define (infer-integer-ranges) + (match op + ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1)) + ('<= (values min0 (min max0 max1) (max min0 min1) max1)) + ('>= (values (max min0 min1) max0 min1 (min max0 max1))) + ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1))))) + (define (infer-real-ranges) + (match op + ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1)) + ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1))))) + (if (= (logior type0 type1) &exact-integer) + (infer-integer-ranges) + (infer-real-ranges))) + +(define-syntax-rule (define-comparison-inferrer (op inverse)) + (define-predicate-inferrer (op a b true?) + (when (zero? (logand (logior (&type a) (&type b)) (lognot &number))) + (call-with-values + (lambda () + (restricted-comparison-ranges (if true? 'op 'inverse) + (&type a) (&min a) (&max a) + (&type b) (&min b) (&max b))) + (lambda (min0 max0 min1 max1) + (restrict! a &real min0 max0) + (restrict! b &real min1 max1)))))) + +(define-simple-type-checker (< &real &real)) +(define-comparison-inferrer (< >=)) + +(define-simple-type-checker (<= &real &real)) +(define-comparison-inferrer (<= >)) + +(define-simple-type-checker (>= &real &real)) +(define-comparison-inferrer (>= <)) + +(define-simple-type-checker (> &real &real)) +(define-comparison-inferrer (> <=)) + +;; Arithmetic. +(define-syntax-rule (define-unary-result! a result min max) + (let ((min* min) + (max* max) + (type (logand (&type a) &number))) + (cond + ((not (= type (&type a))) + ;; Not a number. Punt and do nothing. + (define! result &all-types -inf.0 +inf.0)) + ;; Complex numbers don't have a range. + ((eqv? type &complex) + (define! result &complex -inf.0 +inf.0)) + (else + (define! result type min* max*))))) + +(define-syntax-rule (define-binary-result! a b result closed? min max) + (let ((min* min) + (max* max) + (a-type (logand (&type a) &number)) + (b-type (logand (&type b) &number))) + (cond + ((or (not (= a-type (&type a))) (not (= b-type (&type b)))) + ;; One input not a number. Perhaps we end up dispatching to + ;; GOOPS. + (define! result &all-types -inf.0 +inf.0)) + ;; Complex and floating-point numbers are contagious. + ((or (eqv? a-type &complex) (eqv? b-type &complex)) + (define! result &complex -inf.0 +inf.0)) + ((or (eqv? a-type &flonum) (eqv? b-type &flonum)) + (define! result &flonum min* max*)) + ;; Exact integers are closed under some operations. + ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer)) + (define! result &exact-integer min* max*)) + (else + ;; Fractions may become integers. + (let ((type (logior a-type b-type))) + (define! result + (if (zero? (logand type &fraction)) + type + (logior type &exact-integer)) + min* max*)))))) + +(define-simple-type-checker (add &number &number)) +(define-type-inferrer (add a b result) + (define-binary-result! a b result #t + (+ (&min a) (&min b)) + (+ (&max a) (&max b)))) + +(define-simple-type-checker (sub &number &number)) +(define-type-inferrer (sub a b result) + (define-binary-result! a b result #t + (- (&min a) (&max b)) + (- (&max a) (&min b)))) + +(define-simple-type-checker (mul &number &number)) +(define-type-inferrer (mul a b result) + (let ((min-a (&min a)) (max-a (&max a)) + (min-b (&min b)) (max-b (&max b)) + ;; We only really get +inf.0 at runtime for flonums and + ;; compnums. If we have inferred that the arguments are not + ;; flonums and not compnums, then the result of (* +inf.0 0) at + ;; range inference time is 0 and not +nan.0. + (nan-impossible? (not (logtest (logior (&type a) (&type b)) + (logior &flonum &complex))))) + (define (nan* a b) + (if (and (or (and (inf? a) (zero? b)) + (and (zero? a) (inf? b))) + nan-impossible?) + 0 + (* a b))) + (let ((-- (nan* min-a min-b)) + (-+ (nan* min-a max-b)) + (++ (nan* max-a max-b)) + (+- (nan* max-a min-b))) + (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-)))) + (define-binary-result! a b result #t + (cond + ((eqv? a b) 0) + (has-nan? -inf.0) + (else (min -- -+ ++ +-))) + (if has-nan? + +inf.0 + (max -- -+ ++ +-))))))) + +(define-type-checker (div a b) + (and (check-type a &number -inf.0 +inf.0) + (check-type b &number -inf.0 +inf.0) + ;; We only know that there will not be an exception if b is not + ;; zero. + (not (<= (&min b) 0 (&max b))))) +(define-type-inferrer (div a b result) + (let ((min-a (&min a)) (max-a (&max a)) + (min-b (&min b)) (max-b (&max b))) + (call-with-values + (lambda () + (if (<= min-b 0 max-b) + ;; If the range of the divisor crosses 0, the result spans + ;; the whole range. + (values -inf.0 +inf.0) + ;; Otherwise min-b and max-b have the same sign, and cannot both + ;; be infinity. + (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b))) + (-+- (if (inf? max-b) 0 (floor/ min-a max-b))) + (++- (if (inf? max-b) 0 (floor/ max-a max-b))) + (+-- (if (inf? min-b) 0 (floor/ max-a min-b))) + (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b))) + (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b))) + (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b))) + (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b)))) + (values (min (min --- -+- ++- +--) + (min --+ -++ +++ +-+)) + (max (max --- -+- ++- +--) + (max --+ -++ +++ +-+)))))) + (lambda (min max) + (define-binary-result! a b result #f min max))))) + +(define-simple-type-checker (add1 &number)) +(define-type-inferrer (add1 a result) + (define-unary-result! a result (1+ (&min a)) (1+ (&max a)))) + +(define-simple-type-checker (sub1 &number)) +(define-type-inferrer (sub1 a result) + (define-unary-result! a result (1- (&min a)) (1- (&max a)))) + +(define-type-checker (quo a b) + (and (check-type a &exact-integer -inf.0 +inf.0) + (check-type b &exact-integer -inf.0 +inf.0) + ;; We only know that there will not be an exception if b is not + ;; zero. + (not (<= (&min b) 0 (&max b))))) +(define-type-inferrer (quo a b result) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (define! result &exact-integer -inf.0 +inf.0)) + +(define-type-checker-aliases quo rem) +(define-type-inferrer (rem a b result) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + ;; Same sign as A. + (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b)))))) + (cond + ((< (&min a) 0) + (if (< 0 (&max a)) + (define! result &exact-integer (- max-abs-rem) max-abs-rem) + (define! result &exact-integer (- max-abs-rem) 0))) + (else + (define! result &exact-integer 0 max-abs-rem))))) + +(define-type-checker-aliases quo mod) +(define-type-inferrer (mod a b result) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + ;; Same sign as B. + (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b)))))) + (cond + ((< (&min b) 0) + (if (< 0 (&max b)) + (define! result &exact-integer (- max-abs-mod) max-abs-mod) + (define! result &exact-integer (- max-abs-mod) 0))) + (else + (define! result &exact-integer 0 max-abs-mod))))) + +;; Predicates. +(define-syntax-rule (define-number-kind-predicate-inferrer name type) + (define-type-inferrer (name val result) + (cond + ((zero? (logand (&type val) type)) + (define! result &false 0 0)) + ((zero? (logand (&type val) (lognot type))) + (define! result &true 0 0)) + (else + (define! result (logior &true &false) 0 0))))) +(define-number-kind-predicate-inferrer complex? &number) +(define-number-kind-predicate-inferrer real? &real) +(define-number-kind-predicate-inferrer rational? + (logior &exact-integer &fraction)) +(define-number-kind-predicate-inferrer integer? + (logior &exact-integer &flonum)) +(define-number-kind-predicate-inferrer exact-integer? + &exact-integer) + +(define-simple-type-checker (exact? &number)) +(define-type-inferrer (exact? val result) + (restrict! val &number -inf.0 +inf.0) + (cond + ((zero? (logand (&type val) (logior &exact-integer &fraction))) + (define! result &false 0 0)) + ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction)))) + (define! result &true 0 0)) + (else + (define! result (logior &true &false) 0 0)))) + +(define-simple-type-checker (inexact? &number)) +(define-type-inferrer (inexact? val result) + (restrict! val &number -inf.0 +inf.0) + (cond + ((zero? (logand (&type val) (logior &flonum &complex))) + (define! result &false 0 0)) + ((zero? (logand (&type val) (logand &number + (lognot (logior &flonum &complex))))) + (define! result &true 0 0)) + (else + (define! result (logior &true &false) 0 0)))) + +(define-simple-type-checker (inf? &real)) +(define-type-inferrer (inf? val result) + (restrict! val &real -inf.0 +inf.0) + (cond + ((or (zero? (logand (&type val) (logior &flonum &complex))) + (and (not (inf? (&min val))) (not (inf? (&max val))))) + (define! result &false 0 0)) + (else + (define! result (logior &true &false) 0 0)))) + +(define-type-aliases inf? nan?) + +(define-simple-type (even? &exact-integer) + ((logior &true &false) 0 0)) +(define-type-aliases even? odd?) + +;; Bit operations. +(define-simple-type-checker (ash &exact-integer &exact-integer)) +(define-type-inferrer (ash val count result) + (define (ash* val count) + ;; As we can only represent a 32-bit range, don't bother inferring + ;; shifts that might exceed that range. + (cond + ((inf? val) val) ; Preserves sign. + ((< -32 count 32) (ash val count)) + ((zero? val) 0) + ((positive? val) +inf.0) + (else -inf.0))) + (restrict! val &exact-integer -inf.0 +inf.0) + (restrict! count &exact-integer -inf.0 +inf.0) + (let ((-- (ash* (&min val) (&min count))) + (-+ (ash* (&min val) (&max count))) + (++ (ash* (&max val) (&max count))) + (+- (ash* (&max val) (&min count)))) + (define! result &exact-integer + (min -- -+ ++ +-) + (max -- -+ ++ +-)))) + +(define (next-power-of-two n) + (let lp ((out 1)) + (if (< n out) + out + (lp (ash out 1))))) + +(define-simple-type-checker (logand &exact-integer &exact-integer)) +(define-type-inferrer (logand a b result) + (define (logand-min a b) + (if (and (negative? a) (negative? b)) + (min a b) + 0)) + (define (logand-max a b) + (if (and (positive? a) (positive? b)) + (min a b) + 0)) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (define! result &exact-integer + (logand-min (&min a) (&min b)) + (logand-max (&max a) (&max b)))) + +(define-simple-type-checker (logior &exact-integer &exact-integer)) +(define-type-inferrer (logior a b result) + ;; Saturate all bits of val. + (define (saturate val) + (1- (next-power-of-two val))) + (define (logior-min a b) + (cond ((and (< a 0) (<= 0 b)) a) + ((and (< b 0) (<= 0 a)) b) + (else (max a b)))) + (define (logior-max a b) + ;; If either operand is negative, just assume the max is -1. + (cond + ((or (< a 0) (< b 0)) -1) + ((or (inf? a) (inf? b)) +inf.0) + (else (saturate (logior a b))))) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (define! result &exact-integer + (logior-min (&min a) (&min b)) + (logior-max (&max a) (&max b)))) + +;; For our purposes, treat logxor the same as logior. +(define-type-aliases logior logxor) + +(define-simple-type-checker (lognot &exact-integer)) +(define-type-inferrer (lognot a result) + (restrict! a &exact-integer -inf.0 +inf.0) + (define! result &exact-integer + (- -1 (&max a)) + (- -1 (&min a)))) + +(define-simple-type-checker (logtest &exact-integer &exact-integer)) +(define-predicate-inferrer (logtest a b true?) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0)) + +(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer)) +(define-type-inferrer (logbit? a b result) + (let ((a-min (&min a)) + (a-max (&max a)) + (b-min (&min b)) + (b-max (&max b))) + (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min)) + (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min))) + (let ((type (if (logbit? a-min b-min) &true &false))) + (define! result type 0 0)) + (define! result (logior &true &false) 0 0)))) + +;; Flonums. +(define-simple-type-checker (sqrt &number)) +(define-type-inferrer (sqrt x result) + (let ((type (&type x))) + (cond + ((and (zero? (logand type &complex)) (<= 0 (&min x))) + (define! result + (logior type &flonum) + (inexact->exact (floor (sqrt (&min x)))) + (if (inf? (&max x)) + +inf.0 + (inexact->exact (ceiling (sqrt (&max x))))))) + (else + (define! result (logior type &flonum &complex) -inf.0 +inf.0))))) + +(define-simple-type-checker (abs &real)) +(define-type-inferrer (abs x result) + (let ((type (&type x))) + (cond + ((eqv? type (logand type &number)) + (restrict! x &real -inf.0 +inf.0) + (define! result (logand type &real) + (min (abs (&min x)) (abs (&max x))) + (max (abs (&min x)) (abs (&max x))))) + (else + (define! result (logior (logand (&type x) (lognot &number)) + (logand (&type x) &real)) + (max (&min x) 0) + (max (abs (&min x)) (abs (&max x)))))))) + + + + +;;; +;;; Characters. +;;; + +(define-simple-type (char<? &char &char) + ((logior &true &false) 0 0)) +(define-type-aliases char<? char<=? char>=? char>?) + +(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff))) +(define-type-inferrer (integer->char i result) + (restrict! i &exact-integer 0 #x10ffff) + (define! result &char (max (&min i) 0) (min (&max i) #x10ffff))) + +(define-simple-type-checker (char->integer &char)) +(define-type-inferrer (char->integer c result) + (restrict! c &char 0 #x10ffff) + (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff))) + + + + +;;; +;;; Type flow analysis: the meet (ahem) of the algorithm. +;;; + +(define (successor-count cont) + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (match exp + ((or ($ $branch) ($ $prompt)) 2) + (_ 1))) + (($ $kfun src meta self tail clause) (if clause 1 0)) + (($ $kclause arity body alt) (if alt 2 1)) + (($ $kreceive) 1) + (($ $ktail) 0))) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define-syntax-rule (make-worklist-folder* seed ...) + (lambda (f worklist seed ...) + (let lp ((worklist worklist) (seed seed) ...) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist i) + (if i + (call-with-values (lambda () (f i seed ...)) + (lambda (i* seed ...) + (let add ((i* i*) (worklist worklist)) + (match i* + (() (lp worklist seed ...)) + ((i . i*) (add i* (intset-add worklist i))))))) + (values seed ...))))))) + +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) + +(define intmap-ensure + (let* ((*absent* (list 'absent)) + (not-found (lambda (i) *absent*))) + (lambda (map i ensure) + (let ((val (intmap-ref map i not-found))) + (if (eq? val *absent*) + (let ((val (ensure i))) + (values (intmap-add map i val) val)) + (values map val)))))) + +;; For best results, the labels in the function starting should be +;; topologically sorted (renumbered). Otherwise the backward branch +;; detection mentioned in the module commentary will trigger for +;; ordinary forward branches. +(define (infer-types conts kfun) + "Compute types for all variables bound in the function labelled +@var{kfun}, from @var{conts}. Returns an intmap mapping labels to type +entries. + +A type entry is a vector that describes the types of the values that +flow into and out of a labelled expressoin. The first slot in the type +entry vector corresponds to the types that flow in, and the rest of the +slots correspond to the types that flow out. Each element of the type +entry vector is an intmap mapping variable name to the variable's +inferred type. An inferred type is a 3-vector of type, minimum, and +maximum, where type is a bitset as a fixnum." + (define (get-entry typev label) (intmap-ref typev label)) + (define (entry-not-found label) + (make-vector (1+ (successor-count (intmap-ref conts label))) #f)) + (define (ensure-entry typev label) + (intmap-ensure typev label entry-not-found)) + + (define (compute-initial-state) + (let ((entry (entry-not-found kfun))) + ;; Nothing flows in to the first label. + (vector-set! entry 0 empty-intmap) + (intmap-add empty-intmap kfun entry))) + + (define (adjoin-vars types vars entry) + (match vars + (() types) + ((var . vars) + (adjoin-vars (adjoin-var types var entry) vars entry)))) + + (define (infer-primcall types succ name args result) + (cond + ((hashq-ref *type-inferrers* name) + => (lambda (inferrer) + ;; FIXME: remove the apply? + ;; (pk 'primcall name args result) + (apply inferrer types succ + (if result + (append args (list result)) + args)))) + (result + (adjoin-var types result all-types-entry)) + (else + types))) + + (define (vector-replace vec idx val) + (let ((vec (vector-copy vec))) + (vector-set! vec idx val) + vec)) + + (define (update-out-types label typev types succ-idx) + (let* ((entry (get-entry typev label)) + (old-types (vector-ref entry (1+ succ-idx)))) + (if (eq? types old-types) + (values typev #f) + (let ((entry (vector-replace entry (1+ succ-idx) types)) + (first? (not old-types))) + (values (intmap-replace typev label entry) first?))))) + + (define (update-in-types label typev types saturate?) + (let*-values (((typev entry) (ensure-entry typev label)) + ((old-types) (vector-ref entry 0)) + ;; TODO: If the label has only one predecessor, we can + ;; avoid the meet. + ((types) (if (not old-types) + types + (let ((meet (if saturate? + type-entry-saturating-union + type-entry-union))) + (intmap-intersect old-types types meet))))) + (if (eq? old-types types) + (values typev #f) + (let ((entry (vector-replace entry 0 types))) + (values (intmap-replace typev label entry) #t))))) + + (define (propagate-types label typev succ-idx succ-label types) + (let*-values + (((typev first?) (update-out-types label typev types succ-idx)) + ((saturate?) (and (not first?) (<= succ-label label))) + ((typev changed?) (update-in-types succ-label typev types saturate?))) + (values (if changed? (list succ-label) '()) typev))) + + (define (visit-exp label typev k types exp) + (define (propagate1 succ-label types) + (propagate-types label typev 0 succ-label types)) + (define (propagate2 succ0-label types0 succ1-label types1) + (let*-values (((changed0 typev) + (propagate-types label typev 0 succ0-label types0)) + ((changed1 typev) + (propagate-types label typev 1 succ1-label types1))) + (values (append changed0 changed1) typev))) + ;; Each of these branches must propagate to its successors. + (match exp + (($ $branch kt ($ $values (arg))) + ;; The "normal" continuation is the #f branch. + (let ((kf-types (restrict-var types arg + (make-type-entry (logior &false &nil) + 0 + 0))) + (kt-types (restrict-var types arg + (make-type-entry + (logand &all-types + (lognot (logior &false &nil))) + -inf.0 +inf.0)))) + (propagate2 k kf-types kt kt-types))) + (($ $branch kt ($ $primcall name args)) + ;; The "normal" continuation is the #f branch. + (let ((kf-types (infer-primcall types 0 name args #f)) + (kt-types (infer-primcall types 1 name args #f))) + (propagate2 k kf-types kt kt-types))) + (($ $prompt escape? tag handler) + ;; The "normal" continuation enters the prompt. + (propagate2 k types handler types)) + (($ $primcall name args) + (propagate1 k + (match (intmap-ref conts k) + (($ $kargs _ defs) + (infer-primcall types 0 name args + (match defs ((var) var) (() #f)))) + (_ + ;; (pk 'warning-no-restrictions name) + types)))) + (($ $values args) + (match (intmap-ref conts k) + (($ $kargs _ defs) + (let ((in types)) + (let lp ((defs defs) (args args) (out types)) + (match (cons defs args) + ((() . ()) + (propagate1 k out)) + (((def . defs) . (arg . args)) + (lp defs args + (adjoin-var out def (var-type-entry in arg)))))))) + (_ + (propagate1 k types)))) + ((or ($ $call) ($ $callk)) + (propagate1 k types)) + (($ $rec names vars funs) + (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0))) + (propagate1 k (adjoin-vars types vars proc-type)))) + (_ + (match (intmap-ref conts k) + (($ $kargs (_) (var)) + (let ((entry (match exp + (($ $const val) + (constant-type val)) + ((or ($ $prim) ($ $fun) ($ $closure)) + ;; Could be more precise here. + (make-type-entry &procedure -inf.0 +inf.0))))) + (propagate1 k (adjoin-var types var entry)))))))) + + (define (visit-cont label typev) + (let ((types (vector-ref (intmap-ref typev label) 0))) + (define (propagate0) + (values '() typev)) + (define (propagate1 succ-label types) + (propagate-types label typev 0 succ-label types)) + (define (propagate2 succ0-label types0 succ1-label types1) + (let*-values (((changed0 typev) + (propagate-types label typev 0 succ0-label types0)) + ((changed1 typev) + (propagate-types label typev 1 succ1-label types1))) + (values (append changed0 changed1) typev))) + + ;; Add types for new definitions, and restrict types of + ;; existing variables due to side effects. + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-exp label typev k types exp)) + (($ $kreceive arity k) + (match (intmap-ref conts k) + (($ $kargs names vars) + (propagate1 k (adjoin-vars types vars all-types-entry))))) + (($ $kfun src meta self tail clause) + (if clause + (propagate1 clause (adjoin-var types self all-types-entry)) + (propagate0))) + (($ $kclause arity kbody kalt) + (match (intmap-ref conts kbody) + (($ $kargs _ defs) + (let ((body-types (adjoin-vars types defs all-types-entry))) + (if kalt + (propagate2 kbody body-types kalt types) + (propagate1 kbody body-types)))))) + (($ $ktail) (propagate0))))) + + (worklist-fold* visit-cont + (intset-add empty-intset kfun) + (compute-initial-state))) + +(define (lookup-pre-type types label def) + (let* ((entry (intmap-ref types label)) + (tentry (var-type-entry (vector-ref entry 0) def))) + (values (type-entry-type tentry) + (type-entry-min tentry) + (type-entry-max tentry)))) + +(define (lookup-post-type types label def succ-idx) + (let* ((entry (intmap-ref types label)) + (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def))) + (values (type-entry-type tentry) + (type-entry-min tentry) + (type-entry-max tentry)))) + +(define (primcall-types-check? types label name args) + (match (hashq-ref *type-checkers* name) + (#f #f) + (checker + (let ((entry (intmap-ref types label))) + (apply checker (vector-ref entry 0) args))))) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm new file mode 100644 index 000000000..fa4673c4e --- /dev/null +++ b/module/language/cps/utils.scm @@ -0,0 +1,477 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Helper facilities for working with CPS. +;;; +;;; Code: + +(define-module (language cps utils) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:export (;; Fresh names. + label-counter var-counter + fresh-label fresh-var + with-fresh-name-state compute-max-label-and-var + let-fresh + + ;; Various utilities. + fold1 fold2 + trivial-intset + intmap-map + intmap-keys + invert-bijection invert-partition + intset->intmap + worklist-fold + fixpoint + + ;; Flow analysis. + compute-constant-values + compute-function-body + compute-reachable-functions + compute-successors + invert-graph + compute-predecessors + compute-reverse-post-order + compute-strongly-connected-components + compute-sorted-strongly-connected-components + compute-idoms + compute-dom-edges + )) + +(define label-counter (make-parameter #f)) +(define var-counter (make-parameter #f)) + +(define (fresh-label) + (let ((count (or (label-counter) + (error "fresh-label outside with-fresh-name-state")))) + (label-counter (1+ count)) + count)) + +(define (fresh-var) + (let ((count (or (var-counter) + (error "fresh-var outside with-fresh-name-state")))) + (var-counter (1+ count)) + count)) + +(define-syntax-rule (let-fresh (label ...) (var ...) body ...) + (let* ((label (fresh-label)) ... + (var (fresh-var)) ...) + body ...)) + +(define-syntax-rule (with-fresh-name-state fun body ...) + (call-with-values (lambda () (compute-max-label-and-var fun)) + (lambda (max-label max-var) + (parameterize ((label-counter (1+ max-label)) + (var-counter (1+ max-var))) + body ...)))) + +(define (compute-max-label-and-var conts) + (values (or (intmap-prev conts) -1) + (intmap-fold (lambda (k cont max-var) + (match cont + (($ $kargs names syms body) + (apply max max-var syms)) + (($ $kfun src meta self) + (max max-var self)) + (_ max-var))) + conts + -1))) + +(define-inlinable (fold1 f l s0) + (let lp ((l l) (s0 s0)) + (match l + (() s0) + ((elt . l) (lp l (f elt s0)))))) + +(define-inlinable (fold2 f l s0 s1) + (let lp ((l l) (s0 s0) (s1 s1)) + (match l + (() (values s0 s1)) + ((elt . l) + (call-with-values (lambda () (f elt s0 s1)) + (lambda (s0 s1) + (lp l s0 s1))))))) + +(define (trivial-intset set) + "Returns the sole member of @var{set}, if @var{set} has exactly one +member, or @code{#f} otherwise." + (let ((first (intset-next set))) + (and first + (not (intset-next set (1+ first))) + first))) + +(define (intmap-map proc map) + (persistent-intmap + (intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v))) + map + map))) + +(define (intmap-keys map) + "Return an intset of the keys in @var{map}." + (persistent-intset + (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset))) + +(define (invert-bijection map) + "Assuming the values of @var{map} are integers and are unique, compute +a map in which each value maps to its key. If the values are not +unique, an error will be signalled." + (intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap)) + +(define (invert-partition map) + "Assuming the values of @var{map} are disjoint intsets, compute a map +in which each member of each set maps to its key. If the values are not +disjoint, an error will be signalled." + (intmap-fold (lambda (k v* out) + (intset-fold (lambda (v out) (intmap-add out v k)) v* out)) + map empty-intmap)) + +(define (intset->intmap f set) + (persistent-intmap + (intset-fold (lambda (label preds) + (intmap-add! preds label (f label))) + set empty-intmap))) + +(define worklist-fold + (case-lambda + ((f in out) + (let lp ((in in) (out out)) + (if (eq? in empty-intset) + out + (call-with-values (lambda () (f in out)) lp)))) + ((f in out0 out1) + (let lp ((in in) (out0 out0) (out1 out1)) + (if (eq? in empty-intset) + (values out0 out1) + (call-with-values (lambda () (f in out0 out1)) lp)))))) + +(define fixpoint + (case-lambda + ((f x) + (let lp ((x x)) + (let ((x* (f x))) + (if (eq? x x*) x* (lp x*))))) + ((f x0 x1) + (let lp ((x0 x0) (x1 x1)) + (call-with-values (lambda () (f x0 x1)) + (lambda (x0* x1*) + (if (and (eq? x0 x0*) (eq? x1 x1*)) + (values x0* x1*) + (lp x0* x1*)))))))) + +(define (compute-defining-expressions conts) + (define (meet-defining-expressions old new) + ;; If there are multiple definitions, punt and + ;; record #f. + #f) + (persistent-intmap + (intmap-fold (lambda (label cont defs) + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (match (intmap-ref conts k) + (($ $kargs (_) (var)) + (intmap-add! defs var exp meet-defining-expressions)) + (_ defs))) + (_ defs))) + conts + empty-intmap))) + +(define (compute-constant-values conts) + (persistent-intmap + (intmap-fold (lambda (var exp out) + (match exp + (($ $const val) + (intmap-add! out var val)) + (_ out))) + (compute-defining-expressions conts) + empty-intmap))) + +(define (compute-function-body conts kfun) + (persistent-intset + (let visit-cont ((label kfun) (labels empty-intset)) + (cond + ((intset-ref labels label) labels) + (else + (let ((labels (intset-add! labels label))) + (match (intmap-ref conts label) + (($ $kreceive arity k) (visit-cont k labels)) + (($ $kfun src meta self ktail kclause) + (let ((labels (visit-cont ktail labels))) + (if kclause + (visit-cont kclause labels) + labels))) + (($ $ktail) labels) + (($ $kclause arity kbody kalt) + (if kalt + (visit-cont kalt (visit-cont kbody labels)) + (visit-cont kbody labels))) + (($ $kargs names syms ($ $continue k src exp)) + (visit-cont k (match exp + (($ $branch k) + (visit-cont k labels)) + (($ $prompt escape? tag k) + (visit-cont k labels)) + (_ labels))))))))))) + +(define (compute-reachable-functions conts kfun) + "Compute a mapping LABEL->LABEL..., where each key is a reachable +$kfun and each associated value is the body of the function, as an +intset." + (define (intset-cons i set) (intset-add set i)) + (define (visit-fun kfun body to-visit) + (intset-fold + (lambda (label to-visit) + (define (return kfun*) (fold intset-cons to-visit kfun*)) + (define (return1 kfun) (intset-add to-visit kfun)) + (define (return0) to-visit) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + (($ $fun label) (return1 label)) + (($ $rec _ _ (($ $fun labels) ...)) (return labels)) + (($ $closure label nfree) (return1 label)) + (($ $callk label) (return1 label)) + (_ (return0)))) + (_ (return0)))) + body + to-visit)) + (let lp ((to-visit (intset kfun)) (visited empty-intmap)) + (let ((to-visit (intset-subtract to-visit (intmap-keys visited)))) + (if (eq? to-visit empty-intset) + visited + (call-with-values + (lambda () + (intset-fold + (lambda (kfun to-visit visited) + (let ((body (compute-function-body conts kfun))) + (values (visit-fun kfun body to-visit) + (intmap-add visited kfun body)))) + to-visit + empty-intset + visited)) + lp))))) + +(define* (compute-successors conts #:optional (kfun (intmap-next conts))) + (define (visit label succs) + (let visit ((label kfun) (succs empty-intmap)) + (define (propagate0) + (intmap-add! succs label empty-intset)) + (define (propagate1 succ) + (visit succ (intmap-add! succs label (intset succ)))) + (define (propagate2 succ0 succ1) + (let ((succs (intmap-add! succs label (intset succ0 succ1)))) + (visit succ1 (visit succ0 succs)))) + (if (intmap-ref succs label (lambda (_) #f)) + succs + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $branch kt) (propagate2 k kt)) + (($ $prompt escape? tag handler) (propagate2 k handler)) + (_ (propagate1 k)))) + (($ $kreceive arity k) + (propagate1 k)) + (($ $kfun src meta self tail clause) + (if clause + (propagate2 clause tail) + (propagate1 tail))) + (($ $kclause arity kbody kalt) + (if kalt + (propagate2 kbody kalt) + (propagate1 kbody))) + (($ $ktail) (propagate0)))))) + (persistent-intmap (visit kfun empty-intmap))) + +(define* (compute-predecessors conts kfun #:key + (labels (compute-function-body conts kfun))) + (define (meet cdr car) + (cons car cdr)) + (define (add-preds label preds) + (define (add-pred k preds) + (intmap-add! preds k label meet)) + (match (intmap-ref conts label) + (($ $kreceive arity k) + (add-pred k preds)) + (($ $kfun src meta self ktail kclause) + (add-pred ktail (if kclause (add-pred kclause preds) preds))) + (($ $ktail) + preds) + (($ $kclause arity kbody kalt) + (add-pred kbody (if kalt (add-pred kalt preds) preds))) + (($ $kargs names syms ($ $continue k src exp)) + (add-pred k + (match exp + (($ $branch k) (add-pred k preds)) + (($ $prompt _ _ k) (add-pred k preds)) + (_ preds)))))) + (persistent-intmap + (intset-fold add-preds labels + (intset->intmap (lambda (label) '()) labels)))) + +(define (compute-reverse-post-order succs start) + "Compute a reverse post-order numbering for a depth-first walk over +nodes reachable from the start node." + (let visit ((label start) (order '()) (visited empty-intset)) + (call-with-values + (lambda () + (intset-fold (lambda (succ order visited) + (if (intset-ref visited succ) + (values order visited) + (visit succ order visited))) + (intmap-ref succs label) + order + (intset-add! visited label))) + (lambda (order visited) + ;; After visiting successors, add label to the reverse post-order. + (values (cons label order) visited))))) + +(define (invert-graph succs) + "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an +intset of successors, return a graph SUCC->PRED...." + (intmap-fold (lambda (pred succs preds) + (intset-fold + (lambda (succ preds) + (intmap-add preds succ pred intset-add)) + succs + preds)) + succs + (intmap-map (lambda (label _) empty-intset) succs))) + +(define (compute-strongly-connected-components succs start) + "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map +partitioning the labels into strongly connected components (SCCs)." + (let ((preds (invert-graph succs))) + (define (visit-scc scc sccs-by-label) + (let visit ((label scc) (sccs-by-label sccs-by-label)) + (if (intmap-ref sccs-by-label label (lambda (_) #f)) + sccs-by-label + (intset-fold visit + (intmap-ref preds label) + (intmap-add sccs-by-label label scc))))) + (intmap-fold + (lambda (label scc sccs) + (let ((labels (intset-add empty-intset label))) + (intmap-add sccs scc labels intset-union))) + (fold visit-scc empty-intmap (compute-reverse-post-order succs start)) + empty-intmap))) + +(define (compute-sorted-strongly-connected-components edges) + "Given a LABEL->SUCCESSOR... graph, return a list of strongly +connected components in sorted order." + (define nodes + (intmap-keys edges)) + ;; Add a "start" node that links to all nodes in the graph, and then + ;; remove it from the result. + (define start + (if (eq? nodes empty-intset) + 0 + (1+ (intset-prev nodes)))) + (define components + (intmap-remove + (compute-strongly-connected-components (intmap-add edges start nodes) + start) + start)) + (define node-components + (intmap-fold (lambda (id nodes out) + (intset-fold (lambda (node out) (intmap-add out node id)) + nodes out)) + components + empty-intmap)) + (define (node-component node) + (intmap-ref node-components node)) + (define (component-successors id nodes) + (intset-remove + (intset-fold (lambda (node out) + (intset-fold + (lambda (successor out) + (intset-add out (node-component successor))) + (intmap-ref edges node) + out)) + nodes + empty-intset) + id)) + (define component-edges + (intmap-map component-successors components)) + (define preds + (invert-graph component-edges)) + (define roots + (intmap-fold (lambda (id succs out) + (if (eq? empty-intset succs) + (intset-add out id) + out)) + component-edges + empty-intset)) + ;; As above, add a "start" node that links to the roots, and remove it + ;; from the result. + (match (compute-reverse-post-order (intmap-add preds start roots) start) + (((? (lambda (id) (eqv? id start))) . ids) + (map (lambda (id) (intmap-ref components id)) ids)))) + +;; Precondition: For each function in CONTS, the continuation names are +;; topologically sorted. +(define (compute-idoms conts kfun) + ;; This is the iterative O(n^2) fixpoint algorithm, originally from + ;; Allen and Cocke ("Graph-theoretic constructs for program flow + ;; analysis", 1972). See the discussion in Cooper, Harvey, and + ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. + (let ((preds-map (compute-predecessors conts kfun))) + (define (compute-idom idoms preds) + (define (idom-ref label) + (intmap-ref idoms label (lambda (_) #f))) + (match preds + (() -1) + ((pred) pred) ; Shortcut. + ((pred . preds) + (define (common-idom d0 d1) + ;; We exploit the fact that a reverse post-order is a + ;; topological sort, and so the idom of a node is always + ;; numerically less than the node itself. + (let lp ((d0 d0) (d1 d1)) + (cond + ;; d0 or d1 can be false on the first iteration. + ((not d0) d1) + ((not d1) d0) + ((= d0 d1) d0) + ((< d0 d1) (lp d0 (idom-ref d1))) + (else (lp (idom-ref d0) d1))))) + (fold1 common-idom preds pred)))) + (define (adjoin-idom label preds idoms) + (let ((idom (compute-idom idoms preds))) + ;; Don't use intmap-add! here. + (intmap-add idoms label idom (lambda (old new) new)))) + (fixpoint (lambda (idoms) + (intmap-fold adjoin-idom preds-map idoms)) + empty-intmap))) + +;; Compute a vector containing, for each node, a list of the nodes that +;; it immediately dominates. These are the "D" edges in the DJ tree. +(define (compute-dom-edges idoms) + (define (snoc cdr car) (cons car cdr)) + (persistent-intmap + (intmap-fold (lambda (label idom doms) + (let ((doms (intmap-add! doms label '()))) + (cond + ((< idom 0) doms) ;; No edge to entry. + (else (intmap-add! doms idom label snoc))))) + idoms + empty-intmap))) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm new file mode 100644 index 000000000..f4413af0d --- /dev/null +++ b/module/language/cps/verify.scm @@ -0,0 +1,306 @@ +;;; Diagnostic checker for CPS +;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; A routine to detect invalid CPS. +;;; +;;; Code: + +(define-module (language cps verify) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (language cps primitives) + #:use-module (srfi srfi-11) + #:export (verify)) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define-syntax-rule (make-worklist-folder* seed ...) + (lambda (f worklist seed ...) + (let lp ((worklist worklist) (seed seed) ...) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist i) + (if i + (call-with-values (lambda () (f i seed ...)) + (lambda (i* seed ...) + (let add ((i* i*) (worklist worklist)) + (match i* + (() (lp worklist seed ...)) + ((i . i*) (add i* (intset-add worklist i))))))) + (values seed ...))))))) + +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) + +(define (check-distinct-vars conts) + (define (adjoin-def var seen) + (when (intset-ref seen var) + (error "duplicate var name" seen var)) + (intset-add seen var)) + (intmap-fold + (lambda (label cont seen) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (fold1 adjoin-def vars seen)) + (($ $kfun src meta self tail clause) + (adjoin-def self seen)) + (_ seen)) + ) + conts + empty-intset)) + +(define (compute-available-definitions conts kfun) + "Compute and return a map of LABEL->VAR..., where VAR... are the +definitions that are available at LABEL." + (define (adjoin-def var defs) + (when (intset-ref defs var) + (error "var already present in defs" defs var)) + (intset-add defs var)) + + (define (propagate defs succ out) + (let* ((in (intmap-ref defs succ (lambda (_) #f))) + (in* (if in (intset-intersect in out) out))) + (if (eq? in in*) + (values '() defs) + (values (list succ) + (intmap-add defs succ in* (lambda (old new) new)))))) + + (define (visit-cont label defs) + (let ((in (intmap-ref defs label))) + (define (propagate0 out) + (values '() defs)) + (define (propagate1 succ out) + (propagate defs succ out)) + (define (propagate2 succ0 succ1 out) + (let*-values (((changed0 defs) (propagate defs succ0 out)) + ((changed1 defs) (propagate defs succ1 out))) + (values (append changed0 changed1) defs))) + + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (let ((out (fold1 adjoin-def vars in))) + (match exp + (($ $branch kt) (propagate2 k kt out)) + (($ $prompt escape? tag handler) (propagate2 k handler out)) + (_ (propagate1 k out))))) + (($ $kreceive arity k) + (propagate1 k in)) + (($ $kfun src meta self tail clause) + (let ((out (adjoin-def self in))) + (if clause + (propagate1 clause out) + (propagate0 out)))) + (($ $kclause arity kbody kalt) + (if kalt + (propagate2 kbody kalt in) + (propagate1 kbody in))) + (($ $ktail) (propagate0 in))))) + + (worklist-fold* visit-cont + (intset kfun) + (intmap-add empty-intmap kfun empty-intset))) + +(define (intmap-for-each f map) + (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) + +(define (check-valid-var-uses conts kfun) + (define (adjoin-def var defs) (intset-add defs var)) + (let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset)) + (define (visit-exp exp bound first-order) + (define (check-use var) + (unless (intset-ref bound var) + (error "unbound var" var))) + (define (visit-first-order kfun) + (if (intset-ref first-order kfun) + first-order + (visit-fun kfun empty-intset (intset-add first-order kfun)))) + (match exp + ((or ($ $const) ($ $prim)) first-order) + ;; todo: $closure + (($ $fun kfun) + (visit-fun kfun bound first-order)) + (($ $closure kfun) + (visit-first-order kfun)) + (($ $rec names vars (($ $fun kfuns) ...)) + (let ((bound (fold1 adjoin-def vars bound))) + (fold1 (lambda (kfun first-order) + (visit-fun kfun bound first-order)) + kfuns first-order))) + (($ $values args) + (for-each check-use args) + first-order) + (($ $call proc args) + (check-use proc) + (for-each check-use args) + first-order) + (($ $callk kfun proc args) + (check-use proc) + (for-each check-use args) + (visit-first-order kfun)) + (($ $branch kt ($ $values (arg))) + (check-use arg) + first-order) + (($ $branch kt ($ $primcall name args)) + (for-each check-use args) + first-order) + (($ $primcall name args) + (for-each check-use args) + first-order) + (($ $prompt escape? tag handler) + (check-use tag) + first-order))) + (intmap-fold + (lambda (label bound first-order) + (let ((bound (intset-union free bound))) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-exp exp (fold1 adjoin-def vars bound) first-order)) + (_ first-order)))) + (compute-available-definitions conts kfun) + first-order))) + +(define (check-label-partition conts kfun) + ;; A continuation can only belong to one function. + (intmap-fold + (lambda (kfun body seen) + (intset-fold + (lambda (label seen) + (intmap-add seen label kfun + (lambda (old new) + (error "label used by two functions" label old new)))) + body + seen)) + (compute-reachable-functions conts kfun) + empty-intmap)) + +(define (compute-reachable-labels conts kfun) + (intmap-fold (lambda (kfun body seen) (intset-union seen body)) + (compute-reachable-functions conts kfun) + empty-intset)) + +(define (check-arities conts kfun) + (define (check-arity exp cont) + (define (assert-unary) + (match cont + (($ $kargs (_) (_)) #t) + (_ (error "expected unary continuation" cont)))) + (define (assert-nullary) + (match cont + (($ $kargs () ()) #t) + (_ (error "expected unary continuation" cont)))) + (define (assert-n-ary n) + (match cont + (($ $kargs names vars) + (unless (= (length vars) n) + (error "expected n-ary continuation" n cont))) + (_ (error "expected $kargs continuation" cont)))) + (define (assert-kreceive-or-ktail) + (match cont + ((or ($ $kreceive) ($ $ktail)) #t) + (_ (error "expected $kreceive or $ktail continuation" cont)))) + (match exp + ((or ($ $const) ($ $prim) ($ $closure) ($ $fun)) + (assert-unary)) + (($ $rec names vars funs) + (unless (= (length names) (length vars) (length funs)) + (error "invalid $rec" exp)) + (assert-n-ary (length names)) + (match cont + (($ $kargs names vars*) + (unless (equal? vars* vars) + (error "bound variable mismatch" vars vars*))))) + (($ $values args) + (match cont + (($ $ktail) #t) + (_ (assert-n-ary (length args))))) + (($ $call proc args) + (assert-kreceive-or-ktail)) + (($ $callk k proc args) + (assert-kreceive-or-ktail)) + (($ $branch kt exp) + (assert-nullary) + (match (intmap-ref conts kt) + (($ $kargs () ()) #t) + (cont (error "bad kt" cont)))) + (($ $primcall name args) + (match cont + (($ $kargs names) + (match (prim-arity name) + ((out . in) + (unless (= in (length args)) + (error "bad arity to primcall" name args in)) + (unless (= out (length names)) + (error "bad return arity from primcall" name names out))))) + (($ $kreceive) + (when (false-if-exception (prim-arity name)) + (error "primitive should continue to $kargs, not $kreceive" name))) + (($ $ktail) + (unless (eq? name 'return) + (when (false-if-exception (prim-arity name)) + (error "primitive should continue to $kargs, not $ktail" name)))))) + (($ $prompt escape? tag handler) + (assert-nullary) + (match (intmap-ref conts handler) + (($ $kreceive) #t) + (cont (error "bad handler" cont)))))) + (let ((reachable (compute-reachable-labels conts kfun))) + (intmap-for-each + (lambda (label cont) + (when (intset-ref reachable label) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (unless (= (length names) (length vars)) + (error "broken $kargs" label names vars)) + (check-arity exp (intmap-ref conts k))) + (_ #t)))) + conts))) + +(define (check-functions-bound-once conts kfun) + (let ((reachable (compute-reachable-labels conts kfun))) + (define (add-fun fun functions) + (when (intset-ref functions fun) + (error "function already bound" fun)) + (intset-add functions fun)) + (intmap-fold + (lambda (label cont functions) + (if (intset-ref reachable label) + (match cont + (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) + (add-fun kfun functions)) + (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...)))) + (fold1 add-fun kfuns functions)) + (_ functions)) + functions)) + conts + empty-intset))) + +(define (verify conts) + (check-distinct-vars conts) + (check-label-partition conts 0) + (check-valid-var-uses conts 0) + (check-arities conts 0) + (check-functions-bound-once conts 0) + conts) diff --git a/module/language/cps/with-cps.scm b/module/language/cps/with-cps.scm new file mode 100644 index 000000000..45cb9c4fd --- /dev/null +++ b/module/language/cps/with-cps.scm @@ -0,0 +1,145 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Guile's CPS language is a label->cont mapping, which seems simple +;;; enough. However it's often cumbersome to thread around the output +;;; CPS program when doing non-trivial transformations, or when building +;;; a CPS program from scratch. For example, when visiting an +;;; expression during CPS conversion, we usually already know the label +;;; and the $kargs wrapper for the cont, and just need to know the body +;;; of that cont. However when building the body of that possibly +;;; nested Tree-IL expression we will also need to add conts to the +;;; result, so really it's a process that takes an incoming program, +;;; adds conts to that program, and returns the result program and the +;;; result term. +;;; +;;; It's a bit treacherous to do in a functional style as once you start +;;; adding to a program, you shouldn't add to previous versions of that +;;; program. Getting that right in the context of this program seed +;;; that is threaded through the conversion requires the use of a +;;; pattern, with-cps. +;;; +;;; with-cps goes like this: +;;; +;;; (with-cps cps clause ... tail-clause) +;;; +;;; Valid clause kinds are: +;;; +;;; (letk LABEL CONT) +;;; (setk LABEL CONT) +;;; (letv VAR ...) +;;; (let$ X (PROC ARG ...)) +;;; +;;; letk and letv create fresh CPS labels and variable names, +;;; respectively. Labels and vars bound by letk and letv are in scope +;;; from their point of definition onward. letv just creates fresh +;;; variable names for use in other parts of with-cps, while letk binds +;;; fresh labels to values and adds them to the resulting program. The +;;; right-hand-side of letk, CONT, is passed to build-cont, so it should +;;; be a valid production of that language. setk is like letk but it +;;; doesn't create a fresh label name. +;;; +;;; let$ delegates processing to a sub-computation. The form (PROC ARG +;;; ...) is syntactically altered to be (PROC CPS ARG ...), where CPS is +;;; the value of the program being built, at that point in the +;;; left-to-right with-cps execution. That form is is expected to +;;; evaluate to two values: the new CPS term, and the value to bind to +;;; X. X is in scope for the following with-cps clauses. The name was +;;; chosen because the $ is reminiscent of the $ in CPS data types. +;;; +;;; The result of the with-cps form is determined by the tail clause, +;;; which may be of these kinds: +;;; +;;; ($ (PROC ARG ...)) +;;; (setk LABEL CONT) +;;; EXP +;;; +;;; $ is like let$, but in tail position. If the tail clause is setk, +;;; then only one value is returned, the resulting CPS program. +;;; Otherwise EXP is any kind of expression, which should not add to the +;;; resulting program. Ending the with-cps with EXP is equivalant to +;;; returning (values CPS EXP). +;;; +;;; It's a bit of a monad, innit? Don't tell anyone though! +;;; +;;; Sometimes you need to just bind some constants to CPS values. +;;; with-cps-constants is there for you. For example: +;;; +;;; (with-cps-constants cps ((foo 34)) +;;; (build-term ($values (foo)))) +;;; +;;; The body of with-cps-constants is a with-cps clause, or a sequence +;;; of such clauses. But usually you will want with-cps-constants +;;; inside a with-cps, so it usually looks like this: +;;; +;;; (with-cps cps +;;; ... +;;; ($ (with-cps-constants ((foo 34)) +;;; (build-term ($values (foo)))))) +;;; +;;; which is to say that the $ or the let$ adds the CPS argument for us. +;;; +;;; Code: + +(define-module (language cps with-cps) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:export (with-cps with-cps-constants)) + +(define-syntax with-cps + (syntax-rules (letk setk letv let$ $) + ((_ (exp ...) clause ...) + (let ((cps (exp ...))) + (with-cps cps clause ...))) + ((_ cps (letk label cont) clause ...) + (let-fresh (label) () + (with-cps (intmap-add! cps label (build-cont cont)) + clause ...))) + ((_ cps (setk label cont)) + (intmap-add! cps label (build-cont cont) + (lambda (old new) new))) + ((_ cps (setk label cont) clause ...) + (with-cps (with-cps cps (setk label cont)) + clause ...)) + ((_ cps (letv v ...) clause ...) + (let-fresh () (v ...) + (with-cps cps clause ...))) + ((_ cps (let$ var (proc arg ...)) clause ...) + (call-with-values (lambda () (proc cps arg ...)) + (lambda (cps var) + (with-cps cps clause ...)))) + ((_ cps ($ (proc arg ...))) + (proc cps arg ...)) + ((_ cps exp) + (values cps exp)))) + +(define-syntax with-cps-constants + (syntax-rules () + ((_ cps () clause ...) + (with-cps cps clause ...)) + ((_ cps ((var val) (var* val*) ...) clause ...) + (let ((x val)) + (with-cps cps + (letv var) + (let$ body (with-cps-constants ((var* val*) ...) + clause ...)) + (letk label ($kargs ('var) (var) ,body)) + (build-term ($continue label #f ($const x)))))))) |