summaryrefslogtreecommitdiff
path: root/module/language/tree-il
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/tree-il')
-rw-r--r--module/language/tree-il/analyze.scm1568
-rw-r--r--module/language/tree-il/canonicalize.scm82
-rw-r--r--module/language/tree-il/compile-cps.scm2590
-rw-r--r--module/language/tree-il/cps-primitives.scm176
-rw-r--r--module/language/tree-il/debug.scm246
-rw-r--r--module/language/tree-il/effects.scm591
-rw-r--r--module/language/tree-il/fix-letrec.scm314
-rw-r--r--module/language/tree-il/optimize.scm63
-rw-r--r--module/language/tree-il/peval.scm1675
-rw-r--r--module/language/tree-il/primitives.scm684
-rw-r--r--module/language/tree-il/spec.scm46
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)