From 1b06ab1b39207b50f9f30cb55bb47c491da58578 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Oct 2008 23:17:32 -0500 Subject: [PATCH] Fixing various bugs --- basis/compiler/cfg/builder/builder.factor | 2 +- basis/compiler/cfg/def-use/def-use.factor | 2 + basis/compiler/cfg/hats/hats.factor | 4 +- .../cfg/instructions/instructions.factor | 3 +- .../cfg/intrinsics/alien/alien.factor | 1 - .../cfg/intrinsics/allot/allot.factor | 28 +++++---- .../cfg/intrinsics/fixnum/fixnum.factor | 4 +- .../cfg/intrinsics/float/float.factor | 8 ++- .../cfg/intrinsics/slots/slots.factor | 1 - .../cfg/intrinsics/utilities/utilities.factor | 2 +- .../cfg/stack-frame/stack-frame.factor | 6 ++ basis/compiler/tests/intrinsics.factor | 57 ++++++++++--------- basis/cpu/x86/32/32.factor | 2 +- basis/cpu/x86/64/64.factor | 3 +- .../cpu/x86/architecture/architecture.factor | 46 +++++++++------ 15 files changed, 98 insertions(+), 71 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 7247534b91..28b46e4d19 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -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 ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 37b050eda6..7e3167ea60 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -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 ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 705aa02701..1c6480048c 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -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 diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 17b9728243..c29b723c6e 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 ; diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 087c759384..e49a00ae6f 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -16,7 +16,6 @@ IN: compiler.cfg.intrinsics.alien : prepare-alien-accessor ( infos -- offset-vreg ) [ second class>> ] [ first ] bi dup value-info-small-tagged? [ - ds-drop literal>> (prepare-alien-accessor-imm) ] [ drop (prepare-alien-accessor) ] if ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 3c81367cfc..bcd5e713a9 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -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- ( 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- ( 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 ] ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index a6e8bf28e7..602a482528 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -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 ; diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index c8bd326475..3d7ec5f433 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -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 ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 7817d59770..0b34ec6405 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -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 diff --git a/basis/compiler/cfg/intrinsics/utilities/utilities.factor b/basis/compiler/cfg/intrinsics/utilities/utilities.factor index cd10b4e54e..bc6442886c 100644 --- a/basis/compiler/cfg/intrinsics/utilities/utilities.factor +++ b/basis/compiler/cfg/intrinsics/utilities/utilities.factor @@ -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 ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 4443ea64f7..a1e006872b 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -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 ; diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 530705af46..e012a42cc0 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -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 [ { byte-array } declare *char ] compile-call ] unit-test [ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test -[ -100 ] [ -100 \ xword-def compile-call *char ] unit-test -[ 156 ] [ -100 \ xword-def compile-call *uchar ] unit-test +[ -100 ] [ -100 \ def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test +[ 156 ] [ -100 \ def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test [ -1000 ] [ -1000 [ { byte-array } declare *short ] compile-call ] unit-test [ 64536 ] [ -1000 [ { byte-array } declare *ushort ] compile-call ] unit-test -[ -1000 ] [ -1000 \ xword-def compile-call *short ] unit-test -[ 64536 ] [ -1000 \ xword-def compile-call *ushort ] unit-test +[ -1000 ] [ -1000 \ def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test +[ 64536 ] [ -1000 \ def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test [ -100000 ] [ -100000 [ { byte-array } declare *int ] compile-call ] unit-test [ 4294867296 ] [ -100000 [ { byte-array } declare *uint ] compile-call ] unit-test -[ -100000 ] [ -100000 \ xword-def compile-call *int ] unit-test -[ 4294867296 ] [ -100000 \ xword-def compile-call *uint ] unit-test +[ -100000 ] [ -100000 \ def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test +[ 4294867296 ] [ -100000 \ def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test [ t ] [ pi pi *double = ] unit-test diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index fe1f5e5a38..1c597ac98a 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -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 ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 1e5922122e..3b0403a07e 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -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 diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 9c738d3d34..65067740d9 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -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 ;