compiler.cfg.*: new system for emitting spill/reloads for gc calls (#1471)

GC calls were treated as sync points so all registers were spilled
around them. But if the gc call isn't triggered, it is unnecessary to
spill. This commit fixes that by handling ##call-gc specially and
putting ##spill and ##reloads in the same block as the gc call itself.

basis/compiler/cfg/instructions/instructions-docs.factor

@@ -357,10 +357,13 @@ HELP: gc-map
   { $table
     {
         { $slot "gc-roots" }
-        { "First a " { $link sequence } " of vregs that will be spilled during a gc. It is assigned in the " { $vocab-link "compiler.cfg.liveness" } " compiler pass. Then it is converted to a sequence of " { $link spill-slot } "s in " { $link assign-registers } "." }
+        { { $link sequence } " of vregs or spill-slots" }
     }
-    { { $slot "derived-roots" } { "An " { $link assoc } " of pairs of spill slots." } }
+    {
+        { $slot "derived-roots" }
+        { "An " { $link assoc } " of pairs of vregs or spill slots." } }
   }
+  "The 'gc-roots' and 'derived-roots' slots are initially vreg integers referencing objects that are live during the gc call and needs to be spilled so that they can be traced. In the " { $link emit-gc-map-insn } " word in " { $vocab-link "compiler.cfg.linear-scan.assignment" } " they are converted to spill slots which the collector is able to trace."
 }
 { $see-also emit-gc-info-bitmaps fill-gc-map } ;
 

basis/compiler/cfg/linear-scan/assignment/assignment-docs.factor

@@ -1,22 +1,15 @@
 USING: assocs compiler.cfg compiler.cfg.instructions
-compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation
-compiler.cfg.linear-scan.allocation.state compiler.cfg.liveness
+compiler.cfg.linear-scan.allocation.state
-compiler.cfg.registers heaps help.markup help.syntax math sequences ;
+compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
+compiler.cfg.registers heaps help.markup help.syntax math quotations
+sequences ;
 IN: compiler.cfg.linear-scan.assignment
 
 HELP: add-pending
 { $values { "live-interval" live-interval-state } }
 { $description "Adds a live interval to the pending interval set." } ;
 
-HELP: assign-derived-roots
-{ $values { "gc-map" gc-map } }
-{ $description "Assigns pairs of spill slots for all derived roots in a gc map." } ;
-{ assign-gc-roots assign-derived-roots } related-words
-
-HELP: assign-gc-roots
-{ $values { "gc-map" gc-map } }
-{ $description "Assigns spill slots for all gc roots in a gc map." } ;
-
 HELP: assign-registers-in-block
 { $values { "bb" basic-block } }
 { $description "Assigns registers to vregs and also inserts " { $link ##reload } " and " { $link ##spill } " instructions." } ;
@@ -29,14 +22,22 @@ HELP: assign-all-registers
 { $values { "insn" insn } }
 { $description "Assigns physical registers for the virtual registers used and defined by the instruction." } ;
 
+HELP: change-insn-gc-roots
+{ $values { "gc-map-insn" gc-map-insn } { "quot" quotation } }
+{ $description "Applies the quotation to all vregs in the instructions " { $link gc-map } "." } ;
+
 HELP: compute-live-in
 { $values { "bb" basic-block } }
 { $description "Computes the live in registers for a basic block." }
 { $see-also machine-live-ins } ;
 
+HELP: emit-##call-gc
+{ $values { "insn" ##call-gc } }
+{ $description "Emits a " { $link ##call-gc } " instruction and the " { $link ##reload } " and " { $link ##spill } " instructions it requires. ##call-gc aren't counted as sync points, so the instruction requires special handling." } ;
+
 HELP: expire-old-intervals
 { $values { "n" integer } { "pending-heap" min-heap } }
-{ $description "Expires all intervals older than the cutoff point." } ;
+{ $description "Expires all intervals older than the cutoff point. First they are removed from the 'pending-heap' and " { $link pending-interval-assoc } ". Then " { $link ##spill } " instructions are inserted for each interval that was removed." } ;
 
 HELP: insert-reload
 { $values { "live-interval" live-interval-state } }
@@ -74,15 +75,28 @@ HELP: vreg>spill-slot
 { $description "Converts a vreg number to a spill slot." } ;
 
 ARTICLE: "compiler.cfg.linear-scan.assignment" "Assigning registers to live intervals"
-"The " { $vocab-link "compiler.cfg.linear-scan.assignment" } " assigns registers to live intervals." $nl
+"The " { $vocab-link "compiler.cfg.linear-scan.assignment" } " assigns registers to live intervals. Before this compiler pass, all values in the " { $link cfg } " were represented as simple integers called \"virtual registers\" or vregs. In this pass, using the live interval data computed in the register allocation pass (" { $vocab-link "compiler.cfg.linear-scan.allocation" } "), those vregs are translated into physical registers."
+$nl
+"Since there is an infinite number of vregs but the number of physical registers is limited, some values must be spilled. So this pass also handles spilling decisions and inserts " { $link ##spill } " and " { $link ##reload } " instructions where needed."
+$nl
+"GC maps:"
+{ $subsections
+  change-insn-gc-roots
+  emit-##call-gc
+}
 "Pending intervals:"
 { $subsections
   activate-interval
   add-pending
   pending-interval-assoc
+  expire-old-intervals
   remove-pending
 }
 "Vreg transformations:"
-{ $subsections vreg>reg vreg>spill-slot vregs>regs } ;
+{ $subsections
+  vreg>reg
+  vreg>spill-slot
+  vregs>regs
+} ;
 
 ABOUT: "compiler.cfg.linear-scan.assignment"

basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor

@@ -1,9 +1,10 @@
-USING: accessors arrays compiler.cfg compiler.cfg.instructions
+USING: accessors arrays compiler.cfg.instructions
-compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.assignment
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.live-intervals compiler.cfg.registers
-compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities cpu.architecture
+compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities
-cpu.x86.assembler.operands grouping heaps kernel make namespaces random
+cpu.architecture cpu.x86.assembler.operands heaps kernel make
-sequences sorting tools.test ;
+namespaces sequences sorting tools.test ;
 IN: compiler.cfg.linear-scan.assignment.tests
 
 : cherry-pick ( seq indices -- seq' )
@@ -49,14 +50,6 @@ IN: compiler.cfg.linear-scan.assignment.tests
     } live-intervals>min-heap [ activate-new-intervals ] { } make
 ] unit-test
 
-! assign-gc-roots
-{
-    T{ gc-map { gc-roots { T{ spill-slot { n 7 } } } } }
-} [
-    { { 23 int-rep 23 T{ spill-slot { n 7 } } } } setup-vreg-spills
-    <gc-map> 23 1array >>gc-roots [ assign-gc-roots ] keep
-] unit-test
-
 ! assign-insn-defs
 {
     T{ ##peek { dst RAX } { loc T{ ds-loc } } { insn# 0 } }
@@ -97,9 +90,11 @@ IN: compiler.cfg.linear-scan.assignment.tests
 ] unit-test
 
 ! expire-old-intervals
-{ 3 } [
+{ 3 H{ } } [
+    H{ { 25 RBX } } clone pending-interval-assoc set
     90 { 50 90 95 120 } [ 25 <live-interval> 2array ] map >min-heap
     [ expire-old-intervals ] keep heap-size
+    pending-interval-assoc get
 ] unit-test
 
 ! insert-reload

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -1,22 +1,26 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators compiler.cfg
+USING: accessors arrays assocs combinators compiler.cfg
 compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.live-intervals compiler.cfg.linearization
 compiler.cfg.liveness compiler.cfg.registers
-compiler.cfg.renaming.functor compiler.cfg.ssa.destruction.leaders fry
+compiler.cfg.renaming.functor compiler.cfg.ssa.destruction.leaders
-heaps kernel make math namespaces sequences ;
+compiler.cfg.utilities fry heaps kernel make math namespaces sequences
+;
 IN: compiler.cfg.linear-scan.assignment
-
+QUALIFIED: sets
-: heap-pop-while ( heap quot: ( key -- ? ) -- values )
-    '[ dup heap-empty? [ f f ] [ dup heap-peek @ ] if ]
-    [ over heap-pop* ] produce 2nip ; inline
 
 ! This contains both active and inactive intervals; any interval
 ! such that start <= insn# <= end is in this set.
 SYMBOL: pending-interval-heap
 SYMBOL: pending-interval-assoc
 
+: insert-spill ( live-interval -- )
+    [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ;
+
+: handle-spill ( live-interval -- )
+    dup spill-to>> [ insert-spill ] [ drop ] if ;
+
 : add-pending ( live-interval -- )
     [ dup live-interval-end pending-interval-heap get heap-push ]
     [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
@@ -25,16 +29,13 @@ SYMBOL: pending-interval-assoc
 : remove-pending ( live-interval -- )
     vreg>> pending-interval-assoc get delete-at ;
 
+: vreg>spill-slot ( vreg -- slot )
+    dup rep-of lookup-spill-slot ;
+
 : vreg>reg ( vreg -- reg/spill-slot )
     dup leader dup pending-interval-assoc get at
     [ 2nip ] [ swap rep-of lookup-spill-slot ] if* ;
 
-ERROR: not-spilled-error vreg ;
-
-: vreg>spill-slot ( vreg -- spill-slot )
-    dup vreg>reg dup spill-slot?
-    [ nip ] [ drop leader not-spilled-error ] if ;
-
 : vregs>regs ( assoc -- assoc' )
     [ vreg>reg ] assoc-map ;
 
@@ -65,12 +66,6 @@ SYMBOL: machine-live-outs
 : compute-live-out ( bb -- )
     [ live-out vregs>regs ] keep machine-live-outs get set-at ;
 
-: insert-spill ( live-interval -- )
-    [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ;
-
-: handle-spill ( live-interval -- )
-    dup spill-to>> [ insert-spill ] [ drop ] if ;
-
 : expire-interval ( live-interval -- )
     [ remove-pending ] [ handle-spill ] bi ;
 
@@ -98,12 +93,6 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 : assign-all-registers ( insn -- )
     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
-: assign-gc-roots ( gc-map -- )
-    gc-roots>> [ vreg>spill-slot ] map! drop ;
-
-: assign-derived-roots ( gc-map -- )
-    [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;
-
 : begin-block ( bb -- )
     {
         [ basic-block namespaces:set ]
@@ -112,8 +101,39 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
         [ compute-live-in ]
     } cleave ;
 
-: handle-gc-map-insn ( insn -- )
+: change-insn-gc-roots ( gc-map-insn quot: ( x -- x ) -- )
-    dup , gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ;
+    [ gc-map>> ] dip [ swap gc-roots>> swap map! drop ]
+    [ '[ [ [ @ ] bi@ ] assoc-map ] change-derived-roots drop ] 2bi ; inline
+
+: spill-required? ( live-interval root-leaders n -- ? )
+    [ [ vreg>> ] dip sets:in? ] [ swap covers? ] bi-curry* bi or ;
+
+: spill-intervals ( root-leaders n -- live-intervals )
+    [ pending-interval-heap get heap-members ] 2dip
+    '[ _ _ spill-required? ] filter ;
+
+: spill/reload ( interval -- {reg,rep,slot} )
+    [ reg>> ] [ vreg>> dup rep-of dup swapd assign-spill-slot ] bi 3array ;
+
+: spill/reloads ( intervals -- spill/reloads )
+    [ spill/reload ] map ;
+
+: spill/reloads-for-call-gc ( ##call-gc -- spill-seq )
+    [ gc-map>> gc-roots>> ] [ insn#>> ] bi spill-intervals spill/reloads ;
+
+: emit-##call-gc ( insn -- )
+    dup spill/reloads-for-call-gc
+    dup [ first3 ##spill, ] each
+    swap ,
+    [ first3 ##reload, ] each ;
+
+: emit-gc-map-insn ( gc-map-insn -- )
+    [ [ leader ] change-insn-gc-roots ]
+    [ dup ##call-gc? [ emit-##call-gc ] [ , ] if ]
+    [ [ vreg>spill-slot ] change-insn-gc-roots ] tri ;
+
+: emit-insn ( insn -- )
+    dup gc-map-insn? [ emit-gc-map-insn ] [ , ] if ;
 
 : assign-registers-in-block ( bb -- )
     dup begin-block
@@ -122,7 +142,7 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
             [
                 [ insn#>> prepare-insn ]
                 [ assign-all-registers ]
-                [ dup gc-map-insn? [ handle-gc-map-insn ] [ , ] if ] tri
+                [ emit-insn ] tri
             ] each
         ] V{ } make
     ] change-instructions compute-live-out ;

basis/compiler/cfg/linear-scan/live-intervals/live-intervals-docs.factor

@@ -25,7 +25,7 @@ HELP: cfg>sync-points
 { $see-also sync-point } ;
 
 HELP: clobber-insn
-{ $class-description "Instructions that clobber registers but are allowed to produce outputs in registers. Inputs are in spill slots, except for inputs coalesced with the output, in which case that input will be in a register." } ;
+{ $class-description "Instructions that clobber registers but are allowed to produce outputs in registers. Inputs are in spill slots, except for inputs coalesced with the output, in which case that input will be in a register. Each instruction that is a member of the clobber-insn class requires a " { $link sync-point } "." } ;
 
 HELP: compute-live-intervals
 { $values { "cfg" cfg } { "intervals/sync-points" sequence } }
@@ -48,7 +48,8 @@ HELP: from
 { $var-description "An integer representing a sequence number one lower than all numbers in the currently processed block." } ;
 
 HELP: hairy-clobber-insn
-{ $class-description "Instructions that clobber registers. They receive inputs and produce outputs in spill slots." } ;
+{ $class-description "Instructions that clobber registers. They receive inputs and produce outputs in spill slots." }
+{ $notes "The " { $link ##call-gc } " instruction is not included in the class even though it clobbers registers because it is handled specially." } ;
 
 HELP: insn>sync-point
 { $values { "insn" insn } { "sync-point/f" { $maybe sync-point } } }
@@ -135,6 +136,8 @@ $nl
 "Sync point handling:"
 { $subsections
   cfg>sync-points
+  clobber-insn
+  hairy-clobber-insn
   insn>sync-point
 } ;
 

basis/compiler/cfg/linear-scan/live-intervals/live-intervals-tests.factor

@@ -11,9 +11,14 @@ IN: compiler.cfg.linear-scan.live-intervals.tests
 
 ! cfg>sync-points
 {
-    V{ T{ sync-point { n 0 } } }
+    V{
+        T{ sync-point { n 2 } }
+    }
 } [
-    V{ T{ ##call-gc } } insns>cfg
+    V{
+        T{ ##call-gc }
+        T{ ##callback-inputs }
+    } insns>cfg
     [ number-instructions ] [ cfg>sync-points ] bi
 ] unit-test
 
@@ -35,7 +40,7 @@ IN: compiler.cfg.linear-scan.live-intervals.tests
 
 ! insn>sync-point
 { f f t } [
-    T{ ##call-gc } insn>sync-point keep-dst?>>
+    T{ ##call-gc } insn>sync-point
     T{ ##callback-outputs } insn>sync-point keep-dst?>>
     T{ ##unbox } insn>sync-point keep-dst?>>
 ] unit-test

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -87,7 +87,6 @@ M: insn compute-live-intervals* drop ;
     ] [ uses-vregs ] if ;
 
 UNION: hairy-clobber-insn
-    ##call-gc
     alien-call-insn
     ##callback-inputs
     ##callback-outputs

basis/compiler/cfg/utilities/utilities-docs.factor

@@ -1,4 +1,5 @@
-USING: compiler.cfg help.markup help.syntax sequences ;
+USING: assocs compiler.cfg hashtables help.markup help.syntax
+sequences ;
 IN: compiler.cfg.utilities
 
 HELP: connect-Nto1-bbs
@@ -8,3 +9,18 @@ HELP: connect-Nto1-bbs
 HELP: insert-basic-block
 { $values { "from" basic-block } { "to" basic-block } { "insns" sequence } }
 { $description "Insert basic block on the edge between 'from' and 'to'." } ;
+
+ARTICLE: "compiler.cfg.utilities" "Utility words used by CFG optimization"
+"Various utilities."
+$nl
+"For " { $vocab-link "heaps" } ":"
+{ $subsections
+  heap-members
+  heap-pop-while
+}
+"For " { $vocab-link "deques" } ":"
+{ $subsections
+  slurp/replenish-deque
+} ;
+
+ABOUT: "compiler.cfg.utilities"

basis/compiler/cfg/utilities/utilities.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators.short-circuit compiler.cfg
 compiler.cfg.instructions compiler.cfg.rpo cpu.architecture deques fry
-kernel locals make math namespaces sequences sets ;
+heaps kernel locals math sequences sets ;
 IN: compiler.cfg.utilities
 
 : block>cfg ( bb -- cfg )
@@ -92,3 +92,10 @@ IN: compiler.cfg.utilities
 
 : slurp/replenish-deque ( ... deque quot: ( ... obj -- ... seq ) -- ... )
       over '[ @ _ push-all-front ] slurp-deque ; inline
+
+: heap-members ( heap -- seq )
+    data>> [ value>> ] map ;
+
+: heap-pop-while ( heap quot: ( key -- ? ) -- values )
+    '[ dup heap-empty? [ f f ] [ dup heap-peek @ ] if ]
+    [ over heap-pop* ] produce 2nip ; inline