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

Effects analysis tweaks

Browse source 
* module/language/cps/effects-analysis.scm: Add &fluid-environment
  effect, a dependency of fluid-ref and fluid-set!, and an effect of
  push-fluid/pop-fluid.
  (list): Depend on &cdr.
  (resolve, cached-toplevel-box, cached-module-box): Don't depend on
  &box.
This commit is contained in:
Andy Wingo 2014-04-04 12:08:52 +02:00
parent b764157a7b
commit a11778dd8e
1 changed files with 23 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -47,6 +47,7 @@
compute-effects
&fluid
&fluid-environment
&prompt
&definite-bailout
&possible-bailout
@ -111,6 +112,9 @@
;; variable.
&fluid
;; Indicates that an expression depends on the current fluid environment.
&fluid-environment
;; Indicates that an expression depends on the current prompt
;; stack.
&prompt
@ -194,6 +198,7 @@
&string
&bytevector
&type-check)
(define-syntax &fluid-environment (identifier-syntax &fluid))
(define-syntax &struct-0 (identifier-syntax &struct))
(define-syntax &struct-1 (identifier-syntax &struct))
(define-syntax &struct-2 (identifier-syntax &struct))
@ -272,7 +277,6 @@
((pair? arg) &no-effects)
((null? arg) &no-effects)
((nil? arg ) &no-effects)
((list? arg) &no-effects)
((symbol? arg) &no-effects)
((variable? arg) &no-effects)
((vector? arg) &no-effects)
@ -285,10 +289,14 @@
;; Fluids.
(define-primitive-effects
((fluid-ref f) (logior (cause &type-check) &fluid))
((fluid-set! f v) (logior (cause &type-check) (cause &fluid)))
((push-fluid f v) (logior (cause &type-check) (cause &fluid)))
((pop-fluid) (logior (cause &fluid))))
((fluid-ref f)
(logior (cause &type-check) &fluid &fluid-environment))
((fluid-set! f v)
(logior (cause &type-check) (cause &fluid) &fluid-environment))
((push-fluid f v)
(logior (cause &type-check) (cause &fluid-environment)))
((pop-fluid)
(logior (cause &fluid-environment))))
;; Prompts.
(define-primitive-effects
@ -310,6 +318,7 @@
((set-cdr! x y) (logior (cause &type-check) (cause &cdr)))
((memq x y) (logior (cause &type-check) &car &cdr))
((memv x y) (logior (cause &type-check) &car &cdr))
((list? arg) &cdr)
((length l) (logior (cause &type-check) &car &cdr)))
;; Vectors.
@ -327,12 +336,12 @@
;; Structs.
(define-primitive-effects* dfg
((allocate-struct vtable nfields) (logior (cause &type-check)
(cause &allocation)))
((make-struct vtable ntail . args) (logior (cause &type-check)
(cause &allocation)))
((make-struct/no-tail vtable . args) (logior (cause &type-check)
(cause &allocation)))
((allocate-struct vtable nfields)
(logior (cause &type-check) (cause &allocation)))
((make-struct vtable ntail . args)
(logior (cause &type-check) (cause &allocation)))
((make-struct/no-tail vtable . args)
(logior (cause &type-check) (cause &allocation)))
((struct-ref s n)
(logior (cause &type-check)
(match (lookup-constant-index n dfg)
@ -439,9 +448,9 @@
(define-primitive-effects
((current-module) &module)
((cache-current-module! mod scope) (cause &box))
((resolve name bound?) (logior &box &module (cause &type-check)))
((cached-toplevel-box scope name bound?) (logior &box (cause &type-check)))
((cached-module-box scope name bound?) (logior &box (cause &type-check)))
((resolve name bound?) (logior &module (cause &type-check)))
((cached-toplevel-box scope name bound?) (cause &type-check))
((cached-module-box scope name bound?) (cause &type-check))
((define! name val) (logior &module (cause &box))))
(define (primitive-effects dfg name args)