diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-28 19:39:25 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-28 19:39:39 +0200 |
commit | b275fb2691af150cc57e395e65df5a66e315017e (patch) | |
tree | c16f6098aa757489c222509c3b946f6031761544 /module | |
parent | df40b969780df2979f9f5e1c9ae8b9d6f09dbd9a (diff) | |
download | guile-b275fb2691af150cc57e395e65df5a66e315017e.tar.gz |
separate peval and a new canonicalization pass into their own modules
* module/language/tree-il/peval.scm: Move to its own file. Remove the
bits about <prompt> thunk-application bodies, as they are not
optimizations, simply expectations of the compiler. `canonicalize'
handles that now.
* module/language/tree-il/optimize.scm: Use peval from its module.
Don't call `inline!', as that's useless now.
* module/language/tree-il/canonicalize.scm: New file, implementing a
pass that `compile-tree-il' runs on the result from the optimizer.
The compiler currently expects a <let> form to have bindings, for
example, and this pass turns a <let> without bindings into its body.
* module/language/tree-il/inline.scm: Deprecate, as `peval' does
everything this function ever did.
* module/language/tree-il/compile-glil.scm: Canonicalize after
optimizing. This should allow us to skip the optimizer entirely, if
we want.
* module/Makefile.am: Update and reorder a little bit.
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 6 | ||||
-rw-r--r-- | module/language/tree-il/canonicalize.scm | 86 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/inline.scm | 201 | ||||
-rw-r--r-- | module/language/tree-il/optimize.scm | 964 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 951 |
6 files changed, 1048 insertions, 1162 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 0787f2004..6b265b60d 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -91,10 +91,12 @@ SCHEME_LANG_SOURCES = \ TREE_IL_LANG_SOURCES = \ language/tree-il/primitives.scm \ - language/tree-il/optimize.scm \ - language/tree-il/inline.scm \ + language/tree-il/peval.scm \ language/tree-il/fix-letrec.scm \ + language/tree-il/optimize.scm \ + language/tree-il/canonicalize.scm \ language/tree-il/analyze.scm \ + language/tree-il/inline.scm \ language/tree-il/compile-glil.scm \ language/tree-il/spec.scm diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm new file mode 100644 index 000000000..04f561282 --- /dev/null +++ b/module/language/tree-il/canonicalize.scm @@ -0,0 +1,86 @@ +;;; Tree-il canonicalizer + +;; Copyright (C) 2011 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) + (or res (proc exp))) + (lambda (exp res) res) + #f exp)) + +(define (canonicalize! x) + (post-order! + (lambda (x) + (match x + (($ <sequence> src (tail)) + tail) + (($ <sequence> src exps) + (and (any sequence? exps) + (make-sequence src + (append-map (lambda (x) + (if (sequence? x) + (sequence-exps x) + (list x))) + exps)))) + (($ <let> src () () () body) + body) + (($ <letrec> src _ () () () body) + body) + (($ <fix> src () () () body) + body) + (($ <dynlet> src () () body) + body) + (($ <prompt> src tag body handler) + (define (escape-only? handler) + (match handler + (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f) + (tree-il-any (lambda (x) + (and (lexical-ref? x) + (eq? (lexical-ref-gensym x) cont))) + body)) + (else #f))) + (define (thunk-application? x) + (match x + (($ <application> _ + ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f)) + ()) #t) + (_ #f))) + (define (make-thunk-application body) + (define thunk + (make-lambda #f '() + (make-lambda-case #f '() #f #f #f '() '() body #f))) + (make-application #f thunk '())) + + ;; This code has a nasty job to do: to ensure that either the + ;; handler is escape-only, or the body is the application of a + ;; thunk. Sad but true. + (if (or (escape-only? handler) + (thunk-application? body)) + #f + (make-prompt src tag (make-thunk-application body) handler))) + (_ #f))) + x)) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 518823d11..3daac7fca 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -27,6 +27,7 @@ #:use-module (system vm instruction) #:use-module (language tree-il) #:use-module (language tree-il optimize) + #:use-module (language tree-il canonicalize) #:use-module (language tree-il analyze) #:use-module ((srfi srfi-1) #:select (filter-map)) #:export (compile-glil)) @@ -64,6 +65,7 @@ (let* ((x (make-lambda (tree-il-src x) '() (make-lambda-case #f '() #f #f #f '() '() x #f))) (x (optimize! x e opts)) + (x (canonicalize! x)) (allocation (analyze-lexicals x))) (with-fluids ((*comp-module* e)) diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index 67441eaaf..5a2d9af55 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -17,204 +17,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (language tree-il inline) - #:use-module (system base pmatch) - #:use-module (system base syntax) - #:use-module (language tree-il) #:export (inline!)) -;; Possible optimizations: -;; * constant folding, propagation -;; * procedure inlining -;; * always when single call site -;; * always for "trivial" procs -;; * otherwise who knows -;; * dead code elimination -;; * degenerate case optimizations -;; * "fixing letrec" - -(define (boolean-value x) - (let ((src (tree-il-src x))) - (record-case x - ((<void>) - (make-const src #t)) - - ;; FIXME: This is redundant with what the partial evaluator does. - ((<conditional> test consequent alternate) - (record-case (boolean-value test) - ((<const> exp) - (case exp - ((#t) (boolean-value consequent)) - ((#f) (boolean-value alternate)) - (else x))) - (else x))) - - ((<application> src proc args) - (record-case proc - ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) - ((<primitive-ref> name) - (case name - ((memq memv) - (pmatch args - ((,k ,l) (guard (const? l) (list? (const-exp l))) - (cond - ((null? (const-exp l)) - (make-const #f #f)) - ((const? k) - (make-const #f (->bool ((case name - ((memq) memq) - ((memv) memv) - (else (error "unexpected member func" name))) - (const-exp k) (const-exp l))))) - (else - (let lp ((elts (const-exp l))) - (let ((test (make-application - #f - (make-primitive-ref #f (case name - ((memq) 'eq?) - ((memv) 'eqv?) - (else (error "what")))) - (list k (make-const #f (car elts)))))) - (if (null? (cdr elts)) - test - (make-conditional - src - test - (make-const #f #t) - (lp (cdr elts))))))))) - - (else x))) - - (else x))) - - (else x))) - - ((<lambda> meta body) - (make-const src #t)) - - ((<const> exp) - (make-const src (not (not exp)))) - - (else - x)))) - -;; This is a completely brain-dead optimization pass whose sole claim to -;; fame is ((lambda () x)) => x. (define (inline! x) - (define (inline1 x) - (record-case x - ((<application> src proc args) - (record-case proc - ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) - ((<lambda> body) - (let lp ((lcase body)) - (and lcase - (record-case lcase - ((<lambda-case> req opt rest kw inits gensyms body alternate) - (if (and (= (length gensyms) (length req) (length args))) - (let ((x (make-let src req gensyms args body))) - (or (inline1 x) x)) - (lp alternate))))))) - - ((<primitive-ref> name) - (case name - ((@call-with-values) - (pmatch args - ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) - ;; => (let-values (((a b . c) foo)) bar) - ;; - ;; Note that this is a singly-binding form of let-values. - ;; Also note that Scheme's let-values expands into - ;; call-with-values, then here we reduce it to tree-il's - ;; let-values. - ((,producer ,consumer) - (guard (lambda? consumer) - (lambda-case? (lambda-body consumer)) - (not (lambda-case-opt (lambda-body consumer))) - (not (lambda-case-kw (lambda-body consumer))) - (not (lambda-case-alternate (lambda-body consumer)))) - (make-let-values - src - (let ((x (make-application src producer '()))) - (or (inline1 x) x)) - (lambda-body consumer))) - (else #f))) - - (else #f))) - - (else #f))) - - ((<conditional> test consequent alternate) - (let ((btest (boolean-value test))) - (or (record-case btest - ((<const> exp) - (case exp - ((#t) consequent) - ((#f) alternate) - (else #f))) - (else #f)) - (if (eq? test btest) - x - (make-conditional (conditional-src x) - btest consequent alternate))))) - - ((<let> gensyms body) - (if (null? gensyms) body x)) - - ((<letrec> gensyms body) - (if (null? gensyms) body x)) - - ((<fix> gensyms body) - (if (null? gensyms) body x)) - - ((<lambda-case> req opt rest kw gensyms body alternate) - (define (args-compatible? args gensyms) - (let lp ((args args) (gensyms gensyms)) - (cond - ((null? args) (null? gensyms)) - ((null? gensyms) #f) - ((and (lexical-ref? (car args)) - (eq? (lexical-ref-gensym (car args)) (car gensyms))) - (lp (cdr args) (cdr gensyms))) - (else #f)))) - - (and (not opt) (not kw) rest (not alternate) - (record-case body - ((<application> proc args) - ;; (lambda args (apply (lambda ...) args)) => (lambda ...) - (and (primitive-ref? proc) - (eq? (primitive-ref-name proc) '@apply) - (pair? args) - (lambda? (car args)) - (args-compatible? (cdr args) gensyms) - (lambda-body (car args)))) - (else #f)))) - - ;; Actually the opposite of inlining -- if the prompt cannot be proven to - ;; be escape-only, ensure that its body is the application of a thunk. - ((<prompt> src tag body handler) - (define (escape-only? handler) - (and (pair? (lambda-case-req handler)) - (let ((cont (car (lambda-case-gensyms handler)))) - (tree-il-fold (lambda (leaf escape-only?) - (and escape-only? - (not - (and (lexical-ref? leaf) - (eq? (lexical-ref-gensym leaf) cont))))) - (lambda (down escape-only?) escape-only?) - (lambda (up escape-only?) escape-only?) - #t - (lambda-case-body handler))))) - (define (make-thunk body) - (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f))) - - (if (or (and (application? body) - (lambda? (application-proc body)) - (null? (application-args body))) - (escape-only? handler)) - x - (make-prompt src tag - (make-application #f (make-thunk body) '()) - handler))) - - (else #f))) - (post-order! inline1 x)) + (issue-deprecation-warning + "`inline!' is deprecated. Use (language tree-il peval) instead.") + x) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index fee629a06..cb199053d 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -21,14 +21,9 @@ (define-module (language tree-il optimize) #:use-module (language tree-il) #:use-module (language tree-il primitives) - #:use-module (language tree-il inline) + #:use-module (language tree-il peval) #:use-module (language tree-il fix-letrec) - #: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) #:export (optimize!)) (define (optimize! x env opts) @@ -37,961 +32,6 @@ ;; Disable partial evaluation. (lambda (x e) x)) (_ peval)))) - (inline! (fix-letrec! (peval (expand-primitives! (resolve-primitives! x env)) - env))))) - - -;;; -;;; Partial evaluation. -;;; - -(define (fresh-gensyms syms) - (map (lambda (x) (gensym (string-append (symbol->string x) " "))) - syms)) - -(define (alpha-rename exp) - "Alpha-rename EXP. For any lambda in EXP, generate new symbols and -replace all lexical references to the former symbols with lexical -references to the new symbols." - ;; XXX: This should be factorized somehow. - (let loop ((exp exp) - (mapping vlist-null)) ; maps old to new gensyms - (match exp - (($ <lambda-case> src req opt rest kw inits gensyms body alt) - ;; Create new symbols to replace GENSYMS and propagate them down - ;; in BODY and ALT. - (let* ((new (fresh-gensyms - (append req - (or opt '()) - (if rest (list rest) '()) - (match kw - ((aok? (_ name _) ...) name) - (_ '()))))) - (mapping (fold vhash-consq mapping gensyms new))) - (make-lambda-case src req opt rest - (match kw - ((aok? (kw name old) ...) - (cons aok? (map list - kw - name - (take-right new (length old))))) - (_ #f)) - (map (cut loop <> mapping) inits) - new - (loop body mapping) - (and alt (loop alt mapping))))) - (($ <lexical-ref> src name gensym) - ;; Possibly replace GENSYM by the new gensym defined in MAPPING. - (let ((val (vhash-assq gensym mapping))) - (if val - (make-lexical-ref src name (cdr val)) - exp))) - (($ <lexical-set> src name gensym exp) - (let ((val (vhash-assq gensym mapping))) - (make-lexical-set src name (if val (cdr val) gensym) - (loop exp mapping)))) - (($ <lambda> src meta body) - (make-lambda src meta (loop body mapping))) - (($ <let> src names gensyms vals body) - ;; As for `lambda-case' rename GENSYMS to avoid any collision. - (let* ((new (fresh-gensyms names)) - (mapping (fold vhash-consq mapping gensyms new)) - (vals (map (cut loop <> mapping) vals)) - (body (loop body mapping))) - (make-let src names new vals body))) - (($ <letrec> src in-order? names gensyms vals body) - ;; Likewise. - (let* ((new (fresh-gensyms names)) - (mapping (fold vhash-consq mapping gensyms new)) - (vals (map (cut loop <> mapping) vals)) - (body (loop body mapping))) - (make-letrec src in-order? names new vals body))) - (($ <fix> src names gensyms vals body) - ;; Likewise. - (let* ((new (fresh-gensyms names)) - (mapping (fold vhash-consq mapping gensyms new)) - (vals (map (cut loop <> mapping) vals)) - (body (loop body mapping))) - (make-fix src names new vals body))) - (($ <let-values> src exp body) - (make-let-values src (loop exp mapping) (loop body mapping))) - (($ <const>) - exp) - (($ <void>) - exp) - (($ <toplevel-ref>) - exp) - (($ <module-ref>) - exp) - (($ <primitive-ref>) - exp) - (($ <toplevel-set> src name exp) - (make-toplevel-set src name (loop exp mapping))) - (($ <toplevel-define> src name exp) - (make-toplevel-define src name (loop exp mapping))) - (($ <module-set> src mod name public? exp) - (make-module-set src mod name public? (loop exp mapping))) - (($ <dynlet> src fluids vals body) - (make-dynlet src - (map (cut loop <> mapping) fluids) - (map (cut loop <> mapping) vals) - (loop body mapping))) - (($ <dynwind> src winder body unwinder) - (make-dynwind src - (loop winder mapping) - (loop body mapping) - (loop unwinder mapping))) - (($ <dynref> src fluid) - (make-dynref src (loop fluid mapping))) - (($ <dynset> src fluid exp) - (make-dynset src (loop fluid mapping) (loop exp mapping))) - (($ <conditional> src condition subsequent alternate) - (make-conditional src - (loop condition mapping) - (loop subsequent mapping) - (loop alternate mapping))) - (($ <application> src proc args) - (make-application src (loop proc mapping) - (map (cut loop <> mapping) args))) - (($ <sequence> src exps) - (make-sequence src (map (cut loop <> mapping) exps))) - (($ <prompt> src tag body handler) - (make-prompt src (loop tag mapping) (loop body mapping) - (loop handler mapping))) - (($ <abort> src tag args tail) - (make-abort src (loop tag mapping) (map (cut loop <> mapping) args) - (loop tail mapping)))))) - -(define-syntax-rule (let/ec k e e* ...) - (let ((tag (make-prompt-tag))) - (call-with-prompt - tag - (lambda () - (let ((k (lambda args (apply abort-to-prompt tag args)))) - e e* ...)) - (lambda (_ res) res)))) - -(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) - (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-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 (vhash-assq gensym res))) - (if var - (begin - (set-var-refcount! (cdr var) (1+ (var-refcount (cdr var)))) - res) - (vhash-consq gensym (make-var name gensym 1 #f) res)))) - (_ res))) - (lambda (exp res) - (match exp - (($ <lexical-set> src name gensym exp) - (let ((var (vhash-assq gensym res))) - (if var - (begin - (set-var-set?! (cdr var) #t) - res) - (vhash-consq gensym (make-var name gensym 0 #t) res)))) - (_ res))) - (lambda (exp res) res) - table exp)) - -(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?) - (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)) - -(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. Since -it does not handle <fix> and <let-values>, it should be called before -`fix-letrec'." - - ;; This is a simple partial evaluator. It effectively performs - ;; constant folding, copy propagation, dead code elimination, and - ;; inlining, but not across top-level bindings---there should be a way - ;; to allow this (TODO). - ;; - ;; Unlike a full-blown partial evaluator, it does not emit definitions - ;; of specialized versions of lambdas encountered on its way. Also, - ;; it's not yet complete: it bails out for `prompt', etc. - - (define local-toplevel-env - ;; The top-level environment of the module being compiled. - (match exp - (($ <toplevel-define> _ name) - (vhash-consq name #t env)) - (($ <sequence> _ exps) - (fold (lambda (x r) - (match x - (($ <toplevel-define> _ name) - (vhash-consq name #t r)) - (_ r))) - env - exps)) - (_ env))) - - (define (local-toplevel? name) - (vhash-assq name local-toplevel-env)) - - (define store (build-var-table exp)) - - (define (assigned-lexical? sym) - (let ((v (vhash-assq sym store))) - (and v (var-set? (cdr v))))) - - (define (lexical-refcount sym) - (let ((v (vhash-assq sym store))) - (if v (var-refcount (cdr v)) 0))) - - (define (record-source-expression! orig new) - (set! store (vhash-consq new - (source-expression orig) - (build-var-table new store))) - new) - - (define (source-expression new) - (let ((x (vhash-assq new store))) - (if x (cdr x) new))) - - (define residual-lexical-references (make-hash-table)) - - (define (record-residual-lexical-reference! sym) - (hashq-set! residual-lexical-references sym #t)) - - (define (apply-primitive name args) - ;; todo: further optimize commutative primitives - (catch #t - (lambda () - (call-with-values - (lambda () - (apply (module-ref the-scm-module name) args)) - (lambda results - (values #t results)))) - (lambda _ - (values #f '())))) - - (define (inline-values exp src names gensyms body) - (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>) - ($ <dynref>) - ($ <lexical-set>) ; FIXME: these set! expressions - ($ <toplevel-set>) ; could return zero values in - ($ <toplevel-define>) ; the future - ($ <module-set>) ; - ($ <dynset>)) ; - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) - (($ <application> src - ($ <primitive-ref> _ (? singly-valued-primitive? name))) - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) - - ;; Statically-known number of values. - (($ <application> src ($ <primitive-ref> _ 'values) vals) - (and (= (length names) (length vals)) - (make-let src names gensyms vals body))) - - ;; Not going to copy code into both branches. - (($ <conditional>) #f) - - ;; Bail on other applications. - (($ <application>) #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))))) - (($ <dynwind> src winder body unwinder) - (let ((body (loop body))) - (and body - (make-dynwind src winder body unwinder)))) - (($ <dynlet> src fluids vals body) - (let ((body (loop body))) - (and body - (make-dynlet src fluids vals body)))) - (($ <sequence> src exps) - (match exps - ((head ... tail) - (let ((tail (loop tail))) - (and tail - (make-sequence src (append head (list tail))))))))))) - - (define (make-values src values) - (match values - ((single) single) ; 1 value - ((_ ...) ; 0, or 2 or more values - (make-application src (make-primitive-ref src 'values) - values)))) - - (define (constant-expression? x) - ;; Return true if X is constant---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). - (let loop ((x x)) - (match x - (($ <void>) #t) - (($ <const>) #t) - (($ <lambda>) #t) - (($ <lambda-case> _ req opt rest kw inits _ body alternate) - (and (every loop inits) (loop body) (loop alternate))) - (($ <lexical-ref> _ _ gensym) - (not (assigned-lexical? gensym))) - (($ <primitive-ref>) #t) - (($ <conditional> _ condition subsequent alternate) - (and (loop condition) (loop subsequent) (loop alternate))) - (($ <application> _ ($ <primitive-ref> _ name) args) - (and (effect-free-primitive? name) - (not (constructor-primitive? name)) - (types-check? name args) - (every loop args))) - (($ <application> _ ($ <lambda> _ _ body) args) - (and (loop body) (every loop args))) - (($ <sequence> _ exps) - (every loop exps)) - (($ <let> _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ <letrec> _ _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ <fix> _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ <let-values> _ exp body) - (and (loop exp) (loop body))) - (($ <prompt> _ tag body handler) - (and (loop tag) (loop body) (loop handler))) - (_ #f)))) - - (define (prune-bindings names syms vals body for-effect - build-result) - (let lp ((names names) (syms syms) (vals vals) - (names* '()) (syms* '()) (vals* '()) - (effects '())) - (match (list names syms vals) - ((() () ()) - (let ((body (if (null? effects) - body - (make-sequence #f (reverse (cons body effects)))))) - (if (null? names*) - body - (build-result (reverse names*) (reverse syms*) - (reverse vals*) body)))) - (((name . names) (sym . syms) (val . vals)) - (if (hashq-ref residual-lexical-references sym) - (lp names syms vals - (cons name names*) (cons sym syms*) (cons val vals*) - effects) - (let ((effect (for-effect val))) - (lp names syms vals - names* syms* vals* - (if (void? effect) - effects - (cons effect effects))))))))) - - (define (small-expression? x limit) - (let/ec k - (tree-il-fold - (lambda (x res) ; leaf - (1+ res)) - (lambda (x res) ; down - (1+ res)) - (lambda (x res) ; up - (if (< res limit) - res - (k #f))) - 0 x) - #t)) - - (let loop ((exp exp) - (env vlist-null) ; static environment - (counter #f) ; inlined call stack - (ctx 'value)) ; effect, value, test, operator, or operand - (define (lookup var) - (and=> (vhash-assq var env) cdr)) - - (define (for-value exp) - (loop exp env counter 'value)) - (define (for-operand exp) - (loop exp env counter 'operand)) - (define (for-test exp) - (loop exp env counter 'test)) - (define (for-effect exp) - (loop exp env counter 'effect)) - (define (for-tail exp) - (loop exp env counter ctx)) - - (if counter - (record-effort! counter)) - - (match exp - (($ <const>) - (case ctx - ((effect) (make-void #f)) - (else exp))) - (($ <void>) - (case ctx - ((test) (make-const #f #t)) - (else exp))) - (($ <lexical-ref> _ _ gensym) - (case ctx - ((effect) (make-void #f)) - (else - (let ((val (lookup gensym))) - (cond - ((or (not val) - (assigned-lexical? gensym) - (not (constant-expression? val))) - ;; Don't copy-propagate through assigned variables, - ;; and don't reorder effects. - (record-residual-lexical-reference! gensym) - exp) - ((lexical-ref? val) - (for-tail val)) - ((or (const? val) - (void? val) - (primitive-ref? val)) - ;; Always propagate simple values that cannot lead to - ;; code bloat. - (for-tail val)) - ((= 1 (lexical-refcount gensym)) - ;; Always propagate values referenced only once. - ;; There is no need to rename the bindings, as they - ;; are only being moved, not copied. However in - ;; operator context we do rename it, as that - ;; effectively clears out the residualized-lexical - ;; flags that may have been set when this value was - ;; visited previously as an operand. - (case ctx - ((test) (for-test val)) - ((operator) (record-source-expression! val (alpha-rename val))) - (else 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)) - (record-source-expression! val (alpha-rename val)) - (begin - (record-residual-lexical-reference! gensym) - exp))) - ((eq? ctx 'operand) - ;; A pure expression in the operand position. Inline - ;; if it's small enough. - (if (small-expression? val operand-size-limit) - (record-source-expression! val (alpha-rename val)) - (begin - (record-residual-lexical-reference! gensym) - exp))) - (else - ;; A pure expression, processed 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))) - (record-source-expression! val (alpha-rename val)) - (begin - (record-residual-lexical-reference! gensym) - exp)))))))) - (($ <lexical-set> src name gensym exp) - (if (zero? (lexical-refcount gensym)) - (let ((exp (for-effect exp))) - (if (void? exp) - exp - (make-sequence src (list exp (make-void #f))))) - (begin - (record-residual-lexical-reference! gensym) - (make-lexical-set src name gensym (for-value exp))))) - (($ <let> src names gensyms vals body) - (let* ((vals (map for-operand vals)) - (body (loop body - (fold vhash-consq env gensyms vals) - counter - ctx))) - (cond - ((const? body) - (for-tail (make-sequence src (append vals (list body))))) - ((and (lexical-ref? body) - (memq (lexical-ref-gensym body) gensyms)) - (let ((sym (lexical-ref-gensym body)) - (pairs (map cons gensyms vals))) - ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) - (for-tail - (make-sequence - src - (append (map cdr (alist-delete sym pairs eq?)) - (list (assq-ref pairs sym))))))) - (else - ;; Only include bindings for which lexical references - ;; have been residualized. - (prune-bindings names gensyms vals body for-effect - (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) - ;; Things could be done more precisely when IN-ORDER? but - ;; it's OK not to do it---at worst we lost an optimization - ;; opportunity. - (let* ((vals (map for-operand vals)) - (body (loop body - (fold vhash-consq env gensyms vals) - counter - ctx))) - (if (and (const? body) - (every constant-expression? vals)) - body - (prune-bindings names gensyms vals body for-effect - (lambda (names gensyms vals body) - (make-letrec src in-order? - names gensyms vals body)))))) - (($ <fix> src names gensyms vals body) - (let* ((vals (map for-operand vals)) - (body (loop body - (fold vhash-consq env gensyms vals) - counter - ctx))) - (if (const? body) - body - (prune-bindings names gensyms vals body for-effect - (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-value producer))) - (or (match consumer - (($ <lambda-case> src req #f #f #f () gensyms body #f) - (cond - ((inline-values producer src req gensyms body) - => for-tail) - (else #f))) - (_ #f)) - (make-let-values lv-src producer (for-tail consumer))))) - (($ <dynwind> src winder body unwinder) - (make-dynwind src (for-value winder) (for-tail body) - (for-value unwinder))) - (($ <dynlet> src fluids vals body) - (make-dynlet src (map for-value fluids) (map for-value vals) - (for-tail body))) - (($ <dynref> src fluid) - (make-dynref src (for-value fluid))) - (($ <dynset> src fluid exp) - (make-dynset src (for-value fluid) (for-value exp))) - (($ <toplevel-ref> src (? effect-free-primitive? name)) - (if (local-toplevel? name) - exp - (resolve-primitives! exp cenv))) - (($ <toplevel-ref>) - ;; todo: open private local bindings. - 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) - (let ((condition (for-test condition))) - (if (const? condition) - (if (const-exp condition) - (for-tail subsequent) - (for-tail alternate)) - (make-conditional src condition - (for-tail subsequent) - (for-tail alternate))))) - (($ <application> src - ($ <primitive-ref> _ '@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-application src producer '()) - consumer))) - - (($ <application> src orig-proc orig-args) - ;; todo: augment the global env with specialized functions - (let ((proc (loop orig-proc env counter 'operator))) - (match proc - (($ <primitive-ref> _ (? constructor-primitive? name)) - (case ctx - ((effect test) - (let ((res (if (eq? ctx 'effect) - (make-void #f) - (make-const #f #t)))) - (match (for-value exp) - (($ <application> _ ($ <primitive-ref> _ 'cons) (x xs)) - (for-tail - (make-sequence src (list x xs res)))) - (($ <application> _ ($ <primitive-ref> _ 'list) elts) - (for-tail - (make-sequence src (append elts (list res))))) - (($ <application> _ ($ <primitive-ref> _ 'vector) elts) - (for-tail - (make-sequence src (append elts (list res))))) - (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ()) - res) - (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) - (($ <const> _ (? string?)))) - res) - (exp exp)))) - (else - (match (cons name (map for-value orig-args)) - (('cons head tail) - (match tail - (($ <const> src ()) - (make-application src (make-primitive-ref #f 'list) - (list head))) - (($ <application> src ($ <primitive-ref> _ 'list) elts) - (make-application src (make-primitive-ref #f 'list) - (cons head elts))) - (_ (make-application src proc - (list head tail))))) - - ;; FIXME: these for-tail recursions could take - ;; place outside an effort counter. - (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) - (for-tail (make-sequence src (list tail head)))) - (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) - (for-tail (make-sequence src (list head tail)))) - (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) - (for-tail (make-sequence src (append tail (list head))))) - (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) - (for-tail (make-sequence - src - (list head - (make-application - src (make-primitive-ref #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))) - - ((_ . args) - (make-application src proc args)))))) - (($ <primitive-ref> _ (? effect-free-primitive? name)) - (let ((args (map for-value orig-args))) - (if (every const? args) ; only simple constants - (let-values (((success? values) - (apply-primitive name - (map const-exp args)))) - (if success? - (case ctx - ((effect) (make-void #f)) - ((test) - ;; Values truncation: only take the first - ;; value. - (if (pair? values) - (make-const #f (car values)) - (make-values src '()))) - (else - (make-values src (map (cut make-const src <>) - values)))) - (make-application src proc args))) - (cond - ((and (eq? ctx 'effect) (types-check? name args)) - (make-void #f)) - (else - (make-application src proc args)))))) - (($ <lambda> _ _ - ($ <lambda-case> _ req opt #f #f inits gensyms body #f)) - ;; Simple case: no rest, no keyword arguments. - ;; todo: handle the more complex cases - (let* ((nargs (length orig-args)) - (nreq (length req)) - (nopt (if opt (length opt) 0)) - (key (source-expression proc))) - (cond - ((or (< nargs nreq) (> nargs (+ nreq nopt))) - ;; An error, or effecting arguments. - (make-application src (for-value orig-proc) - (map for-value orig-args))) - ((or (and=> (find-counter key counter) counter-recursive?) - (lambda? orig-proc)) - ;; A recursive call, or a lambda in the operator - ;; position of the source expression. Process again in - ;; tail context. - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - 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. - (let/ec k - (define (abort) - (k (make-application src - (for-value 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 (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - 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)) - - result))))) - (_ - (make-application src proc - (map for-value orig-args)))))) - (($ <lambda> src meta body) - (case ctx - ((effect) (make-void #f)) - ((test) (make-const #f #t)) - ((operator) exp) - (else - (make-lambda src meta (for-value body))))) - (($ <lambda-case> src req opt rest kw inits gensyms body alt) - (make-lambda-case src req opt rest kw - (map for-value inits) - gensyms - (for-tail body) - (and alt (for-tail alt)))) - (($ <sequence> src exps) - (let lp ((exps exps) (effects '())) - (match exps - ((last) - (if (null? effects) - (for-tail last) - (make-sequence - src - (reverse (cons (for-tail last) effects))))) - ((head . rest) - (let ((head (for-effect head))) - (cond - ((sequence? head) - (lp (append (sequence-exps head) rest) effects)) - ((void? head) - (lp rest effects)) - (else - (lp rest (cons head effects))))))))) - (($ <prompt> src tag body handler) - (define (singly-used-definition x) - (cond - ((and (lexical-ref? x) - ;; Only fetch definitions with single uses. - (= (lexical-refcount (lexical-ref-gensym x)) 1) - (lookup (lexical-ref-gensym x))) - => singly-used-definition) - (else x))) - (define (escape-only? handler) - (match handler - (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f) - (tree-il-any (lambda (x) - (and (lexical-ref? x) - (eq? (lexical-ref-gensym x) cont))) - body)) - (else #f))) - (define (thunk-application? x) - (match x - (($ <application> _ - ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f)) - ()) #t) - (_ #f))) - (define (make-thunk-application body) - (define thunk - (make-lambda #f '() - (make-lambda-case #f '() #f #f #f '() '() body #f))) - (make-application #f thunk '())) - - (match (singly-used-definition tag) - (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) - (or () ((? constant-expression?)))) - ;; There is no way that an <abort> could know the tag - ;; for this <prompt>, so we can elide the <prompt> - ;; entirely. - (for-tail body)) - (_ - ;; It's a nasty, but this code has another job to do: to - ;; ensure that either the handler is escape-only, or the - ;; body is the application of a thunk. Sad but true. - (let ((tag (for-value tag)) - (body (for-value body)) - (handler (for-value handler))) - (make-prompt src tag - (if (or (escape-only? handler) - (thunk-application? body)) - body - (make-thunk-application body)) - handler))))) - (($ <abort> src tag args tail) - (make-abort src (for-value tag) (map for-value args) - (for-value tail)))))) + env)))) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm new file mode 100644 index 000000000..a097dd498 --- /dev/null +++ b/module/language/tree-il/peval.scm @@ -0,0 +1,951 @@ +;;; Tree-IL partial evaluator + +;; Copyright (C) 2011 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 (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) + #:export (peval)) + +;;; +;;; Partial evaluation. +;;; + +(define (fresh-gensyms syms) + (map (lambda (x) (gensym (string-append (symbol->string x) " "))) + syms)) + +(define (alpha-rename exp) + "Alpha-rename EXP. For any lambda in EXP, generate new symbols and +replace all lexical references to the former symbols with lexical +references to the new symbols." + ;; XXX: This should be factorized somehow. + (let loop ((exp exp) + (mapping vlist-null)) ; maps old to new gensyms + (match exp + (($ <lambda-case> src req opt rest kw inits gensyms body alt) + ;; Create new symbols to replace GENSYMS and propagate them down + ;; in BODY and ALT. + (let* ((new (fresh-gensyms + (append req + (or opt '()) + (if rest (list rest) '()) + (match kw + ((aok? (_ name _) ...) name) + (_ '()))))) + (mapping (fold vhash-consq mapping gensyms new))) + (make-lambda-case src req opt rest + (match kw + ((aok? (kw name old) ...) + (cons aok? (map list + kw + name + (take-right new (length old))))) + (_ #f)) + (map (cut loop <> mapping) inits) + new + (loop body mapping) + (and alt (loop alt mapping))))) + (($ <lexical-ref> src name gensym) + ;; Possibly replace GENSYM by the new gensym defined in MAPPING. + (let ((val (vhash-assq gensym mapping))) + (if val + (make-lexical-ref src name (cdr val)) + exp))) + (($ <lexical-set> src name gensym exp) + (let ((val (vhash-assq gensym mapping))) + (make-lexical-set src name (if val (cdr val) gensym) + (loop exp mapping)))) + (($ <lambda> src meta body) + (make-lambda src meta (loop body mapping))) + (($ <let> src names gensyms vals body) + ;; As for `lambda-case' rename GENSYMS to avoid any collision. + (let* ((new (fresh-gensyms names)) + (mapping (fold vhash-consq mapping gensyms new)) + (vals (map (cut loop <> mapping) vals)) + (body (loop body mapping))) + (make-let src names new vals body))) + (($ <letrec> src in-order? names gensyms vals body) + ;; Likewise. + (let* ((new (fresh-gensyms names)) + (mapping (fold vhash-consq mapping gensyms new)) + (vals (map (cut loop <> mapping) vals)) + (body (loop body mapping))) + (make-letrec src in-order? names new vals body))) + (($ <fix> src names gensyms vals body) + ;; Likewise. + (let* ((new (fresh-gensyms names)) + (mapping (fold vhash-consq mapping gensyms new)) + (vals (map (cut loop <> mapping) vals)) + (body (loop body mapping))) + (make-fix src names new vals body))) + (($ <let-values> src exp body) + (make-let-values src (loop exp mapping) (loop body mapping))) + (($ <const>) + exp) + (($ <void>) + exp) + (($ <toplevel-ref>) + exp) + (($ <module-ref>) + exp) + (($ <primitive-ref>) + exp) + (($ <toplevel-set> src name exp) + (make-toplevel-set src name (loop exp mapping))) + (($ <toplevel-define> src name exp) + (make-toplevel-define src name (loop exp mapping))) + (($ <module-set> src mod name public? exp) + (make-module-set src mod name public? (loop exp mapping))) + (($ <dynlet> src fluids vals body) + (make-dynlet src + (map (cut loop <> mapping) fluids) + (map (cut loop <> mapping) vals) + (loop body mapping))) + (($ <dynwind> src winder body unwinder) + (make-dynwind src + (loop winder mapping) + (loop body mapping) + (loop unwinder mapping))) + (($ <dynref> src fluid) + (make-dynref src (loop fluid mapping))) + (($ <dynset> src fluid exp) + (make-dynset src (loop fluid mapping) (loop exp mapping))) + (($ <conditional> src condition subsequent alternate) + (make-conditional src + (loop condition mapping) + (loop subsequent mapping) + (loop alternate mapping))) + (($ <application> src proc args) + (make-application src (loop proc mapping) + (map (cut loop <> mapping) args))) + (($ <sequence> src exps) + (make-sequence src (map (cut loop <> mapping) exps))) + (($ <prompt> src tag body handler) + (make-prompt src (loop tag mapping) (loop body mapping) + (loop handler mapping))) + (($ <abort> src tag args tail) + (make-abort src (loop tag mapping) (map (cut loop <> mapping) args) + (loop tail mapping)))))) + +(define-syntax-rule (let/ec k e e* ...) + (let ((tag (make-prompt-tag))) + (call-with-prompt + tag + (lambda () + (let ((k (lambda args (apply abort-to-prompt tag args)))) + e e* ...)) + (lambda (_ res) res)))) + +(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) + (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-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 (vhash-assq gensym res))) + (if var + (begin + (set-var-refcount! (cdr var) (1+ (var-refcount (cdr var)))) + res) + (vhash-consq gensym (make-var name gensym 1 #f) res)))) + (_ res))) + (lambda (exp res) + (match exp + (($ <lexical-set> src name gensym exp) + (let ((var (vhash-assq gensym res))) + (if var + (begin + (set-var-set?! (cdr var) #t) + res) + (vhash-consq gensym (make-var name gensym 0 #t) res)))) + (_ res))) + (lambda (exp res) res) + table exp)) + +(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?) + (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)) + +(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. Since +it does not handle <fix> and <let-values>, it should be called before +`fix-letrec'." + + ;; This is a simple partial evaluator. It effectively performs + ;; constant folding, copy propagation, dead code elimination, and + ;; inlining, but not across top-level bindings---there should be a way + ;; to allow this (TODO). + ;; + ;; Unlike a full-blown partial evaluator, it does not emit definitions + ;; of specialized versions of lambdas encountered on its way. Also, + ;; it's not yet complete: it bails out for `prompt', etc. + + (define local-toplevel-env + ;; The top-level environment of the module being compiled. + (match exp + (($ <toplevel-define> _ name) + (vhash-consq name #t env)) + (($ <sequence> _ exps) + (fold (lambda (x r) + (match x + (($ <toplevel-define> _ name) + (vhash-consq name #t r)) + (_ r))) + env + exps)) + (_ env))) + + (define (local-toplevel? name) + (vhash-assq name local-toplevel-env)) + + (define store (build-var-table exp)) + + (define (assigned-lexical? sym) + (let ((v (vhash-assq sym store))) + (and v (var-set? (cdr v))))) + + (define (lexical-refcount sym) + (let ((v (vhash-assq sym store))) + (if v (var-refcount (cdr v)) 0))) + + (define (record-source-expression! orig new) + (set! store (vhash-consq new + (source-expression orig) + (build-var-table new store))) + new) + + (define (source-expression new) + (let ((x (vhash-assq new store))) + (if x (cdr x) new))) + + (define residual-lexical-references (make-hash-table)) + + (define (record-residual-lexical-reference! sym) + (hashq-set! residual-lexical-references sym #t)) + + (define (apply-primitive name args) + ;; todo: further optimize commutative primitives + (catch #t + (lambda () + (call-with-values + (lambda () + (apply (module-ref the-scm-module name) args)) + (lambda results + (values #t results)))) + (lambda _ + (values #f '())))) + + (define (inline-values exp src names gensyms body) + (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>) + ($ <dynref>) + ($ <lexical-set>) ; FIXME: these set! expressions + ($ <toplevel-set>) ; could return zero values in + ($ <toplevel-define>) ; the future + ($ <module-set>) ; + ($ <dynset>)) ; + (and (= (length names) 1) + (make-let src names gensyms (list exp) body))) + (($ <application> src + ($ <primitive-ref> _ (? singly-valued-primitive? name))) + (and (= (length names) 1) + (make-let src names gensyms (list exp) body))) + + ;; Statically-known number of values. + (($ <application> src ($ <primitive-ref> _ 'values) vals) + (and (= (length names) (length vals)) + (make-let src names gensyms vals body))) + + ;; Not going to copy code into both branches. + (($ <conditional>) #f) + + ;; Bail on other applications. + (($ <application>) #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))))) + (($ <dynwind> src winder body unwinder) + (let ((body (loop body))) + (and body + (make-dynwind src winder body unwinder)))) + (($ <dynlet> src fluids vals body) + (let ((body (loop body))) + (and body + (make-dynlet src fluids vals body)))) + (($ <sequence> src exps) + (match exps + ((head ... tail) + (let ((tail (loop tail))) + (and tail + (make-sequence src (append head (list tail))))))))))) + + (define (make-values src values) + (match values + ((single) single) ; 1 value + ((_ ...) ; 0, or 2 or more values + (make-application src (make-primitive-ref src 'values) + values)))) + + (define (constant-expression? x) + ;; Return true if X is constant---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). + (let loop ((x x)) + (match x + (($ <void>) #t) + (($ <const>) #t) + (($ <lambda>) #t) + (($ <lambda-case> _ req opt rest kw inits _ body alternate) + (and (every loop inits) (loop body) (loop alternate))) + (($ <lexical-ref> _ _ gensym) + (not (assigned-lexical? gensym))) + (($ <primitive-ref>) #t) + (($ <conditional> _ condition subsequent alternate) + (and (loop condition) (loop subsequent) (loop alternate))) + (($ <application> _ ($ <primitive-ref> _ name) args) + (and (effect-free-primitive? name) + (not (constructor-primitive? name)) + (types-check? name args) + (every loop args))) + (($ <application> _ ($ <lambda> _ _ body) args) + (and (loop body) (every loop args))) + (($ <sequence> _ exps) + (every loop exps)) + (($ <let> _ _ _ vals body) + (and (every loop vals) (loop body))) + (($ <letrec> _ _ _ _ vals body) + (and (every loop vals) (loop body))) + (($ <fix> _ _ _ vals body) + (and (every loop vals) (loop body))) + (($ <let-values> _ exp body) + (and (loop exp) (loop body))) + (($ <prompt> _ tag body handler) + (and (loop tag) (loop body) (loop handler))) + (_ #f)))) + + (define (prune-bindings names syms vals body for-effect + build-result) + (let lp ((names names) (syms syms) (vals vals) + (names* '()) (syms* '()) (vals* '()) + (effects '())) + (match (list names syms vals) + ((() () ()) + (let ((body (if (null? effects) + body + (make-sequence #f (reverse (cons body effects)))))) + (if (null? names*) + body + (build-result (reverse names*) (reverse syms*) + (reverse vals*) body)))) + (((name . names) (sym . syms) (val . vals)) + (if (hashq-ref residual-lexical-references sym) + (lp names syms vals + (cons name names*) (cons sym syms*) (cons val vals*) + effects) + (let ((effect (for-effect val))) + (lp names syms vals + names* syms* vals* + (if (void? effect) + effects + (cons effect effects))))))))) + + (define (small-expression? x limit) + (let/ec k + (tree-il-fold + (lambda (x res) ; leaf + (1+ res)) + (lambda (x res) ; down + (1+ res)) + (lambda (x res) ; up + (if (< res limit) + res + (k #f))) + 0 x) + #t)) + + (let loop ((exp exp) + (env vlist-null) ; static environment + (counter #f) ; inlined call stack + (ctx 'value)) ; effect, value, test, operator, or operand + (define (lookup var) + (and=> (vhash-assq var env) cdr)) + + (define (for-value exp) + (loop exp env counter 'value)) + (define (for-operand exp) + (loop exp env counter 'operand)) + (define (for-test exp) + (loop exp env counter 'test)) + (define (for-effect exp) + (loop exp env counter 'effect)) + (define (for-tail exp) + (loop exp env counter ctx)) + + (if counter + (record-effort! counter)) + + (match exp + (($ <const>) + (case ctx + ((effect) (make-void #f)) + (else exp))) + (($ <void>) + (case ctx + ((test) (make-const #f #t)) + (else exp))) + (($ <lexical-ref> _ _ gensym) + (case ctx + ((effect) (make-void #f)) + (else + (let ((val (lookup gensym))) + (cond + ((or (not val) + (assigned-lexical? gensym) + (not (constant-expression? val))) + ;; Don't copy-propagate through assigned variables, + ;; and don't reorder effects. + (record-residual-lexical-reference! gensym) + exp) + ((lexical-ref? val) + (for-tail val)) + ((or (const? val) + (void? val) + (primitive-ref? val)) + ;; Always propagate simple values that cannot lead to + ;; code bloat. + (for-tail val)) + ((= 1 (lexical-refcount gensym)) + ;; Always propagate values referenced only once. + ;; There is no need to rename the bindings, as they + ;; are only being moved, not copied. However in + ;; operator context we do rename it, as that + ;; effectively clears out the residualized-lexical + ;; flags that may have been set when this value was + ;; visited previously as an operand. + (case ctx + ((test) (for-test val)) + ((operator) (record-source-expression! val (alpha-rename val))) + (else 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)) + (record-source-expression! val (alpha-rename val)) + (begin + (record-residual-lexical-reference! gensym) + exp))) + ((eq? ctx 'operand) + ;; A pure expression in the operand position. Inline + ;; if it's small enough. + (if (small-expression? val operand-size-limit) + (record-source-expression! val (alpha-rename val)) + (begin + (record-residual-lexical-reference! gensym) + exp))) + (else + ;; A pure expression, processed 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))) + (record-source-expression! val (alpha-rename val)) + (begin + (record-residual-lexical-reference! gensym) + exp)))))))) + (($ <lexical-set> src name gensym exp) + (if (zero? (lexical-refcount gensym)) + (let ((exp (for-effect exp))) + (if (void? exp) + exp + (make-sequence src (list exp (make-void #f))))) + (begin + (record-residual-lexical-reference! gensym) + (make-lexical-set src name gensym (for-value exp))))) + (($ <let> src names gensyms vals body) + (let* ((vals (map for-operand vals)) + (body (loop body + (fold vhash-consq env gensyms vals) + counter + ctx))) + (cond + ((const? body) + (for-tail (make-sequence src (append vals (list body))))) + ((and (lexical-ref? body) + (memq (lexical-ref-gensym body) gensyms)) + (let ((sym (lexical-ref-gensym body)) + (pairs (map cons gensyms vals))) + ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) + (for-tail + (make-sequence + src + (append (map cdr (alist-delete sym pairs eq?)) + (list (assq-ref pairs sym))))))) + (else + ;; Only include bindings for which lexical references + ;; have been residualized. + (prune-bindings names gensyms vals body for-effect + (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) + ;; Things could be done more precisely when IN-ORDER? but + ;; it's OK not to do it---at worst we lost an optimization + ;; opportunity. + (let* ((vals (map for-operand vals)) + (body (loop body + (fold vhash-consq env gensyms vals) + counter + ctx))) + (if (and (const? body) + (every constant-expression? vals)) + body + (prune-bindings names gensyms vals body for-effect + (lambda (names gensyms vals body) + (make-letrec src in-order? + names gensyms vals body)))))) + (($ <fix> src names gensyms vals body) + (let* ((vals (map for-operand vals)) + (body (loop body + (fold vhash-consq env gensyms vals) + counter + ctx))) + (if (const? body) + body + (prune-bindings names gensyms vals body for-effect + (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-value producer))) + (or (match consumer + (($ <lambda-case> src req #f #f #f () gensyms body #f) + (cond + ((inline-values producer src req gensyms body) + => for-tail) + (else #f))) + (_ #f)) + (make-let-values lv-src producer (for-tail consumer))))) + (($ <dynwind> src winder body unwinder) + (make-dynwind src (for-value winder) (for-tail body) + (for-value unwinder))) + (($ <dynlet> src fluids vals body) + (make-dynlet src (map for-value fluids) (map for-value vals) + (for-tail body))) + (($ <dynref> src fluid) + (make-dynref src (for-value fluid))) + (($ <dynset> src fluid exp) + (make-dynset src (for-value fluid) (for-value exp))) + (($ <toplevel-ref> src (? effect-free-primitive? name)) + (if (local-toplevel? name) + exp + (resolve-primitives! exp cenv))) + (($ <toplevel-ref>) + ;; todo: open private local bindings. + 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) + (let ((condition (for-test condition))) + (if (const? condition) + (if (const-exp condition) + (for-tail subsequent) + (for-tail alternate)) + (make-conditional src condition + (for-tail subsequent) + (for-tail alternate))))) + (($ <application> src + ($ <primitive-ref> _ '@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-application src producer '()) + consumer))) + + (($ <application> src orig-proc orig-args) + ;; todo: augment the global env with specialized functions + (let ((proc (loop orig-proc env counter 'operator))) + (match proc + (($ <primitive-ref> _ (? constructor-primitive? name)) + (case ctx + ((effect test) + (let ((res (if (eq? ctx 'effect) + (make-void #f) + (make-const #f #t)))) + (match (for-value exp) + (($ <application> _ ($ <primitive-ref> _ 'cons) (x xs)) + (for-tail + (make-sequence src (list x xs res)))) + (($ <application> _ ($ <primitive-ref> _ 'list) elts) + (for-tail + (make-sequence src (append elts (list res))))) + (($ <application> _ ($ <primitive-ref> _ 'vector) elts) + (for-tail + (make-sequence src (append elts (list res))))) + (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ()) + res) + (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) + (($ <const> _ (? string?)))) + res) + (exp exp)))) + (else + (match (cons name (map for-value orig-args)) + (('cons head tail) + (match tail + (($ <const> src ()) + (make-application src (make-primitive-ref #f 'list) + (list head))) + (($ <application> src ($ <primitive-ref> _ 'list) elts) + (make-application src (make-primitive-ref #f 'list) + (cons head elts))) + (_ (make-application src proc + (list head tail))))) + + ;; FIXME: these for-tail recursions could take + ;; place outside an effort counter. + (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) + (for-tail (make-sequence src (list tail head)))) + (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) + (for-tail (make-sequence src (list head tail)))) + (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) + (for-tail (make-sequence src (append tail (list head))))) + (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) + (for-tail (make-sequence + src + (list head + (make-application + src (make-primitive-ref #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))) + + ((_ . args) + (make-application src proc args)))))) + (($ <primitive-ref> _ (? effect-free-primitive? name)) + (let ((args (map for-value orig-args))) + (if (every const? args) ; only simple constants + (let-values (((success? values) + (apply-primitive name + (map const-exp args)))) + (if success? + (case ctx + ((effect) (make-void #f)) + ((test) + ;; Values truncation: only take the first + ;; value. + (if (pair? values) + (make-const #f (car values)) + (make-values src '()))) + (else + (make-values src (map (cut make-const src <>) + values)))) + (make-application src proc args))) + (cond + ((and (eq? ctx 'effect) (types-check? name args)) + (make-void #f)) + (else + (make-application src proc args)))))) + (($ <lambda> _ _ + ($ <lambda-case> _ req opt #f #f inits gensyms body #f)) + ;; Simple case: no rest, no keyword arguments. + ;; todo: handle the more complex cases + (let* ((nargs (length orig-args)) + (nreq (length req)) + (nopt (if opt (length opt) 0)) + (key (source-expression proc))) + (cond + ((or (< nargs nreq) (> nargs (+ nreq nopt))) + ;; An error, or effecting arguments. + (make-application src (for-value orig-proc) + (map for-value orig-args))) + ((or (and=> (find-counter key counter) counter-recursive?) + (lambda? orig-proc)) + ;; A recursive call, or a lambda in the operator + ;; position of the source expression. Process again in + ;; tail context. + (loop (make-let src (append req (or opt '())) + gensyms + (append orig-args + (drop inits (- nargs nreq))) + body) + 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. + (let/ec k + (define (abort) + (k (make-application src + (for-value 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 (make-let src (append req (or opt '())) + gensyms + (append orig-args + (drop inits (- nargs nreq))) + body) + 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)) + + result))))) + (_ + (make-application src proc + (map for-value orig-args)))))) + (($ <lambda> src meta body) + (case ctx + ((effect) (make-void #f)) + ((test) (make-const #f #t)) + ((operator) exp) + (else + (make-lambda src meta (for-value body))))) + (($ <lambda-case> src req opt rest kw inits gensyms body alt) + (make-lambda-case src req opt rest kw + (map for-value inits) + gensyms + (for-tail body) + (and alt (for-tail alt)))) + (($ <sequence> src exps) + (let lp ((exps exps) (effects '())) + (match exps + ((last) + (if (null? effects) + (for-tail last) + (make-sequence + src + (reverse (cons (for-tail last) effects))))) + ((head . rest) + (let ((head (for-effect head))) + (cond + ((sequence? head) + (lp (append (sequence-exps head) rest) effects)) + ((void? head) + (lp rest effects)) + (else + (lp rest (cons head effects))))))))) + (($ <prompt> src tag body handler) + (define (singly-used-definition x) + (cond + ((and (lexical-ref? x) + ;; Only fetch definitions with single uses. + (= (lexical-refcount (lexical-ref-gensym x)) 1) + (lookup (lexical-ref-gensym x))) + => singly-used-definition) + (else x))) + (match (singly-used-definition tag) + (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) + (or () ((? constant-expression?)))) + ;; There is no way that an <abort> could know the tag + ;; for this <prompt>, so we can elide the <prompt> + ;; entirely. + (for-tail body)) + (_ + (make-prompt src (for-value tag) (for-tail body) + (for-value handler))))) + (($ <abort> src tag args tail) + (make-abort src (for-value tag) (map for-value args) + (for-value tail)))))) |