better effects analysis for calls to lexically bound procedures

* module/language/tree-il/effects.scm (make-effects-analyzer): The
  analyzer will take an optional second argument, a lookup procedure of
  type sym -> exp.  This can let the analyzer dig into calls to
  lexically bound procedures.

diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm
index 67bb8b7..656b262 100644 (file)
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -162,174 +162,194 @@
   "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
 of an expression."
 
-  (define compute-effects
-    (let ((cache (make-hash-table)))
-      (lambda (exp)
+  (let ((cache (make-hash-table)))
+    (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
+      (define (compute-effects exp)
         (or (hashq-ref cache exp)
             (let ((effects (visit exp)))
               (hashq-set! cache exp effects)
-              effects)))))
-
-  (define (accumulate-effects exps)
-    (let lp ((exps exps) (out &no-effects))
-      (if (null? exps)
-          out
-          (lp (cdr exps) (logior out (compute-effects (car exps)))))))
-
-  (define (visit exp)
-    (match exp
-      (($ <const>)
-       &no-effects)
-      (($ <void>)
-       &no-effects)
-      (($ <lexical-ref> _ _ gensym)
-       (if (assigned-lexical? gensym)
-           &mutable-lexical
-           &no-effects))
-      (($ <lexical-set> _ name gensym exp)
-       (logior (cause &mutable-lexical)
-               (compute-effects exp)))
-      (($ <let> _ names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <letrec> _ in-order? names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <fix> _ names gensyms vals body)
-       (logior (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (accumulate-effects vals)
-               (compute-effects body)))
-      (($ <let-values> _ producer consumer)
-       (logior (compute-effects producer)
-               (compute-effects consumer)
-               (cause &type-check)))
-      (($ <dynwind> _ winder body unwinder)
-       (logior (compute-effects winder)
-               (compute-effects body)
-               (compute-effects unwinder)))
-      (($ <dynlet> _ fluids vals body)
-       (logior (accumulate-effects fluids)
-               (accumulate-effects vals)
-               (cause &type-check)
-               (cause &fluid)
-               (compute-effects body)))
-      (($ <dynref> _ fluid)
-       (logior (compute-effects fluid)
-               (cause &type-check)
-               &fluid))
-      (($ <dynset> _ fluid exp)
-       (logior (compute-effects fluid)
-               (compute-effects exp)
-               (cause &type-check)
-               (cause &fluid)))
-      (($ <toplevel-ref>)
-       (logior &toplevel
-               (cause &type-check)))
-      (($ <module-ref>)
-       (logior &toplevel
-               (cause &type-check)))
-      (($ <module-set> _ mod name public? exp)
-       (logior (cause &toplevel)
-               (cause &type-check)
-               (compute-effects exp)))
-      (($ <toplevel-define> _ name exp)
-       (logior (cause &toplevel)
-               (compute-effects exp)))
-      (($ <toplevel-set> _ name exp)
-       (logior (cause &toplevel)
-               (compute-effects exp)))
-      (($ <primitive-ref>)
-       &no-effects)
-      (($ <conditional> _ test consequent alternate)
-       (let ((tfx (compute-effects test))
-             (cfx (compute-effects consequent))
-             (afx (compute-effects alternate)))
-         (if (causes-effects? (logior tfx (logand afx cfx))
-                              &definite-bailout)
-             (logior tfx cfx afx)
-             (exclude-effects (logior tfx cfx afx)
-                              &definite-bailout))))
-
-      ;; Zero values.
-      (($ <application> _ ($ <primitive-ref> _ 'values) ())
-       (cause &zero-values))
-
-      ;; Effect-free primitives.
-      (($ <application> _
-          ($ <primitive-ref> _ (and name
-                                    (? effect+exception-free-primitive?)))
-          args)
-       (logior (accumulate-effects args)
-               (if (constructor-primitive? name)
-                   (cause &allocation)
-                   &no-effects)))
-      (($ <application> _
-          ($ <primitive-ref> _ (and name
-                                    (? effect-free-primitive?)))
-          args)
-       (logior (accumulate-effects args)
-               (cause &type-check)
-               (if (constructor-primitive? name)
-                   (cause &allocation)
-                   (if (accessor-primitive? name)
-                       &mutable-data
-                       &no-effects))))
+              effects)))
+
+      (define (accumulate-effects exps)
+        (let lp ((exps exps) (out &no-effects))
+          (if (null? exps)
+              out
+              (lp (cdr exps) (logior out (compute-effects (car exps)))))))
+
+      (define (visit exp)
+        (match exp
+          (($ <const>)
+           &no-effects)
+          (($ <void>)
+           &no-effects)
+          (($ <lexical-ref> _ _ gensym)
+           (if (assigned-lexical? gensym)
+               &mutable-lexical
+               &no-effects))
+          (($ <lexical-set> _ name gensym exp)
+           (logior (cause &mutable-lexical)
+                   (compute-effects exp)))
+          (($ <let> _ names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <letrec> _ in-order? names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <fix> _ names gensyms vals body)
+           (logior (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (accumulate-effects vals)
+                   (compute-effects body)))
+          (($ <let-values> _ producer consumer)
+           (logior (compute-effects producer)
+                   (compute-effects consumer)
+                   (cause &type-check)))
+          (($ <dynwind> _ winder body unwinder)
+           (logior (compute-effects winder)
+                   (compute-effects body)
+                   (compute-effects unwinder)))
+          (($ <dynlet> _ fluids vals body)
+           (logior (accumulate-effects fluids)
+                   (accumulate-effects vals)
+                   (cause &type-check)
+                   (cause &fluid)
+                   (compute-effects body)))
+          (($ <dynref> _ fluid)
+           (logior (compute-effects fluid)
+                   (cause &type-check)
+                   &fluid))
+          (($ <dynset> _ fluid exp)
+           (logior (compute-effects fluid)
+                   (compute-effects exp)
+                   (cause &type-check)
+                   (cause &fluid)))
+          (($ <toplevel-ref>)
+           (logior &toplevel
+                   (cause &type-check)))
+          (($ <module-ref>)
+           (logior &toplevel
+                   (cause &type-check)))
+          (($ <module-set> _ mod name public? exp)
+           (logior (cause &toplevel)
+                   (cause &type-check)
+                   (compute-effects exp)))
+          (($ <toplevel-define> _ name exp)
+           (logior (cause &toplevel)
+                   (compute-effects exp)))
+          (($ <toplevel-set> _ name exp)
+           (logior (cause &toplevel)
+                   (compute-effects exp)))
+          (($ <primitive-ref>)
+           &no-effects)
+          (($ <conditional> _ test consequent alternate)
+           (let ((tfx (compute-effects test))
+                 (cfx (compute-effects consequent))
+                 (afx (compute-effects alternate)))
+             (if (causes-effects? (logior tfx (logand afx cfx))
+                                  &definite-bailout)
+                 (logior tfx cfx afx)
+                 (exclude-effects (logior tfx cfx afx)
+                                  &definite-bailout))))
+
+          ;; Zero values.
+          (($ <application> _ ($ <primitive-ref> _ 'values) ())
+           (cause &zero-values))
+
+          ;; Effect-free primitives.
+          (($ <application> _
+              ($ <primitive-ref> _ (and name
+                                        (? effect+exception-free-primitive?)))
+              args)
+           (logior (accumulate-effects args)
+                   (if (constructor-primitive? name)
+                       (cause &allocation)
+                       &no-effects)))
+          (($ <application> _
+              ($ <primitive-ref> _ (and name
+                                        (? effect-free-primitive?)))
+              args)
+           (logior (accumulate-effects args)
+                   (cause &type-check)
+                   (if (constructor-primitive? name)
+                       (cause &allocation)
+                       (if (accessor-primitive? name)
+                           &mutable-data
+                           &no-effects))))
       
-      ;; Lambda applications might throw wrong-number-of-args.
-      (($ <application> _ ($ <lambda> _ _ body) args)
-       (logior (compute-effects body)
-               (accumulate-effects args)
-               (cause &type-check)))
+          ;; Lambda applications might throw wrong-number-of-args.
+          (($ <application> _ ($ <lambda> _ _ body) args)
+           (logior (accumulate-effects args)
+                   (match body
+                     (($ <lambda-case> _ req #f #f #f () syms body #f)
+                      (logior (compute-effects body)
+                              (if (= (length req) (length args))
+                                  0
+                                  (cause &type-check))))
+                     (($ <lambda-case>)
+                      (logior (compute-effects body)
+                              (cause &type-check))))))
         
-      ;; Bailout primitives.
-      (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
-          args)
-       (logior (accumulate-effects args)
-               (cause &definite-bailout)
-               (cause &possible-bailout)))
-
-      ;; A call to an unknown procedure can do anything.
-      (($ <application> _ proc args)
-       (logior &all-effects-but-bailout
-               (cause &all-effects-but-bailout)))
-
-      (($ <lambda> _ meta body)
-       &no-effects)
-      (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
-       (logior (exclude-effects (accumulate-effects inits)
-                                &definite-bailout)
-               (if (or-map assigned-lexical? gensyms)
-                   (cause &allocation)
-                   &no-effects)
-               (compute-effects body)
-               (if alt (compute-effects alt) &no-effects)))
-
-      (($ <sequence> _ exps)
-       (let lp ((exps exps) (effects &no-effects))
-         (match exps
-           ((tail)
-            (logior (compute-effects tail)
-                    ;; Returning zero values to a for-effect continuation is
-                    ;; not observable.
-                    (exclude-effects effects (cause &zero-values))))
-           ((head . tail)
-            (lp tail (logior (compute-effects head) effects))))))
-
-      (($ <prompt> _ tag body handler)
-       (logior (compute-effects tag)
-               (compute-effects body)
-               (compute-effects handler)))
-
-      (($ <abort> _ tag args tail)
-       (logior &all-effects-but-bailout
-               (cause &all-effects-but-bailout)))))
-
-  compute-effects)
+          ;; Bailout primitives.
+          (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
+              args)
+           (logior (accumulate-effects args)
+                   (cause &definite-bailout)
+                   (cause &possible-bailout)))
+
+          ;; A call to a lexically bound procedure, perhaps labels
+          ;; allocated.
+          (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+           (cond
+            ((lookup sym)
+             => (lambda (proc)
+                  (compute-effects (make-application #f proc args))))
+            (else
+             (logior &all-effects-but-bailout
+                     (cause &all-effects-but-bailout)))))
+
+          ;; A call to an unknown procedure can do anything.
+          (($ <application> _ proc args)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))
+
+          (($ <lambda> _ meta body)
+           &no-effects)
+          (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
+           (logior (exclude-effects (accumulate-effects inits)
+                                    &definite-bailout)
+                   (if (or-map assigned-lexical? gensyms)
+                       (cause &allocation)
+                       &no-effects)
+                   (compute-effects body)
+                   (if alt (compute-effects alt) &no-effects)))
+
+          (($ <sequence> _ exps)
+           (let lp ((exps exps) (effects &no-effects))
+             (match exps
+               ((tail)
+                (logior (compute-effects tail)
+                        ;; Returning zero values to a for-effect continuation is
+                        ;; not observable.
+                        (exclude-effects effects (cause &zero-values))))
+               ((head . tail)
+                (lp tail (logior (compute-effects head) effects))))))
+
+          (($ <prompt> _ tag body handler)
+           (logior (compute-effects tag)
+                   (compute-effects body)
+                   (compute-effects handler)))
+
+          (($ <abort> _ tag args tail)
+           (logior &all-effects-but-bailout
+                   (cause &all-effects-but-bailout)))))
+
+      (compute-effects exp))
+
+    compute-effects))