suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Chez Scheme: fix continuation on result-count exception

Browse Source 
The Scheme stack pointer was left in call state when the number of
results is wrong, with the intent of exposing the enclosing function's
frame for debugging purposes, but there's no guanrantee that the
result address is still on the stack (i.e., the continuation make have
been captured). Reinstall the return address before calling the
exception handler.
This commit is contained in:
Matthew Flatt 2020-08-30 20:56:14 -06:00
parent b83e598b20
commit 8834597c1f
4 changed files with 55 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
racket/src/ChezScheme/c/fasl.c
View File

@ -1954,18 +1954,21 @@ static void swap_code_endian(octet *code, uptr len)
code[3] = a;
if (a == pb_adr) {
/* after a few more instructions, we'll hit
a header where 64-bit values needs to be
swapped, instead of 32-bit values */
uptr delta = ((uptr)d << 16) + c;
octet *after_rpheader = code + 4 + delta;
/* delta can be negative for a mvlet-error reinstall of the return address */
iptr delta = (int16_t)(uint16_t)(((uptr)d << 16) + c);
if (delta > 0) {
/* after a few more instructions, we'll hit
a header where 64-bit values needs to be
swapped, instead of 32-bit values */
octet *after_rpheader = code + 4 + delta;
if (after_rpheader[-8] & 0x1)
header_size = size_rp_compact_header;
else
header_size = size_rp_header;
if (after_rpheader[-8] & 0x1)
header_size = size_rp_compact_header;
else
header_size = size_rp_header;
next_rpheader = after_rpheader - header_size;
next_rpheader = after_rpheader - header_size;
}
}
code += 4;

25
racket/src/ChezScheme/mats/3.ms
View File

@ -2087,6 +2087,31 @@
(thing-pos posx)
(do-something-else)))
list)))))
;; regression test to make sure the continuation is well formed when
;; an exception handler is call for a wrong number of values are
;; returned to a multi-value context
(begin
(define ($go-fail-to-get-two-values)
(call-with-values (lambda () ($get-one-value))
(lambda (a b) (list a b))))
(define ($get-one-value)
(call/cc ; copies return address off stack
(lambda (k)
(collect) ; do something non-trivial
k)))
(#%$continuation?
(call/cc
(lambda (esc)
(car
(with-exception-handler
(lambda (exn)
(call/cc
(lambda (k) ; this continuation used to be broken, and
(collect) ; a GC was the simplest way of detecting it
(esc k))))
$go-fail-to-get-two-values))))))
)
(mat let-values

22
racket/src/ChezScheme/s/cpnanopass.ss
View File

@ -11745,8 +11745,10 @@
(if (null? x**)
(%seq
(pariah)
; goto domvleterr before decrementing sfp, so callers frame
; is still on the stack, to go along with value in %ret / sfp[0]
;; mverror point ensures that the call's return address
;; is in sfp[0], so the caller's frame is still
;; on the stack for error reporting and debugging
(mverror-point)
(goto ,Ldomvleterr))
(let ([x* (car x**)] [interface (car interface*)] [l (car l*)])
(let ([ebody `(mventry-point (,x* ...) ,l)])
@ -11831,6 +11833,7 @@
;; if no suffix is specified the prefix is defined as a macro
(import (only asm-module asm-foreign-call asm-foreign-callable asm-enter))
(define newframe-info-for-mventry-point)
(define label-for-mverror-point)
(define Lcall-error (make-Lcall-error))
(define dcl*)
(define local*)
@ -12119,7 +12122,7 @@
(build-return-point rpl this-mrvl #f cnfv*
(build-consumer-call tc cnfv rpl shift?)))
,(f tc* cnfv* rpl* this-mrvl shift?*)))))))))))
,(build-postlude newframe-info))))))))))))
,(build-postlude newframe-info rpl))))))))))))
; NB: combine
(define build-nontail-call-for-tail-call-with-consumers
(lambda (info mdcl t0 t1* tc* nfv** mrvl prepare-for-consumer? build-postlude)
@ -12230,7 +12233,7 @@
(let ([tc* (list-head tc* (fx- (length tc*) 1))])
`(seq
,(build-nontail-call info mdcl t0 t1* tc* '() mrvl #f #t
(lambda (newframe-info)
(lambda (newframe-info rpl)
(%seq
(remove-frame ,newframe-info)
(restore-local-saves ,newframe-info)
@ -13276,10 +13279,12 @@
(if (uvar-referenced? x)
`(seq (set! ,x ,(uvar-location x)) ,(f (cdr x*)))
(f (cdr x*)))))))]
[(mverror-point)
`(set! ,%ref-ret (label-ref ,label-for-mverror-point ,(constant size-rp-header)))]
[(mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...))
(let ([mrvl (make-local-label 'mrvl)])
(build-nontail-call info mdcl t0? t1* t* '() mrvl #t #f
(lambda (newframe-info)
(lambda (newframe-info rpl)
(%seq (label ,mrvl) (remove-frame ,newframe-info) (restore-local-saves ,newframe-info)))))]
[(mvset ,info (,mdcl ,t0? ,t1* ...) (,t* ...) ((,x** ...) ...) ,ebody)
(let* ([frame-x** (map (lambda (x*) (set-formal-registers! x*)) x**)]
@ -13291,12 +13296,13 @@
frame-x**)])
(let ([mrvl (make-local-label 'mrvl)])
(build-nontail-call info mdcl t0? t1* t* nfv** mrvl #f #t
(lambda (newframe-info)
(fluid-let ([newframe-info-for-mventry-point newframe-info])
(lambda (newframe-info rpl)
(fluid-let ([newframe-info-for-mventry-point newframe-info]
[label-for-mverror-point rpl])
(Effect ebody))))))]
[(set! ,[lvalue] (mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...)))
(build-nontail-call info mdcl t0? t1* t* '() #f #f #f
(lambda (newframe-info)
(lambda (newframe-info rpl)
(let ([retval (make-tmp 'retval)])
(%seq
(remove-frame ,newframe-info)

5
racket/src/ChezScheme/s/np-languages.ss
View File

@ -845,9 +845,10 @@
(- (mvset info (mdcl (maybe t0) t1 ...) (t* ...) ((x** ...) interface* l*) ...))
(+ (do-rest fixed-args)
(mvset info (mdcl (maybe t0) t1 ...) (t* ...) ((x** ...) ...) ebody)
; mventry-point can appear only within an mvset ebody
; mventry-point and mverror-point can appear only within an mvset ebody
; ideally, grammar would reflect this
(mventry-point (x* ...) l))))
(mventry-point (x* ...) l)
(mverror-point))))
(define-language L12.5 (extends L12)
(entry Program)