steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixing various bugs

db4
Slava Pestov 2008-10-21 23:17:32 -05:00
parent 87e9fbb34c
commit 1b06ab1b39
15 changed files with 98 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/builder/builder.factor
View File

@ -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 ;

2
basis/compiler/cfg/def-use/def-use.factor
View File

@ -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 ;

4
basis/compiler/cfg/hats/hats.factor
View File

@ -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

3
basis/compiler/cfg/instructions/instructions.factor
View File

@ -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 ;

1
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -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 ;

28
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -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
] ;

4
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -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 ;

8
basis/compiler/cfg/intrinsics/float/float.factor
View File

@ -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 ;

1
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -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

2
basis/compiler/cfg/intrinsics/utilities/utilities.factor
View File

@ -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 ;

6
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -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 ;

57
basis/compiler/tests/intrinsics.factor
View File

@ -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

2
basis/cpu/x86/32/32.factor
View File

@ -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 ;

3
basis/cpu/x86/64/64.factor
View File

@ -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

46
basis/cpu/x86/architecture/architecture.factor
View File

@ -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 ;