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

Chez Scheme: fix continuation-attachments compilation

Browse Source 
On AArch{32,64}, compiling `call-setting-continuation-attachment` in a
non-tail position could run out of registers for saving/restoring
around th intrinsic to reify the continuation.

Closes #3646
This commit is contained in:
Matthew Flatt 2021-01-23 06:25:16 -07:00
parent be42b9a24a
commit c084ead2f3
4 changed files with 43 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
racket/src/ChezScheme/mats/4.ms
View File

@ -3808,6 +3808,19 @@
(lambda () (set! did (cons 'out did))))]
[else did]))))
;; regression test to make sure the compiler doesn't run out of
;; registers:
(procedure? (lambda (f a b c)
(#3%call-with-values
(lambda ()
(#3%call-with-values
(lambda ()
(call-setting-continuation-attachment
1024
(lambda ()
(#3%$app f a b c))))
fx+/carry))
f)))
)
;;; section 4-7:

2
racket/src/ChezScheme/s/arm32.ss
View File

@ -76,7 +76,7 @@
#;[%ac1]
#;[%yp]
[ %r0 %Carg1 %Cretval #f 0 uptr]
[ %r1 %Carg2 #f 1 uptr]
[ %r1 %Carg2 %save1 #f 1 uptr]
[ %r2 %Carg3 %reify1 #f 2 uptr]
[ %r3 %Carg4 %reify2 #f 3 uptr]
[ %lr #f 14 uptr] ; %lr is trashed by 'c' calls including calls to hand-coded routines like get-room

2
racket/src/ChezScheme/s/arm64.ss
View File

@ -33,7 +33,7 @@
[ %r1 %Carg2 #f 1 uptr]
[ %r2 %Carg3 %reify1 #f 2 uptr]
[ %r3 %Carg4 %reify2 #f 3 uptr]
[ %r4 %Carg5 #f 4 uptr]
[ %r4 %Carg5 %save1 #f 4 uptr]
[ %r5 %Carg6 #f 5 uptr]
[ %r6 %Carg7 #f 6 uptr]
[ %r7 %Carg8 #f 7 uptr]

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

@ -3517,6 +3517,20 @@
#'reg
(with-implicit (k %mref) #`(%mref ,%tc ,(tc-disp reg))))])))
(define-syntax ref-reg-list
(lambda (x)
(syntax-case x ()
[(k ?reg ...)
(fold-right
(lambda (reg ref*)
(cond
[(real-register? (syntax->datum reg))
#`(cons #,reg #,ref*)]
[(memq (syntax->datum reg) '(%ac0 %ac1 %sfp %cp %esp %ap %eap %trap %xp %yp))
(with-implicit (k ref-reg) #`(cons (ref-reg #,reg) #,ref*))]
[else ref*]))
#''() #'(?reg ...))])))
;; After the `np-expand-primitives` pass, some expression produce
;; double (i.e., floating-point) values instead of pointer values.
;; Those expression results always flow to an `inline` primitive
@ -12459,9 +12473,13 @@
;; Save and restore any live registers that may be used by the `reify-1cc` instrinsic.
;; Since we can't use temporaries at this point --- %sfp is already moved --- manually
;; allocate a few registers (that may not be real registers) and hope that we
;; have enough.
;; have enough. On a platform that may need an extra register, define `%save1`.
(let* ([reify-cc-modify-reg* (intrinsic-modify-reg* reify-1cc)]
[tmp-reg* (reg-list %ac1 %yp)]
[tmp-reg* (reg-list %ac1 %yp %save1)]
[ref-tmpreg* (with-output-language (L13 Lvalue)
;; Does not have to be in the same order as `tmp-reg*`,
;; but everything here must be in `tmp-reg*`
(ref-reg-list %ac1 %yp %save1))]
[save-reg* (fold-left (lambda (reg* r)
(cond
[(memq r reg*) reg*]
@ -12470,6 +12488,12 @@
($oops who "reify-cc-save live register conflicts ~s" reg*)]
[else reg*]))
'() live-reg*)])
(define (ref-tmp-reg i)
(let loop ([i i] [ref-tmpreg* ref-tmpreg*])
(cond
[(null? ref-tmpreg*) ($oops who "reify-cc-save too many live registers ~s" save-reg*)]
[(fx= i 0) (car ref-tmpreg*)]
[else (loop (fx- i 1) (cdr ref-tmpreg*))])))
(safe-assert (andmap (lambda (tmp-reg) (not (memq tmp-reg reify-cc-modify-reg*))) tmp-reg*))
(with-output-language (L13 Effect)
(let loop ([save-reg* save-reg*] [i 0])
@ -12477,14 +12501,9 @@
[(null? save-reg*) (with-saved-ret-reg e)]
[else
(%seq
,(case i
[(0) `(set! ,(ref-reg %ac1) ,(car save-reg*))]
[(1) `(set! ,(ref-reg %yp) ,(car save-reg*))]
[else ($oops who "reify-cc-save too many live reigsters ~s" save-reg*)])
(set! ,(ref-tmp-reg i) ,(car save-reg*))
,(loop (cdr save-reg*) (fx+ i 1))
,(case i
[(0) `(set! ,(car save-reg*) ,(ref-reg %ac1))]
[(1) `(set! ,(car save-reg*) ,(ref-reg %yp))]))]))))))
(set! ,(car save-reg*) ,(ref-tmp-reg i)))]))))))
(define build-call
(with-output-language (L13 Tail)
(case-lambda