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