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 : with-dummy-cfg-builder ( node quot -- )
  49     [
  50         [ V{ } clone procedures ] 2dip
  51         '[ _ t t [ _ call( node -- ) ] with-cfg-builder ] with-variable
  52     ] { } make drop ;
  53
  54 GENERIC: emit-node ( node -- )
  55
  56 : emit-nodes ( nodes -- )
  57     [ basic-block get [ emit-node ] [ drop ] if ] each ;
  58
  59 : begin-word ( -- )
  60     ##prologue
  61     ##branch
  62     begin-basic-block ;
  63
  64 : (build-cfg) ( nodes word label -- )
  65     [
  66         begin-word
  67         emit-nodes
  68     ] with-cfg-builder ;
  69
  70 : build-cfg ( nodes word -- procedures )
  71     V{ } clone [
  72         procedures [
  73             dup (build-cfg)
  74         ] with-variable
  75     ] keep ;
  76
  77 : emit-loop-call ( basic-block -- )
  78     ##branch
  79     basic-block get successors>> push
  80     end-basic-block ;
  81
  82 : emit-call ( word height -- )
  83     over loops get key?
  84     [ drop loops get at emit-loop-call ]
  85     [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
  86     if ;
  87
  88 ! #recursive
  89 : recursive-height ( #recursive -- n )
  90     [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
  91
  92 : emit-recursive ( #recursive -- )
  93     [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
  94     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
  95
  96 : remember-loop ( label -- )
  97     basic-block get swap loops get set-at ;
  98
  99 : emit-loop ( node -- )
 100     ##branch
 101     begin-basic-block
 102     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
 103
 104 M: #recursive emit-node
 105     dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
 106
 107 ! #if
 108 : emit-branch ( obj -- final-bb )
 109     [ emit-nodes ] with-branch ;
 110
 111 : emit-if ( node -- )
 112     children>> [ emit-branch ] map emit-conditional ;
 113
 114 : trivial-branch? ( nodes -- value ? )
 115     dup length 1 = [
 116         first dup #push? [ literal>> t ] [ drop f f ] if
 117     ] [ drop f f ] if ;
 118
 119 : trivial-if? ( #if -- ? )
 120     children>> first2
 121     [ trivial-branch? [ t eq? ] when ]
 122     [ trivial-branch? [ f eq? ] when ] bi*
 123     and ;
 124
 125 : emit-trivial-if ( -- )
 126     ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
 127
 128 : trivial-not-if? ( #if -- ? )
 129     children>> first2
 130     [ trivial-branch? [ f eq? ] when ]
 131     [ trivial-branch? [ t eq? ] when ] bi*
 132     and ;
 133
 134 : emit-trivial-not-if ( -- )
 135     ds-pop \ f type-number cc= ^^compare-imm ds-push ;
 136
 137 : emit-actual-if ( #if -- )
 138     ! Inputs to the final instruction need to be copied because of
 139     ! loc>vreg sync
 140     ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
 141
 142 M: #if emit-node
 143     {
 144         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
 145         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
 146         [ emit-actual-if ]
 147     } cond ;
 148
 149 ! #dispatch
 150 M: #dispatch emit-node
 151     ! Inputs to the final instruction need to be copied because of
 152     ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
 153     ! though.
 154     ds-pop ^^offset>slot next-vreg ##dispatch emit-if ;
 155
 156 ! #call
 157 M: #call emit-node
 158     dup word>> dup "intrinsic" word-prop
 159     [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 160
 161 ! #call-recursive
 162 M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 163
 164 ! #push
 165 M: #push emit-node
 166     literal>> ^^load-literal ds-push ;
 167
 168 ! #shuffle
 169
 170 ! Even though low level IR has its own dead code elimination pass,
 171 ! we try not to introduce useless ##peeks here, since this reduces
 172 ! the accuracy of global stack analysis.
 173
 174 : make-input-map ( #shuffle -- assoc )
 175     ! Assoc maps high-level IR values to stack locations.
 176     [
 177         [ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
 178         [ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
 179     ] H{ } make-assoc ;
 180
 181 : make-output-seq ( values mapping input-map -- vregs )
 182     '[ _ at _ at peek-loc ] map ;
 183
 184 : load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
 185     [ [ out-d>> ] 2dip make-output-seq ]
 186     [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
 187
 188 : store-shuffle ( #shuffle ds-vregs rs-vregs -- )
 189     [ [ in-d>> length neg inc-d ] dip ds-store ]
 190     [ [ in-r>> length neg inc-r ] dip rs-store ]
 191     bi-curry* bi ;
 192
 193 M: #shuffle emit-node
 194     dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
 195
 196 ! #return
 197 : emit-return ( -- )
 198     ##branch begin-basic-block ##epilogue ##return ;
 199
 200 M: #return emit-node drop emit-return ;
 201
 202 M: #return-recursive emit-node
 203     label>> id>> loops get key? [ emit-return ] unless ;
 204
 205 ! #terminate
 206 M: #terminate emit-node drop ##no-tco end-basic-block ;
 207
 208 ! FFI
 209 : return-size ( ctype -- n )
 210     #! Amount of space we reserve for a return value.
 211     {
 212         { [ dup c-struct? not ] [ drop 0 ] }
 213         { [ dup large-struct? not ] [ drop 2 cells ] }
 214         [ heap-size ]
 215     } cond ;
 216
 217 : <alien-stack-frame> ( params -- stack-frame )
 218     stack-frame new
 219         swap
 220         [ return>> return-size >>return ]
 221         [ alien-parameters parameter-offsets drop >>params ] bi
 222         t >>calls-vm? ;
 223
 224 : alien-node-height ( params -- )
 225     [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
 226
 227 : emit-alien-node ( node quot -- )
 228     [
 229         [ params>> dup dup <alien-stack-frame> ] dip call
 230         alien-node-height
 231     ] emit-trivial-block ; inline
 232
 233 M: #alien-invoke emit-node
 234     [ ##alien-invoke ] emit-alien-node ;
 235
 236 M: #alien-indirect emit-node
 237     [ ##alien-indirect ] emit-alien-node ;
 238
 239 M: #alien-callback emit-node
 240     dup params>> xt>> dup
 241     [
 242         ##prologue
 243         dup [ ##alien-callback ] emit-alien-node
 244         ##epilogue
 245         params>> ##callback-return
 246     ] with-cfg-builder ;
 247
 248 ! No-op nodes
 249 M: #introduce emit-node drop ;
 250
 251 M: #copy emit-node drop ;
 252
 253 M: #enter-recursive emit-node drop ;
 254
 255 M: #phi emit-node drop ;
 256
 257 M: #declare emit-node drop ;