Effects analysis tweaks

* 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.

diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index be5f872..b858edb 100644 (file)
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -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)