fix interpreted begin0 to for a 0-result case

In some cases, 0 results will be represented by a NULL results-array
pointer. Fix the interpreter to detect a single result completion
through a count of 1 instead of a NULL result-array pointer.

Also, remove a bug extra push operation in the JIT-generated code for
`begin0`. (Other features of the JIT-generated code compensated for
the extra push in cases where the bytecode compiler did't optimize
away the `begin0`, so it turns out not to have caused a problem, but
that's a surprising and fragile set of coincidences.)

Closes #2571
This commit is contained in:
Matthew Flatt 2019-03-30 20:34:47 -06:00
parent e7456d3e9e
commit cbd565a3fd
4 changed files with 30 additions and 5 deletions

View File

@ -2223,6 +2223,27 @@
(define x (param)))) (define x (param))))
x)) x))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; check interpreted `begin0`, 0 results, and
;; non-0 results along the way
;; This is a regression test for a bug that caused a crash
(let ()
(define f
(impersonate-procedure
(λ (x) #f)
(λ (x) (values (λ (x) x) x))))
(call-with-values
(λ ()
(begin0
((lambda (pos)
(set! pos pos)
(values))
0)
(f #f)))
(λ args (void))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

View File

@ -15,7 +15,8 @@
"../expand/missing-module.rkt" "../expand/missing-module.rkt"
"../read/api.rkt" "../read/api.rkt"
"../read/primitive-parameter.rkt" "../read/primitive-parameter.rkt"
"load-handler.rkt") "load-handler.rkt"
"../common/performance.rkt")
(provide boot (provide boot
seal seal
@ -459,12 +460,16 @@
(cond (cond
[(symbol? s) [(symbol? s)
(or (path-cache-get (cons s (get-reg))) (or (path-cache-get (cons s (get-reg)))
(performance-region
['eval 'resolve-symbol]
(let-values ([(cols file) (split-relative-string (symbol->string s) #f)]) (let-values ([(cols file) (split-relative-string (symbol->string s) #f)])
(let* ([f-file (if (null? cols) (let* ([f-file (if (null? cols)
"main.rkt" "main.rkt"
(string-append file ".rkt"))] (string-append file ".rkt"))]
[col (if (null? cols) file (car cols))] [col (if (null? cols) file (car cols))]
[col-path (if (null? cols) null (cdr cols))]) [col-path (if (null? cols) null (cdr cols))])
(performance-region
['eval 'resolve-find]
(find-col-file (if (not subm-path) (find-col-file (if (not subm-path)
show-collection-err show-collection-err
;; Invent a fictional collection directory, if necessary, ;; Invent a fictional collection directory, if necessary,
@ -474,7 +479,7 @@
col col
col-path col-path
f-file f-file
#t))))] #t))))))]
[(string? s) [(string? s)
(let* ([dir (get-dir)]) (let* ([dir (get-dir)])
(or (path-cache-get (cons s dir)) (or (path-cache-get (cons s dir))

View File

@ -1917,7 +1917,7 @@ static Scheme_Object *begin0_execute(Scheme_Object *obj)
p->values_buffer = NULL; p->values_buffer = NULL;
} else { } else {
mv = NULL; mv = NULL;
mc = 0; /* makes compilers happy */ mc = 1;
} }
apos = 1; apos = 1;
@ -1925,7 +1925,7 @@ static Scheme_Object *begin0_execute(Scheme_Object *obj)
ignore_result(_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++])); ignore_result(_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++]));
} }
if (mv) { if (mc != 1) {
Scheme_Thread *p = scheme_current_thread; Scheme_Thread *p = scheme_current_thread;
p->ku.multiple.array = mv; p->ku.multiple.array = mv;
p->ku.multiple.count = mc; p->ku.multiple.count = mc;

View File

@ -2330,7 +2330,6 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
if (!result_ignored && (count > 1)) { if (!result_ignored && (count > 1)) {
mz_pushr_p(JIT_R0); mz_pushr_p(JIT_R0);
if (multi_ok) { if (multi_ok) {
mz_pushr_p(JIT_R0);
mz_pushr_p(JIT_R0); mz_pushr_p(JIT_R0);
mz_pushr_p(JIT_R0); mz_pushr_p(JIT_R0);
mz_rs_sync(); mz_rs_sync();