From c084ead2f32870db7507a62db59893d6fff0a00d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 23 Jan 2021 06:25:16 -0700 Subject: [PATCH] Chez Scheme: fix continuation-attachments compilation 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 --- racket/src/ChezScheme/mats/4.ms | 13 ++++++++++ racket/src/ChezScheme/s/arm32.ss | 2 +- racket/src/ChezScheme/s/arm64.ss | 2 +- racket/src/ChezScheme/s/cpnanopass.ss | 37 ++++++++++++++++++++------- 4 files changed, 43 insertions(+), 11 deletions(-) diff --git a/racket/src/ChezScheme/mats/4.ms b/racket/src/ChezScheme/mats/4.ms index 091fb925c1..b18f5afdc9 100644 --- a/racket/src/ChezScheme/mats/4.ms +++ b/racket/src/ChezScheme/mats/4.ms @@ -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: diff --git a/racket/src/ChezScheme/s/arm32.ss b/racket/src/ChezScheme/s/arm32.ss index fc719ac739..04110b0eb3 100644 --- a/racket/src/ChezScheme/s/arm32.ss +++ b/racket/src/ChezScheme/s/arm32.ss @@ -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 diff --git a/racket/src/ChezScheme/s/arm64.ss b/racket/src/ChezScheme/s/arm64.ss index 831df49e53..5dbd73b93f 100644 --- a/racket/src/ChezScheme/s/arm64.ss +++ b/racket/src/ChezScheme/s/arm64.ss @@ -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] diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index cd7af1f5d7..38251aa597 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -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