From fa6a2047f04885e276d6e060c9c38922430608cc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 4 Dec 2008 07:05:59 -0600
Subject: [PATCH] New inlining heuristic: number of usages within this word.
 Speeds up bootstrap by 10%

---
 .../tree/propagation/inlining/inlining.factor | 26 ++++++++++++++-----
 .../tree/propagation/nodes/nodes.factor       |  2 ++
 .../tree/propagation/propagation.factor       |  1 +
 .../propagation/recursive/recursive.factor    |  4 +++
 4 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 83a4a7aef7..3a94029756 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -20,6 +20,10 @@ SYMBOL: node-count
 : count-nodes ( nodes -- )
     0 swap [ drop 1+ ] each-node node-count set ;
 
+! We try not to inline the same word too many times, to avoid
+! combinatorial explosion
+SYMBOL: inlining-count
+
 ! Splicing nodes
 GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
 
@@ -120,17 +124,25 @@ DEFER: (flat-length)
         bi and
     ] contains? ;
 
+: node-count-bias ( -- n )
+    45 node-count get [-] 8 /i ;
+
+: body-length-bias ( word -- n )
+    [ flat-length ] [ inlining-count get at 0 or 2/ 1+ ] bi *
+    24 swap [-] 4 /i ;
+
 : inlining-rank ( #call word -- n )
     [ classes-known? 2 0 ? ]
     [
         {
-            [ drop node-count get 45 swap [-] 8 /i ]
-            [ flat-length 24 swap [-] 4 /i ]
+            [ body-length-bias ]
             [ "default" word-prop -4 0 ? ]
             [ "specializer" word-prop 1 0 ? ]
             [ method-body? 1 0 ? ]
         } cleave
-    ] bi* + + + + + ;
+        node-count-bias
+        loop-nesting get 0 or 2 *
+    ] bi* + + + + + + ;
 
 : should-inline? ( #call word -- ? )
     dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
@@ -138,12 +150,12 @@ DEFER: (flat-length)
 SYMBOL: history
 
 : remember-inlining ( word -- )
-    history [ swap suffix ] change ;
+    [ [ 1 ] dip inlining-count get at+ ]
+    [ history [ swap suffix ] change ]
+    bi ;
 
 : inline-word-def ( #call word quot -- ? )
-    over history get memq? [
-        3drop f
-    ] [
+    over history get memq? [ 3drop f ] [
         [
             swap remember-inlining
             dupd splicing-nodes >>body
diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor
index 9e4d99e462..d676102bde 100644
--- a/basis/compiler/tree/propagation/nodes/nodes.factor
+++ b/basis/compiler/tree/propagation/nodes/nodes.factor
@@ -6,6 +6,8 @@ compiler.tree.propagation.copy
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 
+SYMBOL: loop-nesting
+
 GENERIC: propagate-before ( node -- )
 
 GENERIC: propagate-after ( node -- )
diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor
index b9822d2c6b..2a9825e3f1 100644
--- a/basis/compiler/tree/propagation/propagation.factor
+++ b/basis/compiler/tree/propagation/propagation.factor
@@ -19,5 +19,6 @@ IN: compiler.tree.propagation
     H{ } clone copies set
     H{ } clone 1array value-infos set
     H{ } clone 1array constraints set
+    H{ } clone inlining-count set
     dup count-nodes
     dup (propagate) ;
diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index 7f10f87016..ff9f262d28 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -55,6 +55,8 @@ IN: compiler.tree.propagation.recursive
 M: #recursive propagate-around ( #recursive -- )
     constraints [ H{ } clone suffix ] change
     [
+        loop-nesting inc
+
         constraints [ but-last H{ } clone suffix ] change
 
         child>>
@@ -62,6 +64,8 @@ M: #recursive propagate-around ( #recursive -- )
         [ first propagate-recursive-phi ]
         [ (propagate) ]
         tri
+
+        loop-nesting dec
     ] until-fixed-point ;
 
 : recursive-phi-infos ( node -- infos )