basis/compiler/tree/cleanup/cleanup.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors classes classes.algebra combinators
   4 compiler.tree compiler.tree.combinators
   5 compiler.tree.propagation.branches
   6 compiler.tree.propagation.info compiler.utilities fry kernel
   7 layouts math math.intervals math.partial-dispatch math.private
   8 namespaces sequences stack-checker.branches
   9 stack-checker.dependencies words ;
  10 IN: compiler.tree.cleanup
  11
  12 GENERIC: delete-node ( node -- )
  13
  14 M: #call-recursive delete-node
  15     dup label>> calls>> [ node>> eq? ] with reject! drop ;
  16
  17 M: #return-recursive delete-node
  18     label>> f >>return drop ;
  19
  20 M: node delete-node drop ;
  21
  22 : delete-nodes ( nodes -- ) [ delete-node ] each-node ;
  23
  24 GENERIC: cleanup-tree* ( node -- node/nodes )
  25
  26 : cleanup-tree ( nodes -- nodes' )
  27     ! We don't recurse into children here, instead the methods
  28     ! do it since the logic is a bit more involved
  29     [ cleanup-tree* ] map-flat ;
  30
  31 ! Constant folding
  32 : cleanup-folding? ( #call -- ? )
  33     node-output-infos
  34     [ f ] [ [ literal?>> ] all? ] if-empty ;
  35
  36 : (cleanup-folding) ( #call -- nodes )
  37     ! Replace a #call having a known result with a #drop of its
  38     ! inputs followed by #push nodes for the outputs.
  39     [
  40         [ node-output-infos ] [ out-d>> ] bi
  41         [ [ literal>> ] dip <#push> ] 2map
  42     ]
  43     [ in-d>> <#drop> ]
  44     bi prefix ;
  45
  46 : >predicate-folding< ( #call -- value-info class result )
  47     [ node-input-infos first ]
  48     [ word>> "predicating" word-prop ]
  49     [ node-output-infos first literal>> ] tri ;
  50
  51 : record-predicate-folding ( #call -- )
  52     >predicate-folding< pick literal?>>
  53     [ [ literal>> ] 2dip add-depends-on-instance-predicate ]
  54     [ [ class>> ] 2dip add-depends-on-class-predicate ]
  55     if ;
  56
  57 : record-folding ( #call -- )
  58     dup word>> predicate?
  59     [ record-predicate-folding ]
  60     [ word>> add-depends-on-definition ]
  61     if ;
  62
  63 : cleanup-folding ( #call -- nodes )
  64     [ (cleanup-folding) ] [ record-folding ] bi ;
  65
  66 ! Method inlining
  67 : add-method-dependency ( #call -- )
  68     dup method>> word? [
  69         [ [ class>> ] [ word>> ] bi add-depends-on-generic ]
  70         [ [ class>> ] [ word>> ] [ method>> ] tri add-depends-on-method ]
  71         bi
  72     ] [ drop ] if ;
  73
  74 : record-inlining ( #call -- )
  75     dup method>>
  76     [ add-method-dependency ]
  77     [ word>> add-depends-on-definition ] if ;
  78
  79 : cleanup-inlining ( #call -- nodes )
  80     [ record-inlining ] [ body>> cleanup-tree ] bi ;
  81
  82 ! Removing overflow checks
  83 : (remove-overflow-check?) ( #call -- ? )
  84     node-output-infos first class>> fixnum class<= ;
  85
  86 : small-shift? ( #call -- ? )
  87     node-input-infos second interval>>
  88     cell-bits tag-bits get - [ neg ] keep [a,b] interval-subset? ;
  89
  90 : remove-overflow-check? ( #call -- ? )
  91     {
  92         { [ dup word>> \ fixnum-shift eq? ] [ [ (remove-overflow-check?) ] [ small-shift? ] bi and ] }
  93         { [ dup word>> no-overflow-variant ] [ (remove-overflow-check?) ] }
  94         [ drop f ]
  95     } cond ;
  96
  97 : remove-overflow-check ( #call -- #call )
  98     [ no-overflow-variant ] change-word cleanup-tree* ;
  99
 100 M: #call cleanup-tree*
 101     {
 102         { [ dup body>> ] [ cleanup-inlining ] }
 103         { [ dup cleanup-folding? ] [ cleanup-folding ] }
 104         { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
 105         [ ]
 106     } cond ;
 107
 108 : delete-unreachable-branches ( #branch -- )
 109     dup live-branches>> '[
 110         _
 111         [ [ [ drop ] [ delete-nodes ] if ] 2each ]
 112         [ select-children ]
 113         2bi
 114     ] change-children drop ;
 115
 116 : fold-only-branch ( #branch -- node/nodes )
 117     ! If only one branch is live we don't need to branch at
 118     ! all; just drop the condition value.
 119     dup live-children sift dup length {
 120         { 0 [ drop in-d>> <#drop> ] }
 121         { 1 [ first swap in-d>> <#drop> prefix ] }
 122         [ 2drop ]
 123     } case ;
 124
 125 SYMBOL: live-branches
 126
 127 : cleanup-children ( #branch -- )
 128     [ [ cleanup-tree ] map ] change-children drop ;
 129
 130 M: #branch cleanup-tree*
 131     {
 132         [ delete-unreachable-branches ]
 133         [ cleanup-children ]
 134         [ fold-only-branch ]
 135         [ live-branches>> live-branches set ]
 136     } cleave ;
 137
 138 : output-fs ( values -- nodes )
 139     [ f swap <#push> ] map ;
 140
 141 : eliminate-single-phi ( #phi -- node )
 142     [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
 143     [ [ drop ] [ output-fs ] bi* ]
 144     [ <#copy> ]
 145     if ;
 146
 147 : eliminate-phi ( #phi -- node )
 148     live-branches get sift length {
 149         { 0 [ out-d>> output-fs ] }
 150         { 1 [ eliminate-single-phi ] }
 151         [ drop ]
 152     } case ;
 153
 154 M: #phi cleanup-tree*
 155     ! Remove #phi function inputs which no longer exist.
 156     live-branches get
 157     [ '[ _ sift-children ] change-phi-in-d ]
 158     [ '[ _ sift-children ] change-phi-info-d ]
 159     [ '[ _ sift-children ] change-terminated ] tri
 160     eliminate-phi
 161     live-branches off ;
 162
 163 : >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi <#copy> ;
 164
 165 : flatten-recursive ( #recursive -- nodes )
 166     ! convert #enter-recursive and #return-recursive into
 167     ! #copy nodes.
 168     child>>
 169     unclip >copy prefix
 170     unclip-last >copy suffix ;
 171
 172 M: #recursive cleanup-tree*
 173     ! Inline bodies of #recursive blocks with no calls left.
 174     [ cleanup-tree ] change-child
 175     dup label>> calls>> empty? [ flatten-recursive ] when ;
 176
 177 M: #alien-callback cleanup-tree*
 178     [ cleanup-tree ] change-child ;
 179
 180 M: node cleanup-tree* ;