Skip to content

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

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 2 commits into
base: main
Choose a base branch
from
+53 −14
Open

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

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
b72f733
Fix non-total predicates in tail possition in cptypes
gus-massa Oct 21, 2025
7c324e4
split tail
gus-massa Oct 23, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
19 changes: 19 additions & 0 deletions mats/cptypes.ms
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down
3 changes: 3 additions & 0 deletions release_notes/release_notes.stex
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down
45 changes: 31 additions & 14 deletions s/cptypes.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)])
Expand Down Expand Up @@ -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)))
Expand All @@ -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))]
Expand Down Expand Up @@ -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*))
Expand Down Expand Up @@ -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))
Expand All @@ -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))
Expand Down Expand Up @@ -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)))]))
Expand Down Expand Up @@ -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)
Expand Down