mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-21 03:00:19 +02:00
Code Activity

Add a partial evaluator for use in the compiler.

Browse source 
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 2011-09-09 00:05:34 +02:00
parent 16a3b31611
commit 11671bbacb
4 changed files with 553 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

1
module/language/tree-il/inline.scm
View file

@ -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)

249
module/language/tree-il/optimize.scm
View file

@ -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)))

21
module/language/tree-il/primitives.scm
View file

@ -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)