Clean up generator.registers a bit

core/alien/compiler/compiler.factor

@@ -62,6 +62,25 @@ GENERIC: alien-node-abi ( node -- str )
     call
     f set-stack-frame ; inline
 
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: float-regs reg-size float-regs-size ;
+
+GENERIC: inc-reg-class ( register-class -- )
+
+: (inc-reg-class)
+    dup class inc
+    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+M: int-regs inc-reg-class
+    (inc-reg-class) ;
+
+M: float-regs inc-reg-class
+    dup (inc-reg-class)
+    fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
+
 : reg-class-full? ( class -- ? )
     dup class get swap param-regs length >= ;
 

core/compiler/test/templates-early.factor

@@ -8,7 +8,7 @@ namespaces sequences words kernel math effects ;
     
     [ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
     
-    [ ] [ 0 <int-vreg> phantom-d get phantom-push ] unit-test
+    [ ] [ 0 <int-vreg> phantom-push ] unit-test
     
     [ ] [ compute-free-vregs ] unit-test
     
@@ -17,7 +17,7 @@ namespaces sequences words kernel math effects ;
     [ f ] [
         [
             copy-templates
-            1 <int-vreg> phantom-d get phantom-push
+            1 <int-vreg> phantom-push
             compute-free-vregs
             1 <int-vreg> T{ int-regs } free-vregs member?
         ] with-scope

core/generator/generator.factor

@@ -228,7 +228,7 @@ M: #dispatch generate-node
     "true" resolve-label
     t "if-scratch" get load-literal
     "end" resolve-label
-    "if-scratch" get phantom-d get phantom-push ; inline
+    "if-scratch" get phantom-push ; inline
 
 : define-if>boolean-intrinsics ( word intrinsics -- )
     [
@@ -281,26 +281,20 @@ M: #call-label generate-node node-param generate-call ;
 UNION: immediate fixnum POSTPONE: f ;
 
 M: #push generate-node
-    node-out-d phantom-d get phantom-append iterate-next ;
+    node-out-d [ phantom-push ] each iterate-next ;
 
 ! #shuffle
-: phantom-shuffle ( shuffle -- )
-    [ effect-in length phantom-d get phantom-input ] keep
-    shuffle* phantom-d get phantom-append ;
-
 M: #shuffle generate-node
     node-shuffle phantom-shuffle iterate-next ;
 
 M: #>r generate-node
     node-in-d length
-    phantom-d get phantom-input
+    phantom->r
-    phantom-r get phantom-append
     iterate-next ;
 
 M: #r> generate-node
     node-out-d length
-    phantom-r get phantom-input
+    phantom-r>
-    phantom-d get phantom-append
     iterate-next ;
 
 ! #return

core/generator/registers/registers.factor

@@ -2,10 +2,17 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes classes.private combinators
 cpu.architecture generator.fixup generic hashtables
-inference.dataflow kernel kernel.private layouts math memory
+inference.dataflow inference.stack kernel kernel.private layouts
-namespaces quotations sequences system vectors words ;
+math memory namespaces quotations sequences system vectors words
+effects ;
 IN: generator.registers
 
+SYMBOL: +input+
+SYMBOL: +output+
+SYMBOL: +scratch+
+SYMBOL: +clobber+
+SYMBOL: known-tag
+
 ! A scratch register for computations
 TUPLE: vreg n ;
 
@@ -24,45 +31,8 @@ TUPLE: temp-reg ;
 
 : temp-reg T{ temp-reg T{ int-regs } } ;
 
-: %move ( dst src -- )
-    2dup = [
-        2drop
-    ] [
-        2dup [ delegate class ] 2apply 2array {
-            { { int-regs int-regs } [ %move-int>int ] }
-            { { float-regs int-regs } [ %move-int>float ] }
-            { { int-regs float-regs } [ %move-float>int ] }
-        } case
-    ] if ;
-
-GENERIC: reg-size ( register-class -- n )
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: int-regs reg-size drop cell ;
-
-: (inc-reg-class)
-    dup class inc
-    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: int-regs inc-reg-class
-    (inc-reg-class) ;
-
-M: float-regs reg-size float-regs-size ;
-
-M: float-regs inc-reg-class
-    dup (inc-reg-class)
-    fp-shadows-int? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
-
 M: vreg v>operand dup vreg-n swap vregs nth ;
 
-: reg-spec>class ( spec -- class )
-    float eq?
-    T{ float-regs f 8 } T{ int-regs } ? ;
-
-SYMBOL: phantom-d
-SYMBOL: phantom-r
-
 ! A data stack location.
 TUPLE: ds-loc n ;
 
@@ -73,10 +43,18 @@ TUPLE: rs-loc n ;
 
 C: <rs-loc> rs-loc
 
+<PRIVATE
+
 UNION: loc ds-loc rs-loc ;
 
+! A compile-time stack
 TUPLE: phantom-stack height ;
 
+GENERIC: finalize-height ( stack -- )
+
+SYMBOL: phantom-d
+SYMBOL: phantom-r
+
 : <phantom-stack> ( class -- stack )
     >r
     V{ } clone 0
@@ -84,10 +62,6 @@ TUPLE: phantom-stack height ;
     phantom-stack construct
     r> construct-delegate ;
 
-GENERIC: finalize-height ( stack -- )
-
-GENERIC: <loc> ( n stack -- loc )
-
 : (loc)
     #! Utility for methods on <loc>
     phantom-stack-height - ;
@@ -102,6 +76,8 @@ GENERIC: <loc> ( n stack -- loc )
         0
     ] keep set-phantom-stack-height ; inline
 
+GENERIC: <loc> ( n stack -- loc )
+
 TUPLE: phantom-datastack ;
 
 : <phantom-datastack> phantom-datastack <phantom-stack> ;
@@ -137,17 +113,14 @@ M: phantom-retainstack finalize-height
 : adjust-phantom ( n phantom -- )
     [ phantom-stack-height + ] keep set-phantom-stack-height ;
 
-: phantom-push ( obj stack -- )
-    1 over adjust-phantom push ;
-
-: phantom-append ( seq stack -- )
-    over length over adjust-phantom push-all ;
-
 GENERIC: cut-phantom ( n phantom -- seq )
 
 M: phantom-stack cut-phantom
     [ delegate cut* swap ] keep set-delegate ;
 
+: phantom-append ( seq stack -- )
+    over length over adjust-phantom push-all ;
+
 : phantom-input ( n phantom -- seq )
     [
         2dup length <= [
@@ -160,6 +133,26 @@ M: phantom-stack cut-phantom
         ] if
     ] 2keep >r neg r> adjust-phantom ;
 
+PRIVATE>
+
+: phantom-push ( obj -- )
+    1 phantom-d get adjust-phantom
+    phantom-d get push ;
+
+: phantom-shuffle ( shuffle -- )
+    [ effect-in length phantom-d get phantom-input ] keep
+    shuffle* phantom-d get phantom-append ;
+
+: phantom->r ( n -- )
+    phantom-d get phantom-input
+    phantom-r get phantom-append ;
+
+: phantom-r> ( n -- )
+    phantom-r get phantom-input
+    phantom-d get phantom-append ;
+
+<PRIVATE
+
 : phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
 
 : each-phantom ( quot -- ) phantoms rot 2apply ; inline
@@ -195,10 +188,6 @@ UNION: pseudo loc value ;
 ! are guaranteed to be in the nursery
 SYMBOL: fresh-objects
 
-: fresh-object ( obj -- ) fresh-objects get push ;
-
-: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
-
 ! Computing free registers and initializing allocator
 : free-vregs ( reg-class -- seq )
     #! Free vregs in a given register class
@@ -217,25 +206,25 @@ SYMBOL: fresh-objects
     [ 2dup (compute-free-vregs) ] H{ } map>assoc \ free-vregs set
     drop ;
 
-: init-templates ( -- )
+: reg-spec>class ( spec -- class )
-    #! Initialize register allocator.
+    float eq?
-    V{ } clone fresh-objects set
+    T{ float-regs f 8 } T{ int-regs } ? ;
-    <phantom-datastack> phantom-d set
-    <phantom-retainstack> phantom-r set
-    compute-free-vregs ;
-
-: copy-templates ( -- )
-    #! Copies register allocator state, used when compiling
-    #! branches.
-    fresh-objects [ clone ] change
-    phantom-d [ clone ] change
-    phantom-r [ clone ] change
-    compute-free-vregs ;
 
 ! Copying vregs to stacks
 : alloc-vreg ( spec -- vreg )
     reg-spec>class free-vregs pop ;
 
+: %move ( dst src -- )
+    2dup = [
+        2drop
+    ] [
+        2dup [ delegate class ] 2apply 2array {
+            { { int-regs int-regs } [ %move-int>int ] }
+            { { float-regs int-regs } [ %move-int>float ] }
+            { { int-regs float-regs } [ %move-float>int ] }
+        } case
+    ] if ;
+
 : vreg>vreg ( vreg spec -- vreg )
     alloc-vreg dup rot %move ;
 
@@ -382,13 +371,6 @@ M: object template-rhs ;
     %prepare-alien-invoke
     "simple_gc" f %alien-invoke ;
 
-: end-basic-block ( -- )
-    #! 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 dup empty? swap delete-all [ %gc ] unless ;
-
 ! Loading stacks to vregs
 : free-vregs# ( -- int# float# )
     T{ int-regs } T{ float-regs f 8 } 
@@ -433,11 +415,6 @@ M: object template-rhs ;
         dup length phantom-d get phantom-input swap lazy-load
     ] if ;
 
-SYMBOL: +input+
-SYMBOL: +output+
-SYMBOL: +scratch+
-SYMBOL: +clobber+
-
 : output-vregs ( -- seq seq )
     +output+ +clobber+ [ get [ get ] map ] 2apply ;
 
@@ -489,11 +466,6 @@ SYMBOL: +clobber+
 : template-outputs ( -- )
     +output+ get [ get ] map phantom-d get phantom-append ;
 
-: with-template ( quot hash -- )
-    clone [ template-inputs call template-outputs ] bind
-    compute-free-vregs ;
-    inline
-
 : value-matches? ( value spec -- ? )
     #! If the spec is a quotation and the value is a literal
     #! fixnum, see if the quotation yields true when applied
@@ -519,8 +491,6 @@ SYMBOL: +clobber+
         dup length 1 = [ first tag-number ] [ drop f ] if
     ] if ;
 
-SYMBOL: known-tag
-
 : class-match? ( actual expected -- ? )
     {
         { f [ drop t ] }
@@ -545,6 +515,39 @@ SYMBOL: known-tag
     #! Depends on node@
     [ second template-matches? ] find nip ;
 
+PRIVATE>
+
+: end-basic-block ( -- )
+    #! 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 dup empty? swap delete-all [ %gc ] unless ;
+
+: with-template ( quot hash -- )
+    clone [ template-inputs call template-outputs ] bind
+    compute-free-vregs ;
+    inline
+
+: fresh-object ( obj -- ) fresh-objects get push ;
+
+: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
+
+: init-templates ( -- )
+    #! Initialize register allocator.
+    V{ } clone fresh-objects set
+    <phantom-datastack> phantom-d set
+    <phantom-retainstack> phantom-r set
+    compute-free-vregs ;
+
+: copy-templates ( -- )
+    #! Copies register allocator state, used when compiling
+    #! branches.
+    fresh-objects [ clone ] change
+    phantom-d [ clone ] change
+    phantom-r [ clone ] change
+    compute-free-vregs ;
+
 : find-template ( templates -- pair/f )
     #! Pair has shape { quot hash }
     #! Depends on node@