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

Prepare for CSE bailout propagation

Browse source 
* module/language/cps/cse.scm (compute-available-expressions): Prepare
  for being able to prune joins from bailouts.  Always loop after the
  first iteration.

* module/language/cps/effects-analysis.scm: Remove &possible-bailout.
  Rename &definite-bailout to &bailout, and rename
  &all-effects-but-bailout to &unknown-effects.
This commit is contained in:
Andy Wingo 2014-04-04 13:42:54 +02:00
parent 7a08e47967
commit 780ad383bb
2 changed files with 43 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

38
module/language/cps/effects-analysis.scm
View file

@ -49,8 +49,7 @@
&fluid
&fluid-environment
&prompt
&definite-bailout
&possible-bailout
&bailout
&allocation
&car
&cdr
@ -64,7 +63,7 @@
&no-effects
&all-effects
&all-effects-but-bailout
&unknown-effects
effects-commute?
exclude-effects
@ -121,10 +120,7 @@
;; 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
&bailout
;; Indicates that an expression may return a fresh object -- a
;; "causes" effect.
@ -186,8 +182,7 @@
(define-effects &all-effects
&fluid
&prompt
&definite-bailout
&possible-bailout
&bailout
&allocation
&car
&cdr
@ -209,16 +204,12 @@
(define-syntax &no-effects (identifier-syntax 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.
;; An expression with unknown effects can cause any effect, except
;; &bailout (which indicates certain bailout).
;;
(define-syntax &all-effects-but-bailout
(define-syntax &unknown-effects
(identifier-syntax
(logand &all-effects (lognot &definite-bailout))))
(logand &all-effects (lognot &bailout))))
(define-inlinable (cause effect)
(ash effect 1))
@ -257,8 +248,7 @@
(begin
(hashq-set! *primitive-effects* 'name
(case-lambda* ((dfg . args) effects)
(_ (logior (cause &possible-bailout)
(cause &definite-bailout)))))
(_ (cause &bailout))))
...))
(define-syntax-rule (define-primitive-effects ((name . args) effects) ...)
@ -304,9 +294,9 @@
;; Bailout.
(define-primitive-effects
((error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
((scm-error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
((throw . _) (logior (cause &definite-bailout) (cause &possible-bailout))))
((error . _) (logior (cause &bailout)))
((scm-error . _) (logior (cause &bailout)))
((throw . _) (logior (cause &bailout))))
;; Pairs.
(define-primitive-effects
@ -457,7 +447,7 @@
(let ((proc (hashq-ref *primitive-effects* name)))
(if proc
(apply proc dfg args)
(logior &all-effects-but-bailout (cause &all-effects-but-bailout)))))
(logior &unknown-effects (cause &unknown-effects)))))
(define (expression-effects exp dfg)
(match exp
@ -468,7 +458,7 @@
(($ $prompt)
(cause &prompt))
((or ($ $call) ($ $callk))
(logior &all-effects-but-bailout (cause &all-effects-but-bailout)))
(logior &unknown-effects (cause &unknown-effects)))
(($ $primcall name args)
(primitive-effects dfg name args))))