From d2069742ee6b4b288d25c187a31182f919b0dda3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 4 Jun 2020 15:00:22 -0600 Subject: [PATCH] repairs for arm32le Includes a repair by @cjfrisz at cisco/ChezScheme#510 original commit: e7ee15332bd8f0e5f0887cff9f6ee45b8b38a4f1 --- s/arm32.ss | 72 +++++++++++++++++++++++++------------------------ s/cpnanopass.ss | 43 +++++++++++------------------ s/mkheader.ss | 18 ++++++------- s/x86.ss | 8 +++--- s/x86_64.ss | 18 ++++++------- 5 files changed, 75 insertions(+), 84 deletions(-) diff --git a/s/arm32.ss b/s/arm32.ss index 3a2e371b89..814ee61556 100644 --- a/s/arm32.ss +++ b/s/arm32.ss @@ -77,8 +77,8 @@ #;[%yp] [ %r0 %Carg1 %Cretval #f 0 uptr] [ %r1 %Carg2 #f 1 uptr] - [ %r2 %Carg3 #f 2 uptr] - [ %r3 %Carg4 #f 3 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 [%fp1 %Cfparg5 %d4 %s8 #f 8 fp] [%fp2 %Cfparg6 %d5 %s10 #f 10 fp] @@ -104,8 +104,7 @@ #;[ %d16 #t 32 fp] ; >= 32: high bit goes in D, N, or M bit, low bits go in Vd, Vn, Vm #;[ %d17 #t 33 fp] ; etc. - ) - (reify-support %ts %lr %r3 %r2)) + )) ;;; SECTION 2: instructions (module (md-handle-jump) ; also sets primitive handlers @@ -230,20 +229,18 @@ (cond [(and (eq? x1 %zero) (or (unsigned12? imm) (unsigned12? (- imm)))) (return x0 %zero imm type)] - [(funky12 imm) => + [(funky12 imm) ; NB: dubious value? check to see if it's exercised - (lambda (imm) - (let ([u (make-tmp 'u)]) - (seq - (build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 (immediate ,imm))) - (return u x1 0 type))))] - [(funky12 (- imm)) => + (let ([u (make-tmp 'u)]) + (seq + (build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 (immediate ,imm))) + (return u x1 0 type)))] + [(funky12 (- imm)) ; NB: dubious value? check to see if it's exercised - (lambda (imm) - (let ([u (make-tmp 'u)]) - (seq - (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x0 (immediate ,imm))) - (return u x1 0 type))))] + (let ([u (make-tmp 'u)]) + (seq + (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x0 (immediate ,(- imm)))) + (return u x1 0 type)))] [else (let ([u (make-tmp 'u)]) (seq @@ -1485,7 +1482,7 @@ (define vmov.gpr-op (lambda (op dir flreg flreg-delta gpreg code*) (let-values ([(n vn) (ax-flreg->bits flreg flreg-delta)]) - (emit-code (op flreg gpreg code*) + (emit-code (op flreg gpreg flreg-delta code*) [28 (ax-cond 'al)] [21 #b1110000] [20 dir] @@ -2071,7 +2068,7 @@ (lambda (code* dest src) (Trivit (src) (emit vmov.gpr->s32 %fptmp1 0 src - (emit vcvt.s32->dbl %fptmp1 dest code*))))) + (emit vcvt.s32->dbl dest %fptmp1 code*))))) (define-who asm-fpmove ;; fpmove pseudo instruction is used by set! case in @@ -2099,8 +2096,8 @@ (lambda (code* dest src) (Trivit (dest) (if (eq? part 'lo) - (emit vmov.gpr->s32 src 0 dest code*) - (emit vmov.gpr->s32 src 1 dest code*)))))) + (emit vmov.s32->gpr src 0 dest code*) + (emit vmov.s32->gpr src 1 dest code*)))))) (define asm-fpcastfrom (lambda (code* dest lo-src hi-src) @@ -2271,7 +2268,8 @@ (define asm-direct-jump (lambda (l offset) - (asm-helper-jump '() (make-funcrel 'arm32-jump l offset)))) + (let ([offset (adjust-return-point-offset offset l)]) + (asm-helper-jump '() (make-funcrel 'arm32-jump l offset))))) (define asm-literal-jump (lambda (info) @@ -2313,17 +2311,18 @@ (or (cond [(local-label-offset l) => (lambda (offset) - (let ([disp (fx- next-addr (fx- offset incr-offset) 4)]) - (cond - [(funky12 disp) - (Trivit (dest) - ; aka adr, encoding A1 - (emit addi #f dest `(reg . ,%pc) disp '()))] - [(funky12 (- disp)) - (Trivit (dest) - ; aka adr, encoding A2 - (emit subi #f dest `(reg . ,%pc) (- disp) '()))] - [else #f])))] + (let ([incr-offset (adjust-return-point-offset incr-offset l)]) + (let ([disp (fx- next-addr (fx- offset incr-offset) 4)]) + (cond + [(funky12 disp) + (Trivit (dest) + ; aka adr, encoding A1 + (emit addi #f dest `(reg . ,%pc) disp '()))] + [(funky12 (- disp)) + (Trivit (dest) + ; aka adr, encoding A2 + (emit subi #f dest `(reg . ,%pc) (- disp) '()))] + [else #f]))))] [else #f]) (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset))))))) @@ -3179,8 +3178,11 @@ 8)] [else (values (lambda () - `(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset))) - (list %Cretval %r1) + (case ($ftd-size ftd) + [(1) `(set! ,%Cretval (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,return-stack-offset)))] + [(2) `(set! ,%Cretval (inline ,(make-info-load 'integer-16 #f) ,%load ,%sp ,%zero (immediate ,return-stack-offset)))] + [else `(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset))])) + (list %Cretval) 4)])]))] [(fp-double-float) (values (lambda (rhs) @@ -3213,7 +3215,7 @@ [else (values (lambda (x) `(set! ,%Cretval ,x)) - (list %Cretval %r1) + (list %Cretval) 0)])]))) (lambda (info) (define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr)) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index ace787d30f..770f465096 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -599,18 +599,13 @@ (syntax-case x (reserved allocable machine-dependent) [(k (reserved [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) (allocable [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) - (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...) - (reify-support reify-reg ...)) - (with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? - cons-reify-registers with-initialized-registers) + (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...)) + (with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? with-initialized-registers) #`(begin (define-reserved-registers [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) (define-allocable-registers regvec arg-registers extra-registers extra-fpregisters with-initialized-registers [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) (define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...) - (define-syntax cons-reify-registers - (syntax-rules () - [(_ reg*) (cons* reify-reg ... reg*)])) (define-syntax real-register? (with-syntax ([real-reg* #''(rreg ... rreg-alias ... ... areg ... areg-alias ... ... mdreg ... mdreg-alias ... ...)]) (syntax-rules () @@ -709,8 +704,6 @@ (fold-right (lambda (reg reg*) (cond - [(eq? (syntax->datum reg) 'reify-support) - #`(cons-reify-registers #,reg*)] [(real-register? (syntax->datum reg)) #`(cons #,reg #,reg*)] [else reg*])) @@ -976,8 +969,8 @@ (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) (declare-intrinsic get-room get-room () (%xp) (%xp)) (declare-intrinsic scan-remembered-set scan-remembered-set () () ()) - (declare-intrinsic reify-1cc reify-1cc (%xp %ac0 reify-support) () (%td)) - (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 reify-support) () (%td)) + (declare-intrinsic reify-1cc reify-1cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; %reify1 & %reify2 are defined as needed per machine... + (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; ... to have enough registers to allocate (declare-intrinsic dooverflow dooverflow () () ()) (declare-intrinsic dooverflood dooverflood () (%xp) ()) ; a dorest routine takes all of the register and frame arguments from the rest @@ -12546,7 +12539,7 @@ (set! ,fv0 ,%xp) ,(%mv-jump ,%xp (,%ac0 ,arg-registers ... ,fv0))))])))))))))))) (define reify-cc-help - (lambda (1-shot? always? finish) + (lambda (1-shot? always? save-ra? finish) (with-output-language (L13 Tail) (%seq (set! ,%td ,(%tc-ref stack-link)) @@ -12555,7 +12548,7 @@ (%seq ,(let ([alloc (%seq - (set! ,%xp ,(%constant-alloc type-closure (constant size-continuation))) + (set! ,%xp ,(%constant-alloc type-closure (constant size-continuation) #f save-ra?)) (set! ,(%mref ,%xp ,(constant continuation-code-disp)) (literal ,(make-info-literal #f 'library (lookup-libspec nuate) (constant code-data-disp)))))]) (if 1-shot? @@ -12697,28 +12690,25 @@ [(dorest4) (make-do-rest 4 frame-args-offset)] [(dorest5) (make-do-rest 5 frame-args-offset)] [(reify-1cc maybe-reify-cc) - (let ([other-reg* (fold-left (lambda (live* kill) (remq kill live*)) - (vector->list regvec) - ;; Registers used by `reify-cc-help` output, - ;; including some as needed per machine - (reg-list %xp %td %ac0 reify-support))] - [1cc? (eq? sym 'reify-1cc)]) + (let ([1cc? (eq? sym 'reify-1cc)]) `(lambda ,(make-named-info-lambda (if 1cc? "reify-1cc" "maybe-reify-cc") '(0)) 0 () ,(asm-enter (%seq - (check-live ,other-reg* ...) - ,(reify-cc-help 1cc? 1cc? + ;; make sure the reify-1cc intrinsic declares kill for registers used by `reify-cc-help`, + ;; plus (say) %ts to have one to allocate, plus more as needed to allocate per machine + (check-live ,(intrinsic-entry-live* reify-1cc) ...) + ,(reify-cc-help 1cc? 1cc? #t (lambda (reg) (if (eq? reg %td) - `(asm-return ,%td ,other-reg* ...) + `(asm-return ,%td ,(intrinsic-return-live* reify-1cc) ...) `(seq (set! ,%td ,reg) - (asm-return ,%td ,other-reg* ...)))))))))] + (asm-return ,%td ,(intrinsic-return-live* reify-1cc) ...)))))))))] [(callcc) `(lambda ,(make-named-info-lambda 'callcc '(1)) 0 () ,(%seq (set! ,(ref-reg %cp) ,(make-arg-opnd 1)) - ,(reify-cc-help #f #f + ,(reify-cc-help #f #f #f (lambda (reg) (%seq (set! ,(make-arg-opnd 1) ,reg) @@ -15716,7 +15706,7 @@ [(asm-return) (values (asm-return) chunk* offset)] [(asm-c-return ,info) (values (asm-c-return info) chunk* offset)] [(jump (label-ref ,l ,offset0)) - (values (asm-direct-jump l (adjust-return-point-offset offset0 l)) chunk* offset)] + (values (asm-direct-jump l offset0) chunk* offset)] [(jump (literal ,info)) (values (asm-literal-jump info) chunk* offset)] [(jump ,t) @@ -15799,8 +15789,7 @@ [(rp-compact-header ,error-on-values ,fs ,lpm) (values (asm-rp-compact-header code* error-on-values fs lpm current-func #f) chunk* offset)] [(set! ,x (label-ref ,l ,offset1)) (guard (eq? (local-label-func l) current-func)) - (let ([chunk (make-chunk code*)] - [offset1 (adjust-return-point-offset offset1 l)]) + (let ([chunk (make-chunk code*)]) (let ([offset (fx+ (chunk-size chunk) offset)] [chunk* (cons chunk chunk*)]) (let ([chunk (asm-return-address x l offset1 offset)]) (values '() (cons chunk chunk*) (fx+ (chunk-size chunk) offset)))))] diff --git a/s/mkheader.ss b/s/mkheader.ss index 7675fdc419..07dc09aedd 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -656,8 +656,8 @@ (pr " \"cmp r12, #0\\n\\t\"\\~%") (pr " \"bne 1f\\n\\t\"\\~%") (pr " \"mov r12, #1\\n\\t\"\\~%") - (pr " \"strex r11, r12, [%0]\\n\\t\"\\~%") - (pr " \"cmp r11, #0\\n\\t\"\\~%") + (pr " \"strex r7, r12, [%0]\\n\\t\"\\~%") + (pr " \"cmp r7, #0\\n\\t\"\\~%") (pr " \"beq 2f\\n\\t\"\\~%") (pr " \"1:\\n\\t\"\\~%") (pr " \"ldr r12, [%0, #0]\\n\\t\"\\~%") @@ -667,7 +667,7 @@ (pr " \"2:\\n\\t\"\\~%") (pr " : \\~%") (pr " : \"r\" (addr)\\~%") - (pr " : \"cc\", \"memory\", \"r12\", \"r11\")~%") + (pr " : \"cc\", \"memory\", \"r12\", \"r7\")~%") (nl) (pr "#define UNLOCK(addr) \\~%") @@ -683,14 +683,14 @@ (pr " \"0:\\n\\t\"\\~%") (pr " \"ldrex r12, [%1, #0]\\n\\t\"\\~%") (pr " \"add r12, r12, #1\\n\\t\"\\~%") - (pr " \"strex r11, r12, [%1]\\n\\t\"\\~%") - (pr " \"cmp r11, #0\\n\\t\"\\~%") + (pr " \"strex r7, r12, [%1]\\n\\t\"\\~%") + (pr " \"cmp r7, #0\\n\\t\"\\~%") (pr " \"bne 0b\\n\\t\"\\~%") (pr " \"cmp r12, #0\\n\\t\"\\~%") (pr " \"moveq %0, #1\\n\\t\"\\~%") (pr " : \"=&r\" (ret)\\~%") (pr " : \"r\" (addr)\\~%") - (pr " : \"cc\", \"memory\", \"r12\", \"r11\")~%") + (pr " : \"cc\", \"memory\", \"r12\", \"r7\")~%") (nl) (pr "#define LOCKED_DECR(addr, ret) \\~%") @@ -698,14 +698,14 @@ (pr " \"0:\\n\\t\"\\~%") (pr " \"ldrex r12, [%1, #0]\\n\\t\"\\~%") (pr " \"sub r12, r12, #1\\n\\t\"\\~%") - (pr " \"strex r11, r12, [%1]\\n\\t\"\\~%") - (pr " \"cmp r11, #0\\n\\t\"\\~%") + (pr " \"strex r7, r12, [%1]\\n\\t\"\\~%") + (pr " \"cmp r7, #0\\n\\t\"\\~%") (pr " \"bne 0b\\n\\t\"\\~%") (pr " \"cmp r12, #0\\n\\t\"\\~%") (pr " \"moveq %0, #1\\n\\t\"\\~%") (pr " : \"=&r\" (ret)\\~%") (pr " : \"r\" (addr)\\~%") - (pr " : \"cc\", \"memory\", \"r12\", \"r11\")~%")] + (pr " : \"cc\", \"memory\", \"r12\", \"r7\")~%")] [else ($oops who "asm locking code is not yet defined for ~s" (constant architecture))])))) diff --git a/s/x86.ss b/s/x86.ss index 25986f6dc1..a94c58b9cc 100644 --- a/s/x86.ss +++ b/s/x86.ss @@ -38,8 +38,7 @@ [%fptmp1 #f 0 fp] [%fptmp2 #f 1 fp] [%sp #t 4 uptr] - #;[%esi #f 6]) - (reify-support %ts)) + #;[%esi #f 6])) ;;; SECTION 2: instructions (module (md-handle-jump) ; also sets primitive handlers @@ -812,7 +811,7 @@ [(op (z mem)) `(asm ,info ,asm-flds ,z)]) (define-instruction effect (load-single->double load-double->single) - [(op (x ur) (y ur) (z imm32)) + [(op (x ur) (y ur) (z imm32))< `(asm ,info ,(asm-fl-cvt op (info-loadfl-flreg info)) ,x ,y ,z)]) (define-instruction effect (store-single store-double) @@ -2323,7 +2322,8 @@ (define asm-direct-jump (lambda (l offset) - (emit bra (make-funcrel 'literal l offset) '()))) + (let ([offset (adjust-return-point-offset offset l)]) + (emit bra (make-funcrel 'literal l offset) '())))) (define asm-literal-jump (lambda (info) diff --git a/s/x86_64.ss b/s/x86_64.ss index c62724fb73..8488b823d7 100644 --- a/s/x86_64.ss +++ b/s/x86_64.ss @@ -43,8 +43,7 @@ [%Cfparg2 #f 1 fp] [%fptmp1 #f 4 fp] ; xmm 0-5 are caller-save [%fptmp2 #f 5 fp] ; xmm 6-15 are callee-save - [%sp #t 4 uptr]) - (reify-support %ts)) + [%sp #t 4 uptr])) (define-registers (reserved [%tc %r14 #t 14 uptr] @@ -77,8 +76,7 @@ [%Cfparg8 #f 7 fp] [%fptmp1 #f 8 fp] [%fptmp2 #f 9 fp] - [%sp #t 4 uptr]) - (reify-support %ts))) + [%sp #t 4 uptr]))) ;;; SECTION 2: instructions (module (md-handle-jump) ; also sets primitive handlers @@ -2523,7 +2521,8 @@ (define asm-direct-jump (lambda (l offset) - (asm-helper-jump '() (make-funcrel 'x86_64-jump l offset)))) + (let ([offset (adjust-return-point-offset offset l)]) + (asm-helper-jump '() (make-funcrel 'x86_64-jump l offset))))) (define asm-literal-jump (lambda (info) @@ -2543,10 +2542,11 @@ (or (cond [(local-label-offset l) => (lambda (offset) - (let ([disp (fx- next-addr (fx- offset incr-offset))]) - (and (signed-32? disp) - (Trivit (dest) - (emit lea `(riprel ,disp) dest '())))))] + (let ([incr-offset (adjust-return-point-offset incr-offset l)]) + (let ([disp (fx- next-addr (fx- offset incr-offset))]) + (and (signed-32? disp) + (Trivit (dest) + (emit lea `(riprel ,disp) dest '()))))))] [else #f]) (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))))))