core/generator/generator.factor

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