core/generator/generator.factor

   1  ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes combinators cpu.architecture
   4 effects generator.fixup generator.registers generic hashtables
   5 inference inference.backend inference.dataflow io kernel
   6 kernel.private layouts math namespaces optimizer
   7 optimizer.specializers prettyprint quotations sequences system
   8 threads words vectors sets dequeues ;
   9 IN: generator
  10
  11 SYMBOL: compile-queue
  12 SYMBOL: compiled
  13
  14 : queue-compile ( word -- )
  15     {
  16         { [ dup "forgotten" word-prop ] [ ] }
  17         { [ dup compiled get key? ] [ ] }
  18         { [ dup inlined-block? ] [ ] }
  19         { [ dup primitive? ] [ ] }
  20         [ dup compile-queue get push-front ]
  21     } cond drop ;
  22
  23 : maybe-compile ( word -- )
  24     dup compiled>> [ drop ] [ queue-compile ] if ;
  25
  26 SYMBOL: compiling-word
  27
  28 SYMBOL: compiling-label
  29
  30 SYMBOL: compiling-loops
  31
  32 ! Label of current word, after prologue, makes recursion faster
  33 SYMBOL: current-label-start
  34
  35 : compiled-stack-traces? ( -- ? ) 59 getenv ;
  36
  37 : begin-compiling ( word label -- )
  38     H{ } clone compiling-loops set
  39     compiling-label set
  40     compiling-word set
  41     compiled-stack-traces?
  42     compiling-word get f ?
  43     1vector literal-table set
  44     f compiling-label get compiled get set-at ;
  45
  46 : save-machine-code ( literals relocation labels code -- )
  47     4array compiling-label get compiled get set-at ;
  48
  49 : with-generator ( node word label quot -- )
  50     [
  51         >r begin-compiling r>
  52         { } make fixup
  53         save-machine-code
  54     ] with-scope ; inline
  55
  56 GENERIC: generate-node ( node -- next )
  57
  58 : generate-nodes ( node -- )
  59     [ node@ generate-node ] iterate-nodes end-basic-block ;
  60
  61 : init-generate-nodes ( -- )
  62     init-templates
  63     %save-word-xt
  64     %prologue-later
  65     current-label-start define-label
  66     current-label-start resolve-label ;
  67
  68 : generate ( node word label -- )
  69     [
  70         init-generate-nodes
  71         [ generate-nodes ] with-node-iterator
  72     ] with-generator ;
  73
  74 : word-dataflow ( word -- effect dataflow )
  75     [
  76         [
  77             dup "cannot-infer" word-prop [ cannot-infer-effect ] when
  78             dup "no-compile" word-prop [ cannot-infer-effect ] when
  79             dup specialized-def over dup 2array 1array infer-quot
  80             finish-word
  81         ] maybe-cannot-infer
  82     ] with-infer ;
  83
  84 : intrinsics ( #call -- quot )
  85     node-param "intrinsics" word-prop ;
  86
  87 : if-intrinsics ( #call -- quot )
  88     node-param "if-intrinsics" word-prop ;
  89
  90 ! node
  91 M: node generate-node drop iterate-next ;
  92
  93 : %jump ( word -- )
  94     dup compiling-label get eq?
  95     [ drop current-label-start get ] [ %epilogue-later ] if
  96     %jump-label ;
  97
  98 : generate-call ( label -- next )
  99     dup maybe-compile
 100     end-basic-block
 101     dup compiling-loops get at [
 102         %jump-label f
 103     ] [
 104         tail-call? [
 105             %jump f
 106         ] [
 107             0 frame-required
 108             %call
 109             iterate-next
 110         ] if
 111     ] ?if ;
 112
 113 ! #label
 114 M: #label generate-node
 115     dup node-param generate-call >r
 116     dup node-child over #label-word rot node-param generate
 117     r> ;
 118
 119 ! #loop
 120 : compiling-loop ( word -- )
 121     <label> dup resolve-label swap compiling-loops get set-at ;
 122
 123 M: #loop generate-node
 124     end-basic-block
 125     dup node-param compiling-loop
 126     node-child generate-nodes
 127     iterate-next ;
 128
 129 ! #if
 130 : end-false-branch ( label -- )
 131     tail-call? [ %return drop ] [ %jump-label ] if ;
 132
 133 : generate-branch ( node -- )
 134     [ copy-templates generate-nodes ] with-scope ;
 135
 136 : generate-if ( node label -- next )
 137     <label> [
 138         >r >r node-children first2 swap generate-branch
 139         r> r> end-false-branch resolve-label
 140         generate-branch
 141         init-templates
 142     ] keep resolve-label iterate-next ;
 143
 144 M: #if generate-node
 145     [ <label> dup %jump-f ]
 146     H{ { +input+ { { f "flag" } } } }
 147     with-template
 148     generate-if ;
 149
 150 ! #dispatch
 151 : dispatch-branch ( node word -- label )
 152     gensym [
 153         [
 154             copy-templates
 155             %save-dispatch-xt
 156             %prologue-later
 157             [ generate-nodes ] with-node-iterator
 158         ] with-generator
 159     ] keep ;
 160
 161 : dispatch-branches ( node -- )
 162     node-children [
 163         compiling-word get dispatch-branch
 164         %dispatch-label
 165     ] each ;
 166
 167 : generate-dispatch ( node -- )
 168     %dispatch dispatch-branches init-templates ;
 169
 170 M: #dispatch generate-node
 171     #! The order here is important, dispatch-branches must
 172     #! run after %dispatch, so that each branch gets the
 173     #! correct register state
 174     tail-call? [
 175         generate-dispatch iterate-next
 176     ] [
 177         compiling-word get gensym [
 178             [
 179                 init-generate-nodes
 180                 generate-dispatch
 181             ] with-generator
 182         ] keep generate-call
 183     ] if ;
 184
 185 ! #call
 186 : define-intrinsics ( word intrinsics -- )
 187     "intrinsics" set-word-prop ;
 188
 189 : define-intrinsic ( word quot assoc -- )
 190     2array 1array define-intrinsics ;
 191
 192 : define-if>branch-intrinsics ( word intrinsics -- )
 193     "if-intrinsics" set-word-prop ;
 194
 195 : if>boolean-intrinsic ( quot -- )
 196     "false" define-label
 197     "end" define-label
 198     "false" get swap call
 199     t "if-scratch" get load-literal
 200     "end" get %jump-label
 201     "false" resolve-label
 202     f "if-scratch" get load-literal
 203     "end" resolve-label
 204     "if-scratch" get phantom-push ; inline
 205
 206 : define-if>boolean-intrinsics ( word intrinsics -- )
 207     [
 208         >r [ if>boolean-intrinsic ] curry r>
 209         { { f "if-scratch" } } +scratch+ associate assoc-union
 210     ] assoc-map "intrinsics" set-word-prop ;
 211
 212 : define-if-intrinsics ( word intrinsics -- )
 213     [ +input+ associate ] assoc-map
 214     2dup define-if>branch-intrinsics
 215     define-if>boolean-intrinsics ;
 216
 217 : define-if-intrinsic ( word quot inputs -- )
 218     2array 1array define-if-intrinsics ;
 219
 220 : do-if-intrinsic ( pair -- next )
 221     <label> [
 222         swap do-template
 223         node> node-successor dup >node
 224     ] keep generate-if ;
 225
 226 : find-intrinsic ( #call -- pair/f )
 227     intrinsics find-template ;
 228
 229 : find-if-intrinsic ( #call -- pair/f )
 230     dup node-successor #if? [
 231         if-intrinsics find-template
 232     ] [
 233         drop f
 234     ] if ;
 235
 236 M: #call generate-node
 237     dup node-input-classes set-operand-classes
 238     dup find-if-intrinsic [
 239         do-if-intrinsic
 240     ] [
 241         dup find-intrinsic [
 242             do-template iterate-next
 243         ] [
 244             node-param generate-call
 245         ] ?if
 246     ] ?if ;
 247
 248 ! #call-label
 249 M: #call-label generate-node node-param generate-call ;
 250
 251 ! #push
 252 M: #push generate-node
 253     node-out-d [ value-literal <constant> phantom-push ] each
 254     iterate-next ;
 255
 256 ! #shuffle
 257 M: #shuffle generate-node
 258     node-shuffle phantom-shuffle iterate-next ;
 259
 260 M: #>r generate-node
 261     node-in-d length
 262     phantom->r
 263     iterate-next ;
 264
 265 M: #r> generate-node
 266     node-out-d length
 267     phantom-r>
 268     iterate-next ;
 269
 270 ! #return
 271 M: #return generate-node
 272     end-basic-block
 273     node-param compiling-loops get key?
 274     [ %return ] unless f ;