should fix in 0.82:
- clean up/rewrite register allocation
+- moving between int and float vregs
+- intrinsic fixnum>float float>fixnum
- amd64 %box-struct
- when generating a 32-bit image on a 64-bit system, large numbers which should
end-basic-block
<label> dup %jump-t
] H{
- { +input { { 0 "flag" } } }
+ { +input { { f "flag" } } }
} with-template generate-if ;
! #call
save-xt
t 0 <int-vreg> load-literal
"end" get save-xt
- 0 <int-vreg> phantom-d get phantom-push ;
+ 0 <int-vreg> phantom-d get phantom-push
+ compute-free-vregs ;
: do-if-intrinsic ( node -- next )
[ <label> dup ] keep if-intrinsic call
UNION: immediate fixnum POSTPONE: f ;
: generate-push ( node -- )
- >#push< dup literal-template
- dup requested-vregs ensure-vregs
- alloc-vregs [ [ load-literal ] 2each ] keep
- phantom-d get phantom-append ;
+ [
+ >#push< dup literal-template
+ dup requested-vregs ensure-vregs
+ alloc-vregs [ [ load-literal ] 2each ] keep
+ phantom-d get phantom-append
+ ] with-scope ;
M: #push generate-node ( #push -- )
generate-push iterate-next ;
{ { -1 @ } [ nip 0 swap - ] }
} define-identities
-[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] {
+[ / fixnum/i fixnum/f bignum/i bignum/f float/f ] {
{ { @ 1 } [ drop ] }
{ { @ -1 } [ drop 0 swap - ] }
} define-identities
{ { @ @ } [ 2drop t ] }
} define-identities
-[ eq? number= = ] {
+[ eq? bignum= float= number= = ] {
{ { @ @ } [ 2drop t ] }
} define-identities
M: callable CALL 0 CALL relative-4 ;
M: operand CALL BIN: 010 t HEX: ff 1-operand ;
-GENERIC: JUMPcc ( opcode addr -- )
-M: integer JUMPcc ( opcode addr -- )
- HEX: 0f assemble-1 swap assemble-1 from assemble-4 ;
-M: callable JUMPcc ( opcode addr -- )
- >r 0 JUMPcc r> relative-4 ;
-
-: JO HEX: 80 swap JUMPcc ;
-: JNO HEX: 81 swap JUMPcc ;
-: JB HEX: 82 swap JUMPcc ;
-: JAE HEX: 83 swap JUMPcc ;
-: JE HEX: 84 swap JUMPcc ; ! aka JZ
-: JNE HEX: 85 swap JUMPcc ;
-: JBE HEX: 86 swap JUMPcc ;
-: JA HEX: 87 swap JUMPcc ;
-: JS HEX: 88 swap JUMPcc ;
-: JNS HEX: 89 swap JUMPcc ;
-: JP HEX: 8a swap JUMPcc ;
-: JNP HEX: 8b swap JUMPcc ;
-: JL HEX: 8c swap JUMPcc ;
-: JGE HEX: 8d swap JUMPcc ;
-: JLE HEX: 8e swap JUMPcc ;
-: JG HEX: 8f swap JUMPcc ;
+G: JUMPcc ( addr opcode -- ) 1 standard-combination ;
+M: integer JUMPcc ( addr opcode -- )
+ swap HEX: 0f assemble-1 swap assemble-1 from assemble-4 ;
+M: callable JUMPcc ( addr opcode -- )
+ swap >r 0 swap JUMPcc r> relative-4 ;
+
+: JO HEX: 80 JUMPcc ;
+: JNO HEX: 81 JUMPcc ;
+: JB HEX: 82 JUMPcc ;
+: JAE HEX: 83 JUMPcc ;
+: JE HEX: 84 JUMPcc ; ! aka JZ
+: JNE HEX: 85 JUMPcc ;
+: JBE HEX: 86 JUMPcc ;
+: JA HEX: 87 JUMPcc ;
+: JS HEX: 88 JUMPcc ;
+: JNS HEX: 89 JUMPcc ;
+: JP HEX: 8a JUMPcc ;
+: JNP HEX: 8b JUMPcc ;
+: JL HEX: 8c JUMPcc ;
+: JGE HEX: 8d JUMPcc ;
+: JLE HEX: 8e JUMPcc ;
+: JG HEX: 8f JUMPcc ;
: RET ( -- ) HEX: c3 assemble-1 ;
} define-if-intrinsic ;
{
- { float< JL }
- { float<= JLE }
- { float> JG }
- { float>= JGE }
+ { float< JB }
+ { float<= JBE }
+ { float> JA }
+ { float>= JAE }
{ float= JE }
} [
first2 define-float-jump
IN: math-internals
USING: math kernel ;
-: float= ( n n -- )
+: float= ( n n -- ? )
#! The compiler replaces this with a better intrinsic.
- [ double>bits ] 2apply number= ;
+ [ double>bits ] 2apply number= ; foldable
IN: math
: fp-nan? ( float -- ? )
double>bits -51 shift BIN: 111111111111 [ bitand ] keep = ;
-M: float zero? ( float -- ? ) dup 0.0 = swap -0.0 = or ;
+M: float zero? ( float -- ? )
+ dup 0.0 float= swap -0.0 float= or ;
M: float < float< ;
M: float <= float<= ;
[ 2.0 ] [ 1.0 [ 2.0 swap float/f ] compile-1 ] unit-test
[ 0.5 ] [ 1.0 2.0 [ float/f ] compile-1 ] unit-test
[ 2.0 ] [ 1.0 2.0 [ swap float/f ] compile-1 ] unit-test
+
+[ t ] [ 1.0 2.0 [ float< ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float< ] compile-1 ] unit-test
+[ f ] [ 1.0 1.0 [ float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 float< ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 swap float< ] compile-1 ] unit-test
+[ f ] [ 3.0 1.0 [ float< ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 float< ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 swap float< ] compile-1 ] unit-test
+
+[ t ] [ 1.0 2.0 [ float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 float<= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float<= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float<= ] compile-1 ] unit-test
+[ f ] [ 3.0 1.0 [ float<= ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 float<= ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 swap float<= ] compile-1 ] unit-test
+
+[ f ] [ 1.0 2.0 [ float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float> ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 swap float> ] compile-1 ] unit-test
+[ f ] [ 1.0 1.0 [ float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 float> ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 1.0 swap float> ] compile-1 ] unit-test
+[ t ] [ 3.0 1.0 [ float> ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 float> ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 swap float> ] compile-1 ] unit-test
+
+[ f ] [ 1.0 2.0 [ float>= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 2.0 swap float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float>= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float>= ] compile-1 ] unit-test
+[ t ] [ 3.0 1.0 [ float>= ] compile-1 ] unit-test
+[ t ] [ 3.0 [ 1.0 float>= ] compile-1 ] unit-test
+[ f ] [ 3.0 [ 1.0 swap float>= ] compile-1 ] unit-test
+
+[ f ] [ 1.0 2.0 [ float= ] compile-1 ] unit-test
+[ t ] [ 1.0 1.0 [ float= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 float= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 float= ] compile-1 ] unit-test
+[ f ] [ 1.0 [ 2.0 swap float= ] compile-1 ] unit-test
+[ t ] [ 1.0 [ 1.0 swap float= ] compile-1 ] unit-test
+
+[ t ] [ 0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
+[ t ] [ -0.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
+[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-1 ] unit-test
IN: temporary
-USING: compiler kernel math test vectors ;
+USING: compiler kernel kernel-internals math test vectors ;
[ 5 ] [ 5 [ 0 + ] compile-1 ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-1 ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test
-[ 5 ] [ 5 [ 1 ^ ] compile-1 ] unit-test
-[ 25 ] [ 5 [ 2 ^ ] compile-1 ] unit-test
-[ 1/5 ] [ 5 [ -1 ^ ] compile-1 ] unit-test
-[ 1/25 ] [ 5 [ -2 ^ ] compile-1 ] unit-test
-[ 1 ] [ 5 [ 1 swap ^ ] compile-1 ] unit-test
-
[ 5 ] [ 5 [ -1 bitand ] compile-1 ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-1 ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-1 ] unit-test
[ t ] [ 5 [ dup = ] compile-1 ] unit-test
[ t ] [ 5 [ dup number= ] compile-1 ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test
+
+[ 3 ] [ 10/3 [ { ratio } declare 1 /i ] compile-1 ] unit-test