From b72f733fa2cbe74156244da3754883d081e13f6b Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Tue, 21 Oct 2025 11:29:32 -0300 Subject: [PATCH 1/2] Fix non-total predicates in tail possition in cptypes Avoid moving predicates from tail position when they may raise an error, in spite the result in known in case of a success. --- mats/cptypes.ms | 18 ++++++++++++++++++ release_notes/release_notes.stex | 3 +++ s/cptypes.ss | 24 ++++++++++++++++++++---- 3 files changed, 41 insertions(+), 4 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 780e7350d..d647db729 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -903,6 +903,24 @@ (loop (cdr p?*)))))) (loop (cdr f*))))))) +(mat cptypes-predicates + ; don't remove (exact? x) from tail position if it may raise an error + (not (parameterize ([debug-level 2]) + (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))) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 62c386781..642572e5d 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -141,6 +141,9 @@ similar functions. Also improve the support of predicates, in particular integer?, zero? and similar predicates. Also, add suport for \scheme{+} abd \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, diff --git a/s/cptypes.ss b/s/cptypes.ss index 1d2608bd7..2c2412733 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -1607,6 +1607,24 @@ 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 + [(and (eq? ctxt 'value) + (>= (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])) + ; TODO: improve this when the 'value and 'tail context are split + 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 +1635,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))] From 7c324e403b8a66bce0266500ee3c36cea9145183 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Thu, 23 Oct 2025 19:19:42 -0300 Subject: [PATCH 2/2] split tail --- mats/cptypes.ms | 9 +++++---- s/cptypes.ss | 25 +++++++++++++------------ 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index d647db729..f00c90ac3 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -905,10 +905,11 @@ (mat cptypes-predicates ; don't remove (exact? x) from tail position if it may raise an error - (not (parameterize ([debug-level 2]) - (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]) + (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))) diff --git a/s/cptypes.ss b/s/cptypes.ss index 2c2412733..caf0d0afe 100644 --- a/s/cptypes.ss +++ b/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)]) @@ -1611,7 +1611,9 @@ Notes: ; 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 - [(and (eq? ctxt 'value) + [(eq? ctxt 'effect) + ir] + [(and (eq? ctxt 'tail) (>= (debug-level) 2) (nanopass-case (Lsrc Expr) ir [(call ,preinfo ,pr ,e* ...) @@ -1619,7 +1621,6 @@ Notes: (and (not (all-set? (prim-mask unsafe) flags)) (not (all-set? (prim-mask unrestricted) flags))))] [else #t])) - ; TODO: improve this when the 'value and 'tail context are split ir] [else (make-seq ctxt ir qret)])]) @@ -1733,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*)) @@ -1942,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)) @@ -1951,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)) @@ -2002,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)))])) @@ -2123,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)