mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-21 03:00:19 +02:00
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.
This commit is contained in:
Ludovic Courtès
parent
16a3b31611
commit
11671bbacb
4 changed files with 553 additions and 29 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(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)))))
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -108,7 +134,7 @@
|
|||
(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)
|
||||
|
|
@ -586,6 +614,253 @@
|
|||
(toplevel ref bar) (call call/cc 1)
|
||||
(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"
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue