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 alien.structs
   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.alien ;
  23 IN: compiler.cfg.builder
  24
  25 ! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
  26 ! constructed later by calling compiler.cfg.ssa.construction:construct-ssa.
  27
  28 SYMBOL: procedures
  29 SYMBOL: loops
  30
  31 : begin-cfg ( word label -- cfg )
  32     initial-basic-block
  33     H{ } clone loops set
  34     [ basic-block get ] 2dip <cfg> dup cfg set ;
  35
  36 : begin-procedure ( word label -- )
  37     begin-cfg procedures get push ;
  38
  39 : with-cfg-builder ( nodes word label quot -- )
  40     '[
  41         begin-stack-analysis
  42         begin-procedure
  43         @
  44         end-stack-analysis
  45     ] with-scope ; inline
  46
  47 GENERIC: emit-node ( node -- )
  48
  49 : emit-nodes ( nodes -- )
  50     [ basic-block get [ emit-node ] [ drop ] if ] each ;
  51
  52 : begin-word ( -- )
  53     ##prologue
  54     ##branch
  55     begin-basic-block ;
  56
  57 : (build-cfg) ( nodes word label -- )
  58     [
  59         begin-word
  60         emit-nodes
  61     ] with-cfg-builder ;
  62
  63 : build-cfg ( nodes word -- procedures )
  64     V{ } clone [
  65         procedures [
  66             dup (build-cfg)
  67         ] with-variable
  68     ] keep ;
  69
  70 : emit-loop-call ( basic-block -- )
  71     ##branch
  72     basic-block get successors>> push
  73     end-basic-block ;
  74
  75 : emit-call ( word height -- )
  76     over loops get key?
  77     [ drop loops get at emit-loop-call ]
  78     [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
  79     if ;
  80
  81 ! #recursive
  82 : recursive-height ( #recursive -- n )
  83     [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
  84
  85 : emit-recursive ( #recursive -- )
  86     [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
  87     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
  88
  89 : remember-loop ( label -- )
  90     basic-block get swap loops get set-at ;
  91
  92 : emit-loop ( node -- )
  93     ##branch
  94     begin-basic-block
  95     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
  96
  97 M: #recursive emit-node
  98     dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
  99
 100 ! #if
 101 : emit-branch ( obj -- final-bb )
 102     [ emit-nodes ] with-branch ;
 103
 104 : emit-if ( node -- )
 105     children>> [ emit-branch ] map emit-conditional ;
 106
 107 : trivial-branch? ( nodes -- value ? )
 108     dup length 1 = [
 109         first dup #push? [ literal>> t ] [ drop f f ] if
 110     ] [ drop f f ] if ;
 111
 112 : trivial-if? ( #if -- ? )
 113     children>> first2
 114     [ trivial-branch? [ t eq? ] when ]
 115     [ trivial-branch? [ f eq? ] when ] bi*
 116     and ;
 117
 118 : emit-trivial-if ( -- )
 119     ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
 120
 121 : trivial-not-if? ( #if -- ? )
 122     children>> first2
 123     [ trivial-branch? [ f eq? ] when ]
 124     [ trivial-branch? [ t eq? ] when ] bi*
 125     and ;
 126
 127 : emit-trivial-not-if ( -- )
 128     ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
 129
 130 : emit-actual-if ( #if -- )
 131     ! Inputs to the final instruction need to be copied because of
 132     ! loc>vreg sync
 133     ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
 134
 135 M: #if emit-node
 136     {
 137         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
 138         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
 139         [ emit-actual-if ]
 140     } cond ;
 141
 142 ! #dispatch
 143 M: #dispatch emit-node
 144     ! Inputs to the final instruction need to be copied because of
 145     ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
 146     ! though.
 147     ds-pop ^^offset>slot i ##dispatch emit-if ;
 148
 149 ! #call
 150 M: #call emit-node
 151     dup word>> dup "intrinsic" word-prop
 152     [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 153
 154 ! #call-recursive
 155 M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 156
 157 ! #push
 158 M: #push emit-node
 159     literal>> ^^load-literal ds-push ;
 160
 161 ! #shuffle
 162 M: #shuffle emit-node
 163     dup
 164     H{ } clone
 165     [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
 166     [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
 167     [ nip ] 2tri
 168     [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
 169     [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
 170
 171 ! #return
 172 : emit-return ( -- )
 173     ##branch begin-basic-block ##epilogue ##return ;
 174
 175 M: #return emit-node drop emit-return ;
 176
 177 M: #return-recursive emit-node
 178     label>> id>> loops get key? [ emit-return ] unless ;
 179
 180 ! #terminate
 181 M: #terminate emit-node drop ##no-tco end-basic-block ;
 182
 183 ! FFI
 184 : return-size ( ctype -- n )
 185     #! Amount of space we reserve for a return value.
 186     {
 187         { [ dup c-struct? not ] [ drop 0 ] }
 188         { [ dup large-struct? not ] [ drop 2 cells ] }
 189         [ heap-size ]
 190     } cond ;
 191
 192 : <alien-stack-frame> ( params -- stack-frame )
 193     stack-frame new
 194         swap
 195         [ return>> return-size >>return ]
 196         [ alien-parameters parameter-sizes drop >>params ] bi ;
 197
 198 : alien-node-height ( params -- )
 199     [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
 200
 201 : emit-alien-node ( node quot -- )
 202     [
 203         [ params>> dup dup <alien-stack-frame> ] dip call
 204         alien-node-height
 205     ] emit-trivial-block ; inline
 206
 207 M: #alien-invoke emit-node
 208     [ ##alien-invoke ] emit-alien-node ;
 209
 210 M: #alien-indirect emit-node
 211     [ ##alien-indirect ] emit-alien-node ;
 212
 213 M: #alien-callback emit-node
 214     dup params>> xt>> dup
 215     [
 216         ##prologue
 217         dup [ ##alien-callback ] emit-alien-node
 218         ##epilogue
 219         params>> ##callback-return
 220     ] with-cfg-builder ;
 221
 222 ! No-op nodes
 223 M: #introduce emit-node drop ;
 224
 225 M: #copy emit-node drop ;
 226
 227 M: #enter-recursive emit-node drop ;
 228
 229 M: #phi emit-node drop ;