Fixing various bugs

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 ;

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 ;

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-float ( src -- dst ) ^^d1 ##alien-float ; inline
-: ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; 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

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 ;
 

basis/compiler/cfg/intrinsics/alien/alien.factor

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

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-<tuple-boa> ( node -- )
+: emit-<tuple-boa> ( node -- )
-    [let | layout [ node node-input-infos peek literal>> ] |
+    dup node-input-infos peek literal>>
-        layout tuple-layout? [
+    dup tuple-layout? [
+        nip
         ds-drop
-            layout tuple-slot-regs
+        [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
-            layout size>> ^^allot-tuple
+        [ tuple ##set-slots ] [ ds-push drop ] 2bi
-            tuple ##set-slots
+        ##gc
-        ] [ node emit-primitive ] if
+    ] [ 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
     ] ;

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 ;

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  ;

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

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 ;

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 ;
 

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* ( -- )
+[ ] [
+    10000 [ 
         32 random-bits >fixnum 32 random-bits >fixnum
         2dup
         [ fixnum* ] 2keep compiled-fixnum* =
-    [ 2drop ] [ "Oops" throw ] if ;
+        [ 2drop ] [ "Oops" throw ] if
-
+    ] times
-[ ] [ 10000 [ test-fixnum* ] times ] unit-test
+] unit-test
 
 : compiled-fixnum>bignum fixnum>bignum ;
 
-: test-fixnum>bignum ( -- )
+[ ] [
+    10000 [
         32 random-bits >fixnum
         dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
-    [ drop ] [ "Oops" throw ] if ;
+        [ drop ] [ "Oops" throw ] if
-
+    ] times
-[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
+] unit-test
 
 : compiled-bignum>fixnum bignum>fixnum ;
 
-: test-bignum>fixnum ( -- )
+[ ] [
+    10000 [
         5 random [ drop 32 random-bits ] map product >bignum
         dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
-    [ drop ] [ "Oops" throw ] if ;
+        [ drop ] [ "Oops" throw ] if
-
+    ] times
-[ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
+] 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
+[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
-[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] 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
+[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
-[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] 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
+[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
-[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
+[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
 
 [ t ] [ pi pi <double> *double = ] unit-test
 

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 ;

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

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
+        "end" get JE
-        dst -1 IMUL2
+        dst NEG
-        "positive" resolve-label
-        dst 3 SHL
         "end" resolve-label
     ] with-scope ;
 
-M: x86 %add-float 2operand ADDSD ;
+: ?MOVSD ( dst src -- )
-M: x86 %sub-float 2operand SUBSD ;
+    2dup = [ 2drop ] [ MOVSD ] if ; inline
-M: x86 %mul-float 2operand MULSD ;
-M: x86 %div-float 2operand DIVSD ;
 
-M: x86 %integer>float CVTTSD2SI ;
+: 1operand-fp ( dst src -- dst' )
-M: x86 %float>integer CVTSI2SD ;
+    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 ]
+        [| new-dst |
-        with-save/restore
+            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 ;