diff options
Diffstat (limited to 'module/language/tree-il')
-rw-r--r-- | module/language/tree-il/analyze.scm | 1568 | ||||
-rw-r--r-- | module/language/tree-il/canonicalize.scm | 82 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 2590 | ||||
-rw-r--r-- | module/language/tree-il/cps-primitives.scm | 176 | ||||
-rw-r--r-- | module/language/tree-il/debug.scm | 246 | ||||
-rw-r--r-- | module/language/tree-il/effects.scm | 591 | ||||
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 314 | ||||
-rw-r--r-- | module/language/tree-il/optimize.scm | 63 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 1675 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 684 | ||||
-rw-r--r-- | module/language/tree-il/spec.scm | 46 |
11 files changed, 8035 insertions, 0 deletions
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm new file mode 100644 index 000000000..62632fd3c --- /dev/null +++ b/module/language/tree-il/analyze.scm @@ -0,0 +1,1568 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001, 2008-2014, 2018 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 tree-il analyze) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (system base syntax) + #:use-module (system base message) + #:use-module (system vm program) + #:use-module (language tree-il) + #:use-module (system base pmatch) + #:export (analyze-lexicals + analyze-tree + unused-variable-analysis + unused-toplevel-analysis + shadowed-toplevel-analysis + unbound-variable-analysis + macro-use-before-definition-analysis + arity-analysis + format-analysis)) + +;; Allocation is the process of assigning storage locations for lexical +;; variables. A lexical variable has a distinct "address", or storage +;; location, for each procedure in which it is referenced. +;; +;; A variable is "local", i.e., allocated on the stack, if it is +;; referenced from within the procedure that defined it. Otherwise it is +;; a "closure" variable. For example: +;; +;; (lambda (a) a) ; a will be local +;; `a' is local to the procedure. +;; +;; (lambda (a) (lambda () a)) +;; `a' is local to the outer procedure, but a closure variable with +;; respect to the inner procedure. +;; +;; If a variable is ever assigned, it needs to be heap-allocated +;; ("boxed"). This is so that closures and continuations capture the +;; variable's identity, not just one of the values it may have over the +;; course of program execution. If the variable is never assigned, there +;; is no distinction between value and identity, so closing over its +;; identity (whether through closures or continuations) can make a copy +;; of its value instead. +;; +;; Local variables are stored on the stack within a procedure's call +;; frame. Their index into the stack is determined from their linear +;; postion within a procedure's binding path: +;; (let (0 1) +;; (let (2 3) ...) +;; (let (2) ...)) +;; (let (2 3 4) ...)) +;; etc. +;; +;; This algorithm has the problem that variables are only allocated +;; indices at the end of the binding path. If variables bound early in +;; the path are not used in later portions of the path, their indices +;; will not be recycled. This problem is particularly egregious in the +;; expansion of `or': +;; +;; (or x y z) +;; -> (let ((a x)) (if a a (let ((b y)) (if b b z)))) +;; +;; As you can see, the `a' binding is only used in the ephemeral +;; `consequent' clause of the first `if', but its index would be +;; reserved for the whole of the `or' expansion. So we have a hack for +;; this specific case. A proper solution would be some sort of liveness +;; analysis, and not our linear allocation algorithm. +;; +;; Closure variables are captured when a closure is created, and stored in a +;; vector inline to the closure object itself. Each closure variable has a +;; unique index into that vector. +;; +;; There is one more complication. Procedures bound by <fix> may, in +;; some cases, be rendered inline to their parent procedure. That is to +;; say, +;; +;; (letrec ((lp (lambda () (lp)))) (lp)) +;; => (fix ((lp (lambda () (lp)))) (lp)) +;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP; +;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop +;; +;; The upshot is that we don't have to allocate any space for the `lp' +;; closure at all, as it can be rendered inline as a loop. So there is +;; another kind of allocation, "label allocation", in which the +;; procedure is simply a label, placed at the start of the lambda body. +;; The label is the gensym under which the lambda expression is bound. +;; +;; The analyzer checks to see that the label is called with the correct +;; number of arguments. Calls to labels compile to rename + goto. +;; Lambda, the ultimate goto! +;; +;; +;; The return value of `analyze-lexicals' is a hash table, the +;; "allocation". +;; +;; The allocation maps gensyms -- recall that each lexically bound +;; variable has a unique gensym -- to storage locations ("addresses"). +;; Since one gensym may have many storage locations, if it is referenced +;; in many procedures, it is a two-level map. +;; +;; The allocation also stored information on how many local variables +;; need to be allocated for each procedure, lexicals that have been +;; translated into labels, and information on what free variables to +;; capture from its lexical parent procedure. +;; +;; In addition, we have a conflation: while we're traversing the code, +;; recording information to pass to the compiler, we take the +;; opportunity to generate labels for each lambda-case clause, so that +;; generated code can skip argument checks at runtime if they match at +;; compile-time. +;; +;; Also, while we're a-traversing and an-allocating, we check prompt +;; handlers to see if the "continuation" argument is used. If not, we +;; mark the prompt as being "escape-only". This allows us to implement +;; `catch' and `throw' using `prompt' and `control', but without causing +;; a continuation to be reified. Heh heh. +;; +;; That is: +;; +;; sym -> {lambda -> address} +;; lambda -> (labels . free-locs) +;; lambda-case -> (gensym . nlocs) +;; prompt -> escape-only? +;; +;; address ::= (local? boxed? . index) +;; labels ::= ((sym . lambda) ...) +;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...) +;; free variable addresses are relative to parent proc. + +(define (make-hashq k v) + (let ((res (make-hash-table))) + (hashq-set! res k v) + res)) + +(define (analyze-lexicals x) + ;; bound-vars: lambda -> (sym ...) + ;; all identifiers bound within a lambda + (define bound-vars (make-hash-table)) + ;; free-vars: lambda -> (sym ...) + ;; all identifiers referenced in a lambda, but not bound + ;; NB, this includes identifiers referenced by contained lambdas + (define free-vars (make-hash-table)) + ;; assigned: sym -> #t + ;; variables that are assigned + (define assigned (make-hash-table)) + ;; refcounts: sym -> count + ;; allows us to detect the or-expansion in O(1) time + (define refcounts (make-hash-table)) + ;; labels: sym -> lambda + ;; for determining if fixed-point procedures can be rendered as + ;; labels. + (define labels (make-hash-table)) + + ;; returns variables referenced in expr + (define (analyze! x proc labels-in-proc tail? tail-call-args) + (define (step y) (analyze! y proc '() #f #f)) + (define (step-tail y) (analyze! y proc labels-in-proc tail? #f)) + (define (step-tail-call y args) (analyze! y proc labels-in-proc #f + (and tail? args))) + (define (recur/labels x new-proc labels) + (analyze! x new-proc (append labels labels-in-proc) #t #f)) + (define (recur x new-proc) (analyze! x new-proc '() tail? #f)) + (record-case x + ((<call> proc args) + (apply lset-union eq? (step-tail-call proc args) + (map step args))) + + ((<primcall> args) + (apply lset-union eq? (map step args))) + + ((<conditional> test consequent alternate) + (lset-union eq? (step test) (step-tail consequent) (step-tail alternate))) + + ((<lexical-ref> gensym) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (if (not (and tail-call-args + (memq gensym labels-in-proc) + (let ((p (hashq-ref labels gensym))) + (and p + (let lp ((c (lambda-body p))) + (and c (lambda-case? c) + (or + ;; for now prohibit optional & + ;; keyword arguments; can relax this + ;; restriction later + (and (= (length (lambda-case-req c)) + (length tail-call-args)) + (not (lambda-case-opt c)) + (not (lambda-case-kw c)) + (not (lambda-case-rest c))) + (lp (lambda-case-alternate c))))))))) + (hashq-set! labels gensym #f)) + (list gensym)) + + ((<lexical-set> gensym exp) + (hashq-set! assigned gensym #t) + (hashq-set! labels gensym #f) + (lset-adjoin eq? (step exp) gensym)) + + ((<module-set> exp) + (step exp)) + + ((<toplevel-set> exp) + (step exp)) + + ((<toplevel-define> exp) + (step exp)) + + ((<seq> head tail) + (lset-union eq? (step head) (step-tail tail))) + + ((<lambda> body) + ;; order is important here + (hashq-set! bound-vars x '()) + (let ((free (recur body x))) + (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) + (hashq-set! free-vars x free) + free)) + + ((<lambda-case> opt kw inits gensyms body alternate) + (hashq-set! bound-vars proc + (append (reverse gensyms) (hashq-ref bound-vars proc))) + (lset-union + eq? + (lset-difference eq? + (lset-union eq? + (apply lset-union eq? (map step inits)) + (step-tail body)) + gensyms) + (if alternate (step-tail alternate) '()))) + + ((<let> gensyms vals body) + (hashq-set! bound-vars proc + (append (reverse gensyms) (hashq-ref bound-vars proc))) + (lset-difference eq? + (apply lset-union eq? (step-tail body) (map step vals)) + gensyms)) + + ((<letrec> gensyms vals body) + (hashq-set! bound-vars proc + (append (reverse gensyms) (hashq-ref bound-vars proc))) + (for-each (lambda (sym) (hashq-set! assigned sym #t)) gensyms) + (lset-difference eq? + (apply lset-union eq? (step-tail body) (map step vals)) + gensyms)) + + ((<fix> gensyms vals body) + ;; Try to allocate these procedures as labels. + (for-each (lambda (sym val) (hashq-set! labels sym val)) + gensyms vals) + (hashq-set! bound-vars proc + (append (reverse gensyms) (hashq-ref bound-vars proc))) + ;; Step into subexpressions. + (let* ((var-refs + (map + ;; Since we're trying to label-allocate the lambda, + ;; pretend it's not a closure, and just recurse into its + ;; body directly. (Otherwise, recursing on a closure + ;; that references one of the fix's bound vars would + ;; prevent label allocation.) + (lambda (x) + (record-case x + ((<lambda> body) + ;; just like the closure case, except here we use + ;; recur/labels instead of recur + (hashq-set! bound-vars x '()) + (let ((free (recur/labels body x gensyms))) + (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) + (hashq-set! free-vars x free) + free)))) + vals)) + (vars-with-refs (map cons gensyms var-refs)) + (body-refs (recur/labels body proc gensyms))) + (define (delabel-dependents! sym) + (let ((refs (assq-ref vars-with-refs sym))) + (if refs + (for-each (lambda (sym) + (if (hashq-ref labels sym) + (begin + (hashq-set! labels sym #f) + (delabel-dependents! sym)))) + refs)))) + ;; Stepping into the lambdas and the body might have made some + ;; procedures not label-allocatable -- which might have + ;; knock-on effects. For example: + ;; (fix ((a (lambda () (b))) + ;; (b (lambda () a))) + ;; (a)) + ;; As far as `a' is concerned, both `a' and `b' are + ;; label-allocatable. But `b' references `a' not in a proc-tail + ;; position, which makes `a' not label-allocatable. The + ;; knock-on effect is that, when back-propagating this + ;; information to `a', `b' will also become not + ;; label-allocatable, as it is referenced within `a', which is + ;; allocated as a closure. This is a transitive relationship. + (for-each (lambda (sym) + (if (not (hashq-ref labels sym)) + (delabel-dependents! sym))) + gensyms) + ;; Now lift bound variables with label-allocated lambdas to the + ;; parent procedure. + (for-each + (lambda (sym val) + (if (hashq-ref labels sym) + ;; Remove traces of the label-bound lambda. The free + ;; vars will propagate up via the return val. + (begin + (hashq-set! bound-vars proc + (append (hashq-ref bound-vars val) + (hashq-ref bound-vars proc))) + (hashq-remove! bound-vars val) + (hashq-remove! free-vars val)))) + gensyms vals) + (lset-difference eq? + (apply lset-union eq? body-refs var-refs) + gensyms))) + + ((<let-values> exp body) + (lset-union eq? (step exp) (step body))) + + ((<prompt> escape-only? tag body handler) + (match handler + (($ <lambda> _ _ handler) + (lset-union eq? (step tag) (step body) (step-tail handler))))) + + ((<abort> tag args tail) + (apply lset-union eq? (step tag) (step tail) (map step args))) + + (else '()))) + + ;; allocation: sym -> {lambda -> address} + ;; lambda -> (labels . free-locs) + ;; lambda-case -> (gensym . nlocs) + (define allocation (make-hash-table)) + + (define (allocate! x proc n) + (define (recur y) (allocate! y proc n)) + (record-case x + ((<call> proc args) + (apply max (recur proc) (map recur args))) + + ((<primcall> args) + (apply max n (map recur args))) + + ((<conditional> test consequent alternate) + (max (recur test) (recur consequent) (recur alternate))) + + ((<lexical-set> exp) + (recur exp)) + + ((<module-set> exp) + (recur exp)) + + ((<toplevel-set> exp) + (recur exp)) + + ((<toplevel-define> exp) + (recur exp)) + + ((<seq> head tail) + (max (recur head) + (recur tail))) + + ((<lambda> body) + ;; allocate closure vars in order + (let lp ((c (hashq-ref free-vars x)) (n 0)) + (if (pair? c) + (begin + (hashq-set! (hashq-ref allocation (car c)) + x + `(#f ,(hashq-ref assigned (car c)) . ,n)) + (lp (cdr c) (1+ n))))) + + (let ((nlocs (allocate! body x 0)) + (free-addresses + (map (lambda (v) + (hashq-ref (hashq-ref allocation v) proc)) + (hashq-ref free-vars x))) + (labels (filter cdr + (map (lambda (sym) + (cons sym (hashq-ref labels sym))) + (hashq-ref bound-vars x))))) + ;; set procedure allocations + (hashq-set! allocation x (cons labels free-addresses))) + n) + + ((<lambda-case> opt kw inits gensyms body alternate) + (max + (let lp ((gensyms gensyms) (n n)) + (if (null? gensyms) + (let ((nlocs (apply + max + (allocate! body proc n) + ;; inits not logically at the end, but they + ;; are the list... + (map (lambda (x) (allocate! x proc n)) inits)))) + ;; label and nlocs for the case + (hashq-set! allocation x (cons (gensym ":LCASE") nlocs)) + nlocs) + (begin + (hashq-set! allocation (car gensyms) + (make-hashq + proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n))) + (lp (cdr gensyms) (1+ n))))) + (if alternate (allocate! alternate proc n) n))) + + ((<let> gensyms vals body) + (let ((nmax (apply max (map recur vals)))) + (cond + ;; the `or' hack + ((and (conditional? body) + (= (length gensyms) 1) + (let ((v (car gensyms))) + (and (not (hashq-ref assigned v)) + (= (hashq-ref refcounts v 0) 2) + (lexical-ref? (conditional-test body)) + (eq? (lexical-ref-gensym (conditional-test body)) v) + (lexical-ref? (conditional-consequent body)) + (eq? (lexical-ref-gensym (conditional-consequent body)) v)))) + (hashq-set! allocation (car gensyms) + (make-hashq proc `(#t #f . ,n))) + ;; the 1+ for this var + (max nmax (1+ n) (allocate! (conditional-alternate body) proc n))) + (else + (let lp ((gensyms gensyms) (n n)) + (if (null? gensyms) + (max nmax (allocate! body proc n)) + (let ((v (car gensyms))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr gensyms) (1+ n))))))))) + + ((<letrec> gensyms vals body) + (let lp ((gensyms gensyms) (n n)) + (if (null? gensyms) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x proc n)) + vals)))) + (max nmax (allocate! body proc n))) + (let ((v (car gensyms))) + (hashq-set! + allocation v + (make-hashq proc + `(#t ,(hashq-ref assigned v) . ,n))) + (lp (cdr gensyms) (1+ n)))))) + + ((<fix> gensyms vals body) + (let lp ((in gensyms) (n n)) + (if (null? in) + (let lp ((gensyms gensyms) (vals vals) (nmax n)) + (cond + ((null? gensyms) + (max nmax (allocate! body proc n))) + ((hashq-ref labels (car gensyms)) + ;; allocate lambda body inline to proc + (lp (cdr gensyms) + (cdr vals) + (record-case (car vals) + ((<lambda> body) + (max nmax (allocate! body proc n)))))) + (else + ;; allocate closure + (lp (cdr gensyms) + (cdr vals) + (max nmax (allocate! (car vals) proc n)))))) + + (let ((v (car in))) + (cond + ((hashq-ref assigned v) + (error "fixpoint procedures may not be assigned" x)) + ((hashq-ref labels v) + ;; no binding, it's a label + (lp (cdr in) n)) + (else + ;; allocate closure binding + (hashq-set! allocation v (make-hashq proc `(#t #f . ,n))) + (lp (cdr in) (1+ n)))))))) + + ((<let-values> exp body) + (max (recur exp) (recur body))) + + ((<prompt> escape-only? tag body handler) + (match handler + (($ <lambda> _ _ handler) + (max (recur tag) (recur body) (recur handler))))) + + ((<abort> tag args tail) + (apply max (recur tag) (recur tail) (map recur args))) + + (else n))) + + (analyze! x #f '() #t #f) + (allocate! x #f 0) + + allocation) + + +;;; +;;; Tree analyses for warnings. +;;; + +(define-record-type <tree-analysis> + (make-tree-analysis down up post init) + tree-analysis? + (down tree-analysis-down) ;; (lambda (x result env locs) ...) + (up tree-analysis-up) ;; (lambda (x result env locs) ...) + (post tree-analysis-post) ;; (lambda (result env) ...) + (init tree-analysis-init)) ;; arbitrary value + +(define (analyze-tree analyses tree env) + "Run all tree analyses listed in ANALYSES on TREE for ENV, using +`tree-il-fold'. Return TREE. The down and up procedures of each +analysis are passed a ``location stack', which is the stack of +`tree-il-src' values for each parent tree (a list); it can be used to +approximate source location when accurate information is missing from a +given `tree-il' element." + + (define (traverse proc update-locs) + ;; Return a tree traversing procedure that returns a list of analysis + ;; results prepended by the location stack. + (lambda (x results) + (let ((locs (update-locs x (car results)))) + (cons locs ;; the location stack + (map (lambda (analysis result) + ((proc analysis) x result env locs)) + analyses + (cdr results)))))) + + ;; Extending and shrinking the location stack. + (define (extend-locs x locs) (cons (tree-il-src x) locs)) + (define (shrink-locs x locs) (cdr locs)) + + (let ((results + (tree-il-fold (traverse tree-analysis-down extend-locs) + (traverse tree-analysis-up shrink-locs) + (cons '() ;; empty location stack + (map tree-analysis-init analyses)) + tree))) + + (for-each (lambda (analysis result) + ((tree-analysis-post analysis) result env)) + analyses + (cdr results))) + + tree) + + +;;; +;;; Unused variable analysis. +;;; + +;; <binding-info> records are used during tree traversals in +;; `unused-variable-analysis'. They contain a list of the local vars +;; currently in scope, and a list of locals vars that have been referenced. +(define-record-type <binding-info> + (make-binding-info vars refs) + binding-info? + (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...) + (refs binding-info-refs)) ;; (GENSYM ...) + +(define (gensym? sym) + ;; Return #t if SYM is (likely) a generated symbol. + (string-any #\space (symbol->string sym))) + +(define unused-variable-analysis + ;; Report unused variables in the given tree. + (make-tree-analysis + (lambda (x info env locs) + ;; Going down into X: extend INFO's variable list + ;; accordingly. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info)) + (src (tree-il-src x))) + (define (extend inner-vars inner-names) + (fold (lambda (var name vars) + (vhash-consq var (list name src) vars)) + vars + inner-vars + inner-names)) + + (record-case x + ((<lexical-ref> gensym) + (make-binding-info vars (vhash-consq gensym #t refs))) + ((<lexical-set> gensym) + (make-binding-info vars (vhash-consq gensym #t refs))) + ((<lambda-case> req opt inits rest kw gensyms) + (let ((names `(,@req + ,@(or opt '()) + ,@(if rest (list rest) '()) + ,@(if kw (map cadr (cdr kw)) '())))) + (make-binding-info (extend gensyms names) refs))) + ((<let> gensyms names) + (make-binding-info (extend gensyms names) refs)) + ((<letrec> gensyms names) + (make-binding-info (extend gensyms names) refs)) + ((<fix> gensyms names) + (make-binding-info (extend gensyms names) refs)) + (else info)))) + + (lambda (x info env locs) + ;; Leaving X's scope: shrink INFO's variable list + ;; accordingly and reported unused nested variables. + (let ((refs (binding-info-refs info)) + (vars (binding-info-vars info))) + (define (shrink inner-vars refs) + (vlist-for-each + (lambda (var) + (let ((gensym (car var))) + ;; Don't report lambda parameters as unused. + (if (and (memq gensym inner-vars) + (not (vhash-assq gensym refs)) + (not (lambda-case? x))) + (let ((name (cadr var)) + ;; We can get approximate source location by going up + ;; the LOCS location stack. + (loc (or (caddr var) + (find pair? locs)))) + (if (and (not (gensym? name)) + (not (eq? name '_))) + (warning 'unused-variable loc name)))))) + vars) + (vlist-drop vars (length inner-vars))) + + ;; For simplicity, we leave REFS untouched, i.e., with + ;; names of variables that are now going out of scope. + ;; It doesn't hurt as these are unique names, it just + ;; makes REFS unnecessarily fat. + (record-case x + ((<lambda-case> gensyms) + (make-binding-info (shrink gensyms refs) refs)) + ((<let> gensyms) + (make-binding-info (shrink gensyms refs) refs)) + ((<letrec> gensyms) + (make-binding-info (shrink gensyms refs) refs)) + ((<fix> gensyms) + (make-binding-info (shrink gensyms refs) refs)) + (else info)))) + + (lambda (result env) #t) + (make-binding-info vlist-null vlist-null))) + + +;;; +;;; Unused top-level variable analysis. +;;; + +;; <reference-graph> record top-level definitions that are made, references to +;; top-level definitions and their context (the top-level definition in which +;; the reference appears), as well as the current context (the top-level +;; definition we're currently in). The second part (`refs' below) is +;; effectively a graph from which we can determine unused top-level definitions. +(define-record-type <reference-graph> + (make-reference-graph refs defs toplevel-context) + reference-graph? + (defs reference-graph-defs) ;; ((NAME . LOC) ...) + (refs reference-graph-refs) ;; ((REF-CONTEXT REF ...) ...) + (toplevel-context reference-graph-toplevel-context)) ;; NAME | #f + +(define (graph-reachable-nodes root refs reachable) + ;; Add to REACHABLE the nodes reachable from ROOT in graph REFS. REFS is a + ;; vhash mapping nodes to the list of their children: for instance, + ;; ((A -> (B C)) (B -> (A)) (C -> ())) corresponds to + ;; + ;; ,-------. + ;; v | + ;; A ----> B + ;; | + ;; v + ;; C + ;; + ;; REACHABLE is a vhash of nodes known to be otherwise reachable. + + (let loop ((root root) + (path vlist-null) + (result reachable)) + (if (or (vhash-assq root path) + (vhash-assq root result)) + result + (let* ((children (or (and=> (vhash-assq root refs) cdr) '())) + (path (vhash-consq root #t path)) + (result (fold (lambda (kid result) + (loop kid path result)) + result + children))) + (fold (lambda (kid result) + (vhash-consq kid #t result)) + result + children))))) + +(define (graph-reachable-nodes* roots refs) + ;; Return the list of nodes in REFS reachable from the nodes listed in ROOTS. + (vlist-fold (lambda (root+true result) + (let* ((root (car root+true)) + (reachable (graph-reachable-nodes root refs result))) + (vhash-consq root #t reachable))) + vlist-null + roots)) + +(define (partition* pred vhash) + ;; Partition VHASH according to PRED. Return the two resulting vhashes. + (let ((result + (vlist-fold (lambda (k+v result) + (let ((k (car k+v)) + (v (cdr k+v)) + (r1 (car result)) + (r2 (cdr result))) + (if (pred k) + (cons (vhash-consq k v r1) r2) + (cons r1 (vhash-consq k v r2))))) + (cons vlist-null vlist-null) + vhash))) + (values (car result) (cdr result)))) + +(define unused-toplevel-analysis + ;; Report unused top-level definitions that are not exported. + (let ((add-ref-from-context + (lambda (graph name) + ;; Add an edge CTX -> NAME in GRAPH. + (let* ((refs (reference-graph-refs graph)) + (defs (reference-graph-defs graph)) + (ctx (reference-graph-toplevel-context graph)) + (ctx-refs (or (and=> (vhash-assq ctx refs) cdr) '()))) + (make-reference-graph (vhash-consq ctx (cons name ctx-refs) refs) + defs ctx))))) + (define (macro-variable? name env) + (and (module? env) + (let ((var (module-variable env name))) + (and var (variable-bound? var) + (macro? (variable-ref var)))))) + + (make-tree-analysis + (lambda (x graph env locs) + ;; Going down into X. + (let ((ctx (reference-graph-toplevel-context graph)) + (refs (reference-graph-refs graph)) + (defs (reference-graph-defs graph))) + (record-case x + ((<toplevel-ref> name src) + (add-ref-from-context graph name)) + ((<toplevel-define> name src) + (let ((refs refs) + (defs (vhash-consq name (or src (find pair? locs)) + defs))) + (make-reference-graph refs defs name))) + ((<toplevel-set> name src) + (add-ref-from-context graph name)) + (else graph)))) + + (lambda (x graph env locs) + ;; Leaving X's scope. + (record-case x + ((<toplevel-define>) + (let ((refs (reference-graph-refs graph)) + (defs (reference-graph-defs graph))) + (make-reference-graph refs defs #f))) + (else graph))) + + (lambda (graph env) + ;; Process the resulting reference graph: determine all private definitions + ;; not reachable from any public definition. Macros + ;; (syntax-transformers), which are globally bound, never considered + ;; unused since we can't tell whether a macro is actually used; in + ;; addition, macros are considered roots of the graph since they may use + ;; private bindings. FIXME: The `make-syntax-transformer' calls don't + ;; contain any literal `toplevel-ref' of the global bindings they use so + ;; this strategy fails. + (define (exported? name) + (if (module? env) + (module-variable (module-public-interface env) name) + #t)) + + (let-values (((public-defs private-defs) + (partition* (lambda (name) + (or (exported? name) + (macro-variable? name env))) + (reference-graph-defs graph)))) + (let* ((roots (vhash-consq #f #t public-defs)) + (refs (reference-graph-refs graph)) + (reachable (graph-reachable-nodes* roots refs)) + (unused (vlist-filter (lambda (name+src) + (not (vhash-assq (car name+src) + reachable))) + private-defs))) + (vlist-for-each (lambda (name+loc) + (let ((name (car name+loc)) + (loc (cdr name+loc))) + (if (not (gensym? name)) + (warning 'unused-toplevel loc name)))) + unused)))) + + (make-reference-graph vlist-null vlist-null #f)))) + + +;;; +;;; Shadowed top-level definition analysis. +;;; + +(define shadowed-toplevel-analysis + ;; Report top-level definitions that shadow previous top-level + ;; definitions from the same compilation unit. + (make-tree-analysis + (lambda (x defs env locs) + ;; Going down into X. + (record-case x + ((<toplevel-define> name src) + (match (vhash-assq name defs) + ((_ . previous-definition) + (warning 'shadowed-toplevel src name + (toplevel-define-src previous-definition)) + defs) + (#f + (vhash-consq name x defs)))) + (else defs))) + + (lambda (x defs env locs) + ;; Leaving X's scope. + defs) + + (lambda (defs env) + #t) + + vlist-null)) + + +;;; +;;; Unbound variable analysis. +;;; + +;; <toplevel-info> records are used during tree traversal in search of +;; possibly unbound variable. They contain a list of references to +;; potentially unbound top-level variables, and a list of the top-level +;; defines that have been encountered. +(define-record-type <toplevel-info> + (make-toplevel-info refs defs) + toplevel-info? + (refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...) + (defs toplevel-info-defs)) ;; (VARIABLE-NAME ...) + +(define (goops-toplevel-definition proc args env) + ;; If call of PROC to ARGS is a GOOPS top-level definition, return + ;; the name of the variable being defined; otherwise return #f. This + ;; assumes knowledge of the current implementation of `define-class' et al. + (define (toplevel-define-arg args) + (match args + ((($ <const> _ (and (? symbol?) exp)) _) + exp) + (_ #f))) + + (match proc + (($ <module-ref> _ '(oop goops) 'toplevel-define! #f) + (toplevel-define-arg args)) + (($ <toplevel-ref> _ 'toplevel-define!) + ;; This may be the result of expanding one of the GOOPS macros within + ;; `oop/goops.scm'. + (and (eq? env (resolve-module '(oop goops))) + (toplevel-define-arg args))) + (_ #f))) + +(define unbound-variable-analysis + ;; Report possibly unbound variables in the given tree. + (make-tree-analysis + (lambda (x info env locs) + ;; Going down into X. + (let* ((refs (toplevel-info-refs info)) + (defs (toplevel-info-defs info)) + (src (tree-il-src x))) + (define (bound? name) + (or (and (module? env) + (module-variable env name)) + (vhash-assq name defs))) + + (record-case x + ((<toplevel-ref> name src) + (if (bound? name) + info + (let ((src (or src (find pair? locs)))) + (make-toplevel-info (vhash-consq name src refs) + defs)))) + ((<toplevel-set> name src) + (if (bound? name) + (make-toplevel-info refs defs) + (let ((src (find pair? locs))) + (make-toplevel-info (vhash-consq name src refs) + defs)))) + ((<toplevel-define> name) + (make-toplevel-info (vhash-delq name refs) + (vhash-consq name #t defs))) + + ((<call> proc args) + ;; Check for a dynamic top-level definition, as is + ;; done by code expanded from GOOPS macros. + (let ((name (goops-toplevel-definition proc args + env))) + (if (symbol? name) + (make-toplevel-info (vhash-delq name refs) + (vhash-consq name #t defs)) + (make-toplevel-info refs defs)))) + (else + (make-toplevel-info refs defs))))) + + (lambda (x info env locs) + ;; Leaving X's scope. + info) + + (lambda (toplevel env) + ;; Post-process the result. + (vlist-for-each (match-lambda + ((name . loc) + (warning 'unbound-variable loc name))) + (vlist-reverse (toplevel-info-refs toplevel)))) + + (make-toplevel-info vlist-null vlist-null))) + + +;;; +;;; Macro use-before-definition analysis. +;;; + +;; <macro-use-info> records are used during tree traversal in search of +;; possibly uses of macros before they are defined. They contain a list +;; of references to top-level variables, and a list of the top-level +;; macro definitions that have been encountered. Any definition which +;; is a macro should in theory be expanded out already; if that's not +;; the case, the program likely has a bug. +(define-record-type <macro-use-info> + (make-macro-use-info uses defs) + macro-use-info? + (uses macro-use-info-uses) ;; ((VARIABLE-NAME . LOCATION) ...) + (defs macro-use-info-defs)) ;; ((VARIABLE-NAME . LOCATION) ...) + +(define macro-use-before-definition-analysis + ;; Report possibly unbound variables in the given tree. + (make-tree-analysis + (lambda (x info env locs) + ;; Going down into X. + (define (nearest-loc src) + (or src (find pair? locs))) + (define (add-use name src) + (match info + (($ <macro-use-info> uses defs) + (make-macro-use-info (vhash-consq name src uses) defs)))) + (define (add-def name src) + (match info + (($ <macro-use-info> uses defs) + (make-macro-use-info uses (vhash-consq name src defs))))) + (define (macro? x) + (match x + (($ <primcall> _ 'make-syntax-transformer) #t) + (_ #f))) + (match x + (($ <toplevel-ref> src name) + (add-use name (nearest-loc src))) + (($ <toplevel-set> src name) + (add-use name (nearest-loc src))) + (($ <toplevel-define> src name (? macro?)) + (add-def name (nearest-loc src))) + (_ info))) + + (lambda (x info env locs) + ;; Leaving X's scope. + info) + + (lambda (info env) + ;; Post-process the result. + (match info + (($ <macro-use-info> uses defs) + (vlist-for-each + (match-lambda + ((name . use-loc) + (when (vhash-assq name defs) + (warning 'macro-use-before-definition use-loc name)))) + (vlist-reverse (macro-use-info-uses info)))))) + + (make-macro-use-info vlist-null vlist-null))) + + +;;; +;;; Arity analysis. +;;; + +;; <arity-info> records contain information about lexical definitions of +;; procedures currently in scope, top-level procedure definitions that have +;; been encountered, and calls to top-level procedures that have been +;; encountered. +(define-record-type <arity-info> + (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas) + arity-info? + (toplevel-calls toplevel-procedure-calls) ;; ((NAME . CALL) ...) + (lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...) + (toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...) + +(define (validate-arity proc call lexical?) + ;; Validate the argument count of CALL, a tree-il call of + ;; PROC, emitting a warning in case of argument count mismatch. + + (define (filter-keyword-args keywords allow-other-keys? args) + ;; Filter keyword arguments from ARGS and return the resulting list. + ;; KEYWORDS is the list of allowed keywords, and ALLOW-OTHER-KEYS? + ;; specified whethere keywords not listed in KEYWORDS are allowed. + (let loop ((args args) + (result '())) + (if (null? args) + (reverse result) + (let ((arg (car args))) + (if (and (const? arg) + (or (memq (const-exp arg) keywords) + (and allow-other-keys? + (keyword? (const-exp arg))))) + (loop (if (pair? (cdr args)) + (cddr args) + '()) + result) + (loop (cdr args) + (cons arg result))))))) + + (define (arities proc) + ;; Return the arities of PROC, which can be either a tree-il or a + ;; procedure. + (define (len x) + (or (and (or (null? x) (pair? x)) + (length x)) + 0)) + (cond ((program? proc) + (values (procedure-name proc) + (map (lambda (a) + (list (length (or (assq-ref a 'required) '())) + (length (or (assq-ref a 'optional) '())) + (and (assq-ref a 'rest) #t) + (map car (or (assq-ref a 'keyword) '())) + (assq-ref a 'allow-other-keys?))) + (program-arguments-alists proc)))) + ((procedure? proc) + (if (struct? proc) + ;; An applicable struct. + (arities (struct-ref proc 0)) + ;; An applicable smob. + (let ((arity (procedure-minimum-arity proc))) + (values (procedure-name proc) + (list (list (car arity) (cadr arity) (caddr arity) + #f #f)))))) + (else + (let loop ((name #f) + (proc proc) + (arities '())) + (if (not proc) + (values name (reverse arities)) + (record-case proc + ((<lambda-case> req opt rest kw alternate) + (loop name alternate + (cons (list (len req) (len opt) rest + (and (pair? kw) (map car (cdr kw))) + (and (pair? kw) (car kw))) + arities))) + ((<lambda> meta body) + (loop (assoc-ref meta 'name) body arities)) + (else + (values #f #f)))))))) + + (let ((args (call-args call)) + (src (tree-il-src call))) + (call-with-values (lambda () (arities proc)) + (lambda (name arities) + (define matches? + (find (lambda (arity) + (pmatch arity + ((,req ,opt ,rest? ,kw ,aok?) + (let ((args (if (pair? kw) + (filter-keyword-args kw aok? args) + args))) + (if (and req opt) + (let ((count (length args))) + (and (>= count req) + (or rest? + (<= count (+ req opt))))) + #t))) + (else #t))) + arities)) + + (if (not matches?) + (warning 'arity-mismatch src + (or name (with-output-to-string (lambda () (write proc)))) + lexical?))))) + #t) + +(define arity-analysis + ;; Report arity mismatches in the given tree. + (make-tree-analysis + (lambda (x info env locs) + ;; Down into X. + (define (extend lexical-name val info) + ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO. + (let ((toplevel-calls (toplevel-procedure-calls info)) + (lexical-lambdas (lexical-lambdas info)) + (toplevel-lambdas (toplevel-lambdas info))) + (record-case val + ((<lambda> body) + (make-arity-info toplevel-calls + (vhash-consq lexical-name val + lexical-lambdas) + toplevel-lambdas)) + ((<lexical-ref> gensym) + ;; lexical alias + (let ((val* (vhash-assq gensym lexical-lambdas))) + (if (pair? val*) + (extend lexical-name (cdr val*) info) + info))) + ((<toplevel-ref> name) + ;; top-level alias + (make-arity-info toplevel-calls + (vhash-consq lexical-name val + lexical-lambdas) + toplevel-lambdas)) + (else info)))) + + (let ((toplevel-calls (toplevel-procedure-calls info)) + (lexical-lambdas (lexical-lambdas info)) + (toplevel-lambdas (toplevel-lambdas info))) + + (record-case x + ((<toplevel-define> name exp) + (record-case exp + ((<lambda> body) + (make-arity-info toplevel-calls + lexical-lambdas + (vhash-consq name exp toplevel-lambdas))) + ((<toplevel-ref> name) + ;; alias for another toplevel + (let ((proc (vhash-assq name toplevel-lambdas))) + (make-arity-info toplevel-calls + lexical-lambdas + (vhash-consq (toplevel-define-name x) + (if (pair? proc) + (cdr proc) + exp) + toplevel-lambdas)))) + (else info))) + ((<let> gensyms vals) + (fold extend info gensyms vals)) + ((<letrec> gensyms vals) + (fold extend info gensyms vals)) + ((<fix> gensyms vals) + (fold extend info gensyms vals)) + + ((<call> proc args src) + (record-case proc + ((<lambda> body) + (validate-arity proc x #t) + info) + ((<toplevel-ref> name) + (make-arity-info (vhash-consq name x toplevel-calls) + lexical-lambdas + toplevel-lambdas)) + ((<lexical-ref> gensym) + (let ((proc (vhash-assq gensym lexical-lambdas))) + (if (pair? proc) + (record-case (cdr proc) + ((<toplevel-ref> name) + ;; alias to toplevel + (make-arity-info (vhash-consq name x toplevel-calls) + lexical-lambdas + toplevel-lambdas)) + (else + (validate-arity (cdr proc) x #t) + info)) + + ;; If GENSYM wasn't found, it may be because it's an + ;; argument of the procedure being compiled. + info))) + (else info))) + (else info)))) + + (lambda (x info env locs) + ;; Up from X. + (define (shrink name val info) + ;; Remove NAME from the lexical-lambdas of INFO. + (let ((toplevel-calls (toplevel-procedure-calls info)) + (lexical-lambdas (lexical-lambdas info)) + (toplevel-lambdas (toplevel-lambdas info))) + (make-arity-info toplevel-calls + (if (vhash-assq name lexical-lambdas) + (vlist-tail lexical-lambdas) + lexical-lambdas) + toplevel-lambdas))) + + (let ((toplevel-calls (toplevel-procedure-calls info)) + (lexical-lambdas (lexical-lambdas info)) + (toplevel-lambdas (toplevel-lambdas info))) + (record-case x + ((<let> gensyms vals) + (fold shrink info gensyms vals)) + ((<letrec> gensyms vals) + (fold shrink info gensyms vals)) + ((<fix> gensyms vals) + (fold shrink info gensyms vals)) + + (else info)))) + + (lambda (result env) + ;; Post-processing: check all top-level procedure calls that have been + ;; encountered. + (let ((toplevel-calls (toplevel-procedure-calls result)) + (toplevel-lambdas (toplevel-lambdas result))) + (vlist-for-each + (lambda (name+call) + (let* ((name (car name+call)) + (call (cdr name+call)) + (proc + (or (and=> (vhash-assq name toplevel-lambdas) cdr) + (and (module? env) + (false-if-exception + (module-ref env name))))) + (proc* + ;; handle toplevel aliases + (if (toplevel-ref? proc) + (let ((name (toplevel-ref-name proc))) + (and (module? env) + (false-if-exception + (module-ref env name)))) + proc))) + (cond ((lambda? proc*) + (validate-arity proc* call #t)) + ((procedure? proc*) + (validate-arity proc* call #f))))) + toplevel-calls))) + + (make-arity-info vlist-null vlist-null vlist-null))) + + +;;; +;;; `format' argument analysis. +;;; + +(define &syntax-error + ;; The `throw' key for syntax errors. + (gensym "format-string-syntax-error")) + +(define (format-string-argument-count fmt) + ;; Return the minimum and maxium number of arguments that should + ;; follow format string FMT (or, ahem, a good estimate thereof) or + ;; `any' if the format string can be followed by any number of + ;; arguments. + + (define (drop-group chars end) + ;; Drop characters from CHARS until "~END" is encountered. + (let loop ((chars chars) + (tilde? #f)) + (if (null? chars) + (throw &syntax-error 'unterminated-iteration) + (if tilde? + (if (eq? (car chars) end) + (cdr chars) + (loop (cdr chars) #f)) + (if (eq? (car chars) #\~) + (loop (cdr chars) #t) + (loop (cdr chars) #f)))))) + + (define (digit? char) + ;; Return true if CHAR is a digit, #f otherwise. + (memq char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))) + + (define (previous-number chars) + ;; Return the previous series of digits found in CHARS. + (let ((numbers (take-while digit? chars))) + (and (not (null? numbers)) + (string->number (list->string (reverse numbers)))))) + + (let loop ((chars (string->list fmt)) + (state 'literal) + (params '()) + (conditions '()) + (end-group #f) + (min-count 0) + (max-count 0)) + (if (null? chars) + (if end-group + (throw &syntax-error 'unterminated-conditional) + (values min-count max-count)) + (case state + ((tilde) + (case (car chars) + ((#\~ #\% #\& #\t #\T #\_ #\newline #\( #\) #\! #\| #\/ #\q #\Q) + (loop (cdr chars) 'literal '() + conditions end-group + min-count max-count)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\, #\: #\@ #\+ #\- #\#) + (loop (cdr chars) + 'tilde (cons (car chars) params) + conditions end-group + min-count max-count)) + ((#\v #\V) (loop (cdr chars) + 'tilde (cons (car chars) params) + conditions end-group + (+ 1 min-count) + (+ 1 max-count))) + ((#\p #\P) (let* ((colon? (memq #\: params)) + (min-count (if colon? + (max 1 min-count) + (+ 1 min-count)))) + (loop (cdr chars) 'literal '() + conditions end-group + min-count + (if colon? + (max max-count min-count) + (+ 1 max-count))))) + ((#\[) + (loop chars 'literal '() '() + (let ((selector (previous-number params)) + (at? (memq #\@ params))) + (lambda (chars conds) + ;; end of group + (let ((mins (map car conds)) + (maxs (map cdr conds)) + (sel? (and selector + (< selector (length conds))))) + (if (and (every number? mins) + (every number? maxs)) + (loop chars 'literal '() conditions end-group + (+ min-count + (if sel? + (car (list-ref conds selector)) + (+ (if at? 0 1) + (if (null? mins) + 0 + (apply min mins))))) + (+ max-count + (if sel? + (cdr (list-ref conds selector)) + (+ (if at? 0 1) + (if (null? maxs) + 0 + (apply max maxs)))))) + (values 'any 'any))))) ;; XXX: approximation + 0 0)) + ((#\;) + (if end-group + (loop (cdr chars) 'literal '() + (cons (cons min-count max-count) conditions) + end-group + 0 0) + (throw &syntax-error 'unexpected-semicolon))) + ((#\]) + (if end-group + (end-group (cdr chars) + (reverse (cons (cons min-count max-count) + conditions))) + (throw &syntax-error 'unexpected-conditional-termination))) + ((#\{) (if (memq #\@ params) + (values min-count 'any) + (loop (drop-group (cdr chars) #\}) + 'literal '() + conditions end-group + (+ 1 min-count) (+ 1 max-count)))) + ((#\*) (if (memq #\@ params) + (values 'any 'any) ;; it's unclear what to do here + (loop (cdr chars) + 'literal '() + conditions end-group + (+ (or (previous-number params) 1) + min-count) + (+ (or (previous-number params) 1) + max-count)))) + ((#\? #\k #\K) + ;; We don't have enough info to determine the exact number + ;; of args, but we could determine a lower bound (TODO). + (values 'any 'any)) + ((#\^) + (values min-count 'any)) + ((#\h #\H) + (let ((argc (if (memq #\: params) 2 1))) + (loop (cdr chars) 'literal '() + conditions end-group + (+ argc min-count) + (+ argc max-count)))) + ((#\') + (if (null? (cdr chars)) + (throw &syntax-error 'unexpected-termination) + (loop (cddr chars) 'tilde (cons (cadr chars) params) + conditions end-group min-count max-count))) + (else (loop (cdr chars) 'literal '() + conditions end-group + (+ 1 min-count) (+ 1 max-count))))) + ((literal) + (case (car chars) + ((#\~) (loop (cdr chars) 'tilde '() + conditions end-group + min-count max-count)) + (else (loop (cdr chars) 'literal '() + conditions end-group + min-count max-count)))) + (else (error "computer bought the farm" state)))))) + +(define (proc-ref? exp proc special-name env) + "Return #t when EXP designates procedure PROC in ENV. As a last +resort, return #t when EXP refers to the global variable SPECIAL-NAME." + + (define special? + (cut eq? <> special-name)) + + (match exp + (($ <toplevel-ref> _ (? special?)) + ;; Allow top-levels like: (define _ (cut gettext <> "my-domain")). + #t) + (($ <toplevel-ref> _ name) + (let ((var (module-variable env name))) + (and var (variable-bound? var) + (eq? (variable-ref var) proc)))) + (($ <module-ref> _ _ (? special?)) + #t) + (($ <module-ref> _ module name public?) + (let* ((mod (if public? + (false-if-exception (resolve-interface module)) + (resolve-module module #:ensure #f))) + (var (and mod (module-variable mod name)))) + (and var (variable-bound? var) (eq? (variable-ref var) proc)))) + (($ <lexical-ref> _ (? special?)) + #t) + (_ #f))) + +(define gettext? (cut proc-ref? <> gettext '_ <>)) +(define ngettext? (cut proc-ref? <> ngettext 'N_ <>)) + +(define (const-fmt x env) + ;; Return the literal format string for X, or #f. + (match x + (($ <const> _ (? string? exp)) + exp) + (($ <call> _ (? (cut gettext? <> env)) + (($ <const> _ (? string? fmt)))) + ;; Gettexted literals, like `(_ "foo")'. + fmt) + (($ <call> _ (? (cut ngettext? <> env)) + (($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1)) + ;; Plural gettextized literals, like `(N_ "singular" "plural" n)'. + + ;; TODO: Check whether the singular and plural strings have the + ;; same format escapes. + fmt) + (_ #f))) + +(define format-analysis + ;; Report arity mismatches in the given tree. + (make-tree-analysis + (lambda (x _ env locs) + ;; Down into X. + (define (check-format-args args loc) + (pmatch args + ((,port ,fmt . ,rest) + (guard (const-fmt fmt env)) + (if (and (const? port) + (not (boolean? (const-exp port)))) + (warning 'format loc 'wrong-port (const-exp port))) + (let ((fmt (const-fmt fmt env)) + (count (length rest))) + (catch &syntax-error + (lambda () + (let-values (((min max) + (format-string-argument-count fmt))) + (and min max + (or (and (or (eq? min 'any) (>= count min)) + (or (eq? max 'any) (<= count max))) + (warning 'format loc 'wrong-format-arg-count + fmt min max count))))) + (lambda (_ key) + (warning 'format loc 'syntax-error key fmt))))) + ((,port ,fmt . ,rest) + (if (and (const? port) + (not (boolean? (const-exp port)))) + (warning 'format loc 'wrong-port (const-exp port))) + + (match fmt + (($ <const> loc* (? (negate string?) fmt)) + (warning 'format (or loc* loc) 'wrong-format-string fmt)) + + ;; Warn on non-literal format strings, unless they refer to + ;; a lexical variable named "fmt". + (($ <lexical-ref> _ fmt) + #t) + ((? (negate const?)) + (warning 'format loc 'non-literal-format-string)))) + (else + (warning 'format loc 'wrong-num-args (length args))))) + + (define (check-simple-format-args args loc) + ;; Check the arguments to the `simple-format' procedure, which is + ;; less capable than that of (ice-9 format). + + (define allowed-chars + '(#\A #\S #\a #\s #\~ #\%)) + + (define (format-chars fmt) + (let loop ((chars (string->list fmt)) + (result '())) + (match chars + (() + (reverse result)) + ((#\~ opt rest ...) + (loop rest (cons opt result))) + ((_ rest ...) + (loop rest result))))) + + (match args + ((port ($ <const> _ (? string? fmt)) _ ...) + (let ((opts (format-chars fmt))) + (or (every (cut memq <> allowed-chars) opts) + (begin + (warning 'format loc 'simple-format fmt + (find (negate (cut memq <> allowed-chars)) opts)) + #f)))) + ((port (= (cut const-fmt <> env) (? string? fmt)) args ...) + (check-simple-format-args `(,port ,(make-const loc fmt) ,args) loc)) + (_ #t))) + + (define (resolve-toplevel name) + (and (module? env) + (false-if-exception (module-ref env name)))) + + (match x + (($ <call> src ($ <toplevel-ref> _ name) args) + (let ((proc (resolve-toplevel name))) + (if (or (and (eq? proc (@ (guile) simple-format)) + (check-simple-format-args args + (or src (find pair? locs)))) + (eq? proc (@ (ice-9 format) format))) + (check-format-args args (or src (find pair? locs)))))) + (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args) + (check-format-args args (or src (find pair? locs)))) + (($ <call> src ($ <module-ref> _ '(guile) + (or 'format 'simple-format)) + args) + (and (check-simple-format-args args + (or src (find pair? locs))) + (check-format-args args (or src (find pair? locs))))) + (_ #t)) + #t) + + (lambda (x _ env locs) + ;; Up from X. + #t) + + (lambda (_ env) + ;; Post-processing. + #t) + + #t)) diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm new file mode 100644 index 000000000..9de4caae4 --- /dev/null +++ b/module/language/tree-il/canonicalize.scm @@ -0,0 +1,82 @@ +;;; Tree-il canonicalizer + +;; Copyright (C) 2011, 2012, 2013 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 tree-il canonicalize) + #:use-module (language tree-il) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (canonicalize)) + +(define (tree-il-any proc exp) + (tree-il-fold (lambda (exp res) + (or res (proc exp))) + (lambda (exp res) res) + #f exp)) + +(define (canonicalize x) + (post-order + (lambda (x) + (match x + (($ <let> src () () () body) + body) + (($ <letrec> src _ () () () body) + body) + (($ <fix> src () () () body) + body) + (($ <lambda> src meta #f) + ;; Give a body to case-lambda with no clauses. + (make-lambda + src meta + (make-lambda-case + #f '() #f #f #f '() '() + (make-primcall + #f + 'throw + (list (make-const #f 'wrong-number-of-args) + (make-const #f #f) + (make-const #f "Wrong number of arguments") + (make-const #f '()) + (make-const #f #f))) + #f))) + (($ <prompt> src escape-only? tag body handler) + ;; The prompt handler should be a simple lambda, so that we + ;; can inline it. + (match handler + (($ <lambda> _ _ + ($ <lambda-case> _ req #f rest #f () syms body #f)) + x) + (else + (let ((handler-sym (gensym)) + (args-sym (gensym))) + (make-let + #f (list 'handler) (list handler-sym) (list handler) + (make-prompt + src escape-only? tag body + (make-lambda + #f '() + (make-lambda-case + #f '() #f 'args #f '() (list args-sym) + (make-primcall + #f 'apply + (list (make-lexical-ref #f 'handler handler-sym) + (make-lexical-ref #f 'args args-sym))) + #f)))))))) + (_ x))) + x)) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm new file mode 100644 index 000000000..6c8884add --- /dev/null +++ b/module/language/tree-il/compile-cps.scm @@ -0,0 +1,2590 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015, 2017, 2018 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 Tree-IL to the continuation-passing style (CPS) +;;; language. +;;; +;;; CPS is a lower-level representation than Tree-IL. Converting to +;;; CPS, beyond adding names for all control points and all values, +;;; simplifies expressions in the following ways, among others: +;;; +;;; * Fixing the order of evaluation. +;;; +;;; * Converting assigned variables to boxed variables. +;;; +;;; * Requiring that Scheme's <letrec> has already been lowered to +;;; <fix>. +;;; +;;; * Inlining default-value initializers into lambda-case +;;; expressions. +;;; +;;; * Inlining prompt bodies. +;;; +;;; * Turning toplevel and module references into primcalls. This +;;; involves explicitly modelling the "scope" of toplevel lookups +;;; (indicating the module with respect to which toplevel bindings +;;; are resolved). +;;; +;;; The utility of CPS is that it gives a name to everything: every +;;; intermediate value, and every control point (continuation). As such +;;; it is more verbose than Tree-IL, but at the same time more simple as +;;; the number of concepts is reduced. +;;; +;;; Code: + +(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 (system base target) + #:use-module (system base types internal) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language tree-il 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-cps)) + +(define (convert-primcall/default cps k src op param . args) + (with-cps cps + (build-term + ($continue k src ($primcall op param args))))) + +(define *primcall-converters* (make-hash-table)) +(define-syntax-rule (define-primcall-converter name proc) + (hashq-set! *primcall-converters* 'name proc)) + +(define (convert-primcall* cps k src op param args) + (let ((proc (hashq-ref *primcall-converters* op convert-primcall/default))) + (apply proc cps k src op param args))) + +(define (convert-primcall cps k src op param . args) + (convert-primcall* cps k src op param args)) + +(define (ensure-vector cps src op pred v have-length) + (define msg + (match pred + ('vector? + "Wrong type argument in position 1 (expecting vector): ~S") + ('mutable-vector? + "Wrong type argument in position 1 (expecting mutable vector): ~S"))) + (define not-vector (vector 'wrong-type-arg (symbol->string op) msg)) + (with-cps cps + (letv w0 slen ulen rlen) + (letk knot-vector + ($kargs () () ($throw src 'throw/value+data not-vector (v)))) + (let$ body (have-length slen)) + (letk k ($kargs ('slen) (slen) ,body)) + (letk kcast + ($kargs ('rlen) (rlen) + ($continue k src ($primcall 'u64->s64 #f (rlen))))) + (letk kassume + ($kargs ('ulen) (ulen) + ($continue kcast src + ($primcall 'assume-u64 `(0 . ,(target-max-vector-length)) (ulen))))) + (letk krsh + ($kargs ('w0) (w0) + ($continue kassume src ($primcall 'ursh/immediate 8 (w0))))) + (letk kv + ($kargs () () + ($continue krsh src + ($primcall 'word-ref/immediate '(vector . 0) (v))))) + (letk kheap-object + ($kargs () () + ($branch knot-vector kv src pred #f (v)))) + (build-term + ($branch knot-vector kheap-object src 'heap-object? #f (v))))) + +(define (untag-fixnum-index-in-range cps src op idx slen have-index-in-range) + ;; Precondition: SLEN is a non-negative S64 that is representable as a + ;; fixnum. + (define not-fixnum + (vector 'wrong-type-arg + (symbol->string op) + "Wrong type argument in position 2 (expecting small integer): ~S")) + (define out-of-range + (vector 'out-of-range + (symbol->string op) + "Argument 2 out of range: ~S")) + (with-cps cps + (letv sidx) + (letk knot-fixnum + ($kargs () () ($throw src 'throw/value+data not-fixnum (idx)))) + (letk kout-of-range + ($kargs () () ($throw src 'throw/value+data out-of-range (idx)))) + (let$ body (have-index-in-range sidx)) + (letk k ($kargs () () ,body)) + (letk kboundlen + ($kargs () () + ($branch kout-of-range k src 's64-< #f (sidx slen)))) + (letk kbound0 + ($kargs ('sidx) (sidx) + ($branch kboundlen kout-of-range src 's64-imm-< 0 (sidx)))) + (letk kuntag + ($kargs () () + ($continue kbound0 src ($primcall 'untag-fixnum #f (idx))))) + (build-term ($branch knot-fixnum kuntag src 'fixnum? #f (idx))))) + +(define (untag-fixnum-in-imm-range cps src op size min max have-int-in-range) + (define not-fixnum + (vector 'wrong-type-arg + (symbol->string op) + "Wrong type argument in position 2 (expecting small integer): ~S")) + (define out-of-range + (vector 'out-of-range + (symbol->string op) + "Argument 2 out of range: ~S")) + (with-cps cps + (letv ssize) + (letk knot-fixnum + ($kargs () () ($throw src 'throw/value+data not-fixnum (size)))) + (letk kout-of-range + ($kargs () () ($throw src 'throw/value+data out-of-range (size)))) + (let$ body (have-int-in-range ssize)) + (letk k ($kargs () () ,body)) + (letk kboundlen + ($kargs () () + ($branch k kout-of-range src 'imm-s64-< max (ssize)))) + (letk kbound0 + ($kargs ('ssize) (ssize) + ($branch kboundlen kout-of-range src 's64-imm-< min (ssize)))) + (letk kuntag + ($kargs () () + ($continue kbound0 src ($primcall 'untag-fixnum #f (size))))) + (build-term ($branch knot-fixnum kuntag src 'fixnum? #f (size))))) + +(define (compute-vector-access-pos cps src sidx have-pos) + (with-cps cps + (letv spos upos) + (let$ body (have-pos upos)) + (letk kref ($kargs ('pos) (upos) ,body)) + (letk kcvt ($kargs ('pos) (spos) + ($continue kref src ($primcall 's64->u64 #f (spos))))) + (build-term + ($continue kcvt src ($primcall 'sadd/immediate 1 (sidx)))))) + +(define (prepare-vector-access cps src op pred v idx access) + (ensure-vector + cps src op pred v + (lambda (cps slen) + (untag-fixnum-index-in-range + cps src op idx slen + (lambda (cps sidx) + (compute-vector-access-pos + cps src sidx + (lambda (cps pos) + (access cps v pos)))))))) + +(define (prepare-vector-access/immediate cps src op pred v idx access) + (unless (and (exact-integer? idx) (<= 0 idx (1- (target-max-vector-length)))) + (error "precondition failed" idx)) + (ensure-vector + cps src op pred v + (lambda (cps slen) + (define out-of-range + (vector 'out-of-range + (symbol->string op) + "Argument 2 out of range: ~S")) + (with-cps cps + (letv tidx) + (letk kthrow + ($kargs ('tidx) (tidx) + ($throw src 'throw/value+data out-of-range (tidx)))) + (letk kout-of-range + ($kargs () () + ($continue kthrow src ($const idx)))) + (let$ body (access v (1+ idx))) + (letk k ($kargs () () ,body)) + (build-term + ($branch kout-of-range k src 'imm-s64-< idx (slen))))))) + +(define-primcall-converter vector-length + (lambda (cps k src op param v) + (ensure-vector + cps src op 'vector? v + (lambda (cps slen) + (with-cps cps + (build-term + ($continue k src ($primcall 'tag-fixnum #f (slen))))))))) + +(define-primcall-converter vector-ref + (lambda (cps k src op param v idx) + (prepare-vector-access + cps src op 'vector? v idx + (lambda (cps v upos) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-ref 'vector (v upos))))))))) + +(define-primcall-converter vector-ref/immediate + (lambda (cps k src op param v) + (prepare-vector-access/immediate + cps src 'vector-ref 'vector? v param + (lambda (cps v pos) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-ref/immediate `(vector . ,pos) (v))))))))) + +(define-primcall-converter vector-set! + (lambda (cps k src op param v idx val) + (prepare-vector-access + cps src op 'mutable-vector? v idx + (lambda (cps v upos) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-set! 'vector (v upos val))))))))) + +(define-primcall-converter vector-set!/immediate + (lambda (cps k src op param v val) + (prepare-vector-access/immediate + cps src 'vector-set! 'mutable-vector? v param + (lambda (cps v pos) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-set!/immediate `(vector . ,pos) (v val))))))))) + +(define-primcall-converter vector-init! + (lambda (cps k src op param v val) + (define pos (1+ param)) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-set!/immediate `(vector . ,pos) (v val))))))) + +(define (emit-initializations-as-loop cps k src obj annotation start nwords init) + (with-cps cps + (letv pos) + (letk kloop ,#f) ;; Patched later. + (letk kback + ($kargs () () + ($continue kloop src + ($primcall 'uadd/immediate 1 (pos))))) + (letk kinit + ($kargs () () + ($continue kback src + ($primcall 'scm-set! annotation (obj pos init))))) + (setk kloop + ($kargs ('pos) (pos) + ($branch k kinit src 'u64-< #f (pos nwords)))) + (build-term + ($continue kloop src + ($primcall 'load-u64 start ()))))) + +(define-primcall-converter allocate-vector + (lambda (cps k src op param) + (define size param) + (define nwords (1+ size)) + (unless (and (exact-integer? size) (<= 0 size (target-max-vector-length))) + (error "precondition failed" size)) + (with-cps cps + (letv v w0) + (letk kdone + ($kargs () () + ($continue k src ($values (v))))) + (letk ktag1 + ($kargs ('w0) (w0) + ($continue kdone src + ($primcall 'word-set!/immediate '(vector . 0) (v w0))))) + (letk ktag0 + ($kargs ('v) (v) + ($continue ktag1 src + ($primcall 'load-u64 (+ %tc7-vector (ash size 8)) ())))) + (build-term + ($continue ktag0 src + ($primcall 'allocate-words/immediate `(vector . ,nwords) ())))))) + +(define-primcall-converter make-vector + (lambda (cps k src op param size init) + (untag-fixnum-in-imm-range + cps src op size 0 (target-max-vector-length) + (lambda (cps ssize) + (with-cps cps + (letv usize nwords v w0-high w0) + (letk kdone + ($kargs () () + ($continue k src ($values (v))))) + (let$ init-loop + (emit-initializations-as-loop kdone src v 'vector 1 nwords init)) + (letk kbody ($kargs () () ,init-loop)) + (letk ktag2 + ($kargs ('w0) (w0) + ($continue kbody src + ($primcall 'word-set!/immediate '(vector . 0) (v w0))))) + (letk ktag1 + ($kargs ('w0-high) (w0-high) + ($continue ktag2 src + ($primcall 'uadd/immediate %tc7-vector (w0-high))))) + (letk ktag0 + ($kargs ('v) (v) + ($continue ktag1 src + ($primcall 'ulsh/immediate 8 (usize))))) + (letk kalloc + ($kargs ('nwords) (nwords) + ($continue ktag0 src + ($primcall 'allocate-words 'vector (nwords))))) + (letk kadd1 + ($kargs ('usize) (usize) + ($continue kalloc src + ;; Header word. + ($primcall 'uadd/immediate 1 (usize))))) + (build-term + ($continue kadd1 src + ;; Header word. + ($primcall 's64->u64 #f (ssize))))))))) + +(define-primcall-converter make-vector/immediate + (lambda (cps k src op param init) + (define size param) + (define nwords (1+ size)) + (define (init-fields cps v pos kdone) + ;; Inline the initializations, up to vectors of size 32. Above + ;; that it's a bit of a waste, so reify a loop instead. + (cond + ((<= 32 nwords) + (with-cps cps + (letv unwords) + (let$ init-loop + (emit-initializations-as-loop kdone src v 'vector + pos unwords init)) + (letk kinit ($kargs ('unwords) (unwords) ,init-loop)) + (letk kusize ($kargs () () + ($continue kinit src + ($primcall 'load-u64 nwords ())))) + kusize)) + ((< pos nwords) + (with-cps cps + (let$ knext (init-fields v (1+ pos) kdone)) + (letk kinit + ($kargs () () + ($continue knext src + ($primcall 'scm-set!/immediate `(vector . ,pos) + (v init))))) + kinit)) + (else + (with-cps cps + kdone)))) + (unless (and (exact-integer? size) (<= 0 size (target-max-vector-length))) + (error "precondition failed" size)) + (with-cps cps + (letv v w0) + (letk kdone + ($kargs () () + ($continue k src ($values (v))))) + (let$ kinit (init-fields v 1 kdone)) + (letk ktag1 + ($kargs ('w0) (w0) + ($continue kinit src + ($primcall 'word-set!/immediate '(vector . 0) (v w0))))) + (letk ktag0 + ($kargs ('v) (v) + ($continue ktag1 src + ($primcall 'load-u64 (+ %tc7-vector (ash size 8)) ())))) + (build-term + ($continue ktag0 src + ($primcall 'allocate-words/immediate `(vector . ,nwords) ())))))) + +(define (ensure-pair cps src op pred x is-pair) + (define msg + (match pred + ('pair? + "Wrong type argument in position 1 (expecting pair): ~S") + ('mutable-pair? + "Wrong type argument in position 1 (expecting mutable pair): ~S"))) + (define not-pair (vector 'wrong-type-arg (symbol->string op) msg)) + (with-cps cps + (letk knot-pair ($kargs () () ($throw src 'throw/value+data not-pair (x)))) + (let$ body (is-pair)) + (letk k ($kargs () () ,body)) + (letk kheap-object ($kargs () () ($branch knot-pair k src pred #f (x)))) + (build-term ($branch knot-pair kheap-object src 'heap-object? #f (x))))) + +(define-primcall-converter cons + (lambda (cps k src op param head tail) + (with-cps cps + (letv pair) + (letk kdone + ($kargs () () + ($continue k src ($values (pair))))) + (letk ktail + ($kargs () () + ($continue kdone src + ($primcall 'scm-set!/immediate '(pair . 1) (pair tail))))) + (letk khead + ($kargs ('pair) (pair) + ($continue ktail src + ($primcall 'scm-set!/immediate '(pair . 0) (pair head))))) + (build-term + ($continue khead src + ($primcall 'allocate-words/immediate '(pair . 2) ())))))) + +(define-primcall-converter car + (lambda (cps k src op param pair) + (ensure-pair + cps src 'car 'pair? pair + (lambda (cps) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-ref/immediate '(pair . 0) (pair))))))))) + +(define-primcall-converter cdr + (lambda (cps k src op param pair) + (ensure-pair + cps src 'cdr 'pair? pair + (lambda (cps) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-ref/immediate '(pair . 1) (pair))))))))) + +(define-primcall-converter set-car! + (lambda (cps k src op param pair val) + (ensure-pair + ;; FIXME: Use mutable-pair? as predicate. + cps src 'set-car! 'pair? pair + (lambda (cps) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-set!/immediate '(pair . 0) (pair val))))))))) + +(define-primcall-converter set-cdr! + (lambda (cps k src op param pair val) + (ensure-pair + ;; FIXME: Use mutable-pair? as predicate. + cps src 'set-cdr! 'pair? pair + (lambda (cps) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-set!/immediate '(pair . 1) (pair val))))))))) + +(define-primcall-converter box + (lambda (cps k src op param val) + (with-cps cps + (letv obj tag) + (letk kdone + ($kargs () () + ($continue k src ($values (obj))))) + (letk kval + ($kargs () () + ($continue kdone src + ($primcall 'scm-set!/immediate '(box . 1) (obj val))))) + (letk ktag1 + ($kargs ('tag) (tag) + ($continue kval src + ($primcall 'word-set!/immediate '(box . 0) (obj tag))))) + (letk ktag0 + ($kargs ('obj) (obj) + ($continue ktag1 src + ($primcall 'load-u64 %tc7-variable ())))) + (build-term + ($continue ktag0 src + ($primcall 'allocate-words/immediate '(box . 2) ())))))) + +(define (ensure-box cps src op x is-box) + (define not-box + (vector 'wrong-type-arg + (symbol->string op) + "Wrong type argument in position 1 (expecting box): ~S")) + (with-cps cps + (letk knot-box ($kargs () () ($throw src 'throw/value+data not-box (x)))) + (let$ body (is-box)) + (letk k ($kargs () () ,body)) + (letk kheap-object ($kargs () () ($branch knot-box k src 'variable? #f (x)))) + (build-term ($branch knot-box kheap-object src 'heap-object? #f (x))))) + +(define-primcall-converter box-ref + (lambda (cps k src op param box) + (define unbound + #(misc-error "variable-ref" "Unbound variable: ~S")) + (ensure-box + cps src 'variable-ref box + (lambda (cps) + (with-cps cps + (letv val) + (letk kunbound ($kargs () () ($throw src 'throw/value unbound (box)))) + (letk kbound ($kargs () () ($continue k src ($values (val))))) + (letk ktest + ($kargs ('val) (val) + ($branch kbound kunbound src 'undefined? #f (val)))) + (build-term + ($continue ktest src + ($primcall 'scm-ref/immediate '(box . 1) (box))))))))) + +(define-primcall-converter box-set! + (lambda (cps k src op param box val) + (ensure-box + cps src 'variable-set! box + (lambda (cps) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box val))))))))) + +(define (ensure-struct cps src op x have-vtable) + (define not-struct + (vector 'wrong-type-arg + (symbol->string op) + "Wrong type argument in position 1 (expecting struct): ~S")) + (with-cps cps + (letv vtable) + (letk knot-struct + ($kargs () () ($throw src 'throw/value+data not-struct (x)))) + (let$ body (have-vtable vtable)) + (letk k ($kargs ('vtable) (vtable) ,body)) + (letk kvtable ($kargs () () + ($continue k src ($primcall 'scm-ref/tag 'struct (x))))) + (letk kheap-object + ($kargs () () ($branch knot-struct kvtable src 'struct? #f (x)))) + (build-term ($branch knot-struct kheap-object src 'heap-object? #f (x))))) + +(define-primcall-converter struct-vtable + (lambda (cps k src op param struct) + (ensure-struct + cps src 'struct-vtable struct + (lambda (cps vtable) + (with-cps cps + (build-term + ($continue k src ($values (vtable))))))))) + +(define (ensure-vtable cps src op vtable is-vtable) + (ensure-struct + cps src op vtable + (lambda (cps vtable-vtable) + (define not-vtable + (vector 'wrong-type-arg + (symbol->string op) + "Wrong type argument in position 1 (expecting vtable): ~S")) + (define vtable-index-flags 1) ; FIXME: pull from struct.h + (define vtable-offset-flags (1+ vtable-index-flags)) + (define vtable-validated-mask #b11) + (define vtable-validated-value #b11) + (with-cps cps + (letv flags mask res) + (letk knot-vtable + ($kargs () () ($throw src 'throw/value+data not-vtable (vtable)))) + (let$ body (is-vtable)) + (letk k ($kargs () () ,body)) + (letk ktest + ($kargs ('res) (res) + ($branch knot-vtable k src + 'u64-imm-= vtable-validated-value (res)))) + (letk kand + ($kargs ('mask) (mask) + ($continue ktest src + ($primcall 'ulogand #f (flags mask))))) + (letk kflags + ($kargs ('flags) (flags) + ($continue kand src + ($primcall 'load-u64 vtable-validated-mask ())))) + (build-term + ($continue kflags src + ($primcall 'word-ref/immediate + `(struct . ,vtable-offset-flags) (vtable-vtable)))))))) + +(define-primcall-converter allocate-struct + (lambda (cps k src op nwords vtable) + (ensure-vtable + cps src 'allocate-struct vtable + (lambda (cps) + (define vtable-index-size 5) ; FIXME: pull from struct.h + (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h + (define vtable-offset-size (1+ vtable-index-size)) + (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields)) + (define wrong-number + (vector 'wrong-number-of-args + (symbol->string op) + "Wrong number of initializers when instantiating ~A")) + (define has-unboxed + (vector 'wrong-type-arg + (symbol->string op) + "Expected vtable with no unboxed fields: ~A")) + (define (check-all-boxed cps kf kt vtable ptr word) + (if (< (* word 32) nwords) + (with-cps cps + (letv idx bits) + (let$ checkboxed (check-all-boxed kf kt vtable ptr (1+ word))) + (letk kcheckboxed ($kargs () () ,checkboxed)) + (letk kcheck + ($kargs ('bits) (bits) + ($branch kf kcheckboxed src 'u64-imm-= 0 (bits)))) + (letk kword + ($kargs ('idx) (idx) + ($continue kcheck src + ($primcall 'u32-ref 'bitmask (vtable ptr idx))))) + (build-term + ($continue kword src + ($primcall 'load-u64 word ())))) + (with-cps cps + (build-term ($continue kt src ($values ())))))) + (with-cps cps + (letv rfields nfields ptr s) + (letk kwna + ($kargs () () ($throw src 'throw/value wrong-number (vtable)))) + (letk kunboxed + ($kargs () () ($throw src 'throw/value+data has-unboxed (vtable)))) + (letk kdone + ($kargs () () ($continue k src ($values (s))))) + (letk ktag + ($kargs ('s) (s) + ($continue kdone src + ($primcall 'scm-set!/tag 'struct (s vtable))))) + (letk kalloc + ($kargs () () + ($continue ktag src + ($primcall 'allocate-words/immediate + `(struct . ,(1+ nwords)) ())))) + (let$ checkboxed (check-all-boxed kunboxed kalloc vtable ptr 0)) + (letk kcheckboxed ($kargs ('ptr) (ptr) ,checkboxed)) + (letk kaccess + ($kargs () () + ($continue kcheckboxed src + ($primcall 'pointer-ref/immediate + `(struct . ,vtable-offset-unboxed-fields) + (vtable))))) + (letk knfields + ($kargs ('nfields) (nfields) + ($branch kwna kaccess src 'u64-imm-= nwords (nfields)))) + (letk kassume + ($kargs ('rfields) (rfields) + ($continue knfields src + ($primcall 'assume-u64 `(0 . ,(target-max-size-t/scm)) + (rfields))))) + (build-term + ($continue kassume src + ($primcall 'word-ref/immediate + `(struct . ,vtable-offset-size) (vtable))))))))) + +(define (ensure-struct-index-in-range cps src op vtable idx boxed? in-range) + (define vtable-index-size 5) ; FIXME: pull from struct.h + (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h + (define vtable-offset-size (1+ vtable-index-size)) + (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields)) + (define bad-type + (vector + 'wrong-type-arg + (symbol->string op) + (if boxed? + "Wrong type argument in position 2 (expecting boxed field): ~S" + "Wrong type argument in position 2 (expecting unboxed field): ~S"))) + (define out-of-range + (vector 'out-of-range + (symbol->string op) + "Argument 2 out of range: ~S")) + (with-cps cps + (letv rfields nfields ptr word bits mask res throwval1 throwval2) + (letk kthrow1 + ($kargs (#f) (throwval1) + ($throw src 'throw/value+data out-of-range (throwval1)))) + (letk kthrow2 + ($kargs (#f) (throwval2) + ($throw src 'throw/value+data bad-type (throwval2)))) + (letk kbadidx ($kargs () () ($continue kthrow1 src ($const idx)))) + (letk kbadtype ($kargs () () ($continue kthrow2 src ($const idx)))) + + (let$ body (in-range)) + (letk k ($kargs () () ,body)) + (letk ktest + ($kargs ('res) (res) + ($branch (if boxed? kbadtype k) (if boxed? k kbadtype) src + 'u64-imm-= 0 (res)))) + (letk kand + ($kargs ('mask) (mask) + ($continue ktest src + ($primcall 'ulogand #f (mask bits))))) + (letk kbits + ($kargs ('bits) (bits) + ($continue kand src + ($primcall 'load-u64 (ash 1 (logand idx 31)) ())))) + (letk kword + ($kargs ('word) (word) + ($continue kbits src + ($primcall 'u32-ref 'bitmask (vtable ptr word))))) + (letk kptr + ($kargs ('ptr) (ptr) + ($continue kword src + ($primcall 'load-u64 (ash idx -5) ())))) + (letk kaccess + ($kargs () () + ($continue kptr src + ($primcall 'pointer-ref/immediate + `(struct . ,vtable-offset-unboxed-fields) + (vtable))))) + (letk knfields + ($kargs ('nfields) (nfields) + ($branch kbadidx kaccess src 'imm-u64-< idx (nfields)))) + (letk kassume + ($kargs ('rfields) (rfields) + ($continue knfields src + ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (rfields))))) + (build-term + ($continue kassume src + ($primcall 'word-ref/immediate + `(struct . ,vtable-offset-size) (vtable)))))) + +(define (prepare-struct-scm-access cps src op struct idx boxed? have-pos) + (define not-struct + (vector 'wrong-type-arg + (symbol->string op) + "Wrong type argument in position 1 (expecting struct): ~S")) + (ensure-struct + cps src op struct + (lambda (cps vtable) + (ensure-struct-index-in-range + cps src op vtable idx boxed? + (lambda (cps) (have-pos cps (1+ idx))))))) + +(define-primcall-converter struct-ref/immediate + (lambda (cps k src op param struct) + (prepare-struct-scm-access + cps src op struct param #t + (lambda (cps pos) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-ref/immediate `(struct . ,pos) (struct))))))))) + +(define-primcall-converter struct-set!/immediate + (lambda (cps k src op param struct val) + (prepare-struct-scm-access + cps src op struct param #t + (lambda (cps pos) + (with-cps cps + (letk k* ($kargs () () ($continue k src ($values (val))))) + (build-term + ($continue k* src + ($primcall 'scm-set!/immediate `(struct . ,pos) (struct val))))))))) + +(define-primcall-converter struct-init! + (lambda (cps k src op param s val) + (define pos (1+ param)) + (with-cps cps + (build-term + ($continue k src + ($primcall 'scm-set!/immediate `(struct . ,pos) (s val))))))) + +(define-primcall-converter struct-ref + (lambda (cps k src op param struct idx) + (with-cps cps + (letv prim res) + (letk krecv ($kreceive '(res) #f k)) + (letk kprim ($kargs ('prim) (prim) + ($continue krecv src ($call prim (struct idx))))) + (build-term + ($continue kprim src ($prim 'struct-ref)))))) + +(define-primcall-converter struct-set! + (lambda (cps k src op param struct idx val) + (with-cps cps + (letv prim res) + ;; struct-set! prim returns the value. + (letk krecv ($kreceive '(res) #f k)) + (letk kprim ($kargs ('prim) (prim) + ($continue krecv src ($call prim (struct idx val))))) + (build-term + ($continue kprim src ($prim 'struct-set!)))))) + +(define (untag-bytevector-index cps src op idx ulen width have-uidx) + (define not-fixnum + (vector 'wrong-type-arg + (symbol->string op) + "Wrong type argument in position 2 (expecting small integer): ~S")) + (define out-of-range + (vector 'out-of-range + (symbol->string op) + "Argument 2 out of range: ~S")) + (with-cps cps + (letv sidx uidx maxidx+1) + (letk knot-fixnum + ($kargs () () ($throw src 'throw/value+data not-fixnum (idx)))) + (letk kout-of-range + ($kargs () () ($throw src 'throw/value+data out-of-range (idx)))) + (let$ body (have-uidx uidx)) + (letk k ($kargs () () ,body)) + (letk ktestidx + ($kargs ('maxidx+1) (maxidx+1) + ($branch kout-of-range k src 'u64-< #f (uidx maxidx+1)))) + (letk kdeclen + ($kargs () () + ($continue ktestidx src + ($primcall 'usub/immediate (1- width) (ulen))))) + (letk ktestlen + ($kargs ('uidx) (uidx) + ($branch kout-of-range kdeclen src 'imm-u64-< (1- width) (ulen)))) + (letk kcvt + ($kargs () () + ($continue ktestlen src ($primcall 's64->u64 #f (sidx))))) + (letk kbound0 + ($kargs ('sidx) (sidx) + ($branch kcvt kout-of-range src 's64-imm-< 0 (sidx)))) + (letk kuntag + ($kargs () () + ($continue kbound0 src ($primcall 'untag-fixnum #f (idx))))) + (build-term ($branch knot-fixnum kuntag src 'fixnum? #f (idx))))) + +(define (ensure-bytevector cps k src op pred x) + (define msg + (match pred + ('bytevector? + "Wrong type argument in position 1 (expecting bytevector): ~S") + ('mutable-bytevector? + "Wrong type argument in position 1 (expecting mutable bytevector): ~S"))) + (define bad-type (vector 'wrong-type-arg (symbol->string op) msg)) + (with-cps cps + (letk kf ($kargs () () ($throw src 'throw/value+data bad-type (x)))) + (letk kheap-object ($kargs () () ($branch kf k src pred #f (x)))) + (build-term ($branch kf kheap-object src 'heap-object? #f (x))))) + +(define (prepare-bytevector-access cps src op pred bv idx width + have-ptr-and-uidx) + (with-cps cps + (letv ulen rlen) + (let$ access + (untag-bytevector-index + src op idx rlen width + (lambda (cps uidx) + (with-cps cps + (letv ptr) + (let$ body (have-ptr-and-uidx ptr uidx)) + (letk k ($kargs ('ptr) (ptr) ,body)) + (build-term + ($continue k src + ($primcall 'pointer-ref/immediate '(bytevector . 2) + (bv)))))))) + (letk k ($kargs ('rlen) (rlen) ,access)) + (letk kassume + ($kargs ('ulen) (ulen) + ($continue k src + ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen))))) + (letk klen + ($kargs () () + ($continue kassume src + ($primcall 'word-ref/immediate '(bytevector . 1) (bv))))) + ($ (ensure-bytevector klen src op pred bv)))) + +(define (bytevector-ref-converter scheme-name ptr-op width kind) + (define tag + (match kind + ('unsigned + (if (< (ash 1 (* width 8)) (target-most-positive-fixnum)) + (lambda (cps k src val) + (with-cps cps + (letv s) + (letk kcvt + ($kargs ('s) (s) + ($continue k src ($primcall 'tag-fixnum #f (s))))) + (build-term + ($continue kcvt src ($primcall 'u64->s64 #f (val)))))) + (lambda (cps k src val) + (with-cps cps + (build-term + ($continue k src ($primcall 'u64->scm #f (val)))))))) + ('signed + (if (< (ash 1 (* width 8)) (target-most-positive-fixnum)) + (lambda (cps k src val) + (with-cps cps + (build-term + ($continue k src ($primcall 'tag-fixnum #f (val)))))) + (lambda (cps k src val) + (with-cps cps + (build-term + ($continue k src ($primcall 's64->scm #f (val)))))))) + ('float + (lambda (cps k src val) + (with-cps cps + (build-term + ($continue k src ($primcall 'f64->scm #f (val))))))))) + (lambda (cps k src op param bv idx) + (prepare-bytevector-access + cps src scheme-name 'bytevector? bv idx width + (lambda (cps ptr uidx) + (with-cps cps + (letv val) + (let$ body (tag k src val)) + (letk ktag ($kargs ('val) (val) ,body)) + (build-term + ($continue ktag src + ($primcall ptr-op 'bytevector (bv ptr uidx))))))))) + +(define (bytevector-set-converter scheme-name ptr-op width kind) + (define out-of-range + (vector 'out-of-range + (symbol->string scheme-name) + "Argument 3 out of range: ~S")) + (define (limit-urange cps src val uval hi in-range) + (with-cps cps + (letk kbad ($kargs () () + ($throw src 'throw/value+data out-of-range (val)))) + (let$ body (in-range uval)) + (letk k ($kargs () () ,body)) + (build-term + ($branch k kbad src 'imm-u64-< hi (uval))))) + (define (limit-srange cps src val sval lo hi in-range) + (with-cps cps + (letk kbad ($kargs () () + ($throw src 'throw/value+data out-of-range (val)))) + (let$ body (in-range sval)) + (letk k ($kargs () () ,body)) + (letk k' ($kargs () () + ($branch k kbad src 's64-imm-< lo (sval)))) + (build-term + ($branch k' kbad src 'imm-s64-< hi (sval))))) + (define (integer-unboxer lo hi) + (cond + ((<= hi (target-most-positive-fixnum)) + (lambda (cps src val have-val) + (let ((have-val (if (zero? lo) + (lambda (cps s) + (with-cps cps + (letv u) + (let$ body (have-val u)) + (letk k ($kargs ('u) (u) ,body)) + (build-term + ($continue k src + ($primcall 's64->u64 #f (s)))))) + have-val))) + (with-cps cps + (letv sval) + (letk kbad ($kargs () () + ($throw src 'throw/value+data out-of-range (val)))) + (let$ body (have-val sval)) + (letk k ($kargs () () ,body)) + (letk khi ($kargs () () + ($branch k kbad src 'imm-s64-< hi (sval)))) + (letk klo ($kargs ('sval) (sval) + ($branch khi kbad src 's64-imm-< lo (sval)))) + (letk kuntag + ($kargs () () + ($continue klo src ($primcall 'untag-fixnum #f (val))))) + (build-term + ($branch kbad kuntag src 'fixnum? #f (val))))))) + ((zero? lo) + (lambda (cps src val have-val) + (with-cps cps + (letv u) + (let$ body (limit-urange src val u hi have-val)) + (letk khi ($kargs ('u) (u) ,body)) + (build-term + ($continue khi src ($primcall 'scm->u64 #f (val))))))) + (else + (lambda (cps src val have-val) + (with-cps cps + (letv s) + (let$ body (limit-srange src val s lo hi have-val)) + (letk khi ($kargs ('s) (s) ,body)) + (build-term + ($continue khi src ($primcall 'scm->s64 #f (val))))))))) + (define untag + (match kind + ('unsigned (integer-unboxer 0 (1- (ash 1 (* width 8))))) + ('signed (integer-unboxer (ash -1 (1- (* width 8))) + (1- (ash 1 (1- (* width 8)))))) + ('float + (lambda (cps src val have-val) + (with-cps cps + (letv f) + (let$ body (have-val f)) + (letk k ($kargs ('f) (f) ,body)) + (build-term + ($continue k src ($primcall 'scm->f64 #f (val))))))))) + (lambda (cps k src op param bv idx val) + (prepare-bytevector-access + cps src scheme-name 'bytevector? bv idx width + (lambda (cps ptr uidx) + (untag + cps src val + (lambda (cps uval) + (with-cps cps + (build-term + ($continue k src + ($primcall ptr-op 'bytevector (bv ptr uidx uval))))))))))) + +(define-syntax-rule (define-bytevector-ref-converter + cps-name scheme-name op width kind) + (define-primcall-converter cps-name + (bytevector-ref-converter 'scheme-name 'op width 'kind))) +(define-syntax-rule (define-bytevector-ref-converters (cvt ...) ...) + (begin + (define-bytevector-ref-converter cvt ...) + ...)) + +(define-syntax-rule (define-bytevector-set-converter + cps-name scheme-name op width kind) + (define-primcall-converter cps-name + (bytevector-set-converter 'scheme-name 'op width 'kind))) +(define-syntax-rule (define-bytevector-set-converters (cvt ...) ...) + (begin + (define-bytevector-set-converter cvt ...) + ...)) + +(define-primcall-converter bv-length + (lambda (cps k src op param bv) + (with-cps cps + (letv ulen rlen) + (letk ktag ($kargs ('rlen) (rlen) + ($continue k src ($primcall 'u64->scm #f (rlen))))) + (letk kassume + ($kargs ('ulen) (ulen) + ($continue ktag src + ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen))))) + (letk klen + ($kargs () () + ($continue kassume src + ($primcall 'word-ref/immediate '(bytevector . 1) (bv))))) + ($ (ensure-bytevector klen src op 'bytevector? bv))))) + +(define-bytevector-ref-converters + (bv-u8-ref bytevector-u8-ref u8-ref 1 unsigned) + (bv-u16-ref bytevector-u16-native-ref u16-ref 2 unsigned) + (bv-u32-ref bytevector-u32-native-ref u32-ref 4 unsigned) + (bv-u64-ref bytevector-u64-native-ref u64-ref 8 unsigned) + (bv-s8-ref bytevector-s8-ref s8-ref 1 signed) + (bv-s16-ref bytevector-s16-native-ref s16-ref 2 signed) + (bv-s32-ref bytevector-s32-native-ref s32-ref 4 signed) + (bv-s64-ref bytevector-s64-native-ref s64-ref 8 signed) + (bv-f32-ref bytevector-ieee-single-native-ref f32-ref 4 float) + (bv-f64-ref bytevector-ieee-double-native-ref f64-ref 8 float)) + +(define-bytevector-set-converters + (bv-u8-set! bytevector-u8-set! u8-set! 1 unsigned) + (bv-u16-set! bytevector-u16-native-set! u16-set! 2 unsigned) + (bv-u32-set! bytevector-u32-native-set! u32-set! 4 unsigned) + (bv-u64-set! bytevector-u64-native-set! u64-set! 8 unsigned) + (bv-s8-set! bytevector-s8-set! s8-set! 1 signed) + (bv-s16-set! bytevector-s16-native-set! s16-set! 2 signed) + (bv-s32-set! bytevector-s32-native-set! s32-set! 4 signed) + (bv-s64-set! bytevector-s64-native-set! s64-set! 8 signed) + (bv-f32-set! bytevector-ieee-single-native-set! f32-set! 4 float) + (bv-f64-set! bytevector-ieee-double-native-set! f64-set! 8 float)) + +(define (ensure-string cps src op x have-length) + (define msg "Wrong type argument in position 1 (expecting string): ~S") + (define not-string (vector 'wrong-type-arg (symbol->string op) msg)) + (with-cps cps + (letv ulen rlen) + (letk knot-string + ($kargs () () ($throw src 'throw/value+data not-string (x)))) + (let$ body (have-length rlen)) + (letk k ($kargs ('rlen) (rlen) ,body)) + (letk kassume + ($kargs ('ulen) (ulen) + ($continue k src + ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen))))) + (letk ks + ($kargs () () + ($continue kassume src + ($primcall 'word-ref/immediate '(string . 3) (x))))) + (letk kheap-object + ($kargs () () + ($branch knot-string ks src 'string? #f (x)))) + (build-term + ($branch knot-string kheap-object src 'heap-object? #f (x))))) + +(define (ensure-char cps src op x have-char) + (define msg "Wrong type argument (expecting char): ~S") + (define not-char (vector 'wrong-type-arg (symbol->string op) msg)) + (with-cps cps + (letv uchar) + (letk knot-char + ($kargs () () ($throw src 'throw/value+data not-char (x)))) + (let$ body (have-char uchar)) + (letk k ($kargs ('uchar) (uchar) ,body)) + (letk kchar + ($kargs () () ($continue k src ($primcall 'untag-char #f (x))))) + (build-term + ($branch knot-char kchar src 'char? #f (x))))) + +(define-primcall-converter string-length + (lambda (cps k src op param x) + (ensure-string + cps src op x + (lambda (cps ulen) + (with-cps cps + (build-term + ($continue k src ($primcall 'u64->scm #f (ulen))))))))) + +(define-primcall-converter string-ref + (lambda (cps k src op param s idx) + (define out-of-range + #(out-of-range string-ref "Argument 2 out of range: ~S")) + (define stringbuf-f-wide #x400) + (ensure-string + cps src op s + (lambda (cps ulen) + (with-cps cps + (letv uidx start upos buf ptr tag mask bits uwpos u32 uchar) + (letk kout-of-range + ($kargs () () + ($throw src 'throw/value+data out-of-range (idx)))) + (letk kchar + ($kargs ('uchar) (uchar) + ($continue k src + ($primcall 'tag-char #f (uchar))))) + (letk kassume + ($kargs ('u32) (u32) + ($continue kchar src + ($primcall 'assume-u64 '(0 . #xffffff) (u32))))) + (letk kwideref + ($kargs ('uwpos) (uwpos) + ($continue kassume src + ($primcall 'u32-ref 'stringbuf (buf ptr uwpos))))) + (letk kwide + ($kargs () () + ($continue kwideref src + ($primcall 'ulsh/immediate 2 (upos))))) + (letk knarrow + ($kargs () () + ($continue kchar src + ($primcall 'u8-ref 'stringbuf (buf ptr upos))))) + (letk kcmp + ($kargs ('bits) (bits) + ($branch kwide knarrow src 'u64-imm-= 0 (bits)))) + (letk kmask + ($kargs ('mask) (mask) + ($continue kcmp src + ($primcall 'ulogand #f (tag mask))))) + (letk ktag + ($kargs ('tag) (tag) + ($continue kmask src + ($primcall 'load-u64 stringbuf-f-wide ())))) + (letk kptr + ($kargs ('ptr) (ptr) + ($continue ktag src + ($primcall 'word-ref/immediate '(stringbuf . 0) (buf))))) + (letk kwidth + ($kargs ('buf) (buf) + ($continue kptr src + ($primcall 'tail-pointer-ref/immediate '(stringbuf . 2) (buf))))) + (letk kbuf + ($kargs ('upos) (upos) + ($continue kwidth src + ($primcall 'scm-ref/immediate '(string . 1) (s))))) + (letk kadd + ($kargs ('start) (start) + ($continue kbuf src + ($primcall 'uadd #f (start uidx))))) + (letk kstart + ($kargs () () + ($continue kadd src + ($primcall 'word-ref/immediate '(string . 2) (s))))) + (letk krange + ($kargs ('uidx) (uidx) + ($branch kout-of-range kstart src 'u64-< #f (uidx ulen)))) + (build-term + ($continue krange src ($primcall 'scm->u64 #f (idx))))))))) + +(define-primcall-converter string-set! + (lambda (cps k src op param s idx ch) + (define out-of-range + #(out-of-range string-ref "Argument 2 out of range: ~S")) + (define stringbuf-f-wide #x400) + (ensure-string + cps src op s + (lambda (cps ulen) + (ensure-char + cps src op ch + (lambda (cps uchar) + (with-cps cps + (letv uidx) + (letk kout-of-range + ($kargs () () + ($throw src 'throw/value+data out-of-range (idx)))) + (letk kuidx + ($kargs () () + ($continue k src + ($primcall 'string-set! #f (s uidx uchar))))) + (letk krange + ($kargs ('uidx) (uidx) + ($branch kout-of-range kuidx src 'u64-< #f (uidx ulen)))) + (build-term + ($continue krange src ($primcall 'scm->u64 #f (idx))))))))))) + +(define-primcall-converter integer->char + (lambda (cps k src op param i) + (define not-fixnum + #(wrong-type-arg + "integer->char" + "Wrong type argument in position 1 (expecting small integer): ~S")) + (define out-of-range + #(out-of-range + "integer->char" + "Argument 1 out of range: ~S")) + (define codepoint-surrogate-start #xd800) + (define codepoint-surrogate-end #xdfff) + (define codepoint-max #x10ffff) + (with-cps cps + (letv si ui) + (letk knot-fixnum + ($kargs () () ($throw src 'throw/value+data not-fixnum (i)))) + (letk kf + ($kargs () () ($throw src 'throw/value+data out-of-range (i)))) + (letk ktag ($kargs ('ui) (ui) + ($continue k src ($primcall 'tag-char #f (ui))))) + (letk kt ($kargs () () + ($continue ktag src ($primcall 's64->u64 #f (si))))) + (letk kmax + ($kargs () () + ($branch kt kf src 'imm-s64-< codepoint-max (si)))) + (letk khi + ($kargs () () + ($branch kf kmax src 'imm-s64-< codepoint-surrogate-end (si)))) + (letk klo + ($kargs () () + ($branch khi kt src 's64-imm-< codepoint-surrogate-start (si)))) + (letk kbound0 + ($kargs ('si) (si) + ($branch klo kf src 's64-imm-< 0 (si)))) + (letk kuntag + ($kargs () () + ($continue kbound0 src ($primcall 'untag-fixnum #f (i))))) + (build-term ($branch knot-fixnum kuntag src 'fixnum? #f (i)))))) + +(define-primcall-converter char->integer + (lambda (cps k src op param ch) + (define not-char + #(wrong-type-arg + "char->integer" + "Wrong type argument in position 1 (expecting char): ~S")) + (with-cps cps + (letv ui si) + (letk knot-char + ($kargs () () ($throw src 'throw/value+data not-char (ch)))) + (letk ktag ($kargs ('si) (si) + ($continue k src ($primcall 'tag-fixnum #f (si))))) + (letk kcvt ($kargs ('ui) (ui) + ($continue ktag src ($primcall 'u64->s64 #f (ui))))) + (letk kuntag ($kargs () () + ($continue kcvt src ($primcall 'untag-char #f (ch))))) + (build-term + ($branch knot-char kuntag src 'char? #f (ch)))))) + +(define (convert-shift cps k src op param obj idx) + (with-cps cps + (letv idx') + (letk k' ($kargs ('idx) (idx') + ($continue k src ($primcall op param (obj idx'))))) + (build-term ($continue k' src ($primcall 'scm->u64 #f (idx)))))) + +(define-primcall-converter rsh convert-shift) +(define-primcall-converter lsh convert-shift) + +(define-primcall-converter make-atomic-box + (lambda (cps k src op param val) + (with-cps cps + (letv obj tag) + (letk kdone + ($kargs () () + ($continue k src ($values (obj))))) + (letk kval + ($kargs () () + ($continue kdone src + ($primcall 'atomic-scm-set!/immediate '(atomic-box . 1) (obj val))))) + (letk ktag1 + ($kargs ('tag) (tag) + ($continue kval src + ($primcall 'word-set!/immediate '(atomic-box . 0) (obj tag))))) + (letk ktag0 + ($kargs ('obj) (obj) + ($continue ktag1 src + ($primcall 'load-u64 %tc7-atomic-box ())))) + (build-term + ($continue ktag0 src + ($primcall 'allocate-words/immediate '(atomic-box . 2) ())))))) + +(define (ensure-atomic-box cps src op x is-atomic-box) + (define bad-type + (vector 'wrong-type-arg + (symbol->string op) + "Wrong type argument in position 1 (expecting atomic box): ~S")) + (with-cps cps + (letk kbad ($kargs () () ($throw src 'throw/value+data bad-type (x)))) + (let$ body (is-atomic-box)) + (letk k ($kargs () () ,body)) + (letk kheap-object ($kargs () () ($branch kbad k src 'atomic-box? #f (x)))) + (build-term ($branch kbad kheap-object src 'heap-object? #f (x))))) + +(define-primcall-converter atomic-box-ref + (lambda (cps k src op param x) + (ensure-atomic-box + cps src 'atomic-box-ref x + (lambda (cps) + (with-cps cps + (letv val) + (build-term + ($continue k src + ($primcall 'atomic-scm-ref/immediate '(atomic-box . 1) (x))))))))) + +(define-primcall-converter atomic-box-set! + (lambda (cps k src op param x val) + (ensure-atomic-box + cps src 'atomic-box-set! x + (lambda (cps) + (with-cps cps + (build-term + ($continue k src + ($primcall 'atomic-scm-set!/immediate '(atomic-box . 1) + (x val))))))))) + +(define-primcall-converter atomic-box-swap! + (lambda (cps k src op param x val) + (ensure-atomic-box + cps src 'atomic-box-swap! x + (lambda (cps) + (with-cps cps + (build-term + ($continue k src + ($primcall 'atomic-scm-swap!/immediate '(atomic-box . 1) + (x val))))))))) + +(define-primcall-converter atomic-box-compare-and-swap! + (lambda (cps k src op param x expected desired) + (ensure-atomic-box + cps src 'atomic-box-compare-and-swap! x + (lambda (cps) + (with-cps cps + (build-term + ($continue k src + ($primcall 'atomic-scm-compare-and-swap!/immediate '(atomic-box . 1) + (x expected desired))))))))) + +;;; Guile's semantics are that a toplevel lambda captures a reference on +;;; the current module, and that all contained lambdas use that module +;;; to resolve toplevel variables. This parameter tracks whether or not +;;; we are in a toplevel lambda. If we are in a lambda, the parameter +;;; is bound to a fresh name identifying the module that was current +;;; when the toplevel lambda is defined. +;;; +;;; This is more complicated than it need be. Ideally we should resolve +;;; all toplevel bindings to bindings from specific modules, unless the +;;; binding is unbound. This is always valid if the compilation unit +;;; sets the module explicitly, as when compiling a module, but it +;;; doesn't work for files auto-compiled for use with `load'. +;;; +(define current-topbox-scope (make-parameter #f)) +(define scope-counter (make-parameter #f)) + +(define (fresh-scope-id) + (let ((scope-id (scope-counter))) + (scope-counter (1+ scope-id)) + scope-id)) + +(define (toplevel-box cps src name bound? have-var) + (define %unbound + #(unbound-variable #f "Unbound variable: ~S")) + (match (current-topbox-scope) + (#f + (with-cps cps + (letv mod name-var box) + (letk kbad ($kargs () () ($throw src 'throw/value %unbound (name-var)))) + (let$ body + ((if bound? + (lambda (cps) + (with-cps cps + (letv val) + (let$ body (have-var box)) + (letk kdef ($kargs () () ,body)) + (letk ktest ($kargs ('val) (val) + ($branch kdef kbad src + 'undefined? #f (val)))) + (build-term + ($continue ktest src + ($primcall 'scm-ref/immediate + '(box . 1) (box)))))) + (lambda (cps) + (with-cps cps + ($ (have-var box))))))) + (letk ktest ($kargs () () ,body)) + (letk kbox ($kargs ('box) (box) + ($branch kbad ktest src 'heap-object? #f (box)))) + (letk kname ($kargs ('name) (name-var) + ($continue kbox src + ($primcall 'lookup #f (mod name-var))))) + (letk kmod ($kargs ('mod) (mod) + ($continue kname src ($const name)))) + (build-term + ($continue kmod src ($primcall 'current-module #f ()))))) + (scope + (with-cps cps + (letv box) + (let$ body (have-var box)) + (letk kbox ($kargs ('box) (box) ,body)) + ($ (convert-primcall kbox src 'cached-toplevel-box + (list scope name bound?))))))) + +(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)) + ($ (convert-primcall kbox src 'cached-module-box + (list module name public? bound?))))) + +(define (capture-toplevel-scope cps src scope-id k) + (with-cps cps + (letv module) + (let$ body (convert-primcall k src 'cache-current-module! + (list scope-id) module)) + (letk kmodule ($kargs ('module) (module) ,body)) + ($ (convert-primcall kmodule src 'current-module #f)))) + +(define (fold-formals proc seed arity gensyms inits) + (match arity + (($ $arity req opt rest kw allow-other-keys?) + (let () + (define (fold-req names gensyms seed) + (match names + (() (fold-opt opt gensyms inits seed)) + ((name . names) + (proc name (car gensyms) #f + (fold-req names (cdr gensyms) seed))))) + (define (fold-opt names gensyms inits seed) + (match names + (() (fold-rest rest gensyms inits seed)) + ((name . names) + (proc name (car gensyms) (car inits) + (fold-opt names (cdr gensyms) (cdr inits) seed))))) + (define (fold-rest rest gensyms inits seed) + (match rest + (#f (fold-kw kw gensyms inits seed)) + (name (proc name (car gensyms) #f + (fold-kw kw (cdr gensyms) inits seed))))) + (define (fold-kw kw gensyms inits seed) + (match kw + (() + (unless (null? gensyms) + (error "too many gensyms")) + (unless (null? inits) + (error "too many inits")) + seed) + (((key name var) . kw) + ;; Could be that var is not a gensym any more. + (when (symbol? var) + (unless (eq? var (car gensyms)) + (error "unexpected keyword arg order"))) + (proc name (car gensyms) (car inits) + (fold-kw kw (cdr gensyms) (cdr inits) seed))))) + (fold-req req gensyms seed))))) + +(define (init-default-value cps name sym subst init body) + (match (hashq-ref subst sym) + ((orig-var subst-var box?) + (let ((src (tree-il-src init))) + (define (maybe-box cps k make-body) + (if box? + (with-cps cps + (letv phi) + (let$ body (convert-primcall k src 'box #f phi)) + (letk kbox ($kargs (name) (phi) ,body)) + ($ (make-body kbox))) + (make-body cps k))) + (with-cps cps + (letk knext ($kargs (name) (subst-var) ,body)) + ($ (maybe-box + knext + (lambda (cps k) + (with-cps cps + (letk kbound ($kargs () () ($continue k src + ($values (orig-var))))) + (letv val rest) + (letk krest ($kargs (name 'rest) (val rest) + ($continue k src ($values (val))))) + (letk kreceive ($kreceive (list name) 'rest krest)) + (let$ init (convert init kreceive subst)) + (letk kunbound ($kargs () () ,init)) + (build-term + ($branch kbound kunbound src + 'undefined? #f (orig-var)))))))))))) + +(define (build-list cps k src vals) + (match vals + (() + (with-cps cps + (build-term ($continue k src ($const '()))))) + ((v . vals) + (with-cps cps + (letv tail) + (let$ head (convert-primcall k src 'cons #f v tail)) + (letk ktail ($kargs ('tail) (tail) ,head)) + ($ (build-list ktail src vals)))))) + +;;; The conversion from Tree-IL to CPS essentially wraps every +;;; expression in a $kreceive, which models the Tree-IL semantics that +;;; extra values are simply truncated. In CPS, this means that the +;;; $kreceive has a rest argument after the required arguments, if any, +;;; and that the rest argument is unused. +;;; +;;; All CPS expressions that can return a variable number of values +;;; (i.e., $call and $abort) must continue to $kreceive, which checks +;;; the return arity and on success passes the parsed values along to a +;;; $kargs. If the $call or $abort is in tail position they continue to +;;; $ktail instead, and then the values are parsed by the $kreceive of +;;; the non-tail caller. +;;; +;;; Other CPS terms like $values, $const, and the like all have a +;;; specific return arity, and must continue to $kargs instead of +;;; $kreceive or $ktail. This allows the compiler to reason precisely +;;; about their result values. To make sure that this is the case, +;;; whenever the CPS conversion would reify one of these terms it needs +;;; to ensure that the continuation actually accepts the return arity of +;;; the primcall. +;;; +;;; Some Tree-IL primcalls residualize CPS primcalls that return zero +;;; values, for example box-set!. In this case the Tree-IL semantics +;;; are that the result of the expression is the undefined value. That +;;; is to say, the result of this expression is #t: +;;; +;;; (let ((x 30)) (eq? (set! x 10) (if #f #f))) +;;; +;;; So in the case that the continuation expects a value but the +;;; primcall produces zero values, we insert the "unspecified" value. +;;; +(define (adapt-arity cps k src nvals) + (match nvals + (0 + ;; As mentioned above, in the Tree-IL semantics the primcall + ;; produces the unspecified value, but in CPS it produces no + ;; values. Therefore we plug the unspecified value into the + ;; continuation. + (match (intmap-ref cps k) + (($ $ktail) + (with-cps cps + (let$ body (with-cps-constants ((unspecified *unspecified*)) + (build-term + ($continue k src ($values (unspecified)))))) + (letk kvoid ($kargs () () ,body)) + kvoid)) + (($ $kargs ()) (with-cps cps k)) + (($ $kreceive arity kargs) + (match arity + (($ $arity () () (not #f) () #f) + (with-cps cps + (letk kvoid ($kargs () () ($continue kargs src ($const '())))) + kvoid)) + (($ $arity (_) () #f () #f) + (with-cps cps + (letk kvoid ($kargs () () + ($continue kargs src ($const *unspecified*)))) + kvoid)) + (($ $arity (_) () _ () #f) + (with-cps cps + (let$ void (with-cps-constants ((unspecified *unspecified*) + (rest '())) + (build-term + ($continue kargs src + ($values (unspecified rest)))))) + (letk kvoid ($kargs () () ,void)) + kvoid)) + (_ + ;; Arity mismatch. Serialize a values call. + (with-cps cps + (letv values) + (let$ void (with-cps-constants ((unspecified *unspecified*)) + (build-term + ($continue k src + ($call values (unspecified)))))) + (letk kvoid ($kargs ('values) (values) ,void)) + (letk kvalues ($kargs () () + ($continue kvoid src ($prim 'values)))) + kvalues)))))) + (1 + (match (intmap-ref cps k) + (($ $ktail) + (with-cps cps + (letv val) + (letk kval ($kargs ('val) (val) + ($continue k src ($values (val))))) + kval)) + (($ $kargs (_)) (with-cps cps k)) + (($ $kreceive arity kargs) + (match arity + (($ $arity () () (not #f) () #f) + (with-cps cps + (letv val) + (let$ body (with-cps-constants ((nil '())) + ($ (convert-primcall kargs src 'cons #f + val nil)))) + (letk kval ($kargs ('val) (val) ,body)) + kval)) + (($ $arity (_) () #f () #f) + (with-cps cps + kargs)) + (($ $arity (_) () _ () #f) + (with-cps cps + (letv val) + (let$ body (with-cps-constants ((rest '())) + (build-term + ($continue kargs src ($values (val rest)))))) + (letk kval ($kargs ('val) (val) ,body)) + kval)) + (_ + ;; Arity mismatch. Serialize a values call. + (with-cps cps + (letv val values) + (letk kvalues ($kargs ('values) (values) + ($continue k src + ($call values (val))))) + (letk kval ($kargs ('val) (val) + ($continue kvalues src ($prim 'values)))) + kval)))))))) + +;; cps exp k-name alist -> cps term +(define (convert cps exp k subst) + (define (zero-valued? exp) + (match exp + ((or ($ <module-set>) ($ <toplevel-set>) ($ <toplevel-define>) + ($ <lexical-set>)) + #t) + (($ <let> src names syms vals body) (zero-valued? body)) + ;; Can't use <fix> here as the hack that <fix> uses to convert its + ;; functions relies on continuation being single-valued. + ;; (($ <fix> src names syms vals body) (zero-valued? body)) + (($ <let-values> src exp body) (zero-valued? body)) + (($ <seq> src head tail) (zero-valued? tail)) + (($ <primcall> src 'values args) (= (length args) 0)) + (($ <primcall> src name args) + (match (tree-il-primitive->cps-primitive+nargs+nvalues name) + (#f #f) + (#(cps-prim nargs nvalues) + (and (eqv? nvalues 0) + (eqv? nargs (length args)))))) + (_ #f))) + (define (single-valued? exp) + (match exp + ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>) + ($ <toplevel-ref>) ($ <lambda>)) + #t) + (($ <let> src names syms vals body) (single-valued? body)) + (($ <fix> src names syms vals body) (single-valued? body)) + (($ <let-values> src exp body) (single-valued? body)) + (($ <seq> src head tail) (single-valued? tail)) + (($ <primcall> src 'values args) (= (length args) 1)) + (($ <primcall> src name args) + (match (tree-il-primitive->cps-primitive+nargs+nvalues name) + (#f #f) + (#(cps-prim nargs nvalues) + (and (eqv? nvalues 1) + (eqv? nargs (length args)))))) + (_ #f))) + ;; exp (v-name -> term) -> term + (define (convert-arg cps exp k) + (match exp + (($ <lexical-ref> src name sym) + (match (hashq-ref subst sym) + ((orig-var box #t) + (with-cps cps + (letv unboxed) + (let$ body (k unboxed)) + (letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) + (build-term ($continue kunboxed src + ($primcall 'scm-ref/immediate '(box . 1) (box)))))) + ((orig-var subst-var #f) (k cps subst-var)) + (var (k cps var)))) + ((? single-valued?) + (with-cps cps + (letv arg) + (let$ body (k arg)) + (letk karg ($kargs ('arg) (arg) ,body)) + ($ (convert exp karg subst)))) + (_ + (with-cps cps + (letv arg rest) + (let$ body (k arg)) + (letk karg ($kargs ('arg 'rest) (arg rest) ,body)) + (letk kreceive ($kreceive '(arg) 'rest karg)) + ($ (convert exp kreceive subst)))))) + ;; (exp ...) ((v-name ...) -> term) -> term + (define (convert-args cps exps k) + (match exps + (() (k cps '())) + ((exp . exps) + (convert-arg cps exp + (lambda (cps name) + (convert-args cps exps + (lambda (cps names) + (k cps (cons name names))))))))) + (define (box-bound-var cps name sym body) + (match (hashq-ref subst sym) + ((orig-var subst-var #t) + (with-cps cps + (letk k ($kargs (name) (subst-var) ,body)) + ($ (convert-primcall k #f 'box #f orig-var)))) + (else + (with-cps cps body)))) + (define (box-bound-vars cps names syms body) + (match (vector names syms) + (#((name . names) (sym . syms)) + (with-cps cps + (let$ body (box-bound-var name sym body)) + ($ (box-bound-vars names syms body)))) + (#(() ()) (with-cps cps body)))) + (define (bound-var sym) + (match (hashq-ref subst sym) + ((var . _) var) + ((? exact-integer? var) var))) + + (match exp + (($ <lexical-ref> src name sym) + (with-cps cps + (let$ k (adapt-arity k src 1)) + (rewrite-term (hashq-ref subst sym) + ((orig-var box #t) ($continue k src + ($primcall 'scm-ref/immediate '(box . 1) (box)))) + ((orig-var subst-var #f) ($continue k src ($values (subst-var)))) + (var ($continue k src ($values (var))))))) + + (($ <void> src) + (with-cps cps + (let$ k (adapt-arity k src 1)) + (build-term ($continue k src ($const *unspecified*))))) + + (($ <const> src exp) + (with-cps cps + (let$ k (adapt-arity k src 1)) + (build-term ($continue k src ($const exp))))) + + (($ <primitive-ref> src name) + (with-cps cps + (let$ k (adapt-arity k src 1)) + (build-term ($continue k src ($prim name))))) + + (($ <lambda> fun-src meta body) + (let () + (define (convert-clauses cps body ktail) + (match body + (#f (values cps #f)) + (($ <lambda-case> src req opt rest kw inits gensyms body alternate) + (let* ((arity (make-$arity req (or opt '()) rest + (map (match-lambda + ((kw name sym) + (list kw name (bound-var sym)))) + (if kw (cdr kw) '())) + (and kw (car kw)))) + (names (fold-formals (lambda (name sym init names) + (cons name names)) + '() + arity gensyms inits))) + (define (fold-formals* cps f seed arity gensyms inits) + (match (fold-formals + (lambda (name sym init cps+seed) + (match cps+seed + ((cps . seed) + (call-with-values (lambda () + (f cps name sym init seed)) + (lambda (cps seed) (cons cps seed)))))) + (cons cps seed) arity gensyms inits) + ((cps . seed) (values cps seed)))) + (with-cps cps + (let$ kalt (convert-clauses alternate ktail)) + (let$ body (convert body ktail subst)) + (let$ body + (fold-formals* + (lambda (cps name sym init body) + (if init + (init-default-value cps name sym subst init body) + (box-bound-var cps name sym body))) + body arity gensyms inits)) + (letk kargs ($kargs names (map bound-var gensyms) ,body)) + (letk kclause ($kclause ,arity kargs kalt)) + kclause))))) + (if (current-topbox-scope) + (with-cps cps + (letv self) + (letk ktail ($ktail)) + (let$ kclause (convert-clauses body ktail)) + (letk kfun ($kfun fun-src meta self ktail kclause)) + (let$ k (adapt-arity k fun-src 1)) + (build-term ($continue k fun-src ($fun kfun)))) + (let ((scope-id (fresh-scope-id))) + (with-cps cps + (let$ body ((lambda (cps) + (parameterize ((current-topbox-scope scope-id)) + (convert cps exp k subst))))) + (letk kscope ($kargs () () ,body)) + ($ (capture-toplevel-scope fun-src scope-id kscope))))))) + + (($ <module-ref> src mod name public?) + (module-box + cps src mod name public? #t + (lambda (cps box) + (with-cps cps + (let$ k (adapt-arity k src 1)) + (build-term ($continue k src + ($primcall 'scm-ref/immediate '(box . 1) (box)))))))) + + (($ <module-set> src mod name public? exp) + (convert-arg cps exp + (lambda (cps val) + (module-box + cps src mod name public? #t + (lambda (cps box) + (with-cps cps + (let$ k (adapt-arity k src 0)) + (build-term + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))) + + (($ <toplevel-ref> src name) + (toplevel-box + cps src name #t + (lambda (cps box) + (with-cps cps + (let$ k (adapt-arity k src 1)) + (build-term + ($continue k src + ($primcall 'scm-ref/immediate '(box . 1) (box)))))))) + + (($ <toplevel-set> src name exp) + (convert-arg cps exp + (lambda (cps val) + (toplevel-box + cps src name #f + (lambda (cps box) + (with-cps cps + (let$ k (adapt-arity k src 0)) + (build-term + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box val)))))))))) + + (($ <toplevel-define> src name exp) + (convert-arg cps exp + (lambda (cps val) + (with-cps cps + (let$ k (adapt-arity k src 0)) + (letv box mod) + (letk kset ($kargs ('box) (box) + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box val))))) + ($ (with-cps-constants ((name name)) + (letk kmod + ($kargs ('mod) (mod) + ($continue kset src + ($primcall 'define! #f (mod name))))) + (build-term + ($continue kmod src ($primcall 'current-module #f ()))))))))) + + (($ <call> src proc args) + (convert-args cps (cons proc args) + (match-lambda* + ((cps (proc . args)) + (with-cps cps + (build-term ($continue k src ($call proc args)))))))) + + (($ <primcall> src name args) + (cond + ((eq? name 'throw) + (let () + (define (fallback) + (convert-args cps args + (lambda (cps args) + (match args + ((key . args) + (with-cps cps + (letv arglist) + (letk kargs ($kargs ('arglist) (arglist) + ($throw src 'throw #f (key arglist)))) + ($ (build-list kargs src args)))))))) + (define (specialize op param . args) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($throw src op param args)))))) + (match args + ((($ <const> _ key) ($ <const> _ subr) ($ <const> _ msg) args data) + ;; Specialize `throw' invocations corresponding to common + ;; "error" invocations. + (let () + (match (vector args data) + (#(($ <primcall> _ 'cons (x ($ <const> _ ()))) + ($ <primcall> _ 'cons (x ($ <const> _ ())))) + (specialize 'throw/value+data `#(,key ,subr ,msg) x)) + (#(($ <primcall> _ 'cons (x ($ <const> _ ()))) ($ <const> _ #f)) + (specialize 'throw/value `#(,key ,subr ,msg) x)) + (_ (fallback))))) + (_ (fallback))))) + ((eq? name 'values) + (convert-args cps args + (lambda (cps args) + (match (intmap-ref cps k) + (($ $ktail) + (with-cps cps + (build-term + ($continue k src ($values args))))) + (($ $kargs names) + ;; Can happen if continuation already saw we produced the + ;; right number of values. + (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))) + (with-cps cps + (letv rest) + (letk krest ($kargs ('rest) (rest) + ($continue kargs src + ($values ,(append (list-head args (length req)) + (list rest)))))) + ($ (build-list krest src (list-tail args (length req)))))) + (else + ;; Number of values mismatch; reify a values call. + (with-cps cps + (letv val values) + (letk kvalues ($kargs ('values) (values) + ($continue k src ($call values args)))) + (build-term ($continue kvalues src ($prim 'values))))))))))) + ((tree-il-primitive->cps-primitive+nargs+nvalues name) + => + (match-lambda + (#(cps-prim nargs nvalues) + (define (cvt cps k src op args) + (define (default) + (convert-args cps args + (lambda (cps args) + (with-cps cps + ($ (convert-primcall* k src op #f args)))))) + (define-syntax-rule (specialize-case (pat (op c (arg ...))) ... + (_ def)) + (match (cons cps-prim args) + (pat + (convert-args cps (list arg ...) + (lambda (cps args) + (with-cps cps + ($ (convert-primcall* k src 'op c args)))))) + ... + (_ def))) + (define (uint? val) (and (exact-integer? val) (<= 0 val))) + (define (vector-index? val) + (and (exact-integer? val) + (<= 0 val (1- (target-max-vector-length))))) + (define (vector-size? val) + (and (exact-integer? val) + (<= 0 val (target-max-vector-length)))) + (define (negint? val) (and (exact-integer? val) (< val 0))) + ;; FIXME: Add case for mul + (specialize-case + (('allocate-vector ($ <const> _ n)) + (allocate-vector n ())) + (('make-vector ($ <const> _ (? vector-size? n)) init) + (make-vector/immediate n (init))) + (('vector-ref v ($ <const> _ (? vector-index? n))) + (vector-ref/immediate n (v))) + (('vector-set! v ($ <const> _ (? vector-index? n)) x) + (vector-set!/immediate n (v x))) + (('vector-init! v ($ <const> _ n) x) + (vector-init! n (v x))) + (('allocate-struct v ($ <const> _ n)) + (allocate-struct n (v))) + (('struct-ref s ($ <const> _ (? uint? n))) + (struct-ref/immediate n (s))) + (('struct-set! s ($ <const> _ (? uint? n)) x) + (struct-set!/immediate n (s x))) + (('struct-init! s ($ <const> _ n) x) + (struct-init! n (s x))) + (('add x ($ <const> _ (? number? y))) + (add/immediate y (x))) + (('add ($ <const> _ (? number? y)) x) + (add/immediate y (x))) + (('sub x ($ <const> _ (? number? y))) + (sub/immediate y (x))) + (('lsh x ($ <const> _ (? uint? y))) + (lsh/immediate y (x))) + (('rsh x ($ <const> _ (? uint? y))) + (rsh/immediate y (x))) + (_ + (default)))) + ;; Tree-IL primcalls are sloppy, in that it could be that + ;; they are called with too many or too few arguments. In + ;; CPS we are more strict and only residualize a $primcall + ;; if the argument count matches. + (if (= nargs (length args)) + (with-cps cps + (let$ k (adapt-arity k src nvalues)) + ($ (cvt k src cps-prim args))) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (letv prim) + (letk kprim ($kargs ('prim) (prim) + ($continue k src ($call prim args)))) + (build-term ($continue kprim src ($prim name)))))))))) + (else + ;; We have something that's a primcall for Tree-IL but not for + ;; CPS; compile as a call. + (convert-args cps args + (lambda (cps args) + (with-cps cps + (letv prim) + (letk kprim ($kargs ('prim) (prim) + ($continue k src ($call prim args)))) + (build-term ($continue kprim src ($prim name))))))))) + + ;; Prompts with inline handlers. + (($ <prompt> src escape-only? tag body + ($ <lambda> hsrc hmeta + ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) + ;; Handler: + ;; khargs: check args returned to handler, -> khbody + ;; khbody: the handler, -> k + ;; + ;; Post-body: + ;; krest: collect return vals from body to list, -> kpop + ;; kpop: pop the prompt, -> kprim + ;; kprim: load the values primitive, -> kret + ;; kret: (apply values rvals), -> k + ;; + ;; Escape prompts evaluate the body with the continuation of krest. + ;; Otherwise we do a no-inline call to body, continuing to krest. + (convert-arg cps tag + (lambda (cps tag) + (let ((hnames (append hreq (if hrest (list hrest) '()))) + (bound-vars (map bound-var hsyms))) + (define (convert-body cps khargs krest) + (if escape-only? + (with-cps cps + (let$ body (convert body krest subst)) + (letk kbody ($kargs () () ,body)) + (build-term ($prompt kbody khargs src #t tag))) + (convert-arg cps body + (lambda (cps thunk) + (with-cps cps + (letk kbody ($kargs () () + ($continue krest (tree-il-src body) + ($primcall 'call-thunk/no-inline #f + (thunk))))) + (build-term ($prompt kbody khargs (tree-il-src body) + #f tag))))))) + (with-cps cps + (letv prim vals apply) + (let$ hbody (convert hbody k subst)) + (let$ hbody (box-bound-vars hnames hsyms hbody)) + (letk khbody ($kargs hnames bound-vars ,hbody)) + (letk khargs ($kreceive hreq hrest khbody)) + (letk kapp ($kargs ('apply) (apply) + ($continue k src ($call apply (prim vals))))) + (letk kprim ($kargs ('prim) (prim) + ($continue kapp src ($prim 'apply)))) + (letk kret ($kargs () () + ($continue kprim src ($prim 'values)))) + (letk kpop ($kargs ('rest) (vals) + ($continue kret src ($primcall 'unwind #f ())))) + ;; FIXME: Attach hsrc to $kreceive. + (letk krest ($kreceive '() 'rest kpop)) + ($ (convert-body khargs krest))))))) + + (($ <abort> src tag args ($ <const> _ ())) + (convert-args cps (cons tag args) + (lambda (cps args*) + (with-cps cps + (letv abort) + (letk kabort ($kargs ('abort) (abort) + ($continue k src ($call abort args*)))) + (build-term + ($continue kabort src ($prim 'abort-to-prompt))))))) + + (($ <abort> src tag args tail) + (convert-args cps + (append (list (make-primitive-ref #f 'apply) + (make-primitive-ref #f 'abort-to-prompt) + tag) + args + (list tail)) + (lambda (cps args*) + (match args* + ((apply . apply-args) + (with-cps cps + (build-term ($continue k src ($call apply apply-args))))))))) + + (($ <conditional> src test consequent alternate) + (define (convert-test cps test kt kf) + (match test + (($ <primcall> src (? branching-primitive? name) args) + (convert-args cps args + (lambda (cps args) + (if (heap-type-predicate? name) + (with-cps cps + (letk kt* ($kargs () () + ($branch kf kt src name #f args))) + (build-term + ($branch kf kt* src 'heap-object? #f args))) + (with-cps cps + (build-term ($branch kf kt src name #f args))))))) + (($ <conditional> src test consequent alternate) + (with-cps cps + (let$ t (convert-test consequent kt kf)) + (let$ f (convert-test alternate kt kf)) + (letk kt* ($kargs () () ,t)) + (letk kf* ($kargs () () ,f)) + ($ (convert-test test kt* kf*)))) + (($ <const> src c) + (with-cps cps + (build-term ($continue (if c kt kf) src ($values ()))))) + (_ (convert-arg cps test + (lambda (cps test) + (with-cps cps + (build-term ($branch kt kf src 'false? #f (test))))))))) + (with-cps cps + (let$ t (convert consequent k subst)) + (let$ f (convert alternate k subst)) + (letk kt ($kargs () () ,t)) + (letk kf ($kargs () () ,f)) + ($ (convert-test test kt kf)))) + + (($ <lexical-set> src name gensym exp) + (convert-arg cps exp + (lambda (cps exp) + (match (hashq-ref subst gensym) + ((orig-var box #t) + (with-cps cps + (let$ k (adapt-arity k src 0)) + (build-term + ($continue k src + ($primcall 'scm-set!/immediate '(box . 1) (box exp)))))))))) + + (($ <seq> src head tail) + (if (zero-valued? head) + (with-cps cps + (let$ tail (convert tail k subst)) + (letk kseq ($kargs () () ,tail)) + ($ (convert head kseq subst))) + (with-cps cps + (let$ tail (convert tail k subst)) + (letv vals) + (letk kseq ($kargs ('vals) (vals) ,tail)) + (letk kreceive ($kreceive '() 'vals kseq)) + ($ (convert head kreceive subst))))) + + (($ <let> src names syms vals body) + (let lp ((cps cps) (names names) (syms syms) (vals vals)) + (match (list names syms vals) + ((() () ()) (convert cps body k subst)) + (((name . names) (sym . syms) (val . vals)) + (with-cps cps + (let$ body (lp names syms vals)) + (let$ body (box-bound-var name sym body)) + ($ ((lambda (cps) + (if (single-valued? val) + (with-cps cps + (letk klet ($kargs (name) ((bound-var sym)) ,body)) + ($ (convert val klet subst))) + (with-cps cps + (letv rest) + (letk klet ($kargs (name 'rest) ((bound-var sym) rest) ,body)) + (letk kreceive ($kreceive (list name) 'rest klet)) + ($ (convert val kreceive subst)))))))))))) + + (($ <fix> src names gensyms funs body) + ;; Some letrecs can be contified; that happens later. + (define (convert-funs cps funs) + (match funs + (() + (with-cps cps '())) + ((fun . funs) + (with-cps cps + (let$ fun (convert fun k subst)) + (let$ funs (convert-funs funs)) + (cons (match fun + (($ $continue _ _ (and fun ($ $fun))) + fun)) + funs))))) + (if (current-topbox-scope) + (let ((vars (map bound-var gensyms))) + (with-cps cps + (let$ body (convert body k subst)) + (letk krec ($kargs names vars ,body)) + (let$ funs (convert-funs funs)) + (build-term ($continue krec src ($rec names vars funs))))) + (let ((scope-id (fresh-scope-id))) + (with-cps cps + (let$ body ((lambda (cps) + (parameterize ((current-topbox-scope scope-id)) + (convert cps exp k subst))))) + (letk kscope ($kargs () () ,body)) + ($ (capture-toplevel-scope src scope-id kscope)))))) + + (($ <let-values> src exp + ($ <lambda-case> lsrc req #f rest #f () syms body #f)) + (let ((names (append req (if rest (list rest) '()))) + (bound-vars (map bound-var syms))) + (with-cps cps + (let$ body (convert body k subst)) + (let$ body (box-bound-vars names syms body)) + (letk kargs ($kargs names bound-vars ,body)) + (letk kreceive ($kreceive req rest kargs)) + ($ (convert exp kreceive subst))))))) + +(define (build-subst exp) + "Compute a mapping from lexical gensyms to CPS variable indexes. CPS +uses small integers to identify variables, instead of gensyms. + +This subst table serves an additional purpose of mapping variables to +replacements. The usual reason to replace one variable by another is +assignment conversion. Default argument values is the other reason. + +The result is a hash table mapping symbols to substitutions (in the case +that a variable is substituted) or to indexes. A substitution is a list +of the form: + + (ORIG-INDEX SUBST-INDEX BOXED?) + +A true value for BOXED? indicates that the replacement variable is in a +box. If a variable is not substituted, the mapped value is a small +integer." + (let ((table (make-hash-table))) + (define (down exp) + (match exp + (($ <lexical-set> src name sym exp) + (match (hashq-ref table sym) + ((orig subst #t) #t) + ((orig subst #f) (hashq-set! table sym (list orig subst #t))) + ((? number? idx) (hashq-set! table sym (list idx (fresh-var) #t))))) + (($ <lambda-case> src req opt rest kw inits gensyms body alternate) + (fold-formals (lambda (name sym init seed) + (hashq-set! table sym + (if init + (list (fresh-var) (fresh-var) #f) + (fresh-var)))) + #f + (make-$arity req (or opt '()) rest + (if kw (cdr kw) '()) (and kw (car kw))) + gensyms + inits)) + (($ <let> src names gensyms vals body) + (for-each (lambda (sym) + (hashq-set! table sym (fresh-var))) + gensyms)) + (($ <fix> src names gensyms vals body) + (for-each (lambda (sym) + (hashq-set! table sym (fresh-var))) + gensyms)) + (_ #t)) + (values)) + (define (up exp) (values)) + ((make-tree-il-folder) exp down up) + table)) + +(define (cps-convert/thunk exp) + (parameterize ((label-counter 0) + (var-counter 0) + (scope-counter 0)) + (with-cps empty-intmap + (letv init) + ;; Allocate kinit first so that we know that the entry point's + ;; label is zero. This simplifies data flow in the compiler if we + ;; can just pass around the program as a map of continuations and + ;; know that the entry point is label 0. + (letk kinit ,#f) + (letk ktail ($ktail)) + (let$ body (convert exp ktail (build-subst exp))) + (letk kbody ($kargs () () ,body)) + (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) + ($ ((lambda (cps) + (let ((init (build-cont + ($kfun (tree-il-src exp) '() init ktail kclause)))) + (with-cps (persistent-intmap (intmap-replace! cps kinit init)) + kinit)))))))) + +(define *comp-module* (make-fluid)) + +(define %warning-passes + `((unused-variable . ,unused-variable-analysis) + (unused-toplevel . ,unused-toplevel-analysis) + (shadowed-toplevel . ,shadowed-toplevel-analysis) + (unbound-variable . ,unbound-variable-analysis) + (macro-use-before-definition . ,macro-use-before-definition-analysis) + (arity-mismatch . ,arity-analysis) + (format . ,format-analysis))) + +(define (optimize-tree-il x e opts) + (define warnings + (or (and=> (memq #:warnings opts) cadr) + '())) + + ;; Go through the warning passes. + (let ((analyses (filter-map (lambda (kind) + (assoc-ref %warning-passes kind)) + warnings))) + (analyze-tree analyses x e)) + + (optimize x e opts)) + +(define (canonicalize exp) + (define-syntax-rule (with-lexical src id . body) + (let ((k (lambda (id) . body))) + (match id + (($ <lexical-ref>) (k id)) + (_ + (let ((v (gensym "v "))) + (make-let src (list 'v) (list v) (list id) + (k (make-lexical-ref src 'v v)))))))) + (define-syntax with-lexicals + (syntax-rules () + ((with-lexicals src () . body) (let () . body)) + ((with-lexicals src (id . ids) . body) + (with-lexical src id (with-lexicals src ids . body))))) + (define (reduce-conditional exp) + (match exp + (($ <conditional> src + ($ <conditional> _ test ($ <const> _ t) ($ <const> _ f)) + consequent alternate) + (cond + ((and t (not f)) + (reduce-conditional (make-conditional src test consequent alternate))) + ((and (not t) f) + (reduce-conditional (make-conditional src test alternate consequent))) + (else + exp))) + (_ exp))) + (define (evaluate-args-eagerly-if-needed src inits k) + ;; Some macros generate calls to "vector" or "list" with like 300 + ;; arguments. Since we eventually compile to lower-level operations + ;; like make-vector and vector-set! or cons, it reduces live + ;; variable pressure to sink initializers if we can, if we can prove + ;; that the initializer can't capture the continuation. (More on + ;; that caveat here: + ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time). + ;; + ;; Normally we would do this transformation in the optimizer, but + ;; it's quite tricky there and quite easy here, so we do it here. + (match inits + (() (k '())) + ((init . inits) + (match init + ((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>)) + (evaluate-args-eagerly-if-needed + src inits (lambda (inits) (k (cons init inits))))) + (_ + (with-lexical + src init + (evaluate-args-eagerly-if-needed + src inits (lambda (inits) (k (cons init inits)))))))))) + (post-order + (lambda (exp) + (match exp + (($ <conditional>) + (reduce-conditional exp)) + + (($ <primcall> src 'exact-integer? (x)) + ;; Both fixnum? and bignum? are branching primitives. + (with-lexicals src (x) + (make-conditional + src (make-primcall src 'fixnum? (list x)) + (make-const src #t) + (make-conditional src (make-primcall src 'bignum? (list x)) + (make-const src #t) + (make-const src #f))))) + + (($ <primcall> src '<= (a b)) + ;; No need to reduce as <= is a branching primitive. + (make-conditional src (make-primcall src '<= (list a b)) + (make-const src #t) + (make-const src #f))) + + (($ <primcall> src '>= (a b)) + ;; No need to reduce as < is a branching primitive. + (make-conditional src (make-primcall src '<= (list b a)) + (make-const src #t) + (make-const src #f))) + + (($ <primcall> src '> (a b)) + ;; No need to reduce as < is a branching primitive. + (make-conditional src (make-primcall src '< (list b a)) + (make-const src #t) + (make-const src #f))) + + (($ <primcall> src (? branching-primitive? name) args) + ;; No need to reduce because test is not reducible: reifying + ;; #t/#f is the right thing. + (make-conditional src exp + (make-const src #t) + (make-const src #f))) + + (($ <primcall> src 'not (x)) + (reduce-conditional + (make-conditional src x + (make-const src #f) + (make-const src #t)))) + + (($ <primcall> src (or 'eqv? 'equal?) (a b)) + (let () + (define-syntax-rule (primcall name . args) + (make-primcall src 'name (list . args))) + (define-syntax primcall-chain + (syntax-rules () + ((_ x) x) + ((_ x . y) + (make-conditional src (primcall . x) (primcall-chain . y) + (make-const src #f))))) + (define-syntax-rule (bool x) + (make-conditional src x (make-const src #t) (make-const src #f))) + (with-lexicals src (a b) + (make-conditional + src + (primcall eq? a b) + (make-const src #t) + (match (primcall-name exp) + ('eqv? + ;; Completely inline. + (primcall-chain (heap-number? a) + (heap-number? b) + (bool (primcall heap-numbers-equal? a b)))) + ('equal? + ;; Partially inline. + (primcall-chain (heap-object? a) + (heap-object? b) + (primcall equal? a b)))))))) + + (($ <primcall> src 'vector args) + ;; Expand to "allocate-vector" + "vector-init!". + (evaluate-args-eagerly-if-needed + src args + (lambda (args) + (define-syntax-rule (primcall name . args) + (make-primcall src 'name (list . args))) + (define-syntax-rule (const val) + (make-const src val)) + (let ((v (primcall allocate-vector (const (length args))))) + (with-lexicals src (v) + (list->seq + src + (append (map (lambda (idx arg) + (primcall vector-init! v (const idx) arg)) + (iota (length args)) + args) + (list v)))))))) + + (($ <primcall> src 'make-struct/simple (vtable . args)) + ;; Expand to "allocate-struct" + "struct-init!". + (evaluate-args-eagerly-if-needed + src args + (lambda (args) + (define-syntax-rule (primcall name . args) + (make-primcall src 'name (list . args))) + (define-syntax-rule (const val) + (make-const src val)) + (let ((s (primcall allocate-struct vtable (const (length args))))) + (with-lexicals src (s) + (list->seq + src + (append (map (lambda (idx arg) + (primcall struct-init! s (const idx) arg)) + (iota (length args)) + args) + (list s)))))))) + + (($ <primcall> src 'list args) + ;; Expand to "cons". + (evaluate-args-eagerly-if-needed + src args + (lambda (args) + (define-syntax-rule (primcall name . args) + (make-primcall src 'name (list . args))) + (define-syntax-rule (const val) + (make-const src val)) + (fold (lambda (arg tail) (primcall cons arg tail)) + (const '()) + (reverse args))))) + + ;; Lower (logand x (lognot y)) to (logsub x y). We do it here + ;; instead of in CPS because it gets rid of the lognot entirely; + ;; if type folding can't prove Y to be an exact integer, then DCE + ;; would have to leave it in the program for its possible + ;; effects. + (($ <primcall> src 'logand (x ($ <primcall> _ 'lognot (y)))) + (make-primcall src 'logsub (list x y))) + (($ <primcall> src 'logand (($ <primcall> _ 'lognot (y)) x)) + (make-primcall src 'logsub (list x y))) + + (($ <primcall> src 'throw ()) + (make-call src (make-primitive-ref src 'throw) '())) + + (($ <prompt> src escape-only? tag body + ($ <lambda> hsrc hmeta + ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) + exp) + + (($ <primcall> src 'ash (a b)) + (match b + (($ <const> src2 (? exact-integer? n)) + (if (< n 0) + (make-primcall src 'rsh (list a (make-const src2 (- n)))) + (make-primcall src 'lsh (list a b)))) + (_ + (with-lexicals src (a b) + (make-conditional + src + (make-primcall src '< (list b (make-const src 0))) + (let ((n (make-primcall src '- (list (make-const src 0) b)))) + (make-primcall src 'rsh (list a n))) + (make-primcall src 'lsh (list a b))))))) + + ;; Eta-convert prompts without inline handlers. + (($ <prompt> src escape-only? tag body handler) + (let ((h (gensym "h ")) + (args (gensym "args "))) + (define-syntax-rule (primcall name . args) + (make-primcall src 'name (list . args))) + (define-syntax-rule (const val) + (make-const src val)) + (with-lexicals src (handler) + (make-conditional + src + (primcall procedure? handler) + (make-prompt + src escape-only? tag body + (make-lambda + src '() + (make-lambda-case + src '() #f 'args #f '() (list args) + (primcall apply handler (make-lexical-ref #f 'args args)) + #f))) + (primcall throw + (const 'wrong-type-arg) + (const "call-with-prompt") + (const "Wrong type (expecting procedure): ~S") + (primcall cons handler (const '())) + (primcall cons handler (const '()))))))) + (_ exp))) + exp)) + +(define (compile-cps exp env opts) + (values (cps-convert/thunk + (canonicalize (optimize-tree-il exp env opts))) + env + env)) + +;;; Local Variables: +;;; eval: (put 'convert-arg 'scheme-indent-function 2) +;;; eval: (put 'convert-args 'scheme-indent-function 2) +;;; eval: (put 'with-lexicals 'scheme-indent-function 2) +;;; End: diff --git a/module/language/tree-il/cps-primitives.scm b/module/language/tree-il/cps-primitives.scm new file mode 100644 index 000000000..b9f2fe95b --- /dev/null +++ b/module/language/tree-il/cps-primitives.scm @@ -0,0 +1,176 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013- 2015, 2017-2018 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: +;;; +;;; Information about named primitives, as they appear in $prim and +;;; $primcall. +;;; +;;; Code: + +(define-module (language tree-il cps-primitives) + #:use-module (ice-9 match) + #:use-module (language bytecode) + #:use-module (system base types internal) + #:export (tree-il-primitive->cps-primitive+nargs+nvalues + branching-primitive? + heap-type-predicate?)) + +(define *primitives* (make-hash-table)) + +(define-syntax define-cps-primitive + (syntax-rules () + ((_ (tree-il-primitive cps-primitive) nargs nvalues) + (hashq-set! *primitives* 'tree-il-primitive + '#(cps-primitive nargs nvalues))) + ((_ primitive nargs nvalues) + (define-cps-primitive (primitive primitive) nargs nvalues)))) + +;; tree-il-prim -> #(cps-prim nargs nvalues) | #f +(define (tree-il-primitive->cps-primitive+nargs+nvalues name) + (hashq-ref *primitives* name)) + +(define-cps-primitive box 1 1) +(define-cps-primitive (variable-ref box-ref) 1 1) +(define-cps-primitive (variable-set! box-set!) 2 0) + +(define-cps-primitive current-module 0 1) +(define-cps-primitive define! 1 1) + +(define-cps-primitive wind 2 0) +(define-cps-primitive unwind 0 0) +(define-cps-primitive push-dynamic-state 1 0) +(define-cps-primitive pop-dynamic-state 0 0) + +(define-cps-primitive push-fluid 2 0) +(define-cps-primitive pop-fluid 0 0) +(define-cps-primitive fluid-ref 1 1) +(define-cps-primitive fluid-set! 2 0) + +(define-cps-primitive string-length 1 1) +(define-cps-primitive string-ref 2 1) +(define-cps-primitive string-set! 3 0) +(define-cps-primitive string->number 1 1) +(define-cps-primitive string->symbol 1 1) +(define-cps-primitive symbol->keyword 1 1) + +(define-cps-primitive integer->char 1 1) +(define-cps-primitive char->integer 1 1) + +(define-cps-primitive cons 2 1) +(define-cps-primitive car 1 1) +(define-cps-primitive cdr 1 1) +(define-cps-primitive set-car! 2 0) +(define-cps-primitive set-cdr! 2 0) + +(define-cps-primitive (+ add) 2 1) +(define-cps-primitive (- sub) 2 1) +(define-cps-primitive (* mul) 2 1) +(define-cps-primitive (/ div) 2 1) +(define-cps-primitive (quotient quo) 2 1) +(define-cps-primitive (remainder rem) 2 1) +(define-cps-primitive (modulo mod) 2 1) + +(define-cps-primitive lsh 2 1) +(define-cps-primitive rsh 2 1) +(define-cps-primitive logand 2 1) +(define-cps-primitive logior 2 1) +(define-cps-primitive logxor 2 1) +(define-cps-primitive logsub 2 1) +(define-cps-primitive logbit? 2 1) + +(define-cps-primitive allocate-vector 1 1) +(define-cps-primitive make-vector 2 1) +(define-cps-primitive vector-length 1 1) +(define-cps-primitive vector-ref 2 1) +(define-cps-primitive vector-set! 3 0) +(define-cps-primitive vector-init! 3 0) + +(define-cps-primitive struct-vtable 1 1) +(define-cps-primitive allocate-struct 2 1) +(define-cps-primitive struct-ref 2 1) +;; Unhappily, and undocumentedly, struct-set! returns the value that was +;; set. There is code that relies on this. The struct-set! lowering +;; routines ensure this return arity. +(define-cps-primitive struct-set! 3 1) +(define-cps-primitive struct-init! 3 0) + +(define-cps-primitive class-of 1 1) + +(define-cps-primitive (bytevector-length bv-length) 1 1) +(define-cps-primitive (bytevector-u8-ref bv-u8-ref) 2 1) +(define-cps-primitive (bytevector-u16-native-ref bv-u16-ref) 2 1) +(define-cps-primitive (bytevector-u32-native-ref bv-u32-ref) 2 1) +(define-cps-primitive (bytevector-u64-native-ref bv-u64-ref) 2 1) +(define-cps-primitive (bytevector-s8-ref bv-s8-ref) 2 1) +(define-cps-primitive (bytevector-s16-native-ref bv-s16-ref) 2 1) +(define-cps-primitive (bytevector-s32-native-ref bv-s32-ref) 2 1) +(define-cps-primitive (bytevector-s64-native-ref bv-s64-ref) 2 1) +(define-cps-primitive (bytevector-ieee-single-native-ref bv-f32-ref) 2 1) +(define-cps-primitive (bytevector-ieee-double-native-ref bv-f64-ref) 2 1) +(define-cps-primitive (bytevector-u8-set! bv-u8-set!) 3 0) +(define-cps-primitive (bytevector-u16-native-set! bv-u16-set!) 3 0) +(define-cps-primitive (bytevector-u32-native-set! bv-u32-set!) 3 0) +(define-cps-primitive (bytevector-u64-native-set! bv-u64-set!) 3 0) +(define-cps-primitive (bytevector-s8-set! bv-s8-set!) 3 0) +(define-cps-primitive (bytevector-s16-native-set! bv-s16-set!) 3 0) +(define-cps-primitive (bytevector-s32-native-set! bv-s32-set!) 3 0) +(define-cps-primitive (bytevector-s64-native-set! bv-s64-set!) 3 0) +(define-cps-primitive (bytevector-ieee-single-native-set! bv-f32-set!) 3 0) +(define-cps-primitive (bytevector-ieee-double-native-set! bv-f64-set!) 3 0) + +(define-cps-primitive current-thread 0 1) + +(define-cps-primitive make-atomic-box 1 1) +(define-cps-primitive atomic-box-ref 1 1) +(define-cps-primitive atomic-box-set! 2 0) +(define-cps-primitive atomic-box-swap! 2 1) +(define-cps-primitive atomic-box-compare-and-swap! 3 1) + +(define *branching-primitive-arities* (make-hash-table)) +(define-syntax-rule (define-branching-primitive name nargs) + (hashq-set! *branching-primitive-arities* 'name '(0 . nargs))) + +(define-syntax-rule (define-immediate-type-predicate name pred mask tag) + (define-branching-primitive pred 1)) +(define *heap-type-predicates* (make-hash-table)) +(define-syntax-rule (define-heap-type-predicate name pred mask tag) + (begin + (hashq-set! *heap-type-predicates* 'pred #t) + (define-branching-primitive pred 1))) + +(visit-immediate-tags define-immediate-type-predicate) +(visit-heap-tags define-heap-type-predicate) + +(define (branching-primitive? name) + "Is @var{name} a primitive that can only appear in $branch CPS terms?" + (hashq-ref *branching-primitive-arities* name)) + +(define (heap-type-predicate? name) + "Is @var{name} a predicate that needs guarding by @code{heap-object?} + before it is lowered to CPS?" + (hashq-ref *heap-type-predicates* name)) + +;; We only need to define those branching primitives that are used as +;; Tree-IL primitives. There are others like u64-= which are emitted by +;; CPS code. +(define-branching-primitive eq? 2) +(define-branching-primitive heap-numbers-equal? 2) +(define-branching-primitive < 2) +(define-branching-primitive <= 2) +(define-branching-primitive = 2) diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm new file mode 100644 index 000000000..613dc2ea6 --- /dev/null +++ b/module/language/tree-il/debug.scm @@ -0,0 +1,246 @@ +;;; Tree-IL verifier + +;; Copyright (C) 2011, 2013 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 + +(define-module (language tree-il debug) + #:use-module (language tree-il) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (verify-tree-il)) + +(define (verify-tree-il exp) + (define seen-gensyms (make-hash-table)) + (define (add sym env) + (if (hashq-ref seen-gensyms sym) + (error "duplicate gensym" sym) + (begin + (hashq-set! seen-gensyms sym #t) + (cons sym env)))) + (define (add-env new env) + (if (null? new) + env + (add-env (cdr new) (add (car new) env)))) + + (let visit ((exp exp) + (env '())) + (match exp + (($ <lambda-case> src req opt rest kw inits gensyms body alt) + (cond + ((not (and (list? req) (and-map symbol? req))) + (error "bad required args (should be list of symbols)" exp)) + ((and opt (not (and (list? opt) (and-map symbol? opt)))) + (error "bad optionals (should be #f or list of symbols)" exp)) + ((and rest (not (symbol? rest))) + (error "bad required args (should be #f or symbol)" exp)) + ((and kw (not (match kw + ((aok . kwlist) + (and (list? kwlist) + (and-map + (lambda (x) + (match x + (((? keyword?) (? symbol?) (? symbol? sym)) + (memq sym gensyms)) + (_ #f))) + kwlist))) + (_ #f)))) + (error "bad keywords (should be #f or (aok (kw name sym) ...))" exp)) + ((not (and (list? gensyms) (and-map symbol? gensyms))) + (error "bad gensyms (should be list of symbols)" exp)) + ((not (and (list? gensyms) (and-map symbol? gensyms))) + (error "bad gensyms (should be list of symbols)" exp)) + ((not (= (length gensyms) + (+ (length req) + (if opt (length opt) 0) + ;; FIXME: technically possible for kw gensyms to + ;; alias other gensyms + (if rest 1 0) + (if kw (1- (length kw)) 0)))) + (error "unexpected gensyms length" exp)) + (else + (let lp ((env (add-env (take gensyms (length req)) env)) + (nopt (if opt (length opt) 0)) + (inits inits) + (tail (drop gensyms (length req)))) + (if (zero? nopt) + (let lp ((env (if rest (add (car tail) env) env)) + (inits inits) + (tail (if rest (cdr tail) tail))) + (if (pair? inits) + (begin + (visit (car inits) env) + (lp (add (car tail) env) (cdr inits) + (cdr tail))) + (visit body env))) + (begin + (visit (car inits) env) + (lp (add (car tail) env) + (1- nopt) + (cdr inits) + (cdr tail))))) + (if alt (visit alt env))))) + (($ <lexical-ref> src name gensym) + (cond + ((not (symbol? name)) + (error "name should be a symbol" name)) + ((not (hashq-ref seen-gensyms gensym)) + (error "unbound lexical" exp)) + ((not (memq gensym env)) + (error "displaced lexical" exp)))) + (($ <lexical-set> src name gensym exp) + (cond + ((not (symbol? name)) + (error "name should be a symbol" name)) + ((not (hashq-ref seen-gensyms gensym)) + (error "unbound lexical" exp)) + ((not (memq gensym env)) + (error "displaced lexical" exp)) + (else + (visit exp env)))) + (($ <lambda> src meta body) + (cond + ((and meta (not (and (list? meta) (and-map pair? meta)))) + (error "meta should be alist" meta)) + ((and body (not (lambda-case? body))) + (error "lambda body should be lambda-case" exp)) + (else + (if body + (visit body env))))) + (($ <let> src names gensyms vals body) + (cond + ((not (and (list? names) (and-map symbol? names))) + (error "names should be list of syms" exp)) + ((not (and (list? gensyms) (and-map symbol? gensyms))) + (error "gensyms should be list of syms" exp)) + ((not (list? vals)) + (error "vals should be list" exp)) + ((not (= (length names) (length gensyms) (length vals))) + (error "names, syms, vals should be same length" exp)) + (else + (for-each (cut visit <> env) vals) + (visit body (add-env gensyms env))))) + (($ <letrec> src in-order? names gensyms vals body) + (cond + ((not (and (list? names) (and-map symbol? names))) + (error "names should be list of syms" exp)) + ((not (and (list? gensyms) (and-map symbol? gensyms))) + (error "gensyms should be list of syms" exp)) + ((not (list? vals)) + (error "vals should be list" exp)) + ((not (= (length names) (length gensyms) (length vals))) + (error "names, syms, vals should be same length" exp)) + (else + (let ((env (add-env gensyms env))) + (for-each (cut visit <> env) vals) + (visit body env))))) + (($ <fix> src names gensyms vals body) + (cond + ((not (and (list? names) (and-map symbol? names))) + (error "names should be list of syms" exp)) + ((not (and (list? gensyms) (and-map symbol? gensyms))) + (error "gensyms should be list of syms" exp)) + ((not (list? vals)) + (error "vals should be list" exp)) + ((not (= (length names) (length gensyms) (length vals))) + (error "names, syms, vals should be same length" exp)) + (else + (let ((env (add-env gensyms env))) + (for-each (cut visit <> env) vals) + (visit body env))))) + (($ <let-values> src exp body) + (cond + ((not (lambda-case? body)) + (error "let-values body should be lambda-case" exp)) + (else + (visit exp env) + (visit body env)))) + (($ <const> src val) #t) + (($ <void> src) #t) + (($ <toplevel-ref> src name) + (cond + ((not (symbol? name)) + (error "name should be a symbol" name)))) + (($ <module-ref> src mod name public?) + (cond + ((not (and (list? mod) (and-map symbol? mod))) + (error "module name should be list of symbols" exp)) + ((not (symbol? name)) + (error "name should be symbol" exp)))) + (($ <primitive-ref> src name) + (cond + ((not (symbol? name)) + (error "name should be symbol" exp)))) + (($ <toplevel-set> src name exp) + (cond + ((not (symbol? name)) + (error "name should be a symbol" name)) + (else + (visit exp env)))) + (($ <toplevel-define> src name exp) + (cond + ((not (symbol? name)) + (error "name should be a symbol" name)) + (else + (visit exp env)))) + (($ <module-set> src mod name public? exp) + (cond + ((not (and (list? mod) (and-map symbol? mod))) + (error "module name should be list of symbols" exp)) + ((not (symbol? name)) + (error "name should be symbol" exp)) + (else + (visit exp env)))) + (($ <conditional> src condition subsequent alternate) + (visit condition env) + (visit subsequent env) + (visit alternate env)) + (($ <primcall> src name args) + (cond + ((not (symbol? name)) + (error "expected symbolic operator" exp)) + ((not (list? args)) + (error "expected list of args" args)) + (else + (for-each (cut visit <> env) args)))) + (($ <call> src proc args) + (cond + ((not (list? args)) + (error "expected list of args" args)) + (else + (visit proc env) + (for-each (cut visit <> env) args)))) + (($ <seq> src head tail) + (visit head env) + (visit tail env)) + (($ <prompt> src escape-only? tag body handler) + (unless (boolean? escape-only?) + (error "escape-only? should be a bool" escape-only?)) + (visit tag env) + (visit body env) + (visit handler env)) + (($ <abort> src tag args tail) + (visit tag env) + (for-each (cut visit <> env) args) + (visit tail env)) + (_ + (error "unexpected tree-il" exp))) + (let ((src (tree-il-src exp))) + (if (and src (not (and (list? src) (and-map pair? src) + (and-map symbol? (map car src))))) + (error "bad src")) + ;; Return it, why not. + exp))) diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm new file mode 100644 index 000000000..a133e3269 --- /dev/null +++ b/module/language/tree-il/effects.scm @@ -0,0 +1,591 @@ +;;; Effects analysis on Tree-IL + +;; Copyright (C) 2011, 2012, 2013 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 + +(define-module (language tree-il effects) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (ice-9 match) + #:export (make-effects-analyzer + &mutable-lexical + &toplevel + &fluid + &definite-bailout + &possible-bailout + &zero-values + &allocation + &type-check + &all-effects + effects-commute? + exclude-effects + effect-free? + constant? + depends-on-effects? + causes-effects?)) + +;;; +;;; Hey, it's some effects analysis! If you invoke +;;; `make-effects-analyzer', you get a procedure that computes the set +;;; of effects that an expression depends on and causes. This +;;; information is useful when writing algorithms that move code around, +;;; while preserving the semantics of an input program. +;;; +;;; The effects set is represented by a bitfield, as a fixnum. The set +;;; of possible effects is modelled rather coarsely. For example, a +;;; toplevel reference to FOO is modelled as depending on the &toplevel +;;; effect, and causing a &type-check effect. If any intervening code +;;; sets any toplevel variable, that will block motion of FOO. +;;; +;;; For each effect, two bits are reserved: one to indicate that an +;;; expression depends on the effect, and the other to indicate that an +;;; expression causes the effect. +;;; +;;; Since we have more bits in a fixnum on 64-bit systems, we can be +;;; more precise without losing efficiency. On a 32-bit system, some of +;;; the more precise effects map to fewer bits. +;;; + +(define-syntax define-effects + (lambda (x) + (syntax-case x () + ((_ all name ...) + (with-syntax (((n ...) (iota (length #'(name ...))))) + #'(begin + (define-syntax name (identifier-syntax (ash 1 (* n 2)))) + ... + (define-syntax all (identifier-syntax (logior name ...))))))))) + +(define-syntax compile-time-cond + (lambda (x) + (syntax-case x (else) + ((_ (else body ...)) + #'(begin body ...)) + ((_ (exp body ...) clause ...) + (if (eval (syntax->datum #'exp) (current-module)) + #'(begin body ...) + #'(compile-time-cond clause ...)))))) + +;; Here we define the effects, indicating the meaning of the effect. +;; +;; Effects that are described in a "depends on" sense can also be used +;; in the "causes" sense. +;; +;; Effects that are described as causing an effect are not usually used +;; in a "depends-on" sense. Although the "depends-on" sense is used +;; when checking for the existence of the "causes" effect, the effects +;; analyzer will not associate the "depends-on" sense of these effects +;; with any expression. +;; +(compile-time-cond + ((>= (logcount most-positive-fixnum) 60) + (define-effects &all-effects + ;; Indicates that an expression depends on the value of a mutable + ;; lexical variable. + &mutable-lexical + + ;; Indicates that an expression depends on the value of a toplevel + ;; variable. + &toplevel + + ;; Indicates that an expression depends on the value of a fluid + ;; variable. + &fluid + + ;; Indicates that an expression definitely causes a non-local, + ;; non-resumable exit -- a bailout. Only used in the "changes" sense. + &definite-bailout + + ;; Indicates that an expression may cause a bailout. + &possible-bailout + + ;; Indicates than an expression may return zero values -- a "causes" + ;; effect. + &zero-values + + ;; Indicates that an expression may return a fresh object -- a + ;; "causes" effect. + &allocation + + ;; Indicates that an expression depends on the value of the car of a + ;; pair. + &car + + ;; Indicates that an expression depends on the value of the cdr of a + ;; pair. + &cdr + + ;; Indicates that an expression depends on the value of a vector + ;; field. We cannot be more precise, as vectors may alias other + ;; vectors. + &vector + + ;; Indicates that an expression depends on the value of a variable + ;; cell. + &variable + + ;; Indicates that an expression depends on the value of a particular + ;; struct field. + &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+ + + ;; 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 + + ;; 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 depends on the contents of an unknown + ;; struct field. + (define-syntax &struct + (identifier-syntax + (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+)))) + + (else + ;; For systems with smaller fixnums, be less precise regarding struct + ;; fields. + (define-effects &all-effects + &mutable-lexical + &toplevel + &fluid + &definite-bailout + &possible-bailout + &zero-values + &allocation + &car + &cdr + &vector + &variable + &struct + &string + &bytevector + &type-check) + (define-syntax &struct-0 (identifier-syntax &struct)) + (define-syntax &struct-1 (identifier-syntax &struct)) + (define-syntax &struct-2 (identifier-syntax &struct)) + (define-syntax &struct-3 (identifier-syntax &struct)) + (define-syntax &struct-4 (identifier-syntax &struct)) + (define-syntax &struct-5 (identifier-syntax &struct)) + (define-syntax &struct-6+ (identifier-syntax &struct)))) + +(define-syntax &no-effects (identifier-syntax 0)) + +;; Definite bailout is an oddball effect. Since it indicates that an +;; expression definitely causes bailout, it's not in the set of effects +;; of a call to an unknown procedure. At the same time, it's also +;; special in that a definite bailout in a subexpression doesn't always +;; cause an outer expression to include &definite-bailout in its +;; effects. For that reason we have to treat it specially. +;; +(define-syntax &all-effects-but-bailout + (identifier-syntax + (logand &all-effects (lognot &definite-bailout)))) + +(define-inlinable (cause effect) + (ash effect 1)) + +(define-inlinable (&depends-on a) + (logand a &all-effects)) +(define-inlinable (&causes a) + (logand a (cause &all-effects))) + +(define (exclude-effects effects exclude) + (logand effects (lognot (cause exclude)))) +(define (effect-free? effects) + (zero? (&causes effects))) +(define (constant? effects) + (zero? effects)) + +(define-inlinable (depends-on-effects? x effects) + (not (zero? (logand (&depends-on x) effects)))) +(define-inlinable (causes-effects? x effects) + (not (zero? (logand (&causes x) (cause effects))))) + +(define-inlinable (effects-commute? a b) + (and (not (causes-effects? a (&depends-on b))) + (not (causes-effects? b (&depends-on a))))) + +(define (make-effects-analyzer assigned-lexical?) + "Returns a procedure of type EXP -> EFFECTS that analyzes the effects +of an expression." + + (let ((cache (make-hash-table))) + (define* (compute-effects exp #:optional (lookup (lambda (x) #f))) + (define (compute-effects exp) + (or (hashq-ref cache exp) + (let ((effects (visit exp))) + (hashq-set! cache exp effects) + effects))) + + (define (accumulate-effects exps) + (let lp ((exps exps) (out &no-effects)) + (if (null? exps) + out + (lp (cdr exps) (logior out (compute-effects (car exps))))))) + + (define (visit exp) + (match exp + (($ <const>) + &no-effects) + (($ <void>) + &no-effects) + (($ <lexical-ref> _ _ gensym) + (if (assigned-lexical? gensym) + &mutable-lexical + &no-effects)) + (($ <lexical-set> _ name gensym exp) + (logior (cause &mutable-lexical) + (compute-effects exp))) + (($ <let> _ names gensyms vals body) + (logior (if (or-map assigned-lexical? gensyms) + (cause &allocation) + &no-effects) + (accumulate-effects vals) + (compute-effects body))) + (($ <letrec> _ in-order? names gensyms vals body) + (logior (if (or-map assigned-lexical? gensyms) + (cause &allocation) + &no-effects) + (accumulate-effects vals) + (compute-effects body))) + (($ <fix> _ names gensyms vals body) + (logior (if (or-map assigned-lexical? gensyms) + (cause &allocation) + &no-effects) + (accumulate-effects vals) + (compute-effects body))) + (($ <let-values> _ producer consumer) + (logior (compute-effects producer) + (compute-effects consumer) + (cause &type-check))) + (($ <toplevel-ref>) + (logior &toplevel + (cause &type-check))) + (($ <module-ref>) + (logior &toplevel + (cause &type-check))) + (($ <module-set> _ mod name public? exp) + (logior (cause &toplevel) + (cause &type-check) + (compute-effects exp))) + (($ <toplevel-define> _ name exp) + (logior (cause &toplevel) + (compute-effects exp))) + (($ <toplevel-set> _ name exp) + (logior (cause &toplevel) + (compute-effects exp))) + (($ <primitive-ref>) + &no-effects) + (($ <conditional> _ test consequent alternate) + (let ((tfx (compute-effects test)) + (cfx (compute-effects consequent)) + (afx (compute-effects alternate))) + (if (causes-effects? (logior tfx (logand afx cfx)) + &definite-bailout) + (logior tfx cfx afx) + (exclude-effects (logior tfx cfx afx) + &definite-bailout)))) + + ;; Zero values. + (($ <primcall> _ 'values ()) + (cause &zero-values)) + + ;; Effect-free primitives. + (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args) + (accumulate-effects args)) + + (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol? + 'vector? 'struct? 'string? 'number? + 'char?) + (arg)) + (compute-effects arg)) + + ;; Primitives that allocate memory. + (($ <primcall> _ 'cons (x y)) + (logior (compute-effects x) (compute-effects y) + &allocation)) + + (($ <primcall> _ (or 'list 'vector) args) + (logior (accumulate-effects args) &allocation)) + + (($ <primcall> _ 'make-prompt-tag ()) + &allocation) + + (($ <primcall> _ 'make-prompt-tag (arg)) + (logior (compute-effects arg) &allocation)) + + (($ <primcall> _ 'fluid-ref (fluid)) + (logior (compute-effects fluid) + (cause &type-check) + &fluid)) + + (($ <primcall> _ 'fluid-set! (fluid exp)) + (logior (compute-effects fluid) + (compute-effects exp) + (cause &type-check) + (cause &fluid))) + + (($ <primcall> _ 'push-fluid (fluid val)) + (logior (compute-effects fluid) + (compute-effects val) + (cause &type-check) + (cause &fluid))) + + (($ <primcall> _ 'pop-fluid ()) + (logior (cause &fluid))) + + (($ <primcall> _ 'push-dynamic-state (state)) + (logior (compute-effects state) + (cause &type-check) + (cause &fluid))) + + (($ <primcall> _ 'pop-dynamic-state ()) + (logior (cause &fluid))) + + (($ <primcall> _ 'car (x)) + (logior (compute-effects x) + (cause &type-check) + &car)) + (($ <primcall> _ 'set-car! (x y)) + (logior (compute-effects x) + (compute-effects y) + (cause &type-check) + (cause &car))) + + (($ <primcall> _ 'cdr (x)) + (logior (compute-effects x) + (cause &type-check) + &cdr)) + (($ <primcall> _ 'set-cdr! (x y)) + (logior (compute-effects x) + (compute-effects y) + (cause &type-check) + (cause &cdr))) + + (($ <primcall> _ (or 'memq 'memv) (x y)) + (logior (compute-effects x) + (compute-effects y) + (cause &type-check) + &car &cdr)) + + (($ <primcall> _ 'vector-ref (v n)) + (logior (compute-effects v) + (compute-effects n) + (cause &type-check) + &vector)) + (($ <primcall> _ 'vector-set! (v n x)) + (logior (compute-effects v) + (compute-effects n) + (compute-effects x) + (cause &type-check) + (cause &vector))) + + (($ <primcall> _ 'variable-ref (v)) + (logior (compute-effects v) + (cause &type-check) + &variable)) + (($ <primcall> _ 'variable-set! (v x)) + (logior (compute-effects v) + (compute-effects x) + (cause &type-check) + (cause &variable))) + + (($ <primcall> _ 'struct-ref (s n)) + (logior (compute-effects s) + (compute-effects n) + (cause &type-check) + (match n + (($ <const> _ 0) &struct-0) + (($ <const> _ 1) &struct-1) + (($ <const> _ 2) &struct-2) + (($ <const> _ 3) &struct-3) + (($ <const> _ 4) &struct-4) + (($ <const> _ 5) &struct-5) + (($ <const> _ _) &struct-6+) + (_ &struct)))) + (($ <primcall> _ 'struct-set! (s n x)) + (logior (compute-effects s) + (compute-effects n) + (compute-effects x) + (cause &type-check) + (match n + (($ <const> _ 0) (cause &struct-0)) + (($ <const> _ 1) (cause &struct-1)) + (($ <const> _ 2) (cause &struct-2)) + (($ <const> _ 3) (cause &struct-3)) + (($ <const> _ 4) (cause &struct-4)) + (($ <const> _ 5) (cause &struct-5)) + (($ <const> _ _) (cause &struct-6+)) + (_ (cause &struct))))) + + (($ <primcall> _ 'string-ref (s n)) + (logior (compute-effects s) + (compute-effects n) + (cause &type-check) + &string)) + (($ <primcall> _ 'string-set! (s n c)) + (logior (compute-effects s) + (compute-effects n) + (compute-effects c) + (cause &type-check) + (cause &string))) + + (($ <primcall> _ + (or 'bytevector-u8-ref 'bytevector-s8-ref + 'bytevector-u16-ref 'bytevector-u16-native-ref + 'bytevector-s16-ref 'bytevector-s16-native-ref + 'bytevector-u32-ref 'bytevector-u32-native-ref + 'bytevector-s32-ref 'bytevector-s32-native-ref + 'bytevector-u64-ref 'bytevector-u64-native-ref + 'bytevector-s64-ref 'bytevector-s64-native-ref + 'bytevector-ieee-single-ref 'bytevector-ieee-single-native-ref + 'bytevector-ieee-double-ref 'bytevector-ieee-double-native-ref) + (bv n)) + (logior (compute-effects bv) + (compute-effects n) + (cause &type-check) + &bytevector)) + (($ <primcall> _ + (or 'bytevector-u8-set! 'bytevector-s8-set! + 'bytevector-u16-set! 'bytevector-u16-native-set! + 'bytevector-s16-set! 'bytevector-s16-native-set! + 'bytevector-u32-set! 'bytevector-u32-native-set! + 'bytevector-s32-set! 'bytevector-s32-native-set! + 'bytevector-u64-set! 'bytevector-u64-native-set! + 'bytevector-s64-set! 'bytevector-s64-native-set! + 'bytevector-ieee-single-set! 'bytevector-ieee-single-native-set! + 'bytevector-ieee-double-set! 'bytevector-ieee-double-native-set!) + (bv n x)) + (logior (compute-effects bv) + (compute-effects n) + (compute-effects x) + (cause &type-check) + (cause &bytevector))) + + ;; Primitives that are normally effect-free, but which might + ;; cause type checks or allocate memory. Nota bene, + ;; primitives that access mutable memory should be given their + ;; own inline cases above! + (($ <primcall> _ (and name (? effect-free-primitive?)) args) + (logior (accumulate-effects args) + (cause &type-check) + (if (constructor-primitive? name) + (cause &allocation) + &no-effects))) + + ;; Lambda applications might throw wrong-number-of-args. + (($ <call> _ ($ <lambda> _ _ body) args) + (logior (accumulate-effects args) + (match body + (($ <lambda-case> _ req #f #f #f () syms body #f) + (logior (compute-effects body) + (if (= (length req) (length args)) + 0 + (cause &type-check)))) + (($ <lambda-case>) + (logior (compute-effects body) + (cause &type-check))) + (#f + ;; Calling a case-lambda with no clauses + ;; definitely causes bailout. + (logior (cause &definite-bailout) + (cause &possible-bailout)))))) + + ;; Bailout primitives. + (($ <primcall> _ (? bailout-primitive? name) args) + (logior (accumulate-effects args) + (cause &definite-bailout) + (cause &possible-bailout))) + (($ <call> _ + (and proc + ($ <module-ref> _ mod name public?) + (? (lambda (_) + (false-if-exception + (procedure-property + (module-ref (if public? + (resolve-interface mod) + (resolve-module mod)) + name) + 'definite-bailout?))))) + args) + (logior (compute-effects proc) + (accumulate-effects args) + (cause &definite-bailout) + (cause &possible-bailout))) + + ;; A call to a lexically bound procedure, perhaps labels + ;; allocated. + (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args) + (cond + ((lookup sym) + => (lambda (proc) + (compute-effects (make-call #f proc args)))) + (else + (logior &all-effects-but-bailout + (cause &all-effects-but-bailout))))) + + ;; A call to an unknown procedure can do anything. + (($ <primcall> _ name args) + (logior &all-effects-but-bailout + (cause &all-effects-but-bailout))) + (($ <call> _ proc args) + (logior &all-effects-but-bailout + (cause &all-effects-but-bailout))) + + (($ <lambda> _ meta body) + &no-effects) + (($ <lambda-case> _ req opt rest kw inits gensyms body alt) + (logior (exclude-effects (accumulate-effects inits) + &definite-bailout) + (if (or-map assigned-lexical? gensyms) + (cause &allocation) + &no-effects) + (compute-effects body) + (if alt (compute-effects alt) &no-effects))) + + (($ <seq> _ head tail) + (logior + ;; Returning zero values to a for-effect continuation is + ;; not observable. + (exclude-effects (compute-effects head) + (cause &zero-values)) + (compute-effects tail))) + + (($ <prompt> _ escape-only? tag body handler) + (logior (compute-effects tag) + (compute-effects body) + (compute-effects handler))) + + (($ <abort> _ tag args tail) + (logior &all-effects-but-bailout + (cause &all-effects-but-bailout))))) + + (compute-effects exp)) + + compute-effects)) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm new file mode 100644 index 000000000..5d6ad91f6 --- /dev/null +++ b/module/language/tree-il/fix-letrec.scm @@ -0,0 +1,314 @@ +;;; transformation of letrec into simpler forms + +;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2016 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 + +(define-module (language tree-il fix-letrec) + #:use-module (system base syntax) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language tree-il) + #:use-module (language tree-il effects) + #:export (fix-letrec)) + +;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet +;; Efficient Implementation of Scheme's Recursive Binding Construct", by +;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig. + +(define fix-fold + (make-tree-il-folder unref ref set simple lambda complex)) + +(define (simple-expression? x bound-vars simple-primcall?) + (record-case x + ((<void>) #t) + ((<const>) #t) + ((<lexical-ref> gensym) + (not (memq gensym bound-vars))) + ((<conditional> test consequent alternate) + (and (simple-expression? test bound-vars simple-primcall?) + (simple-expression? consequent bound-vars simple-primcall?) + (simple-expression? alternate bound-vars simple-primcall?))) + ((<seq> head tail) + (and (simple-expression? head bound-vars simple-primcall?) + (simple-expression? tail bound-vars simple-primcall?))) + ((<primcall> name args) + (and (simple-primcall? x) + (and-map (lambda (x) + (simple-expression? x bound-vars simple-primcall?)) + args))) + (else #f))) + +(define (partition-vars x) + (let-values + (((unref ref set simple lambda* complex) + (fix-fold x + (lambda (x unref ref set simple lambda* complex) + (record-case x + ((<lexical-ref> gensym) + (values (delq gensym unref) + (lset-adjoin eq? ref gensym) + set + simple + lambda* + complex)) + ((<lexical-set> gensym) + (values unref + ref + (lset-adjoin eq? set gensym) + simple + lambda* + complex)) + ((<letrec> gensyms) + (values (append gensyms unref) + ref + set + simple + lambda* + complex)) + ((<let> gensyms) + (values (append gensyms unref) + ref + set + simple + lambda* + complex)) + (else + (values unref ref set simple lambda* complex)))) + (lambda (x unref ref set simple lambda* complex) + (record-case x + ((<letrec> in-order? (orig-gensyms gensyms) vals) + (define compute-effects + (make-effects-analyzer (lambda (x) (memq x set)))) + (define (effect-free-primcall? x) + (let ((effects (compute-effects x))) + (effect-free? + (exclude-effects effects (logior &allocation + &type-check))))) + (define (effect+exception-free-primcall? x) + (let ((effects (compute-effects x))) + (effect-free? + (exclude-effects effects &allocation)))) + (let lp ((gensyms orig-gensyms) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? gensyms) + ;; Unreferenced complex vars are still + ;; complex for letrec*. We need to update + ;; our algorithm to "Fixing letrec reloaded" + ;; to fix this. + (values (if in-order? + (lset-difference eq? unref c) + unref) + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car gensyms) unref) + ;; See above note about unref and letrec*. + (if (and in-order? + (not (lambda? (car vals))) + (not (simple-expression? + (car vals) orig-gensyms + effect+exception-free-primcall?))) + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c)) + (lp (cdr gensyms) (cdr vals) + s l c))) + ((memq (car gensyms) set) + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c))) + ((lambda? (car vals)) + (lp (cdr gensyms) (cdr vals) + s (cons (car gensyms) l) c)) + ((simple-expression? + (car vals) orig-gensyms + (if in-order? + effect+exception-free-primcall? + effect-free-primcall?)) + ;; For letrec*, we can't consider e.g. `car' to be + ;; "simple", as it could raise an exception. Hence + ;; effect+exception-free-primitive? above. + (lp (cdr gensyms) (cdr vals) + (cons (car gensyms) s) l c)) + (else + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c)))))) + ((<let> (orig-gensyms gensyms) vals) + ;; The point is to compile let-bound lambdas as + ;; efficiently as we do letrec-bound lambdas, so + ;; we use the same algorithm for analyzing the + ;; gensyms. There is no problem recursing into the + ;; bindings after the let, because all variables + ;; have been renamed. + (let lp ((gensyms orig-gensyms) (vals vals) + (s '()) (l '()) (c '())) + (cond + ((null? gensyms) + (values unref + ref + set + (append s simple) + (append l lambda*) + (append c complex))) + ((memq (car gensyms) unref) + (lp (cdr gensyms) (cdr vals) + s l c)) + ((memq (car gensyms) set) + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c))) + ((and (lambda? (car vals)) + (not (memq (car gensyms) set))) + (lp (cdr gensyms) (cdr vals) + s (cons (car gensyms) l) c)) + ;; There is no difference between simple and + ;; complex, for the purposes of let. Just lump + ;; them all into complex. + (else + (lp (cdr gensyms) (cdr vals) + s l (cons (car gensyms) c)))))) + (else + (values unref ref set simple lambda* complex)))) + '() + '() + '() + '() + '() + '()))) + (values unref simple lambda* complex))) + +(define (make-seq* src head tail) + (record-case head + ((<lambda>) tail) + ((<const>) tail) + ((<lexical-ref>) tail) + ((<void>) tail) + (else (make-seq src head tail)))) + +(define (list->seq* loc exps) + (if (null? (cdr exps)) + (car exps) + (let lp ((exps (cdr exps)) (effects (list (car exps)))) + (if (null? (cdr exps)) + (make-seq* loc + (fold (lambda (exp tail) (make-seq* #f exp tail)) + (car effects) + (cdr effects)) + (car exps)) + (lp (cdr exps) (cons (car exps) effects)))))) + +(define (fix-letrec x) + (let-values (((unref simple lambda* complex) (partition-vars x))) + (post-order + (lambda (x) + (record-case x + + ;; Sets to unreferenced variables may be replaced by their + ;; expression, called for effect. + ((<lexical-set> gensym exp) + (if (memq gensym unref) + (make-seq* #f exp (make-void #f)) + x)) + + ((<letrec> src in-order? names gensyms vals body) + (let ((binds (map list gensyms names vals))) + ;; The bindings returned by this function need to appear in the same + ;; order that they appear in the letrec. + (define (lookup set) + (let lp ((binds binds)) + (cond + ((null? binds) '()) + ((memq (caar binds) set) + (cons (car binds) (lp (cdr binds)))) + (else (lp (cdr binds)))))) + (let ((u (lookup unref)) + (s (lookup simple)) + (l (lookup lambda*)) + (c (lookup complex))) + ;; Bind "simple" bindings, and locations for complex + ;; bindings. + (make-let + src + (append (map cadr s) (map cadr c)) + (append (map car s) (map car c)) + (append (map caddr s) (map (lambda (x) (make-void #f)) c)) + ;; Bind lambdas using the fixpoint operator. + (make-fix + src (map cadr l) (map car l) (map caddr l) + (list->seq* + src + (append + ;; The right-hand-sides of the unreferenced + ;; bindings, for effect. + (map caddr u) + (cond + ((null? c) + ;; No complex bindings, just emit the body. + (list body)) + (in-order? + ;; For letrec*, assign complex bindings in order, then the + ;; body. + (append + (map (lambda (c) + (make-lexical-set #f (cadr c) (car c) + (caddr c))) + c) + (list body))) + (else + ;; Otherwise for plain letrec, evaluate the "complex" + ;; bindings, in a `let' to indicate that order doesn't + ;; matter, and bind to their variables. + (list + (let ((tmps (map (lambda (x) + (module-gensym "fixlr")) + c))) + (make-let + #f (map cadr c) tmps (map caddr c) + (list->seq + #f + (map (lambda (x tmp) + (make-lexical-set + #f (cadr x) (car x) + (make-lexical-ref #f (cadr x) tmp))) + c tmps)))) + body)))))))))) + + ((<let> src names gensyms vals body) + (let ((binds (map list gensyms names vals))) + (define (lookup set) + (map (lambda (v) (assq v binds)) + (lset-intersection eq? gensyms set))) + (let ((u (lookup unref)) + (l (lookup lambda*)) + (c (lookup complex))) + (list->seq* + src + (append + ;; unreferenced bindings, called for effect. + (map caddr u) + (list + ;; unassigned lambdas use fix. + (make-fix src (map cadr l) (map car l) (map caddr l) + ;; and the "complex" bindings. + (make-let src (map cadr c) (map car c) (map caddr c) + body)))))))) + + (else x))) + x))) + +;;; Local Variables: +;;; eval: (put 'record-case 'scheme-indent-function 1) +;;; End: diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm new file mode 100644 index 000000000..13b0977d4 --- /dev/null +++ b/module/language/tree-il/optimize.scm @@ -0,0 +1,63 @@ +;;; Tree-il optimizer + +;; Copyright (C) 2009, 2010-2015, 2018 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 tree-il optimize) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (language tree-il peval) + #:use-module (language tree-il fix-letrec) + #:use-module (language tree-il debug) + #:use-module (ice-9 match) + #:export (optimize + tree-il-optimizations)) + +(define (kw-arg-ref args kw default) + (match (memq kw args) + ((_ val . _) val) + (_ default))) + +(define *debug?* #f) + +(define (maybe-verify x) + (if *debug?* + (verify-tree-il x) + x)) + +(define (optimize x env opts) + (define-syntax-rule (run-pass pass kw default) + (when (kw-arg-ref opts kw default) + (set! x (maybe-verify (pass x))))) + (define (resolve* x) (resolve-primitives x env)) + (define (peval* x) (peval x env)) + (maybe-verify x) + (run-pass resolve* #:resolve-primitives? #t) + (run-pass expand-primitives #:expand-primitives? #t) + (run-pass peval* #:partial-eval? #t) + (run-pass fix-letrec #:fix-letrec? #t) + x) + +(define (tree-il-optimizations) + ;; Avoid resolve-primitives until -O2, when CPS optimizations kick in. + ;; Otherwise, inlining the primcalls during Tree-IL->CPS compilation + ;; will result in a lot of code that will never get optimized nicely. + '((#:resolve-primitives? 2) + (#:expand-primitives? 1) + (#:partial-eval? 1) + (#:fix-letrec? 1))) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm new file mode 100644 index 000000000..b8a0fe9d0 --- /dev/null +++ b/module/language/tree-il/peval.scm @@ -0,0 +1,1675 @@ +;;; Tree-IL partial evaluator + +;; Copyright (C) 2011-2014, 2017 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 + +(define-module (language tree-il peval) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (language tree-il effects) + #:use-module (ice-9 vlist) + #: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 (ice-9 control) + #:export (peval)) + +;;; +;;; Partial evaluation is Guile's most important source-to-source +;;; optimization pass. It performs copy propagation, dead code +;;; elimination, inlining, and constant folding, all while preserving +;;; the order of effects in the residual program. +;;; +;;; For more on partial evaluation, see William Cook’s excellent +;;; tutorial on partial evaluation at DSL 2011, called “Build your own +;;; partial evaluator in 90 minutes”[0]. +;;; +;;; Our implementation of this algorithm was heavily influenced by +;;; Waddell and Dybvig's paper, "Fast and Effective Procedure Inlining", +;;; IU CS Dept. TR 484. +;;; +;;; [0] http://www.cs.utexas.edu/~wcook/tutorial/. +;;; + +;; First, some helpers. +;; +(define-syntax *logging* (identifier-syntax #f)) + +;; For efficiency we define *logging* to inline to #f, so that the call +;; to log* gets optimized out. If you want to log, uncomment these +;; lines: +;; +;; (define %logging #f) +;; (define-syntax *logging* (identifier-syntax %logging)) +;; +;; Then you can change %logging at runtime. + +(define-syntax log + (syntax-rules (quote) + ((log 'event arg ...) + (if (and *logging* + (or (eq? *logging* #t) + (memq 'event *logging*))) + (log* 'event arg ...))))) + +(define (log* event . args) + (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print)) + 'pretty-print))) + (pp `(log ,event . ,args)) + (newline) + (values))) + +(define (tree-il-any proc exp) + (let/ec k + (tree-il-fold (lambda (exp res) + (let ((res (proc exp))) + (if res (k res) #f))) + (lambda (exp res) #f) + #f exp))) + +(define (vlist-any proc vlist) + (let ((len (vlist-length vlist))) + (let lp ((i 0)) + (and (< i len) + (or (proc (vlist-ref vlist i)) + (lp (1+ i))))))) + +(define (singly-valued-expression? exp) + (match exp + (($ <const>) #t) + (($ <void>) #t) + (($ <lexical-ref>) #t) + (($ <primitive-ref>) #t) + (($ <module-ref>) #t) + (($ <toplevel-ref>) #t) + (($ <primcall> _ (? singly-valued-primitive?)) #t) + (($ <primcall> _ 'values (val)) #t) + (($ <lambda>) #t) + (($ <conditional> _ test consequent alternate) + (and (singly-valued-expression? consequent) + (singly-valued-expression? alternate))) + (else #f))) + +(define (truncate-values x) + "Discard all but the first value of X." + (if (singly-valued-expression? x) + x + (make-primcall (tree-il-src x) 'values (list x)))) + +;; Peval will do a one-pass analysis on the source program to determine +;; the set of assigned lexicals, and to identify unreferenced and +;; singly-referenced lexicals. +;; +(define-record-type <var> + (make-var name gensym refcount set?) + var? + (name var-name) + (gensym var-gensym) + (refcount var-refcount set-var-refcount!) + (set? var-set? set-var-set?!)) + +(define* (build-var-table exp #:optional (table vlist-null)) + (tree-il-fold + (lambda (exp res) + (match exp + (($ <lexical-ref> src name gensym) + (let ((var (cdr (vhash-assq gensym res)))) + (set-var-refcount! var (1+ (var-refcount var))) + res)) + (($ <lambda-case> src req opt rest kw init gensyms body alt) + (fold (lambda (name sym res) + (vhash-consq sym (make-var name sym 0 #f) res)) + res + (append req (or opt '()) (if rest (list rest) '()) + (match kw + ((aok? (kw name sym) ...) name) + (_ '()))) + gensyms)) + (($ <let> src names gensyms vals body) + (fold (lambda (name sym res) + (vhash-consq sym (make-var name sym 0 #f) res)) + res names gensyms)) + (($ <letrec> src in-order? names gensyms vals body) + (fold (lambda (name sym res) + (vhash-consq sym (make-var name sym 0 #f) res)) + res names gensyms)) + (($ <fix> src names gensyms vals body) + (fold (lambda (name sym res) + (vhash-consq sym (make-var name sym 0 #f) res)) + res names gensyms)) + (($ <lexical-set> src name gensym exp) + (set-var-set?! (cdr (vhash-assq gensym res)) #t) + res) + (_ res))) + (lambda (exp res) res) + table exp)) + +;; Counters are data structures used to limit the effort that peval +;; spends on particular inlining attempts. Each call site in the source +;; program is allocated some amount of effort. If peval exceeds the +;; effort counter while attempting to inline a call site, it aborts the +;; inlining attempt and residualizes a call instead. +;; +;; As there is a fixed number of call sites, that makes `peval' O(N) in +;; the number of call sites in the source program. +;; +;; Counters should limit the size of the residual program as well, but +;; currently this is not implemented. +;; +;; At the top level, before seeing any peval call, there is no counter, +;; because inlining will terminate as there is no recursion. When peval +;; sees a call at the top level, it will make a new counter, allocating +;; it some amount of effort and size. +;; +;; This top-level effort counter effectively "prints money". Within a +;; toplevel counter, no more effort is printed ex nihilo; for a nested +;; inlining attempt to proceed, effort must be transferred from the +;; toplevel counter to the nested counter. +;; +;; Via `data' and `prev', counters form a linked list, terminating in a +;; toplevel counter. In practice `data' will be the a pointer to the +;; source expression of the procedure being inlined. +;; +;; In this way peval can detect a recursive inlining attempt, by walking +;; back on the `prev' links looking for matching `data'. Recursive +;; counters receive a more limited effort allocation, as we don't want +;; to spend all of the effort for a toplevel inlining site on loops. +;; Also, recursive counters don't need a prompt at each inlining site: +;; either the call chain folds entirely, or it will be residualized at +;; its original call. +;; +(define-record-type <counter> + (%make-counter effort size continuation recursive? data prev) + counter? + (effort effort-counter) + (size size-counter) + (continuation counter-continuation) + (recursive? counter-recursive? set-counter-recursive?!) + (data counter-data) + (prev counter-prev)) + +(define (abort-counter c) + ((counter-continuation c))) + +(define (record-effort! c) + (let ((e (effort-counter c))) + (if (zero? (variable-ref e)) + (abort-counter c) + (variable-set! e (1- (variable-ref e)))))) + +(define (record-size! c) + (let ((s (size-counter c))) + (if (zero? (variable-ref s)) + (abort-counter c) + (variable-set! s (1- (variable-ref s)))))) + +(define (find-counter data counter) + (and counter + (if (eq? data (counter-data counter)) + counter + (find-counter data (counter-prev counter))))) + +(define* (transfer! from to #:optional + (effort (variable-ref (effort-counter from))) + (size (variable-ref (size-counter from)))) + (define (transfer-counter! from-v to-v amount) + (let* ((from-balance (variable-ref from-v)) + (to-balance (variable-ref to-v)) + (amount (min amount from-balance))) + (variable-set! from-v (- from-balance amount)) + (variable-set! to-v (+ to-balance amount)))) + + (transfer-counter! (effort-counter from) (effort-counter to) effort) + (transfer-counter! (size-counter from) (size-counter to) size)) + +(define (make-top-counter effort-limit size-limit continuation data) + (%make-counter (make-variable effort-limit) + (make-variable size-limit) + continuation + #t + data + #f)) + +(define (make-nested-counter continuation data current) + (let ((c (%make-counter (make-variable 0) + (make-variable 0) + continuation + #f + data + current))) + (transfer! current c) + c)) + +(define (make-recursive-counter effort-limit size-limit orig current) + (let ((c (%make-counter (make-variable 0) + (make-variable 0) + (counter-continuation orig) + #t + (counter-data orig) + current))) + (transfer! current c effort-limit size-limit) + c)) + +;; Operand structures allow bindings to be processed lazily instead of +;; eagerly. By doing so, hopefully we can get process them in a way +;; appropriate to their use contexts. Operands also prevent values from +;; being visited multiple times, wasting effort. +;; +;; TODO: Record value size in operand structure? +;; +(define-record-type <operand> + (%make-operand var sym visit source visit-count use-count + copyable? residual-value constant-value alias) + operand? + (var operand-var) + (sym operand-sym) + (visit %operand-visit) + (source operand-source) + (visit-count operand-visit-count set-operand-visit-count!) + (use-count operand-use-count set-operand-use-count!) + (copyable? operand-copyable? set-operand-copyable?!) + (residual-value operand-residual-value %set-operand-residual-value!) + (constant-value operand-constant-value set-operand-constant-value!) + (alias operand-alias set-operand-alias!)) + +(define* (make-operand var sym #:optional source visit alias) + ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are + ;; considered copyable until we prove otherwise. If we have a source + ;; expression, truncate it to one value. Copy propagation does not + ;; work on multiply-valued expressions. + (let ((source (and=> source truncate-values))) + (%make-operand var sym visit source 0 0 + (and source (not (var-set? var))) #f #f + (and (not (var-set? var)) alias)))) + +(define* (make-bound-operands vars syms sources visit #:optional aliases) + (if aliases + (map (lambda (name sym source alias) + (make-operand name sym source visit alias)) + vars syms sources aliases) + (map (lambda (name sym source) + (make-operand name sym source visit #f)) + vars syms sources))) + +(define (make-unbound-operands vars syms) + (map make-operand vars syms)) + +(define (set-operand-residual-value! op val) + (%set-operand-residual-value! + op + (match val + (($ <primcall> src 'values (first)) + ;; The continuation of a residualized binding does not need the + ;; introduced `values' node, so undo the effects of truncation. + first) + (else + val)))) + +(define* (visit-operand op counter ctx #:optional effort-limit size-limit) + ;; Peval is O(N) in call sites of the source program. However, + ;; visiting an operand can introduce new call sites. If we visit an + ;; operand outside a counter -- i.e., outside an inlining attempt -- + ;; this can lead to divergence. So, if we are visiting an operand to + ;; try to copy it, and there is no counter, make a new one. + ;; + ;; This will only happen at most as many times as there are lexical + ;; references in the source program. + (and (zero? (operand-visit-count op)) + (dynamic-wind + (lambda () + (set-operand-visit-count! op (1+ (operand-visit-count op)))) + (lambda () + (and (operand-source op) + (if (or counter (and (not effort-limit) (not size-limit))) + ((%operand-visit op) (operand-source op) counter ctx) + (let/ec k + (define (abort) + ;; If we abort when visiting the value in a + ;; fresh context, we won't succeed in any future + ;; attempt, so don't try to copy it again. + (set-operand-copyable?! op #f) + (k #f)) + ((%operand-visit op) + (operand-source op) + (make-top-counter effort-limit size-limit abort op) + ctx))))) + (lambda () + (set-operand-visit-count! op (1- (operand-visit-count op))))))) + +;; A helper for constant folding. +;; +(define (types-check? primitive-name args) + (case primitive-name + ((values) #t) + ((not pair? null? list? symbol? vector? struct?) + (= (length args) 1)) + ((eq? eqv? equal?) + (= (length args) 2)) + ;; FIXME: add more cases? + (else #f))) + +(define* (peval exp #:optional (cenv (current-module)) (env vlist-null) + #:key + (operator-size-limit 40) + (operand-size-limit 20) + (value-size-limit 10) + (effort-limit 500) + (recursive-effort-limit 100)) + "Partially evaluate EXP in compilation environment CENV, with +top-level bindings from ENV and return the resulting expression." + + ;; This is a simple partial evaluator. It effectively performs + ;; constant folding, copy propagation, dead code elimination, and + ;; inlining. + + ;; TODO: + ;; + ;; Propagate copies across toplevel bindings, if we can prove the + ;; bindings to be immutable. + ;; + ;; Specialize lambda expressions with invariant arguments. + + (define local-toplevel-env + ;; The top-level environment of the module being compiled. + (let () + (define (env-folder x env) + (match x + (($ <toplevel-define> _ name) + (vhash-consq name #t env)) + (($ <seq> _ head tail) + (env-folder tail (env-folder head env))) + (_ env))) + (env-folder exp vlist-null))) + + (define (local-toplevel? name) + (vhash-assq name local-toplevel-env)) + + ;; gensym -> <var> + ;; renamed-term -> original-term + ;; + (define store (build-var-table exp)) + + (define (record-new-temporary! name sym refcount) + (set! store (vhash-consq sym (make-var name sym refcount #f) store))) + + (define (lookup-var sym) + (let ((v (vhash-assq sym store))) + (if v (cdr v) (error "unbound var" sym (vlist->list store))))) + + (define (fresh-gensyms vars) + (map (lambda (var) + (let ((new (gensym (string-append (symbol->string (var-name var)) + " ")))) + (set! store (vhash-consq new var store)) + new)) + vars)) + + (define (fresh-temporaries ls) + (map (lambda (elt) + (let ((new (gensym "tmp "))) + (record-new-temporary! 'tmp new 1) + new)) + ls)) + + (define (assigned-lexical? sym) + (var-set? (lookup-var sym))) + + (define (lexical-refcount sym) + (var-refcount (lookup-var sym))) + + (define (with-temporaries src exps refcount can-copy? k) + (let* ((pairs (map (match-lambda + ((and exp (? can-copy?)) + (cons #f exp)) + (exp + (let ((sym (gensym "tmp "))) + (record-new-temporary! 'tmp sym refcount) + (cons sym exp)))) + exps)) + (tmps (filter car pairs))) + (match tmps + (() (k exps)) + (tmps + (make-let src + (make-list (length tmps) 'tmp) + (map car tmps) + (map cdr tmps) + (k (map (match-lambda + ((#f . val) val) + ((sym . _) + (make-lexical-ref #f 'tmp sym))) + pairs))))))) + + (define (make-begin0 src first second) + (make-let-values + src + first + (let ((vals (gensym "vals "))) + (record-new-temporary! 'vals vals 1) + (make-lambda-case + #f + '() #f 'vals #f '() (list vals) + (make-seq + src + second + (make-primcall #f 'apply + (list + (make-primitive-ref #f 'values) + (make-lexical-ref #f 'vals vals)))) + #f)))) + + ;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link + ;; from it to ORIG. + ;; + (define (record-source-expression! orig new) + (set! store (vhash-consq new (source-expression orig) store)) + new) + + ;; Find the source expression corresponding to NEW. Used to detect + ;; recursive inlining attempts. + ;; + (define (source-expression new) + (let ((x (vhash-assq new store))) + (if x (cdr x) new))) + + (define (record-operand-use op) + (set-operand-use-count! op (1+ (operand-use-count op)))) + + (define (unrecord-operand-uses op n) + (let ((count (- (operand-use-count op) n))) + (when (zero? count) + (set-operand-residual-value! op #f)) + (set-operand-use-count! op count))) + + (define* (residualize-lexical op #:optional ctx val) + (log 'residualize op) + (record-operand-use op) + (if (memq ctx '(value values)) + (set-operand-residual-value! op val)) + (make-lexical-ref #f (var-name (operand-var op)) (operand-sym op))) + + (define (fold-constants src name args ctx) + (define (apply-primitive name args) + ;; todo: further optimize commutative primitives + (catch #t + (lambda () + (call-with-values + (lambda () + (case name + ((eq? eqv?) + ;; Constants will be deduplicated later, but eq? + ;; folding can happen now. Anticipate the + ;; deduplication by using equal? instead of eq?. + ;; Same for eqv?. + (apply equal? args)) + (else + (apply (module-ref the-scm-module name) args)))) + (lambda results + (values #t results)))) + (lambda _ + (values #f '())))) + (define (make-values src values) + (match values + ((single) single) ; 1 value + ((_ ...) ; 0, or 2 or more values + (make-primcall src 'values values)))) + (define (residualize-call) + (make-primcall src name args)) + (cond + ((every const? args) + (let-values (((success? values) + (apply-primitive name (map const-exp args)))) + (log 'fold success? values name args) + (if success? + (case ctx + ((effect) (make-void src)) + ((test) + ;; Values truncation: only take the first + ;; value. + (if (pair? values) + (make-const src (car values)) + (make-values src '()))) + (else + (make-values src (map (cut make-const src <>) values)))) + (residualize-call)))) + ((and (eq? ctx 'effect) (types-check? name args)) + (make-void #f)) + (else + (residualize-call)))) + + (define (inline-values src exp nmin nmax consumer) + (let loop ((exp exp)) + (match exp + ;; Some expression types are always singly-valued. + ((or ($ <const>) + ($ <void>) + ($ <lambda>) + ($ <lexical-ref>) + ($ <toplevel-ref>) + ($ <module-ref>) + ($ <primitive-ref>) + ($ <lexical-set>) ; FIXME: these set! expressions + ($ <toplevel-set>) ; could return zero values in + ($ <toplevel-define>) ; the future + ($ <module-set>) ; + ($ <primcall> src (? singly-valued-primitive?))) + (and (<= nmin 1) (or (not nmax) (>= nmax 1)) + (make-call src (make-lambda #f '() consumer) (list exp)))) + + ;; Statically-known number of values. + (($ <primcall> src 'values vals) + (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals))) + (make-call src (make-lambda #f '() consumer) vals))) + + ;; Not going to copy code into both branches. + (($ <conditional>) #f) + + ;; Bail on other applications. + (($ <call>) #f) + (($ <primcall>) #f) + + ;; Bail on prompt and abort. + (($ <prompt>) #f) + (($ <abort>) #f) + + ;; Propagate to tail positions. + (($ <let> src names gensyms vals body) + (let ((body (loop body))) + (and body + (make-let src names gensyms vals body)))) + (($ <letrec> src in-order? names gensyms vals body) + (let ((body (loop body))) + (and body + (make-letrec src in-order? names gensyms vals body)))) + (($ <fix> src names gensyms vals body) + (let ((body (loop body))) + (and body + (make-fix src names gensyms vals body)))) + (($ <let-values> src exp + ($ <lambda-case> src2 req opt rest kw inits gensyms body #f)) + (let ((body (loop body))) + (and body + (make-let-values src exp + (make-lambda-case src2 req opt rest kw + inits gensyms body #f))))) + (($ <seq> src head tail) + (let ((tail (loop tail))) + (and tail (make-seq src head tail))))))) + + (define compute-effects + (make-effects-analyzer assigned-lexical?)) + + (define (constant-expression? x) + ;; Return true if X is constant, for the purposes of copying or + ;; elision---i.e., if it is known to have no effects, does not + ;; allocate storage for a mutable object, and does not access + ;; mutable data (like `car' or toplevel references). + (constant? (compute-effects x))) + + (define (prune-bindings ops in-order? body counter ctx build-result) + ;; This helper handles both `let' and `letrec'/`fix'. In the latter + ;; cases we need to make sure that if referenced binding A needs + ;; as-yet-unreferenced binding B, that B is processed for value. + ;; Likewise if C, when processed for effect, needs otherwise + ;; unreferenced D, then D needs to be processed for value too. + ;; + (define (referenced? op) + ;; When we visit lambdas in operator context, we just copy them, + ;; as we will process their body later. However this does have + ;; the problem that any free var referenced by the lambda is not + ;; marked as needing residualization. Here we hack around this + ;; and treat all bindings as referenced if we are in operator + ;; context. + (or (eq? ctx 'operator) + (not (zero? (operand-use-count op))))) + + ;; values := (op ...) + ;; effects := (op ...) + (define (residualize values effects) + ;; Note, values and effects are reversed. + (cond + (in-order? + (let ((values (filter operand-residual-value ops))) + (if (null? values) + body + (build-result (map (compose var-name operand-var) values) + (map operand-sym values) + (map operand-residual-value values) + body)))) + (else + (let ((body + (if (null? effects) + body + (let ((effect-vals (map operand-residual-value effects))) + (list->seq #f (reverse (cons body effect-vals))))))) + (if (null? values) + body + (let ((values (reverse values))) + (build-result (map (compose var-name operand-var) values) + (map operand-sym values) + (map operand-residual-value values) + body))))))) + + ;; old := (bool ...) + ;; values := (op ...) + ;; effects := ((op . value) ...) + (let prune ((old (map referenced? ops)) (values '()) (effects '())) + (let lp ((ops* ops) (values values) (effects effects)) + (cond + ((null? ops*) + (let ((new (map referenced? ops))) + (if (not (equal? new old)) + (prune new values '()) + (residualize values + (map (lambda (op val) + (set-operand-residual-value! op val) + op) + (map car effects) (map cdr effects)))))) + (else + (let ((op (car ops*))) + (cond + ((memq op values) + (lp (cdr ops*) values effects)) + ((operand-residual-value op) + (lp (cdr ops*) (cons op values) effects)) + ((referenced? op) + (set-operand-residual-value! op (visit-operand op counter 'value)) + (lp (cdr ops*) (cons op values) effects)) + (else + (lp (cdr ops*) + values + (let ((effect (visit-operand op counter 'effect))) + (if (void? effect) + effects + (acons op effect effects)))))))))))) + + (define (small-expression? x limit) + (let/ec k + (tree-il-fold + (lambda (x res) ; down + (1+ res)) + (lambda (x res) ; up + (if (< res limit) + res + (k #f))) + 0 x) + #t)) + + (define (extend-env sym op env) + (vhash-consq (operand-sym op) op (vhash-consq sym op env))) + + (let loop ((exp exp) + (env vlist-null) ; vhash of gensym -> <operand> + (counter #f) ; inlined call stack + (ctx 'values)) ; effect, value, values, test, operator, or call + (define (lookup var) + (cond + ((vhash-assq var env) => cdr) + (else (error "unbound var" var)))) + + ;; Find a value referenced a specific number of times. This is a hack + ;; that's used for propagating fresh data structures like rest lists and + ;; prompt tags. Usually we wouldn't copy consed data, but we can do so in + ;; some special cases like `apply' or prompts if we can account + ;; for all of its uses. + ;; + ;; You don't want to use this in general because it introduces a slight + ;; nonlinearity by running peval again (though with a small effort and size + ;; counter). + ;; + (define (find-definition x n-aliases) + (cond + ((lexical-ref? x) + (cond + ((lookup (lexical-ref-gensym x)) + => (lambda (op) + (if (var-set? (operand-var op)) + (values #f #f) + (let ((y (or (operand-residual-value op) + (visit-operand op counter 'value 10 10) + (operand-source op)))) + (cond + ((and (lexical-ref? y) + (= (lexical-refcount (lexical-ref-gensym x)) 1)) + ;; X is a simple alias for Y. Recurse, regardless of + ;; the number of aliases we were expecting. + (find-definition y n-aliases)) + ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) + ;; We found a definition that is aliased the right + ;; number of times. We still recurse in case it is a + ;; lexical. + (values (find-definition y 1) + op)) + (else + ;; We can't account for our aliases. + (values #f #f))))))) + (else + ;; A formal parameter. Can't say anything about that. + (values #f #f)))) + ((= n-aliases 1) + ;; Not a lexical: success, but only if we are looking for an + ;; unaliased value. + (values x #f)) + (else (values #f #f)))) + + (define (visit exp ctx) + (loop exp env counter ctx)) + + (define (for-value exp) (visit exp 'value)) + (define (for-values exp) (visit exp 'values)) + (define (for-test exp) (visit exp 'test)) + (define (for-effect exp) (visit exp 'effect)) + (define (for-call exp) (visit exp 'call)) + (define (for-tail exp) (visit exp ctx)) + + (if counter + (record-effort! counter)) + + (log 'visit ctx (and=> counter effort-counter) + (unparse-tree-il exp)) + + (match exp + (($ <const>) + (case ctx + ((effect) (make-void #f)) + (else exp))) + (($ <void>) + (case ctx + ((test) (make-const #f #t)) + (else exp))) + (($ <lexical-ref> _ _ gensym) + (log 'begin-copy gensym) + (let lp ((op (lookup gensym))) + (cond + ((eq? ctx 'effect) + (log 'lexical-for-effect gensym) + (make-void #f)) + ((operand-alias op) + ;; This is an unassigned operand that simply aliases some + ;; other operand. Recurse to avoid residualizing the leaf + ;; binding. + => lp) + ((eq? ctx 'call) + ;; Don't propagate copies if we are residualizing a call. + (log 'residualize-lexical-call gensym op) + (residualize-lexical op)) + ((var-set? (operand-var op)) + ;; Assigned lexicals don't copy-propagate. + (log 'assigned-var gensym op) + (residualize-lexical op)) + ((not (operand-copyable? op)) + ;; We already know that this operand is not copyable. + (log 'not-copyable gensym op) + (residualize-lexical op)) + ((and=> (operand-constant-value op) + (lambda (x) (or (const? x) (void? x) (primitive-ref? x)))) + ;; A cache hit. + (let ((val (operand-constant-value op))) + (log 'memoized-constant gensym val) + (for-tail val))) + ((visit-operand op counter (if (eq? ctx 'values) 'value ctx) + recursive-effort-limit operand-size-limit) + => + ;; If we end up deciding to residualize this value instead of + ;; copying it, save that residualized value. + (lambda (val) + (cond + ((not (constant-expression? val)) + (log 'not-constant gensym op) + ;; At this point, ctx is operator, test, or value. A + ;; value that is non-constant in one context will be + ;; non-constant in the others, so it's safe to record + ;; that here, and avoid future visits. + (set-operand-copyable?! op #f) + (residualize-lexical op ctx val)) + ((or (const? val) + (void? val) + (primitive-ref? val)) + ;; Always propagate simple values that cannot lead to + ;; code bloat. + (log 'copy-simple gensym val) + ;; It could be this constant is the result of folding. + ;; If that is the case, cache it. This helps loop + ;; unrolling get farther. + (if (or (eq? ctx 'value) (eq? ctx 'values)) + (begin + (log 'memoize-constant gensym val) + (set-operand-constant-value! op val))) + val) + ((= 1 (var-refcount (operand-var op))) + ;; Always propagate values referenced only once. + (log 'copy-single gensym val) + val) + ;; FIXME: do demand-driven size accounting rather than + ;; these heuristics. + ((eq? ctx 'operator) + ;; A pure expression in the operator position. Inline + ;; if it's a lambda that's small enough. + (if (and (lambda? val) + (small-expression? val operator-size-limit)) + (begin + (log 'copy-operator gensym val) + val) + (begin + (log 'too-big-for-operator gensym val) + (residualize-lexical op ctx val)))) + (else + ;; A pure expression, processed for call or for value. + ;; Don't inline lambdas, because they will probably won't + ;; fold because we don't know the operator. + (if (and (small-expression? val value-size-limit) + (not (tree-il-any lambda? val))) + (begin + (log 'copy-value gensym val) + val) + (begin + (log 'too-big-or-has-lambda gensym val) + (residualize-lexical op ctx val))))))) + (else + ;; Visit failed. Either the operand isn't bound, as in + ;; lambda formal parameters, or the copy was aborted. + (log 'unbound-or-aborted gensym op) + (residualize-lexical op))))) + (($ <lexical-set> src name gensym exp) + (let ((op (lookup gensym))) + (if (zero? (var-refcount (operand-var op))) + (let ((exp (for-effect exp))) + (if (void? exp) + exp + (make-seq src exp (make-void #f)))) + (begin + (record-operand-use op) + (make-lexical-set src name (operand-sym op) (for-value exp)))))) + (($ <let> src + (names ... rest) + (gensyms ... rest-sym) + (vals ... ($ <primcall> _ 'list rest-args)) + ($ <primcall> asrc 'apply + (proc args ... + ($ <lexical-ref> _ + (? (cut eq? <> rest)) + (? (lambda (sym) + (and (eq? sym rest-sym) + (= (lexical-refcount sym) 1)))))))) + (let* ((tmps (make-list (length rest-args) 'tmp)) + (tmp-syms (fresh-temporaries tmps))) + (for-tail + (make-let src + (append names tmps) + (append gensyms tmp-syms) + (append vals rest-args) + (make-call + asrc + proc + (append args + (map (cut make-lexical-ref #f <> <>) + tmps tmp-syms))))))) + (($ <let> src names gensyms vals body) + (define (lookup-alias exp) + ;; It's very common for macros to introduce something like: + ;; + ;; ((lambda (x y) ...) x-exp y-exp) + ;; + ;; In that case you might end up trying to inline something like: + ;; + ;; (let ((x x-exp) (y y-exp)) ...) + ;; + ;; But if x-exp is itself a lexical-ref that aliases some much + ;; larger expression, perhaps it will fail to inline due to + ;; size. However we don't want to introduce a useless alias + ;; (in this case, x). So if the RHS of a let expression is a + ;; lexical-ref, we record that expression. If we end up having + ;; to residualize X, then instead we residualize X-EXP, as long + ;; as it isn't assigned. + ;; + (match exp + (($ <lexical-ref> _ _ sym) + (let ((op (lookup sym))) + (and (not (var-set? (operand-var op))) op))) + (_ #f))) + + (let* ((vars (map lookup-var gensyms)) + (new (fresh-gensyms vars)) + (ops (make-bound-operands vars new vals + (lambda (exp counter ctx) + (loop exp env counter ctx)) + (map lookup-alias vals))) + (env (fold extend-env env gensyms ops)) + (body (loop body env counter ctx))) + (match body + (($ <const>) + (for-tail (list->seq src (append vals (list body))))) + (($ <lexical-ref> _ _ (? (lambda (sym) (memq sym new)) sym)) + (let ((pairs (map cons new vals))) + ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) + (for-tail + (list->seq + src + (append (map cdr (alist-delete sym pairs eq?)) + (list (assq-ref pairs sym))))))) + ((and ($ <conditional> src* + ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym) alt) + (? (lambda (_) + (case ctx + ((test effect) + (and (equal? (list sym) new) + (= (lexical-refcount sym) 2))) + (else #f))))) + ;; (let ((x EXP)) (if x x ALT)) -> (if EXP #t ALT) in test context + (make-conditional src* (visit-operand (car ops) counter 'test) + (make-const src* #t) alt)) + (_ + ;; Only include bindings for which lexical references + ;; have been residualized. + (prune-bindings ops #f body counter ctx + (lambda (names gensyms vals body) + (if (null? names) (error "what!" names)) + (make-let src names gensyms vals body))))))) + (($ <letrec> src in-order? names gensyms vals body) + ;; Note the difference from the `let' case: here we use letrec* + ;; so that the `visit' procedure for the new operands closes over + ;; an environment that includes the operands. Also we don't try + ;; to elide aliases, because we can't sensibly reduce something + ;; like (letrec ((a b) (b a)) a). + (letrec* ((visit (lambda (exp counter ctx) + (loop exp env* counter ctx))) + (vars (map lookup-var gensyms)) + (new (fresh-gensyms vars)) + (ops (make-bound-operands vars new vals visit)) + (env* (fold extend-env env gensyms ops)) + (body* (visit body counter ctx))) + (if (and (const? body*) (every constant-expression? vals)) + ;; We may have folded a loop completely, even though there + ;; might be cyclical references between the bound values. + ;; Handle this degenerate case specially. + body* + (prune-bindings ops in-order? body* counter ctx + (lambda (names gensyms vals body) + (make-letrec src in-order? + names gensyms vals body)))))) + (($ <fix> src names gensyms vals body) + (letrec* ((visit (lambda (exp counter ctx) + (loop exp env* counter ctx))) + (vars (map lookup-var gensyms)) + (new (fresh-gensyms vars)) + (ops (make-bound-operands vars new vals visit)) + (env* (fold extend-env env gensyms ops)) + (body* (visit body counter ctx))) + (if (const? body*) + body* + (prune-bindings ops #f body* counter ctx + (lambda (names gensyms vals body) + (make-fix src names gensyms vals body)))))) + (($ <let-values> lv-src producer consumer) + ;; Peval the producer, then try to inline the consumer into + ;; the producer. If that succeeds, peval again. Otherwise + ;; reconstruct the let-values, pevaling the consumer. + (let ((producer (for-values producer))) + (or (match consumer + ((and ($ <lambda-case> src () #f rest #f () (rest-sym) body #f) + (? (lambda _ (singly-valued-expression? producer)))) + (let ((tmp (gensym "tmp "))) + (record-new-temporary! 'tmp tmp 1) + (for-tail + (make-let + src (list 'tmp) (list tmp) (list producer) + (make-let + src (list rest) (list rest-sym) + (list + (make-primcall #f 'list + (list (make-lexical-ref #f 'tmp tmp)))) + body))))) + (($ <lambda-case> src req opt rest #f inits gensyms body #f) + (let* ((nmin (length req)) + (nmax (and (not rest) (+ nmin (if opt (length opt) 0))))) + (cond + ((inline-values lv-src producer nmin nmax consumer) + => for-tail) + (else #f)))) + (_ #f)) + (make-let-values lv-src producer (for-tail consumer))))) + (($ <toplevel-ref> src (? effect-free-primitive? name)) + exp) + (($ <toplevel-ref>) + ;; todo: open private local bindings. + exp) + (($ <module-ref> src module (? effect-free-primitive? name) #f) + (let ((module (false-if-exception + (resolve-module module #:ensure #f)))) + (if (module? module) + (let ((var (module-variable module name))) + (if (eq? var (module-variable the-scm-module name)) + (make-primitive-ref src name) + exp)) + exp))) + (($ <module-ref>) + exp) + (($ <module-set> src mod name public? exp) + (make-module-set src mod name public? (for-value exp))) + (($ <toplevel-define> src name exp) + (make-toplevel-define src name (for-value exp))) + (($ <toplevel-set> src name exp) + (make-toplevel-set src name (for-value exp))) + (($ <primitive-ref>) + (case ctx + ((effect) (make-void #f)) + ((test) (make-const #f #t)) + (else exp))) + (($ <conditional> src condition subsequent alternate) + (define (call-with-failure-thunk exp proc) + (match exp + (($ <call> _ _ ()) (proc exp)) + (($ <primcall> _ _ ()) (proc exp)) + (($ <const>) (proc exp)) + (($ <void>) (proc exp)) + (($ <lexical-ref>) (proc exp)) + (_ + (let ((t (gensym "failure-"))) + (record-new-temporary! 'failure t 2) + (make-let + src (list 'failure) (list t) + (list + (make-lambda + #f '() + (make-lambda-case #f '() #f #f #f '() '() exp #f))) + (proc (make-call #f (make-lexical-ref #f 'failure t) + '()))))))) + (define (simplify-conditional c) + (match c + ;; Swap the arms of (if (not FOO) A B), to simplify. + (($ <conditional> src ($ <primcall> _ 'not (pred)) + subsequent alternate) + (simplify-conditional + (make-conditional src pred alternate subsequent))) + ;; In the following four cases, we try to expose the test to + ;; the conditional. This will let the CPS conversion avoid + ;; reifying boolean literals in some cases. + (($ <conditional> src ($ <let> src* names vars vals body) + subsequent alternate) + (make-let src* names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ <conditional> src + ($ <letrec> src* in-order? names vars vals body) + subsequent alternate) + (make-letrec src* in-order? names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ <conditional> src ($ <fix> src* names vars vals body) + subsequent alternate) + (make-fix src* names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ <conditional> src ($ <seq> src* head tail) + subsequent alternate) + (make-seq src* head + (simplify-conditional + (make-conditional src tail subsequent alternate)))) + ;; Special cases for common tests in the predicates of chains + ;; of if expressions. + (($ <conditional> src + ($ <conditional> src* outer-test inner-test ($ <const> _ #f)) + inner-subsequent + alternate) + (let lp ((alternate alternate)) + (match alternate + ;; Lift a common repeated test out of a chain of if + ;; expressions. + (($ <conditional> _ (? (cut tree-il=? outer-test <>)) + other-subsequent alternate) + (make-conditional + src outer-test + (simplify-conditional + (make-conditional src* inner-test inner-subsequent + other-subsequent)) + alternate)) + ;; Likewise, but punching through any surrounding + ;; failure continuations. + (($ <let> let-src (name) (sym) ((and thunk ($ <lambda>))) body) + (make-let + let-src (list name) (list sym) (list thunk) + (lp body))) + ;; Otherwise, rotate AND tests to expose a simple + ;; condition in the front. Although this may result in + ;; lexically binding failure thunks, the thunks will be + ;; compiled to labels allocation, so there's no actual + ;; code growth. + (_ + (call-with-failure-thunk + alternate + (lambda (failure) + (make-conditional + src outer-test + (simplify-conditional + (make-conditional src* inner-test inner-subsequent failure)) + failure))))))) + (_ c))) + (match (for-test condition) + (($ <const> _ val) + (if val + (for-tail subsequent) + (for-tail alternate))) + (c + (simplify-conditional + (make-conditional src c (for-tail subsequent) + (for-tail alternate)))))) + (($ <primcall> src 'call-with-values + (producer + ($ <lambda> _ _ + (and consumer + ;; No optional or kwargs. + ($ <lambda-case> + _ req #f rest #f () gensyms body #f))))) + (for-tail (make-let-values src (make-call src producer '()) + consumer))) + (($ <primcall> src 'dynamic-wind (w thunk u)) + (for-tail + (with-temporaries + src (list w u) 2 constant-expression? + (match-lambda + ((w u) + (make-seq + src + (make-seq + src + (make-conditional + src + ;; fixme: introduce logic to fold thunk? + (make-primcall src 'thunk? (list u)) + (make-call src w '()) + (make-primcall + src 'throw + (list + (make-const #f 'wrong-type-arg) + (make-const #f "dynamic-wind") + (make-const #f "Wrong type (expecting thunk): ~S") + (make-primcall #f 'list (list u)) + (make-primcall #f 'list (list u))))) + (make-primcall src 'wind (list w u))) + (make-begin0 src + (make-call src thunk '()) + (make-seq src + (make-primcall src 'unwind '()) + (make-call src u '()))))))))) + + (($ <primcall> src 'with-fluid* (f v thunk)) + (for-tail + (with-temporaries + src (list f v thunk) 1 constant-expression? + (match-lambda + ((f v thunk) + (make-seq src + (make-primcall src 'push-fluid (list f v)) + (make-begin0 src + (make-call src thunk '()) + (make-primcall src 'pop-fluid '())))))))) + + (($ <primcall> src 'with-dynamic-state (state thunk)) + (for-tail + (with-temporaries + src (list state thunk) 1 constant-expression? + (match-lambda + ((state thunk) + (make-seq src + (make-primcall src 'push-dynamic-state (list state)) + (make-begin0 src + (make-call src thunk '()) + (make-primcall src 'pop-dynamic-state + '())))))))) + + (($ <primcall> src 'values exps) + (cond + ((null? exps) + (if (eq? ctx 'effect) + (make-void #f) + exp)) + (else + (let ((vals (map for-value exps))) + (if (and (case ctx + ((value test effect) #t) + (else (null? (cdr vals)))) + (every singly-valued-expression? vals)) + (for-tail (list->seq src (append (cdr vals) (list (car vals))))) + (make-primcall src 'values vals)))))) + + (($ <primcall> src 'apply (proc args ... tail)) + (let lp ((tail* (find-definition tail 1)) (speculative? #t)) + (define (copyable? x) + ;; Inlining a result from find-definition effectively copies it, + ;; relying on the let-pruning to remove its original binding. We + ;; shouldn't copy non-constant expressions. + (or (not speculative?) (constant-expression? x))) + (match tail* + (($ <const> _ (args* ...)) + (let ((args* (map (cut make-const #f <>) args*))) + (for-tail (make-call src proc (append args args*))))) + (($ <primcall> _ 'cons + ((and head (? copyable?)) (and tail (? copyable?)))) + (for-tail (make-primcall src 'apply + (cons proc + (append args (list head tail)))))) + (($ <primcall> _ 'list + (and args* ((? copyable?) ...))) + (for-tail (make-call src proc (append args args*)))) + (tail* + (if speculative? + (lp (for-value tail) #f) + (let ((args (append (map for-value args) (list tail*)))) + (make-primcall src 'apply + (cons (for-value proc) args)))))))) + + (($ <primcall> src (? constructor-primitive? name) args) + (cond + ((and (memq ctx '(effect test)) + (match (cons name args) + ((or ('cons _ _) + ('list . _) + ('vector . _) + ('make-prompt-tag) + ('make-prompt-tag ($ <const> _ (? string?)))) + #t) + (_ #f))) + ;; Some expressions can be folded without visiting the + ;; arguments for value. + (let ((res (if (eq? ctx 'effect) + (make-void #f) + (make-const #f #t)))) + (for-tail (list->seq src (append args (list res)))))) + (else + (match (cons name (map for-value args)) + (('cons x ($ <const> _ (? (cut eq? <> '())))) + (make-primcall src 'list (list x))) + (('cons x ($ <primcall> _ 'list elts)) + (make-primcall src 'list (cons x elts))) + (('list) + (make-const src '())) + (('vector) + (make-const src '#())) + ((name . args) + (make-primcall src name args)))))) + + (($ <primcall> src 'thunk? (proc)) + (case ctx + ((effect) + (for-tail (make-seq src proc (make-void src)))) + (else + (match (for-value proc) + (($ <lambda> _ _ ($ <lambda-case> _ req)) + (for-tail (make-const src (null? req)))) + (proc + (match (find-definition proc 2) + (($ <lambda> _ _ ($ <lambda-case> _ req)) + (for-tail (make-const src (null? req)))) + (_ + (make-primcall src 'thunk? (list proc))))))))) + + (($ <primcall> src name args) + (match (cons name (map for-value args)) + ;; FIXME: these for-tail recursions could take place outside + ;; an effort counter. + (('car ($ <primcall> src 'cons (head tail))) + (for-tail (make-seq src tail head))) + (('cdr ($ <primcall> src 'cons (head tail))) + (for-tail (make-seq src head tail))) + (('car ($ <primcall> src 'list (head . tail))) + (for-tail (list->seq src (append tail (list head))))) + (('cdr ($ <primcall> src 'list (head . tail))) + (for-tail (make-seq src head (make-primcall #f 'list tail)))) + + (('car ($ <const> src (head . tail))) + (for-tail (make-const src head))) + (('cdr ($ <const> src (head . tail))) + (for-tail (make-const src tail))) + (((or 'memq 'memv) k ($ <const> _ (elts ...))) + ;; FIXME: factor + (case ctx + ((effect) + (for-tail + (make-seq src k (make-void #f)))) + ((test) + (cond + ((const? k) + ;; A shortcut. The `else' case would handle it, but + ;; this way is faster. + (let ((member (case name ((memq) memq) ((memv) memv)))) + (make-const #f (and (member (const-exp k) elts) #t)))) + ((null? elts) + (for-tail + (make-seq src k (make-const #f #f)))) + (else + (let ((t (gensym "t ")) + (eq (if (eq? name 'memq) 'eq? 'eqv?))) + (record-new-temporary! 't t (length elts)) + (for-tail + (make-let + src (list 't) (list t) (list k) + (let lp ((elts elts)) + (define test + (make-primcall #f eq + (list (make-lexical-ref #f 't t) + (make-const #f (car elts))))) + (if (null? (cdr elts)) + test + (make-conditional src test + (make-const #f #t) + (lp (cdr elts))))))))))) + (else + (cond + ((const? k) + (let ((member (case name ((memq) memq) ((memv) memv)))) + (make-const #f (member (const-exp k) elts)))) + ((null? elts) + (for-tail (make-seq src k (make-const #f #f)))) + (else + (make-primcall src name (list k (make-const #f elts)))))))) + (((? equality-primitive?) + ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym)) + (for-tail (make-const #f #t))) + + (('logbit? ($ <const> src2 + (? (lambda (bit) + (and (exact-integer? bit) + (<= 0 bit (logcount most-positive-fixnum)))) + bit)) + val) + (for-tail + (make-primcall src 'logtest + (list (make-const src2 (ash 1 bit)) val)))) + + (('logtest a b) + (for-tail + (make-primcall + src + 'not + (list + (make-primcall src 'eq? + (list (make-primcall src 'logand (list a b)) + (make-const src 0))))))) + + (((? effect-free-primitive?) . args) + (fold-constants src name args ctx)) + + ((name . args) + (make-primcall src name args)))) + + (($ <call> src orig-proc orig-args) + ;; todo: augment the global env with specialized functions + (let revisit-proc ((proc (visit orig-proc 'operator))) + (match proc + (($ <primitive-ref> _ name) + (for-tail + (expand-primcall (make-primcall src name orig-args)))) + (($ <lambda> _ _ + ($ <lambda-case> _ req opt rest #f inits gensyms body #f)) + ;; Simple case: no keyword arguments. + ;; todo: handle the more complex cases + (let* ((nargs (length orig-args)) + (nreq (length req)) + (opt (or opt '())) + (rest (if rest (list rest) '())) + (nopt (length opt)) + (key (source-expression proc))) + (define (singly-referenced-lambda? orig-proc) + (match orig-proc + (($ <lambda>) #t) + (($ <lexical-ref> _ _ sym) + (and (not (assigned-lexical? sym)) + (= (lexical-refcount sym) 1) + (singly-referenced-lambda? + (operand-source (lookup sym))))) + (_ #f))) + (define (inlined-call) + (let ((req-vals (list-head orig-args nreq)) + (opt-vals (let lp ((args (drop orig-args nreq)) + (inits inits) + (out '())) + (match inits + (() (reverse out)) + ((init . inits) + (match args + (() + (lp '() inits (cons init out))) + ((arg . args) + (lp args inits (cons arg out)))))))) + (rest-vals (cond + ((> nargs (+ nreq nopt)) + (list (make-primcall + #f 'list + (drop orig-args (+ nreq nopt))))) + ((null? rest) '()) + (else (list (make-const #f '())))))) + (if (>= nargs (+ nreq nopt)) + (make-let src + (append req opt rest) + gensyms + (append req-vals opt-vals rest-vals) + body) + ;; The default initializers of optional arguments + ;; may refer to earlier arguments, so in the general + ;; case we must expand into a series of nested let + ;; expressions. + ;; + ;; In the generated code, the outermost let + ;; expression will bind all required arguments, as + ;; well as the empty rest argument, if any. Each + ;; optional argument will be bound within an inner + ;; let. + (make-let src + (append req rest) + (append (list-head gensyms nreq) + (last-pair gensyms)) + (append req-vals rest-vals) + (fold-right (lambda (var gensym val body) + (make-let src + (list var) + (list gensym) + (list val) + body)) + body + opt + (list-head (drop gensyms nreq) nopt) + opt-vals))))) + + (cond + ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) + ;; An error, or effecting arguments. + (make-call src (for-call orig-proc) (map for-value orig-args))) + ((or (and=> (find-counter key counter) counter-recursive?) + (singly-referenced-lambda? orig-proc)) + ;; A recursive call, or a lambda in the operator + ;; position of the source expression. Process again in + ;; tail context. + ;; + ;; In the recursive case, mark intervening counters as + ;; recursive, so we can handle a toplevel counter that + ;; recurses mutually with some other procedure. + ;; Otherwise, the next time we see the other procedure, + ;; the effort limit would be clamped to 100. + ;; + (let ((found (find-counter key counter))) + (if (and found (counter-recursive? found)) + (let lp ((counter counter)) + (if (not (eq? counter found)) + (begin + (set-counter-recursive?! counter #t) + (lp (counter-prev counter))))))) + + (log 'inline-recurse key) + (loop (inlined-call) env counter ctx)) + (else + ;; An integration at the top-level, the first + ;; recursion of a recursive procedure, or a nested + ;; integration of a procedure that hasn't been seen + ;; yet. + (log 'inline-begin exp) + (let/ec k + (define (abort) + (log 'inline-abort exp) + (k (make-call src (for-call orig-proc) + (map for-value orig-args)))) + (define new-counter + (cond + ;; These first two cases will transfer effort + ;; from the current counter into the new + ;; counter. + ((find-counter key counter) + => (lambda (prev) + (make-recursive-counter recursive-effort-limit + operand-size-limit + prev counter))) + (counter + (make-nested-counter abort key counter)) + ;; This case opens a new account, effectively + ;; printing money. It should only do so once + ;; for each call site in the source program. + (else + (make-top-counter effort-limit operand-size-limit + abort key)))) + (define result + (loop (inlined-call) env new-counter ctx)) + + (if counter + ;; The nested inlining attempt succeeded. + ;; Deposit the unspent effort and size back + ;; into the current counter. + (transfer! new-counter counter)) + + (log 'inline-end result exp) + result))))) + (($ <let> _ _ _ vals _) + ;; Attempt to inline `let' in the operator position. + ;; + ;; We have to re-visit the proc in value mode, since the + ;; `let' bindings might have been introduced or renamed, + ;; whereas the lambda (if any) in operator position has not + ;; been renamed. + (if (or (and-map constant-expression? vals) + (and-map constant-expression? orig-args)) + ;; The arguments and the let-bound values commute. + (match (for-value orig-proc) + (($ <let> lsrc names syms vals body) + (log 'inline-let orig-proc) + (for-tail + (make-let lsrc names syms vals + (make-call src body orig-args)))) + ;; It's possible for a `let' to go away after the + ;; visit due to the fact that visiting a procedure in + ;; value context will prune unused bindings, whereas + ;; visiting in operator mode can't because it doesn't + ;; traverse through lambdas. In that case re-visit + ;; the procedure. + (proc (revisit-proc proc))) + (make-call src (for-call orig-proc) + (map for-value orig-args)))) + (_ + (make-call src (for-call orig-proc) (map for-value orig-args)))))) + (($ <lambda> src meta body) + (case ctx + ((effect) (make-void #f)) + ((test) (make-const #f #t)) + ((operator) exp) + (else (record-source-expression! + exp + (make-lambda src meta (and body (for-values body))))))) + (($ <lambda-case> src req opt rest kw inits gensyms body alt) + (define (lift-applied-lambda body gensyms) + (and (not opt) rest (not kw) + (match body + (($ <primcall> _ 'apply + (($ <lambda> _ _ (and lcase ($ <lambda-case> _ req1))) + ($ <lexical-ref> _ _ sym) + ...)) + (and (equal? sym gensyms) + (not (lambda-case-alternate lcase)) + (<= (length req) (length req1)) + (every (lambda (s) + (= (lexical-refcount s) 1)) + sym) + lcase)) + (_ #f)))) + (let* ((vars (map lookup-var gensyms)) + (new (fresh-gensyms vars)) + (env (fold extend-env env gensyms + (make-unbound-operands vars new))) + (new-sym (lambda (old) + (operand-sym (cdr (vhash-assq old env))))) + (body (loop body env counter ctx))) + (or + ;; (lambda args (apply (lambda ...) args)) => (lambda ...) + (lift-applied-lambda body new) + (make-lambda-case src req opt rest + (match kw + ((aok? (kw name old) ...) + (cons aok? (map list kw name (map new-sym old)))) + (_ #f)) + (map (cut loop <> env counter 'value) inits) + new + body + (and alt (for-tail alt)))))) + (($ <seq> src head tail) + (let ((head (for-effect head)) + (tail (for-tail tail))) + (if (void? head) + tail + (make-seq src + (if (and (seq? head) + (void? (seq-tail head))) + (seq-head head) + head) + tail)))) + (($ <prompt> src escape-only? tag body handler) + (define (make-prompt-tag? x) + (match x + (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?)))) + #t) + (_ #f))) + + (let ((tag (for-value tag)) + (body (if escape-only? (for-tail body) (for-value body)))) + (cond + ((find-definition tag 1) + (lambda (val op) + (make-prompt-tag? val)) + => (lambda (val op) + ;; There is no way that an <abort> could know the tag + ;; for this <prompt>, so we can elide the <prompt> + ;; entirely. + (unrecord-operand-uses op 1) + (for-tail (if escape-only? body (make-call src body '()))))) + (else + (let ((handler (for-value handler))) + (define (escape-only-handler? handler) + (match handler + (($ <lambda> _ _ + ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f)) + (not (tree-il-any + (match-lambda + (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t) + (_ #f)) + body))) + (else #f))) + (if (and (not escape-only?) (escape-only-handler? handler)) + ;; Prompt transitioning to escape-only; transition body + ;; to be an expression. + (for-tail + (make-prompt src #t tag (make-call #f body '()) handler)) + (make-prompt src escape-only? tag body handler))))))) + + (($ <abort> src tag args tail) + (make-abort src (for-value tag) (map for-value args) + (for-value tail)))))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm new file mode 100644 index 000000000..21124bbd4 --- /dev/null +++ b/module/language/tree-il/primitives.scm @@ -0,0 +1,684 @@ +;;; open-coding primitive procedures + +;; Copyright (C) 2009-2015, 2017-2018 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 tree-il primitives) + #:use-module (system base pmatch) + #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module (rnrs bytevectors) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:use-module (srfi srfi-4) + #:use-module (srfi srfi-16) + #:export (resolve-primitives add-interesting-primitive! + expand-primcall expand-primitives + effect-free-primitive? effect+exception-free-primitive? + constructor-primitive? + singly-valued-primitive? equality-primitive? + bailout-primitive? + negate-primitive)) + +;; When adding to this, be sure to update *multiply-valued-primitives* +;; if appropriate. +(define *interesting-primitive-names* + '(apply + call-with-values + call-with-current-continuation + call/cc + dynamic-wind + values + eq? eqv? equal? + memq memv + = < > <= >= zero? positive? negative? + + * - / 1- 1+ quotient remainder modulo + ash logand logior logxor lognot logtest logbit? + sqrt abs + not + pair? null? list? symbol? vector? string? struct? number? char? nil? + bytevector? keyword? bitvector? + + symbol->string string->symbol + + procedure? thunk? + + complex? real? rational? inf? nan? integer? exact? inexact? even? odd? + exact-integer? + + char<? char<=? char>=? char>? + + integer->char char->integer number->string string->number + + acons cons cons* + + list vector + + car cdr + set-car! set-cdr! + + caar cadr cdar cddr + + caaar caadr cadar caddr cdaar cdadr cddar cdddr + + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + + length + + make-vector vector-length vector-ref vector-set! + variable? variable-ref variable-set! + variable-bound? + + current-module define! + + current-thread fluid-ref fluid-set! with-fluid* with-dynamic-state + + call-with-prompt + abort-to-prompt* abort-to-prompt + make-prompt-tag + + throw error scm-error + + string-length string-ref string-set! + + make-struct/simple struct-vtable struct-ref struct-set! + + bytevector-length + + bytevector-u8-ref bytevector-u8-set! + bytevector-s8-ref bytevector-s8-set! + u8vector-ref u8vector-set! s8vector-ref s8vector-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! + u16vector-ref u16vector-set! s16vector-ref s16vector-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! + u32vector-ref u32vector-set! s32vector-ref s32vector-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! + u64vector-ref u64vector-set! s64vector-ref s64vector-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! + f32vector-ref f32vector-set! f64vector-ref f64vector-set!)) + +(define (add-interesting-primitive! name) + (hashq-set! *interesting-primitive-vars* + (or (module-variable (current-module) name) + (error "unbound interesting primitive" name)) + name)) + +(define *interesting-primitive-vars* (make-hash-table)) + +(for-each add-interesting-primitive! *interesting-primitive-names*) + +(define *primitive-constructors* + ;; Primitives that return a fresh object. + '(acons cons cons* list vector make-vector + make-struct/simple + make-prompt-tag)) + +(define *primitive-accessors* + ;; Primitives that are pure, but whose result depends on the mutable + ;; memory pointed to by their operands. + ;; + ;; Note: if you add an accessor here, be sure to add a corresponding + ;; case in (language tree-il effects)! + '(vector-ref + car cdr + memq memv + struct-ref + string-ref + bytevector-u8-ref bytevector-s8-ref + bytevector-u16-ref bytevector-u16-native-ref + bytevector-s16-ref bytevector-s16-native-ref + bytevector-u32-ref bytevector-u32-native-ref + bytevector-s32-ref bytevector-s32-native-ref + bytevector-u64-ref bytevector-u64-native-ref + bytevector-s64-ref bytevector-s64-native-ref + bytevector-ieee-single-ref bytevector-ieee-single-native-ref + bytevector-ieee-double-ref bytevector-ieee-double-native-ref)) + +(define *effect-free-primitives* + `(values + eq? eqv? equal? + = < > <= >= zero? positive? negative? + ash logand logior logxor lognot logtest logbit? + + * - / 1- 1+ sqrt abs quotient remainder modulo + not + pair? null? nil? list? + symbol? variable? vector? struct? string? number? char? + bytevector? keyword? bitvector? atomic-box? + complex? real? rational? inf? nan? integer? exact? inexact? even? odd? + exact-integer? + char<? char<=? char>=? char>? + integer->char char->integer number->string string->number + symbol->string string->symbol + struct-vtable + length string-length vector-length bytevector-length + ;; These all should get expanded out by expand-primitives. + caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + ,@*primitive-constructors* + ,@*primitive-accessors*)) + +;; Like *effect-free-primitives* above, but further restricted in that they +;; cannot raise exceptions. +(define *effect+exception-free-primitives* + '(values + eq? eqv? equal? + not + pair? null? nil? list? + symbol? variable? vector? struct? string? number? char? + exact-integer? + bytevector? keyword? bitvector? + procedure? thunk? atomic-box? + acons cons cons* list vector)) + +;; Primitives that don't always return one value. +(define *multiply-valued-primitives* + '(apply + call-with-values + call-with-current-continuation + call/cc + dynamic-wind + values + call-with-prompt + @abort abort-to-prompt)) + +;; Procedures that cause a nonlocal, non-resumable abort. +(define *bailout-primitives* + '(throw error scm-error)) + +;; Negatable predicates. +(define *negatable-primitives* + '((even? . odd?) + (exact? . inexact?) + ;; (< <= > >=) are not negatable because of NaNs. + (char<? . char>=?) + (char>? . char<=?))) + +(define *equality-primitives* + '(eq? eqv? equal?)) + +(define *effect-free-primitive-table* (make-hash-table)) +(define *effect+exceptions-free-primitive-table* (make-hash-table)) +(define *equality-primitive-table* (make-hash-table)) +(define *multiply-valued-primitive-table* (make-hash-table)) +(define *bailout-primitive-table* (make-hash-table)) +(define *negatable-primitive-table* (make-hash-table)) + +(for-each (lambda (x) + (hashq-set! *effect-free-primitive-table* x #t)) + *effect-free-primitives*) +(for-each (lambda (x) + (hashq-set! *effect+exceptions-free-primitive-table* x #t)) + *effect+exception-free-primitives*) +(for-each (lambda (x) + (hashq-set! *equality-primitive-table* x #t)) + *equality-primitives*) +(for-each (lambda (x) + (hashq-set! *multiply-valued-primitive-table* x #t)) + *multiply-valued-primitives*) +(for-each (lambda (x) + (hashq-set! *bailout-primitive-table* x #t)) + *bailout-primitives*) +(for-each (lambda (x) + (hashq-set! *negatable-primitive-table* (car x) (cdr x)) + (hashq-set! *negatable-primitive-table* (cdr x) (car x))) + *negatable-primitives*) + +(define (constructor-primitive? prim) + (memq prim *primitive-constructors*)) +(define (effect-free-primitive? prim) + (hashq-ref *effect-free-primitive-table* prim)) +(define (effect+exception-free-primitive? prim) + (hashq-ref *effect+exceptions-free-primitive-table* prim)) +(define (equality-primitive? prim) + (hashq-ref *equality-primitive-table* prim)) +(define (singly-valued-primitive? prim) + (not (hashq-ref *multiply-valued-primitive-table* prim))) +(define (bailout-primitive? prim) + (hashq-ref *bailout-primitive-table* prim)) +(define (negate-primitive prim) + (hashq-ref *negatable-primitive-table* prim)) + +(define (resolve-primitives x mod) + (define local-definitions + (make-hash-table)) + + ;; Assume that any definitions with primitive names in the root module + ;; have the same semantics as the primitives. + (unless (eq? mod the-root-module) + (let collect-local-definitions ((x x)) + (record-case x + ((<toplevel-define> name) + (hashq-set! local-definitions name #t)) + ((<seq> head tail) + (collect-local-definitions head) + (collect-local-definitions tail)) + (else #f)))) + + (post-order + (lambda (x) + (or + (record-case x + ((<toplevel-ref> src name) + (and=> (and (not (hashq-ref local-definitions name)) + (hashq-ref *interesting-primitive-vars* + (module-variable mod name))) + (lambda (name) (make-primitive-ref src name)))) + ((<module-ref> src mod name public?) + ;; for the moment, we're disabling primitive resolution for + ;; public refs because resolve-interface can raise errors. + (and=> (and=> (resolve-module mod) + (if public? + module-public-interface + identity)) + (lambda (m) + (and=> (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (lambda (name) + (make-primitive-ref src name)))))) + ((<call> src proc args) + (and (primitive-ref? proc) + (make-primcall src (primitive-ref-name proc) args))) + (else #f)) + x)) + x)) + + + +(define *primitive-expand-table* (make-hash-table)) + +(define (expand-primcall x) + (record-case x + ((<primcall> src name args) + (let ((expand (hashq-ref *primitive-expand-table* name))) + (or (and expand (apply expand src args)) + x))) + (else x))) + +(define (expand-primitives x) + (pre-order expand-primcall x)) + +;;; I actually did spend about 10 minutes trying to redo this with +;;; syntax-rules. Patches appreciated. +;;; +(define-macro (define-primitive-expander sym . clauses) + (define (inline-args args) + (let lp ((in args) (out '())) + (cond ((null? in) `(list ,@(reverse out))) + ((symbol? in) `(cons* ,@(reverse out) ,in)) + ((pair? (car in)) + (lp (cdr in) + (cons (if (eq? (caar in) 'quote) + `(make-const src ,@(cdar in)) + `(make-primcall src ',(caar in) + ,(inline-args (cdar in)))) + out))) + ((symbol? (car in)) + ;; assume it's locally bound + (lp (cdr in) (cons (car in) out))) + ((self-evaluating? (car in)) + (lp (cdr in) (cons `(make-const src ,(car in)) out))) + (else + (error "what what" (car in)))))) + (define (consequent exp) + (cond + ((pair? exp) + (pmatch exp + ((if ,test ,then ,else) + `(if ,test + ,(consequent then) + ,(consequent else))) + (else + `(make-primcall src ',(car exp) + ,(inline-args (cdr exp)))))) + ((symbol? exp) + ;; assume locally bound + exp) + ((number? exp) + `(make-const src ,exp)) + ((not exp) + ;; failed match + #f) + (else (error "bad consequent yall" exp)))) + `(hashq-set! *primitive-expand-table* + ',sym + (match-lambda* + ,@(let lp ((in clauses) (out '())) + (if (null? in) + (reverse (cons '(_ #f) out)) + (lp (cddr in) + (cons `((src . ,(car in)) + ,(consequent (cadr in))) + out))))))) + +;; Oddly, scm-error is just an explicitly 5-argument `throw'. Weird. +(define-primitive-expander scm-error (key who message args data) + (throw key who message args data)) + +(define (escape-format-directives str) + (string-join (string-split str #\~) "~~")) + +(hashq-set! + *primitive-expand-table* + 'error + (match-lambda* + ((src) + (make-primcall src 'throw + (list (make-const src 'misc-error) + (make-const src #f) + (make-const src "?") + (make-const src #f) + (make-const src #f)))) + ((src ($ <const> src2 (? string? message)) . args) + (let ((msg (string-join (cons (escape-format-directives message) + (make-list (length args) "~S"))))) + (make-primcall src 'throw + (list (make-const src 'misc-error) + (make-const src #f) + (make-const src2 msg) + (make-primcall src 'list args) + (make-const src #f))))) + ((src message . args) + (let ((msg (string-join (cons "~A" (make-list (length args) "~S"))))) + (make-primcall src 'throw + (list (make-const src 'misc-error) + (make-const src #f) + (make-const src msg) + (make-const src "?") + (make-primcall src 'list (cons message args)) + (make-const src #f))))))) + +(define-primitive-expander zero? (x) + (= x 0)) + +(define-primitive-expander positive? (x) + (> x 0)) + +(define-primitive-expander negative? (x) + (< x 0)) + +;; FIXME: All the code that uses `const?' is redundant with `peval'. + +(define-primitive-expander 1+ (x) + (+ x 1)) + +(define-primitive-expander 1- (x) + (- x 1)) + +(define-primitive-expander + + () 0 + (x) (values x) + (x y) (+ x y) + (x y z ... last) (+ (+ x y . z) last)) + +(define-primitive-expander * + () 1 + (x) (values x) + (x y z ... last) (* (* x y . z) last)) + +(define-primitive-expander - + (x) (- 0 x) + (x y) (- x y) + (x y z ... last) (- (- x y . z) last)) + +(define-primitive-expander / + (x) (/ 1 x) + (x y z ... last) (/ (/ x y . z) last)) + +(define-primitive-expander logior + () 0 + (x) (logior x 0) + (x y) (logior x y) + (x y z ... last) (logior (logior x y . z) last)) + +(define-primitive-expander logand + () -1 + (x) (logand x -1) + (x y) (logand x y) + (x y z ... last) (logand (logand x y . z) last)) + +(hashq-set! + *primitive-expand-table* + 'make-vector + (match-lambda* + ((src len) + (make-primcall src 'make-vector (list len (make-const src *unspecified*)))) + ((src len init) + (make-primcall src 'make-vector (list len init))) + ((src . args) + (make-call src (make-primitive-ref src 'make-vector) args)))) + +(define-primitive-expander caar (x) (car (car x))) +(define-primitive-expander cadr (x) (car (cdr x))) +(define-primitive-expander cdar (x) (cdr (car x))) +(define-primitive-expander cddr (x) (cdr (cdr x))) +(define-primitive-expander caaar (x) (car (car (car x)))) +(define-primitive-expander caadr (x) (car (car (cdr x)))) +(define-primitive-expander cadar (x) (car (cdr (car x)))) +(define-primitive-expander caddr (x) (car (cdr (cdr x)))) +(define-primitive-expander cdaar (x) (cdr (car (car x)))) +(define-primitive-expander cdadr (x) (cdr (car (cdr x)))) +(define-primitive-expander cddar (x) (cdr (cdr (car x)))) +(define-primitive-expander cdddr (x) (cdr (cdr (cdr x)))) +(define-primitive-expander caaaar (x) (car (car (car (car x))))) +(define-primitive-expander caaadr (x) (car (car (car (cdr x))))) +(define-primitive-expander caadar (x) (car (car (cdr (car x))))) +(define-primitive-expander caaddr (x) (car (car (cdr (cdr x))))) +(define-primitive-expander cadaar (x) (car (cdr (car (car x))))) +(define-primitive-expander cadadr (x) (car (cdr (car (cdr x))))) +(define-primitive-expander caddar (x) (car (cdr (cdr (car x))))) +(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x))))) +(define-primitive-expander cdaaar (x) (cdr (car (car (car x))))) +(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x))))) +(define-primitive-expander cdadar (x) (cdr (car (cdr (car x))))) +(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x))))) +(define-primitive-expander cddaar (x) (cdr (cdr (car (car x))))) +(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x))))) +(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x))))) +(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) + +(define-primitive-expander cons* + (x) (values x) + (x y) (cons x y) + (x y . rest) (cons x (cons* y . rest))) + +(define-primitive-expander acons (x y z) + (cons (cons x y) z)) + +(define-primitive-expander call/cc (proc) + (call-with-current-continuation proc)) + +(define-primitive-expander u8vector-ref (vec i) + (bytevector-u8-ref vec i)) +(define-primitive-expander u8vector-set! (vec i x) + (bytevector-u8-set! vec i x)) +(define-primitive-expander s8vector-ref (vec i) + (bytevector-s8-ref vec i)) +(define-primitive-expander s8vector-set! (vec i x) + (bytevector-s8-set! vec i x)) + +(define-primitive-expander u16vector-ref (vec i) + (bytevector-u16-native-ref vec (* i 2))) +(define-primitive-expander u16vector-set! (vec i x) + (bytevector-u16-native-set! vec (* i 2) x)) +(define-primitive-expander s16vector-ref (vec i) + (bytevector-s16-native-ref vec (* i 2))) +(define-primitive-expander s16vector-set! (vec i x) + (bytevector-s16-native-set! vec (* i 2) x)) + +(define-primitive-expander u32vector-ref (vec i) + (bytevector-u32-native-ref vec (* i 4))) +(define-primitive-expander u32vector-set! (vec i x) + (bytevector-u32-native-set! vec (* i 4) x)) +(define-primitive-expander s32vector-ref (vec i) + (bytevector-s32-native-ref vec (* i 4))) +(define-primitive-expander s32vector-set! (vec i x) + (bytevector-s32-native-set! vec (* i 4) x)) + +(define-primitive-expander u64vector-ref (vec i) + (bytevector-u64-native-ref vec (* i 8))) +(define-primitive-expander u64vector-set! (vec i x) + (bytevector-u64-native-set! vec (* i 8) x)) +(define-primitive-expander s64vector-ref (vec i) + (bytevector-s64-native-ref vec (* i 8))) +(define-primitive-expander s64vector-set! (vec i x) + (bytevector-s64-native-set! vec (* i 8) x)) + +(define-primitive-expander f32vector-ref (vec i) + (bytevector-ieee-single-native-ref vec (* i 4))) +(define-primitive-expander f32vector-set! (vec i x) + (bytevector-ieee-single-native-set! vec (* i 4) x)) +(define-primitive-expander f32vector-ref (vec i) + (bytevector-ieee-single-native-ref vec (* i 4))) +(define-primitive-expander f32vector-set! (vec i x) + (bytevector-ieee-single-native-set! vec (* i 4) x)) + +(define-primitive-expander f64vector-ref (vec i) + (bytevector-ieee-double-native-ref vec (* i 8))) +(define-primitive-expander f64vector-set! (vec i x) + (bytevector-ieee-double-native-set! vec (* i 8) x)) +(define-primitive-expander f64vector-ref (vec i) + (bytevector-ieee-double-native-ref vec (* i 8))) +(define-primitive-expander f64vector-set! (vec i x) + (bytevector-ieee-double-native-set! vec (* i 8) x)) + +(define (chained-comparison-expander prim-name) + (case-lambda + ((src) (make-const src #t)) + ((src a) #f) + ((src a b) #f) + ((src a b . rest) + (let* ((b-sym (gensym "b")) + (b* (make-lexical-ref src 'b b-sym))) + (make-let src + '(b) + (list b-sym) + (list b) + (make-conditional src + (make-primcall src prim-name (list a b*)) + (make-primcall src prim-name (cons b* rest)) + (make-const src #f))))))) + +(for-each (lambda (prim-name) + (hashq-set! *primitive-expand-table* prim-name + (chained-comparison-expander prim-name))) + '(< > <= >= =)) + +(define (character-comparison-expander char< <) + (lambda (src . args) + (expand-primcall + (make-primcall src < + (map (lambda (arg) + (make-primcall src 'char->integer (list arg))) + args))))) + +(for-each (match-lambda + ((char< . <) + (hashq-set! *primitive-expand-table* char< + (character-comparison-expander char< <)))) + '((char<? . <) + (char>? . >) + (char<=? . <=) + (char>=? . >=) + (char=? . =))) + +;; Appropriate for use with either 'eqv?' or 'equal?'. +(define (maybe-simplify-to-eq prim) + (case-lambda + ((src) (make-const src #t)) + ((src a) (make-const src #t)) + ((src a b) + ;; Simplify cases where either A or B is constant. + (define (maybe-simplify a b) + (and (const? a) + (let ((v (const-exp a))) + (and (or (memq v '(#f #t () #nil)) + (symbol? v) + (and (integer? v) + (exact? v) + (<= v most-positive-fixnum) + (>= v most-negative-fixnum))) + (make-primcall src 'eq? (list a b)))))) + (or (maybe-simplify a b) (maybe-simplify b a))) + ((src a b . rest) + (make-conditional src (make-primcall src prim (list a b)) + (make-primcall src prim (cons b rest)) + (make-const src #f))) + (else #f))) + +(hashq-set! *primitive-expand-table* 'eqv? (maybe-simplify-to-eq 'eqv?)) +(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?)) + +(define (expand-chained-comparisons prim) + (case-lambda + ((src) (make-const src #t)) + ((src a) + ;; (< x) -> (begin (< x 0) #t). Residualizes side-effects from x + ;; and, for numeric comparisons, checks that x is a number. + (make-seq src + (make-primcall src prim (list a (make-const src 0))) + (make-const src #t))) + ((src a b) #f) + ((src a b . rest) + (make-conditional src (make-primcall src prim (list a b)) + (make-primcall src prim (cons b rest)) + (make-const src #f))) + (else #f))) + +(for-each (lambda (prim) + (hashq-set! *primitive-expand-table* prim + (expand-chained-comparisons prim))) + '(< <= = >= > eq?)) + +(hashq-set! *primitive-expand-table* + 'call-with-prompt + (case-lambda + ((src tag thunk handler) + (make-prompt src #f tag thunk handler)) + (else #f))) + +(hashq-set! *primitive-expand-table* + 'abort-to-prompt* + (case-lambda + ((src tag tail-args) + (make-abort src tag '() tail-args)) + (else #f))) +(hashq-set! *primitive-expand-table* + 'abort-to-prompt + (case-lambda + ((src tag . args) + (make-abort src tag args (make-const #f '()))) + (else #f))) diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm new file mode 100644 index 000000000..10c20a010 --- /dev/null +++ b/module/language/tree-il/spec.scm @@ -0,0 +1,46 @@ +;;; Tree Intermediate Language + +;; 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 +;;;; 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 tree-il spec) + #:use-module (system base language) + #:use-module (system base pmatch) + #:use-module (language tree-il) + #:use-module (language tree-il compile-cps) + #:export (tree-il)) + +(define (write-tree-il exp . port) + (apply write (unparse-tree-il exp) port)) + +(define (join exps env) + (pmatch exps + (() (make-void #f)) + ((,x) x) + ((,x . ,rest) + (make-seq #f x (join rest env))) + (else (error "what!" exps env)))) + +(define-language tree-il + #:title "Tree Intermediate Language" + #:reader (lambda (port env) (read port)) + #:printer write-tree-il + #:parser parse-tree-il + #:joiner join + #:compilers `((cps . ,compile-cps)) + #:for-humans? #f) |