Fix non-total predicates in tail position in cptypes (#985)

Avoid moving predicates from tail position when they may raise
an error, in spite the result in known in case of a success.

Author: gus-massa

mats/cptypes.ms

@@ -903,6 +903,25 @@
                            (loop (cdr p?*))))))
                (loop (cdr f*)))))))
 
+(mat cptypes-predicates
+  ; don't remove (exact? x) from tail position if it may raise an error
+  (parameterize ([debug-level 2])
+    (not
+     (cptypes-equivalent-expansion?
+       '(lambda (x) (when (or (fixnum? x) (list? x)) (#2%exact? x)))
+       '(lambda (x) (when (or (fixnum? x) (list? x)) (#2%exact? x) #t)))))
+  (parameterize ([debug-level 2])
+    (cptypes-equivalent-expansion?
+      '(lambda (x) (when (or (fixnum? x) (list? x)) (#3%exact? x)))
+      '(lambda (x) (when (or (fixnum? x) (list? x)) (#3%exact? x) #t))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (or (fixnum? x) (list? x)) (list (exact? x))))
+    '(lambda (x) (when (or (fixnum? x) (list? x)) (list (begin (exact? x) #t)))))
+  (cptypes-equivalent-expansion?
+    '(lambda (x) (when (or (fixnum? x) (list? x)) (if (exact? x) 1 2)))
+    '(lambda (x) (when (or (fixnum? x) (list? x)) (exact? x) 1)))
+)
+
 (mat cptypes-unsafe
   (cptypes-equivalent-expansion?
     '(lambda (x) (when (pair? x) (car x)))

release_notes/release_notes.stex

@@ -137,6 +137,9 @@ The compiler now inlines more numeric predicates, in particular \scheme{real?},
 The type recovery pass has improved support for \scheme{cfl+} and similar functions,
 \scheme{integer?}, \scheme{zero?}, and similar predicates, and \scheme{+} and \scheme{-}.
 
+Avoid moving predicates from tail position when they may raise
+an error, in spite the result in known in case of a success.
+
 \subsection{Unicode 16.0.0 support (10.3.0)}
 
 The character sets, character classes, and word-breaking algorithms for character, string,

s/cptypes.ss

@@ -19,7 +19,7 @@ Notes:
  - (cptypes ir ctxt types) -> (values ir ret types t-types f-types)
    + arguments
      ir: expression to be optimized
-     ctxt: 'effect 'test 'value
+     ctxt: 'effect 'test 'value 'tail
      types: an immutable dictionary (currently an intmap).
             The dictionary connects the counter of a prelex with the types
             discovered previously.
@@ -753,10 +753,10 @@ Notes:
                          ;; here because we know an error will be raised); we need to keep
                          ;; those non-tail:
                          (single-valued? e))
-                    ;; A 'test or 'effect context cannot have an active attachment,
+                    ;; A 'test, 'effect or 'value context cannot have an active attachment,
                     ;; and they are non-tail with respect to the enclosing function,
                     ;; so ok to have `e` immediately:
-                    (not (eq? 'value ctxt)))
+                    (not (eq? 'tail ctxt)))
                 ;; => It's ok to potentially move `e` into tail position
                 ;; from a continuation-marks perspective. Although an
                 ;; error may trigger a handler that has continuation-mark
@@ -1478,8 +1478,8 @@ Notes:
                          types2 t-types2 f-types2))])))
 
         (define-specialize/unrestricted 2 $call-setting-continuation-attachment
-          ;; body is in 'value context, because called with a mark
-          [(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc 'value)])
+          ;; body is in 'tail context, because called with a mark
+          [(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc 'tail)])
 
         (define-specialize/unrestricted 2 $call-getting-continuation-attachment
           [(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc ctxt)])
@@ -1607,6 +1607,25 @@ Notes:
                  [r* (if unsafe nr* r*)])
              (fold-primref/try-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc))]))))
 
+  (define (wrap/result ctxt ir qret ntypes)
+    ; Assume cret is a quoted constant, that can be used as result in the expression
+    ; and also as the the predicate in ret.
+    (let ([ir (cond
+                [(eq? ctxt 'effect)
+                 ir]
+                [(and (eq? ctxt 'tail)
+                      (>= (debug-level) 2)
+                      (nanopass-case (Lsrc Expr) ir
+                        [(call ,preinfo ,pr ,e* ...)
+                         (let ([flags (primref-flags pr)])
+                           (and (not (all-set? (prim-mask unsafe) flags))
+                                (not (all-set? (prim-mask unrestricted) flags))))]
+                        [else #t]))
+                 ir]
+                [else
+                 (make-seq ctxt ir qret)])])
+       (values ir qret ntypes #f #f)))
+
   (define (fold-primref/try-predicate preinfo pr e* ret r* ctxt ntypes oldtypes plxc)
     (cond
       [(not (and (fx= (length e*) 1) (primref->predicate pr #t)))
@@ -1617,11 +1636,9 @@ Notes:
                                      (primref->argument-predicate pr 0 1 #t))])
          (cond
            [(predicate-implies? r (primref->predicate pr #f))
-            (values (make-seq ctxt `(call ,preinfo ,pr ,e) true-rec)
-                    true-rec ntypes #f #f)]
+            (wrap/result ctxt `(call ,preinfo ,pr ,e) true-rec ntypes)]
            [(predicate-disjoint? r (primref->predicate pr #t))
-            (values (make-seq ctxt `(call ,preinfo ,pr ,e) false-rec)
-                    false-rec ntypes #f #f)]
+            (wrap/result ctxt `(call ,preinfo ,pr ,e) false-rec ntypes)]
            [else
             (let ([ttypes (and (eq? ctxt 'test)
                                (pred-env-add/ref ntypes e (primref->predicate pr #t) plxc))]
@@ -1717,7 +1734,7 @@ Notes:
     (let*-values ([(ntypes e* r* t* t-t* f-t*)
                    (map-Expr/delayed e* oldtypes plxc)]
                   [(e0 ret0 types0 t-types0 f-types0 e0-bottom?)
-                   (Expr/call e0 'value ntypes oldtypes plxc)])
+                   (Expr/call e0 'tail ntypes oldtypes plxc)])
       (cond
         [(or (and e0-bottom? e0)
              (ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*))
@@ -1926,7 +1943,7 @@ Notes:
                  (values (if (unsafe-unreachable? e2)
                              (make-seq ctxt e1 e3)
                              (if (or (< (debug-level) 2)
-                                     (not (eq? ctxt 'value)))
+                                     (not (eq? ctxt 'tail)))
                                  (make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3)
                                  ;; If `debug-level` >= 2, may need to keep in tail position
                                  ir))
@@ -1935,7 +1952,7 @@ Notes:
                  (values (if (unsafe-unreachable? e3)
                              (make-seq ctxt e1 e2)
                              (if (or (< (debug-level) 2)
-                                     (not (eq? ctxt 'value)))
+                                     (not (eq? ctxt 'tail)))
                                  (make-seq ctxt `(if ,e1 ,void-rec ,e3) e2)
                                  ;; As above:
                                  ir))
@@ -1986,7 +2003,7 @@ Notes:
                         (nanopass-case (Lsrc CaseLambdaClause) cl
                           [(clause (,x* ...) ,interface ,body)
                            (let-values ([(body ret types t-types f-types)
-                                         (Expr body 'value types plxc)])
+                                         (Expr body 'tail types plxc)]) ;use 'tail context just in case
                              (for-each (lambda (x) (prelex-operand-set! x #f)) x*)
                              (with-output-language (Lsrc CaseLambdaClause)
                                `(clause (,x* ...) ,interface ,body)))]))
@@ -2107,7 +2124,7 @@ Notes:
   ; external version of cptypes: Lsrc -> Lsrc 
   (define (Scptypes ir)
     (let-values ([(ir ret types t-types f-types)
-                  (Expr ir 'value pred-env-empty (box 0))])
+                  (Expr ir 'tail pred-env-empty (box 0))])
       ir))
 
     (set! $cptypes Scptypes)