Fixing various bugs
parent
87e9fbb34c
commit
1b06ab1b39
|
@ -98,7 +98,7 @@ GENERIC: emit-node ( node -- next )
|
|||
: emit-call ( word -- next )
|
||||
{
|
||||
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
|
||||
{ [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
|
||||
{ [ tail-call? not ] [ ##call iterate-next ] }
|
||||
{ [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
|
||||
[ ##epilogue ##jump stop-iterating ]
|
||||
} cond ;
|
||||
|
|
|
@ -28,6 +28,8 @@ M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
|
|||
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: ##compare-imm-branch uses-vregs src1>> 1array ;
|
||||
M: ##dispatch uses-vregs src>> 1array ;
|
||||
M: ##alien-getter uses-vregs src>> 1array ;
|
||||
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
|
||||
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
|
||||
M: _compare-imm-branch uses-vregs src1>> 1array ;
|
||||
M: insn uses-vregs drop f ;
|
||||
|
|
|
@ -62,8 +62,8 @@ IN: compiler.cfg.hats
|
|||
: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
|
||||
: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
|
||||
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
|
||||
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
|
||||
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
|
||||
: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
|
||||
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
|
||||
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
|
||||
|
|
|
@ -55,7 +55,6 @@ TUPLE: stack-frame
|
|||
spill-counts ;
|
||||
|
||||
INSN: ##stack-frame stack-frame ;
|
||||
: ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
|
||||
INSN: ##call word ;
|
||||
INSN: ##jump word ;
|
||||
INSN: ##return ;
|
||||
|
@ -139,7 +138,7 @@ INSN: ##alien-double < ##alien-getter ;
|
|||
INSN: ##set-alien-integer-1 < ##alien-setter ;
|
||||
INSN: ##set-alien-integer-2 < ##alien-setter ;
|
||||
INSN: ##set-alien-integer-4 < ##alien-setter ;
|
||||
INSN: ##set-alien-cell < ##alien-getter ;
|
||||
INSN: ##set-alien-cell < ##alien-setter ;
|
||||
INSN: ##set-alien-float < ##alien-setter ;
|
||||
INSN: ##set-alien-double < ##alien-setter ;
|
||||
|
||||
|
|
|
@ -16,7 +16,6 @@ IN: compiler.cfg.intrinsics.alien
|
|||
: prepare-alien-accessor ( infos -- offset-vreg )
|
||||
<reversed> [ second class>> ] [ first ] bi
|
||||
dup value-info-small-tagged? [
|
||||
ds-drop
|
||||
literal>> (prepare-alien-accessor-imm)
|
||||
] [ drop (prepare-alien-accessor) ] if ;
|
||||
|
||||
|
|
|
@ -13,20 +13,24 @@ IN: compiler.cfg.intrinsics.allot
|
|||
: emit-simple-allot ( node -- )
|
||||
[ in-d>> length ] [ node-output-infos first class>> ] bi
|
||||
[ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
|
||||
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
|
||||
[ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi
|
||||
##gc ;
|
||||
|
||||
: tuple-slot-regs ( layout -- vregs )
|
||||
[ size>> ds-load ] [ ^^load-literal ] bi prefix ;
|
||||
|
||||
:: emit-<tuple-boa> ( node -- )
|
||||
[let | layout [ node node-input-infos peek literal>> ] |
|
||||
layout tuple-layout? [
|
||||
ds-drop
|
||||
layout tuple-slot-regs
|
||||
layout size>> ^^allot-tuple
|
||||
tuple ##set-slots
|
||||
] [ node emit-primitive ] if
|
||||
] ;
|
||||
: emit-<tuple-boa> ( node -- )
|
||||
dup node-input-infos peek literal>>
|
||||
dup tuple-layout? [
|
||||
nip
|
||||
ds-drop
|
||||
[ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
|
||||
[ tuple ##set-slots ] [ ds-push drop ] 2bi
|
||||
##gc
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: store-length ( len reg -- )
|
||||
[ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
|
||||
|
||||
: store-initial-element ( elt reg len -- )
|
||||
[ 2 + object tag-number ##set-slot-imm ] with with each ;
|
||||
|
@ -40,8 +44,10 @@ IN: compiler.cfg.intrinsics.allot
|
|||
[let | elt [ ds-pop ]
|
||||
reg [ len ^^allot-array ] |
|
||||
ds-drop
|
||||
len reg store-length
|
||||
elt reg len store-initial-element
|
||||
reg ds-push
|
||||
##gc
|
||||
]
|
||||
] [ node emit-primitive ] if
|
||||
] ;
|
||||
|
@ -57,8 +63,10 @@ IN: compiler.cfg.intrinsics.allot
|
|||
[let | elt [ 0 ^^load-literal ]
|
||||
reg [ len ^^allot-byte-array ] |
|
||||
ds-drop
|
||||
len reg store-length
|
||||
elt reg len bytes>cells store-initial-element
|
||||
reg ds-push
|
||||
##gc
|
||||
]
|
||||
] [ node emit-primitive ] if
|
||||
] ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
USING: sequences accessors layouts kernel math namespaces
|
||||
combinators fry locals
|
||||
compiler.tree.propagation.info
|
||||
compiler.cfg.stacks compiler.cfg.hats
|
||||
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
|
||||
compiler.cfg.intrinsics.utilities ;
|
||||
IN: compiler.cfg.intrinsics.fixnum
|
||||
|
||||
|
@ -60,4 +60,4 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
|
||||
|
||||
: emit-fixnum>bignum ( -- )
|
||||
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
|
||||
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ##gc ;
|
||||
|
|
|
@ -1,11 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel compiler.cfg.stacks compiler.cfg.hats ;
|
||||
USING: kernel compiler.cfg.stacks compiler.cfg.hats
|
||||
compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.intrinsics.float
|
||||
|
||||
: emit-float-op ( insn -- )
|
||||
[ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
|
||||
ds-push ; inline
|
||||
ds-push
|
||||
##gc ; inline
|
||||
|
||||
: emit-float-comparison ( cc -- )
|
||||
[ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
|
||||
|
@ -15,4 +17,4 @@ IN: compiler.cfg.intrinsics.float
|
|||
ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
|
||||
|
||||
: emit-fixnum>float ( -- )
|
||||
ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
|
||||
ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ##gc ;
|
||||
|
|
|
@ -45,7 +45,6 @@ IN: compiler.cfg.intrinsics.slots
|
|||
dup node-input-infos
|
||||
dup second value-tag [
|
||||
nip
|
||||
ds-drop
|
||||
[
|
||||
dup third value-info-small-tagged?
|
||||
[ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
|
||||
|
|
|
@ -8,4 +8,4 @@ IN: compiler.cfg.intrinsics.utilities
|
|||
literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
|
||||
|
||||
: emit-primitive ( node -- )
|
||||
word>> ##simple-stack-frame ##call ;
|
||||
word>> ##call ;
|
||||
|
|
|
@ -21,6 +21,12 @@ M: ##stack-frame compute-stack-frame*
|
|||
frame-required? on
|
||||
stack-frame>> stack-frame [ max-stack-frame ] change ;
|
||||
|
||||
M: ##gc compute-stack-frame*
|
||||
drop frame-required? on ;
|
||||
|
||||
M: ##call compute-stack-frame*
|
||||
drop frame-required? on ;
|
||||
|
||||
M: _spill compute-stack-frame*
|
||||
drop frame-required? on ;
|
||||
|
||||
|
|
|
@ -27,7 +27,7 @@ IN: compiler.tests
|
|||
|
||||
[ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
|
||||
[ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
|
||||
[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
|
||||
[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
|
||||
[ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
|
||||
[ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
|
||||
[ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
|
||||
|
@ -252,31 +252,34 @@ cell 8 = [
|
|||
! Some randomized tests
|
||||
: compiled-fixnum* fixnum* ;
|
||||
|
||||
: test-fixnum* ( -- )
|
||||
32 random-bits >fixnum 32 random-bits >fixnum
|
||||
2dup
|
||||
[ fixnum* ] 2keep compiled-fixnum* =
|
||||
[ 2drop ] [ "Oops" throw ] if ;
|
||||
|
||||
[ ] [ 10000 [ test-fixnum* ] times ] unit-test
|
||||
[ ] [
|
||||
10000 [
|
||||
32 random-bits >fixnum 32 random-bits >fixnum
|
||||
2dup
|
||||
[ fixnum* ] 2keep compiled-fixnum* =
|
||||
[ 2drop ] [ "Oops" throw ] if
|
||||
] times
|
||||
] unit-test
|
||||
|
||||
: compiled-fixnum>bignum fixnum>bignum ;
|
||||
|
||||
: test-fixnum>bignum ( -- )
|
||||
32 random-bits >fixnum
|
||||
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
|
||||
[ drop ] [ "Oops" throw ] if ;
|
||||
|
||||
[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
|
||||
[ ] [
|
||||
10000 [
|
||||
32 random-bits >fixnum
|
||||
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
|
||||
[ drop ] [ "Oops" throw ] if
|
||||
] times
|
||||
] unit-test
|
||||
|
||||
: compiled-bignum>fixnum bignum>fixnum ;
|
||||
|
||||
: test-bignum>fixnum ( -- )
|
||||
5 random [ drop 32 random-bits ] map product >bignum
|
||||
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
|
||||
[ drop ] [ "Oops" throw ] if ;
|
||||
|
||||
[ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
|
||||
[ ] [
|
||||
10000 [
|
||||
5 random [ drop 32 random-bits ] map product >bignum
|
||||
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
|
||||
[ drop ] [ "Oops" throw ] if
|
||||
] times
|
||||
] unit-test
|
||||
|
||||
! Test overflow check removal
|
||||
[ t ] [
|
||||
|
@ -377,25 +380,23 @@ cell 8 = [
|
|||
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
|
||||
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
|
||||
|
||||
: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ;
|
||||
|
||||
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
|
||||
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
|
||||
|
||||
[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
|
||||
[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
|
||||
[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
|
||||
[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
|
||||
|
||||
[ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
|
||||
[ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
|
||||
|
||||
[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
|
||||
[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
|
||||
[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
|
||||
[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
|
||||
|
||||
[ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
|
||||
[ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
|
||||
|
||||
[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
|
||||
[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
|
||||
[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
|
||||
[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
|
||||
|
||||
[ t ] [ pi pi <double> *double = ] unit-test
|
||||
|
||||
|
|
|
@ -221,7 +221,7 @@ M: x86.32 %alien-indirect ( -- )
|
|||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
4 [
|
||||
EAX %load-indirect
|
||||
EAX swap %load-indirect
|
||||
EAX PUSH
|
||||
"c_to_factor" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
|
|
@ -200,7 +200,8 @@ M: x86.64 %alien-indirect ( -- )
|
|||
RBP CALL ;
|
||||
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
RDI %load-indirect "c_to_factor" f %alien-invoke ;
|
||||
RDI swap %load-indirect
|
||||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
|
|
|
@ -96,7 +96,7 @@ M: x86 %add [+] LEA ;
|
|||
M: x86 %add-imm [+] LEA ;
|
||||
M: x86 %sub 2operand SUB ;
|
||||
M: x86 %sub-imm neg [+] LEA ;
|
||||
M: x86 %mul 2operand IMUL2 ;
|
||||
M: x86 %mul 2operand swap IMUL2 ;
|
||||
M: x86 %mul-imm 2operand IMUL2 ;
|
||||
M: x86 %and 2operand AND ;
|
||||
M: x86 %and-imm 2operand AND ;
|
||||
|
@ -146,7 +146,6 @@ M:: x86 %integer>bignum ( dst src temp -- )
|
|||
M:: x86 %bignum>integer ( dst src -- )
|
||||
[
|
||||
"nonzero" define-label
|
||||
"positive" define-label
|
||||
"end" define-label
|
||||
dst src 1 bignum@ MOV
|
||||
! if the length is 1, its just the sign and nothing else,
|
||||
|
@ -160,20 +159,27 @@ M:: x86 %bignum>integer ( dst src -- )
|
|||
dst src 3 bignum@ MOV
|
||||
! is the sign negative?
|
||||
src 2 bignum@ 0 CMP
|
||||
"positive" get JE
|
||||
dst -1 IMUL2
|
||||
"positive" resolve-label
|
||||
dst 3 SHL
|
||||
"end" get JE
|
||||
dst NEG
|
||||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: x86 %add-float 2operand ADDSD ;
|
||||
M: x86 %sub-float 2operand SUBSD ;
|
||||
M: x86 %mul-float 2operand MULSD ;
|
||||
M: x86 %div-float 2operand DIVSD ;
|
||||
: ?MOVSD ( dst src -- )
|
||||
2dup = [ 2drop ] [ MOVSD ] if ; inline
|
||||
|
||||
M: x86 %integer>float CVTTSD2SI ;
|
||||
M: x86 %float>integer CVTSI2SD ;
|
||||
: 1operand-fp ( dst src -- dst' )
|
||||
dupd ?MOVSD ; inline
|
||||
|
||||
: 2operand-fp ( dst src1 src2 -- dst src )
|
||||
[ 1operand-fp ] dip ; inline
|
||||
|
||||
M: x86 %add-float 2operand-fp ADDSD ;
|
||||
M: x86 %sub-float 2operand-fp SUBSD ;
|
||||
M: x86 %mul-float 2operand-fp MULSD ;
|
||||
M: x86 %div-float 2operand-fp DIVSD ;
|
||||
|
||||
M: x86 %integer>float CVTSI2SD ;
|
||||
M: x86 %float>integer CVTTSD2SI ;
|
||||
|
||||
M: x86 %copy ( dst src -- ) MOV ;
|
||||
|
||||
|
@ -210,7 +216,7 @@ M:: x86 %unbox-any-c-ptr ( dst src temp -- )
|
|||
|
||||
M:: x86 %box-float ( dst src temp -- )
|
||||
dst 16 float temp %allot
|
||||
dst 8 float tag-number - [+] src MOVSD ;
|
||||
dst float-offset [+] src MOVSD ;
|
||||
|
||||
: alien@ ( reg n -- op ) cells object tag-number - [+] ;
|
||||
|
||||
|
@ -291,21 +297,23 @@ M:: x86 %box-alien ( dst src temp -- )
|
|||
#! call the quot with that. Otherwise, we find a small
|
||||
#! register that is not equal to src, and call quot, saving
|
||||
#! and restoring the small register.
|
||||
dst small-regs memq? [ dst src quot call ] [
|
||||
dst small-reg-4 small-regs memq? [ dst src quot call ] [
|
||||
src small-reg-that-isn't
|
||||
[ src quot call ]
|
||||
with-save/restore
|
||||
[| new-dst |
|
||||
new-dst src quot call
|
||||
dst new-dst MOV
|
||||
] with-save/restore
|
||||
] if ; inline
|
||||
|
||||
: %alien-integer-getter ( dst src size quot -- )
|
||||
'[ [ _ small-reg ] dip @ ] with-small-register ; inline
|
||||
'[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
|
||||
with-small-register ; inline
|
||||
|
||||
: %alien-unsigned-getter ( dst src size -- )
|
||||
[ MOVZX ] %alien-integer-getter ; inline
|
||||
|
||||
M: x86 %alien-unsigned-1 1 %alien-unsigned-getter ;
|
||||
M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
|
||||
M: x86 %alien-unsigned-4 4 %alien-unsigned-getter ;
|
||||
|
||||
: %alien-signed-getter ( dst src size -- )
|
||||
[ MOVSX ] %alien-integer-getter ; inline
|
||||
|
@ -314,6 +322,8 @@ M: x86 %alien-signed-1 1 %alien-signed-getter ;
|
|||
M: x86 %alien-signed-2 2 %alien-signed-getter ;
|
||||
M: x86 %alien-signed-4 4 %alien-signed-getter ;
|
||||
|
||||
M: x86 %alien-unsigned-4 4 [ 2drop ] %alien-integer-getter ;
|
||||
|
||||
M: x86 %alien-cell [] MOV ;
|
||||
M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
|
||||
M: x86 %alien-double [] MOVSD ;
|
||||
|
|
Loading…
Reference in New Issue