compiler: optimizer must watch for throwing constant exprs

We have these issues, which are regressions:

  1> (compile-toplevel '(/ 1 0))
  ** expr-1:1: warning: sys:b/: constant expression (sys:b/ 1 0) throws
  ** /: division by zero
  ** during evaluation at expr-1:1 of form (sys:b/ 1 0)
  1> (compile-toplevel '(let ((a 1) (b 0)) (/ a b)))
  ** /: division by zero
  ** during evaluation at expr-1:1 of form (compile-toplevel [...])

While the compiler's early pass constant folding is careful
to detect constant expressions that throw, care was not taken
in the optimizer's later constant folding which takes place
after constant values are propagated around.

After the fix:

  1> (compile-toplevel '(let ((a 1) (b 0) (c t)) (if c (/ a b))))
  ** expr-1:1: warning: let: function sys:b/ with arguments (1 0) throws
  #<sys:vm-desc: 9aceb20>
  2> (compile-toplevel '(let ((a 1) (b 0) (c nil)) (if c (/ a b))))
  #<sys:vm-desc: 9aef9f0>

* stdlib/compiler.tl (compiler): New slot top-form.
(compile-toplevel): Initialize the top-form slot of the
compiler. The optimizer uses this to issue a warning now.
Since the warning is based on analyzing generated code, we
cannot trace it to the code more precisely than to the top-level
form.

* stdlib/optimize.tl (basic-blocks): New slot, warned-insns.
List of instructions that have been warned about.
(basic-blocks do-peephole-block): Rearrange the constant folding
case so that as part of the pattern match condition, we include
the fact that the function will not throw when called with those
constant arguments. Only in that case do we do the optimization.
We warn in the case when the function call does throw.
A function rejected due to throwing could be processed through
this rule multiple times, under multiple peephole passes, so
for that reason we use the warned-insns list to suppress duplicate
warnings.

2 files changed, 27 insertions, 11 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index 08e1e16e..451b7988 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -244,6 +244,7 @@
     symvec
     lt-frags
     last-form
+    top-form
     closure-spies
     access-spies
 
@@ -2354,7 +2355,7 @@
   (eval (if-match (sys:dvbind @nil @exp) form exp form)))
 
 (defun usr:compile-toplevel (exp : (expanded-p nil))
-  (let ((co (new compiler))
+  (let ((co (new compiler top-form exp))
         (as (new assembler))
         (*dedup* (or *dedup* (hash)))
         (*load-time* nil)
diff --git a/stdlib/optimize.tl b/stdlib/optimize.tl
index 702a4252..d4043528 100644
--- a/stdlib/optimize.tl
+++ b/stdlib/optimize.tl
@@ -68,6 +68,7 @@
     recalc
     reelim
     tryjoin
+    warned-insns
     (:static start (gensym "start-"))
     (:static jump-ops '(jmp if ifq ifql close swtch ret abscsr
                         uwprot catch block jend xend))
@@ -538,17 +539,31 @@
       (@(require ((@(as op @(or gapply gcall)) @tgt @idx
                                                . @(all @(or (d @dn)
                                                             @(with (t 0) dn nil))))
-                  . @rest)
+                  . @(with @rest
+                           val nil))
                  [%const-foldable% [bb.symvec idx]]
-                 [none dn (lop member bb.lt-dregs : cadr)])
-        (let* ((co bb.compiler)
-               (dvec co.(get-datavec))
-               (fun [bb.symvec idx])
-               (args (mapcar [iffi true dvec] dn))
-               (val (if (eq op 'gcall)
-                      (apply fun args)
-                      (apply fun (append [args 0..-1] [args -1]))))
-               (dreg co.(get-dreg val)))
+                 [none dn (lop member bb.lt-dregs : cadr)]
+                 (let ((err '#:err))
+                   (set val (let* ((insn (car insns))
+                                   (co bb.compiler)
+                                   (dvec co.(get-datavec))
+                                   (fun [bb.symvec idx])
+                                   (args (mapcar [iffi true dvec] dn))
+                                   (val (usr:catch
+                                          (if (eq op 'gcall)
+                                            (apply fun args)
+                                            (apply fun (append [args 0..-1]
+                                                               [args -1])))
+                                          (error (#:x) err))))
+                              (when (and (eq val err)
+                                         (not (member insn bb.warned-insns)))
+                                (compile-warning co.top-form
+                                                 "function ~s with arguments ~s throws"
+                                                 fun args)
+                                (push insn bb.warned-insns))
+                              val))
+                   (neq val err)))
+        (let* ((dreg bb.compiler.(get-dreg val)))
           ^((mov ,tgt ,dreg) ,*rest)))
       ;; apply to gapply
       (@(require @(with ((getf @(as treg (t @tn)) @idx) . @rest)