From 743550f19c956ca29c4238f57f6ff3097ce212c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 May 2009 05:36:04 -0500
Subject: [PATCH] Put GC checks in the right place when linearizing, and
 generate _dispatch-labels

---
 basis/compiler/cfg/def-use/def-use.factor     |  5 +-
 .../cfg/instructions/instructions.factor      |  3 ++
 .../cfg/linearization/linearization.factor    | 52 ++++++++++++++-----
 3 files changed, 45 insertions(+), 15 deletions(-)

diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 97047a7c3e..ba2a4dac3a 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -21,6 +21,7 @@ M: ##compare-imm defs-vregs dst/tmp-vregs ;
 M: ##compare-float defs-vregs dst/tmp-vregs ;
 M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: _dispatch defs-vregs temp>> 1array ;
 M: insn defs-vregs drop f ;
 
 M: ##unary uses-vregs src>> 1array ;
@@ -42,6 +43,7 @@ M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##phi uses-vregs inputs>> ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
+M: _dispatch uses-vregs src>> 1array ;
 M: insn uses-vregs drop f ;
 
 ! Instructions that use vregs
@@ -54,4 +56,5 @@ UNION: vreg-insn
 ##conditional-branch
 ##compare-imm-branch
 _conditional-branch
-_compare-imm-branch ;
+_compare-imm-branch
+_dispatch ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 6da9f797bd..5682aa668d 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -231,6 +231,9 @@ INSN: _gc live-in ;
 
 INSN: _branch label ;
 
+INSN: _dispatch src temp ;
+INSN: _dispatch-label label ;
+
 TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
 
 INSN: _compare-branch < _conditional-branch ;
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 64507779a4..0d851ea483 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -12,8 +12,38 @@ IN: compiler.cfg.linearization
 ! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
-: linearize-insns ( basic-block -- )
-    dup instructions>> [ linearize-insn ] with each ; inline
+: linearize-insns ( bb insns -- )
+    [ linearize-insn ] with each ;
+
+: gc? ( bb -- ? )
+    instructions>> [ ##allocation? ] any? ;
+
+: object-pointer-regs ( basic-block -- vregs )
+    live-out keys [ reg-class>> int-regs eq? ] filter ;
+
+: gc-check-position ( insns -- n )
+    #! We want to insert the GC check before the final branch in a basic block.
+    #! If there is a ##epilogue or ##loop-entry we want to insert it before that too.
+    dup length
+    dup 2 >= [
+        2 - swap nth [ ##loop-entry? ] [ ##epilogue? ] bi or
+        2 1 ?
+    ] [ 2drop 1 ] if ;
+
+: linearize-basic-block/gc ( bb -- )
+    dup instructions>> dup gc-check-position
+    [ head* linearize-insns ]
+    [ 2drop object-pointer-regs _gc ]
+    [ tail* linearize-insns ]
+    3tri ;
+
+: linearize-basic-block ( bb -- )
+    [ number>> _label ]
+    [
+        dup gc?
+        [ linearize-basic-block/gc ]
+        [ dup instructions>> linearize-insns ] if
+    ] bi ;
 
 M: insn linearize-insn , drop ;
 
@@ -32,7 +62,7 @@ M: insn linearize-insn , drop ;
 : emit-branch ( basic-block successor -- )
     {
         { [ 2dup useless-branch? ] [ 2drop ] }
-        { [ dup branch-to-branch? ] [ nip linearize-insns ] }
+        { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
         [ nip number>> _branch ]
     } cond ;
 
@@ -57,17 +87,11 @@ M: ##compare-imm-branch linearize-insn
 M: ##compare-float-branch linearize-insn
     binary-conditional _compare-float-branch emit-branch ;
 
-: gc? ( bb -- ? )
-    instructions>> [ ##allocation? ] any? ;
-
-: object-pointer-regs ( basic-block -- vregs )
-    live-in keys [ reg-class>> int-regs eq? ] filter ;
-
-: linearize-basic-block ( bb -- )
-    [ number>> _label ]
-    [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ]
-    [ linearize-insns ]
-    tri ;
+M: ##dispatch linearize-insn
+    swap
+    [ [ src>> ] [ temp>> ] bi _dispatch ]
+    [ successors>> [ number>> _dispatch-label ] each ]
+    bi* ;
 
 : linearize-basic-blocks ( rpo -- insns )
     [ [ linearize-basic-block ] each ] { } make ;