Adding identity optimization pass, tweak inlining heuristic

basis/compiler/tree/identities/identities.factor

@@ -0,0 +1,98 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences fry words math
+math.partial-dispatch combinators arrays hashtables
+compiler.tree
+compiler.tree.combinators
+compiler.tree.propagation.info ;
+IN: compiler.tree.identities
+
+: define-identities ( word identities -- )
+    [ integer-derived-ops ] dip
+    '[ _ "identities" set-word-prop ] each ;
+
+SYMBOL: X
+
+\ + {
+    { { X 0 } drop }
+    { { 0 X } nip }
+} define-identities
+
+\ - {
+    { { X 0 } drop }
+} define-identities
+
+\ * {
+    { { X 1 } drop }
+    { { 1 X } nip }
+    { { X 0 } nip }
+    { { 0 X } drop }
+} define-identities
+
+\ / {
+    { { X 1 } drop }
+} define-identities
+
+\ mod {
+    { { X 1 } 0 }
+} define-identities
+
+\ rem {
+    { { X 1 } 0 }
+} define-identities
+
+\ bitand {
+    { { X -1 } drop }
+    { { -1 X } nip }
+    { { X 0 } nip }
+    { { 0 X } drop }
+} define-identities
+
+\ bitor {
+    { { X 0 } drop }
+    { { 0 X } nip }
+    { { X -1 } nip }
+    { { -1 X } drop }
+} define-identities
+
+\ bitxor {
+    { { X 0 } drop }
+    { { 0 X } nip }
+} define-identities
+
+\ shift {
+    { { 0 X } drop }
+    { { X 0 } drop }
+} define-identities
+
+: matches? ( pattern infos -- ? )
+    [ over X eq? [ 2drop t ] [ literal>> = ] if ] 2all? ;
+
+: find-identity ( patterns infos -- result )
+    '[ first _ matches? ] find swap [ second ] when ;
+
+GENERIC: apply-identities* ( node -- node )
+
+: simplify-to-constant ( #call constant -- nodes )
+    [ [ in-d>> #drop ] [ out-d>> first ] bi ] dip swap #push
+    2array ;
+
+: select-input ( node n -- #shuffle )
+    [ [ in-d>> ] [ out-d>> ] bi ] dip
+    pick nth over first associate #shuffle ;
+
+M: #call apply-identities*
+    dup word>> "identities" word-prop [
+        over node-input-infos find-identity [
+            {
+                { \ drop [ 0 select-input ] }
+                { \ nip [ 1 select-input ] }
+                [ simplify-to-constant ]
+            } case
+        ] when*
+    ] when* ;
+
+M: node apply-identities* ;
+
+: apply-identities ( nodes -- nodes' )
+    [ apply-identities* ] map-nodes ;

basis/compiler/tree/optimizer/optimizer.factor

@@ -7,6 +7,7 @@ compiler.tree.propagation
 compiler.tree.cleanup
 compiler.tree.escape-analysis
 compiler.tree.tuple-unboxing
+compiler.tree.identities
 compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
@@ -23,6 +24,7 @@ SYMBOL: check-optimizer?
     cleanup
     escape-analysis
     unbox-tuples
+    apply-identities
     compute-def-use
     remove-dead-code
     ! strength-reduce

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -7,11 +7,19 @@ words namespaces
 compiler.tree
 compiler.tree.builder
 compiler.tree.recursive
+compiler.tree.combinators
 compiler.tree.normalization
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes ;
 IN: compiler.tree.propagation.inlining
 
+! We count nodes up-front; if there are relatively few nodes,
+! we are more eager to inline
+SYMBOL: node-count
+
+: count-nodes ( nodes -- )
+    0 swap [ drop 1+ ] each-node node-count set ;
+
 ! Splicing nodes
 GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
 
@@ -114,12 +122,13 @@ DEFER: (flat-length)
     [ classes-known? 2 0 ? ]
     [
         {
+            [ drop node-count get 45 swap [-] 8 /i ]
             [ flat-length 24 swap [-] 4 /i ]
             [ "default" word-prop -4 0 ? ]
             [ "specializer" word-prop 1 0 ? ]
             [ method-body? 1 0 ? ]
         } cleave
-    ] bi* + + + + ;
+    ] bi* + + + + + ;
 
 : should-inline? ( #call word -- ? )
     inlining-rank 5 >= ;

basis/compiler/tree/propagation/propagation.factor

@@ -6,6 +6,7 @@ compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
+compiler.tree.propagation.inlining
 compiler.tree.propagation.branches
 compiler.tree.propagation.recursive
 compiler.tree.propagation.constraints
@@ -18,4 +19,5 @@ IN: compiler.tree.propagation
     H{ } clone copies set
     H{ } clone constraints set
     H{ } clone value-infos set
+    dup count-nodes
     dup (propagate) ;

basis/hints/hints.factor

@@ -91,7 +91,7 @@ IN: hints
 
 \ >string { sbuf } "specializer" set-word-prop
 
-\ >array { { string } { vector } } "specializer" set-word-prop
+\ >array { { vector } } "specializer" set-word-prop
 
 \ >vector { { array } { vector } } "specializer" set-word-prop
 
@@ -101,7 +101,7 @@ IN: hints
 
 \ memq? { array } "specializer" set-word-prop
 
-\ member? { fixnum string } "specializer" set-word-prop
+\ member? { array } "specializer" set-word-prop
 
 \ assoc-stack { vector } "specializer" set-word-prop
 

basis/math/partial-dispatch/partial-dispatch.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel kernel.private math math.private words
 sequences parser namespaces make assocs quotations arrays locals
-generic generic.math hashtables effects compiler.units ;
+generic generic.math hashtables effects compiler.units
+classes.algebra ;
 IN: math.partial-dispatch
 
 ! Partial dispatch.
@@ -96,19 +97,28 @@ SYMBOL: fast-math-ops
     [ drop math-class-max swap specific-method >boolean ] if ;
 
 : (derived-ops) ( word assoc -- words )
-    swap [ rot first eq? nip ] curry assoc-filter values ;
+    swap [ rot first eq? nip ] curry assoc-filter ;
 
 : derived-ops ( word -- words )
-    [ 1array ]
+    [ 1array ] [ math-ops get (derived-ops) values ] bi append ;
-    [ math-ops get (derived-ops) ]
-    bi append ;
 
 : fast-derived-ops ( word -- words )
-    fast-math-ops get (derived-ops) ;
+    fast-math-ops get (derived-ops) values ;
 
 : all-derived-ops ( word -- words )
     [ derived-ops ] [ fast-derived-ops ] bi append ;
 
+: integer-derived-ops ( word -- words )
+    [ math-ops get (derived-ops) ] [ fast-math-ops get (derived-ops) ] bi
+    [
+            [
+            drop
+            [ second integer class<= ]
+            [ third integer class<= ]
+            bi and
+        ] assoc-filter values
+    ] bi@ append ;
+
 : each-derived-op ( word quot -- )
     >r derived-ops r> each ; inline