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