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.

module/language/tree-il/effects.scm

@@ -162,13 +162,13 @@
   "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
 of an expression."
 
-  (define compute-effects
   (let ((cache (make-hash-table)))
-      (lambda (exp)
+    (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)))))
+              effects)))
 
       (define (accumulate-effects exps)
         (let lp ((exps exps) (out &no-effects))
@@ -285,9 +285,16 @@ of an expression."
       
           ;; 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)
-               (accumulate-effects args)
-               (cause &type-check)))
+                              (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))
@@ -296,6 +303,17 @@ of an expression."
                    (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
@@ -332,4 +350,6 @@ of an expression."
            (logior &all-effects-but-bailout
                    (cause &all-effects-but-bailout)))))
 
-  compute-effects)
+      (compute-effects exp))
+
+    compute-effects))