[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-137-gb275f
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-137-gb275fb2 |
|
Date: |
Wed, 28 Sep 2011 17:39:58 +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=b275fb2691af150cc57e395e65df5a66e315017e
The branch, stable-2.0 has been updated
via b275fb2691af150cc57e395e65df5a66e315017e (commit)
from df40b969780df2979f9f5e1c9ae8b9d6f09dbd9a (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 b275fb2691af150cc57e395e65df5a66e315017e
Author: Andy Wingo <address@hidden>
Date: Wed Sep 28 19:39:25 2011 +0200
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.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 6 +-
module/language/tree-il/canonicalize.scm | 86 ++
module/language/tree-il/compile-glil.scm | 2 +
module/language/tree-il/inline.scm | 201 +----
module/language/tree-il/optimize.scm | 964 +-------------------
.../language/tree-il/{optimize.scm => peval.scm} | 60 +--
6 files changed, 104 insertions(+), 1215 deletions(-)
create mode 100644 module/language/tree-il/canonicalize.scm
copy module/language/tree-il/{optimize.scm => peval.scm} (95%)
diff --git a/module/Makefile.am b/module/Makefile.am
index 0787f20..6b265b6 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 0000000..04f5612
--- /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 518823d..3daac7f 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 67441ea..5a2d9af 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 fee629a..cb19905 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/optimize.scm
b/module/language/tree-il/peval.scm
similarity index 95%
copy from module/language/tree-il/optimize.scm
copy to module/language/tree-il/peval.scm
index fee629a..a097dd4 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
-;;; Tree-il optimizer
+;;; Tree-IL partial evaluator
-;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
+;; 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
@@ -16,33 +16,17 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-;;; Code:
-
-(define-module (language tree-il optimize)
+(define-module (language tree-il peval)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language tree-il inline)
- #: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)
- (let ((peval (match (memq #:partial-eval? opts)
- ((#:partial-eval? #f _ ...)
- ;; Disable partial evaluation.
- (lambda (x e) x))
- (_ peval))))
- (inline!
- (fix-letrec!
- (peval (expand-primitives! (resolve-primitives! x env))
- env)))))
-
-
+ #:export (peval))
+
;;;
;;; Partial evaluation.
;;;
@@ -952,26 +936,6 @@ it does not handle <fix> and <let-values>, it should be
called before
(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?))))
@@ -980,18 +944,8 @@ it does not handle <fix> and <let-values>, it should be
called before
;; 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)))))
+ (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))))))
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-137-gb275fb2,
Andy Wingo <=