Working on comparison operations, clearing out remaining dead wood

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index bee7884e81dc07aa178afa05b3e38ab4833d4e7e..7247534b91edcf5678b1b2666eef90ee55f497a8 100755 (executable)
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -65,14 +65,12 @@ GENERIC: emit-node ( node -- next )
     basic-block get [ drop f ] unless ; inline
 
 : emit-nodes ( nodes -- )
-    [ current-node emit-node check-basic-block ] iterate-nodes
-    finalize-phantoms ;
+    [ current-node emit-node check-basic-block ] iterate-nodes ;
 
 : begin-word ( -- )
     #! We store the basic block after the prologue as a loop
     #! labelled by the current word, so that self-recursive
     #! calls can skip an epilogue/prologue.
-    init-phantoms
     ##prologue
     ##branch
     begin-basic-block
@@ -98,7 +96,6 @@ GENERIC: emit-node ( node -- next )
     stop-iterating ;
 
 : emit-call ( word -- next )
-    finalize-phantoms
     {
         { [ dup loops get key? ] [ loops get at local-recursive-call ] }
         { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
@@ -115,7 +112,6 @@ GENERIC: emit-node ( node -- next )
     basic-block get swap loops get set-at ;
 
 : compile-loop ( node -- next )
-    finalize-phantoms
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
     iterate-next ;
@@ -126,7 +122,7 @@ M: #recursive emit-node
 ! #if
 : emit-branch ( obj -- final-bb )
     [
-        begin-basic-block copy-phantoms
+        begin-basic-block
         emit-nodes
         basic-block get dup [ ##branch ] when
     ] with-scope ;
@@ -135,21 +131,19 @@ M: #recursive emit-node
     children>>  [ emit-branch ] map
     end-basic-block
     begin-basic-block
-    basic-block get '[ [ _ swap successors>> push ] when* ] each
-    init-phantoms ;
+    basic-block get '[ [ _ swap successors>> push ] when* ] each ;
 
 : ##branch-t ( vreg -- )
     \ f tag-number cc/= ##compare-imm-branch ;
 
 M: #if emit-node
-    phantom-pop ##branch-t emit-if iterate-next ;
+    ds-pop ##branch-t emit-if iterate-next ;
 
 ! #dispatch
 : dispatch-branch ( nodes word -- label )
     gensym [
         [
             V{ } clone node-stack set
-            init-phantoms
             ##prologue
             emit-nodes
             basic-block get [
@@ -167,11 +161,9 @@ M: #if emit-node
     ] each ;
 
 : emit-dispatch ( node -- )
-    phantom-pop int-regs next-vreg
-    [ finalize-phantoms ##epilogue ] 2dip
-    [ ^^offset>slot ] dip
-    ##dispatch
-    dispatch-branches init-phantoms ;
+    ##epilogue
+    ds-pop ^^offset>slot i ##dispatch
+    dispatch-branches ;
 
 : <dispatch-block> ( -- word )
     gensym dup t "inlined-block" set-word-prop ;
@@ -198,34 +190,36 @@ M: #call-recursive emit-node label>> id>> emit-call ;
 
 ! #push
 M: #push emit-node
-    literal>> ^^load-literal phantom-push iterate-next ;
+    literal>> ^^load-literal ds-push iterate-next ;
 
 ! #shuffle
+: emit-shuffle ( effect -- )
+    [ out>> ] [ in>> dup length ds-load zip ] bi
+    '[ _ at ] map ds-store ;
+
 M: #shuffle emit-node
-    shuffle-effect phantom-shuffle iterate-next ;
+    shuffle-effect emit-shuffle iterate-next ;
 
 M: #>r emit-node
     [ in-d>> length ] [ out-r>> empty? ] bi
-    [ phantom-drop ] [ phantom->r ] if
+    [ neg ##inc-d ] [ ds-load rs-store ] if
     iterate-next ;
 
 M: #r> emit-node
     [ in-r>> length ] [ out-d>> empty? ] bi
-    [ phantom-rdrop ] [ phantom-r> ] if
+    [ neg ##inc-r ] [ rs-load ds-store ] if
     iterate-next ;
 
 ! #return
 M: #return emit-node
-    drop finalize-phantoms ##epilogue ##return stop-iterating ;
+    drop ##epilogue ##return stop-iterating ;
 
 M: #return-recursive emit-node
-    finalize-phantoms
     label>> id>> loops get key?
     [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
 
 ! #terminate
-M: #terminate emit-node
-    drop finalize-phantoms stop-iterating ;
+M: #terminate emit-node drop stop-iterating ;
 
 ! FFI
 : return-size ( ctype -- n )
@@ -246,7 +240,6 @@ M: #terminate emit-node
     <alien-stack-frame> ##stack-frame ;
 
 : emit-alien-node ( node quot -- next )
-    finalize-phantoms
     [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
     iterate-next ; inline
 
@@ -259,7 +252,6 @@ M: #alien-indirect emit-node
 M: #alien-callback emit-node
     dup params>> xt>> dup
     [
-        init-phantoms
         ##prologue
         dup [ ##alien-callback ] emit-alien-node drop
         ##epilogue

diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index fea51ab2a53bf357846d85171f652199e456184b..37b050eda66c899841265dd661dd5e3db48d852b 100644 (file)
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -13,6 +13,8 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
 M: ##unary/temp defs-vregs dst/tmp-vregs ;
 M: ##allot defs-vregs dst/tmp-vregs ;
 M: ##dispatch defs-vregs temp>> 1array ;
+M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: ##set-slot defs-vregs temp>> 1array ;
 M: insn defs-vregs drop f ;
 
 M: ##unary uses-vregs src>> 1array ;

diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 77b10b5e9fff8da9d63e995ecbbf24cb181d6e64..705aa027019b58a223f09397e95cb313c86a0690 100644 (file)
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -5,13 +5,6 @@ sequences classes.tuple cpu.architecture compiler.cfg.registers
 compiler.cfg.instructions ;
 IN: compiler.cfg.hats
 
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
-: fresh-object ( vreg/t -- ) fresh-objects get push ;
-: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
-
 : i int-regs next-vreg ; inline
 : ^^i i dup ; inline
 : ^^i1 [ ^^i ] dip ; inline
@@ -53,11 +46,10 @@ SYMBOL: fresh-objects
 : ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
 : ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
 : ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
-: ^^allot ( size class -- dst ) ^^i2 i ##allot dup fresh-object ; inline
+: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
 : ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
 : ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
 : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^write-barrier ( src -- ) dup fresh-object? [ drop ] [ i i ##write-barrier ] if ; inline
 : ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
 : ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
 : ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
@@ -72,9 +64,9 @@ SYMBOL: fresh-objects
 : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
 : ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
 : ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
-: ^^compare ( src1 src2 -- dst ) ^^i2 ##compare ; inline
-: ^^compare-imm ( src1 src2 -- dst ) ^^i2 ##compare-imm ; inline
-: ^^compare-float ( src1 src2 -- dst ) ^^i2 ##compare-float ; 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
 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline

diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index 9ab013f04b5cdea82c3791c413ed1e45d26659bc..087c7593840c273b3540496ca0e4635c1ee09ca1 100644 (file)
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -8,15 +8,15 @@ compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.alien
 
 : (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
-    1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
+    ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
 
 : (prepare-alien-accessor) ( class -- offset-vreg )
-    [ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+    [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
 
 : prepare-alien-accessor ( infos -- offset-vreg )
     <reversed> [ second class>> ] [ first ] bi
     dup value-info-small-tagged? [
-        1 phantom-drop
+        ds-drop
         literal>> (prepare-alien-accessor-imm)
     ] [ drop (prepare-alien-accessor) ] if ;
 
@@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.alien
     bi and ;
 
 : inline-alien-getter ( node quot -- )
-    '[ @ phantom-push ]
+    '[ @ ds-push ]
     [ inline-alien-getter? ] inline-alien ; inline
 
 : inline-alien-setter? ( infos class -- ? )
@@ -44,18 +44,18 @@ IN: compiler.cfg.intrinsics.alien
     tri and and ;
 
 : inline-alien-integer-setter ( node quot -- )
-    '[ phantom-pop ^^untag-fixnum @ ]
+    '[ ds-pop ^^untag-fixnum @ ]
     [ fixnum inline-alien-setter? ]
     inline-alien ; inline
 
 : inline-alien-cell-setter ( node quot -- )
     [ dup node-input-infos first class>> ] dip
-    '[ phantom-pop _ ^^unbox-c-ptr @ ]
+    '[ ds-pop _ ^^unbox-c-ptr @ ]
     [ pinned-c-ptr inline-alien-setter? ]
     inline-alien ; inline
 
 : inline-alien-float-setter ( node quot -- )
-    '[ phantom-pop ^^unbox-float @ ]
+    '[ ds-pop ^^unbox-float @ ]
     [ float inline-alien-setter? ]
     inline-alien ; inline
 

diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index a371f071cc7e801ffd3f20ab88bbdfaa909b871e..3c81367cfce722d6b3ce16dd657960697a865a36 100644 (file)
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -3,7 +3,8 @@
 USING: kernel math math.order sequences accessors arrays
 byte-arrays layouts classes.tuple.private fry locals
 compiler.tree.propagation.info compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.stacks ;
+compiler.cfg.instructions compiler.cfg.stacks
+compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.allot
 
 : ##set-slots ( regs obj class -- )
@@ -11,16 +12,16 @@ IN: compiler.cfg.intrinsics.allot
 
 : emit-simple-allot ( node -- )
     [ in-d>> length ] [ node-output-infos first class>> ] bi
-    [ drop phantom-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
-    [ ##set-slots ] [ [ drop ] [ phantom-push ] [ drop ] tri* ] 3bi ;
+    [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
+    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
 
 : tuple-slot-regs ( layout -- vregs )
-    [ size>> phantom-load ] [ ^^load-literal ] bi prefix ;
+    [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
 
 :: emit-<tuple-boa> ( node -- )
     [let | layout [ node node-input-infos peek literal>> ] |
         layout tuple-layout? [
-            1 phantom-drop
+            ds-drop
             layout tuple-slot-regs
             layout size>> ^^allot-tuple
             tuple ##set-slots
@@ -36,11 +37,11 @@ IN: compiler.cfg.intrinsics.allot
 :: emit-<array> ( node -- )
     [let | len [ node node-input-infos first literal>> ] |
         len expand-<array>? [
-            [let | elt [ phantom-pop ]
+            [let | elt [ ds-pop ]
                    reg [ len ^^allot-array ] |
-                1 phantom-drop
+                ds-drop
                 elt reg len store-initial-element
-                reg phantom-push
+                reg ds-push
             ]
         ] [ node emit-primitive ] if
     ] ;
@@ -55,9 +56,9 @@ IN: compiler.cfg.intrinsics.allot
         len expand-<byte-array>? [
             [let | elt [ 0 ^^load-literal ]
                    reg [ len ^^allot-byte-array ] |
-                1 phantom-drop
+                ds-drop
                 elt reg len bytes>cells store-initial-element
-                reg phantom-push
+                reg ds-push
             ]
         ] [ node emit-primitive ] if
     ] ;

diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 7791edb727bcbb82743af774959313ace1d11c0e..a6e8bf28e72dda024c0f55a10335e935909fc1ec 100644 (file)
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -8,12 +8,12 @@ compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : (emit-fixnum-imm-op) ( infos insn -- dst )
-    1 phantom-drop
-    [ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri*
+    ds-drop
+    [ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
     call ; inline
 
 : (emit-fixnum-op) ( insn -- dst )
-    [ 2phantom-pop ] dip call ; inline
+    [ 2inputs ] dip call ; inline
 
 :: emit-fixnum-op ( node insn imm-insn -- )
     [let | infos [ node node-input-infos ] |
@@ -21,43 +21,43 @@ IN: compiler.cfg.intrinsics.fixnum
         [ infos imm-insn (emit-fixnum-imm-op) ]
         [ insn (emit-fixnum-op) ]
         if
-        phantom-push
+        ds-push
     ] ; inline
 
 : emit-fixnum-shift-fast ( node -- )
     dup node-input-infos dup second value-info-small-tagged? [
         nip
-        [ 1 phantom-drop phantom-pop ] dip
+        [ ds-drop ds-pop ] dip
         second literal>> dup sgn {
             { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
             {  0 [ drop ] }
             {  1 [ ^^shl-imm ] }
         } case
-        phantom-push
+        ds-push
     ] [ drop emit-primitive ] if ;
 
 : emit-fixnum-bitnot ( -- )
-    phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ;
+    ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
 
 : (emit-fixnum*fast) ( -- dst )
-    2phantom-pop ^^untag-fixnum ^^mul ;
+    2inputs ^^untag-fixnum ^^mul ;
 
 : (emit-fixnum*fast-imm) ( infos -- dst )
-    1 phantom-drop
-    [ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ;
+    ds-drop
+    [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
 
 : emit-fixnum*fast ( node -- )
     node-input-infos
     dup second value-info-small-tagged?
     [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
-    phantom-push ;
+    ds-push ;
 
 : emit-fixnum-comparison ( node cc -- )
     [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
     emit-fixnum-op ;
 
 : emit-bignum>fixnum ( -- )
-    phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ;
+    ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>bignum ( -- )
-    phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
+    ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;

diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
index 24bb56d237a4f74d41f6552d73ed2cacf1bcc2d3..c8bd3264754e0d38bfa9989022933dee92ffb1b3 100644 (file)
--- a/basis/compiler/cfg/intrinsics/float/float.factor
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -4,15 +4,15 @@ USING: kernel compiler.cfg.stacks compiler.cfg.hats ;
 IN: compiler.cfg.intrinsics.float
 
 : emit-float-op ( insn -- )
-    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float
-    phantom-push ; inline
+    [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
+    ds-push ; inline
 
 : emit-float-comparison ( cc -- )
-    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float
-    phantom-push ; inline
+    [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
+    ds-push ; inline
 
 : emit-float>fixnum ( -- )
-    phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
+    ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>float ( -- )
-    phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ;
+    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;

diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index d2e2e95d0d2fa302379147ed5d82c4842d2b9861..7817d597708b27f7c9edd617015527a5f7fbb880 100644 (file)
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -7,17 +7,17 @@ compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.slots
 
 : emit-tag ( -- )
-    phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
+    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
 
 : value-tag ( info -- n ) class>> class-tag ; inline
 
 : (emit-slot) ( infos -- dst )
-    [ 2phantom-pop ] [ first value-tag ] bi*
+    [ 2inputs ] [ first value-tag ] bi*
     ^^slot ;
 
 : (emit-slot-imm) ( infos -- dst )
-    1 phantom-drop
-    [ phantom-pop ^^offset>slot ]
+    ds-drop
+    [ ds-pop ^^offset>slot ]
     [ [ second literal>> ] [ first value-tag ] bi ] bi*
     ^^slot-imm ;
 
@@ -27,17 +27,17 @@ IN: compiler.cfg.intrinsics.slots
         nip
         dup second value-info-small-tagged?
         [ (emit-slot-imm) ] [ (emit-slot) ] if
-        phantom-push
+        ds-push
     ] [ drop emit-primitive ] if ;
 
 : (emit-set-slot) ( infos -- obj-reg )
-    [ 3phantom-pop [ tuck ] dip ^^offset>slot ]
+    [ 3inputs [ tuck ] dip ^^offset>slot ]
     [ second value-tag ]
     bi* ^^set-slot ;
 
 : (emit-set-slot-imm) ( infos -- obj-reg )
-    1 phantom-drop
-    [ 2phantom-pop tuck ]
+    ds-drop
+    [ 2inputs tuck ]
     [ [ third literal>> ] [ second value-tag ] bi ] bi*
     ##set-slot-imm ;
 
@@ -45,10 +45,10 @@ IN: compiler.cfg.intrinsics.slots
     dup node-input-infos
     dup second value-tag [
         nip
-        1 phantom-drop
+        ds-drop
         [
             dup third value-info-small-tagged?
             [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
         ] [ first class>> immediate class<= ] bi
-        [ drop ] [ ^^write-barrier ] if
+        [ drop ] [ i i ##write-barrier ] if
     ] [ drop emit-primitive ] if ;

diff --git a/basis/compiler/cfg/intrinsics/utilities/utilities.factor b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
index 5540e3316ac4449129d0a8860f753a0ce2e3bf57..cd10b4e54e9f1759c253468e9f669fca176b3a86 100644 (file)
--- a/basis/compiler/cfg/intrinsics/utilities/utilities.factor
+++ b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
@@ -1,7 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts cpu.architecture ;
+USING: accessors kernel math layouts cpu.architecture
+compiler.cfg.instructions ;
 IN: compiler.cfg.intrinsics.utilities
 
 : value-info-small-tagged? ( value-info -- ? )
     literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
+
+: emit-primitive ( node -- )
+    word>> ##simple-stack-frame ##call ;

diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor
new file mode 100644 (file)
index 0000000..5e866d1
--- /dev/null
+++ b/basis/compiler/cfg/linearization/linearization-tests.factor
@@ -0,0 +1,4 @@
+IN: compiler.cfg.linearization.tests
+USING: compiler.cfg.linearization tools.test ;
+
+\ build-mr must-infer

diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index f9fd4521f7e922afc97bfbd56f438d81b8e56400..09d2feba6dd1908802fb0429bca9b706a8d53487 100644 (file)
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -16,7 +16,7 @@ TUPLE: ds-loc < loc ;
 C: <ds-loc> ds-loc
 
 TUPLE: rs-loc < loc ;
-C: <rs-loc> ds-loc
+C: <rs-loc> rs-loc
 
 ! Prettyprinting
 : V scan-word scan-word vreg boa parsed ; parsing

diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 73261e0e42992eb22c0fd117f66650d0981af7f2..f138f673e0c10fb6b5e423864dfb1f4dc4c21186 100755 (executable)
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -1,201 +1,33 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes classes.private classes.algebra
-combinators hashtables kernel layouts math fry namespaces
-quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order
-combinators.short-circuit cpu.architecture
+USING: math sequences kernel cpu.architecture
 compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.hats ;
 IN: compiler.cfg.stacks
 
-! Converting stack operations into register operations, while
-! doing a bit of optimization along the way.
+: ds-drop ( -- )
+    -1 ##inc-d ;
 
-! A compile-time stack
-TUPLE: phantom-stack { height integer } { stack vector } ;
+: ds-pop ( -- vreg )
+    D 0 ^^peek -1 ##inc-d ;
 
-M: phantom-stack clone
-    call-next-method [ clone ] change-stack ;
+: ds-push ( vreg -- )
+    1 ##inc-d D 0 ##replace ;
 
-GENERIC: finalize-height ( stack -- )
+: ds-load ( n -- vregs )
+    [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
 
-: new-phantom-stack ( class -- stack )
-    new V{ } clone >>stack ; inline
+: ds-store ( vregs -- )
+    <reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
 
-: (loc) ( m stack -- n )
-    #! Utility for methods on <loc>
-    height>> - ; inline
+: rs-load ( n -- vregs )
+    [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
 
-: (finalize-height) ( stack word -- )
-    #! We consolidate multiple stack height changes until the
-    #! last moment, and we emit the final height changing
-    #! instruction here.
-    '[ dup zero? [ drop ] [ _ execute ] if 0 ] change-height drop ; inline
+: rs-store ( vregs -- )
+    <reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
 
-GENERIC: <loc> ( n stack -- loc )
+: 2inputs ( -- vreg1 vreg2 )
+    D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
 
-TUPLE: phantom-datastack < phantom-stack ;
-
-: <phantom-datastack> ( -- stack )
-    phantom-datastack new-phantom-stack ;
-
-M: phantom-datastack <loc> (loc) <ds-loc> ;
-
-M: phantom-datastack finalize-height
-    \ ##inc-d (finalize-height) ;
-
-TUPLE: phantom-retainstack < phantom-stack ;
-
-: <phantom-retainstack> ( -- stack )
-    phantom-retainstack new-phantom-stack ;
-
-M: phantom-retainstack <loc> (loc) <rs-loc> ;
-
-M: phantom-retainstack finalize-height
-    \ ##inc-r (finalize-height) ;
-
-: phantom-locs ( n phantom -- locs )
-    #! A sequence of n ds-locs or rs-locs indexing the stack.
-    [ <reversed> ] dip '[ _ <loc> ] map ;
-
-: phantom-locs* ( phantom -- locs )
-    [ stack>> length ] keep phantom-locs ;
-
-: phantoms ( -- phantom phantom )
-    phantom-datastack get phantom-retainstack get ;
-
-: (each-loc) ( phantom quot -- )
-    >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
-
-: each-loc ( quot -- )
-    phantoms 2array swap '[ _ (each-loc) ] each ; inline
-
-: adjust-phantom ( n phantom -- )
-    swap '[ _ + ] change-height drop ;
-
-: cut-phantom ( n phantom -- seq )
-    swap '[ _ cut* swap ] change-stack drop ;
-
-: phantom-append ( seq stack -- )
-    over length over adjust-phantom stack>> push-all ;
-
-: add-locs ( n phantom -- )
-    2dup stack>> length <= [
-        2drop
-    ] [
-        [ phantom-locs ] keep
-        [ stack>> length head-slice* ] keep
-        [ append >vector ] change-stack drop
-    ] if ;
-
-: phantom-input ( n phantom -- seq )
-    2dup add-locs
-    2dup cut-phantom
-    >r >r neg r> adjust-phantom r> ;
-
-: each-phantom ( quot -- ) phantoms rot bi@ ; inline
-
-: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
-
-GENERIC: lazy-load ( loc/vreg -- vreg )
-M: loc lazy-load ^^peek ;
-M: vreg lazy-load ;
-
-GENERIC: live-loc? ( actual current -- ? )
-M: vreg live-loc? 2drop f ;
-M: loc live-loc? { [ [ class ] bi@ = ] [ [ n>> ] bi@ = not ] } 2&& ;
-
-: (live-locs) ( phantom -- seq )
-    #! Discard locs which haven't moved
-    [ phantom-locs* ] [ stack>> ] bi zip
-    [ live-loc? ] assoc-filter
-    values ;
-
-: live-locs ( -- seq )
-    [ (live-locs) ] each-phantom append prune ;
-
-GENERIC: lazy-store ( dst src -- )
-
-M: vreg lazy-store 2drop ;
-
-M: loc lazy-store
-    2dup live-loc? [
-        \ live-locs get at swap ##replace
-    ] [ 2drop ] if ;
-
-: finalize-locs ( -- )
-    #! Perform any deferred stack shuffling.
-    live-locs [ dup lazy-load ] H{ } map>assoc
-    dup assoc-empty? [ drop ] [
-        \ live-locs set
-        [ lazy-store ] each-loc
-    ] if ;
-
-: finalize-vregs ( -- )
-    #! Store any vregs to their final stack locations.
-    [ dup loc? [ 2drop ] [ swap ##replace ] if ] each-loc ;
-
-: clear-phantoms ( -- )
-    [ stack>> delete-all ] each-phantom ;
-
-: finalize-contents ( -- )
-    finalize-locs finalize-vregs clear-phantoms ;
-
-! Loading stacks to vregs
-: finalize-phantoms ( -- )
-    #! Commit all deferred stacking shuffling, and ensure the
-    #! in-memory data and retain stacks are up to date with
-    #! respect to the compiler's current picture.
-    finalize-contents
-    finalize-heights
-    fresh-objects get [
-        empty? [ ##simple-stack-frame ##gc ] unless
-    ] [ delete-all ] bi ;
-
-: init-phantoms ( -- )
-    V{ } clone fresh-objects set
-    <phantom-datastack> phantom-datastack set
-    <phantom-retainstack> phantom-retainstack set ;
-
-: copy-phantoms ( -- )
-    fresh-objects [ clone ] change
-    phantom-datastack [ clone ] change
-    phantom-retainstack [ clone ] change ;
-
-: phantom-push ( obj -- )
-    1 phantom-datastack get adjust-phantom
-    phantom-datastack get stack>> push ;
-
-: phantom-shuffle ( shuffle -- )
-    [ in>> length phantom-datastack get phantom-input ] keep
-    shuffle phantom-datastack get phantom-append ;
-
-: phantom->r ( n -- )
-    phantom-datastack get phantom-input
-    phantom-retainstack get phantom-append ;
-
-: phantom-r> ( n -- )
-    phantom-retainstack get phantom-input
-    phantom-datastack get phantom-append ;
-
-: phantom-drop ( n -- )
-    phantom-datastack get phantom-input drop ;
-
-: phantom-rdrop ( n -- )
-    phantom-retainstack get phantom-input drop ;
-
-: phantom-load ( n -- vreg )
-    phantom-datastack get phantom-input [ lazy-load ] map ;
-
-: phantom-pop ( -- vreg )
-    1 phantom-load first ;
-
-: 2phantom-pop ( -- vreg1 vreg2 )
-    2 phantom-load first2 ;
-
-: 3phantom-pop ( -- vreg1 vreg2 vreg3 )
-    3 phantom-load first3 ;
-
-: emit-primitive ( node -- )
-    finalize-phantoms word>> ##simple-stack-frame ##call ;
+: 3inputs ( -- vreg1 vreg2 vreg3 )
+    D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;