basis/compiler/cfg/builder/builder.factor

   1 ! Copyright (C) 2004, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators compiler.cfg
   4 compiler.cfg.builder.blocks compiler.cfg.comparisons compiler.cfg.hats
   5 compiler.cfg.instructions compiler.cfg.intrinsics compiler.cfg.registers
   6 compiler.cfg.stacks compiler.cfg.stacks.local compiler.tree
   7 compiler.cfg.utilities cpu.architecture fry kernel locals make math
   8 namespaces sequences words ;
   9 IN: compiler.cfg.builder
  10
  11 SYMBOL: procedures
  12 SYMBOL: loops
  13
  14 : begin-cfg ( word label -- cfg )
  15     H{ } clone loops set
  16     <basic-block> dup set-basic-block <cfg> dup cfg set ;
  17
  18 : with-cfg-builder ( nodes word label quot: ( ..a block -- ..b ) -- )
  19     '[
  20         begin-stack-analysis
  21         begin-cfg
  22         [ procedures get push ]
  23         [ entry>> @ ]
  24         [ end-stack-analysis ] tri
  25     ] with-scope ; inline
  26
  27 : with-dummy-cfg-builder ( node quot -- )
  28     [
  29         [ V{ } clone procedures ] 2dip
  30         '[ _ t t [ drop _ call( node -- ) ] with-cfg-builder ] with-variable
  31     ] { } make drop ;
  32
  33 GENERIC: emit-node ( block node -- block' )
  34
  35 : emit-nodes ( block nodes -- block' )
  36     [ over [ emit-node ] [ drop ] if ] each ;
  37
  38 : begin-word ( block -- block' )
  39     t >>kill-block?
  40     ##safepoint, ##prologue, ##branch,
  41     begin-basic-block ;
  42
  43 : (build-cfg) ( nodes word label -- )
  44     [ begin-word swap emit-nodes drop ] with-cfg-builder ;
  45
  46 : build-cfg ( nodes word -- procedures )
  47     V{ } clone [
  48         procedures [
  49             dup (build-cfg)
  50         ] with-variable
  51     ] keep ;
  52
  53 : emit-loop-call ( successor-block current-block -- )
  54     ##safepoint, ##branch,
  55     [ swap connect-bbs ] [ end-basic-block ] bi ;
  56
  57 : emit-call ( block word height -- block' )
  58     over loops get at [
  59         2nip swap emit-loop-call f
  60     ] [ emit-trivial-call ] if* ;
  61
  62 ! #recursive
  63 : recursive-height ( #recursive -- n )
  64     [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
  65
  66 : emit-recursive ( block #recursive -- block' )
  67     [ [ label>> id>> ] [ recursive-height ] bi emit-call ] keep
  68     [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ;
  69
  70 : emit-loop ( block #recursive -- block' )
  71     ##branch, [ begin-basic-block ] dip
  72     [ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ;
  73
  74 M: #recursive emit-node ( block node -- block' )
  75     dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
  76
  77 ! #if
  78 : emit-branch ( nodes block -- pair/f )
  79     [ swap emit-nodes ] with-branch ;
  80
  81 : emit-if ( block node -- block' )
  82     children>> over '[ _ emit-branch ] map emit-conditional ;
  83
  84 : trivial-branch? ( nodes -- value ? )
  85     dup length 1 = [
  86         first dup #push? [ literal>> t ] [ drop f f ] if
  87     ] [ drop f f ] if ;
  88
  89 : trivial-if? ( #if -- ? )
  90     children>> first2
  91     [ trivial-branch? [ t eq? ] when ]
  92     [ trivial-branch? [ f eq? ] when ] bi*
  93     and ;
  94
  95 : emit-trivial-if ( -- )
  96     [ f cc/= ^^compare-imm ] unary-op ;
  97
  98 : trivial-not-if? ( #if -- ? )
  99     children>> first2
 100     [ trivial-branch? [ f eq? ] when ]
 101     [ trivial-branch? [ t eq? ] when ] bi*
 102     and ;
 103
 104 : emit-trivial-not-if ( -- )
 105     [ f cc= ^^compare-imm ] unary-op ;
 106
 107 : emit-actual-if ( block #if -- block' )
 108     ! Inputs to the final instruction need to be copied because of
 109     ! loc>vreg sync
 110     ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ;
 111
 112 M: #if emit-node ( block node -- block' )
 113     {
 114         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
 115         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
 116         [ emit-actual-if ]
 117     } cond ;
 118
 119 M: #dispatch emit-node ( block node -- block' )
 120     ! Inputs to the final instruction need to be copied because of
 121     ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
 122     ! though.
 123     ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
 124
 125 M: #call emit-node ( block node -- block' )
 126     dup word>> dup "intrinsic" word-prop [
 127         nip call( block #call -- block' )
 128     ] [ swap call-height emit-call ] if* ;
 129
 130 M: #call-recursive emit-node ( block node -- block' )
 131     [ label>> id>> ] [ call-height ] bi emit-call ;
 132
 133 M: #push emit-node ( block node -- block )
 134     literal>> ^^load-literal ds-push ;
 135
 136 ! #shuffle
 137
 138 ! Even though low level IR has its own dead code elimination pass,
 139 ! we try not to introduce useless ##peeks here, since this reduces
 140 ! the accuracy of global stack analysis.
 141
 142 : make-input-map ( #shuffle -- assoc )
 143     [ in-d>> ds-loc ] [ in-r>> rs-loc ] bi
 144     [ over length stack-locs zip ] 2bi@ append ;
 145
 146 : height-changes ( #shuffle -- height-changes )
 147     { [ out-d>> ] [ in-d>> ] [ out-r>> ] [ in-r>> ] } cleave 4array
 148     [ length ] map first4 [ - ] 2bi@ 2array ;
 149
 150 : store-height-changes ( #shuffle -- )
 151     height-changes { ds-loc rs-loc } [ new swap >>n inc-stack ] 2each ;
 152
 153 : extract-outputs ( #shuffle -- pair )
 154     [ out-d>> ] [ out-r>> ] bi 2array ;
 155
 156 : out-vregs/stack ( #shuffle -- pair )
 157     [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
 158     [ [ of of peek-loc ] 2with map ] 2with map ;
 159
 160 M: #shuffle emit-node ( block node -- block )
 161     [ out-vregs/stack ] keep store-height-changes
 162     first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ;
 163
 164 ! #return
 165 : end-word ( block -- block' )
 166     ##branch, begin-basic-block
 167     t >>kill-block?
 168     ##safepoint, ##epilogue, ##return, ;
 169
 170 M: #return emit-node ( block node -- block' )
 171     drop end-word ;
 172
 173 M: #return-recursive emit-node ( block node -- block' )
 174     label>> id>> loops get key? [ ] [ end-word ] if ;
 175
 176 ! #terminate
 177 M: #terminate emit-node ( block node -- block' )
 178     drop ##no-tco, end-basic-block f ;
 179
 180 ! No-op nodes
 181 M: #introduce emit-node drop ;
 182
 183 M: #copy emit-node drop ;
 184
 185 M: #enter-recursive emit-node drop ;
 186
 187 M: #phi emit-node drop ;
 188
 189 M: #declare emit-node drop ;