Expand slot accessors further to avoid having to use complex template decision

basis/compiler/cfg/registers/registers.factor

@@ -38,20 +38,6 @@ TUPLE: rs-loc < loc ;
 
 INSTANCE: loc value
 
-! A stack location which has been loaded into a register. To
-! read the location, we just read the register, but when time
-! comes to save it back to the stack, we know the register just
-! contains a stack value so we don't have to redundantly write
-! it back.
-TUPLE: cached loc vreg ;
-C: <cached> cached
-
-M: cached set-value-class vreg>> set-value-class ;
-M: cached value-class* vreg>> value-class* ;
-M: cached >vreg vreg>> >vreg ;
-
-INSTANCE: cached value
-
 ! A tagged pointer
 TUPLE: tagged vreg class ;
 : <tagged> ( vreg -- tagged ) f tagged boa ;

basis/compiler/cfg/stacks/stacks.factor

@@ -56,15 +56,6 @@ M: loc move-spec drop loc ;
 M: f move-spec drop loc ;
 M: f value-class* ;
 
-M: cached move-spec drop cached ;
-M: cached live-loc? loc>> live-loc? ;
-M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
-M: cached (eager-load) >r vreg>> r> (eager-load) ;
-M: cached lazy-store
-    2dup loc>> live-loc?
-    [ "live-locs" get at ##move ] [ 2drop ] if ;
-M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
-
 M: tagged move-spec drop f ;
 
 M: unboxed-alien move-spec class ;
@@ -278,9 +269,7 @@ M: loc lazy-store
 
 : finalize-vregs ( -- )
     #! Store any vregs to their final stack locations.
-    [
+    [ dup loc? [ 2drop ] [ ##move ] if ] each-loc ;
-        dup loc? over cached? or [ 2drop ] [ ##move ] if
-    ] each-loc ;
 
 : clear-phantoms ( -- )
     [ stack>> delete-all ] each-phantom ;
@@ -289,19 +278,6 @@ M: loc lazy-store
     finalize-locs finalize-vregs clear-phantoms ;
 
 ! Loading stacks to vregs
-: vreg-substitution ( value vreg -- pair )
-    dupd <cached> 2array ;
-
-: substitute-vreg? ( old new -- ? )
-    #! We don't substitute locs for float or alien vregs,
-    #! since in those cases the boxing overhead might kill us.
-    vreg>> tagged? >r loc? r> and ;
-
-: substitute-vregs ( values vregs -- )
-    [ vreg-substitution ] 2map
-    [ substitute-vreg? ] assoc-filter >hashtable
-    '[ stack>> _ substitute-here ] each-phantom ;
-
 : set-value-classes ( classes -- )
     phantom-datastack get
     over length over add-locs
@@ -350,5 +326,4 @@ M: loc lazy-store
     phantom-retainstack get phantom-input drop ;
 
 : phantom-pop ( -- vreg )
-    1 phantom-datastack get phantom-input dup first f (lazy-load)
+    1 phantom-datastack get phantom-input first f (lazy-load) ;
-    [ 1array substitute-vregs ] keep ;

basis/compiler/intrinsics/intrinsics.factor

@@ -36,9 +36,13 @@ ERROR: missing-intrinsic ;
 \ (wrapper) { } { wrapper } define-primitive
 \ (wrapper) make-flushable
 
-: (set-slot) ( val obj n -- ) missing-intrinsic ;
+: (slot) ( obj n tag# -- val ) missing-intrinsic ;
 
-\ (set-slot) { object object fixnum } { } define-primitive
+\ (slot) { object fixnum fixnum } { object } define-primitive
+
+: (set-slot) ( val obj n tag# -- ) missing-intrinsic ;
+
+\ (set-slot) { object object fixnum fixnum } { } define-primitive
 
 : (write-barrier) ( obj -- ) missing-intrinsic ;
 

basis/compiler/tree/finalization/finalization.factor

@@ -124,10 +124,25 @@ MEMO: <wrapper>-expansion ( -- quot )
 : expand-<wrapper> ( #call -- nodes )
     drop <wrapper>-expansion ;
 
+MEMO: slot-expansion ( tag -- nodes )
+    '[ _ (slot) ] splice-final ;
+
+: value-tag ( node value -- n )
+    node-value-info class>> class-tag ;
+
+: expand-slot ( #call -- nodes )
+    dup dup in-d>> first value-tag [ slot-expansion ] [ ] ?if ;
+
+MEMO: set-slot-expansion ( write-barrier? tag# -- nodes )
+    [ '[ [ _ (set-slot) ] [ drop (write-barrier) ] 2bi ] ]
+    [ '[ _ (set-slot) ] ]
+    bi ? splice-final ;
+
 : expand-set-slot ( #call -- nodes )
-    dup in-d>> first node-value-info class>> immediate class<=
+    dup dup in-d>> second value-tag [
-    [ (set-slot) ] [ over >r (set-slot) r> (write-barrier) ] ?
+        [ dup in-d>> first node-value-info class>> immediate class<= not ] dip
-    splice-final ;
+        set-slot-expansion
+    ] when* ;
 
 M: #call finalize*
     {
@@ -141,6 +156,7 @@ M: #call finalize*
                 { \ <complex> [ expand-<complex> ] }
                 { \ <wrapper> [ expand-<wrapper> ] }
                 { \ set-slot [ expand-set-slot ] }
+                { \ slot [ expand-slot ] }
                 [ drop ]
             } case
         ]