basis/compiler/cfg/builder/builder.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators hashtables kernel
   4 math fry namespaces make sequences words byte-arrays
   5 layouts alien.c-types
   6 stack-checker.inlining cpu.architecture
   7 compiler.tree
   8 compiler.tree.builder
   9 compiler.tree.combinators
  10 compiler.tree.propagation.info
  11 compiler.cfg
  12 compiler.cfg.hats
  13 compiler.cfg.utilities
  14 compiler.cfg.registers
  15 compiler.cfg.intrinsics
  16 compiler.cfg.comparisons
  17 compiler.cfg.stack-frame
  18 compiler.cfg.instructions
  19 compiler.cfg.predecessors
  20 compiler.cfg.builder.blocks
  21 compiler.cfg.stacks
  22 compiler.cfg.stacks.local
  23 compiler.alien ;
  24 IN: compiler.cfg.builder
  25
  26 ! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
  27 ! constructed later by calling compiler.cfg.ssa.construction:construct-ssa.
  28
  29 SYMBOL: procedures
  30 SYMBOL: loops
  31
  32 : begin-cfg ( word label -- cfg )
  33     initial-basic-block
  34     H{ } clone loops set
  35     [ basic-block get ] 2dip <cfg> dup cfg set ;
  36
  37 : begin-procedure ( word label -- )
  38     begin-cfg procedures get push ;
  39
  40 : with-cfg-builder ( nodes word label quot -- )
  41     '[
  42         begin-stack-analysis
  43         begin-procedure
  44         @
  45         end-stack-analysis
  46     ] with-scope ; inline
  47
  48 GENERIC: emit-node ( node -- )
  49
  50 : emit-nodes ( nodes -- )
  51     [ basic-block get [ emit-node ] [ drop ] if ] each ;
  52
  53 : begin-word ( -- )
  54     ##prologue
  55     ##branch
  56     begin-basic-block ;
  57
  58 : (build-cfg) ( nodes word label -- )
  59     [
  60         begin-word
  61         emit-nodes
  62     ] with-cfg-builder ;
  63
  64 : build-cfg ( nodes word -- procedures )
  65     V{ } clone [
  66         procedures [
  67             dup (build-cfg)
  68         ] with-variable
  69     ] keep ;
  70
  71 : emit-loop-call ( basic-block -- )
  72     ##branch
  73     basic-block get successors>> push
  74     end-basic-block ;
  75
  76 : emit-call ( word height -- )
  77     over loops get key?
  78     [ drop loops get at emit-loop-call ]
  79     [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
  80     if ;
  81
  82 ! #recursive
  83 : recursive-height ( #recursive -- n )
  84     [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
  85
  86 : emit-recursive ( #recursive -- )
  87     [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
  88     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
  89
  90 : remember-loop ( label -- )
  91     basic-block get swap loops get set-at ;
  92
  93 : emit-loop ( node -- )
  94     ##branch
  95     begin-basic-block
  96     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
  97
  98 M: #recursive emit-node
  99     dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
 100
 101 ! #if
 102 : emit-branch ( obj -- final-bb )
 103     [ emit-nodes ] with-branch ;
 104
 105 : emit-if ( node -- )
 106     children>> [ emit-branch ] map emit-conditional ;
 107
 108 : trivial-branch? ( nodes -- value ? )
 109     dup length 1 = [
 110         first dup #push? [ literal>> t ] [ drop f f ] if
 111     ] [ drop f f ] if ;
 112
 113 : trivial-if? ( #if -- ? )
 114     children>> first2
 115     [ trivial-branch? [ t eq? ] when ]
 116     [ trivial-branch? [ f eq? ] when ] bi*
 117     and ;
 118
 119 : emit-trivial-if ( -- )
 120     ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
 121
 122 : trivial-not-if? ( #if -- ? )
 123     children>> first2
 124     [ trivial-branch? [ f eq? ] when ]
 125     [ trivial-branch? [ t eq? ] when ] bi*
 126     and ;
 127
 128 : emit-trivial-not-if ( -- )
 129     ds-pop \ f type-number cc= ^^compare-imm ds-push ;
 130
 131 : emit-actual-if ( #if -- )
 132     ! Inputs to the final instruction need to be copied because of
 133     ! loc>vreg sync
 134     ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
 135
 136 M: #if emit-node
 137     {
 138         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
 139         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
 140         [ emit-actual-if ]
 141     } cond ;
 142
 143 ! #dispatch
 144 M: #dispatch emit-node
 145     ! Inputs to the final instruction need to be copied because of
 146     ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
 147     ! though.
 148     ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
 149
 150 ! #call
 151 M: #call emit-node
 152     dup word>> dup "intrinsic" word-prop
 153     [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 154
 155 ! #call-recursive
 156 M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 157
 158 ! #push
 159 M: #push emit-node
 160     literal>> ^^load-literal ds-push ;
 161
 162 ! #shuffle
 163
 164 ! Even though low level IR has its own dead code elimination pass,
 165 ! we try not to introduce useless ##peeks here, since this reduces
 166 ! the accuracy of global stack analysis.
 167
 168 : make-input-map ( #shuffle -- assoc )
 169     ! Assoc maps high-level IR values to stack locations.
 170     [
 171         [ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
 172         [ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
 173     ] H{ } make-assoc ;
 174
 175 : make-output-seq ( values mapping input-map -- vregs )
 176     '[ _ at _ at peek-loc ] map ;
 177
 178 : load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
 179     [ [ out-d>> ] 2dip make-output-seq ]
 180     [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
 181
 182 : store-shuffle ( #shuffle ds-vregs rs-vregs -- )
 183     [ [ in-d>> length neg inc-d ] dip ds-store ]
 184     [ [ in-r>> length neg inc-r ] dip rs-store ]
 185     bi-curry* bi ;
 186
 187 M: #shuffle emit-node
 188     dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
 189
 190 ! #return
 191 : emit-return ( -- )
 192     ##branch begin-basic-block ##epilogue ##return ;
 193
 194 M: #return emit-node drop emit-return ;
 195
 196 M: #return-recursive emit-node
 197     label>> id>> loops get key? [ emit-return ] unless ;
 198
 199 ! #terminate
 200 M: #terminate emit-node drop ##no-tco end-basic-block ;
 201
 202 ! FFI
 203 : return-size ( ctype -- n )
 204     #! Amount of space we reserve for a return value.
 205     {
 206         { [ dup c-struct? not ] [ drop 0 ] }
 207         { [ dup large-struct? not ] [ drop 2 cells ] }
 208         [ heap-size ]
 209     } cond ;
 210
 211 : <alien-stack-frame> ( params -- stack-frame )
 212     stack-frame new
 213         swap
 214         [ return>> return-size >>return ]
 215         [ alien-parameters parameter-offsets drop >>params ] bi
 216         t >>calls-vm? ;
 217
 218 : alien-node-height ( params -- )
 219     [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
 220
 221 : emit-alien-node ( node quot -- )
 222     [
 223         [ params>> dup dup <alien-stack-frame> ] dip call
 224         alien-node-height
 225     ] emit-trivial-block ; inline
 226
 227 M: #alien-invoke emit-node
 228     [ ##alien-invoke ] emit-alien-node ;
 229
 230 M: #alien-indirect emit-node
 231     [ ##alien-indirect ] emit-alien-node ;
 232
 233 M: #alien-callback emit-node
 234     dup params>> xt>> dup
 235     [
 236         ##prologue
 237         dup [ ##alien-callback ] emit-alien-node
 238         ##epilogue
 239         params>> ##callback-return
 240     ] with-cfg-builder ;
 241
 242 ! No-op nodes
 243 M: #introduce emit-node drop ;
 244
 245 M: #copy emit-node drop ;
 246
 247 M: #enter-recursive emit-node drop ;
 248
 249 M: #phi emit-node drop ;
 250
 251 M: #declare emit-node drop ;