unfinished/compiler/cfg/builder/builder.factor

   1  ! Copyright (C) 2004, 2008 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 stack-checker.inlining
   5 compiler.tree
   6 compiler.tree.builder
   7 compiler.tree.combinators
   8 compiler.tree.propagation.info
   9 compiler.cfg
  10 compiler.cfg.stacks
  11 compiler.cfg.templates
  12 compiler.cfg.iterator
  13 compiler.alien
  14 compiler.instructions
  15 compiler.registers ;
  16 IN: compiler.cfg.builder
  17
  18 ! Convert tree SSA IR to CFG (not quite SSA yet) IR.
  19
  20 : set-basic-block ( basic-block -- )
  21     [ basic-block set ] [ instructions>> building set ] bi ;
  22
  23 : begin-basic-block ( -- )
  24     <basic-block> basic-block get [
  25         dupd successors>> push
  26     ] when*
  27     set-basic-block ;
  28
  29 : end-basic-block ( -- )
  30     building off
  31     basic-block off ;
  32
  33 USE: qualified
  34 FROM: compiler.generator.registers => +input+   ;
  35 FROM: compiler.generator.registers => +output+  ;
  36 FROM: compiler.generator.registers => +scratch+ ;
  37 FROM: compiler.generator.registers => +clobber+ ;
  38
  39 SYMBOL: procedures
  40
  41 SYMBOL: current-word
  42
  43 SYMBOL: current-label
  44
  45 SYMBOL: loops
  46
  47 ! Basic block after prologue, makes recursion faster
  48 SYMBOL: current-label-start
  49
  50 : add-procedure ( -- )
  51     basic-block get current-word get current-label get
  52     <procedure> procedures get push ;
  53
  54 : begin-procedure ( word label -- )
  55     end-basic-block
  56     begin-basic-block
  57     H{ } clone loops set
  58     current-label set
  59     current-word set
  60     add-procedure ;
  61
  62 : with-cfg-builder ( nodes word label quot -- )
  63     '[ begin-procedure @ ] with-scope ; inline
  64
  65 GENERIC: emit-node ( node -- next )
  66
  67 : check-basic-block ( node -- node' )
  68     basic-block get [ drop f ] unless ; inline
  69
  70 : emit-nodes ( nodes -- )
  71     [ current-node emit-node check-basic-block ] iterate-nodes
  72     finalize-phantoms ;
  73
  74 : remember-loop ( label -- )
  75     basic-block get swap loops get set-at ;
  76
  77 : begin-word ( -- )
  78     #! We store the basic block after the prologue as a loop
  79     #! labelled by the current word, so that self-recursive
  80     #! calls can skip an epilogue/prologue.
  81     init-phantoms
  82     %prologue
  83     %branch
  84     begin-basic-block
  85     current-label get remember-loop ;
  86
  87 : (build-cfg) ( nodes word label -- )
  88     [
  89         begin-word
  90         [ emit-nodes ] with-node-iterator
  91     ] with-cfg-builder ;
  92
  93 : build-cfg ( nodes word label -- procedures )
  94     V{ } clone [
  95         procedures [
  96             (build-cfg)
  97         ] with-variable
  98     ] keep ;
  99
 100 : if-intrinsics ( #call -- quot )
 101     word>> "if-intrinsics" word-prop ;
 102
 103 : local-recursive-call ( basic-block -- )
 104     %branch
 105     basic-block get successors>> push
 106     end-basic-block ;
 107
 108 : emit-call ( word -- next )
 109     finalize-phantoms
 110     {
 111         { [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
 112         { [ dup loops get key? ] [ loops get at local-recursive-call f ] }
 113         [ %epilogue %jump f ]
 114     } cond ;
 115
 116 ! #recursive
 117 : compile-recursive ( node -- next )
 118     [ label>> id>> emit-call ]
 119     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 120
 121 : compile-loop ( node -- next )
 122     finalize-phantoms
 123     begin-basic-block
 124     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
 125     iterate-next ;
 126
 127 M: #recursive emit-node
 128     dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
 129
 130 ! #if
 131 : emit-branch ( nodes -- final-bb )
 132     [
 133         begin-basic-block copy-phantoms
 134         emit-nodes
 135         basic-block get dup [ %branch ] when
 136     ] with-scope ;
 137
 138 : emit-if ( node -- next )
 139     children>> [ emit-branch ] map
 140     end-basic-block
 141     begin-basic-block
 142     basic-block get '[ [ _ swap successors>> push ] when* ] each
 143     init-phantoms
 144     iterate-next ;
 145
 146 M: #if emit-node
 147     { { f "flag" } } lazy-load first %branch-t
 148     emit-if ;
 149
 150 ! #dispatch
 151 : dispatch-branch ( nodes word -- label )
 152     gensym [
 153         [
 154             copy-phantoms
 155             %prologue
 156             [ emit-nodes ] with-node-iterator
 157             %epilogue
 158             %return
 159         ] with-cfg-builder
 160     ] keep ;
 161
 162 : dispatch-branches ( node -- )
 163     children>> [
 164         current-word get dispatch-branch
 165         %dispatch-label
 166     ] each ;
 167
 168 : emit-dispatch ( node -- )
 169     %dispatch dispatch-branches init-phantoms ;
 170
 171 M: #dispatch emit-node
 172     #! The order here is important, dispatch-branches must
 173     #! run after %dispatch, so that each branch gets the
 174     #! correct register state
 175     tail-call? [
 176         emit-dispatch iterate-next
 177     ] [
 178         current-word get gensym [
 179             [
 180                 begin-word
 181                 emit-dispatch
 182             ] with-cfg-builder
 183         ] keep emit-call
 184     ] if ;
 185
 186 ! #call
 187 : define-intrinsics ( word intrinsics -- )
 188     "intrinsics" set-word-prop ;
 189
 190 : define-intrinsic ( word quot assoc -- )
 191     2array 1array define-intrinsics ;
 192
 193 : define-if-intrinsics ( word intrinsics -- )
 194     [ +input+ associate ] assoc-map
 195     "if-intrinsics" set-word-prop ;
 196
 197 : define-if-intrinsic ( word quot inputs -- )
 198     2array 1array define-if-intrinsics ;
 199
 200 : find-intrinsic ( #call -- pair/f )
 201     word>> "intrinsics" word-prop find-template ;
 202
 203 : find-boolean-intrinsic ( #call -- pair/f )
 204     word>> "if-intrinsics" word-prop find-template ;
 205
 206 : find-if-intrinsic ( #call -- pair/f )
 207     node@ {
 208         { [ dup length 2 < ] [ 2drop f ] }
 209         { [ dup second #if? ] [ drop find-boolean-intrinsic ] }
 210         [ 2drop f ]
 211     } cond ;
 212
 213 : do-if-intrinsic ( pair -- next )
 214     [ %if-intrinsic ] apply-template skip-next emit-if ;
 215
 216 : do-boolean-intrinsic ( pair -- next )
 217     [
 218         f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
 219     ] apply-template iterate-next ;
 220
 221 : do-intrinsic ( pair -- next )
 222     [ %intrinsic ] apply-template iterate-next ;
 223
 224 : setup-operand-classes ( #call -- )
 225     node-input-infos [ class>> ] map set-operand-classes ;
 226
 227 M: #call emit-node
 228     dup setup-operand-classes
 229     dup find-if-intrinsic [ do-if-intrinsic ] [
 230         dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
 231             dup find-intrinsic [ do-intrinsic ] [
 232                 word>> emit-call
 233             ] ?if
 234         ] ?if
 235     ] ?if ;
 236
 237 ! #call-recursive
 238 M: #call-recursive emit-node label>> id>> emit-call ;
 239
 240 ! #push
 241 M: #push emit-node
 242     literal>> <constant> phantom-push iterate-next ;
 243
 244 ! #shuffle
 245 M: #shuffle emit-node
 246     shuffle-effect phantom-shuffle iterate-next ;
 247
 248 M: #>r emit-node
 249     [ in-d>> length ] [ out-r>> empty? ] bi
 250     [ phantom-drop ] [ phantom->r ] if
 251     iterate-next ;
 252
 253 M: #r> emit-node
 254     [ in-r>> length ] [ out-d>> empty? ] bi
 255     [ phantom-rdrop ] [ phantom-r> ] if
 256     iterate-next ;
 257
 258 ! #return
 259 M: #return emit-node
 260     drop finalize-phantoms %epilogue %return f ;
 261
 262 M: #return-recursive emit-node
 263     finalize-phantoms
 264     label>> id>> loops get key?
 265     [ %epilogue %return ] unless f ;
 266
 267 ! #terminate
 268 M: #terminate emit-node drop end-basic-block f ;
 269
 270 ! FFI
 271 M: #alien-invoke emit-node
 272     params>>
 273     [ alien-invoke-frame %frame-required ]
 274     [ %alien-invoke iterate-next ]
 275     bi ;
 276
 277 M: #alien-indirect emit-node
 278     params>>
 279     [ alien-invoke-frame %frame-required ]
 280     [ %alien-indirect iterate-next ]
 281     bi ;
 282
 283 M: #alien-callback emit-node
 284     params>> dup xt>> dup
 285     [ init-phantoms %alien-callback ] with-cfg-builder
 286     iterate-next ;
 287
 288 ! No-op nodes
 289 M: #introduce emit-node drop iterate-next ;
 290
 291 M: #copy emit-node drop iterate-next ;
 292
 293 M: #enter-recursive emit-node drop iterate-next ;
 294
 295 M: #phi emit-node drop iterate-next ;