basis/compiler/tree/cleanup/cleanup.factor

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