mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 00:40:20 +02:00
Code Activity

peval uses effects analysis

Browse source 
* module/language/tree-il/peval.scm: Use effects analysis from (language
  tree-il effects) instead of our own constant-expression?.  Eagerly
  mark assigned lexicals as non-copyable.
This commit is contained in:
Andy Wingo 2012-04-12 16:46:18 -07:00
parent da9b2b71f7
commit a36e7870c3
1 changed files with 25 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

78
module/language/tree-il/peval.scm
View file

@ -19,6 +19,7 @@
(define-module (language tree-il peval) (define-module (language tree-il peval)
#:use-module (language tree-il) #:use-module (language tree-il)
#:use-module (language tree-il primitives) #:use-module (language tree-il primitives)
#:use-module (language tree-il effects)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -301,12 +302,13 @@
(constant-value operand-constant-value set-operand-constant-value!)) (constant-value operand-constant-value set-operand-constant-value!))
(define* (make-operand var sym #:optional source visit) (define* (make-operand var sym #:optional source visit)
;; Bind SYM to VAR, with value SOURCE. Bound operands are considered ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are
;; copyable until we prove otherwise. If we have a source expression, ;; considered copyable until we prove otherwise. If we have a source
;; truncate it to one value. Copy propagation does not work on ;; expression, truncate it to one value. Copy propagation does not
;; multiply-valued expressions. ;; work on multiply-valued expressions.
(let ((source (and=> source truncate-values))) (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) (define (make-bound-operands vars syms sources visit)
(map (lambda (x y z) (make-operand x y z visit)) vars syms sources)) (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
@ -566,51 +568,15 @@ top-level bindings from ENV and return the resulting expression."
(and tail (and tail
(make-sequence src (append head (list tail))))))))))) (make-sequence src (append head (list tail)))))))))))
(define compute-effects
(make-effects-analyzer assigned-lexical?))
(define (constant-expression? x) (define (constant-expression? x)
;; Return true if X is constant, for the purposes of copying or ;; 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 ;; elision---i.e., if it is known to have no effects, does not
;; allocate storage for a mutable object, and does not access ;; allocate storage for a mutable object, and does not access
;; mutable data (like `car' or toplevel references). ;; mutable data (like `car' or toplevel references).
(let loop ((x x)) (constant? (compute-effects 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)))
(($ <application> _ ($ <primitive-ref> _ 'values) exps)
(and (not (null? exps))
(every loop exps)))
(($ <application> _ ($ <primitive-ref> _ name) args)
(and (effect-free-primitive? name)
(not (constructor-primitive? name))
(not (accessor-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> _ _ 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))))
(define (prune-bindings ops in-order? body counter ctx build-result) (define (prune-bindings ops in-order? body counter ctx build-result)
;; This helper handles both `let' and `letrec'/`fix'. In the latter ;; This helper handles both `let' and `letrec'/`fix'. In the latter
@ -985,14 +951,20 @@ top-level bindings from ENV and return the resulting expression."
((test) (make-const #f #t)) ((test) (make-const #f #t))
(else exp))) (else exp)))
(($ <conditional> src condition subsequent alternate) (($ <conditional> src condition subsequent alternate)
(let ((condition (for-test condition))) (match (for-test condition)
(if (const? condition) (($ <const> _ val)
(if (const-exp condition) (if val
(for-tail subsequent) (for-tail subsequent)
(for-tail alternate)) (for-tail alternate)))
(make-conditional src condition ;; Swap the arms of (if (not FOO) A B), to simplify.
(for-tail subsequent) (($ <application> _ ($ <primitive-ref> _ 'not) (c))
(for-tail alternate))))) (make-conditional src c
(for-tail alternate)
(for-tail subsequent)))
(c
(make-conditional src c
(for-tail subsequent)
(for-tail alternate)))))
(($ <application> src (($ <application> src
($ <primitive-ref> _ '@call-with-values) ($ <primitive-ref> _ '@call-with-values)
(producer (producer