Chez Scheme: fix continuation on result-count exception

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.

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

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

racket/src/ChezScheme/s/cpnanopass.ss

@@ -11745,8 +11745,10 @@
               (if (null? x**)
                   (%seq
                     (pariah)
-                    ; goto domvleterr before decrementing sfp, so callers frame
+                    ;; mverror point ensures that the call's return address
-                    ; is still on the stack, to go along with value in %ret / sfp[0]
+                    ;; 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)
+               (lambda (newframe-info rpl)
-                 (fluid-let ([newframe-info-for-mventry-point newframe-info])
+                 (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)

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)