[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-146-g01249
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-146-g012492a |
|
Date: |
Fri, 07 Oct 2011 23:46:39 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=012492a7f1968bb996a98864da32591bffbf08a3
The branch, stable-2.0 has been updated
via 012492a7f1968bb996a98864da32591bffbf08a3 (commit)
via 6d2d68972144e795a53067f1c08c13be01559784 (commit)
via 904981ee417afea6f1ed4a244dd275e78a6a4b8d (commit)
via 47974c308a27c6327696b1c21bfde00fe78fd3a9 (commit)
from 6d5f8c324e6c5f4fda155329eab6dade43ac5ffe (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 012492a7f1968bb996a98864da32591bffbf08a3
Author: Andy Wingo <address@hidden>
Date: Thu Oct 6 23:28:06 2011 +0200
optimizer verifies its output
* module/language/tree-il/optimize.scm: Verify the result of partial
evaluation.
commit 6d2d68972144e795a53067f1c08c13be01559784
Author: Andy Wingo <address@hidden>
Date: Thu Oct 6 23:27:43 2011 +0200
add tree-il verifier
* module/Makefile.am: Add debug.scm.
* module/language/tree-il/debug.scm: New file, a verifier for tree-il.
commit 904981ee417afea6f1ed4a244dd275e78a6a4b8d
Author: Andy Wingo <address@hidden>
Date: Thu Oct 6 12:14:10 2011 +0200
peval refactor
* module/language/tree-il/peval.scm (peval): Refactor the for-value, etc
helpers.
commit 47974c308a27c6327696b1c21bfde00fe78fd3a9
Author: Andy Wingo <address@hidden>
Date: Thu Oct 6 10:39:14 2011 +0200
comment peval.scm
* module/language/tree-il/peval.scm: Add comments. Move alpha-rename
later in the file.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 1 +
module/language/tree-il/debug.scm | 261 ++++++++++++++++++++++++++
module/language/tree-il/optimize.scm | 6 +-
module/language/tree-il/peval.scm | 338 ++++++++++++++++++++--------------
4 files changed, 469 insertions(+), 137 deletions(-)
create mode 100644 module/language/tree-il/debug.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 6b265b6..b93d8d3 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -98,6 +98,7 @@ TREE_IL_LANG_SOURCES =
\
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
language/tree-il/compile-glil.scm \
+ language/tree-il/debug.scm \
language/tree-il/spec.scm
GLIL_LANG_SOURCES = \
diff --git a/module/language/tree-il/debug.scm
b/module/language/tree-il/debug.scm
new file mode 100644
index 0000000..78f1324
--- /dev/null
+++ b/module/language/tree-il/debug.scm
@@ -0,0 +1,261 @@
+;;; Tree-IL verifier
+
+;; 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 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))
+ ((not (lambda-case? body))
+ (error "lambda body should be lambda-case" exp))
+ (else
+ (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))))
+ (($ <dynlet> src fluids vals body)
+ (cond
+ ((not (list? fluids))
+ (error "fluids should be list" exp))
+ ((not (list? vals))
+ (error "vals should be list" exp))
+ ((not (= (length fluids) (length vals)))
+ (error "mismatch in fluids/vals" exp))
+ (else
+ (for-each (cut visit <> env) fluids)
+ (for-each (cut visit <> env) vals)
+ (visit body env))))
+ (($ <dynwind> src winder body unwinder)
+ (visit winder env)
+ (visit body env)
+ (visit unwinder env))
+ (($ <dynref> src fluid)
+ (visit fluid env))
+ (($ <dynset> src fluid exp)
+ (visit fluid env)
+ (visit exp env))
+ (($ <conditional> src condition subsequent alternate)
+ (visit condition env)
+ (visit subsequent env)
+ (visit alternate env))
+ (($ <application> src proc args)
+ (cond
+ ((not (list? args))
+ (error "expected list of args" args))
+ (else
+ (visit proc env)
+ (for-each (cut visit <> env) args))))
+ (($ <sequence> src exps)
+ (cond
+ ((not (list? exps))
+ (error "expected list of exps" exp))
+ ((null? exps)
+ (error "expected more than one exp" exp))
+ (else
+ (for-each (cut visit <> env) exps))))
+ (($ <prompt> src tag body handler)
+ (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/optimize.scm
b/module/language/tree-il/optimize.scm
index cb19905..baac915 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -23,6 +23,7 @@
#: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!))
@@ -33,5 +34,6 @@
(lambda (x e) x))
(_ peval))))
(fix-letrec!
- (peval (expand-primitives! (resolve-primitives! x env))
- env))))
+ (verify-tree-il
+ (peval (expand-primitives! (resolve-primitives! x env))
+ env)))))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index c05a2be..aadba24 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -28,126 +28,24 @@
#:export (peval))
;;;
-;;; Partial evaluation.
+;;; 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/.
;;;
-(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))))))
-
+;; First, some helpers.
+;;
(define-syntax-rule (let/ec k e e* ...)
(let ((tag (make-prompt-tag)))
(call-with-prompt
@@ -175,6 +73,14 @@ references to the new symbols."
(or (proc (vlist-ref vlist i))
(lp (1+ i)))))))
+;; 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.
+;;
+;; If peval introduces more code, via copy-propagation, it will need to
+;; run `build-var-table' on the new code to add to make sure it can find
+;; a <var> for each gensym bound in the program.
+;;
(define-record-type <var>
(make-var name gensym refcount set?)
var?
@@ -208,6 +114,40 @@ references to the new symbols."
(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?
@@ -290,6 +230,127 @@ references to the new symbols."
;; FIXME: add more cases?
(else #f)))
+(define (fresh-gensyms syms)
+ (map (lambda (x) (gensym (string-append (symbol->string x) " ")))
+ syms))
+
+;; Copy propagation of terms that bind variables, like `lambda' terms,
+;; will need to bind fresh variables. This procedure renames all the
+;; lexicals in a term.
+;;
+(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* (peval exp #:optional (cenv (current-module)) (env vlist-null)
#:key
(operator-size-limit 40)
@@ -298,18 +359,18 @@ references to the new symbols."
(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'."
+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, but not across top-level bindings---there should be a way
- ;; to allow this (TODO).
+ ;; inlining.
+
+ ;; 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.
+ ;; 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.
@@ -329,6 +390,9 @@ it does not handle <fix> and <let-values>, it should be
called before
(define (local-toplevel? name)
(vhash-assq name local-toplevel-env))
+ ;; gensym -> <var>
+ ;; renamed-term -> original-term
+ ;;
(define store (build-var-table exp))
(define (assigned-lexical? sym)
@@ -339,12 +403,18 @@ it does not handle <fix> and <let-values>, it should be
called before
(let ((v (vhash-assq sym store)))
(if v (var-refcount (cdr v)) 0)))
+ ;; 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)
(build-var-table new 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)))
@@ -531,17 +601,15 @@ it does not handle <fix> and <let-values>, it should be
called before
(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)
+ (define (visit exp ctx)
(loop exp env counter ctx))
+ (define (for-value exp) (visit exp 'value))
+ (define (for-operand exp) (visit exp 'operand))
+ (define (for-test exp) (visit exp 'test))
+ (define (for-effect exp) (visit exp 'effect))
+ (define (for-tail exp) (visit exp ctx))
+
(if counter
(record-effort! counter))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-146-g012492a,
Andy Wingo <=