[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-70-gcf14f3
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-70-gcf14f30 |
|
Date: |
Thu, 08 Sep 2011 22:08:23 +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=cf14f3011bdb32c303ec1937a245269c100abe95
The branch, stable-2.0 has been updated
via cf14f3011bdb32c303ec1937a245269c100abe95 (commit)
via c8286111e0d149adc30687a27e5f52c9c064291a (commit)
via f9c1b8278dbf1992d83f91f91391ee39e714d364 (commit)
via 11671bbacbdd52039c77978bfe7f24a3316f6019 (commit)
from 16a3b316113b4000a39b92ddfe4c3edc16954d52 (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 cf14f3011bdb32c303ec1937a245269c100abe95
Author: Ludovic Courtès <address@hidden>
Date: Fri Sep 9 00:02:47 2011 +0200
doc: Use fashionable terminology for macros.
* doc/ref/api-macros.texi (Macros): Mention EDSLs.
commit c8286111e0d149adc30687a27e5f52c9c064291a
Author: Ludovic Courtès <address@hidden>
Date: Fri Sep 9 00:02:17 2011 +0200
Clarify `--debug' vs. `--no-debug'.
* module/ice-9/command-line.scm (*usage*): Attempt to suggest that
`--no-debug' doesn't inhibit debugging support.
* doc/ref/guile-invoke.texi (Command-line Options): Make it clear that
`--no-debug' doesn't inhibit debugging support. Reported by Manuel
Serrano.
commit f9c1b8278dbf1992d83f91f91391ee39e714d364
Author: Ludovic Courtès <address@hidden>
Date: Thu Sep 8 23:53:31 2011 +0200
Tweak `statprof.test' for faster machines.
* test-suite/tests/statprof.test ("statistical sample counts within
expected range"): Increase NUM-CALLS and the frequency so that they
are at least a few samples on my new 2.6 GHz laptop.
commit 11671bbacbdd52039c77978bfe7f24a3316f6019
Author: Ludovic Courtès <address@hidden>
Date: Fri Sep 9 00:05:34 2011 +0200
Add a partial evaluator for use in the compiler.
Thanks to William R. Cook for his excellent tutorial,
<http://softlang.uni-koblenz.de/dsl11/>.
* module/language/tree-il/optimize.scm (optimize!): Call `peval' unless
the #:partial-eval? option asks otherwise.
(peval): New procedure.
* module/language/tree-il/inline.scm: Add comment.
* module/language/tree-il/primitives.scm (*primitive-constructors*): New
variable.
(*effect-free-primitives*): Use it.
(constructor-primitive?): New primitive.
* test-suite/tests/tree-il.test (assert-tree-il->glil): Extend to
support `with-partial-evaluation', `without-partial-evaluation', and
`with-options'.
(peval): New binding.
(pass-if-peval): New macro.
("lexical refs"): Run tests without partial evaluation.
("letrec"): Likewise.
("the or hack"): Likewise.
("conditional"): Likewise, for some tests.
("sequence"): Adjust to new generated code.
("partial evaluation"): New test prefix.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-macros.texi | 8 +-
doc/ref/guile-invoke.texi | 6 +
module/ice-9/command-line.scm | 4 +-
module/language/tree-il/inline.scm | 1 +
module/language/tree-il/optimize.scm | 249 +++++++++++++++++++++++++-
module/language/tree-il/primitives.scm | 21 ++-
test-suite/tests/statprof.test | 6 +-
test-suite/tests/tree-il.test | 311 ++++++++++++++++++++++++++++++--
8 files changed, 571 insertions(+), 35 deletions(-)
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 1167650..92816ad 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -24,9 +24,15 @@ macro must appear as the first element, like this:
@end lisp
@cindex macro expansion
address@hidden domain-specific language
address@hidden embedded domain-specific language
address@hidden DSL
address@hidden EDSL
Macro expansion is a separate phase of evaluation, run before code is
interpreted or compiled. A macro is a program that runs on programs,
translating
-an embedded language into core Scheme.
+an embedded language into core address@hidden days such embedded
+languages are often referred to as @dfn{embedded domain-specific
+languages}, or EDSLs.}.
@menu
* Defining Macros:: Binding macros, globally and locally.
diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi
index 9379a8b..ccb5301 100644
--- a/doc/ref/guile-invoke.texi
+++ b/doc/ref/guile-invoke.texi
@@ -156,6 +156,12 @@ interactive session. When executing a script with
@option{-s} or
Do not use the debugging VM engine, even when entering an interactive
session.
+Note that, despite the name, Guile running with @option{--no-debug}
address@hidden support the usual debugging facilities, such as printing a
+detailed backtrace upon error. The only difference with
address@hidden is lack of support for VM hooks and the facilities that
+build upon it (see above).
+
@item -q
@cindex init file, not loading
@cindex @file{.guile} file, not loading
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index e94336a..706948f 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -122,8 +122,8 @@ If FILE begins with `-' the -s switch is mandatory.
-e FUNCTION after reading script, apply FUNCTION to
command line arguments
-ds do -s script at this point
- --debug start with debugging evaluator and backtraces
- --no-debug start with normal evaluator
+ --debug start with the \"debugging\" VM engine
+ --no-debug start with the normal VM engine, which also supports debugging
Default is to enable debugging for interactive
use, but not for `-s' and `-c'.
--auto-compile compile source files automatically
diff --git a/module/language/tree-il/inline.scm
b/module/language/tree-il/inline.scm
index de0cffc..67441ea 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -38,6 +38,7 @@
((<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)
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index dbbc216..35b1aec 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
;;; Tree-il optimizer
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 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
@@ -23,10 +23,249 @@
#: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-11)
+ #:use-module (srfi srfi-26)
#:export (optimize!))
(define (optimize! x env opts)
- (inline!
- (fix-letrec!
- (expand-primitives!
- (resolve-primitives! x env)))))
+ (let ((peval (match (memq #:partial-eval? opts)
+ ((#:partial-eval? #f _ ...)
+ ;; Disable partial evaluation.
+ identity)
+ (_ peval))))
+ (inline!
+ (fix-letrec!
+ (peval
+ (expand-primitives!
+ (resolve-primitives! x env)))))))
+
+(define* (peval exp #:optional (env vlist-null))
+ "Partially evaluate EXP in top-level environment 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 very conservative: it bails out if `set!', `prompt', etc. are
+ ;; met.
+
+ (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 (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 (make-values src values)
+ (make-application src (make-primitive-ref src 'values)
+ (map (cut make-const src <>) values)))
+
+ (define (const*? x)
+ (or (const? x) (lambda? x) (void? x)))
+
+ (define (pure-expression? x)
+ ;; Return true if X is pure---i.e., if it is known to have no
+ ;; effects and does not allocate new storage. Note: <module-ref> is
+ ;; not "pure" because it loads a module as a side-effect.
+ (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>) #t)
+ (($ <toplevel-ref>) #t)
+ (($ <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))
+ (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)))
+ (_ #f))))
+
+ (catch 'match-error
+ (lambda ()
+ (let loop ((exp exp)
+ (env vlist-null) ; static environment
+ (calls '())) ; inlined call stack
+ (define (lookup var)
+ (and=> (vhash-assq var env) cdr))
+
+ (match exp
+ (($ <const>)
+ exp)
+ (($ <void>)
+ exp)
+ (($ <lexical-ref> _ _ gensym)
+ ;; Propagate only pure expressions.
+ (let ((val (lookup gensym)))
+ (or (and (pure-expression? val) val) exp)))
+ (($ <let> src names gensyms vals body)
+ (let* ((vals (map (cut loop <> env calls) vals))
+ (body (loop body
+ (fold vhash-consq env gensyms vals)
+ calls)))
+ (if (const? body)
+ body
+ (let*-values (((stripped) (remove (compose const? car)
+ (zip vals gensyms names)))
+ ((vals gensyms names) (unzip3 stripped)))
+ (if (null? stripped)
+ body
+ (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 (cut loop <> env calls) vals))
+ (body (loop body
+ (fold vhash-consq env gensyms vals)
+ calls)))
+ (if (const? body)
+ body
+ (make-letrec src in-order? names gensyms vals body))))
+ (($ <toplevel-ref> src (? effect-free-primitive? name))
+ (if (and (not (local-toplevel? name))
+ (eq? (module-ref (current-module) name #f)
+ (module-ref the-scm-module name)))
+ (make-primitive-ref src name)
+ exp))
+ (($ <toplevel-ref>)
+ ;; todo: open private local bindings.
+ exp)
+ (($ <module-ref>)
+ exp)
+ (($ <toplevel-define> src name exp)
+ (make-toplevel-define src name (loop exp env '())))
+ (($ <primitive-ref>)
+ exp)
+ (($ <conditional> src condition subsequent alternate)
+ (let ((condition (loop condition env calls)))
+ (if (const*? condition)
+ (if (or (lambda? condition) (void? condition)
+ (const-exp condition))
+ (loop subsequent env calls)
+ (loop alternate env calls))
+ (make-conditional src condition
+ (loop subsequent env calls)
+ (loop alternate env calls)))))
+ (($ <application> src proc* args*)
+ ;; todo: augment the global env with specialized functions
+ (let* ((proc (loop proc* env calls))
+ (args (map (cut loop <> env calls) args*))
+ (app (make-application src proc args)))
+ ;; If ARGS are constants and this call hasn't already been
+ ;; expanded before (to avoid infinite recursion), then
+ ;; expand it (todo: emit an infinite recursion warning.)
+ (if (and (any const*? args)
+ (not (member (cons proc args) calls)))
+ (match proc
+ (($ <primitive-ref> _ (? effect-free-primitive? name))
+ (if (every const? args) ; only simple constants
+ (let-values (((success? values)
+ (apply-primitive name
+ (map const-exp args))))
+ (if success?
+ (match values
+ ((value)
+ (make-const src value))
+ (_
+ (make-values src values)))
+ app))
+ app))
+ (($ <primitive-ref>)
+ ;; An effectful primitive.
+ app)
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req opt #f #f inits gensyms body))
+ ;; Simple case: no rest, no keyword arguments.
+ ;; todo: handle the more complex cases
+ (let ((nargs (length args))
+ (nreq (length req))
+ (nopt (if opt (length opt) 0)))
+ (if (and (>= nargs nreq) (<= nargs (+ nreq nopt)))
+ (loop body
+ (fold vhash-consq env gensyms
+ (append args
+ (drop inits
+ (max 0
+ (- nargs
+ (+ nreq nopt))))))
+ (cons (cons proc args) calls))
+ app)))
+ (($ <lambda>)
+ app)
+ (($ <toplevel-ref>)
+ app))
+
+ ;; There are no constant arguments, so don't substitute
+ ;; lambdas---i.e., prefer (lexical f) over an inline
+ ;; copy of `f'.
+ (let ((proc (if (lambda? proc) proc* proc))
+ (args (map (lambda (raw evaled)
+ (if (lambda? evaled)
+ raw
+ evaled))
+ args*
+ args)))
+ (make-application src proc args)))))
+ (($ <lambda> src meta body)
+ (make-lambda src meta (loop body env calls)))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+ (make-lambda-case src req opt rest kw inits gensyms
+ (loop body env calls)
+ alt))
+ (($ <sequence> src exps)
+ (let ((exps (map (cut loop <> env calls) exps)))
+ (if (every pure-expression? exps)
+ (last exps)
+ (match (reverse exps)
+ ;; Remove all expressions but the last one.
+ ((keep rest ...)
+ (let ((rest (remove pure-expression? rest)))
+ (make-sequence src (reverse (cons keep rest))))))))))))
+ (lambda _
+ ;; We encountered something we don't handle, like `<lexical-set>',
+ ;; <abort>, or some other effecting construct, so bail out.
+ exp)))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index d21fc73..2627279 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -27,7 +27,8 @@
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
expand-primitives!
- effect-free-primitive? effect+exception-free-primitive?))
+ effect-free-primitive? effect+exception-free-primitive?
+ constructor-primitive?))
(define *interesting-primitive-names*
'(apply @apply
@@ -106,21 +107,24 @@
(for-each add-interesting-primitive! *interesting-primitive-names*)
+(define *primitive-constructors*
+ ;; Primitives that return a fresh object.
+ '(acons cons cons* list vector make-struct make-struct/no-tail))
+
(define *effect-free-primitives*
- '(values
+ `(values
eq? eqv? equal?
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? acons cons cons*
- list vector
+ pair? null? list? symbol? vector?
car cdr
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-ref
- struct? struct-vtable make-struct make-struct/no-tail struct-ref
+ struct? struct-vtable struct-ref
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
bytevector-s16-ref bytevector-s16-native-ref
@@ -129,7 +133,8 @@
bytevector-u64-ref bytevector-u64-native-ref
bytevector-s64-ref bytevector-s64-native-ref
bytevector-ieee-single-ref bytevector-ieee-single-native-ref
- bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+ bytevector-ieee-double-ref bytevector-ieee-double-native-ref
+ ,@*primitive-constructors*))
;; Like *effect-free-primitives* above, but further restricted in that they
;; cannot raise exceptions.
@@ -151,6 +156,8 @@
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
+(define (constructor-primitive? prim)
+ (memq prim *primitive-constructors*))
(define (effect-free-primitive? prim)
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
@@ -246,6 +253,8 @@
(define-primitive-expander zero? (x)
(= x 0))
+;; FIXME: All the code that uses `const?' is redundant with `peval'.
+
(define-primitive-expander +
() 0
(x) (values x)
diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test
index 66af55f..96acb3c 100644
--- a/test-suite/tests/statprof.test
+++ b/test-suite/tests/statprof.test
@@ -50,11 +50,11 @@
((car funcs) x)
(loop (- x 1) (cdr funcs))))))))
- (let ((num-calls 40000)
+ (let ((num-calls 20000000)
(funcs (circular-list (make-func) (make-func) (make-func))))
- ;; Run test. 10000 us == 100 Hz.
- (statprof-reset 0 10000 #f #f)
+ ;; Run test. 20000 us == 200 Hz.
+ (statprof-reset 0 20000 #f #f)
(statprof-start)
(run-test num-calls funcs)
(statprof-stop)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index cb609aa..fd9ef20 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -44,16 +44,27 @@
'out))))))
(define-syntax assert-tree-il->glil
- (syntax-rules ()
- ((_ in pat test ...)
+ (syntax-rules (with-partial-evaluation without-partial-evaluation
+ with-options)
+ ((_ with-partial-evaluation in pat test ...)
+ (assert-tree-il->glil with-options (#:partial-eval? #t)
+ in pat test ...))
+ ((_ without-partial-evaluation in pat test ...)
+ (assert-tree-il->glil with-options (#:partial-eval? #f)
+ in pat test ...))
+ ((_ with-options opts in pat test ...)
(let ((exp 'in))
(pass-if 'in
(let ((glil (unparse-glil
(compile (strip-source (parse-tree-il exp))
- #:from 'tree-il #:to 'glil))))
+ #:from 'tree-il #:to 'glil
+ #:opts 'opts))))
(pmatch glil
(pat (guard test ...) #t)
- (else #f))))))))
+ (else #f))))))
+ ((_ in pat test ...)
+ (assert-tree-il->glil with-partial-evaluation
+ in pat test ...))))
(define-syntax pass-if-tree-il->scheme
(syntax-rules ()
@@ -66,6 +77,21 @@
(pat (guard guard-exp) #t)
(_ #f))))))
+(define peval
+ ;; The partial evaluator.
+ (@@ (language tree-il optimize) peval))
+
+(define-syntax pass-if-peval
+ (syntax-rules ()
+ ((_ in pat)
+ (pass-if 'in
+ (let ((evaled (unparse-tree-il
+ (peval (compile 'in #:from 'scheme #:to 'tree-il)))))
+ (pmatch evaled
+ (pat #t)
+ (_ (pk 'peval-mismatch evaled) #f)))))))
+
+
(with-test-prefix "tree-il->scheme"
(pass-if-tree-il->scheme
(case-lambda ((a) a) ((b c) (list b c)))
@@ -107,8 +133,8 @@
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
-
- (assert-tree-il->glil
+
+ (assert-tree-il->glil without-partial-evaluation
(begin (if (toplevel foo) (const 1) (const 2)) (const #f))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch
br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1))
@@ -137,21 +163,21 @@
(call return 1))))
(with-test-prefix "lexical refs"
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (lexical x y))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call return 1)
(unbind)))
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1)
(unbind)))
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
@@ -270,7 +296,7 @@
(toplevel ref bar)
(call return 1)))
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(begin (toplevel bar) (const #f))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (call drop 1)
@@ -332,13 +358,14 @@
(const #f) (call return 1)))
(assert-tree-il->glil
+ ;; This gets simplified by `peval'.
(apply (primitive null?) (const 2))
(program () (std-prelude 0 0 #f) (label _)
- (const 2) (call null? 1) (call return 1))))
+ (const #f) (call return 1))))
(with-test-prefix "letrec"
;; simple bindings -> let
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(letrec (x y) (x1 y1) ((const 10) (const 20))
(apply (toplevel foo) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
@@ -351,7 +378,7 @@
(unbind)))
;; complex bindings -> box and set! within let
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
(apply (primitive +) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _)
@@ -367,7 +394,7 @@
(call add 2) (call return 1) (unbind)))
;; complex bindings in letrec* -> box and set! in order
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
(apply (primitive +) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
@@ -383,7 +410,7 @@
(call add 2) (call return 1) (unbind)))
;; simple bindings in letrec* -> equivalent to letrec
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(letrec* (x y) (xx yy) ((const 1) (const 2))
(lexical y yy))
(program () (std-prelude 0 1 #f) (label _)
@@ -487,9 +514,10 @@
(const #t) (call return 1)))
(assert-tree-il->glil
+ ;; This gets simplified by `peval'.
(apply (primitive null?) (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
- (const 2) (call null? 1) (call return 1))))
+ (const #f) (call return 1))))
(with-test-prefix "values"
(assert-tree-il->glil
@@ -514,7 +542,7 @@
;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case
(with-test-prefix "the or hack"
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
@@ -532,7 +560,7 @@
(eq? l1 l2))
;; second bound var is unreferenced
- (assert-tree-il->glil
+ (assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
@@ -587,6 +615,253 @@
(call tail-call 1))))
+(with-test-prefix "partial evaluation"
+
+ (pass-if-peval
+ ;; First order, primitive.
+ (let ((x 1) (y 2)) (+ x y))
+ (const 3))
+
+ (pass-if-peval
+ ;; First order, aliased primitive.
+ (let* ((x *) (y (x 1 2))) y)
+ (const 2))
+
+ (pass-if-peval
+ ;; First order, shadowed primitive.
+ (begin
+ (define (+ x y) (pk x y))
+ (+ 1 2))
+ (begin
+ (define +
+ (lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (apply (toplevel pk) (lexical x _) (lexical y _))))))
+ (apply (toplevel +) (const 1) (const 2))))
+
+ (pass-if-peval
+ ;; First-order, effects preserved.
+ (let ((x 2))
+ (do-something!)
+ x)
+ (begin
+ (apply (toplevel do-something!))
+ (const 2)))
+
+ (pass-if-peval
+ ;; First order, residual bindings removed.
+ (let ((x 2) (y 3))
+ (* (+ x y) z))
+ (apply (primitive *) (const 5) (toplevel z)))
+
+ (pass-if-peval
+ ;; First order, with lambda.
+ (define (foo x)
+ (define (bar z) (* z z))
+ (+ x (bar 3)))
+ (define foo
+ (lambda (_)
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (letrec* (bar) (_) ((lambda (_) . _))
+ (apply (primitive +) (lexical x _) (const 9))))))))
+
+ (pass-if-peval
+ ;; First order, with lambda inlined & specialized twice.
+ (let ((f (lambda (x y)
+ (+ (* x top) y)))
+ (x 2)
+ (y 3))
+ (+ (* x (f x y))
+ (f something x)))
+ (let (f) (_) ((lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (apply (primitive +)
+ (apply (primitive *)
+ (lexical x _)
+ (toplevel top))
+ (lexical y _))))))
+ (apply (primitive +)
+ (apply (primitive *)
+ (const 2)
+ (apply (primitive +) ; (f 2 3)
+ (apply (primitive *)
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (apply (primitive +) ; (f something 2)
+ (apply (primitive *)
+ (toplevel something)
+ (toplevel top))
+ (const 2)))))
+
+ (pass-if-peval
+ ;; First order, with lambda inlined & specialized 3 times.
+ (let ((f (lambda (x y) (if (> x 0) y x))))
+ (+ (f -1 x) (f 2 y) (f z y)))
+ (let (f) (_)
+ ((lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (apply (primitive >) (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _))))))
+ (apply (primitive +)
+ (const -1) ; (f -1 x)
+ (toplevel y) ; (f 2 y)
+ (apply (lexical f _) ; (f z y)
+ (toplevel z) (toplevel y)))))
+
+ (pass-if-peval
+ ;; First order, conditional.
+ (let ((y 2))
+ (lambda (x)
+ (if (> y 0)
+ (display x)
+ 'never-reached)))
+ (lambda ()
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (apply (toplevel display) (lexical x _))))))
+
+ (pass-if-peval
+ ;; First order, recursive procedure.
+ (letrec ((fibo (lambda (n)
+ (if (<= n 1)
+ n
+ (+ (fibo (- n 1))
+ (fibo (- n 2)))))))
+ (fibo 7))
+ (const 13))
+
+ (pass-if-peval
+ ;; Higher order.
+ ((lambda (f x)
+ (f (* (car x) (cadr x))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 7))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (default value).
+ ((lambda* (f x #:optional (y 0))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 7))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (caller-supplied value).
+ ((lambda* (f x #:optional (y 0))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ 35)
+ (const 42))
+
+ (pass-if-peval
+ ;; Higher order, mutually recursive procedures.
+ (letrec ((even? (lambda (x)
+ (or (= 0 x)
+ (odd? (- x 1)))))
+ (odd? (lambda (x)
+ (not (even? (- x 1))))))
+ (and (even? 4) (odd? 7)))
+ (const #t))
+
+ ;;
+ ;; Below are cases where constant propagation should bail out.
+ ;;
+
+ (pass-if-peval
+ ;; Non-constant lexical is not propagated.
+ (let ((v (make-vector 6 #f)))
+ (lambda (n)
+ (vector-set! v n n)))
+ (let (v) (_)
+ ((apply (toplevel make-vector) (const 6) (const #f)))
+ (lambda ()
+ (lambda-case
+ (((n) #f #f #f () (_))
+ (apply (toplevel vector-set!)
+ (lexical v _) (lexical n _) (lexical n _)))))))
+
+ (pass-if-peval
+ ;; Lexical that is not provably pure is not inlined nor propagated.
+ (let* ((x (if (> p q) (frob!) (display 'chbouib)))
+ (y (* x 2)))
+ (+ x x y))
+ (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
+ (apply (toplevel frob!))
+ (apply (toplevel display) (const chbouib))))
+ (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
+ (apply (primitive +) (lexical x _) (lexical x _)
+ (apply (primitive *) (lexical x _) (const 2))))))
+
+ (pass-if-peval
+ ;; Procedure only called with non-constant args is not inlined.
+ (let* ((g (lambda (x y) (+ x y)))
+ (f (lambda (g x) (g x x))))
+ (+ (f g foo) (f g bar)))
+ (let (g) (_)
+ ((lambda _ ; g
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (apply (primitive +) (lexical x _) (lexical y _))))))
+ (let (f) (_)
+ ((lambda _ ; f
+ (lambda-case
+ (((g x) #f #f #f () (_ _))
+ (apply (lexical g _) (lexical x _) (lexical x _))))))
+ (apply (primitive +)
+ (apply (lexical g _) (toplevel foo) (toplevel foo))
+ (apply (lexical g _) (toplevel bar) (toplevel bar))))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (let ((x 2))
+ (set! x 3)
+ x)
+ (let (x) (_) ((const 2))
+ (begin
+ (set! (lexical x _) (const 3))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (letrec ((x 0)
+ (f (lambda ()
+ (set! x (+ 1 x))
+ x)))
+ (frob f) ; may mutate `x'
+ x)
+ (letrec (x f) (_ _) ((const 0) _)
+ (begin
+ (apply (toplevel frob) (lexical f _))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (letrec ((f (lambda (x)
+ (set! f (lambda (_) x))
+ x)))
+ (f 2))
+ (letrec _ . _))
+
+ (pass-if-peval
+ ;; Infinite recursion: `peval' gives up and leaves it as is.
+ (letrec ((f (lambda (x) (g (1- x))))
+ (g (lambda (x) (h (1+ x))))
+ (h (lambda (x) (f x))))
+ (f 0))
+ (letrec _ . _)))
+
+
(with-test-prefix "tree-il-fold"
(pass-if "empty tree"
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-70-gcf14f30,
Ludovic Courtès <=