Skip to content

Commit

Permalink
restore (debug-level 2) behavior, but reduce its guarantees
Browse files Browse the repository at this point in the history 
When `debug-level` is 2 or more, optimization is supposed to refrain
from moving a call to an error function into tail position of the
enclosing function. (That's a stronger guarantee than the usual one of
not moving an expression into tail position if there's potentially a
way to detect the movement through continuation marks.) An earlier
commit 6a73b9e strengthened movement of error calls in a way that
did not preserve this `(debug-level 2)` constraint, so this commit
primarily adjusts those changes. Also, the earlier commit 19af32e
allowed the compiler to move an error call out of tail position, and
that transformation is now suppressed when `debug-level` is 2 or more.

These changes are meant to help with debugging, but they're not enough
to implement the previously specified behavior of `debug-level`. It
turns out that Chez Scheme v9.x didn't implement the specified
behavior, either, because it would convert `(let ([x (error ...)]) x)`
to just `(error ...)`, for example. The old specification seems too
strong, and so part of the revision here is to change the specificaton
to be encouraging a particular interaction of errors and
continuaton-inspection results, but not guaranteeing it. Meanwhile,
when well-defined reflection on continuations is needed, continuation
marks provide that functionality.
  • Loading branch information
@mflatt
mflatt committed May 21, 2024
1 parent 66c40f1 commit d22d7e8
Show file tree
Hide file tree
Showing 5 changed files with 133 additions and 24 deletions.
11 changes: 7 additions & 4 deletions csug/system.stex
View file
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
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])
(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
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
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
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

0 comments on commit d22d7e8

Please sign in to comment.