File: 0005-continuation-repair-for-return-arity-error.patch

package info (click to toggle)
chezscheme 9.5.4%2Bdfsg-4
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, bullseye, sid
  • size: 61,640 kB
  • sloc: ansic: 17,508; sh: 759; makefile: 509; csh: 423
file content (138 lines) | stat: -rw-r--r-- 6,291 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 31 Aug 2020 06:02:36 -0600
Subject: continuation repair for return-arity error
Applied-Upstream: https://github.com/cisco/ChezScheme/commit/07108624d347e13980d70f3a10d48dc2b2aebd7d

---
 mats/3.ms         | 25 +++++++++++++++++++++++++
 s/cpnanopass.ss   | 22 ++++++++++++++--------
 s/np-languages.ss |  5 +++--
 3 files changed, 42 insertions(+), 10 deletions(-)

diff --git a/mats/3.ms b/mats/3.ms
index 8658669..d8a3021 100644
--- a/mats/3.ms
+++ b/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/s/cpnanopass.ss b/s/cpnanopass.ss
index b653cb9..b4b9d70 100644
--- a/s/cpnanopass.ss
+++ b/s/cpnanopass.ss
@@ -10125,8 +10125,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)])
@@ -10163,6 +10165,7 @@
       (definitions
         (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*)
@@ -10397,7 +10400,7 @@
                                                                (build-return-point rpl this-mrvl cnfv*
                                                                  (build-consumer-call tc cnfv rpl)))
                                                             ,(f tc* cnfv* rpl* this-mrvl)))))))))))
-                               ,(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)
@@ -10508,7 +10511,7 @@
                             (let ([tc* (list-head tc* (fx- (length tc*) 1))])
                               `(seq
                                  ,(build-nontail-call info mdcl t0 t1* tc* '() mrvl #t
-                                    (lambda (newframe-info)
+                                    (lambda (newframe-info rpl)
                                       (%seq
                                         (remove-frame ,newframe-info)
                                         (restore-local-saves ,newframe-info)
@@ -11401,10 +11404,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 #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**)]
@@ -11416,12 +11421,13 @@
                          frame-x**)])
            (let ([mrvl (make-local-label 'mrvl)])
              (build-nontail-call info mdcl t0? t1* t* nfv** mrvl #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
-           (lambda (newframe-info)
+           (lambda (newframe-info rpl)
              (let ([retval (make-tmp 'retval)])
                (%seq
                  (remove-frame ,newframe-info)
diff --git a/s/np-languages.ss b/s/np-languages.ss
index 84128ce..cf89756 100644
--- a/s/np-languages.ss
+++ b/s/np-languages.ss
@@ -775,9 +775,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 exact-integer?
     (lambda (x)