diff --git a/racket/src/ChezScheme/c/fasl.c b/racket/src/ChezScheme/c/fasl.c index e2b919cd43..c78412df72 100644 --- a/racket/src/ChezScheme/c/fasl.c +++ b/racket/src/ChezScheme/c/fasl.c @@ -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; diff --git a/racket/src/ChezScheme/mats/3.ms b/racket/src/ChezScheme/mats/3.ms index 8658669d50..d8a302189b 100644 --- a/racket/src/ChezScheme/mats/3.ms +++ b/racket/src/ChezScheme/mats/3.ms @@ -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 diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index 51d4cab734..8bd5b0d329 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -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) diff --git a/racket/src/ChezScheme/s/np-languages.ss b/racket/src/ChezScheme/s/np-languages.ss index 13a957f471..7e3e0a90a4 100644 --- a/racket/src/ChezScheme/s/np-languages.ss +++ b/racket/src/ChezScheme/s/np-languages.ss @@ -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)