Skip to content
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

Jump to bottom

restore (debug-level 2) behavior, but reduce its guarantees #834

Merged
merged 1 commit into from
May 25, 2024
Merged

restore (debug-level 2) behavior, but reduce its guarantees #834

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
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
11 changes: 7 additions & 4 deletions csug/system.stex
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2724,10 +2724,13 @@ It is used to tell the compiler how important the preservation of
debugging information is, with 0 being least important and 3 being
most important.
The default value is 1.
As of Version~9.0, it is used solely to determine whether an
error-causing call encountered in nontail position is treated as
if it were in tail position (thus causing the caller's frame not
to appear in a stack backtrace); this occurs at debug levels below~2.

As of Version~9.0, the value of \scheme{debug-level} is used by the
system only to discourage optimizations that affect the continuation
as revealed by the inspector. The reduced optimization is intended to
produce more informative stack backtraces at the point when an
exception is raised, and the reduction applies when the debug level is
2 or 3.

%----------------------------------------------------------------------------
\entryheader
Expand Down
53 changes: 53 additions & 0 deletions mats/cptypes.ms
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -206,6 +206,10 @@
(cptypes-equivalent-expansion?
'(lambda () (box (let ([x (error 'who "msg")]) (cons x (random)))))
'(lambda () (error 'who "msg")))
(parameterize ([debug-level 2])
(cptypes-equivalent-expansion?
'(lambda () (box (let ([x (error 'who "msg")]) (cons x (random)))))
'(lambda () (#%$value (error 'who "msg")))))
(cptypes-equivalent-expansion?
'(lambda (x) (vector-set! (box 5) 0 0) 1)
'(lambda (x) (vector-set! (box 5) 0 0) 2))
Expand Down Expand Up @@ -1565,6 +1569,25 @@
(cptypes-equivalent-expansion?
'(lambda (x) (error 'x "no") (add1 x))
'(lambda (x) (error 'x "no")))
(parameterize ([debug-level 2])
(cptypes-equivalent-expansion?
'(lambda (x) (error 'x "no") (add1 x))
'(lambda (x) (error 'x "no") (void))))
(parameterize ([debug-level 2])
(not
(cptypes-equivalent-expansion?
'(lambda (x) (error 'x "no") (add1 x))
'(lambda (x) (error 'x "no")))))
(parameterize ([debug-level 2])
(not
(cptypes-equivalent-expansion?
'(lambda (x) (rationalize "no") (add1 x))
'(lambda (x) (rationalize "no")))))
(parameterize ([debug-level 2])
(not
(cptypes-equivalent-expansion?
'(lambda (x) (+ 1 "no") (add1 x))
'(lambda (x) (+ 1 "no")))))
(cptypes-equivalent-expansion?
'(lambda (f) (f (error 'x "no") f))
'(lambda (f) (error 'x "no")))
Expand All @@ -1574,6 +1597,11 @@
(cptypes-equivalent-expansion?
'(lambda (x) (if (error 'x "no") (add1 x) (sub1 x)))
'(lambda (x) (error 'x "no")))
(parameterize ([debug-level 2])
(not
(cptypes-equivalent-expansion?
'(lambda (x) (if (error 'x "no") (add1 x) (sub1 x)))
'(lambda (x) (error 'x "no")))))
(cptypes-equivalent-expansion?
'(lambda (x) (+ (error 'x "no") x))
'(lambda (x) (error 'x "no")))
Expand All @@ -1595,10 +1623,31 @@
(cptypes-equivalent-expansion?
'(let ([x #f]) (case-lambda [() x] [(y) (set! x (error 'x "no"))]))
'(let ([x #f]) (case-lambda [() x] [(y) (error 'x "no")])))
(parameterize ([debug-level 2])
(cptypes-equivalent-expansion?
'(let ([x #f]) (case-lambda [() x] [(y) (set! x (error 'x "no"))]))
'(let ([x #f]) (case-lambda [() x] [(y) (error 'x "no") (void)]))))
(parameterize ([debug-level 2])
(not
(cptypes-equivalent-expansion?
'(let ([x #f]) (case-lambda [() x] [(y) (set! x (error 'x "no"))]))
'(let ([x #f]) (case-lambda [() x] [(y) (error 'x "no")])))))

(cptypes-equivalent-expansion?
'(lambda (x) (if x (x) (error 'x "no")))
'(lambda (x) (if x (void) (error 'x "no")) (x)))
(parameterize ([debug-level 2])
(not
(cptypes-equivalent-expansion?
'(lambda (x) (if x (x) (error 'x "no")))
'(lambda (x) (if x (void) (error 'x "no")) (x)))))

(cptypes-equivalent-expansion?
'(lambda (x) (+ (#%$call-setting-continuation-attachment 'a (lambda () (error 'x "no ~s" a))) 1))
'(lambda (x) (#%$value (#%$call-setting-continuation-attachment 'a (lambda () (error 'x "no ~s" a))))))
(cptypes-equivalent-expansion?
'(lambda (x) (if (#%$call-setting-continuation-attachment 'a (lambda () (error 'x "no ~s" a))) 1))
'(lambda (x) (#%$value (#%$call-setting-continuation-attachment 'a (lambda () (error 'x "no ~s" a))))))
(not
(cptypes-equivalent-expansion?
'(lambda (x) (+ (#%$call-setting-continuation-attachment 'a (lambda () (error 'x "no ~s" a))) 1))
Expand All @@ -1617,6 +1666,10 @@
(cptypes-equivalent-expansion?
'(lambda (x) (+ (#%$call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no ~s" a))) 1))
'(lambda (x) (#%$call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no ~s" a))))))
(parameterize ([optimize-level 2])
burgerrg marked this conversation as resolved.
Show resolved Hide resolved
(cptypes-equivalent-expansion?
'(lambda (p) (car p) (vector-ref p 0) (oops))
'(lambda (p) (car p) (vector-ref p 0))))
)

(mat cptypes-boxes
Expand Down
22 changes: 22 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 @@ -2726,6 +2726,28 @@ in fasl files does not generally make sense.
%-----------------------------------------------------------------------------
\section{Bug Fixes}\label{section:bugfixes}

\subsection{Optimization and \scheme{debug-level} $\geq$ 2 (10.1.0)}

Setting \scheme{debug-level} to 2 or higher did not prevent an
error-causing call in nontail position to stay nontail when
\scheme{enable-type-recovery} is \scheme{#t} (the default value).
Furthermore, a tail error-causing call could be made non-tail by
optimizations that aim to expose non-error paths. Those behaviors
moved further from the documented behavior of \scheme{debug-level}
than Chez Scheme version 9.x---but version 9.x was also not consistent
with the documentation due to cp0 conversions such as replacing
\scheme{(let ([x \var{expr}]) x)} with just \var{expr}.

Instead of guaranteeing any specific behavior, a \scheme{debug-level}
value of 2 or higher is now defined to merely \emph{discourage}
optimizations that affect the continuation structure as revealed by the
inspector, where the goal is to produce more informative stack
backtraces at the point where an exception is raised. The
implementation produces results that are more in line with Chez Scheme
9.x. Meanwhile, continuation marks support predictable and
well-defined reflection on continuations in a way that is compatible
with compiler optimizations.

\subsection{Random number generation for large exact integers (10.1.0)}

Given an exact integer greater than 4294967087,
Expand Down
20 changes: 16 additions & 4 deletions s/cp0.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1437,21 +1437,31 @@
;; Returns #t, #f, 'value/inspect (single-valued, but may
;; inspect continuation), or a prelex for a lambda that needs to
;; be single-valued to imply #t. The prelex case is useful to
;; detect a single-valued loop.
;; detect a single-valued loop. When `debug-level` is 2 or more,
;; we treat aborting ops as 'value/inspect instead of #t so that
;; those calls are not moved into tail position (especially after
;; cptypes lifts them into a sequence with `(void)`).
(define-who single-valued
(lambda (e)
(with-memoize () e
; known to produce a single value
(nanopass-case (Lsrc Expr) e
[(quote ,d) #t]
[(call ,preinfo ,e ,e* ...)
(or (and (preinfo-call-single-valued? preinfo)
(or (and (or (and (preinfo-call-no-return? preinfo)
(if (fx< (debug-level) 2)
#t
'value/inspect))
(preinfo-call-single-valued? preinfo))
(not (preinfo-call-check? preinfo)))
(let procedure-single-valued ([e e] [e* e*])
(nanopass-case (Lsrc Expr) (result-exp e)
[,pr
(or (all-set? (prim-mask single-valued) (primref-flags pr))
(all-set? (prim-mask abort-op) (primref-flags pr))
(or (and (all-set? (prim-mask abort-op) (primref-flags pr))
(if (fx< (debug-level) 2)
#t
'value/inspect))
(all-set? (prim-mask single-valued) (primref-flags pr))
(and e*
(cond
[(extract-called-procedure pr e*)
Expand Down Expand Up @@ -1568,6 +1578,8 @@
;; conservative assumption for a prelex:
[else #f])))

;; Single-valued and ok to move from non-tail to tail position
;; (because it doesn't inspect the continuation)?
(define-who single-valued?
(lambda (e)
(single-valued-reduce? (single-valued e)))))
Expand Down
51 changes: 35 additions & 16 deletions s/cptypes.ss
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -93,6 +93,7 @@ Notes:
[else #f]
#;[else ($oops who "unrecognized record ~s" e)])))))

;; Unlike `single-valued?` in cp0, the result is always #t for aborting operations
(module (single-valued?)
(define default-fuel 5)
(define (single-valued? e)
Expand All @@ -103,7 +104,7 @@ Notes:
(nanopass-case (Lsrc Expr) e
[(quote ,d) #t]
[(seq ,e1 ,e2)
(sv? e fuel)]
(sv? e2 fuel)]
[(if ,e1 ,e2, e3)
(and (sv? e2 fuel)
(sv? e3 fuel))]
Expand Down Expand Up @@ -226,17 +227,6 @@ Notes:
#t]
[else #f]))

(define make-nontail
(lambda (ctxt e)
(case ctxt
[(value)
(if (single-valued? e)
e
`(call ,(make-preinfo-call) ,(lookup-primref 3 '$value) ,e))]
[else
;; 'test and 'effect contexts cannot have an active attachment
e])))

(define make-seq
; ensures that the right subtree of the output seq is not a seq if the
; last argument is similarly constrained, to facilitate result-exp
Expand All @@ -254,7 +244,7 @@ Notes:
(if (simple? e1)
e2
(if (and (eq? ctxt 'effect) (simple? e2))
(make-nontail ctxt e1)
e1
(nanopass-case (Lsrc Expr) e2
[(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)]
[else `(seq ,e1 ,e2)])))]
Expand Down Expand Up @@ -673,7 +663,28 @@ Notes:
(predicate-implies? x $fixmediate-pred)))

(define (unwrapped-error ctxt e)
(values (make-nontail ctxt e) 'bottom pred-env-bottom #f #f))
(let ([e (cond
[(or (and (fx< (debug-level) 2)
;; Calling functions for continuation-attachment operations
;; will not count as `single-valued?` (even though we get
;; 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,
;; and they are non-tail with respect to the enclosing function,
;; so ok to have `e` immediately:
(not (eq? 'value 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
;; operations, but the handler is called by `raise` in
;; non-tail position.
e]
[else
;; Wrap `e` to keep it non-tail
(with-output-language (Lsrc Expr)
`(seq ,e ,void-rec))])])
(values e 'bottom pred-env-bottom #f #f)))

(module ()
(with-output-language (Lsrc Expr)
Expand Down Expand Up @@ -1758,12 +1769,20 @@ Notes:
[(predicate-implies? ret2 'bottom) ;check bottom first
(values (if (unsafe-unreachable? e2)
(make-seq ctxt e1 e3)
(make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3))
(if (or (< (debug-level) 2)
(not (eq? ctxt 'value)))
(make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3)
;; If `debug-level` >= 2, may need to keep in tail position
ir))
ret3 types3 t-types3 f-types3)]
[(predicate-implies? ret3 'bottom) ;check bottom first
(values (if (unsafe-unreachable? e3)
(make-seq ctxt e1 e2)
(make-seq ctxt `(if ,e1 ,void-rec ,e3) e2))
(if (or (< (debug-level) 2)
(not (eq? ctxt 'value)))
(make-seq ctxt `(if ,e1 ,void-rec ,e3) e2)
;; As above:
ir))
ret2 types2 t-types2 f-types2)]
[else
(let ([new-types (pred-env-union/super-base types2 t-types1
Expand Down