repairs for arm32le
Includes a repair by @cjfrisz at cisco/ChezScheme#510 original commit: e7ee15332bd8f0e5f0887cff9f6ee45b8b38a4f1
This commit is contained in:
Matthew Flatt
parent
c103184272
commit
d2069742ee
72
s/arm32.ss
72
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))
|
||||
|
|
|
|||
|
|
@ -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)))))]
|
||||
|
|
|
|||
|
|
@ -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))]))))
|
||||
|
||||
|
|
|
|||
8
s/x86.ss
8
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)
|
||||
|
|
|
|||
18
s/x86_64.ss
18
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)))))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user