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

clean up backend API for floating point

Browse Source 
Simplify and normalize backend elements for loading, storing, and
converting floating-point numbers, taking better advantage of
new support for floating-pointer registers.

original commit: 4066af9cf3799392ef785a77da69f7cfff74d2fe
This commit is contained in:
Matthew Flatt 2020-06-07 09:11:20 -06:00
parent a5f877f95d
commit 69b597e496
5 changed files with 346 additions and 380 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

381
s/arm32.ss
View File

@ -80,8 +80,8 @@
[ %r2 %Carg3 %reify1 #f 2 uptr] [ %r2 %Carg3 %reify1 #f 2 uptr]
[ %r3 %Carg4 %reify2 #f 3 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 [ %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] [%fp1 %d8 %s16 #t 16 fp] ; allocable fp regs must not overlap with any half registers
[%fp2 %Cfparg6 %d5 %s10 #f 10 fp] [%fp2 %d9 %s18 #t 18 fp]
) )
(machine-dependent (machine-dependent
[%sp #t 13 uptr] [%sp #t 13 uptr]
@ -94,10 +94,12 @@
[%Cfparg3b %s5 #f 5 fp] [%Cfparg3b %s5 #f 5 fp]
[%Cfparg4 %d3 %s6 #f 6 fp] [%Cfparg4 %d3 %s6 #f 6 fp]
[%Cfparg4b %s7 #f 7 fp] [%Cfparg4b %s7 #f 7 fp]
[%Cfparg5 %d4 %s8 #f 8 fp]
[%Cfparg5b %s9 #f 9 fp] [%Cfparg5b %s9 #f 9 fp]
[%Cfparg6 %d5 %s10 #f 10 fp]
[%Cfparg6b %s11 #f 11 fp] [%Cfparg6b %s11 #f 11 fp]
[%Cfparg7 %fptmp1 %d6 %s12 #f 12 fp] [%Cfparg7 %d6 %s12 #f 12 fp]
[%Cfparg7b %fptmp2 %s13 #f 13 fp] [%Cfparg7b %s13 #f 13 fp]
[%Cfparg8 %d7 %s14 #f 14 fp] [%Cfparg8 %d7 %s14 #f 14 fp]
[%Cfparg8b %s15 #f 15 fp] [%Cfparg8b %s15 #f 15 fp]
;; etc., but other FP registers are preserved ;; etc., but other FP registers are preserved
@ -261,7 +263,7 @@
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))] (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))]
[else (mref->mref a k)]))) [else (mref->mref a k)])))
(define fpmem->fpmem (define fpmem->fpmem ; allows mem argument, too
(lambda (a k) (lambda (a k)
(define return (define return
(lambda (x0 x1 imm) (lambda (x0 x1 imm)
@ -292,6 +294,10 @@
[else [else
(return x0 %zero imm)])))))]))) (return x0 %zero imm)])))))])))
(define mem->fpmem
(lambda (a k)
(fpmem->fpmem a k)))
(define-syntax coercible? (define-syntax coercible?
(syntax-rules () (syntax-rules ()
[(_ ?a ?aty*) [(_ ?a ?aty*)
@ -306,7 +312,8 @@
(and (memq 'unsigned12 aty*) (imm-unsigned12? a)) (and (memq 'unsigned12 aty*) (imm-unsigned12? a))
(and (memq 'imm-constant aty*) (imm-constant? a)) (and (memq 'imm-constant aty*) (imm-constant? a))
(and (memq 'uword8 aty*) (imm-uword8? a)) (and (memq 'uword8 aty*) (imm-uword8? a))
(and (memq 'mem aty*) (mem? a))))])) (and (memq 'mem aty*) (mem? a))
(and (memq 'fpmem aty*) (fpmem? a))))]))
(define-syntax coerce-opnd ; passes k something compatible with aty* (define-syntax coerce-opnd ; passes k something compatible with aty*
(syntax-rules () (syntax-rules ()
@ -314,6 +321,7 @@
(let ([a ?a] [aty* ?aty*] [k ?k]) (let ([a ?a] [aty* ?aty*] [k ?k])
(cond (cond
[(and (memq 'mem aty*) (mem? a)) (mem->mem a k)] [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
[(and (memq 'fpmem aty*) (fpmem? a)) (fpmem->fpmem a k)]
[(and (memq 'funky12 aty*) (imm-funky12? a)) (k (imm->imm a))] [(and (memq 'funky12 aty*) (imm-funky12? a)) (k (imm->imm a))]
[(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a)) (k (imm->negate-imm a))] [(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a)) (k (imm->negate-imm a))]
[(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a)) (k (imm->lognot-imm a))] [(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a)) (k (imm->lognot-imm a))]
@ -384,12 +392,6 @@
(define-syntax define-instruction (define-syntax define-instruction
(lambda (x) (lambda (x)
(define mem-type?
(lambda (t)
(syntax-case t (mem fpmem)
[mem #t]
[fpmem #t]
[else #f])))
(define make-value-clause (define make-value-clause
(lambda (fmt) (lambda (fmt)
(syntax-case fmt (mem fpmem ur fpur) (syntax-case fmt (mem fpmem ur fpur)
@ -721,52 +723,33 @@
`(asm ,null-info ,(asm-store type) ,x ,y ,w ,u))) `(asm ,null-info ,(asm-store type) ,x ,y ,w ,u)))
`(asm ,null-info ,(asm-store type) ,x ,y ,w ,z)))))])) `(asm ,null-info ,(asm-store type) ,x ,y ,w ,z)))))]))
(let () (define-instruction value (load-single->double)
(define pick-asm-op [(op (x fpur) (y fpmem))
(lambda (op info) (let ([u (make-tmp 'u 'fp)])
(let ([flreg (info-loadfl-flreg info)]) (seq
(case op `(set! ,(make-live-info) ,u (asm ,null-info ,asm-fpmove-single ,y))
[(load-single->double load-double->single) (asm-fl-load/cvt op flreg)] `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,u))))])
[(store-single->double) (asm-fl-store/cvt op flreg)]
[else (asm-fl-load/store op flreg)])))) (define-instruction effect (store-double->single)
(define-instruction effect (load-single->double load-double->single store-single->double [(op (x fpmem) (y fpur))
store-single store-double (let ([u (make-tmp 'u 'fp)])
load-single load-double) (seq
[(op (x ur) (y ur) (z uword8)) `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y))
(if (eq? y %zero) `(asm ,info ,asm-fpmove-single ,x ,u)))])
`(asm ,info ,(pick-asm-op op info) ,x ,z)
(let ([u (make-tmp 'u)]) (define-instruction effect (store-single)
(seq [(op (x fpmem) (y fpur))
`(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,x ,y)) `(asm ,info ,asm-fpmove-single ,x ,y)])
`(asm ,info ,(pick-asm-op op info) ,u ,z))))]
[(op (x ur) (y ur) (z ur)) (define-instruction value (load-single)
(let ([u (make-tmp 'u)]) [(op (x fpur) (y fpmem))
(seq `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove-single ,y))])
`(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,x ,z))
(if (eq? y %zero) (define-instruction value (single->double double->single)
`(asm ,info ,(pick-asm-op op info) ,u (immediate 0)) [(op (x fpur) (y fpur))
(seq `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt op) ,y))])
`(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,u ,y))
`(asm ,info ,(pick-asm-op op info) ,u (immediate 0))))))]))
(let () (let ()
; vldr, vstr allow only word offsets, and we require byte offset due to the type tag
(module (with-flonum-data-pointers)
(define $flonum-data-pointer
(lambda (x p)
(with-output-language (L15d Effect)
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x (immediate ,(constant flonum-data-disp))))
(p u))))))
(define-syntax with-flonum-data-pointers
(syntax-rules ()
[(_ () e1 e2 ...) (begin e1 e2 ...)]
[(_ (x1 x2 ...) e1 e2 ...)
($flonum-data-pointer x1
(lambda (x1)
(with-flonum-data-pointers (x2 ...) e1 e2 ...)))])))
(define (fpmem->mem mem dir) (define (fpmem->mem mem dir)
(with-output-language (L15d Triv) (with-output-language (L15d Triv)
(nanopass-case (L15d Triv) mem (nanopass-case (L15d Triv) mem
@ -780,45 +763,48 @@
(define-instruction value (fpt) (define-instruction value (fpt)
[(op (x fpur) (y ur)) [(op (x fpur) (y ur))
`(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))]) (let ([u (make-tmp 'u 'fp)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y, u))))])
(define-instruction value (fpmove) (define-instruction value (fpmove)
[(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)] [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)]
[(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x ,y)]) [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)])
(define-instruction value (fpcastto/hi) (define-instruction value (fpcastto/hi)
[(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(fpmem->mem y 'hi))] [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(fpmem->mem y 'hi))]
[(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'hi) ,y))]) [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'hi) ,y))])
(define-instruction value (fpcastto/lo) (define-instruction value (fpcastto/lo)
[(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(fpmem->mem y 'lo))] [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(fpmem->mem y 'lo))]
[(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'lo) ,y))]) [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'lo) ,y))])
(define-instruction value (fpcastfrom) (define-instruction value (fpcastfrom)
[(op (x fpmem) (hi ur) (lo ur)) (seq [(op (x fpmem) (hi ur) (lo ur)) (seq
`(set! ,(make-live-info) ,(fpmem->mem x 'lo) ,lo) `(set! ,(make-live-info) ,(fpmem->mem x 'lo) ,lo)
`(set! ,(make-live-info) ,(fpmem->mem x 'hi) ,hi))] `(set! ,(make-live-info) ,(fpmem->mem x 'hi) ,hi))]
[(op (x fpur) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,lo ,hi))]) [(op (x fpur) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,lo ,hi))]))
(define-instruction value (fp+ fp- fp/ fp*)
[(op (x fpur) (y fpur) (z fpur))
`(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
(define-instruction value (fpsqrt)
[(op (x fpur) (y fpur))
`(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
(define-instruction value (fp+ fp- fp/ fp*) (define-instruction value (fptrunc)
[(op (x fpur) (y fpur) (z fpur)) [(op (z ur) (x fpur))
`(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))]) (let ([u (make-tmp 'u 'fp)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(set! ,(make-live-info) ,z (asm ,info ,asm-fptrunc ,x ,u))))])
(define-instruction value (fpsqrt) (define-instruction pred (fp= fp< fp<=)
[(op (x fpur) (y fpur)) [(op (x fpur) (y fpur))
`(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))]) (let ([info (make-info-condition-code op #f #f)])
(values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])
(define-instruction value (trunc)
[(op (z ur) (x ur))
(with-flonum-data-pointers (x)
`(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x)))])
(define-instruction pred (fp= fp< fp<=)
[(op (x fpur) (y fpur))
(let ([info (make-info-condition-code op #f #f)])
(values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]))
(define-instruction effect (inc-cc-counter) (define-instruction effect (inc-cc-counter)
[(op (x ur) (w ur funky12) (z funky12 ur)) [(op (x ur) (w ur funky12) (z funky12 ur))
@ -993,6 +979,9 @@
(define-instruction effect (vpush-multiple) (define-instruction effect (vpush-multiple)
[(op) `(asm ,info ,(asm-vpush-multiple (info-vpush-reg info) (info-vpush-n info)))]) [(op) `(asm ,info ,(asm-vpush-multiple (info-vpush-reg info) (info-vpush-n info)))])
(define-instruction effect (vpop-multiple)
[(op) `(asm ,info ,(asm-vpop-multiple (info-vpush-reg info) (info-vpush-n info)))])
(define-instruction effect save-flrv (define-instruction effect save-flrv
[(op) `(asm ,info ,asm-save-flrv)]) [(op) `(asm ,info ,asm-save-flrv)])
@ -1008,13 +997,12 @@
asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump
asm-mul asm-smull asm-cmp/shift asm-add asm-sub asm-rsb asm-logand asm-logor asm-logxor asm-bic asm-mul asm-smull asm-cmp/shift asm-add asm-sub asm-rsb asm-logand asm-logor asm-logxor asm-bic
asm-pop-multiple asm-shiftop asm-logand asm-lognot asm-pop-multiple asm-shiftop asm-logand asm-lognot
asm-logtest asm-fp-relop asm-relop asm-push-multiple asm-vpush-multiple asm-logtest asm-fp-relop asm-relop asm-push-multiple asm-vpush-multiple asm-vpop-multiple
asm-indirect-jump asm-literal-jump asm-indirect-jump asm-literal-jump
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
asm-rp-header asm-rp-compact-header asm-rp-header asm-rp-compact-header
asm-indirect-call asm-condition-code asm-indirect-call asm-condition-code
asm-fl-load/store asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc
asm-fl-load/cvt asm-fl-store/cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-trunc
asm-lock asm-lock+/- asm-cas asm-lock asm-lock+/- asm-cas
asm-fpop-2 asm-fpsqrt asm-c-simple-call asm-fpop-2 asm-fpsqrt asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
@ -1189,7 +1177,8 @@
(define-op popm pm-op #b10001011) (define-op popm pm-op #b10001011)
(define-op pushm pm-op #b10010010) (define-op pushm pm-op #b10010010)
(define-op vpushm vpushm-op) (define-op vpushm vpm-op #b11010 #b10)
(define-op vpopm vpm-op #b11001 #b11)
(define-op vldr.sgl vldr/vstr-op #b1010 #b01) (define-op vldr.sgl vldr/vstr-op #b1010 #b01)
(define-op vldr.dbl vldr/vstr-op #b1011 #b01) (define-op vldr.dbl vldr/vstr-op #b1011 #b01)
@ -1574,14 +1563,15 @@
[12 #b1111] [12 #b1111]
[0 #b101000010000]))) [0 #b101000010000])))
(define vpushm-op (define vpm-op
(lambda (op flreg n code*) (lambda (op opcode opcode2 flreg n code*)
(let-values ([(d vd) (ax-flreg->bits flreg)]) (let-values ([(d vd) (ax-flreg->bits flreg)])
(emit-code (op flreg n code*) (emit-code (op flreg n code*)
[28 (ax-cond 'al)] [28 (ax-cond 'al)]
[23 #b11010] [23 opcode]
[22 d] [22 d]
[16 #b101101] [20 opcode2]
[16 #b1101]
[12 vd] [12 vd]
[8 #b1011] [8 #b1011]
[0 (fxsll n 1)])))) [0 (fxsll n 1)]))))
@ -1959,40 +1949,15 @@
(Trivit (src0 src1) (Trivit (src0 src1)
(emit cmp/shift count type src0 src1 code*))))) (emit cmp/shift count type src0 src1 code*)))))
(define-who asm-fl-load/cvt (define-who asm-fl-cvt
(lambda (op flreg) (lambda (op)
(lambda (code* base offset) (lambda (code* dest-reg src-reg)
(Trivit (base offset) (case op
(case op [(single->double)
[(load-single->double) (emit vcvt.sgl->dbl dest-reg src-reg code*)]
(emit vldr.sgl %fptmp2 base (ax-imm-data offset) [(double->single)
(emit vcvt.sgl->dbl flreg %fptmp2 code*))] (emit vcvt.dbl->sgl dest-reg src-reg code*)]
[(load-double->single) [else (sorry! who "unrecognized op ~s" op)]))))
(emit vldr.dbl %fptmp2 base (ax-imm-data offset)
(emit vcvt.dbl->sgl flreg %fptmp2 code*))]
[else (sorry! who "unrecognized op ~s" op)])))))
(define-who asm-fl-store/cvt
(lambda (op flreg)
(lambda (code* base offset)
(Trivit (base offset)
(case op
[(store-single->double)
(emit vcvt.sgl->dbl %fptmp2 flreg
(emit vstr.dbl %fptmp2 base (ax-imm-data offset) code*))]
[else (sorry! who "unrecognized op ~s" op)])))))
(define-who asm-fl-load/store
(lambda (op flreg)
(lambda (code* base offset)
(Trivit (base offset)
(let ([offset (ax-imm-data offset)])
(case op
[(load-single) (emit vldr.sgl flreg base offset code*)]
[(load-double) (emit vldr.dbl flreg base offset code*)]
[(store-single) (emit vstr.sgl flreg base offset code*)]
[(store-double) (emit vstr.dbl flreg base offset code*)]
[else (sorry! who "unrecognized op ~s" op)]))))))
(define-who asm-load (define-who asm-load
(lambda (type) (lambda (type)
@ -2060,37 +2025,51 @@
(lambda (code* dest src) (lambda (code* dest src)
(emit vsqrt dest src code*))) (emit vsqrt dest src code*)))
(define asm-trunc (define asm-fptrunc
(lambda (code* dest flonumreg) (lambda (code* dest flonumreg tmpreg)
(Trivit (dest flonumreg) (Trivit (dest)
(emit vldr.dbl %fptmp1 flonumreg 0 (emit vcvt.dbl->s32 tmpreg flonumreg
(emit vcvt.dbl->s32 %fptmp1 %fptmp1 (emit vmov.s32->gpr tmpreg 0 dest code*)))))
(emit vmov.s32->gpr %fptmp1 0 dest code*))))))
(define asm-fpt (define asm-fpt
(lambda (code* dest src) (lambda (code* dest src tmpreg)
(Trivit (src) (Trivit (src)
(emit vmov.gpr->s32 %fptmp1 0 src (emit vmov.gpr->s32 tmpreg 0 src
(emit vcvt.s32->dbl dest %fptmp1 code*))))) (emit vcvt.s32->dbl dest tmpreg code*)))))
(define-who asm-fpmove (define-who asm-fpmove
;; fpmove pseudo instruction is used by set! case in ;; fpmove pseudo instruction is used by set! case in
;; select-instructions! and generate-code; at most one of src or ;; select-instructions! and generate-code; at most one of src or
;; dest can be an mref, and then the offset is double-aligned ;; dest can be an mref, and then the offset is double-aligned
(lambda (code* dest src) (lambda (code* dest src)
(gen-fpmove who code* dest src #t)))
(define-who asm-fpmove-single
;; fpmove pseudo instruction is used by set! case in
;; select-instructions! and generate-code; at most one of src or
;; dest can be an mref, and then the offset is double-aligned
(lambda (code* dest src)
(gen-fpmove who code* dest src #f)))
(define gen-fpmove
(lambda (who code* dest src double?)
(let ([dest-it dest] (let ([dest-it dest]
[src-it src]) [src-it src])
(Trivit (dest-it src-it) (Trivit (dest-it src-it)
(record-case dest-it (record-case dest-it
[(disp) (imm reg) [(disp) (imm reg)
(safe-assert (fx= 0 (fxand imm #b11))) (safe-assert (fx= 0 (fxand imm #b11)))
(emit vstr.dbl src (cons 'reg reg) imm code*)] (if double?
(emit vstr.dbl src (cons 'reg reg) imm code*)
(emit vstr.sgl src (cons 'reg reg) imm code*))]
[(index) (n ireg breg) (sorry! who "cannot handle indexed fp dest ref")] [(index) (n ireg breg) (sorry! who "cannot handle indexed fp dest ref")]
[else [else
(record-case src-it (record-case src-it
[(disp) (imm reg) [(disp) (imm reg)
(safe-assert (fx= 0 (fxand imm #b11))) (safe-assert (fx= 0 (fxand imm #b11)))
(emit vldr.dbl dest (cons 'reg reg) imm code*)] (if double?
(emit vldr.dbl dest (cons 'reg reg) imm code*)
(emit vldr.sgl dest (cons 'reg reg) imm code*))]
[(index) (n ireg breg) (sorry! who "cannot handle indexed fp src ref")] [(index) (n ireg breg) (sorry! who "cannot handle indexed fp src ref")]
[else (emit vmov.fpr dest src code*)])]))))) [else (emit vmov.fpr dest src code*)])])))))
@ -2211,6 +2190,11 @@
(lambda (code*) (lambda (code*)
(emit vpushm reg n code*)))) (emit vpushm reg n code*))))
(define asm-vpop-multiple
(lambda (reg n)
(lambda (code*)
(emit vpopm reg n code*))))
(define asm-save-flrv (define asm-save-flrv
(lambda (code*) (lambda (code*)
(let ([sp (cons 'reg %sp)]) (let ([sp (cons 'reg %sp)])
@ -2574,15 +2558,13 @@
(letrec ([load-double-stack (letrec ([load-double-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,%sp ,%zero ,offset fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)) ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))]
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
[load-single-stack [load-single-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)) ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))]
(inline ,(make-info-loadfl %fptmp1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
[load-int-stack [load-int-stack
(lambda (offset) (lambda (offset)
(lambda (rhs) ; requires rhs (lambda (rhs) ; requires rhs
@ -2615,11 +2597,12 @@
[load-double-reg [load-double-reg
(lambda (fpreg fp-disp) (lambda (fpreg fp-disp)
(lambda (x) ; requires var (lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp))))] `(set! ,fpreg ,(%mref ,x ,%zero ,fp-disp fp))))]
[load-single-reg [load-single-reg
(lambda (fpreg fp-disp single?) (lambda (fpreg fp-disp single?)
(lambda (x) ; requires var (lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))))] (let ([%op (if single? %load-single %double->single)])
`(set! ,fpreg (inline ,null-info ,%op ,(%mref ,x ,%zero ,fp-disp fp))))))]
[load-double-int-reg [load-double-int-reg
(lambda (loreg hireg) (lambda (loreg hireg)
(lambda (x) ; requires var (lambda (x) ; requires var
@ -2688,20 +2671,20 @@
[else [else
(loop (cdr types) (loop (cdr types)
(cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs) (cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs)
live* int* (cddr sgl*) bsgl isp)])] (cons (car sgl*) live*) int* (cddr sgl*) bsgl isp)])]
[(fp-single-float) [(fp-single-float)
(safe-assert (not varargs?)) (safe-assert (not varargs?))
(if bsgl (if bsgl
(loop (cdr types) (loop (cdr types)
(cons (load-single-reg bsgl (constant flonum-data-disp) #f) locs) (cons (load-single-reg bsgl (constant flonum-data-disp) #f) locs)
live* int* sgl* #f isp) (cons bsgl live*) int* sgl* #f isp)
(if (null? sgl*) (if (null? sgl*)
(loop (cdr types) (loop (cdr types)
(cons (load-single-stack isp) locs) (cons (load-single-stack isp) locs)
live* int* '() #f (fx+ isp 4)) live* int* '() #f (fx+ isp 4))
(loop (cdr types) (loop (cdr types)
(cons (load-single-reg (car sgl*) (constant flonum-data-disp) #f) locs) (cons (load-single-reg (car sgl*) (constant flonum-data-disp) #f) locs)
live* int* (cddr sgl*) (cadr sgl*) isp)))] (cons (car sgl*) live*) int* (cddr sgl*) (cadr sgl*) isp)))]
[(fp-ftd& ,ftd) [(fp-ftd& ,ftd)
(let ([size ($ftd-size ftd)] (let ([size ($ftd-size ftd)]
[members ($ftd->members ftd)] [members ($ftd->members ftd)]
@ -2755,7 +2738,7 @@
[(and floats? [(and floats?
(fx>= (fx+ (length sgl*) (if bsgl 1 0)) num-members)) (fx>= (fx+ (length sgl*) (if bsgl 1 0)) num-members))
;; Allocate each float to register ;; Allocate each float to register
(let flt-loop ([size size] [offset 0] [sgl* sgl*] [bsgl bsgl] [loc #f]) (let flt-loop ([size size] [offset 0] [sgl* sgl*] [bsgl bsgl] [loc #f] [live* live*])
(cond (cond
[(fx= size 0) [(fx= size 0)
(loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)] (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)]
@ -2763,7 +2746,8 @@
(flt-loop (fx- size 4) (fx+ offset 4) (flt-loop (fx- size 4) (fx+ offset 4)
(if bsgl sgl* (cddr sgl*)) (if bsgl sgl* (cddr sgl*))
(if bsgl #f (cadr sgl*)) (if bsgl #f (cadr sgl*))
(combine-loc loc (load-single-reg (or bsgl (car sgl*)) offset #t)))]))] (combine-loc loc (load-single-reg (or bsgl (car sgl*)) offset #t))
(cons (or bsgl (car sgl*)) live*))]))]
[else [else
;; General case; use integer registers while available, ;; General case; use integer registers while available,
;; possibly splitting between registers and stack ;; possibly splitting between registers and stack
@ -2827,8 +2811,9 @@
(fx+ offset (if double? 8 4)) (fx+ offset (if double? 8 4))
`(seq `(seq
,e ,e
(inline ,(make-info-loadfl (car sgl*)) ,(if double? %store-double %store-single) ,(if double?
,dest-x ,%zero (immediate ,offset))))])))] `(set! ,(%mref ,dest-x ,%zero ,offset fp) ,(car sgl*))
(%inline store-single ,(%mref ,dest-x ,%zero ,offset fp) ,(car sgl*)))))])))]
[else [else
;; result is in %Cretval and maybe %r1 ;; result is in %Cretval and maybe %r1
`(seq `(seq
@ -2844,12 +2829,33 @@
[(8) `(seq [(8) `(seq
(set! ,(%mref ,dest-x ,0) ,%Cretval) (set! ,(%mref ,dest-x ,0) ,%Cretval)
(set! ,(%mref ,dest-x ,4) ,%r1))]))]))])] (set! ,(%mref ,dest-x ,4) ,%r1))]))]))])]
[else e]))]) [else e]))]
[get-result-regs
(lambda (result-type varargs?)
(nanopass-case (Ltype Type) result-type
[(fp-double-float)
(if varargs?
(list %r1 %Cretval)
(list %Cfpretval))]
[(fp-single-float)
(if varargs?
(list %Cretval)
(list %Cfpretval))]
[(fp-integer ,bits)
(case bits
[(64) (list %r1 %Cretval)]
[else (list %Cretval)])]
[(fp-unsigned ,bits)
(case bits
[(64) (list %r1 %Cretval)]
[else (list %Cretval)])]
[else (list %r0)]))])
(lambda (info) (lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let* ([arg-type* (info-foreign-arg-type* info)] (let* ([arg-type* (info-foreign-arg-type* info)]
[varargs? (memq 'varargs (info-foreign-conv* info))] [varargs? (memq 'varargs (info-foreign-conv* info))]
[result-type (info-foreign-result-type info)] [result-type (info-foreign-result-type info)]
[result-reg* (get-result-regs result-type varargs?)]
[fill-result-here? (indirect-result-that-fits-in-registers? result-type)]) [fill-result-here? (indirect-result-that-fits-in-registers? result-type)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)
varargs?) varargs?)
@ -2873,7 +2879,7 @@
[else locs])) [else locs]))
(lambda (t0) (lambda (t0)
(add-fill-result fill-result-here? result-type args-frame-size (add-fill-result fill-result-here? result-type args-frame-size
`(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0))) `(inline ,(make-info-kill*-live* result-reg* live*) ,%c-call ,t0)))
(nanopass-case (Ltype Type) result-type (nanopass-case (Ltype Type) result-type
[(fp-double-float) [(fp-double-float)
(if varargs? (if varargs?
@ -2881,18 +2887,17 @@
`(set! ,(%mref ,lvalue ,%zero ,(constant flonum-data-disp) fp) `(set! ,(%mref ,lvalue ,%zero ,(constant flonum-data-disp) fp)
,(%inline fpcastfrom ,%r1 ,%Cretval))) ,(%inline fpcastfrom ,%r1 ,%Cretval)))
(lambda (lvalue) (lambda (lvalue)
`(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero `(set! ,(%mref ,lvalue ,%zero ,(constant flonum-data-disp) fp)
,(%constant flonum-data-disp))))] ,%Cfpretval)))]
[(fp-single-float) [(fp-single-float)
(if varargs? (if varargs?
(lambda (lvalue) (lambda (lvalue)
`(seq (let ([t %Cfpretval]) ; should be ok as a temporary register
(set! ,%fptmp1 ,(%inline fpcastfrom ,%r1 ,%Cretval)) ; we don't actuall care about the hi/%r1 part `(seq
(inline ,(make-info-loadfl %fptmp1) ,%store-single->double ,lvalue ,%zero, (set! ,t ,(%inline fpcastfrom ,%r1 ,%Cretval)) ; we don't actually care about the hi/%r1 part
(%constant flonum-data-disp)))) (set! ,(%mref ,lvalue ,%zero ,(constant flonum-data-disp) fp) ,(%inline single->double ,t)))))
(lambda (lvalue) (lambda (lvalue)
`(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero `(set! ,(%mref ,lvalue ,%zero ,(constant flonum-data-disp) fp) ,(%inline single->double ,%Cfpretval))))]
,(%constant flonum-data-disp))))]
[(fp-integer ,bits) [(fp-integer ,bits)
(case bits (case bits
[(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%r0)))] [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%r0)))]
@ -2923,31 +2928,31 @@
+---------------------------+ +---------------------------+
| | | |
| incoming stack args | | incoming stack args |
sp+36+R+X+Y+Z+W: | | sp+52+R+X+Y+Z+W: | |
+---------------------------+<- 8-byte boundary +---------------------------+<- 8-byte boundary
| | | |
| saved int reg args | 0-4 words | saved int reg args | 0-4 words
sp+36+R+X+Y+Z: | | sp+52+R+X+Y+Z: | |
+---------------------------+ +---------------------------+
| | | |
| pad word if necessary | 0-1 words | pad word if necessary | 0-1 words
sp+36+R+X+Y: | | sp+52+R+X+Y: | |
+---------------------------+<- 8-byte boundary +---------------------------+<- 8-byte boundary
| | | |
| saved float reg args | 0-16 words | saved float reg args | 0-16 words
sp+36+R+X: | | sp+52+R+X: | |
+---------------------------+<- 8-byte boundary +---------------------------+<- 8-byte boundary
| | | |
| &-return space | up to 8 words | &-return space | up to 8 words
sp+36+R: | | sp+52+R: | |
+---------------------------+<- 8-byte boundary +---------------------------+<- 8-byte boundary
| | | |
| pad word if necessary | 0-1 words | pad word if necessary | 0-1 words
sp+36: | | sp+52: | |
+---------------------------+ +---------------------------+
| | | |
| callee-save regs + lr | 9 words | callee-save regs + lr | 13 words
sp+0: | | sp+0: | callee-save fpregs |
+---------------------------+<- 8-byte boundary +---------------------------+<- 8-byte boundary
X = 0 or 4 (depending on whether pad is present) X = 0 or 4 (depending on whether pad is present)
@ -2959,15 +2964,13 @@
(define load-double-stack (define load-double-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,%sp ,%zero (immediate ,offset)) ,(%mref ,%sp ,%zero ,offset fp)))))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-single-stack (define load-single-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-single->double ,%sp ,%zero (immediate ,offset)) ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-int-stack (define load-int-stack
(lambda (type offset) (lambda (type offset)
(lambda (lvalue) (lambda (lvalue)
@ -3224,8 +3227,9 @@
(if double? (cddr sgl*) (cdr sgl*)) (if double? (cddr sgl*) (cdr sgl*))
(fx+ offset (if double? 8 4)) (fx+ offset (if double? 8 4))
(let ([new-e (let ([new-e
`(inline ,(make-info-loadfl (car sgl*)) ,(if double? %load-double %load-single) (if double?
,%sp ,%zero (immediate ,offset))]) `(set! ,(car sgl*) ,(%mref ,%sp ,%zero ,offset fp))
`(set! ,(car sgl*) ,(%inline load-single ,(%mref ,%sp ,%zero ,offset fp))))])
(if e `(seq ,e ,new-e) new-e)))])))) (if e `(seq ,e ,new-e) new-e)))]))))
'() '()
($ftd-size ftd))] ($ftd-size ftd))]
@ -3260,25 +3264,22 @@
(set! ,endreg ,(%mref ,rhs ,(constant flonum-data-disp))) (set! ,endreg ,(%mref ,rhs ,(constant flonum-data-disp)))
(set! ,otherreg ,(%mref ,rhs ,(fx+ 4 (constant flonum-data-disp))))))) (set! ,otherreg ,(%mref ,rhs ,(fx+ 4 (constant flonum-data-disp)))))))
(lambda (rhs) (lambda (rhs)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double `(set! ,%Cfpretval ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp))))
,rhs ,%zero ,(%constant flonum-data-disp))))
(if varargs? (if varargs?
(list %Cretval %r1) (list %Cretval %r1)
'()) (list %Cfpretval))
0)] 0)]
[(fp-single-float) [(fp-single-float)
(values (if varargs? (values (if varargs?
(lambda (rhs) (lambda (rhs)
`(seq `(seq
(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single (set! ,%Cfpretval ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp)))
,rhs ,%zero ,(%constant flonum-data-disp))
(set! ,%Cretval ,(%inline fpcastto/lo ,%Cfpretval)))) (set! ,%Cretval ,(%inline fpcastto/lo ,%Cfpretval))))
(lambda (rhs) (lambda (rhs)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single `(set! ,%Cfpretval ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp)))))
,rhs ,%zero ,(%constant flonum-data-disp))))
(if varargs? (if varargs?
(list %Cretval) (list %Cretval)
'()) (list %Cfpretval))
0)] 0)]
[(fp-void) [(fp-void)
(values (lambda () `(nop)) (values (lambda () `(nop))
@ -3303,13 +3304,21 @@
0)])]))) 0)])])))
(lambda (info) (lambda (info)
(define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr)) (define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr))
(define callee-save-fpregs (list %fp1 %fp2)) ; must be consecutive
(define isaved (length callee-save-regs+lr)) (define isaved (length callee-save-regs+lr))
(define fpsaved (length callee-save-fpregs))
(safe-assert (andmap (lambda (r)
(or (not (reg-callee-save? r))
(if (eq? (reg-type r) 'fp)
(memq r callee-save-fpregs)
(memq r callee-save-regs+lr))))
(vector->list regvec)))
(let* ([arg-type* (info-foreign-arg-type* info)] (let* ([arg-type* (info-foreign-arg-type* info)]
[varargs? (memq 'varargs (info-foreign-conv* info))] [varargs? (memq 'varargs (info-foreign-conv* info))]
[result-type (info-foreign-result-type info)] [result-type (info-foreign-result-type info)]
[synthesize-first? (indirect-result-that-fits-in-registers? result-type)]) [synthesize-first? (indirect-result-that-fits-in-registers? result-type)])
(let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first? varargs?)]) (let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first? varargs?)])
(let ([saved-reg-bytes (fx* isaved 4)] (let ([saved-reg-bytes (fx+ (fx* isaved 4) (fx* fpsaved 8))]
[pre-pad-bytes (if (fxeven? isaved) 0 4)] [pre-pad-bytes (if (fxeven? isaved) 0 4)]
[int-reg-bytes (fx* iint 4)] [int-reg-bytes (fx* iint 4)]
[post-pad-bytes (if (fxeven? iint) 0 4)] [post-pad-bytes (if (fxeven? iint) 0 4)]
@ -3331,6 +3340,7 @@
,(if (fx= pre-pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4)))) ,(if (fx= pre-pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4))))
; save the callee save registers & return address ; save the callee save registers & return address
(inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple) (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple)
(inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpush-multiple)
; set up tc for benefit of argument-conversion code, which might allocate ; set up tc for benefit of argument-conversion code, which might allocate
,(if-feature pthreads ,(if-feature pthreads
(%seq (%seq
@ -3346,6 +3356,7 @@
(in-context Tail (in-context Tail
(%seq (%seq
; restore the callee save registers ; restore the callee save registers
(inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpop-multiple)
(inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple) (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple)
; deallocate space for pad & arg reg values ; deallocate space for pad & arg reg values
(set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pre-pad-bytes int-reg-bytes post-pad-bytes float-reg-bytes)))) (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pre-pad-bytes int-reg-bytes post-pad-bytes float-reg-bytes))))

69
s/cpnanopass.ss
View File

@ -1029,11 +1029,6 @@
(sealed #t) (sealed #t)
(fields type swapped?)) (fields type swapped?))
(define-record-type info-loadfl (nongenerative)
(parent info)
(sealed #t)
(fields flreg))
(define-record-type info-condition-code (nongenerative) (define-record-type info-condition-code (nongenerative)
(parent info) (parent info)
(sealed #t) (sealed #t)
@ -3998,10 +3993,8 @@
[else [else
(bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
(%seq (%seq
(inline ,(make-info-loadfl %fptmp1) ,%load-double (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)
,base ,index (immediate ,offset)) (unboxed-fp ,(%mref ,base ,index ,offset fp)))
(inline ,(make-info-loadfl %fptmp1) ,%store-double
,t ,%zero ,(%constant flonum-data-disp))
,t))])))] ,t))])))]
[(single-float) [(single-float)
(if swapped? (if swapped?
@ -4011,18 +4004,22 @@
(set! ,(%mref ,t ,(constant flonum-data-disp)) (set! ,(%mref ,t ,(constant flonum-data-disp))
(inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index
(immediate ,offset))) (immediate ,offset)))
(inline ,(make-info-loadfl %fptmp1) ,%load-single->double (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)
,t ,%zero ,(%constant flonum-data-disp)) (unboxed-fp (inline ,(make-info-unboxed-args '(#t))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,%load-single->double
,t ,%zero ,(%constant flonum-data-disp)) ;; slight abuse to call this "unboxed", but `load-single->double`
;; wants an FP-flavored address
(unboxed-fp ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)))))
,t))) ,t)))
(bind #f (base index) (bind #f (base index)
(bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
(%seq (%seq
(inline ,(make-info-loadfl %fptmp1) ,%load-single->double (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)
,base ,index (immediate ,offset)) (unboxed-fp (inline ,(make-info-unboxed-args '(#t))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,%load-single->double
,t ,%zero ,(%constant flonum-data-disp)) ;; slight abuse to call this "unboxed", but `load-single->double`
;; wants an FP-flavored address
(unboxed-fp ,(%mref ,base ,index ,offset fp)))))
,t))))] ,t))))]
[(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64) [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64)
(build-int-load swapped? type base index offset (build-int-load swapped? type base index offset
@ -4101,21 +4098,14 @@
[(double-float) [(double-float)
(bind #f (base index) (bind #f (base index)
(bind #f fp (value) (bind #f fp (value)
`(set! ,(%mref ,base ,index ,offset fp) ,value))) `(set! ,(%mref ,base ,index ,offset fp) ,value)))]
#;
(bind #f (base index)
(%seq
(inline ,(make-info-loadfl %fptmp1) ,%load-double
,value ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %fptmp1) ,%store-double
,base ,index (immediate ,offset))))]
[(single-float) [(single-float)
(bind #f (base index) (bind #f (base index)
(%seq `(inline ,(make-info-unboxed-args '(#t #t)) ,%store-double->single
(inline ,(make-info-loadfl %fptmp1) ,%load-double->single ;; slight abuse to call this "unboxed", but `store-double->single`
,value ,%zero ,(%constant flonum-data-disp)) ;; wants an FP-flavored address
(inline ,(make-info-loadfl %fptmp1) ,%store-single (unboxed-fp ,(%mref ,base ,index ,offset fp))
,base ,index (immediate ,offset))))] (unboxed-fp ,(%mref ,value ,%zero ,(constant flonum-data-disp) fp))))]
; 40-bit+ only on 64-bit machines ; 40-bit+ only on 64-bit machines
[(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64
unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64)
@ -7536,19 +7526,14 @@
(lambda (e1 e2) (lambda (e1 e2)
(bind #f (e1 e2) (bind #f (e1 e2)
(bind #t ([t (%constant-alloc type-typed-object (constant size-inexactnum))]) (bind #t ([t (%constant-alloc type-typed-object (constant size-inexactnum))])
`(seq (%seq
(set! ,(%mref ,t ,(constant inexactnum-type-disp)) (set! ,(%mref ,t ,(constant inexactnum-type-disp))
,(%constant type-inexactnum)) ,(%constant type-inexactnum))
,(%seq (set! ,(%mref ,t ,%zero ,(constant inexactnum-real-disp) fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double (unboxed-fp ,(%mref ,e1 ,%zero ,(constant flonum-data-disp) fp)))
,e1 ,%zero ,(%constant flonum-data-disp)) (set! ,(%mref ,t ,%zero ,(constant inexactnum-imag-disp) fp)
(inline ,(make-info-loadfl %fptmp1) ,%store-double (unboxed-fp ,(%mref ,e2 ,%zero ,(constant flonum-data-disp) fp)))
,t ,%zero ,(%constant inexactnum-real-disp)) ,t)))))
(inline ,(make-info-loadfl %fptmp1) ,%load-double
,e2 ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %fptmp1) ,%store-double
,t ,%zero ,(%constant inexactnum-imag-disp))
,t))))))
(define-inline 3 fl-make-rectangular (define-inline 3 fl-make-rectangular
[(e1 e2) (build-fl-make-rectangular e1 e2)]) [(e1 e2) (build-fl-make-rectangular e1 e2)])
@ -7849,7 +7834,7 @@
(define-inline 3 flonum->fixnum (define-inline 3 flonum->fixnum
[(e-x) (bind #f (e-x) [(e-x) (bind #f (e-x)
(build-fix (build-fix
(%inline trunc ,e-x)))]) `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)))])
(let () (let ()
(define build-fixnum->flonum (define build-fixnum->flonum
; NB: x must already be bound in order to ensure it is done before the flonum is allocated ; NB: x must already be bound in order to ensure it is done before the flonum is allocated

17
s/np-languages.ss
View File

@ -542,10 +542,6 @@
(declare-primitive inc-profile-counter effect #f) (declare-primitive inc-profile-counter effect #f)
(declare-primitive invoke-prelude effect #f) (declare-primitive invoke-prelude effect #f)
(declare-primitive keep-live effect #f) (declare-primitive keep-live effect #f)
(declare-primitive load-double effect #f)
(declare-primitive load-double->single effect #f)
(declare-primitive load-single effect #f)
(declare-primitive load-single->double effect #f)
(declare-primitive locked-decr! effect #f) (declare-primitive locked-decr! effect #f)
(declare-primitive locked-incr! effect #f) (declare-primitive locked-incr! effect #f)
(declare-primitive pause effect #f) (declare-primitive pause effect #f)
@ -558,12 +554,12 @@
(declare-primitive save-flrv effect #f) (declare-primitive save-flrv effect #f)
(declare-primitive save-lr effect #f) ; ppc (declare-primitive save-lr effect #f) ; ppc
(declare-primitive store effect #f) (declare-primitive store effect #f)
(declare-primitive store-double effect #f) (declare-primitive store-single effect #f); not required by cpnanopass
(declare-primitive store-single effect #f) (declare-primitive store-double->single effect #f)
(declare-primitive store-single->double effect #f)
(declare-primitive store-with-update effect #f) ; ppc (declare-primitive store-with-update effect #f) ; ppc
(declare-primitive unactivate-thread effect #f) ; threaded version only (declare-primitive unactivate-thread effect #f) ; threaded version only
(declare-primitive vpush-multiple effect #f) ; arm (declare-primitive vpush-multiple effect #f) ; arm
(declare-primitive vpop-multiple effect #f) ; arm
(declare-primitive cas effect #f) (declare-primitive cas effect #f)
(declare-primitive < pred #t) (declare-primitive < pred #t)
@ -615,7 +611,6 @@
(declare-primitive sll value #t) (declare-primitive sll value #t)
(declare-primitive srl value #t) (declare-primitive srl value #t)
(declare-primitive sra value #t) (declare-primitive sra value #t)
(declare-primitive trunc value #t)
(declare-primitive zext8 value #t) (declare-primitive zext8 value #t)
(declare-primitive zext16 value #t) (declare-primitive zext16 value #t)
(declare-primitive zext32 value #t) ; 64-bit only (declare-primitive zext32 value #t) ; 64-bit only
@ -627,6 +622,12 @@
(declare-primitive fp/ value #t) (declare-primitive fp/ value #t)
(declare-primitive fpt value #t) (declare-primitive fpt value #t)
(declare-primitive fpsqrt value #t) ; not implemented for some ppc32 (so we don't use it) (declare-primitive fpsqrt value #t) ; not implemented for some ppc32 (so we don't use it)
(declare-primitive fptrunc value #t)
(declare-primitive double->single value #t) ; not required by cpnanopass
(declare-primitive single->double value #t) ; not required by cpnanopass
(declare-primitive load-single value #t) ; not required by cpnanopass
(declare-primitive load-single->double value #t)
(declare-primitive fpcastto value #t) ; 64-bit only (declare-primitive fpcastto value #t) ; 64-bit only
(declare-primitive fpcastto/hi value #t) ; 32-bit only (declare-primitive fpcastto/hi value #t) ; 32-bit only

83
s/x86.ss
View File

@ -810,17 +810,16 @@
(define-instruction effect (flds) (define-instruction effect (flds)
[(op (z mem)) `(asm ,info ,asm-flds ,z)]) [(op (z mem)) `(asm ,info ,asm-flds ,z)])
(define-instruction effect (load-single->double load-double->single) (define-instruction value (load-single->double)
[(op (x ur) (y ur) (z imm32))< [(op (x fpur) (y fpmem))
`(asm ,info ,(asm-fl-cvt op (info-loadfl-flreg info)) ,x ,y ,z)]) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,y))])
(define-instruction effect (store-single store-double) (define-instruction effect (store-double->single)
[(op (x ur) (y ur) (z imm32)) [(op (x fpmem) (y fpmem fpur))
`(asm ,info ,(asm-fl-store op (info-loadfl-flreg info)) ,x ,y ,z)]) (let ([u (make-tmp 'u 'fp)])
(seq
(define-instruction effect (load-double load-single) `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y))
[(op (x ur) (y ur) (z imm32)) `(asm ,info ,asm-store-single ,x ,u)))])
`(asm ,info ,(asm-fl-load op (info-loadfl-flreg info)) ,x ,y ,z)])
(define-instruction value (fpt) (define-instruction value (fpt)
[(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))]) [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))])
@ -854,8 +853,8 @@
(define-instruction effect inc-profile-counter (define-instruction effect inc-profile-counter
[(op (x ur mem) (y imm32 ur)) `(asm ,info ,asm-inc-profile-counter ,x ,y)]) [(op (x ur mem) (y imm32 ur)) `(asm ,info ,asm-inc-profile-counter ,x ,y)])
(define-instruction value (trunc) (define-instruction value (fptrunc)
[(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x))]) [(op (z ur) (x fpmem fpur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fptrunc ,x))])
;; no kills since we expect to be called when all necessary state has already been saved ;; no kills since we expect to be called when all necessary state has already been saved
(define-instruction value get-tc (define-instruction value get-tc
@ -1028,7 +1027,7 @@
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
asm-rp-header asm-rp-compact-header asm-rp-header asm-rp-compact-header
asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code
asm-fl-cvt asm-fl-store asm-fl-load asm-fpt asm-trunc asm-div asm-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-div
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
asm-fpop-2 asm-fpmove asm-fpmovefrom asm-fpcastfrom asm-fpcastto asm-fpsqrt asm-c-simple-call asm-fpop-2 asm-fpmove asm-fpmovefrom asm-fpcastfrom asm-fpcastto asm-fpsqrt asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
@ -1819,28 +1818,17 @@
(emit flds src code*)))) (emit flds src code*))))
(define asm-fl-cvt (define asm-fl-cvt
(lambda (op flreg) (lambda (op)
(lambda (code* base index offset) (lambda (code* dest-reg src)
(let ([src (build-mem-opnd base index offset)]) (Trivit (src)
(case op (case op
[(load-single->double) (emit sse.cvtss2sd src (cons 'reg flreg) code*)] [(single->double) (emit sse.cvtss2sd src (cons 'reg dest-reg) code*)]
[(load-double->single) (emit sse.cvtsd2ss src (cons 'reg flreg) code*)]))))) [(double->single) (emit sse.cvtsd2ss src (cons 'reg dest-reg) code*)])))))
(define asm-fl-store (define asm-store-single
(lambda (op flreg) (lambda (code* dest flreg)
(lambda (code* base index offset) (Trivit (dest)
(let ([dest (build-mem-opnd base index offset)]) (emit sse.movss (cons 'reg flreg) dest code*))))
(case op
[(store-single) (emit sse.movss (cons 'reg flreg) dest code*)]
[(store-double) (emit sse.movsd (cons 'reg flreg) dest code*)])))))
(define asm-fl-load
(lambda (op flreg)
(lambda (code* base index offset)
(let ([src (build-mem-opnd base index offset)])
(case op
[(load-single) (emit sse.movss src (cons 'reg flreg) code*)]
[(load-double) (emit sse.movsd src (cons 'reg flreg) code*)])))))
(define asm-fpt (define asm-fpt
(lambda (code* dest src) (lambda (code* dest src)
@ -1906,11 +1894,10 @@
(emit sse.psrlq (cons 'reg %fptmp1) shift (emit sse.psrlq (cons 'reg %fptmp1) shift
(emit sse.movd (cons 'reg %fptmp1) dest code*)))]))))) (emit sse.movd (cons 'reg %fptmp1) dest code*)))])))))
(define asm-trunc (define asm-fptrunc
(lambda (code* dest flonumreg) (lambda (code* dest src)
(Trivit (dest) (Trivit (dest src)
(let ([src `(disp ,(constant flonum-data-disp) ,flonumreg)]) (emit sse.cvttsd2si src dest code*))))
(emit sse.cvttsd2si src dest code*)))))
(define asm-load (define asm-load
(lambda (type) (lambda (type)
@ -2552,15 +2539,13 @@
(letrec ([load-double-stack (letrec ([load-double-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,%sp ,%zero ,offset fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)) ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))]
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
[load-single-stack [load-single-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)) ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))]
(inline ,(make-info-loadfl %fptmp1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
[load-stack [load-stack
(lambda (offset) (lambda (offset)
(lambda (rhs) ; requires rhs (lambda (rhs) ; requires rhs
@ -2852,15 +2837,13 @@
(define load-double-stack (define load-double-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,%sp ,%zero (immediate ,offset)) ,(%mref ,%sp ,%zero ,offset fp)))))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-single-stack (define load-single-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-single->double ,%sp ,%zero (immediate ,offset)) ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-stack (define load-stack
(lambda (type offset) (lambda (type offset)
(lambda (lvalue) ; requires lvalue (lambda (lvalue) ; requires lvalue

174
s/x86_64.ss
View File

@ -864,26 +864,32 @@
`(set! ,(make-live-info) ,u (asm ,null-info ,(asm-lea2 0) ,y ,z)) `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-lea2 0) ,y ,z))
`(asm ,info ,(asm-store (info-load-type info)) ,x ,u (immediate 0) ,w))))))]) `(asm ,info ,(asm-store (info-load-type info)) ,x ,u (immediate 0) ,w))))))])
(define-instruction effect (load-single->double load-double->single) (define-instruction value (load-single->double)
[(op (x ur) (y ur) (z imm32)) [(op (x fpur) (y fpmem))
`(asm ,info ,(asm-fl-cvt op (info-loadfl-flreg info)) ,x ,y ,z)]) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,y))])
(define-instruction effect (store-single->double) (define-instruction value (single->double double->single)
[(op (x ur) (y ur) (z imm32)) [(op (x fpur) (y fpmem fpur))
`(asm ,info ,(asm-store-single->double (info-loadfl-flreg info)) ,x ,y ,z)]) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt op) ,y))])
(define-instruction effect (store-single store-double) (define-instruction effect (store-double->single)
[(op (x ur) (y ur) (z imm32)) [(op (x fpmem) (y fpmem fpur))
`(asm ,info ,(asm-fl-store op (info-loadfl-flreg info)) ,x ,y ,z)]) (let ([u (make-tmp 'u 'fp)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y))
`(asm ,info ,asm-store-single ,x ,u)))])
(define-instruction effect (load-double load-single) (define-instruction effect (store-single)
[(op (x ur) (y ur) (z imm32)) [(op (x fpmem) (y fpur))
`(asm ,info ,(asm-fl-load op (info-loadfl-flreg info)) ,x ,y ,z)]) `(asm ,info ,asm-store-single ,x ,y)])
(define-instruction value (load-single)
[(op (x fpur) (y fpmem))
`(set! ,(make-live-info) ,x (asm ,info ,asm-load-single ,y))])
(define-instruction value (get-double) (define-instruction value (get-double)
[(op (z ur)) [(op (z ur) (y fpur))
`(set! ,(make-live-info) ,z `(set! ,(make-live-info) ,z (asm ,info ,asm-get-double ,y))])
(asm ,info ,(asm-get-double (info-loadfl-flreg info))))])
(define-instruction value (fpt) (define-instruction value (fpt)
[(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))]) [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))])
@ -915,8 +921,8 @@
(define-instruction effect inc-profile-counter (define-instruction effect inc-profile-counter
[(op (x ur mem) (y imm32 ur)) `(asm ,info ,asm-inc-profile-counter ,x ,y)]) [(op (x ur mem) (y imm32 ur)) `(asm ,info ,asm-inc-profile-counter ,x ,y)])
(define-instruction value (trunc) (define-instruction value (fptrunc)
[(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x))]) [(op (z ur) (x fpmem fpur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fptrunc ,x))])
(define-instruction value get-tc (define-instruction value get-tc
[(op (z ur)) [(op (z ur))
@ -1112,7 +1118,7 @@
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
asm-rp-header asm-rp-compact-header asm-rp-header asm-rp-compact-header
asm-lea1 asm-lea2 asm-indirect-call asm-condition-code asm-lea1 asm-lea2 asm-indirect-call asm-condition-code
asm-fl-cvt asm-fl-store asm-fl-load asm-fpt asm-trunc asm-div asm-popcount asm-fl-cvt asm-store-single asm-load-single asm-fpt asm-fptrunc asm-div asm-popcount
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
asm-fpsqrt asm-fpop-2 asm-fpmove asm-fpcast asm-fpsqrt asm-fpop-2 asm-fpmove asm-fpcast
asm-c-simple-call asm-c-simple-call
@ -2002,12 +2008,12 @@
[else (sorry! who "unexpected op ~s" op)]))))) [else (sorry! who "unexpected op ~s" op)])))))
(define asm-fl-cvt (define asm-fl-cvt
(lambda (op flreg) (lambda (op)
(lambda (code* base index offset) (lambda (code* dest-reg src)
(let ([src (build-mem-opnd base index offset)]) (Trivit (src)
(case op (case op
[(load-single->double) (emit sse.cvtss2sd src (cons 'reg flreg) code*)] [(single->double) (emit sse.cvtss2sd src (cons 'reg dest-reg) code*)]
[(load-double->single) (emit sse.cvtsd2ss src (cons 'reg flreg) code*)]))))) [(double->single) (emit sse.cvtsd2ss src (cons 'reg dest-reg) code*)])))))
(define asm-store-single->double (define asm-store-single->double
(lambda (flreg) (lambda (flreg)
@ -2016,26 +2022,19 @@
(emit sse.cvtss2sd flreg flreg (emit sse.cvtss2sd flreg flreg
(emit sse.movsd flreg dest code*)))))) (emit sse.movsd flreg dest code*))))))
(define asm-fl-store (define asm-store-single
(lambda (op flreg) (lambda (code* dest flreg)
(lambda (code* base index offset) (Trivit (dest)
(let ([dest (build-mem-opnd base index offset)]) (emit sse.movss (cons 'reg flreg) dest code*))))
(case op
[(store-single) (emit sse.movss (cons 'reg flreg) dest code*)]
[(store-double) (emit sse.movsd (cons 'reg flreg) dest code*)])))))
(define asm-fl-load (define asm-load-single
(lambda (op flreg) (lambda (code* flreg src)
(lambda (code* base index offset) (Trivit (src)
(let ([src (build-mem-opnd base index offset)]) (emit sse.movss src (cons 'reg flreg) code*))))
(case op
[(load-single) (emit sse.movss src (cons 'reg flreg) code*)]
[(load-double) (emit sse.movsd src (cons 'reg flreg) code*)])))))
(define asm-get-double (define asm-get-double
(lambda (flreg) (lambda (code* dst flreg)
(lambda (code* dst) (emit sse.movd (cons 'reg flreg) (cons 'reg dst) code*)))
(emit sse.movd (cons 'reg flreg) (cons 'reg dst) code*))))
(define asm-fpt (define asm-fpt
(lambda (code* dest src) (lambda (code* dest src)
@ -2080,11 +2079,10 @@
(Trivit (dest src) (Trivit (dest src)
(emit sse.movd src dest code*)))) (emit sse.movd src dest code*))))
(define asm-trunc (define asm-fptrunc
(lambda (code* dest flonumreg) (lambda (code* dest src)
(Trivit (dest) (Trivit (dest src)
(let ([src `(disp ,(constant flonum-data-disp) ,flonumreg)]) (emit sse.cvttsd2si src dest code*))))
(emit sse.cvttsd2si src dest code*)))))
(define asm-load (define asm-load
(lambda (type) (lambda (type)
@ -2817,17 +2815,15 @@
(module (push-registers pop-registers push-registers-size) (module (push-registers pop-registers push-registers-size)
(define (move-registers regs load?) (define (move-registers regs load?)
(define vfp (make-vfp)) (define (fp-reg? reg) (eq? (reg-type reg) 'fp))
(define (fp-reg? reg)
(let loop ([i (fx- (vector-length vfp) 1)])
(or (eq? reg (vector-ref vfp i))
(and (fx> i 0) (loop (fx- i 1))))))
(with-output-language (L13 Effect) (with-output-language (L13 Effect)
(let loop ([regs regs] [offset 0]) (let loop ([regs regs] [offset 0])
(let* ([reg (car regs)] (let* ([reg (car regs)]
[e (cond [e (cond
[(fp-reg? reg) [(fp-reg? reg)
`(inline ,(make-info-loadfl reg) ,(if load? %load-double %store-double) ,%sp ,%zero (immediate ,offset))] (if load?
`(set! ,reg ,(%mref ,%sp ,%zero ,offset fp))
`(set! ,(%mref ,%sp ,%zero ,offset fp) ,reg))]
[load? `(set! ,reg ,(%mref ,%sp ,offset))] [load? `(set! ,reg ,(%mref ,%sp ,offset))]
[else `(set! ,(%mref ,%sp ,offset) ,reg)])] [else `(set! ,(%mref ,%sp ,offset) ,reg)])]
[regs (cdr regs)]) [regs (cdr regs)])
@ -2861,15 +2857,13 @@
(letrec ([load-double-stack (letrec ([load-double-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,%sp ,%zero ,offset fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)) ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))]
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
[load-single-stack [load-single-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)) ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))]
(inline ,(make-info-loadfl %fptmp1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
[load-int-stack [load-int-stack
(lambda (offset) (lambda (offset)
(lambda (rhs) ; requires rhs (lambda (rhs) ; requires rhs
@ -2877,17 +2871,18 @@
[load-double-reg [load-double-reg
(lambda (fpreg) (lambda (fpreg)
(lambda (x) ; requires var (lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))))] `(set! ,fpreg ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))]
[load-double-reg2 [load-double-reg2
(lambda (fpreg ireg) (lambda (fpreg ireg)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq (%seq
(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)) (set! ,fpreg ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))
(set! ,ireg (inline ,(make-info-loadfl fpreg) ,%get-double)))))] ;; To support the varargs convention, copy the value into a GP register
(set! ,ireg ,(%inline get-double ,fpreg)))))]
[load-single-reg [load-single-reg
(lambda (fpreg) (lambda (fpreg)
(lambda (x) ; requires var (lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))))] `(set! ,fpreg ,(%inline double->single ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)))))]
[load-int-reg [load-int-reg
(lambda (type ireg) (lambda (type ireg)
(lambda (x) (lambda (x)
@ -2934,10 +2929,10 @@
(cond (cond
[(fx= size 4) [(fx= size 4)
;; Must be the last element ;; Must be the last element
`(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%load-single ,x ,%zero (immediate ,x-offset))] `(set! ,(vector-ref vfp ifp) ,(%inline load-single ,(%mref ,x ,%zero ,x-offset fp)))]
[else [else
`(seq `(seq
(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%load-double ,x ,%zero (immediate ,x-offset)) (set! ,(vector-ref vfp ifp) ,(%mref ,x ,%zero ,x-offset fp))
,(loop (fx- size 8) iint (fx+ ifp 1) (cdr classes) (fx+ x-offset 8)))])] ,(loop (fx- size 8) iint (fx+ ifp 1) (cdr classes) (fx+ x-offset 8)))])]
;; Remaining cases are integers: ;; Remaining cases are integers:
[(>= size 8) [(>= size 8)
@ -3138,8 +3133,8 @@
`(seq `(seq
,(loop (cdr classes) (fx+ offset 8) iregs (cdr fpregs) (fx- size 8)) ,(loop (cdr classes) (fx+ offset 8) iregs (cdr fpregs) (fx- size 8))
,(case size ,(case size
[(4) `(inline ,(make-info-loadfl (car fpregs)) ,%store-single ,%rcx ,%zero (immediate ,offset))] [(4) (%inline store-single ,(%mref ,%rcx ,%zero ,offset fp) ,(car fpregs))]
[else `(inline ,(make-info-loadfl (car fpregs)) ,%store-double ,%rcx ,%zero (immediate ,offset))]))] [else `(set! ,(%mref ,%rcx ,%zero ,offset fp) ,(car fpregs))]))]
[else [else
`(seq `(seq
,(loop (cdr classes) (fx+ offset 8) (cdr iregs) fpregs (fx- size 8)) ,(loop (cdr classes) (fx+ offset 8) (cdr iregs) fpregs (fx- size 8))
@ -3215,6 +3210,7 @@
[result-classes (classify-type result-type)] [result-classes (classify-type result-type)]
[result-size (classified-size result-type)] [result-size (classified-size result-type)]
[fill-result-here? (result-fits-in-registers? result-classes)] [fill-result-here? (result-fits-in-registers? result-classes)]
[result-reg* (get-result-regs fill-result-here? result-type result-classes)]
[adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]) [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp)) (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp))
(lambda (frame-size nfp locs live* fp-live*) (lambda (frame-size nfp locs live* fp-live*)
@ -3225,17 +3221,17 @@
(let* ([t (if adjust-active? %deact t0)] ; need a register if `adjust-active?` (let* ([t (if adjust-active? %deact t0)] ; need a register if `adjust-active?`
[c-call [c-call
(add-deactivate adjust-active? t0 (append fp-live* live*) (add-deactivate adjust-active? t0 (append fp-live* live*)
(get-result-regs fill-result-here? result-type result-classes) result-reg*
(if-feature windows (if-feature windows
(%seq (%seq
(set! ,%sp ,(%inline - ,%sp (immediate 32))) (set! ,%sp ,(%inline - ,%sp (immediate 32)))
(inline ,(make-info-kill*-live* (reg-list %rax %rdx) live*) ,%c-call ,t) (inline ,(make-info-kill*-live* result-reg* (append fp-live* live*)) ,%c-call ,t)
(set! ,%sp ,(%inline + ,%sp (immediate 32)))) (set! ,%sp ,(%inline + ,%sp (immediate 32))))
(%seq (%seq
;; System V ABI varargs functions require count of fp regs used in %al register. ;; System V ABI varargs functions require count of fp regs used in %al register.
;; since we don't know if the callee is a varargs function, we always set it. ;; since we don't know if the callee is a varargs function, we always set it.
(set! ,%rax (immediate ,nfp)) (set! ,%rax (immediate ,nfp))
(inline ,(make-info-kill*-live* (reg-list %rax %rdx) (cons %rax live*)) ,%c-call ,t))))]) (inline ,(make-info-kill*-live* result-reg* (cons %rax (append fp-live* live*))) ,%c-call ,t))))])
(cond (cond
[fill-result-here? [fill-result-here?
(add-fill-result c-call (fx- frame-size (constant ptr-bytes)) result-classes result-size)] (add-fill-result c-call (fx- frame-size (constant ptr-bytes)) result-classes result-size)]
@ -3243,12 +3239,10 @@
(nanopass-case (Ltype Type) result-type (nanopass-case (Ltype Type) result-type
[(fp-double-float) [(fp-double-float)
(lambda (lvalue) (lambda (lvalue)
`(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero `(set! ,(%mref ,lvalue ,%zero ,(constant flonum-data-disp) fp) ,%Cfpretval))]
,(%constant flonum-data-disp)))]
[(fp-single-float) [(fp-single-float)
(lambda (lvalue) (lambda (lvalue)
`(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero `(set! ,(%mref ,lvalue ,%zero ,(constant flonum-data-disp) fp) ,(%inline single->double ,%Cfpretval)))]
,(%constant flonum-data-disp)))]
[(fp-integer ,bits) [(fp-integer ,bits)
(case bits (case bits
[(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%rax)))] [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%rax)))]
@ -3322,15 +3316,13 @@
(define load-double-stack (define load-double-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,%sp ,%zero (immediate ,offset)) ,(%mref ,%sp ,%zero ,offset fp)))))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-single-stack (define load-single-stack
(lambda (offset) (lambda (offset)
(lambda (x) ; requires var (lambda (x) ; requires var
(%seq `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
(inline ,(make-info-loadfl %fptmp1) ,%load-single->double ,%sp ,%zero (immediate ,offset)) ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-int-stack (define load-int-stack
(lambda (type offset) (lambda (type offset)
(lambda (lvalue) (lambda (lvalue)
@ -3370,15 +3362,13 @@
[(fp-double-float) [(fp-double-float)
(if (< i 4) (if (< i 4)
(%seq (%seq
(inline ,(make-info-loadfl (vector-ref vfp i)) ,%store-double (set! ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp i))
,%sp ,%zero (immediate ,isp))
,(f (cdr types) (fx+ i 1) (fx+ isp 8))) ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))
(f (cdr types) i isp))] (f (cdr types) i isp))]
[(fp-single-float) [(fp-single-float)
(if (< i 4) (if (< i 4)
(%seq (%seq
(inline ,(make-info-loadfl (vector-ref vfp i)) ,%store-single ,(%inline store-single ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp i))
,%sp ,%zero (immediate ,isp))
,(f (cdr types) (fx+ i 1) (fx+ isp 8))) ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))
(f (cdr types) i isp))] (f (cdr types) i isp))]
[(fp-ftd& ,ftd) [(fp-ftd& ,ftd)
@ -3393,8 +3383,7 @@
(eq? 'float (caar ($ftd->members ftd)))) (eq? 'float (caar ($ftd->members ftd))))
;; float or double ;; float or double
`(seq `(seq
(inline ,(make-info-loadfl (vector-ref vfp i)) ,%store-double (set! ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp i))
,%sp ,%zero (immediate ,isp))
,(f (cdr types) (fx+ i 1) (fx+ isp 8)))] ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))]
[else [else
;; integer ;; integer
@ -3428,15 +3417,13 @@
[(fp-double-float) [(fp-double-float)
(if (< ifp 8) (if (< ifp 8)
(%seq (%seq
(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%store-double (set! ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp ifp))
,%sp ,%zero (immediate ,isp))
,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8))) ,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8)))
(f (cdr types) iint ifp isp))] (f (cdr types) iint ifp isp))]
[(fp-single-float) [(fp-single-float)
(if (< ifp 8) (if (< ifp 8)
(%seq (%seq
(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%store-single ,(%inline store-single ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp ifp))
,%sp ,%zero (immediate ,isp))
,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8))) ,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8)))
(f (cdr types) iint ifp isp))] (f (cdr types) iint ifp isp))]
[(fp-ftd& ,ftd) [(fp-ftd& ,ftd)
@ -3455,8 +3442,7 @@
(f (cdr types) iint ifp isp)] (f (cdr types) iint ifp isp)]
[(eq? (car classes) 'sse) [(eq? (car classes) 'sse)
`(seq `(seq
(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%store-double (set! ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp ifp))
,%sp ,%zero (immediate ,isp))
,(reg-loop (cdr classes) iint (fx+ ifp 1) (+ isp 8)))] ,(reg-loop (cdr classes) iint (fx+ ifp 1) (+ isp 8)))]
[else [else
`(seq `(seq
@ -3576,7 +3562,7 @@
(fx+ offset 8) (fx+ offset 8)
int* int*
(cdr fp*) (cdr fp*)
(cons `(inline ,(make-info-loadfl (car fp*)) ,%load-double ,%sp ,%zero (immediate ,offset)) (cons `(set! ,(car fp*) ,(%mref ,%sp ,%zero ,offset fp))
accum) accum)
live* live*
(cons (car fp*) fp-live*))]))] (cons (car fp*) fp-live*))]))]
@ -3589,13 +3575,13 @@
[(fp-double-float) [(fp-double-float)
(values (values
(lambda (x) (lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))) `(set! ,%Cfpretval ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)))
'() '()
(list %Cfpretval))] (list %Cfpretval))]
[(fp-single-float) [(fp-single-float)
(values (values
(lambda (x) (lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))) `(set! ,%Cfpretval ,(%inline double->single ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))
'() '()
(list %Cfpretval))] (list %Cfpretval))]
[(fp-void) [(fp-void)
@ -3710,5 +3696,5 @@
(set! ,%rbp ,(%inline pop)) (set! ,%rbp ,(%inline pop))
(set! ,%rbx ,(%inline pop)) (set! ,%rbx ,(%inline pop))
(set! ,%sp ,(%inline + ,%sp (immediate 136))))) (set! ,%sp ,(%inline + ,%sp (immediate 136)))))
(asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...)))))))))))))) (asm-c-return ,null-info ,callee-save-regs ... ,result-regs ... ,result-fp-regs ...))))))))))))))
) )