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 compiled get key? ] [ drop ] }
  17         { [ dup inlined-block? ] [ drop ] }
  18         { [ dup primitive? ] [ drop ] }
  19         [ compile-queue get push-front ]
  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         [
  76             dup "cannot-infer" word-prop [ cannot-infer-effect ] when
  77             dup "no-compile" word-prop [ cannot-infer-effect ] when
  78             dup specialized-def over dup 2array 1array infer-quot
  79             finish-word
  80         ] maybe-cannot-infer
  81     ] with-infer ;
  82
  83 : intrinsics ( #call -- quot )
  84     node-param "intrinsics" word-prop ;
  85
  86 : if-intrinsics ( #call -- quot )
  87     node-param "if-intrinsics" word-prop ;
  88
  89 ! node
  90 M: node generate-node drop iterate-next ;
  91
  92 : %jump ( word -- )
  93     dup compiling-label get eq?
  94     [ drop current-label-start get ] [ %epilogue-later ] if
  95     %jump-label ;
  96
  97 : generate-call ( label -- next )
  98     dup maybe-compile
  99     end-basic-block
 100     dup compiling-loops get at [
 101         %jump-label f
 102     ] [
 103         tail-call? [
 104             %jump f
 105         ] [
 106             0 frame-required
 107             %call
 108             iterate-next
 109         ] if
 110     ] ?if ;
 111
 112 ! #label
 113 M: #label generate-node
 114     dup node-param generate-call >r
 115     dup node-child over #label-word rot node-param generate
 116     r> ;
 117
 118 ! #loop
 119 : compiling-loop ( word -- )
 120     <label> dup resolve-label swap compiling-loops get set-at ;
 121
 122 M: #loop generate-node
 123     end-basic-block
 124     dup node-param compiling-loop
 125     node-child generate-nodes
 126     iterate-next ;
 127
 128 ! #if
 129 : end-false-branch ( label -- )
 130     tail-call? [ %return drop ] [ %jump-label ] if ;
 131
 132 : generate-branch ( node -- )
 133     [ copy-templates generate-nodes ] with-scope ;
 134
 135 : generate-if ( node label -- next )
 136     <label> [
 137         >r >r node-children first2 swap generate-branch
 138         r> r> end-false-branch resolve-label
 139         generate-branch
 140         init-templates
 141     ] keep resolve-label iterate-next ;
 142
 143 M: #if generate-node
 144     [ <label> dup %jump-f ]
 145     H{ { +input+ { { f "flag" } } } }
 146     with-template
 147     generate-if ;
 148
 149 ! #dispatch
 150 : dispatch-branch ( node word -- label )
 151     gensym [
 152         [
 153             copy-templates
 154             %save-dispatch-xt
 155             %prologue-later
 156             [ generate-nodes ] with-node-iterator
 157         ] with-generator
 158     ] keep ;
 159
 160 : dispatch-branches ( node -- )
 161     node-children [
 162         compiling-word get dispatch-branch
 163         %dispatch-label
 164     ] each ;
 165
 166 : generate-dispatch ( node -- )
 167     %dispatch dispatch-branches init-templates ;
 168
 169 M: #dispatch generate-node
 170     #! The order here is important, dispatch-branches must
 171     #! run after %dispatch, so that each branch gets the
 172     #! correct register state
 173     tail-call? [
 174         generate-dispatch iterate-next
 175     ] [
 176         compiling-word get gensym [
 177             [
 178                 init-generate-nodes
 179                 generate-dispatch
 180             ] with-generator
 181         ] keep generate-call
 182     ] if ;
 183
 184 ! #call
 185 : define-intrinsics ( word intrinsics -- )
 186     "intrinsics" set-word-prop ;
 187
 188 : define-intrinsic ( word quot assoc -- )
 189     2array 1array define-intrinsics ;
 190
 191 : define-if>branch-intrinsics ( word intrinsics -- )
 192     "if-intrinsics" set-word-prop ;
 193
 194 : if>boolean-intrinsic ( quot -- )
 195     "false" define-label
 196     "end" define-label
 197     "false" get swap call
 198     t "if-scratch" get load-literal
 199     "end" get %jump-label
 200     "false" resolve-label
 201     f "if-scratch" get load-literal
 202     "end" resolve-label
 203     "if-scratch" get phantom-push ; inline
 204
 205 : define-if>boolean-intrinsics ( word intrinsics -- )
 206     [
 207         >r [ if>boolean-intrinsic ] curry r>
 208         { { f "if-scratch" } } +scratch+ associate assoc-union
 209     ] assoc-map "intrinsics" set-word-prop ;
 210
 211 : define-if-intrinsics ( word intrinsics -- )
 212     [ +input+ associate ] assoc-map
 213     2dup define-if>branch-intrinsics
 214     define-if>boolean-intrinsics ;
 215
 216 : define-if-intrinsic ( word quot inputs -- )
 217     2array 1array define-if-intrinsics ;
 218
 219 : do-if-intrinsic ( pair -- next )
 220     <label> [
 221         swap do-template
 222         node> node-successor dup >node
 223     ] keep generate-if ;
 224
 225 : find-intrinsic ( #call -- pair/f )
 226     intrinsics find-template ;
 227
 228 : find-if-intrinsic ( #call -- pair/f )
 229     dup node-successor #if? [
 230         if-intrinsics find-template
 231     ] [
 232         drop f
 233     ] if ;
 234
 235 M: #call generate-node
 236     dup node-input-classes set-operand-classes
 237     dup find-if-intrinsic [
 238         do-if-intrinsic
 239     ] [
 240         dup find-intrinsic [
 241             do-template iterate-next
 242         ] [
 243             node-param generate-call
 244         ] ?if
 245     ] ?if ;
 246
 247 ! #call-label
 248 M: #call-label generate-node node-param generate-call ;
 249
 250 ! #push
 251 M: #push generate-node
 252     node-out-d [ value-literal <constant> phantom-push ] each
 253     iterate-next ;
 254
 255 ! #shuffle
 256 M: #shuffle generate-node
 257     node-shuffle phantom-shuffle iterate-next ;
 258
 259 M: #>r generate-node
 260     node-in-d length
 261     phantom->r
 262     iterate-next ;
 263
 264 M: #r> generate-node
 265     node-out-d length
 266     phantom-r>
 267     iterate-next ;
 268
 269 ! #return
 270 M: #return generate-node
 271     end-basic-block
 272     node-param compiling-loops get key?
 273     [ %return ] unless f ;