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

unbox local floating-point arithmetic

Browse Source 
Avoid allocating a flonum object for floating-opint calculations
that are consumed only by other floating-point caculations.

For this first cut, unboxing applies only to fl+, fl-, fl*, fl/,
flabs, fl<, fl<=, fl=, fl>, fl>=, bytevector-ieee-double-[native-]ref,
and bytevector-ieee-double-[native-]set!. Local variables can be
unboxed in the same way as implicit temporaries, and loop arguments
can be unboxed, but values in a closure and function-call arguments
are always boxed.

arm32 support is mostly in place, but not yet right. ppc32 support is
not yet implemented.

This commit includes a small change that is incompatible with previous
Chez Scheme versions: `(fl= +nan.0)` (and similar for other
comparisons) produces true instead of false.

original commit: 36459e43f10705aa3e383376ca7d54cf2998b7ee
This commit is contained in:
Matthew Flatt 2020-05-26 06:16:52 -06:00
parent 75f287befd
commit 7768b09118
47 changed files with 1850 additions and 809 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
makefiles/Mf-boot.in
View File

@ -20,7 +20,7 @@ doit: $(bootfiles)
%.boot:
( cd .. ; ./workarea $* xc-$* )
( cd ../xc-$*/s ; make -f Mf-cross base=../../$(workarea) --jobs=2 m=$(m) xm=$* )
for x in `echo scheme.boot petite.boot scheme.h equates.h` ; do\
for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc vfasl.inc` ; do\
if [ ! -h ../xc-$*/boot/$*/$$x ] ; then \
mv -f ../xc-$*/boot/$*/$$x ../boot/$*/$$x ;\
fi ;\

2
makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point #
###############################################################################
Version=csv9.5.3.28
Version=csv9.5.3.29
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

68
mats/fl.ms
View File

@ -1038,3 +1038,71 @@
'((3.0 . -2.0) (-2.0 . -2.0) (-3.0 . -2.0) (2.0 . -2.0)
(0.0 . 4.0) (0.0 . -4.0) (-0.0 . 4.0) (0.0 . -4.0)))
)
(mat fp-unboxing
(begin
(define-syntax check-loop-allocation
(syntax-rules ()
[(_ proc) ; proc should allocate only its result flonum
(or (eq? (current-eval) interpret)
(let ([before (+ (bytes-allocated) (bytes-deallocated))]
[N 100000])
(box?
(let loop ([i N] [bx (box 0.0)])
(if (zero? i)
bx
(loop (sub1 i) (let ([v (unbox bx)])
(box (proc v)))))))
(let ([allocated (- (+ (bytes-allocated) (bytes-deallocated)) before)]
[expected (* N (+ (compute-size 1.0)
(compute-size (box #f))))])
(printf "~s ~s\n" allocated expected)
(<= expected allocated (* 1.2 expected)))))]))
#t)
(check-loop-allocation (lambda (v) (fl+ v v)))
(check-loop-allocation (lambda (v) (fl* v v)))
(check-loop-allocation (lambda (v) (fl- v 1.0)))
(check-loop-allocation (lambda (v) (fl/ v 2.0)))
(check-loop-allocation (lambda (v) (fl+ v 2.0 v)))
(check-loop-allocation (lambda (v) (fl+ v (fl* 2.0 v))))
(check-loop-allocation (lambda (v) (fl+ v v v)))
(check-loop-allocation (lambda (v) (fl+ v (fl* v v) (fl/ v 2.0))))
(check-loop-allocation (lambda (v) (flabs v)))
(check-loop-allocation (lambda (v) (fl- v)))
(check-loop-allocation (lambda (v) (flabs (fl+ v v))))
(check-loop-allocation (lambda (v) (fl- (fl+ v v))))
(let ([i 0])
(check-loop-allocation (lambda (v) (begin
(set! i (add1 i))
(fl+ v (fixnum->flonum i))))))
(check-loop-allocation (lambda (v) (if (fl= (fl+ v (fl* 2.0 v)) 7.0)
(fl+ v 1.0)
(fl- v 1.0))))
(check-loop-allocation (lambda (v) (if (fl< (fl+ v v) v)
(fl+ v 1.0)
(fl- v 1.0))))
(check-loop-allocation (lambda (v) (if (fl> (fl+ v v) v)
(fl+ v 1.0)
(fl- v 1.0))))
(check-loop-allocation (lambda (v) (if (fl<= (fl+ v v) v)
(fl+ v 1.0)
(fl- v 1.0))))
(check-loop-allocation (lambda (v) (if (fl>= (fl+ v v) v)
(fl+ v 1.0)
(fl- v 1.0))))
(let ([bv (make-bytevector 8 0)])
(check-loop-allocation (lambda (v) (fl+ v (bytevector-ieee-double-native-ref bv 0)))))
(let ([bv (make-bytevector 8 0)])
(check-loop-allocation (lambda (v) (begin
(bytevector-ieee-double-native-set! bv 0 (fl+ v 0.1))
(fl* v 0.99)))))
)

10
mats/ieee.ms
View File

@ -159,7 +159,7 @@
(mat fl=
(let ((n (read (open-input-string "+nan.0"))))
(not (fl= n n)))
(not (fl= (nan)))
(fl= (nan))
(not (fl= (nan) +inf.0))
(not (fl= (nan) -inf.0))
(not (fl= (nan) (nan)))
@ -171,7 +171,7 @@
)
(mat fl<
(not (fl< (nan)))
(fl< (nan))
(not (fl< (nan) (nan)))
(not (fl< (nan) 0.0))
(not (fl< 0.0 (nan)))
@ -179,7 +179,7 @@
)
(mat fl>
(not (fl> (nan)))
(fl> (nan))
(not (fl> (nan) (nan)))
(not (fl> (nan) 0.0))
(not (fl> 0.0 (nan)))
@ -189,14 +189,14 @@
)
(mat fl<=
(not (fl<= (nan)))
(fl<= (nan))
(not (fl<= (nan) (nan)))
(not (fl<= (nan) 0.0))
(not (fl<= 0.0 (nan)))
)
(mat fl>=
(not (fl>= (nan)))
(fl>= (nan))
(not (fl>= (nan) (nan)))
(not (fl>= (nan) 0.0))
(not (fl>= 0.0 (nan)))

7
mats/misc.ms
View File

@ -5293,6 +5293,13 @@
(condition-wait c m)
(loop)))
(mutex-release m)
;; Wait for threads to exit
(let ()
(define $threads (foreign-procedure "(cs)threads" () scheme-object))
(let loop ()
(unless (= 1 (length ($threads)))
(sleep (make-time 'time-duration 10000 0))
(loop))))
#t))
)

1
s/a6fb.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/a6le.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/a6nb.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/a6nt.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long long int")
(define-constant typedef-uptr "unsigned long long int")

1
s/a6ob.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/a6osx.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/a6s2.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

436
s/arm32.ss
View File

@ -60,53 +60,52 @@
(define-registers
(reserved
[%tc %r9 #t 9]
[%sfp %r10 #t 10]
[%ap %r5 #t 5]
[%tc %r9 #t 9 uptr]
[%sfp %r10 #t 10 uptr]
[%ap %r5 #t 5 uptr]
#;[%esp]
#;[%eap]
[%trap %r8 #t 8])
[%trap %r8 #t 8 uptr])
(allocable
[%ac0 %r4 #t 4]
[%xp %r6 #t 6]
[%ts %ip #f 12]
[%td %r11 #t 11]
[%ac0 %r4 #t 4 uptr]
[%xp %r6 #t 6 uptr]
[%ts %ip #f 12 uptr]
[%td %r11 #t 11 uptr]
#;[%ret]
[%cp %r7 #t 7]
[%cp %r7 #t 7 uptr]
#;[%ac1]
#;[%yp]
[ %r0 %Carg1 %Cretval #f 0]
[ %r1 %Carg2 #f 1]
[ %r2 %Carg3 #f 2]
[ %r3 %Carg4 #f 3]
[ %lr #f 14] ; %lr is trashed by 'c' calls including calls to hand-coded routines like get-room
[ %r0 %Carg1 %Cretval #f 0 uptr]
[ %r1 %Carg2 #f 1 uptr]
[ %r2 %Carg3 #f 2 uptr]
[ %r3 %Carg4 #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]
)
(machine-dependent
[%sp #t 13]
[%pc #f 15]
[%Cfparg1 %Cfpretval %d0 %s0 #f 0] ; < 32: low bit goes in D, N, or M bit, high bits go in Vd, Vn, Vm
[%Cfparg1b %s1 #f 1]
[%Cfparg2 %d1 %s2 #f 2]
[%Cfparg2b %s3 #f 3]
[%Cfparg3 %d2 %s4 #f 4]
[%Cfparg3b %s5 #f 5]
[%Cfparg4 %d3 %s6 #f 6]
[%Cfparg4b %s7 #f 7]
[%Cfparg5 %d4 %s8 #f 8]
[%Cfparg5b %s9 #f 9]
[%Cfparg6 %d5 %s10 #f 10]
[%Cfparg6b %s11 #f 11]
[%Cfparg7 %d6 %s12 #f 12]
[%Cfparg7b %s13 #f 13]
[%Cfparg8 %d7 %s14 #f 14]
[%Cfparg8b %s15 #f 15]
[%flreg1 %d8 %s16 #f 16]
[%flreg2 %d9 %s18 #f 18]
[%sp #t 13 uptr]
[%pc #f 15 uptr]
[%Cfparg1 %Cfpretval %d0 %s0 #f 0 fp] ; < 32: low bit goes in D, N, or M bit, high bits go in Vd, Vn, Vm
[%Cfparg1b %s1 #f 1 fp]
[%Cfparg2 %d1 %s2 #f 2 fp]
[%Cfparg2b %s3 #f 3 fp]
[%Cfparg3 %d2 %s4 #f 4 fp]
[%Cfparg3b %s5 #f 5 fp]
[%Cfparg4 %d3 %s6 #f 6 fp]
[%Cfparg4b %s7 #f 7 fp]
[%Cfparg5b %s9 #f 9 fp]
[%Cfparg6b %s11 #f 11 fp]
[%Cfparg7 %fptmp1 %d6 %s12 #f 12 fp]
[%Cfparg7b %fptmp2 %s13 #f 13 fp]
[%Cfparg8 %d7 %s14 #f 14 fp]
[%Cfparg8b %s15 #f 15 fp]
;; etc., but other FP registers are preserved
#;[ %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.
#;[ %d16 #f 32] ; >= 32: high bit goes in D, N, or M bit, low bits go in Vd, Vn, Vm
#;[ %d17 #f 33]
; etc.
))
)
(reify-support %ts %lr %r3 %r2))
;;; SECTION 2: instructions
(module (md-handle-jump) ; also sets primitive handlers
@ -130,6 +129,18 @@
(lambda (x)
(or (lmem? x) (literal@? x))))
(define fpmem?
(lambda (x)
(nanopass-case (L15c Triv) x
[(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
[else #f])))
(define-syntax mem-of-type?
(lambda (stx)
(syntax-case stx (mem fpmem)
[(_ mem e) #'(lmem? e)]
[(_ fpmem e) #'(fpmem? e)])))
(define imm-funky12?
(lambda (x)
(nanopass-case (L15c Triv) x
@ -206,42 +217,42 @@
(define mref->mref
(lambda (a k)
(define return
(lambda (x0 x1 imm)
(lambda (x0 x1 imm type)
; arm load & store instructions support index or offset but not both
(safe-assert (or (eq? x1 %zero) (eqv? imm 0)))
(k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm)))))
(k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))
(nanopass-case (L15c Triv) a
[(mref ,lvalue0 ,lvalue1 ,imm)
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
(lvalue->ur lvalue0
(lambda (x0)
(lvalue->ur lvalue1
(lambda (x1)
(cond
[(and (eq? x1 %zero) (or (unsigned12? imm) (unsigned12? (- imm))))
(return x0 %zero imm)]
(return x0 %zero imm 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-add #f) ,x0 (immediate ,imm)))
(return u x1 0))))]
(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))))]
(return u x1 0 type))))]
[else
(let ([u (make-tmp 'u)])
(seq
(build-set! ,u (immediate ,imm))
(if (eq? x1 %zero)
(return x0 u 0)
(return x0 u 0 type)
(seq
(build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1))
(return x0 u 0)))))])))))])))
(return x0 u 0 type)))))])))))])))
(define mem->mem
(lambda (a k)
@ -250,14 +261,46 @@
(let ([u (make-tmp 'u)])
(seq
(build-set! ,u ,(literal@->literal a))
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0)))))]
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))]
[else (mref->mref a k)])))
(define fpmem->fpmem
(lambda (a k)
(define return
(lambda (x0 x1 imm)
(k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm fp)))))
(nanopass-case (L15c Triv) a
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
(lvalue->ur lvalue0
(lambda (x0)
(lvalue->ur lvalue1
(lambda (x1)
(cond
[(not (and (<= 0 imm #x3FF)
(fx= 0 (fxand imm #b11))))
;; offset not aligned or out of range
(let ([u (make-tmp 'umov)])
(seq
(build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 (immediate ,imm)))
(if (eq? x1 %zero)
(return u %zero 0)
(seq
(build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1))
(return u %zero 0)))))]
[(not (eq? x1 %zero))
(let ([u (make-tmp 'umov)])
(seq
(build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 ,x1))
(return u %zero imm)))]
[else
(return x0 %zero imm)])))))])))
(define-syntax coercible?
(syntax-rules ()
[(_ ?a ?aty*)
(let ([a ?a] [aty* ?aty*])
(or (memq 'ur aty*)
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
(and (memq 'funky12 aty*) (imm-funky12? a))
(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a))
(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a))
@ -298,6 +341,18 @@
(build-set! ,u ,a)
(k u)))))]
[else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
[(memq 'fpur aty*)
(cond
[(fpur? a) (k a)]
[(fpmem? a)
(fpmem->fpmem a
(lambda (a)
(let ([u (make-tmp 'u 'fp)])
(seq
(build-set! ,u ,a)
(k u)))))]
[else
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
(define set-ur=mref
@ -332,9 +387,15 @@
(define-syntax define-instruction
(lambda (x)
(define mem-type?
(lambda (t)
(syntax-case t (mem fpmem)
[mem #t]
[fpmem #t]
[else #f])))
(define make-value-clause
(lambda (fmt)
(syntax-case fmt (mem ur)
(syntax-case fmt (mem fpmem ur fpur)
[(op (c mem) (a ur))
#`(lambda (c a)
(if (lmem? c)
@ -344,6 +405,20 @@
(lambda (c)
(rhs c a)))))
(next c a)))]
[(op (c fpmem) (a aty ...) ...)
#`(lambda (c a ...)
(if (and (fpmem? c) (coercible? a '(aty ...)) ...)
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
(cond
[(null? a*)
#'(fpmem->fpmem c
(lambda (c)
(rhs c a ...)))]
[else
#`(coerce-opnd #,(car a*) '#,(car aty**)
(lambda (#,(car a*))
#,(f (cdr a*) (cdr aty**))))]))
(next c a ...)))]
[(op (c ur) (a aty ...) ...)
#`(lambda (c a ...)
(if (and (coercible? a '(aty ...)) ...)
@ -359,6 +434,22 @@
(build-set! ,c ,u))))))
#`(coerce-opnd #,(car a*) '#,(car aty**)
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
(next c a ...)))]
[(op (c fpur) (a aty ...) ...)
#`(lambda (c a ...)
(if (and (coercible? a '(aty ...)) ...)
#,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
(if (null? a*)
#'(if (fpur? c)
(rhs c a ...)
(let ([u (make-tmp 'u 'fp)])
(seq
(rhs u a ...)
(fpmem->fpmem c
(lambda (c)
(build-set! ,c ,u))))))
#`(coerce-opnd #,(car a*) '#,(car aty**)
(lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
(next c a ...)))])))
(define-who make-pred-clause
@ -679,31 +770,58 @@
(lambda (x1)
(with-flonum-data-pointers (x2 ...) e1 e2 ...)))])))
(define-instruction effect (flt)
[(op (x ur) (y ur))
(with-flonum-data-pointers (y)
`(asm ,info ,asm-flt ,x ,y))])
(define (fpmem->mem mem dir)
(with-output-language (L15d Triv)
(nanopass-case (L15d Triv) mem
[(mref ,x1 ,x2 ,imm ,type)
(safe-assert (eq? type 'fp))
(let ([delta (constant-case native-endianness
[(little) (if (eq? dir 'lo) 0 4)]
[(big) (if (eq? dir 'hi) 0 4)])])
`(mref ,x1 ,x2 ,(fx+ imm delta) uptr))]
[else (sorry! 'fpmem->mem "unexpected reference ~s" mem)])))
(define-instruction effect (fl+ fl- fl/ fl*)
[(op (x ur) (y ur) (z ur))
(with-flonum-data-pointers (x y z)
`(asm ,info ,(asm-flop-2 op) ,x ,y ,z))])
(define-instruction value (fpt)
[(op (x fpur) (y ur))
`(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))])
(define-instruction effect (flsqrt)
[(op (x ur) (y ur))
(with-flonum-data-pointers (x y)
`(asm ,info ,asm-flsqrt ,x ,y))])
(define-instruction value (fpmove)
[(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)]
[(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x ,y)])
(define-instruction value (fpcastto/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))])
(define-instruction value (fpcastto/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))])
(define-instruction value (fpcastfrom)
[(op (x fpmem) (hi ur) (lo ur)) (seq
`(set! ,(make-live-info) ,(fpmem->mem x 'lo) ,lo)
`(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))])
(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 (trunc)
[(op (z ur) (x ur))
(with-flonum-data-pointers (x)
`(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x)))])
(define-instruction pred (fl= fl< fl<=)
[(op (x ur) (y ur))
(with-flonum-data-pointers (x y)
(define-instruction pred (fp= fp< fp<=)
[(op (x fpur) (y fpur))
(let ([info (make-info-condition-code op #f #f)])
(values '() `(asm ,info ,(asm-fl-relop info) ,x ,y))))]))
(values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]))
(define-instruction effect (inc-cc-counter)
[(op (x ur) (w ur funky12) (z funky12 ur))
@ -891,15 +1009,15 @@
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-pop-multiple asm-shiftop asm-logand asm-lognot
asm-logtest asm-fl-relop asm-relop asm-push-multiple asm-vpush-multiple
asm-logtest asm-fp-relop asm-relop asm-push-multiple asm-vpush-multiple
asm-indirect-jump asm-literal-jump
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
asm-rp-header asm-rp-compact-header
asm-indirect-call asm-condition-code
asm-fl-load/store
asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc
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-flop-2 asm-flsqrt 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-enter asm-foreign-call asm-foreign-callable
asm-read-counter
@ -1079,8 +1197,10 @@
(define-op vstr.sgl vldr/vstr-op #b1010 #b00)
(define-op vstr.dbl vldr/vstr-op #b1011 #b00)
(define-op vmov.gpr->s32 vmov-op #b0)
(define-op vmov.s32->gpr vmov-op #b1)
(define-op vmov.gpr->s32 vmov.gpr-op #b0)
(define-op vmov.s32->gpr vmov.gpr-op #b1)
(define-op vmov.gprgpr->s64 vmov.gpr64-op #b0)
(define-op vmov.fpr vmov.fpr-op)
(define-op vcvt.sgl->dbl vcvt-op #b01 #b110111)
(define-op vcvt.dbl->sgl vcvt-op #b11 #b110111)
@ -1347,6 +1467,8 @@
(define vldr/vstr-op
(lambda (op opc1 opc2 flreg reg offset code*)
(safe-assert (and (<= 0 offset #x3FF)
(fx= 0 (fxand offset #b11))))
(let-values ([(d vd) (ax-flreg->bits flreg)])
(emit-code (op flreg reg offset code*)
[28 (ax-cond 'al)]
@ -1360,9 +1482,9 @@
[8 opc1]
[0 (fxsrl offset 2)]))))
(define vmov-op
(lambda (op dir flreg gpreg code*)
(let-values ([(n vn) (ax-flreg->bits flreg)])
(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*)
[28 (ax-cond 'al)]
[21 #b1110000]
@ -1373,6 +1495,44 @@
[7 n]
[0 #b0010000]))))
(define vmov.gpr64-op
(lambda (op dir flreg gpreglo gpreghi code*)
(let-values ([(n vn) (ax-flreg->bits flreg)])
(emit-code (op flreg gpreglo gpreghi code*)
[28 (ax-cond 'al)]
[23 #b11000]
[22 1]
[21 0]
[20 dir] ; 0 to fp, 1 from fp
[16 (ax-ea-reg-code gpreghi)]
[12 (ax-ea-reg-code gpreglo)]
[10 #b10]
[8 #b11]
[6 #b00]
[5 n]
[4 1]
[0 vn]))))
(define vmov.fpr-op
(lambda (op destreg srcreg code*)
(let-values ([(d vd) (ax-flreg->bits destreg)]
[(m vm) (ax-flreg->bits srcreg)])
(emit-code (op destreg srcreg code*)
[28 (ax-cond 'al)]
[23 #b11101]
[22 0] ; D
[20 #b11]
[19 d]
[16 #b000]
[12 vd]
[10 #b10]
[8 #b11]
[7 0]
[6 1]
[5 m]
[4 0]
[00 vm]))))
(define vcvt-op
(lambda (op szop opc2 dest src code*)
(let-values ([(d vd) (ax-flreg->bits dest)]
@ -1588,11 +1748,13 @@
[else ($oops who "unsupported op ~s" op)])))
(define ax-flreg->bits
(lambda (flreg)
(let ([n (reg-mdinfo flreg)])
(case-lambda
[(flreg) (ax-flreg->bits flreg 0)]
[(flreg flreg-delta)
(let ([n (fx+ (reg-mdinfo flreg) flreg-delta)])
(if (fx< n 32)
(values (fxlogand n 1) (fxsrl n 1))
(values (fxsrl n 4) (fxlogand n #b1111))))))
(values (fxsrl n 4) (fxlogand n #b1111))))]))
(define-syntax emit-code
(lambda (x)
@ -1803,11 +1965,11 @@
(Trivit (base offset)
(case op
[(load-single->double)
(emit vldr.sgl %flreg2 base (ax-imm-data offset)
(emit vcvt.sgl->dbl flreg %flreg2 code*))]
(emit vldr.sgl %fptmp2 base (ax-imm-data offset)
(emit vcvt.sgl->dbl flreg %fptmp2 code*))]
[(load-double->single)
(emit vldr.dbl %flreg2 base (ax-imm-data offset)
(emit vcvt.dbl->sgl flreg %flreg2 code*))]
(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
@ -1816,8 +1978,8 @@
(Trivit (base offset)
(case op
[(store-single->double)
(emit vcvt.sgl->dbl %flreg2 flreg
(emit vstr.dbl %flreg2 base (ax-imm-data offset) code*))]
(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
@ -1884,40 +2046,66 @@
[else (sorry! who "unexpected mref type ~s" type)]))]
[else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)])))))))
(define-who asm-flop-2
(define-who asm-fpop-2
(lambda (op)
(lambda (code* src1 src2 dest)
(Trivit (src1 src2 dest)
(emit vldr.dbl %flreg1 src1 0
(emit vldr.dbl %flreg2 src2 0
(let ([code* (emit vstr.dbl %flreg1 dest 0 code*)])
(lambda (code* dest src1 src2)
(case op
[(fl+) (emit vadd %flreg1 %flreg1 %flreg2 code*)]
[(fl-) (emit vsub %flreg1 %flreg1 %flreg2 code*)]
[(fl*) (emit vmul %flreg1 %flreg1 %flreg2 code*)]
[(fl/) (emit vdiv %flreg1 %flreg1 %flreg2 code*)]
[else (sorry! who "unrecognized op ~s" op)]))))))))
[(fp+) (emit vadd dest src1 src2 code*)]
[(fp-) (emit vsub dest src1 src2 code*)]
[(fp*) (emit vmul dest src1 src2 code*)]
[(fp/) (emit vdiv dest src1 src2 code*)]
[else (sorry! who "unrecognized op ~s" op)]))))
(define asm-flsqrt
(lambda (code* src dest)
(Trivit (src dest)
(emit vldr.dbl %flreg1 src 0
(emit vsqrt %flreg1 %flreg1
(emit vstr.dbl %flreg1 dest 0 code*))))))
(define asm-fpsqrt
(lambda (code* dest src)
(emit vsqrt dest src code*)))
(define asm-trunc
(lambda (code* dest flonumreg)
(Trivit (dest flonumreg)
(emit vldr.dbl %flreg1 flonumreg 0
(emit vcvt.dbl->s32 %flreg1 %flreg1
(emit vmov.s32->gpr %flreg1 dest code*))))))
(emit vldr.dbl %fptmp1 flonumreg 0
(emit vcvt.dbl->s32 %fptmp1 %fptmp1
(emit vmov.s32->gpr %fptmp1 0 dest code*))))))
(define asm-flt
(lambda (code* src flonumreg)
(Trivit (src flonumreg)
(emit vmov.gpr->s32 %flreg1 src
(emit vcvt.s32->dbl %flreg1 %flreg1
(emit vstr.dbl %flreg1 flonumreg 0 code*))))))
(define asm-fpt
(lambda (code* dest src)
(Trivit (src)
(emit vmov.gpr->s32 %fptmp1 0 src
(emit vcvt.s32->dbl %fptmp1 dest code*)))))
(define-who asm-fpmove
;; 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)
(let ([dest-it dest]
[src-it src])
(Trivit (dest-it src-it)
(record-case dest-it
[(disp) (imm reg)
(safe-assert (fx= 0 (fxand imm #b11)))
(emit vstr.dbl src (cons 'reg reg) imm code*)]
[(index) (n ireg breg) (sorry! who "cannot handle indexed fp dest ref")]
[else
(record-case src-it
[(disp) (imm reg)
(safe-assert (fx= 0 (fxand imm #b11)))
(emit vldr.dbl dest (cons 'reg reg) imm code*)]
[(index) (n ireg breg) (sorry! who "cannot handle indexed fp src ref")]
[else (emit vmov.fpr dest src code*)])])))))
(define asm-fpcastto
(lambda (part)
(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*))))))
(define asm-fpcastfrom
(lambda (code* dest lo-src hi-src)
(Trivit (lo-src hi-src)
(emit vmov.gprgpr->s64 dest lo-src hi-src code*))))
(define-who asm-swap
(lambda (type)
@ -1982,16 +2170,12 @@
(emit cmpi tmp2 0
code*))))))))
(define asm-fl-relop
(define asm-fp-relop
(lambda (info)
(lambda (l1 l2 offset x y)
(Trivit (x y)
(values
(emit vldr.dbl %flreg1 x 0
(emit vldr.dbl %flreg2 y 0
(emit vcmp %flreg1 %flreg2
(emit fpscr->apsr '()))))
(asm-conditional-jump info l1 l2 offset))))))
(emit vcmp x y (emit fpscr->apsr '()))
(asm-conditional-jump info l1 l2 offset)))))
(define-who asm-relop
(lambda (info)
@ -2231,9 +2415,9 @@
[(overflow) (i? bvc bvs)]
[(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if oveflow
[(carry) (i? bcc bcs)]
[(fl<) (i? (r? ble bcs) (r? bgt bcc))]
[(fl<=) (i? (r? blt bhi) (r? bge bls))]
[(fl=) (i? bne beq)]))))))
[(fp<) (i? (r? ble bcs) (r? bgt bcc))]
[(fp<=) (i? (r? blt bhi) (r? bge bls))]
[(fp=) (i? bne beq)]))))))
(define asm-data-label
(lambda (code* l offset func code-size)
@ -2387,14 +2571,14 @@
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
[load-single-stack
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
(inline ,(make-info-loadfl %fptmp1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %fptmp1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
[load-int-stack
(lambda (offset)
(lambda (rhs) ; requires rhs
@ -2737,14 +2921,14 @@
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-single-stack
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(inline ,(make-info-loadfl %fptmp1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-int-stack
(lambda (type offset)
(lambda (lvalue)

1
s/arm32le.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

14
s/bytevector.ss
View File

@ -732,16 +732,11 @@
(set-who! bytevector-ieee-double-native-ref
(lambda (v i)
(if ($bytevector-ref-check? 64 v i)
(#3%bytevector-ieee-double-native-ref v i)
(if (bytevector? v)
(invalid-index who v i)
(not-a-bytevector who v)))))
(#2%bytevector-ieee-double-native-ref v i)))
(set-who! bytevector-ieee-single-native-set!
(lambda (v i x)
(if ($bytevector-set!-check? 32 v i)
; inline routine checks to make sure x is a real number
(#3%bytevector-ieee-single-native-set! v i x)
(if (mutable-bytevector? v)
(invalid-index who v i)
@ -749,12 +744,7 @@
(set-who! bytevector-ieee-double-native-set!
(lambda (v i x)
(if ($bytevector-set!-check? 64 v i)
; inline routine checks to make sure x is a real number
(#3%bytevector-ieee-double-native-set! v i x)
(if (mutable-bytevector? v)
(invalid-index who v i)
(not-a-mutable-bytevector who v)))))
(#2%bytevector-ieee-double-native-set! v i x)))
(set-who! bytevector-copy
(lambda (v)

20
s/cmacros.ss
View File

@ -328,7 +328,7 @@
[(_ foo e1 e2) e1] ...
[(_ bar e1 e2) e2]))))])))
(define-constant scheme-version #x0905031C)
(define-constant scheme-version #x0905031D)
(define-syntax define-machine-types
(lambda (x)
@ -412,6 +412,11 @@
(define-constant ptr-alignment
(/ (constant byte-alignment) (constant ptr-bytes)))
;; Stack alignment may be needed for unboxed floating-point values:
(constant-case ptr-bits
[(32) (define-constant stack-word-alignment 2)]
[(64) (define-constant stack-word-alignment 1)])
;; seginfo offsets, must be consistent with `seginfo` in "types.h"
(define-constant seginfo-space-disp 0)
(define-constant seginfo-generation-disp 1)
@ -1448,7 +1453,8 @@
[void* lz4-out-buffer]
[U64 instr-counter]
[U64 alloc-counter]
[ptr parameters]))
[ptr parameters]
[double fpregs (constant asm-fpreg-max)]))
(define tc-field-list
(let f ([ls (oblist)] [params '()])
@ -1686,6 +1692,7 @@
(unsafe #b00001000000000000000000)
(unrestricted #b00010000000000000000000)
(safeongoodargs #b00100000000000000000000)
(unboxed-arguments #b10000000000000000000000) ; always accepts unboxed 'flonum arguments, up to inline-args-limit
(cptypes2 #b01000000000000000000000)
(cptypes3 cptypes2)
(cptypes2x cptypes2)
@ -1696,6 +1703,8 @@
(partial-folder (or cp02 cp03))
)
(define-constant inline-args-limit 10)
(define-flags cp0-info-mask
(pure-known #b0000000001)
(pure #b0000000010)
@ -1806,6 +1815,9 @@
(float-type-case
[(ieee) (fx= ($flonum-exponent x) #x7ff)]))))
;; #t => incompatibility with older Chez Scheme:
(define-constant nan-single-comparison-true? #t)
(define-syntax on-reset
(syntax-rules ()
((_ oops e1 e2 ...)
@ -2503,6 +2515,7 @@
(cfl/ #f 2 #f #t)
(negate #f 1 #f #t)
(flnegate #f 1 #t #t)
(flabs #f 1 #t #t)
(call-error #f 0 #f #f)
(unsafe-unread-char #f 2 #f #t)
(map-car #f 1 #f #t)
@ -2523,6 +2536,7 @@
(fxsll #f 2 #f #t)
(fxsrl #f 2 #t #t)
(fxsra #f 2 #t #t)
(fixnum->flonum #f 1 #t #t)
(append #f 2 #f #t)
(values-error #f 0 #f #f)
(dooverflow #f 0 #f #f)
@ -2640,6 +2654,8 @@
(bytevector-s8-set! #f 3 #f #t)
(bytevector-u8-set! #f 3 #f #t)
(bytevector=? #f 2 #f #f)
(bytevector-ieee-double-native-ref #f 2 #t #t)
(bytevector-ieee-double-native-set! #f 2 #t #t)
(real->flonum #f 2 #f #t)
(unsafe-port-eof? #f 1 #f #t)
(unsafe-lookahead-u8 #f 1 #f #t)

8
s/cp0.ss
View File

@ -550,7 +550,13 @@
; pure OR body to be pure, since we can't separate non-pure
; RHS and body expressions
[(letrec ([,x* ,e*] ...) ,body)
(guard (or (ivory? body) (andmap ivory1? e*)))
(guard (and (or (ivory? body) (andmap ivory1? e*))
;; don't break apart (potential) loops
(not (and (fx= (length x*) 1)
(nanopass-case (Lsrc Expr) body
[(call ,preinfo (ref ,maybe-src ,x) ,e* ...)
(eq? x (car x*))]
[else #f])))))
; assocate each lhs with cooked operand for corresponding rhs. see note above.
(for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
(values (make-lifted #f x* e*) body)]

1154
s/cpnanopass.ss
View File

File diff suppressed because it is too large Load Diff

1
s/i3fb.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/i3le.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/i3nb.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/i3nt.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/i3ob.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/i3osx.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/i3qnx.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/i3s2.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

15
s/inspect.ss
View File

@ -2281,8 +2281,12 @@
(values (make-vector count) count cp))
(let ([obj (vector-ref vals i)] [var* (vector-ref vars i)])
(cond
[(eq? obj cookie)
(unless (null? var*) ($oops who "expected value for ~s but it was not in lpm" (car var*)))
[(and (eq? obj cookie)
(or (null? var*)
;; unboxed variable?
(not (and (pair? var*) (box? (car var*)) (null? (cdr var*))))))
(unless (null? var*)
($oops who "expected value for ~s but it was not in lpm" (car var*)))
(f (fx1+ i) count cp cpvar*)]
[(null? var*)
(let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)])
@ -2310,7 +2314,12 @@
(vector->list var)))]
[else
(let-values ([(v frame-count cp) (g (cdr var*) (fx1+ count) cp cpvar*)])
(vector-set! v count (make-variable-object obj var))
(vector-set! v count (cond
[(box? var)
;; unboxed variable
(make-variable-object '<unboxed-flonum> (unbox var))]
[else
(make-variable-object obj var)]))
(values v frame-count cp))])))))]))))
(lambda (v frame-count cp)
(real-make-continuation-object x (rp-info-src rpi) (rp-info-sexpr rpi) cp v frame-count pos))))))]

17
s/library.ss
View File

@ -303,6 +303,11 @@
(define index-oops
(lambda (who x i)
($oops who "~s is not a valid index for ~s" i x)))
(define bytevector-index-oops
;; for consistency with error before library entry was introduced:
(lambda (who x i)
($oops who "invalid index ~s for bytevector ~s" i x)))
(define stencil-vector-oops
(lambda (who x)
($oops who "~s is not a vector" x)))
@ -400,6 +405,16 @@
(define-library-entry (stencil-vector-mask v)
(stencil-vector-oops 'stencil-vector-mask v))
(define-library-entry (bytevector-ieee-double-native-ref v i)
(if (bytevector? v)
(bytevector-index-oops 'bytevector-ieee-double-native-ref v i)
(bytevector-oops 'bytevector-ieee-double-native-ref v)))
(define-library-entry (bytevector-ieee-double-native-set! v i)
(if (mutable-bytevector? v)
(bytevector-index-oops 'bytevector-ieee-double-native-set! v i)
(mutable-bytevector-oops 'bytevector-ieee-double-native-set! v)))
(define-library-entry (char=? x y) (char-oops 'char=? (if (char? x) y x)))
(define-library-entry (char<? x y) (char-oops 'char<? (if (char? x) y x)))
(define-library-entry (char>? x y) (char-oops 'char>? (if (char? x) y x)))
@ -523,6 +538,7 @@
(define-library-entry (fxxor x y) (fxnonfixnum2 'fxxor x y))
(define-library-entry (fxand x y) (fxnonfixnum2 'fxand x y))
(define-library-entry (fxnot x) (fxnonfixnum1 'fxnot x))
(define-library-entry (fixnum->flonum x) (fxnonfixnum1 'fixnum->flonum x))
(define-library-entry (fxpopcount x) ($oops 'fxpopcount32 "~s is not a non-negative fixnum" x))
(define-library-entry (fxpopcount32 x) ($oops 'fxpopcount32 "~s is not a 32-bit fixnum" x))
(define-library-entry (fxpopcount16 x) ($oops 'fxpopcount16 "~s is not a 16-bit fixnum" x))
@ -658,6 +674,7 @@
(define-library-entry (fl* x y) (flonum-oops 'fl* (if (flonum? x) y x)))
(define-library-entry (fl/ x y) (flonum-oops 'fl/ (if (flonum? x) y x)))
(define-library-entry (flnegate x) (flonum-oops 'fl- x))
(define-library-entry (flabs x) (flonum-oops 'flabs x))
)
(define-library-entry (flround x)

6
s/mathprims.ss
View File

@ -272,8 +272,7 @@
(set! flabs
(lambda (x)
(unless (flonum? x) (flargerr 'flabs x))
(#3%flabs x)))
(#2%flabs x)))
(set! flround
(lambda (x)
@ -682,8 +681,7 @@
(set! fixnum->flonum
(lambda (x)
(unless (fixnum? x) (fxargerr 'fixnum->flonum x))
(#3%fixnum->flonum x)))
(#2%fixnum->flonum x)))
(set-who! fxlength
(lambda (x)

102
s/np-languages.ss
View File

@ -17,7 +17,7 @@
(module np-languages ()
(export sorry! var? var-index var-index-set! prelex->uvar make-tmp make-assigned-tmp
make-unspillable make-cpvar make-restricted-unspillable
uvar? uvar-name uvar-type uvar-source
uvar? uvar-name uvar-type uvar-type-set! uvar-source
uvar-referenced? uvar-referenced! uvar-assigned? uvar-assigned!
uvar-was-closure-ref? uvar-was-closure-ref!
uvar-unspillable? uvar-spilled? uvar-spilled! uvar-local-save? uvar-local-save!
@ -29,13 +29,13 @@
uvar-ref-weight uvar-ref-weight-set! uvar-save-weight uvar-save-weight-set!
uvar-live-count uvar-live-count-set!
uvar
fv-offset
fv-offset fv-type
var-spillable-conflict* var-spillable-conflict*-set!
var-unspillable-conflict* var-unspillable-conflict*-set!
uvar-degree uvar-degree-set!
uvar-info-lambda uvar-info-lambda-set!
uvar-iii uvar-iii-set!
ur?
ur? fpur?
block make-block block? block-label block-effect* block-src* block-pseudo-src block-in-link* block-flags
block-label-set! block-effect*-set! block-src*-set! block-pseudo-src-set! block-in-link*-set! block-flags-set!
block-live-in block-live-in-set! block-fp-offset block-fp-offset-set!
@ -57,7 +57,7 @@
live-info make-live-info live-info-live live-info-live-set! live-info-useless live-info-useless-set!
primitive-pure? primitive-type primitive-handler primitive-handler-set!
%primitive value-primitive? pred-primitive? effect-primitive?
fv? $make-fv make-reg reg? reg-name reg-tc-disp reg-callee-save? reg-mdinfo
fv? $make-fv make-reg reg? reg-name reg-tc-disp reg-callee-save? reg-mdinfo reg-type
reg-precolored reg-precolored-set!
label? label-name
libspec-label? make-libspec-label libspec-label-libspec libspec-label-live-reg*
@ -92,13 +92,13 @@
(define-record-type (fv $make-fv fv?)
(parent var)
(fields offset)
(fields offset type)
(nongenerative)
(sealed #t)
(protocol
(lambda (pargs->new)
(lambda (offset)
((pargs->new) offset)))))
(lambda (offset type)
((pargs->new) offset type)))))
(module ()
(record-writer (record-type-descriptor fv)
@ -107,13 +107,13 @@
(define-record-type reg
(parent var)
(fields name mdinfo tc-disp callee-save? (mutable precolored))
(fields name mdinfo tc-disp callee-save? type (mutable precolored))
(nongenerative)
(sealed #t)
(protocol
(lambda (pargs->new)
(lambda (name mdinfo tc-disp callee-save?)
((pargs->new) name mdinfo tc-disp callee-save? #f)))))
(lambda (name mdinfo tc-disp callee-save? type)
((pargs->new) name mdinfo tc-disp callee-save? type #f)))))
(module ()
(record-writer (record-type-descriptor reg)
@ -169,7 +169,7 @@
(fields
name
source
type
(mutable type)
conflict*
(mutable flags)
(mutable info-lambda)
@ -206,8 +206,8 @@
[(name) (make-assigned-tmp name 'ptr)]
[(name type) ($make-uvar name #f type '() (uvar-flags-mask referenced assigned))]))
(define make-unspillable
(lambda (name)
($make-uvar name #f 'ptr '() (uvar-flags-mask referenced unspillable))))
(lambda (name type)
($make-uvar name #f type '() (uvar-flags-mask referenced unspillable))))
(define make-cpvar
(lambda ()
(include "types.ss")
@ -220,7 +220,9 @@
(module ()
(record-writer (record-type-descriptor uvar)
(lambda (x p wr)
(write (lookup-unique-uvar x) p))))
(write (lookup-unique-uvar x) p)
(when (eq? (uvar-type x) 'fp)
(write 'fp p)))))
(define lookup-unique-uvar
(let ([ht (make-eq-hashtable)])
@ -439,6 +441,12 @@
(- (clause (x* ...) interface body))
(+ (clause (x* ...) mcp interface body))))
(define (mref-type? t)
;; Currently, only 'fp vesus non-'fp matters
(or (eq? t 'ptr)
(eq? t 'uptr)
(eq? t 'fp)))
; move labels to top level and expands closures forms to more primitive operations
(define-language L7 (extends L6)
(terminals
@ -446,7 +454,8 @@
(fixnum (interface)))
(+ (var (x))
(primitive (prim)) ; moved up one language to support closure instrumentation
(fixnum (interface offset))))
(fixnum (interface offset))
(mref-type (type))))
(entry Program)
(Program (prog)
(+ (labels ([l* le*] ...) l) => (labels ([l* le*] ...) (l))))
@ -454,7 +463,7 @@
(+ (fcallable info l) => (fcallable info l)))
(Lvalue (lvalue)
(+ x
(mref e1 e2 imm)))
(mref e1 e2 imm type)))
(Expr (e body)
(- x
(fcallable info)
@ -471,7 +480,9 @@
(set! lvalue e)
; these two forms are added here so expand-inline handlers can expand into them
(values info e* ...)
(goto l))))
(goto l)
; for floating-point unboxing during expand-line:
(unboxed-fp e))))
(define-record-type primitive
(fields name type pure? (mutable handler))
@ -525,14 +536,8 @@
(declare-primitive c-simple-call effect #f)
(declare-primitive c-simple-return effect #f)
(declare-primitive deactivate-thread effect #f) ; threaded version only
(declare-primitive fl* effect #f)
(declare-primitive fl+ effect #f)
(declare-primitive fl- effect #f)
(declare-primitive fl/ effect #f)
(declare-primitive fldl effect #f) ; x86
(declare-primitive flds effect #f) ; x86
(declare-primitive flsqrt effect #f) ; not implemented for some ppc32 (so we don't use it)
(declare-primitive flt effect #f)
(declare-primitive inc-cc-counter effect #f)
(declare-primitive inc-profile-counter effect #f)
(declare-primitive invoke-prelude effect #f)
@ -567,9 +572,9 @@
(declare-primitive >= pred #t)
(declare-primitive condition-code pred #t)
(declare-primitive eq? pred #t)
(declare-primitive fl< pred #t)
(declare-primitive fl<= pred #t)
(declare-primitive fl= pred #t)
(declare-primitive fp< pred #t)
(declare-primitive fp<= pred #t)
(declare-primitive fp= pred #t)
(declare-primitive lock! pred #f)
(declare-primitive logtest pred #t)
(declare-primitive log!test pred #t)
@ -615,6 +620,19 @@
(declare-primitive zext16 value #t)
(declare-primitive zext32 value #t) ; 64-bit only
(declare-primitive fpmove value #t)
(declare-primitive fp+ value #t)
(declare-primitive fp- value #t)
(declare-primitive fp* value #t)
(declare-primitive fp/ 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 fpcastto value #t) ; 64-bit only
(declare-primitive fpcastto/hi value #t) ; 32-bit only
(declare-primitive fpcastto/lo value #t) ; 32-bit only
(declare-primitive fpcastfrom value #t) ; 64-bit: 1 argument; 32-bit: 2 arguments
(define immediate?
(let ([low (- (bitwise-arithmetic-shift-left 1 (fx- (constant ptr-bits) 1)))]
[high (- (bitwise-arithmetic-shift-left 1 (constant ptr-bits)) 1)])
@ -652,7 +670,8 @@
(+ (hand-coded sym)))
(Expr (e body)
(- (quote d)
pr)))
pr
(unboxed-fp e))))
; determine where we should be placing interrupt and overflow
(define-language L9.5 (extends L9)
@ -683,8 +702,8 @@
(- (clause (x* ...) mcp interface body))
(+ (clause (x* ...) (local* ...) mcp interface body)))
(Lvalue (lvalue)
(- (mref e1 e2 imm))
(+ (mref x1 x2 imm)))
(- (mref e1 e2 imm type))
(+ (mref x1 x2 imm type)))
(Triv (t)
(+ lvalue
(literal info) => info
@ -854,7 +873,8 @@
(label (l rpl))
(source-object (src))
(symbol (sym))
(boolean (as-fallthrough)))
(boolean (as-fallthrough))
(mref-type (type)))
(Program (prog)
(labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l)))
(CaseLambdaExpr (le)
@ -862,7 +882,7 @@
(hand-coded sym))
(Lvalue (lvalue)
x
(mref x1 x2 imm))
(mref x1 x2 imm type))
(Triv (t)
lvalue
(literal info) => info
@ -985,7 +1005,8 @@
(return-label (mrvl))
(boolean (error-on-values as-fallthrough))
(fixnum (max-fv offset))
(block (block entry-block)))
(block (block entry-block))
(mref-type (type)))
(Program (pgm)
(labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l)))
(CaseLambdaExpr (le)
@ -993,7 +1014,7 @@
(Dummy (dumdum) (dummy))
(Lvalue (lvalue)
x
(mref x1 x2 imm))
(mref x1 x2 imm type))
(Triv (t)
lvalue
(literal info) => info
@ -1049,14 +1070,21 @@
(lambda (x)
(or (reg? x) (uvar? x))))
(define fpur?
(lambda (x)
(or (and (reg? x)
(eq? (reg-type x) 'fp))
(and (uvar? x)
(eq? (uvar-type x) 'fp)))))
(define-language L15c (extends L15b)
(terminals
(- (var (x var)))
(+ (ur (x))))
; NB: base and index are really either regs or (mref %sfp %zero imm)
(Lvalue (lvalue)
(- (mref x1 x2 imm))
(+ (mref lvalue1 lvalue2 imm)))
(- (mref x1 x2 imm type))
(+ (mref lvalue1 lvalue2 imm type)))
(Effect (e)
(- (fp-offset live-info imm))))
@ -1068,8 +1096,8 @@
(+ (procedure (proc)) => $procedure-name))
(entry Program)
(Lvalue (lvalue)
(- (mref lvalue1 lvalue2 imm))
(+ (mref x1 x2 imm)))
(- (mref lvalue1 lvalue2 imm type))
(+ (mref x1 x2 imm type)))
(Rhs (rhs)
(- (inline info value-prim t* ...))
(+ (asm info proc t* ...) => (asm proc t* ...)))

28
s/primdata.ss
View File

@ -91,11 +91,11 @@
(define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc])
(flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl<? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; restricted to 2+ arguments
(fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments
(fl<? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments
(fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments
(fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments
(fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments
(flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
@ -107,11 +107,11 @@
(flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
(fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
(fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
(fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
(flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
(fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
(fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
(fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
(fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
(flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
(fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard])
(fldiv [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
(flmod [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
@ -1327,10 +1327,10 @@
(flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02])
(flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments
(fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments
(fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments
(fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments
(fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(flush-output-port [sig [() (output-port) -> (void)]] [flags true]) ; not restricted to 1 argument
(foreign-entry? [sig [(string) -> (boolean)]] [flags discard])

1
s/ta6fb.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/ta6le.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/ta6nb.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/ta6nt.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long long int")
(define-constant typedef-uptr "unsigned long long int")

1
s/ta6ob.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/ta6osx.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/ta6s2.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned long int")

1
s/ti3fb.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/ti3le.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/ti3nb.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/ti3nt.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 8)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/ti3ob.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/ti3osx.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

1
s/ti3s2.def
View File

@ -29,6 +29,7 @@
(define-constant max-integer-alignment 4)
(define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int")

314
s/x86.ss
View File

@ -16,27 +16,30 @@
;;; SECTION 1: registers
(define-registers
(reserved
[%tc %edi #t 7]
[%sfp %ebp #t 5]
[%tc %edi #t 7 uptr]
[%sfp %ebp #t 5 uptr]
#;[%ap]
#;[%esp]
#;[%eap]
#;[%trap])
(allocable ; keep in sync with all-but-byte-registers below
[%ac0 %edx #f 2]
[%xp %ecx #f 1]
[%ts %eax #f 0]
[%td %ebx #t 3]
[%ac0 %edx #f 2 uptr]
[%xp %ecx #f 1 uptr]
[%ts %eax #f 0 uptr]
[%td %ebx #t 3 uptr]
#;[%ret]
#;[%cp]
#;[%ac1]
#;[%yp]
[%esi #t 6])
[%esi #t 6 uptr]
[%fp1 %Cfparg3 #f 2 fp]
[%fp2 %Cfparg4 #f 3 fp])
(machine-dependent
[%flreg1 #f 0]
[%flreg2 #f 1]
[%sp #t 4]
#;[%esi #f 6]))
[%fptmp1 #f 0 fp]
[%fptmp2 #f 1 fp]
[%sp #t 4 uptr]
#;[%esi #f 6])
(reify-support %ts))
;;; SECTION 2: instructions
(module (md-handle-jump) ; also sets primitive handlers
@ -66,6 +69,18 @@
(lambda (x)
(or (lmem? x) (literal@? x))))
(define fpmem?
(lambda (x)
(nanopass-case (L15c Triv) x
[(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
[else #f])))
(define-syntax mem-of-type?
(lambda (stx)
(syntax-case stx (mem fpmem)
[(_ mem e) #'(lmem? e)]
[(_ fpmem e) #'(fpmem? e)])))
(define real-imm32?
(lambda (x)
(nanopass-case (L15c Triv) x
@ -100,12 +115,12 @@
(lambda (a k)
(nanopass-case (L15c Triv) a
; NOTE: x86_64 and risc arch's will need to deal with limitations on the offset
[(mref ,lvalue0 ,lvalue1 ,imm)
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
(lvalue->ur lvalue0
(lambda (x0)
(lvalue->ur lvalue1
(lambda (x1)
(k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm)))))))])))
(k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))))])))
(define mem->mem
(lambda (a k)
@ -117,13 +132,15 @@
(syntax-rules ()
[(_ ?a ?aty*)
(let ([a ?a] [aty* ?aty*])
(or (memq 'ur aty*)
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
(or (and (memq 'imm32 aty*) (imm32? a))
(and (memq 'imm aty*) (imm? a))
(and (memq 'zero aty*) (imm0? a))
(and (memq 'real-imm32 aty*) (real-imm32? a))
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? 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*
(syntax-rules ()
@ -131,6 +148,7 @@
(let ([a ?a] [aty* ?aty*] [k ?k])
(cond
[(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
[(and (memq 'fpmem aty*) (fpmem? a)) (mem->mem a k)]
[(and (memq 'imm32 aty*) (imm32? a)) (k (imm->imm a))]
[(and (memq 'imm aty*) (imm? a)) (k (imm->imm a))]
[(and (memq 'zero aty*) (imm0? a)) (k (imm->imm a))]
@ -152,6 +170,18 @@
(build-set! ,u ,a)
(k u)))))]
[else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
[(memq 'fpur aty*)
(cond
[(fpur? a) (k a)]
[(fpmem? a)
(mem->mem a
(lambda (a)
(let ([u (make-tmp 'u 'fp)])
(seq
(build-set! ,u ,a)
(k u)))))]
[else
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
(define set-ur=mref
@ -212,22 +242,29 @@
[(mref? c)
(nanopass-case (L15c Triv) c
; NOTE: x86_64 and risc arch's will need to deal with limitations on the offset
[(mref ,lvalue0 ,lvalue1 ,imm)
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
(lvalue->ur lvalue0
(lambda (x0)
(lvalue->ur lvalue1
(lambda (x1)
(let ([u (make-tmp 'u)])
(seq
(build-set! ,u (mref ,x0 ,x1 ,imm))
(build-set! ,u (mref ,x0 ,x1 ,imm ,type))
(#,k u b)
(build-set! (mref ,x0 ,x1 ,imm) ,u)))))))])]
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u)))))))])]
[else (sorry! '#,(datum->syntax #'* who) "unexpected operand ~s" c)])))
(next c a b)))))
(define mem-type?
(lambda (t)
(syntax-case t (mem fpmem)
[mem #t]
[fpmem #t]
[else #f])))
(define make-value-clause
(lambda (fmt)
(syntax-case fmt (mem ur xp)
(syntax-case fmt (mem ur fpur xp)
[(op (c mem) (a ?c) (b bty* ...))
(bound-identifier=? #'?c #'c)
(acsame-mem #'c #'a #'b #'(bty* ...) #'(lambda (c b) (rhs c c b)))]
@ -240,9 +277,10 @@
[(op (c ur) (a aty* ...) (b ?c))
(bound-identifier=? #'?c #'c)
(acsame-ur #'c #'b #'a #'(aty* ...) #'(lambda (c a) (rhs c a c)))]
[(op (c mem) (a aty ...) (b bty ...))
[(op (c xmem) (a aty ...) (b bty ...))
(mem-type? #'xmem)
#`(lambda (c a b)
(if (and (lmem? c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
(coerce-opnd b '(bty ...)
(lambda (b)
(coerce-opnd a '(aty ...)
@ -265,6 +303,22 @@
(lambda (c)
(build-set! ,c ,u))))))))))
(next c a b)))]
[(op (c fpur) (a aty ...) (b bty ...))
#`(lambda (c a b)
(if (and (coercible? a '(aty ...)) (coercible? b '(bty ...)))
(coerce-opnd b '(bty ...)
(lambda (b)
(coerce-opnd a '(aty ...)
(lambda (a)
(if (fpur? c)
(rhs c a b)
(let ([u (make-tmp 'u 'fp)])
(seq
(rhs u a b)
(mref->mref c
(lambda (c)
(build-set! ,c ,u))))))))))
(next c a b)))]
; four-operand case below can require four unspillables
[(op (c ur) (a ur) (b ur) (d dty ...))
(not (memq 'mem (datum (dty ...))))
@ -307,9 +361,10 @@
(rhs u u)
(build-set! ,c ,u))))))
(next c a)))]
[(op (c mem) (a aty ...))
[(op (c xmem) (a aty ...))
(mem-type? #'xmem)
#`(lambda (c a)
(if (and (lmem? c) (coercible? a '(aty ...)))
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)))
(coerce-opnd a '(aty ...)
(lambda (a)
(mem->mem c
@ -330,6 +385,20 @@
(rhs u a)
(build-set! ,c ,u))))))))
(next c a)))]
[(op (c fpur) (a aty ...))
#`(lambda (c a)
(if (coercible? a '(aty ...))
(coerce-opnd a '(aty ...)
(lambda (a)
(if (fpur? c)
(rhs c a)
(mem->mem c
(lambda (c)
(let ([u (make-tmp 'u 'fp)])
(seq
(rhs u a)
(build-set! ,c ,u))))))))
(next c a)))]
[(op (c ur))
#`(lambda (c)
(if (ur? c)
@ -754,14 +823,31 @@
[(op (x ur) (y ur) (z imm32))
`(asm ,info ,(asm-fl-load op (info-loadfl-flreg info)) ,x ,y ,z)])
(define-instruction effect (flt)
[(op (x mem ur) (y ur)) `(asm ,info ,asm-flt ,x ,y)])
(define-instruction value (fpt)
[(op (x fpur) (y ur)) `(asm ,info ,asm-fpt ,x ,y)])
(define-instruction effect (fl+ fl- fl/ fl*)
[(op (x ur) (y ur) (z ur)) `(asm ,info ,(asm-flop-2 op) ,x ,y ,z)])
(define-instruction value (fpmove)
[(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))])
(define-instruction effect (flsqrt)
[(op (x ur) (y ur)) `(asm ,info ,asm-flsqrt ,x ,y)])
(define-instruction value (fpcastto/hi) ; little endian: high bytes are at +4
[(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-movefrom 4) ,y))]
[(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 32) ,y))])
(define-instruction value (fpcastto/lo) ; little endian: low byte are immediate bytes
[(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,asm-move ,y))]
[(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 0) ,y))])
(define-instruction value (fpcastfrom)
[(op (x fpmem) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmovefrom ,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 fpmem fpur) (z fpmem fpur))
`(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
(define-instruction value (fpsqrt)
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
(define-instruction effect inc-cc-counter
[(op (x ur) (y imm32 ur) (z imm32 ur)) `(asm ,info ,asm-inc-cc-counter ,x ,y ,z)])
@ -807,10 +893,13 @@
(define-instruction value pop
[(op (z ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-pop))])
(define-instruction pred (fl= fl< fl<=)
[(op (x ur) (y ur))
(define-instruction pred (fp= fp< fp<=)
[(op (x fpmem) (y fpur))
(let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t
(values '() `(asm ,info ,(asm-fl-relop info) ,x ,y)))])
(values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]
[(op (x fpur) (y fpur))
(let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t
(values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])
(define-instruction pred (eq? u< < > <= >=)
; the idea (following from the intel x86/x86_64 documentation)
@ -871,7 +960,7 @@
`(set! ,(make-live-info) ,uts (immediate 1))
`(set! ,(make-live-info) ,uts
(asm ,info ,asm-exchange ,uts
(mref ,x ,y ,imm)))))])
(mref ,x ,y ,imm uptr)))))])
`(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))]))
(define-instruction effect (locked-incr!)
@ -926,23 +1015,23 @@
(constant-case machine-type-name
[(i3osx ti3osx)
(seq
`(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4))
`(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4 uptr))
`(set! ,(make-live-info) ,%sp (asm ,info ,asm-sub ,%sp (immediate 12))))]
[else `(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4))])])
[else `(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4 uptr))])])
)
;;; SECTION 3: assembler
(module asm-module (; required exports
asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-jump
asm-move asm-move/extend asm-movefrom asm-load asm-store asm-swap asm-library-call asm-library-jump
asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate
asm-pop asm-shiftop asm-sll asm-logand asm-lognot
asm-logtest asm-fl-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
asm-logtest asm-fp-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
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-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div
asm-fl-cvt asm-fl-store asm-fl-load asm-fpt asm-trunc asm-div
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
asm-flop-2 asm-flsqrt 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-enter asm-foreign-call asm-foreign-callable
asm-inc-profile-counter
@ -961,6 +1050,9 @@
[(x) (record-case x [(reg) r #t] [else #f])]
[(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])]))
(define ax-fp-register?
(lambda (x) (record-case x [(reg) r (eq? 'fp (reg-type r))] [else #f])))
(define ax-ea-reg-code
(lambda (ea)
(record-case ea
@ -1131,6 +1223,9 @@
(define-op sse.subsd sse-op1 #xF2 #x5C)
(define-op sse.ucomisd sse-op1 #x66 #x2E)
(define-op sse.xorpd sse-op1 #x66 #x57)
(define-op sse.psllq sse-shift 6)
(define-op sse.psrlq sse-shift 2)
(define-op sse.orpd sse-op1 #x66 #x56)
(define sse-op1
(lambda (op prefix-code op-code source dest-reg code*)
@ -1145,7 +1240,7 @@
(define sse-op2
(lambda (op prefix-code dstreg-op-code srcreg-op-code source dest code*)
(cond
[(ax-register? source)
[(ax-fp-register? source)
(emit-code (op source dest code*)
(build byte prefix-code)
(build byte #x0F)
@ -1153,7 +1248,7 @@
(ax-ea-modrm-reg dest source)
(ax-ea-sib dest)
(ax-ea-addr-disp dest))]
[(ax-register? dest)
[(ax-fp-register? dest)
(emit-code (op source dest code*)
(build byte prefix-code)
(build byte #x0F)
@ -1164,6 +1259,15 @@
[else
($oops 'assembler-internal "sse-op2 source=~s dest=~s" source dest)])))
(define sse-shift
(lambda (op op-code dest-reg amt code*)
(emit-code (op dest-reg amt code*)
(build byte #x66)
(build byte #x0F)
(build byte #x73)
(ax-ea-modrm-ttt dest-reg op-code)
(build byte amt))))
(define float-op2
(lambda (op op-code1 op-code2 source-ea code*)
(emit-code (op source-ea code*)
@ -1660,6 +1764,13 @@
[(word) 2]
[else 4])))
(define shift-address
(lambda (src offset)
(record-case src
[(disp) (imm x1) `(disp ,(fx+ imm offset) ,x1)]
[(index) (imm x2 x1) `(index ,(fx+ imm offset) ,x2 ,x1)]
[else ($oops 'shift-address "unexpected shift-address argument ~s" src)])))
(define asm-move
(lambda (code* dest src)
(Trivit (dest src)
@ -1682,6 +1793,12 @@
[(zext16) (emit movzw src dest code*)]
[else (sorry! who "unexpected op ~s" op)])))))
(define asm-movefrom
(lambda (offset)
(lambda (code* dest src)
(Trivit (dest src)
(emit mov (shift-address src offset) dest code*)))))
(define asm-fstpl
(lambda (code* dest)
(Trivit (dest)
@ -1726,34 +1843,69 @@
[(load-single) (emit sse.movss src (cons 'reg flreg) code*)]
[(load-double) (emit sse.movsd src (cons 'reg flreg) code*)])))))
(define asm-flt
(lambda (code* src flonumreg)
(Trivit (src)
(let ([dest `(disp ,(constant flonum-data-disp) ,flonumreg)]
[flreg (cons 'reg %flreg1)])
(emit sse.cvtsi2sd src flreg
(emit sse.movsd flreg dest code*))))))
(define asm-fpt
(lambda (code* dest src)
(Trivit (dest src)
(emit sse.cvtsi2sd src dest code*))))
(define asm-flop-2
(define asm-fpop-2
(lambda (op)
(lambda (code* src1 src2 dest)
(let ([src1 `(disp ,(constant flonum-data-disp) ,src1)]
[src2 `(disp ,(constant flonum-data-disp) ,src2)]
[dest `(disp ,(constant flonum-data-disp) ,dest)])
(let ([code* (emit sse.movsd (cons 'reg %flreg1) dest code*)])
(let ([code* (case op
[(fl+) (emit sse.addsd src2 (cons 'reg %flreg1) code*)]
[(fl-) (emit sse.subsd src2 (cons 'reg %flreg1) code*)]
[(fl*) (emit sse.mulsd src2 (cons 'reg %flreg1) code*)]
[(fl/) (emit sse.divsd src2 (cons 'reg %flreg1) code*)])])
(emit sse.movsd src1 (cons 'reg %flreg1) code*)))))))
(lambda (code* dest-reg src1 src2)
(define (emit-it src dest code*)
(case op
[(fp+) (emit sse.addsd src dest code*)]
[(fp-) (emit sse.subsd src dest code*)]
[(fp*) (emit sse.mulsd src dest code*)]
[(fp/) (emit sse.divsd src dest code*)]))
(cond
[(eq? dest-reg src1)
(Trivit (dest-reg src2)
(emit-it src2 dest-reg code*))]
[(and (eq? dest-reg src2)
(memq op '(fp+ fp*)))
(Trivit (dest-reg src1)
(emit-it src1 dest-reg code*))]
[else
(Trivit (dest-reg src1 src2)
(emit sse.movsd src2 (cons 'reg %fptmp1)
(emit sse.movsd src1 dest-reg
(emit-it (cons 'reg %fptmp1) dest-reg code*))))]))))
(define asm-flsqrt
(lambda (code* src dest)
(let ([src `(disp ,(constant flonum-data-disp) ,src)]
[dest `(disp ,(constant flonum-data-disp) ,dest)])
(emit sse.sqrtsd src (cons 'reg %flreg1)
(emit sse.movsd (cons 'reg %flreg1) dest code*)))))
(define asm-fpsqrt
(lambda (code* dest-reg src)
(Trivit (dest-reg src)
(emit sse.sqrtsd src dest-reg code*))))
(define asm-fpmove
(lambda (code* dest src)
(Trivit (dest src)
(emit sse.movsd src dest code*))))
(define asm-fpmovefrom
(lambda (code* dest src1 src2)
(Trivit (dest src1 src2)
(emit mov src1 dest
(emit mov src2 (shift-address dest 4) code*)))))
(define asm-fpcastfrom
(lambda (code* dest-reg src1 src2)
(Trivit (dest-reg src1 src2)
(emit sse.movd src1 dest-reg
(emit sse.movd src2 (cons 'reg %fptmp1)
(emit sse.psllq (cons 'reg %fptmp1) 32
(emit sse.orpd (cons 'reg %fptmp1) dest-reg code*)))))))
(define asm-fpcastto
(lambda (shift)
(lambda (code* dest src)
(Trivit (dest src)
(cond
[(eqv? shift 0)
(emit sse.movd src dest code*)]
[else
(emit sse.movsd src (cons 'reg %fptmp1)
(emit sse.psrlq (cons 'reg %fptmp1) shift
(emit sse.movd (cons 'reg %fptmp1) dest code*)))])))))
(define asm-trunc
(lambda (code* dest flonumreg)
@ -2073,14 +2225,12 @@
(let-values ([(l1 l2) (if i? (values l2 l1) (values l1 l2))])
(asm-conditional-jump info l2 l1 offset)))))))
(define asm-fl-relop
(define asm-fp-relop
(lambda (info)
(lambda (l1 l2 offset x y)
(values
(let ([x `(disp ,(constant flonum-data-disp) ,x)]
[y `(disp ,(constant flonum-data-disp) ,y)])
(emit sse.movsd y (cons 'reg %flreg1)
(emit sse.ucomisd x (cons 'reg %flreg1) '())))
(Trivit (x y)
(emit sse.ucomisd x y '()))
(asm-conditional-jump info l1 l2 offset)))))
(define asm-relop
@ -2277,11 +2427,11 @@
[(carry) (i? bcc bcs)]
; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100
; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1
[(fl<) bls]
[(fp<) bls]
; reversed & inverted: !(fl<= y x) = !(fl>= x y) iff cf = 1
[(fl<=) bcs]
[(fp<=) bcs]
; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1
[(fl=) (or bne bcs)]))))))
[(fp=) (or bne bcs)]))))))
(define asm-data-label
(lambda (code* l offset func code-size)
@ -2403,14 +2553,14 @@
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
[load-single-stack
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
(inline ,(make-info-loadfl %fptmp1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %fptmp1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
[load-stack
(lambda (offset)
(lambda (rhs) ; requires rhs
@ -2703,14 +2853,14 @@
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-single-stack
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(inline ,(make-info-loadfl %fptmp1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-stack
(lambda (type offset)
(lambda (lvalue) ; requires lvalue

358
s/x86_64.ss
View File

@ -17,66 +17,68 @@
(if-feature windows
(define-registers
(reserved
[%tc %r14 #t 14]
[%sfp %r13 #t 13]
[%ap %rdi #t 7]
[%tc %r14 #t 14 uptr]
[%sfp %r13 #t 13 uptr]
[%ap %rdi #t 7 uptr]
#;[%esp]
#;[%eap]
#;[%trap])
(allocable
[%ac0 %rbp #t 5]
[%xp %r12 #t 12]
[%ts %rax %Cretval #f 0]
[%td %rbx #t 3]
[%ac1 %r10 %deact #f 10]
[%yp %r11 #f 11]
[%cp %r15 #t 15]
[#;%ret %rsi #t 6]
[ %rdx %Carg2 #f 2]
[ %r8 %Carg3 #f 8]
[ %r9 %Carg4 #f 9]
[ %rcx %Carg1 #f 1]) ; last to avoid use as a Scheme argument
[%ac0 %rbp #t 5 uptr]
[%xp %r12 #t 12 uptr]
[%ts %rax %Cretval #f 0 uptr]
[%td %rbx #t 3 uptr]
[%ac1 %r10 %deact #f 10 uptr]
[%yp %r11 #f 11 uptr]
[%cp %r15 #t 15 uptr]
[#;%ret %rsi #t 6 uptr]
[ %rdx %Carg2 #f 2 uptr]
[ %r8 %Carg3 #f 8 uptr]
[ %r9 %Carg4 #f 9 uptr]
[ %rcx %Carg1 #f 1 uptr] ; last to avoid use as a Scheme argument
[%fp1 %Cfparg3 #f 2 fp]
[%fp2 %Cfparg4 #f 3 fp])
(machine-dependent
[%Cfparg1 %Cfpretval #f 0]
[%Cfparg2 #f 1]
[%Cfparg3 #f 2]
[%Cfparg4 #f 3]
[%flreg1 #f 4] ; xmm 0-5 are caller-save
[%flreg2 #f 5] ; xmm 6-15 are callee-save
[%sp #t 4]))
[%Cfparg1 %Cfpretval #f 0 fp]
[%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 fp])
(reify-support %ts))
(define-registers
(reserved
[%tc %r14 #t 14]
[%sfp %r13 #t 13]
[%ap %r9 %Carg6 #f 9]
[%tc %r14 #t 14 uptr]
[%sfp %r13 #t 13 uptr]
[%ap %r9 %Carg6 #f 9 uptr]
#;[%esp]
#;[%eap]
#;[%trap])
(allocable
[%ac0 %rbp #t 5]
[%xp %r12 #t 12]
[%ts %rax %Cretval #f 0]
[%td %rbx #t 3]
[%ac1 %r10 %deact #f 10]
[%yp %r11 #f 11]
[%cp %r15 #t 15]
[#;%ret %r8 %Carg5 #f 8]
[ %rdi %Carg1 #f 7]
[ %rsi %Carg2 #f 6]
[ %rdx %Carg3 #f 2]
[ %rcx %Carg4 #f 1])
[%ac0 %rbp #t 5 uptr]
[%xp %r12 #t 12 uptr]
[%ts %rax %Cretval #f 0 uptr]
[%td %rbx #t 3 uptr]
[%ac1 %r10 %deact #f 10 uptr]
[%yp %r11 #f 11 uptr]
[%cp %r15 #t 15 uptr]
[#;%ret %r8 %Carg5 #f 8 uptr]
[ %rdi %Carg1 #f 7 uptr]
[ %rsi %Carg2 #f 6 uptr]
[ %rdx %Carg3 #f 2 uptr]
[ %rcx %Carg4 #f 1 uptr]
[%fp1 %Cfparg3 #f 2 fp]
[%fp2 %Cfparg4 #f 3 fp])
(machine-dependent
[%Cfparg1 %Cfpretval #f 0]
[%Cfparg2 #f 1]
[%Cfparg3 #f 2]
[%Cfparg4 #f 3]
[%Cfparg5 #f 4]
[%Cfparg6 #f 5]
[%Cfparg7 #f 6]
[%Cfparg8 #f 7]
[%flreg1 #f 8]
[%flreg2 #f 9]
[%sp #t 4])))
[%Cfparg1 %Cfpretval #f 0 fp]
[%Cfparg2 #f 1 fp]
[%Cfparg5 #f 4 fp]
[%Cfparg6 #f 5 fp]
[%Cfparg7 #f 6 fp]
[%Cfparg8 #f 7 fp]
[%fptmp1 #f 8 fp]
[%fptmp2 #f 9 fp]
[%sp #t 4 uptr])
(reify-support %ts)))
;;; SECTION 2: instructions
(module (md-handle-jump) ; also sets primitive handlers
@ -100,6 +102,18 @@
(lambda (x)
(or (lmem? x) (literal@? x))))
(define fpmem?
(lambda (x)
(nanopass-case (L15c Triv) x
[(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
[else #f])))
(define-syntax mem-of-type?
(lambda (stx)
(syntax-case stx (mem fpmem)
[(_ mem e) #'(lmem? e)]
[(_ fpmem e) #'(fpmem? e)])))
(define real-imm32?
(lambda (x)
(nanopass-case (L15c Triv) x
@ -127,24 +141,24 @@
(define mref->mref
(lambda (a k)
(define return
(lambda (x0 x1 imm)
(k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm)))))
(lambda (x0 x1 imm type)
(k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))
(nanopass-case (L15c Triv) a
[(mref ,lvalue0 ,lvalue1 ,imm)
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
(lvalue->ur lvalue0
(lambda (x0)
(lvalue->ur lvalue1
(lambda (x1)
(if (signed-32? imm)
(return x0 x1 imm)
(return x0 x1 imm type)
(let ([u (make-tmp 'u)])
(seq
(build-set! ,u (immediate ,imm))
(if (eq? x1 %zero)
(return x0 u 0)
(return x0 u 0 type)
(seq
(build-set! ,u (asm ,null-info ,asm-add ,u ,x1))
(return x0 u 0))))))))))])))
(return x0 u 0 type))))))))))])))
(define mem->mem
(lambda (a k)
@ -153,20 +167,27 @@
(let ([u (make-tmp 'u)])
(seq
(build-set! ,u ,(literal@->literal a))
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0)))))]
(k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 ptr)))))]
[else (mref->mref a k)])))
(define literal->literal
(lambda (a)
(nanopass-case (L15c Triv) a
[(literal ,info) (with-output-language (L15d Triv) `(literal ,info))])))
(define-syntax coercible?
(syntax-rules ()
[(_ ?a ?aty*)
(let ([a ?a] [aty* ?aty*])
(or (memq 'ur aty*)
(or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
(and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
(or (and (memq 'imm32 aty*) (imm32? a))
(and (memq 'imm aty*) (imm? a))
(and (memq 'zero aty*) (imm0? a))
(and (memq 'real-imm32 aty*) (real-imm32? a))
(and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? 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*
(syntax-rules ()
@ -174,6 +195,7 @@
(let ([a ?a] [aty* ?aty*] [k ?k])
(cond
[(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
[(and (memq 'fpmem aty*) (fpmem? a)) (mem->mem a k)]
[(and (memq 'imm32 aty*) (imm32? a)) (k (imm->imm a))]
[(and (memq 'imm aty*) (imm? a)) (k (imm->imm a))]
[(and (memq 'zero aty*) (imm0? a)) (k (imm->imm a))]
@ -195,6 +217,18 @@
(build-set! ,u ,a)
(k u)))))]
[else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
[(memq 'fpur aty*)
(cond
[(fpur? a) (k a)]
[(fpmem? a)
(mem->mem a
(lambda (a)
(let ([u (make-tmp 'u 'fp)])
(seq
(build-set! ,u ,a)
(k u)))))]
[else
(sorry! 'coerce-opnd "unexpected operand ~s" a)])]
[else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
(define set-ur=mref
@ -254,7 +288,7 @@
[(ur? c) (#,k c b)]
[(mref? c)
(nanopass-case (L15c Triv) c
[(mref ,lvalue0 ,lvalue1 ,imm)
[(mref ,lvalue0 ,lvalue1 ,imm ,type)
; TODO: does this use too many registers? (no longer special casing fv x0, x1 case)
(lvalue->ur lvalue0
(lambda (x0)
@ -263,23 +297,30 @@
(let ([u1 (make-tmp 'u)])
(if (signed-32? imm)
(seq
(build-set! ,u1 (mref ,x0 ,x1 ,imm))
(build-set! ,u1 (mref ,x0 ,x1 ,imm ,type))
(#,k u1 b)
(build-set! (mref ,x0 ,x1 ,imm) ,u1))
(build-set! (mref ,x0 ,x1 ,imm ,type) ,u1))
(let ([u2 (make-tmp 'u)])
(seq
(build-set! ,u2 ,imm)
(build-set! ,x1 (asm ,null-info ,asm-add ,x1 ,u2))
(build-set! ,u1 (mref ,x0 ,x1 0))
(build-set! ,u1 (mref ,x0 ,x1 0 ,type))
(#,k u1 b)
(build-set! (mref ,x0 ,x1 0) ,u1)))))))))])]
(build-set! (mref ,x0 ,x1 0 ,type) ,u1)))))))))])]
; can't be literal@ since literals can't be lvalues
[else (sorry! '#,(datum->syntax #'* who) "unexpected operand ~s" c)])))
(next c a b)))))
(define mem-type?
(lambda (t)
(syntax-case t (mem fpmem)
[mem #t]
[fpmem #t]
[else #f])))
(define make-value-clause
(lambda (fmt)
(syntax-case fmt (mem ur xp)
(syntax-case fmt (mem fpmem ur fpur xp)
[(op (c mem) (a ?c) (b bty* ...))
(bound-identifier=? #'?c #'c)
(acsame-mem #'c #'a #'b #'(bty* ...) #'(lambda (c b) (rhs c c b)))]
@ -292,9 +333,10 @@
[(op (c ur) (a aty* ...) (b ?c))
(bound-identifier=? #'?c #'c)
(acsame-ur #'c #'b #'a #'(aty* ...) #'(lambda (c a) (rhs c a c)))]
[(op (c mem) (a aty ...) (b bty ...))
[(op (c xmem) (a aty ...) (b bty ...))
(mem-type? #'xmem)
#`(lambda (c a b)
(if (and (lmem? c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
(coerce-opnd b '(bty ...)
(lambda (b)
(coerce-opnd a '(aty ...)
@ -317,6 +359,22 @@
(lambda (c)
(build-set! ,c ,u))))))))))
(next c a b)))]
[(op (c fpur) (a aty ...) (b bty ...))
#`(lambda (c a b)
(if (and (coercible? a '(aty ...)) (coercible? b '(bty ...)))
(coerce-opnd b '(bty ...)
(lambda (b)
(coerce-opnd a '(aty ...)
(lambda (a)
(if (fpur? c)
(rhs c a b)
(let ([u (make-tmp 'u 'fp)])
(seq
(rhs u a b)
(mref->mref c
(lambda (c)
(build-set! ,c ,u))))))))))
(next c a b)))]
; four-operand case below can require four unspillables
[(op (c ur) (a ur) (b ur) (d dty ...))
(not (memq 'mem (datum (dty ...))))
@ -359,9 +417,10 @@
(rhs u u)
(build-set! ,c ,u))))))
(next c a)))]
[(op (c mem) (a aty ...))
[(op (c xmem) (a aty ...))
(mem-type? #'xmem)
#`(lambda (c a)
(if (and (lmem? c) (coercible? a '(aty ...)))
(if (and (mem-of-type? xmem c) (coercible? a '(aty ...)))
(coerce-opnd a '(aty ...)
(lambda (a)
(mem->mem c
@ -382,6 +441,20 @@
(rhs u a)
(build-set! ,c ,u))))))))
(next c a)))]
[(op (c fpur) (a aty ...))
#`(lambda (c a)
(if (coercible? a '(aty ...))
(coerce-opnd a '(aty ...)
(lambda (a)
(if (fpur? c)
(rhs c a)
(mem->mem c
(lambda (c)
(let ([u (make-tmp 'u 'fp)])
(seq
(rhs u a)
(build-set! ,c ,u))))))))
(next c a)))]
[(op (c ur))
#`(lambda (c)
(if (ur? c)
@ -392,9 +465,10 @@
(seq
(rhs u)
(build-set! ,c ,u)))))))]
[(op (c mem))
[(op (c xmem))
(mem-type? #'xmem)
#`(lambda (c)
(if (lmem? c)
(if (mem-of-type? xmem c)
(mem->mem c
(lambda (c)
(rhs c)))
@ -813,14 +887,29 @@
`(set! ,(make-live-info) ,z
(asm ,info ,(asm-get-double (info-loadfl-flreg info))))])
(define-instruction effect (flt)
[(op (x mem ur) (y ur)) `(asm ,info ,asm-flt ,x ,y)])
(define-instruction value (fpt)
[(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))])
(define-instruction effect (fl+ fl- fl/ fl*)
[(op (x ur) (y ur) (z ur)) `(asm ,info ,(asm-flop-2 op) ,x ,y ,z)])
(define-instruction value (fpmove)
[(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))])
(define-instruction effect (flsqrt)
[(op (x ur) (y ur)) `(asm ,info ,asm-flsqrt ,x ,y)])
(define-instruction value (fpcastto)
[(op (x mem) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
[(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,asm-move ,y))]
[(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcast ,y))])
(define-instruction value (fpcastfrom)
[(op (x fpmem) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-move ,y))]
[(op (x fpur) (y mem)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
[(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcast ,y))])
(define-instruction value (fp+ fp- fp* fp/)
[(op (x fpur) (y fpmem fpur) (z fpmem fpur))
`(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
(define-instruction value (fpsqrt)
[(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
(define-instruction effect inc-cc-counter
[(op (x ur) (y imm32 ur) (z imm32 ur)) `(asm ,info ,asm-inc-cc-counter ,x ,y ,z)])
@ -878,10 +967,13 @@
(define-instruction value pop
[(op (z ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-pop))])
(define-instruction pred (fl= fl< fl<=)
[(op (x ur) (y ur))
(define-instruction pred (fp= fp< fp<=)
[(op (x fpmem) (y fpur))
(let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t
(values '() `(asm ,info ,(asm-fl-relop info) ,x ,y)))])
(values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]
[(op (x fpur) (y fpur))
(let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t
(values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])
(define-instruction pred (eq? u< < > <= >=)
; the idea (following from the intel x86/x86_64 documentation)
@ -942,7 +1034,7 @@
`(set! ,(make-live-info) ,uts (immediate 1))
`(set! ,(make-live-info) ,uts
(asm ,info ,asm-exchange ,uts
(mref ,x ,y ,imm)))))])
(mref ,x ,y ,imm uptr)))))])
`(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))]))
(define-instruction effect (locked-incr!)
@ -1018,13 +1110,14 @@
asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-jump
asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate
asm-pop asm-shiftop asm-sll asm-logand asm-lognot
asm-logtest asm-fl-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
asm-logtest asm-fp-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
asm-rp-header asm-rp-compact-header
asm-lea1 asm-lea2 asm-indirect-call asm-condition-code
asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div asm-popcount
asm-fl-cvt asm-fl-store asm-fl-load asm-fpt asm-trunc asm-div asm-popcount
asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
asm-flop-2 asm-flsqrt asm-c-simple-call
asm-fpsqrt asm-fpop-2 asm-fpmove asm-fpcast
asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
asm-enter asm-foreign-call asm-foreign-callable
asm-inc-profile-counter
@ -1040,6 +1133,9 @@
[(x) (record-case x [(reg) r #t] [else #f])]
[(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])]))
(define ax-fp-register?
(lambda (x) (record-case x [(reg) r (eq? 'fp (reg-type r))] [else #f])))
(define ax-ea-reg-code
(lambda (ea)
(record-case ea
@ -1223,7 +1319,7 @@
(define sse-op2
(lambda (op prefix-code dstreg-op-code srcreg-op-code w source dest code*)
(cond
[(ax-register? source)
[(ax-fp-register? source)
(emit-code (op source dest code*)
(build byte prefix-code)
(ax-ea-rex w dest source #f)
@ -1232,7 +1328,7 @@
(ax-ea-modrm-reg dest source)
(ax-ea-sib dest)
(ax-ea-addr-disp dest))]
[(ax-register? dest)
[(ax-fp-register? dest)
(emit-code (op source dest code*)
(build byte prefix-code)
(ax-ea-rex w source dest #f)
@ -1943,34 +2039,48 @@
(lambda (code* dst)
(emit sse.movd (cons 'reg flreg) (cons 'reg dst) code*))))
(define asm-flt
(lambda (code* src flonumreg)
(Trivit (src)
(let ([dest `(disp ,(constant flonum-data-disp) ,flonumreg)]
[flreg (cons 'reg %flreg1)])
(emit sse.cvtsi2sd src flreg
(emit sse.movsd flreg dest code*))))))
(define asm-fpt
(lambda (code* dest src)
(Trivit (dest src)
(emit sse.cvtsi2sd src dest code*))))
(define asm-flop-2
(define asm-fpop-2
(lambda (op)
(lambda (code* src1 src2 dest)
(let ([src1 `(disp ,(constant flonum-data-disp) ,src1)]
[src2 `(disp ,(constant flonum-data-disp) ,src2)]
[dest `(disp ,(constant flonum-data-disp) ,dest)])
(let ([code* (emit sse.movsd (cons 'reg %flreg1) dest code*)])
(let ([code* (case op
[(fl+) (emit sse.addsd src2 (cons 'reg %flreg1) code*)]
[(fl-) (emit sse.subsd src2 (cons 'reg %flreg1) code*)]
[(fl*) (emit sse.mulsd src2 (cons 'reg %flreg1) code*)]
[(fl/) (emit sse.divsd src2 (cons 'reg %flreg1) code*)])])
(emit sse.movsd src1 (cons 'reg %flreg1) code*)))))))
(lambda (code* dest-reg src1 src2)
(define (emit-it src dest code*)
(case op
[(fp+) (emit sse.addsd src dest code*)]
[(fp-) (emit sse.subsd src dest code*)]
[(fp*) (emit sse.mulsd src dest code*)]
[(fp/) (emit sse.divsd src dest code*)]))
(cond
[(eq? dest-reg src1)
(Trivit (dest-reg src2)
(emit-it src2 dest-reg code*))]
[(and (eq? dest-reg src2)
(memq op '(fp+ fp*)))
(Trivit (dest-reg src1)
(emit-it src1 dest-reg code*))]
[else
(Trivit (dest-reg src1 src2)
(emit sse.movsd src2 (cons 'reg %fptmp1)
(emit sse.movsd src1 dest-reg
(emit-it (cons 'reg %fptmp1) dest-reg code*))))]))))
(define asm-flsqrt
(lambda (code* src dest)
(let ([src `(disp ,(constant flonum-data-disp) ,src)]
[dest `(disp ,(constant flonum-data-disp) ,dest)])
(emit sse.sqrtsd src (cons 'reg %flreg1)
(emit sse.movsd (cons 'reg %flreg1) dest code*)))))
(define asm-fpsqrt
(lambda (code* dest-reg src)
(Trivit (dest-reg src)
(emit sse.sqrtsd src dest-reg code*))))
(define asm-fpmove
(lambda (code* dest src)
(Trivit (dest src)
(emit sse.movsd src dest code*))))
(define asm-fpcast
(lambda (code* dest src)
(Trivit (dest src)
(emit sse.movd src dest code*))))
(define asm-trunc
(lambda (code* dest flonumreg)
@ -2305,14 +2415,12 @@
(let-values ([(l1 l2) (if i? (values l2 l1) (values l1 l2))])
(asm-conditional-jump info l2 l1 offset)))))))
(define asm-fl-relop
(define asm-fp-relop
(lambda (info)
(lambda (l1 l2 offset x y)
(values
(let ([x `(disp ,(constant flonum-data-disp) ,x)]
[y `(disp ,(constant flonum-data-disp) ,y)])
(emit sse.movsd y (cons 'reg %flreg1)
(emit sse.ucomisd x (cons 'reg %flreg1) '())))
(Trivit (x y)
(emit sse.ucomisd x y '()))
(asm-conditional-jump info l1 l2 offset)))))
(define asm-relop
@ -2527,11 +2635,11 @@
[(carry) (i? bcc bcs)]
; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100
; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1
[(fl<) bls]
[(fp<) bls]
; reversed & inverted: !(fl<= y x) = !(fl>= x y) iff cf = 1
[(fl<=) bcs]
[(fp<=) bcs]
; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1
[(fl=) (or bne bcs)]))))))
[(fp=) (or bne bcs)]))))))
(define asm-data-label
(lambda (code* l offset func code-size)
@ -2754,14 +2862,14 @@
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
[load-single-stack
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
(inline ,(make-info-loadfl %fptmp1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %fptmp1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
[load-int-stack
(lambda (offset)
(lambda (rhs) ; requires rhs
@ -3215,14 +3323,14 @@
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(inline ,(make-info-loadfl %fptmp1) ,%load-double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-single-stack
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(inline ,(make-info-loadfl %fptmp1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %fptmp1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
(define load-int-stack
(lambda (type offset)
(lambda (lvalue)