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: %.boot:
( cd .. ; ./workarea $* xc-$* ) ( cd .. ; ./workarea $* xc-$* )
( cd ../xc-$*/s ; make -f Mf-cross base=../../$(workarea) --jobs=2 m=$(m) xm=$* ) ( 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 \ if [ ! -h ../xc-$*/boot/$*/$$x ] ; then \
mv -f ../xc-$*/boot/$*/$$x ../boot/$*/$$x ;\ mv -f ../xc-$*/boot/$*/$$x ../boot/$*/$$x ;\
fi ;\ fi ;\

2
makefiles/Mf-install.in
View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point # # no changes should be needed below this point #
############################################################################### ###############################################################################
Version=csv9.5.3.28 Version=csv9.5.3.29
Include=boot/$m Include=boot/$m
PetiteBoot=boot/$m/petite.boot PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.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) '((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))) (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= (mat fl=
(let ((n (read (open-input-string "+nan.0")))) (let ((n (read (open-input-string "+nan.0"))))
(not (fl= n n))) (not (fl= n n)))
(not (fl= (nan))) (fl= (nan))
(not (fl= (nan) +inf.0)) (not (fl= (nan) +inf.0))
(not (fl= (nan) -inf.0)) (not (fl= (nan) -inf.0))
(not (fl= (nan) (nan))) (not (fl= (nan) (nan)))
@ -171,7 +171,7 @@
) )
(mat fl< (mat fl<
(not (fl< (nan))) (fl< (nan))
(not (fl< (nan) (nan))) (not (fl< (nan) (nan)))
(not (fl< (nan) 0.0)) (not (fl< (nan) 0.0))
(not (fl< 0.0 (nan))) (not (fl< 0.0 (nan)))
@ -179,7 +179,7 @@
) )
(mat fl> (mat fl>
(not (fl> (nan))) (fl> (nan))
(not (fl> (nan) (nan))) (not (fl> (nan) (nan)))
(not (fl> (nan) 0.0)) (not (fl> (nan) 0.0))
(not (fl> 0.0 (nan))) (not (fl> 0.0 (nan)))
@ -189,14 +189,14 @@
) )
(mat fl<= (mat fl<=
(not (fl<= (nan))) (fl<= (nan))
(not (fl<= (nan) (nan))) (not (fl<= (nan) (nan)))
(not (fl<= (nan) 0.0)) (not (fl<= (nan) 0.0))
(not (fl<= 0.0 (nan))) (not (fl<= 0.0 (nan)))
) )
(mat fl>= (mat fl>=
(not (fl>= (nan))) (fl>= (nan))
(not (fl>= (nan) (nan))) (not (fl>= (nan) (nan)))
(not (fl>= (nan) 0.0)) (not (fl>= (nan) 0.0))
(not (fl>= 0.0 (nan))) (not (fl>= 0.0 (nan)))

7
mats/misc.ms
View File

@ -5293,6 +5293,13 @@
(condition-wait c m) (condition-wait c m)
(loop))) (loop)))
(mutex-release m) (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)) #t))
) )

1
s/a6fb.def
View File

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

442
s/arm32.ss
View File

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

1
s/arm32le.def
View File

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

14
s/bytevector.ss
View File

@ -732,16 +732,11 @@
(set-who! bytevector-ieee-double-native-ref (set-who! bytevector-ieee-double-native-ref
(lambda (v i) (lambda (v i)
(if ($bytevector-ref-check? 64 v i) (#2%bytevector-ieee-double-native-ref v i)))
(#3%bytevector-ieee-double-native-ref v i)
(if (bytevector? v)
(invalid-index who v i)
(not-a-bytevector who v)))))
(set-who! bytevector-ieee-single-native-set! (set-who! bytevector-ieee-single-native-set!
(lambda (v i x) (lambda (v i x)
(if ($bytevector-set!-check? 32 v i) (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) (#3%bytevector-ieee-single-native-set! v i x)
(if (mutable-bytevector? v) (if (mutable-bytevector? v)
(invalid-index who v i) (invalid-index who v i)
@ -749,12 +744,7 @@
(set-who! bytevector-ieee-double-native-set! (set-who! bytevector-ieee-double-native-set!
(lambda (v i x) (lambda (v i x)
(if ($bytevector-set!-check? 64 v i) (#2%bytevector-ieee-double-native-set! v i x)))
; 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)))))
(set-who! bytevector-copy (set-who! bytevector-copy
(lambda (v) (lambda (v)

24
s/cmacros.ss
View File

@ -328,7 +328,7 @@
[(_ foo e1 e2) e1] ... [(_ foo e1 e2) e1] ...
[(_ bar e1 e2) e2]))))]))) [(_ bar e1 e2) e2]))))])))
(define-constant scheme-version #x0905031C) (define-constant scheme-version #x0905031D)
(define-syntax define-machine-types (define-syntax define-machine-types
(lambda (x) (lambda (x)
@ -412,6 +412,11 @@
(define-constant ptr-alignment (define-constant ptr-alignment
(/ (constant byte-alignment) (constant ptr-bytes))) (/ (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" ;; seginfo offsets, must be consistent with `seginfo` in "types.h"
(define-constant seginfo-space-disp 0) (define-constant seginfo-space-disp 0)
(define-constant seginfo-generation-disp 1) (define-constant seginfo-generation-disp 1)
@ -1448,7 +1453,8 @@
[void* lz4-out-buffer] [void* lz4-out-buffer]
[U64 instr-counter] [U64 instr-counter]
[U64 alloc-counter] [U64 alloc-counter]
[ptr parameters])) [ptr parameters]
[double fpregs (constant asm-fpreg-max)]))
(define tc-field-list (define tc-field-list
(let f ([ls (oblist)] [params '()]) (let f ([ls (oblist)] [params '()])
@ -1686,6 +1692,7 @@
(unsafe #b00001000000000000000000) (unsafe #b00001000000000000000000)
(unrestricted #b00010000000000000000000) (unrestricted #b00010000000000000000000)
(safeongoodargs #b00100000000000000000000) (safeongoodargs #b00100000000000000000000)
(unboxed-arguments #b10000000000000000000000) ; always accepts unboxed 'flonum arguments, up to inline-args-limit
(cptypes2 #b01000000000000000000000) (cptypes2 #b01000000000000000000000)
(cptypes3 cptypes2) (cptypes3 cptypes2)
(cptypes2x cptypes2) (cptypes2x cptypes2)
@ -1694,7 +1701,9 @@
(alloc (or proc discard true)) (alloc (or proc discard true))
; would be nice to check that these and only these actually have cp0 partial folders ; would be nice to check that these and only these actually have cp0 partial folders
(partial-folder (or cp02 cp03)) (partial-folder (or cp02 cp03))
) )
(define-constant inline-args-limit 10)
(define-flags cp0-info-mask (define-flags cp0-info-mask
(pure-known #b0000000001) (pure-known #b0000000001)
@ -1804,7 +1813,10 @@
(syntax-rules () (syntax-rules ()
((_ x) ((_ x)
(float-type-case (float-type-case
[(ieee) (fx= ($flonum-exponent x) #x7ff)])))) [(ieee) (fx= ($flonum-exponent x) #x7ff)]))))
;; #t => incompatibility with older Chez Scheme:
(define-constant nan-single-comparison-true? #t)
(define-syntax on-reset (define-syntax on-reset
(syntax-rules () (syntax-rules ()
@ -2503,6 +2515,7 @@
(cfl/ #f 2 #f #t) (cfl/ #f 2 #f #t)
(negate #f 1 #f #t) (negate #f 1 #f #t)
(flnegate #f 1 #t #t) (flnegate #f 1 #t #t)
(flabs #f 1 #t #t)
(call-error #f 0 #f #f) (call-error #f 0 #f #f)
(unsafe-unread-char #f 2 #f #t) (unsafe-unread-char #f 2 #f #t)
(map-car #f 1 #f #t) (map-car #f 1 #f #t)
@ -2523,6 +2536,7 @@
(fxsll #f 2 #f #t) (fxsll #f 2 #f #t)
(fxsrl #f 2 #t #t) (fxsrl #f 2 #t #t)
(fxsra #f 2 #t #t) (fxsra #f 2 #t #t)
(fixnum->flonum #f 1 #t #t)
(append #f 2 #f #t) (append #f 2 #f #t)
(values-error #f 0 #f #f) (values-error #f 0 #f #f)
(dooverflow #f 0 #f #f) (dooverflow #f 0 #f #f)
@ -2640,6 +2654,8 @@
(bytevector-s8-set! #f 3 #f #t) (bytevector-s8-set! #f 3 #f #t)
(bytevector-u8-set! #f 3 #f #t) (bytevector-u8-set! #f 3 #f #t)
(bytevector=? #f 2 #f #f) (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) (real->flonum #f 2 #f #t)
(unsafe-port-eof? #f 1 #f #t) (unsafe-port-eof? #f 1 #f #t)
(unsafe-lookahead-u8 #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 ; pure OR body to be pure, since we can't separate non-pure
; RHS and body expressions ; RHS and body expressions
[(letrec ([,x* ,e*] ...) ,body) [(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. ; 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*) (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)] (values (make-lifted #f x* e*) body)]

1210
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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int") (define-constant typedef-uptr "unsigned int")

15
s/inspect.ss
View File

@ -2281,8 +2281,12 @@
(values (make-vector count) count cp)) (values (make-vector count) count cp))
(let ([obj (vector-ref vals i)] [var* (vector-ref vars i)]) (let ([obj (vector-ref vals i)] [var* (vector-ref vars i)])
(cond (cond
[(eq? obj cookie) [(and (eq? obj cookie)
(unless (null? var*) ($oops who "expected value for ~s but it was not in lpm" (car var*))) (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*)] (f (fx1+ i) count cp cpvar*)]
[(null? var*) [(null? var*)
(let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)]) (let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)])
@ -2310,7 +2314,12 @@
(vector->list var)))] (vector->list var)))]
[else [else
(let-values ([(v frame-count cp) (g (cdr var*) (fx1+ count) cp cpvar*)]) (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))])))))])))) (values v frame-count cp))])))))]))))
(lambda (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))))))] (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 (define index-oops
(lambda (who x i) (lambda (who x i)
($oops who "~s is not a valid index for ~s" i x))) ($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 (define stencil-vector-oops
(lambda (who x) (lambda (who x)
($oops who "~s is not a vector" x))) ($oops who "~s is not a vector" x)))
@ -400,6 +405,16 @@
(define-library-entry (stencil-vector-mask v) (define-library-entry (stencil-vector-mask v)
(stencil-vector-oops '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))) (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 (fxxor x y) (fxnonfixnum2 'fxxor x y))
(define-library-entry (fxand x y) (fxnonfixnum2 'fxand x y)) (define-library-entry (fxand x y) (fxnonfixnum2 'fxand x y))
(define-library-entry (fxnot x) (fxnonfixnum1 'fxnot x)) (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 (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 (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)) (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 (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 (flnegate x) (flonum-oops 'fl- x))
(define-library-entry (flabs x) (flonum-oops 'flabs x))
) )
(define-library-entry (flround x) (define-library-entry (flround x)

6
s/mathprims.ss
View File

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

102
s/np-languages.ss
View File

@ -17,7 +17,7 @@
(module np-languages () (module np-languages ()
(export sorry! var? var-index var-index-set! prelex->uvar make-tmp make-assigned-tmp (export sorry! var? var-index var-index-set! prelex->uvar make-tmp make-assigned-tmp
make-unspillable make-cpvar make-restricted-unspillable 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-referenced? uvar-referenced! uvar-assigned? uvar-assigned!
uvar-was-closure-ref? uvar-was-closure-ref! uvar-was-closure-ref? uvar-was-closure-ref!
uvar-unspillable? uvar-spilled? uvar-spilled! uvar-local-save? uvar-local-save! 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-ref-weight uvar-ref-weight-set! uvar-save-weight uvar-save-weight-set!
uvar-live-count uvar-live-count-set! uvar-live-count uvar-live-count-set!
uvar uvar
fv-offset fv-offset fv-type
var-spillable-conflict* var-spillable-conflict*-set! var-spillable-conflict* var-spillable-conflict*-set!
var-unspillable-conflict* var-unspillable-conflict*-set! var-unspillable-conflict* var-unspillable-conflict*-set!
uvar-degree uvar-degree-set! uvar-degree uvar-degree-set!
uvar-info-lambda uvar-info-lambda-set! uvar-info-lambda uvar-info-lambda-set!
uvar-iii uvar-iii-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 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-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! 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! 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-pure? primitive-type primitive-handler primitive-handler-set!
%primitive value-primitive? pred-primitive? effect-primitive? %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! reg-precolored reg-precolored-set!
label? label-name label? label-name
libspec-label? make-libspec-label libspec-label-libspec libspec-label-live-reg* libspec-label? make-libspec-label libspec-label-libspec libspec-label-live-reg*
@ -92,13 +92,13 @@
(define-record-type (fv $make-fv fv?) (define-record-type (fv $make-fv fv?)
(parent var) (parent var)
(fields offset) (fields offset type)
(nongenerative) (nongenerative)
(sealed #t) (sealed #t)
(protocol (protocol
(lambda (pargs->new) (lambda (pargs->new)
(lambda (offset) (lambda (offset type)
((pargs->new) offset))))) ((pargs->new) offset type)))))
(module () (module ()
(record-writer (record-type-descriptor fv) (record-writer (record-type-descriptor fv)
@ -107,13 +107,13 @@
(define-record-type reg (define-record-type reg
(parent var) (parent var)
(fields name mdinfo tc-disp callee-save? (mutable precolored)) (fields name mdinfo tc-disp callee-save? type (mutable precolored))
(nongenerative) (nongenerative)
(sealed #t) (sealed #t)
(protocol (protocol
(lambda (pargs->new) (lambda (pargs->new)
(lambda (name mdinfo tc-disp callee-save?) (lambda (name mdinfo tc-disp callee-save? type)
((pargs->new) name mdinfo tc-disp callee-save? #f))))) ((pargs->new) name mdinfo tc-disp callee-save? type #f)))))
(module () (module ()
(record-writer (record-type-descriptor reg) (record-writer (record-type-descriptor reg)
@ -169,7 +169,7 @@
(fields (fields
name name
source source
type (mutable type)
conflict* conflict*
(mutable flags) (mutable flags)
(mutable info-lambda) (mutable info-lambda)
@ -206,8 +206,8 @@
[(name) (make-assigned-tmp name 'ptr)] [(name) (make-assigned-tmp name 'ptr)]
[(name type) ($make-uvar name #f type '() (uvar-flags-mask referenced assigned))])) [(name type) ($make-uvar name #f type '() (uvar-flags-mask referenced assigned))]))
(define make-unspillable (define make-unspillable
(lambda (name) (lambda (name type)
($make-uvar name #f 'ptr '() (uvar-flags-mask referenced unspillable)))) ($make-uvar name #f type '() (uvar-flags-mask referenced unspillable))))
(define make-cpvar (define make-cpvar
(lambda () (lambda ()
(include "types.ss") (include "types.ss")
@ -220,7 +220,9 @@
(module () (module ()
(record-writer (record-type-descriptor uvar) (record-writer (record-type-descriptor uvar)
(lambda (x p wr) (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 (define lookup-unique-uvar
(let ([ht (make-eq-hashtable)]) (let ([ht (make-eq-hashtable)])
@ -439,6 +441,12 @@
(- (clause (x* ...) interface body)) (- (clause (x* ...) interface body))
(+ (clause (x* ...) mcp 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 ; move labels to top level and expands closures forms to more primitive operations
(define-language L7 (extends L6) (define-language L7 (extends L6)
(terminals (terminals
@ -446,7 +454,8 @@
(fixnum (interface))) (fixnum (interface)))
(+ (var (x)) (+ (var (x))
(primitive (prim)) ; moved up one language to support closure instrumentation (primitive (prim)) ; moved up one language to support closure instrumentation
(fixnum (interface offset)))) (fixnum (interface offset))
(mref-type (type))))
(entry Program) (entry Program)
(Program (prog) (Program (prog)
(+ (labels ([l* le*] ...) l) => (labels ([l* le*] ...) (l)))) (+ (labels ([l* le*] ...) l) => (labels ([l* le*] ...) (l))))
@ -454,7 +463,7 @@
(+ (fcallable info l) => (fcallable info l))) (+ (fcallable info l) => (fcallable info l)))
(Lvalue (lvalue) (Lvalue (lvalue)
(+ x (+ x
(mref e1 e2 imm))) (mref e1 e2 imm type)))
(Expr (e body) (Expr (e body)
(- x (- x
(fcallable info) (fcallable info)
@ -471,7 +480,9 @@
(set! lvalue e) (set! lvalue e)
; these two forms are added here so expand-inline handlers can expand into them ; these two forms are added here so expand-inline handlers can expand into them
(values info e* ...) (values info e* ...)
(goto l)))) (goto l)
; for floating-point unboxing during expand-line:
(unboxed-fp e))))
(define-record-type primitive (define-record-type primitive
(fields name type pure? (mutable handler)) (fields name type pure? (mutable handler))
@ -525,14 +536,8 @@
(declare-primitive c-simple-call effect #f) (declare-primitive c-simple-call effect #f)
(declare-primitive c-simple-return effect #f) (declare-primitive c-simple-return effect #f)
(declare-primitive deactivate-thread effect #f) ; threaded version only (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 fldl effect #f) ; x86
(declare-primitive flds 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-cc-counter effect #f)
(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)
@ -567,9 +572,9 @@
(declare-primitive >= pred #t) (declare-primitive >= pred #t)
(declare-primitive condition-code pred #t) (declare-primitive condition-code pred #t)
(declare-primitive eq? pred #t) (declare-primitive eq? pred #t)
(declare-primitive fl< pred #t) (declare-primitive fp< pred #t)
(declare-primitive fl<= pred #t) (declare-primitive fp<= pred #t)
(declare-primitive fl= pred #t) (declare-primitive fp= pred #t)
(declare-primitive lock! pred #f) (declare-primitive lock! pred #f)
(declare-primitive logtest pred #t) (declare-primitive logtest pred #t)
(declare-primitive log!test pred #t) (declare-primitive log!test pred #t)
@ -615,6 +620,19 @@
(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
(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? (define immediate?
(let ([low (- (bitwise-arithmetic-shift-left 1 (fx- (constant ptr-bits) 1)))] (let ([low (- (bitwise-arithmetic-shift-left 1 (fx- (constant ptr-bits) 1)))]
[high (- (bitwise-arithmetic-shift-left 1 (constant ptr-bits)) 1)]) [high (- (bitwise-arithmetic-shift-left 1 (constant ptr-bits)) 1)])
@ -652,7 +670,8 @@
(+ (hand-coded sym))) (+ (hand-coded sym)))
(Expr (e body) (Expr (e body)
(- (quote d) (- (quote d)
pr))) pr
(unboxed-fp e))))
; determine where we should be placing interrupt and overflow ; determine where we should be placing interrupt and overflow
(define-language L9.5 (extends L9) (define-language L9.5 (extends L9)
@ -683,8 +702,8 @@
(- (clause (x* ...) mcp interface body)) (- (clause (x* ...) mcp interface body))
(+ (clause (x* ...) (local* ...) mcp interface body))) (+ (clause (x* ...) (local* ...) mcp interface body)))
(Lvalue (lvalue) (Lvalue (lvalue)
(- (mref e1 e2 imm)) (- (mref e1 e2 imm type))
(+ (mref x1 x2 imm))) (+ (mref x1 x2 imm type)))
(Triv (t) (Triv (t)
(+ lvalue (+ lvalue
(literal info) => info (literal info) => info
@ -854,7 +873,8 @@
(label (l rpl)) (label (l rpl))
(source-object (src)) (source-object (src))
(symbol (sym)) (symbol (sym))
(boolean (as-fallthrough))) (boolean (as-fallthrough))
(mref-type (type)))
(Program (prog) (Program (prog)
(labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l))) (labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l)))
(CaseLambdaExpr (le) (CaseLambdaExpr (le)
@ -862,7 +882,7 @@
(hand-coded sym)) (hand-coded sym))
(Lvalue (lvalue) (Lvalue (lvalue)
x x
(mref x1 x2 imm)) (mref x1 x2 imm type))
(Triv (t) (Triv (t)
lvalue lvalue
(literal info) => info (literal info) => info
@ -985,7 +1005,8 @@
(return-label (mrvl)) (return-label (mrvl))
(boolean (error-on-values as-fallthrough)) (boolean (error-on-values as-fallthrough))
(fixnum (max-fv offset)) (fixnum (max-fv offset))
(block (block entry-block))) (block (block entry-block))
(mref-type (type)))
(Program (pgm) (Program (pgm)
(labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l))) (labels ([l* le*] ...) l) => (letrec ([l* le*] ...) (l)))
(CaseLambdaExpr (le) (CaseLambdaExpr (le)
@ -993,7 +1014,7 @@
(Dummy (dumdum) (dummy)) (Dummy (dumdum) (dummy))
(Lvalue (lvalue) (Lvalue (lvalue)
x x
(mref x1 x2 imm)) (mref x1 x2 imm type))
(Triv (t) (Triv (t)
lvalue lvalue
(literal info) => info (literal info) => info
@ -1049,14 +1070,21 @@
(lambda (x) (lambda (x)
(or (reg? x) (uvar? 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) (define-language L15c (extends L15b)
(terminals (terminals
(- (var (x var))) (- (var (x var)))
(+ (ur (x)))) (+ (ur (x))))
; NB: base and index are really either regs or (mref %sfp %zero imm) ; NB: base and index are really either regs or (mref %sfp %zero imm)
(Lvalue (lvalue) (Lvalue (lvalue)
(- (mref x1 x2 imm)) (- (mref x1 x2 imm type))
(+ (mref lvalue1 lvalue2 imm))) (+ (mref lvalue1 lvalue2 imm type)))
(Effect (e) (Effect (e)
(- (fp-offset live-info imm)))) (- (fp-offset live-info imm))))
@ -1068,8 +1096,8 @@
(+ (procedure (proc)) => $procedure-name)) (+ (procedure (proc)) => $procedure-name))
(entry Program) (entry Program)
(Lvalue (lvalue) (Lvalue (lvalue)
(- (mref lvalue1 lvalue2 imm)) (- (mref lvalue1 lvalue2 imm type))
(+ (mref x1 x2 imm))) (+ (mref x1 x2 imm type)))
(Rhs (rhs) (Rhs (rhs)
(- (inline info value-prim t* ...)) (- (inline info value-prim t* ...))
(+ (asm info proc t* ...) => (asm proc 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]) (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc])
(flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) (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 unboxed-arguments]) ; 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]) ; 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]) ; 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]) ; 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]) (flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flzero? [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]) (flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
@ -107,11 +107,11 @@
(flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) (flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op 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]) (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 unboxed-arguments])
(fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs]) (fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
(fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs]) (fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
(fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs]) (fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
(flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs]) (flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
(fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard]) (fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard])
(fldiv [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard]) (fldiv [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
(flmod [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]) (flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02])
(flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) (flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
(flnonnegative? [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 unboxed-arguments]) ; 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]) ; 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 (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 (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 (flush-output-port [sig [() (output-port) -> (void)]] [flags true]) ; not restricted to 1 argument
(foreign-entry? [sig [(string) -> (boolean)]] [flags discard]) (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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 5) (define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3) (define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int") (define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 5) (define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3) (define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int") (define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 5) (define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3) (define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int") (define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 5) (define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3) (define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long long int") (define-constant typedef-iptr "long long int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 5) (define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3) (define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int") (define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 5) (define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3) (define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int") (define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 5) (define-constant asm-arg-reg-max 5)
(define-constant asm-arg-reg-cnt 3) (define-constant asm-arg-reg-cnt 3)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "long int") (define-constant typedef-iptr "long int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 8)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned 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 max-integer-alignment 4)
(define-constant asm-arg-reg-max 1) (define-constant asm-arg-reg-max 1)
(define-constant asm-arg-reg-cnt 1) (define-constant asm-arg-reg-cnt 1)
(define-constant asm-fpreg-max 2)
(define-constant typedef-ptr "void *") (define-constant typedef-ptr "void *")
(define-constant typedef-iptr "int") (define-constant typedef-iptr "int")
(define-constant typedef-uptr "unsigned int") (define-constant typedef-uptr "unsigned int")

316
s/x86.ss
View File

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

358
s/x86_64.ss
View File

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