mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-28 16:00:22 +02:00
Merge commit '1cd63115be
'
Conflicts: module/language/tree-il/peval.scm test-suite/tests/peval.test
This commit is contained in:
commit
79d29f96c7
4 changed files with 361 additions and 60 deletions
|
@ -96,6 +96,7 @@ SCHEME_LANG_SOURCES = \
|
|||
TREE_IL_LANG_SOURCES = \
|
||||
language/tree-il/primitives.scm \
|
||||
language/tree-il/peval.scm \
|
||||
language/tree-il/effects.scm \
|
||||
language/tree-il/fix-letrec.scm \
|
||||
language/tree-il/optimize.scm \
|
||||
language/tree-il/canonicalize.scm \
|
||||
|
|
329
module/language/tree-il/effects.scm
Normal file
329
module/language/tree-il/effects.scm
Normal file
|
@ -0,0 +1,329 @@
|
|||
;;; Effects analysis on Tree-IL
|
||||
|
||||
;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
|
||||
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This library is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
(define-module (language tree-il effects)
|
||||
#:use-module (language tree-il)
|
||||
#:use-module (language tree-il primitives)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (make-effects-analyzer
|
||||
&mutable-lexical
|
||||
&toplevel
|
||||
&fluid
|
||||
&definite-bailout
|
||||
&possible-bailout
|
||||
&zero-values
|
||||
&allocation
|
||||
&mutable-data
|
||||
&type-check
|
||||
&all-effects
|
||||
effects-commute?
|
||||
exclude-effects
|
||||
effect-free?
|
||||
constant?
|
||||
depends-on-effects?
|
||||
causes-effects?))
|
||||
|
||||
;;;
|
||||
;;; Hey, it's some effects analysis! If you invoke
|
||||
;;; `make-effects-analyzer', you get a procedure that computes the set
|
||||
;;; of effects that an expression depends on and causes. This
|
||||
;;; information is useful when writing algorithms that move code around,
|
||||
;;; while preserving the semantics of an input program.
|
||||
;;;
|
||||
;;; The effects set is represented by a bitfield, as a fixnum. The set
|
||||
;;; of possible effects is modelled rather coarsely. For example, a
|
||||
;;; toplevel reference to FOO is modelled as depending on the &toplevel
|
||||
;;; effect, and causing a &type-check effect. If any intervening code
|
||||
;;; sets any toplevel variable, that will block motion of FOO.
|
||||
;;;
|
||||
;;; For each effect, two bits are reserved: one to indicate that an
|
||||
;;; expression depends on the effect, and the other to indicate that an
|
||||
;;; expression causes the effect.
|
||||
;;;
|
||||
|
||||
(define-syntax define-effects
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_ all name ...)
|
||||
(with-syntax (((n ...) (iota (length #'(name ...)))))
|
||||
#'(begin
|
||||
(define name (ash 1 (* n 2)))
|
||||
...
|
||||
(define all (logior name ...))))))))
|
||||
|
||||
;; Here we define the effects, indicating the meaning of the effect.
|
||||
;;
|
||||
;; Effects that are described in a "depends on" sense can also be used
|
||||
;; in the "causes" sense.
|
||||
;;
|
||||
;; Effects that are described as causing an effect are not usually used
|
||||
;; in a "depends-on" sense. Although the "depends-on" sense is used
|
||||
;; when checking for the existence of the "causes" effect, the effects
|
||||
;; analyzer will not associate the "depends-on" sense of these effects
|
||||
;; with any expression.
|
||||
;;
|
||||
(define-effects &all-effects
|
||||
;; Indicates that an expression depends on the value of a mutable
|
||||
;; lexical variable.
|
||||
&mutable-lexical
|
||||
|
||||
;; Indicates that an expression depends on the value of a toplevel
|
||||
;; variable.
|
||||
&toplevel
|
||||
|
||||
;; Indicates that an expression depends on the value of a fluid
|
||||
;; variable.
|
||||
&fluid
|
||||
|
||||
;; Indicates that an expression definitely causes a non-local,
|
||||
;; non-resumable exit -- a bailout. Only used in the "changes" sense.
|
||||
&definite-bailout
|
||||
|
||||
;; Indicates that an expression may cause a bailout.
|
||||
&possible-bailout
|
||||
|
||||
;; Indicates than an expression may return zero values -- a "causes"
|
||||
;; effect.
|
||||
&zero-values
|
||||
|
||||
;; Indicates that an expression may return a fresh object -- a
|
||||
;; "causes" effect.
|
||||
&allocation
|
||||
|
||||
;; Indicates that an expression depends on the value of a mutable data
|
||||
;; structure.
|
||||
&mutable-data
|
||||
|
||||
;; Indicates that an expression may cause a type check. A type check,
|
||||
;; for the purposes of this analysis, is the possibility of throwing
|
||||
;; an exception the first time an expression is evaluated. If the
|
||||
;; expression did not cause an exception to be thrown, users can
|
||||
;; assume that evaluating the expression again will not cause an
|
||||
;; exception to be thrown.
|
||||
;;
|
||||
;; For example, (+ x y) might throw if X or Y are not numbers. But if
|
||||
;; it doesn't throw, it should be safe to elide a dominated, common
|
||||
;; subexpression (+ x y).
|
||||
&type-check)
|
||||
|
||||
(define &no-effects 0)
|
||||
|
||||
;; Definite bailout is an oddball effect. Since it indicates that an
|
||||
;; expression definitely causes bailout, it's not in the set of effects
|
||||
;; of a call to an unknown procedure. At the same time, it's also
|
||||
;; special in that a definite bailout in a subexpression doesn't always
|
||||
;; cause an outer expression to include &definite-bailout in its
|
||||
;; effects. For that reason we have to treat it specially.
|
||||
;;
|
||||
(define &all-effects-but-bailout
|
||||
(logand &all-effects (lognot &definite-bailout)))
|
||||
|
||||
(define (cause effect)
|
||||
(ash effect 1))
|
||||
|
||||
(define (&depends-on a)
|
||||
(logand a &all-effects))
|
||||
(define (&causes a)
|
||||
(logand a (cause &all-effects)))
|
||||
|
||||
(define (exclude-effects effects exclude)
|
||||
(logand effects (lognot (cause exclude))))
|
||||
(define (effect-free? effects)
|
||||
(zero? (&causes effects)))
|
||||
(define (constant? effects)
|
||||
(zero? effects))
|
||||
|
||||
(define (depends-on-effects? x effects)
|
||||
(not (zero? (logand (&depends-on x) effects))))
|
||||
(define (causes-effects? x effects)
|
||||
(not (zero? (logand (&causes x) (cause effects)))))
|
||||
|
||||
(define (effects-commute? a b)
|
||||
(and (not (causes-effects? a (&depends-on b)))
|
||||
(not (causes-effects? b (&depends-on a)))))
|
||||
|
||||
(define (make-effects-analyzer assigned-lexical?)
|
||||
"Returns a procedure of type EXP -> EFFECTS that analyzes the effects
|
||||
of an expression."
|
||||
|
||||
(define compute-effects
|
||||
(let ((cache (make-hash-table)))
|
||||
(lambda (exp)
|
||||
(or (hashq-ref cache exp)
|
||||
(let ((effects (visit exp)))
|
||||
(hashq-set! cache exp effects)
|
||||
effects)))))
|
||||
|
||||
(define (accumulate-effects exps)
|
||||
(let lp ((exps exps) (out &no-effects))
|
||||
(if (null? exps)
|
||||
out
|
||||
(lp (cdr exps) (logior out (compute-effects (car exps)))))))
|
||||
|
||||
(define (visit exp)
|
||||
(match exp
|
||||
(($ <const>)
|
||||
&no-effects)
|
||||
(($ <void>)
|
||||
&no-effects)
|
||||
(($ <lexical-ref> _ _ gensym)
|
||||
(if (assigned-lexical? gensym)
|
||||
&mutable-lexical
|
||||
&no-effects))
|
||||
(($ <lexical-set> _ name gensym exp)
|
||||
(logior (cause &mutable-lexical)
|
||||
(compute-effects exp)))
|
||||
(($ <let> _ names gensyms vals body)
|
||||
(logior (if (or-map assigned-lexical? gensyms)
|
||||
(cause &allocation)
|
||||
&no-effects)
|
||||
(accumulate-effects vals)
|
||||
(compute-effects body)))
|
||||
(($ <letrec> _ in-order? names gensyms vals body)
|
||||
(logior (if (or-map assigned-lexical? gensyms)
|
||||
(cause &allocation)
|
||||
&no-effects)
|
||||
(accumulate-effects vals)
|
||||
(compute-effects body)))
|
||||
(($ <fix> _ names gensyms vals body)
|
||||
(logior (if (or-map assigned-lexical? gensyms)
|
||||
(cause &allocation)
|
||||
&no-effects)
|
||||
(accumulate-effects vals)
|
||||
(compute-effects body)))
|
||||
(($ <let-values> _ producer consumer)
|
||||
(logior (compute-effects producer)
|
||||
(compute-effects consumer)
|
||||
(cause &type-check)))
|
||||
(($ <dynwind> _ winder pre body post unwinder)
|
||||
(logior (compute-effects winder)
|
||||
(compute-effects pre)
|
||||
(compute-effects body)
|
||||
(compute-effects post)
|
||||
(compute-effects unwinder)))
|
||||
(($ <dynlet> _ fluids vals body)
|
||||
(logior (accumulate-effects fluids)
|
||||
(accumulate-effects vals)
|
||||
(cause &type-check)
|
||||
(cause &fluid)
|
||||
(compute-effects body)))
|
||||
(($ <dynref> _ fluid)
|
||||
(logior (compute-effects fluid)
|
||||
(cause &type-check)
|
||||
&fluid))
|
||||
(($ <dynset> _ fluid exp)
|
||||
(logior (compute-effects fluid)
|
||||
(compute-effects exp)
|
||||
(cause &type-check)
|
||||
(cause &fluid)))
|
||||
(($ <toplevel-ref>)
|
||||
(logior &toplevel
|
||||
(cause &type-check)))
|
||||
(($ <module-ref>)
|
||||
(logior &toplevel
|
||||
(cause &type-check)))
|
||||
(($ <module-set> _ mod name public? exp)
|
||||
(logior (cause &toplevel)
|
||||
(cause &type-check)
|
||||
(compute-effects exp)))
|
||||
(($ <toplevel-define> _ name exp)
|
||||
(logior (cause &toplevel)
|
||||
(compute-effects exp)))
|
||||
(($ <toplevel-set> _ name exp)
|
||||
(logior (cause &toplevel)
|
||||
(compute-effects exp)))
|
||||
(($ <primitive-ref>)
|
||||
&no-effects)
|
||||
(($ <conditional> _ test consequent alternate)
|
||||
(let ((tfx (compute-effects test))
|
||||
(cfx (compute-effects consequent))
|
||||
(afx (compute-effects alternate)))
|
||||
(if (causes-effects? (logior tfx (logand afx cfx))
|
||||
&definite-bailout)
|
||||
(logior tfx cfx afx)
|
||||
(exclude-effects (logior tfx cfx afx)
|
||||
&definite-bailout))))
|
||||
|
||||
;; Zero values.
|
||||
(($ <primcall> _ 'values ())
|
||||
(cause &zero-values))
|
||||
|
||||
;; Effect-free primitives.
|
||||
(($ <primcall> _ (and name (? effect+exception-free-primitive?)) args)
|
||||
(logior (accumulate-effects args)
|
||||
(if (constructor-primitive? name)
|
||||
(cause &allocation)
|
||||
&no-effects)))
|
||||
(($ <primcall> _ (and name (? effect-free-primitive?)) args)
|
||||
(logior (accumulate-effects args)
|
||||
(cause &type-check)
|
||||
(if (constructor-primitive? name)
|
||||
(cause &allocation)
|
||||
(if (accessor-primitive? name)
|
||||
&mutable-data
|
||||
&no-effects))))
|
||||
|
||||
;; Lambda applications might throw wrong-number-of-args.
|
||||
(($ <call> _ ($ <lambda> _ _ body) args)
|
||||
(logior (compute-effects body)
|
||||
(accumulate-effects args)
|
||||
(cause &type-check)))
|
||||
|
||||
;; Bailout primitives.
|
||||
(($ <primcall> _ (? bailout-primitive? name) args)
|
||||
(logior (accumulate-effects args)
|
||||
(cause &definite-bailout)
|
||||
(cause &possible-bailout)))
|
||||
|
||||
;; A call to an unknown procedure can do anything.
|
||||
(($ <primcall> _ name args)
|
||||
(logior &all-effects-but-bailout
|
||||
(cause &all-effects-but-bailout)))
|
||||
(($ <call> _ proc args)
|
||||
(logior &all-effects-but-bailout
|
||||
(cause &all-effects-but-bailout)))
|
||||
|
||||
(($ <lambda> _ meta body)
|
||||
&no-effects)
|
||||
(($ <lambda-case> _ req opt rest kw inits gensyms body alt)
|
||||
(logior (exclude-effects (accumulate-effects inits)
|
||||
&definite-bailout)
|
||||
(if (or-map assigned-lexical? gensyms)
|
||||
(cause &allocation)
|
||||
&no-effects)
|
||||
(compute-effects body)
|
||||
(if alt (compute-effects alt) &no-effects)))
|
||||
|
||||
(($ <seq> _ head tail)
|
||||
(logior
|
||||
;; Returning zero values to a for-effect continuation is
|
||||
;; not observable.
|
||||
(exclude-effects (compute-effects head)
|
||||
(cause &zero-values))
|
||||
(compute-effects tail)))
|
||||
|
||||
(($ <prompt> _ tag body handler)
|
||||
(logior (compute-effects tag)
|
||||
(compute-effects body)
|
||||
(compute-effects handler)))
|
||||
|
||||
(($ <abort> _ tag args tail)
|
||||
(logior &all-effects-but-bailout
|
||||
(cause &all-effects-but-bailout)))))
|
||||
|
||||
compute-effects)
|
|
@ -19,6 +19,7 @@
|
|||
(define-module (language tree-il peval)
|
||||
#:use-module (language tree-il)
|
||||
#:use-module (language tree-il primitives)
|
||||
#:use-module (language tree-il effects)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
|
@ -298,12 +299,13 @@
|
|||
(constant-value operand-constant-value set-operand-constant-value!))
|
||||
|
||||
(define* (make-operand var sym #:optional source visit)
|
||||
;; Bind SYM to VAR, with value SOURCE. Bound operands are considered
|
||||
;; copyable until we prove otherwise. If we have a source expression,
|
||||
;; truncate it to one value. Copy propagation does not work on
|
||||
;; multiply-valued expressions.
|
||||
;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are
|
||||
;; considered copyable until we prove otherwise. If we have a source
|
||||
;; expression, truncate it to one value. Copy propagation does not
|
||||
;; work on multiply-valued expressions.
|
||||
(let ((source (and=> source truncate-values)))
|
||||
(%make-operand var sym visit source 0 #f (and source #t) #f #f)))
|
||||
(%make-operand var sym visit source 0 #f
|
||||
(and source (not (var-set? var))) #f #f)))
|
||||
|
||||
(define (make-bound-operands vars syms sources visit)
|
||||
(map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
|
||||
|
@ -555,52 +557,15 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(let ((tail (loop tail)))
|
||||
(and tail (make-seq src head tail)))))))
|
||||
|
||||
(define compute-effects
|
||||
(make-effects-analyzer assigned-lexical?))
|
||||
|
||||
(define (constant-expression? x)
|
||||
;; Return true if X is constant, for the purposes of copying or
|
||||
;; elision---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 syms body alternate)
|
||||
(and (not (any assigned-lexical? syms))
|
||||
(every loop inits) (loop body)
|
||||
(or (not alternate) (loop alternate))))
|
||||
(($ <lexical-ref> _ _ gensym)
|
||||
(not (assigned-lexical? gensym)))
|
||||
(($ <primitive-ref>) #t)
|
||||
(($ <conditional> _ condition subsequent alternate)
|
||||
(and (loop condition) (loop subsequent) (loop alternate)))
|
||||
(($ <primcall> _ 'values exps)
|
||||
(and (not (null? exps))
|
||||
(every loop exps)))
|
||||
(($ <primcall> _ name args)
|
||||
(and (effect-free-primitive? name)
|
||||
(not (constructor-primitive? name))
|
||||
(types-check? name args)
|
||||
(if (accessor-primitive? name)
|
||||
(every const? args)
|
||||
(every loop args))))
|
||||
(($ <call> _ ($ <lambda> _ _ body) args)
|
||||
(and (loop body) (every loop args)))
|
||||
(($ <seq> _ head tail)
|
||||
(and (loop head) (loop tail)))
|
||||
(($ <let> _ _ syms vals body)
|
||||
(and (not (any assigned-lexical? syms))
|
||||
(every loop vals) (loop body)))
|
||||
(($ <letrec> _ _ _ syms vals body)
|
||||
(and (not (any assigned-lexical? syms))
|
||||
(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))))
|
||||
(constant? (compute-effects x)))
|
||||
|
||||
(define (prune-bindings ops in-order? body counter ctx build-result)
|
||||
;; This helper handles both `let' and `letrec'/`fix'. In the latter
|
||||
|
@ -940,14 +905,20 @@ top-level bindings from ENV and return the resulting expression."
|
|||
((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)))))
|
||||
(match (for-test condition)
|
||||
(($ <const> _ val)
|
||||
(if val
|
||||
(for-tail subsequent)
|
||||
(for-tail alternate)))
|
||||
;; Swap the arms of (if (not FOO) A B), to simplify.
|
||||
(($ <primcall> _ 'not (c))
|
||||
(make-conditional src c
|
||||
(for-tail alternate)
|
||||
(for-tail subsequent)))
|
||||
(c
|
||||
(make-conditional src c
|
||||
(for-tail subsequent)
|
||||
(for-tail alternate)))))
|
||||
(($ <primcall> src '@call-with-values
|
||||
(producer
|
||||
($ <lambda> _ _
|
||||
|
|
|
@ -760,15 +760,15 @@
|
|||
;; This test checks that the `start' binding is indeed residualized.
|
||||
;; See the `referenced?' procedure in peval's `prune-bindings'.
|
||||
(let ((pos 0))
|
||||
(set! pos 1) ;; Cause references to `pos' to residualize.
|
||||
(let ((here (let ((start pos)) (lambda () start))))
|
||||
(set! pos 1) ;; Cause references to `pos' to residualize.
|
||||
(here)))
|
||||
(let (pos) (_) ((const 0))
|
||||
(seq
|
||||
(set! (lexical pos _) (const 1))
|
||||
(let (here) (_) (_)
|
||||
(call (lexical here _))))))
|
||||
|
||||
(let (here) (_) (_)
|
||||
(seq
|
||||
(set! (lexical pos _) (const 1))
|
||||
(call (lexical here _))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; FIXME: should this one residualize the binding?
|
||||
(letrec ((a a))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue