compiler: avoid eval of unsafe constantp in some situations.

In situations when the compiler evaluates a constant expression in order
to make some code generating decision, we don't just want to be using
safe-const-eval. While that prevents the compiler from blowing up, and
issues a diagnostic, it causes incorrect code to be generated: code
which does not incorporate the unsafe expression. Concrete example:

  (if (sqrt -1) (foo) (bar))

if we simply evaluate (sqrt -1) with safe-const-eval, we get a
diagnostic, and the value nil comes out. The compiler will thus
constant-fold this to (bar). Though the diagnostic was emitted,
executing the compiled code does not produce the exception from
(sqrt -1) any more, but just calls bar.

In certain cases where the compiler relies on the evaluation of a
constant expression, we should bypass those cases when the expression is
unsafe.

In cases where the expression will be integrated into the output
code, we can test with constantp. The same is true in some other
mitigating circumstances. For instance if we test with constantp,
and then require safe-const-eval to produce an integer, we are
okay, because a throwing evaluation will not produce an integer.

* stdlib/compiler.tl (safe-constantp): New function.
(compiler (comp-if, comp-ift, lambda-apply-transform)): Use
safe-constantp rather than constantp for determining whether
an expression is suitable for compile-time evaluation.

1 files changed, 12 insertions, 6 deletions

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index 186f026c..fadbef32 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -614,11 +614,11 @@
     (((not (@(and @(or eq eql equal) @op) . @eargs)) . @args)
      (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal))))
        me.(comp-if oreg env ^(if (,nop ,*eargs) ,*args))))
-    ((@(constantp @test) @then @else)
+    ((@(safe-constantp @test) @then @else)
      me.(compile oreg env (if (safe-const-eval test) then else)))
-    ((@(constantp @test) @then)
+    ((@(safe-constantp @test) @then)
      me.(compile oreg env (if (safe-const-eval test) then)))
-    ((@(constantp @test))
+    ((@(safe-constantp @test))
      me.(compile oreg env nil))
     (((@(member @op %test-funs%) @a @b) . @rest)
      me.(compile oreg env ^(ift ,op ,a ,b ,*rest)))
@@ -672,7 +672,7 @@
     (when (member fun %test-funs-neg%)
       (set fun [%test-inv% fun])
       (swap then else))
-    (if (and (constantp left) (constantp right))
+    (if (and (safe-constantp left) (safe-constantp right))
       me.(compile oreg env (if (call fun
                                      (safe-const-eval left)
                                      (safe-const-eval right))
@@ -2006,7 +2006,7 @@
 (defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr recursed)
   (if (and (not recursed)
            apply-list-expr
-           (constantp apply-list-expr))
+           (safe-constantp apply-list-expr))
     (let* ((apply-list-val (safe-const-eval apply-list-expr))
            (apply-atom (nthlast 0 apply-list-val))
            (apply-fixed (butlastn 0 apply-list-val)))
@@ -2037,7 +2037,7 @@
                         (add ^(,var-sym ,(car fix-vals)))
                         (if have-sym
                           (add ^(,have-sym t)))
-                        (unless (and (constantp (car fix-arg-iter))
+                        (unless (and (safe-constantp (car fix-arg-iter))
                                      (neq (safe-const-eval (car fix-arg-iter))
                                           :))
                           (push (list* var-sym have-sym init-form) check-opts)))
@@ -2138,6 +2138,12 @@
     (unless ece.?throws
       (eval form))))
 
+(defun safe-constantp (form)
+  (if (constantp form)
+    (or (atom form)
+        (progn (safe-const-reduce form)
+               (not [%eval-cache% form].?throws)))))
+
 (defun eval-cache-emit-warnings ()
   (dohash (form ece %eval-cache%)
     (when ece.throws