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