unfinished/compiler/cfg/builder/builder.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel assocs sequences sequences.lib fry accessors
   4 namespaces math combinators math.order
   5 compiler.tree
   6 compiler.tree.combinators
   7 compiler.tree.propagation.info
   8 compiler.cfg
   9 compiler.vops
  10 compiler.vops.builder ;
  11 IN: compiler.cfg.builder
  12
  13 ! Convert tree SSA IR to CFG SSA IR.
  14
  15 ! We construct the graph and set successors first, then we
  16 ! set predecessors in a separate pass. This simplifies the
  17 ! logic.
  18
  19 SYMBOL: procedures
  20
  21 SYMBOL: loop-nesting
  22
  23 SYMBOL: values>vregs
  24
  25 GENERIC: convert ( node -- )
  26
  27 M: #introduce convert drop ;
  28
  29 : init-builder ( -- )
  30     H{ } clone values>vregs set ;
  31
  32 : end-basic-block ( -- )
  33     basic-block get [ %b emit ] when ;
  34
  35 : set-basic-block ( basic-block -- )
  36     [ basic-block set ] [ instructions>> building set ] bi ;
  37
  38 : begin-basic-block ( -- )
  39     <basic-block> basic-block get
  40     [
  41         end-basic-block
  42         dupd successors>> push
  43     ] when*
  44     set-basic-block ;
  45
  46 : convert-nodes ( node -- )
  47     [ convert ] each ;
  48
  49 : (build-cfg) ( node word -- )
  50     init-builder
  51     begin-basic-block
  52     basic-block get swap procedures get set-at
  53     convert-nodes ;
  54
  55 : build-cfg ( node word -- procedures )
  56     H{ } clone [
  57         procedures [ (build-cfg) ] with-variable
  58     ] keep ;
  59
  60 : value>vreg ( value -- vreg )
  61     values>vregs get at ;
  62
  63 : output-vreg ( value vreg -- )
  64     swap values>vregs get set-at ;
  65
  66 : produce-vreg ( value -- vreg )
  67     next-vreg [ output-vreg ] keep ;
  68
  69 : (load-inputs) ( seq stack -- )
  70     over empty? [ 2drop ] [
  71         [ <reversed> ] dip
  72         [ '[ produce-vreg _ , %peek emit ] each-index ]
  73         [ [ length neg ] dip %height emit ]
  74         2bi
  75     ] if ;
  76
  77 : load-in-d ( node -- ) in-d>> %data (load-inputs) ;
  78
  79 : load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
  80
  81 : (store-outputs) ( seq stack -- )
  82     over empty? [ 2drop ] [
  83         [ <reversed> ] dip
  84         [ [ length ] dip %height emit ]
  85         [ '[ value>vreg _ , %replace emit ] each-index ]
  86         2bi
  87     ] if ;
  88
  89 : store-out-d ( node -- ) out-d>> %data (store-outputs) ;
  90
  91 : store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
  92
  93 : (emit-call) ( word -- )
  94     begin-basic-block %call emit begin-basic-block ;
  95
  96 : intrinsic-inputs ( node -- )
  97     [ load-in-d ]
  98     [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
  99     bi ;
 100
 101 : intrinsic-outputs ( node -- )
 102     [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
 103     [ store-out-d ]
 104     bi ;
 105
 106 : intrinsic ( node quot -- )
 107     [
 108         init-intrinsic
 109
 110         [ intrinsic-inputs ]
 111         swap
 112         [ intrinsic-outputs ]
 113         tri
 114     ] with-scope ; inline
 115
 116 USING: kernel.private math.private slots.private ;
 117
 118 : maybe-emit-fixnum-shift-fast ( node -- node )
 119     dup dup in-d>> second node-value-info literal>> dup fixnum? [
 120         '[ , emit-fixnum-shift-fast ] intrinsic
 121     ] [
 122         drop dup word>> (emit-call)
 123     ] if ;
 124
 125 : emit-call ( node -- )
 126     dup word>> {
 127         { \ tag [ [ emit-tag ] intrinsic ] }
 128
 129         { \ slot [ [ dup emit-slot ] intrinsic ] }
 130         { \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
 131
 132         { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
 133         { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
 134         { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
 135         { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
 136         { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
 137         { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
 138         { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
 139         { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
 140         { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
 141         { \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
 142         { \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
 143         { \ eq? [ [ emit-eq? ] intrinsic ] }
 144
 145         { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
 146
 147         { \ float+ [ [ emit-float+ ] intrinsic ] }
 148         { \ float- [ [ emit-float- ] intrinsic ] }
 149         { \ float* [ [ emit-float* ] intrinsic ] }
 150         { \ float/f [ [ emit-float/f ] intrinsic ] }
 151         { \ float<= [ [ emit-float<= ] intrinsic ] }
 152         { \ float>= [ [ emit-float>= ] intrinsic ] }
 153         { \ float< [ [ emit-float< ] intrinsic ] }
 154         { \ float> [ [ emit-float> ] intrinsic ] }
 155         { \ float? [ [ emit-float= ] intrinsic ] }
 156
 157         ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
 158         ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
 159         ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
 160
 161         [ (emit-call) ]
 162     } case drop ;
 163
 164 M: #call convert emit-call ;
 165
 166 : emit-call-loop ( #recursive -- )
 167     dup label>> loop-nesting get at basic-block get successors>> push
 168     end-basic-block
 169     basic-block off
 170     drop ;
 171
 172 : emit-call-recursive ( #recursive -- )
 173     label>> id>> (emit-call) ;
 174
 175 M: #call-recursive convert
 176     dup label>> loop?>>
 177     [ emit-call-loop ] [ emit-call-recursive ] if ;
 178
 179 M: #push convert
 180     [
 181         [ out-d>> first produce-vreg ]
 182         [ node-output-infos first literal>> ]
 183         bi emit-literal
 184     ]
 185     [ store-out-d ] bi ;
 186
 187 M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
 188
 189 M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
 190
 191 M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
 192
 193 M: #terminate convert drop ;
 194
 195 : integer-conditional ( in1 in2 cc -- )
 196     [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
 197
 198 : float-conditional ( in1 in2 branch -- )
 199     [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
 200
 201 : emit-if ( #if -- )
 202     in-d>> first value>vreg
 203     next-vreg dup f emit-literal
 204     cc/= integer-conditional ;
 205
 206 : convert-nested ( node -- last-bb )
 207     [
 208         <basic-block>
 209         [ set-basic-block ] keep
 210         [ convert-nodes end-basic-block ] dip
 211         basic-block get
 212     ] with-scope
 213     [ basic-block get successors>> push ] dip ;
 214
 215 : convert-if-children ( #if -- )
 216     children>> [ convert-nested ] map sift
 217     <basic-block>
 218     [ '[ , _ successors>> push ] each ]
 219     [ set-basic-block ]
 220     bi ;
 221
 222 M: #if convert
 223     [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
 224
 225 M: #dispatch convert
 226     "Unimplemented" throw ;
 227
 228 M: #phi convert drop ;
 229
 230 M: #declare convert drop ;
 231
 232 M: #return convert drop %return emit ;
 233
 234 : convert-recursive ( #recursive -- )
 235     [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
 236     [ (emit-call) ]
 237     bi ;
 238
 239 : begin-loop ( #recursive -- )
 240     label>> basic-block get 2array loop-nesting get push ;
 241
 242 : end-loop ( -- )
 243     loop-nesting get pop* ;
 244
 245 : convert-loop ( #recursive -- )
 246     begin-basic-block
 247     [ begin-loop ]
 248     [ child>> convert-nodes ]
 249     [ drop end-loop ]
 250     tri ;
 251
 252 M: #recursive convert
 253     dup label>> loop?>>
 254     [ convert-loop ] [ convert-recursive ] if ;
 255
 256 M: #copy convert drop ;