core/compiler/generator/generator.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: compiler
   4 USING: arrays assembler errors generic hashtables inference
   5 kernel kernel-internals math namespaces sequences words ;
   6
   7 GENERIC: stack-reserve* ( node -- n )
   8
   9 M: object stack-reserve* drop 0 ;
  10
  11 : stack-reserve ( node -- n )
  12     0 swap [ stack-reserve* max ] each-node ;
  13
  14 : intrinsic ( #call -- quot )
  15     node-param "intrinsic" word-prop ;
  16
  17 : if-intrinsic ( #call -- quot )
  18     node-param "if-intrinsic" word-prop ;
  19
  20 DEFER: #terminal?
  21
  22 PREDICATE: #merge #terminal-merge node-successor #terminal? ;
  23
  24 PREDICATE: #values #terminal-values node-successor #terminal? ;
  25
  26 PREDICATE: #call #terminal-call
  27     dup node-successor #if?
  28     over node-successor node-successor #terminal? and
  29     swap if-intrinsic and ;
  30
  31 UNION: #terminal
  32     POSTPONE: f #return #terminal-values #terminal-merge ;
  33
  34 : tail-call? ( -- ? )
  35     node-stack get [
  36         dup #terminal-call? swap node-successor #terminal? or
  37     ] all? ;
  38
  39 : generate-code ( node quot -- )
  40     over stack-reserve %prologue call ; inline
  41
  42 : init-generator ( word -- )
  43     #! The first entry in the literal table is the word itself,
  44     #! this is for compiled call traces
  45     V{ } clone relocation-table set
  46     V{ } clone literal-table set
  47     V{ } clone label-table set
  48     V{ } clone word-table set
  49     literal-table get push ;
  50
  51 : generate-1 ( word node quot -- )
  52     #! Generate the code, then dump three vectors to pass to
  53     #! add-compiled-block.
  54     pick f save-xt [
  55         pick init-generator
  56         init-templates
  57         generate-code
  58         generate-labels
  59         relocation-table get
  60         literal-table get
  61         word-table get
  62     ] V{ } make code-format add-compiled-block save-xt ;
  63
  64 GENERIC: generate-node ( node -- next )
  65
  66 : generate-nodes ( node -- )
  67     [ node@ generate-node ] iterate-nodes end-basic-block ;
  68
  69 : generate-branch ( node -- )
  70     [ generate-nodes ] keep-templates ;
  71
  72 : generate ( word node -- )
  73     [ [ generate-nodes ] with-node-iterator ] generate-1 ;
  74
  75 ! node
  76 M: node generate-node drop iterate-next ;
  77
  78 ! #label
  79 : generate-call ( label -- next )
  80     end-basic-block
  81     tail-call? [ %jump f ] [ %call iterate-next ] if ;
  82
  83 M: #label generate-node
  84     dup node-param dup generate-call >r
  85     swap node-child generate r> ;
  86
  87 ! #if
  88 : end-false-branch ( label -- )
  89     tail-call? [ %return drop ] [ %jump-label ] if ;
  90
  91 : generate-if ( node label -- next )
  92     <label> [
  93         >r >r node-children first2 generate-branch
  94         r> r> end-false-branch resolve-label
  95         generate-branch
  96         init-templates
  97     ] keep resolve-label iterate-next ;
  98
  99 M: #if generate-node
 100     [ <label> dup %jump-t ]
 101     H{ { +input+ { { f "flag" } } } }
 102     with-template
 103     generate-if ;
 104
 105 ! #call
 106 : [with-template] ( quot template -- quot )
 107     \ with-template 3array >quotation ;
 108
 109 : define-intrinsic ( word quot template -- )
 110     [with-template] "intrinsic" set-word-prop ;
 111
 112 : define-if>branch-intrinsic ( word quot inputs -- )
 113     +input+ associate
 114     [with-template] "if-intrinsic" set-word-prop ;
 115
 116 : if>boolean-intrinsic ( quot -- )
 117     "true" define-label
 118     "end" define-label
 119     "true" get swap call
 120     f "if-scratch" get load-literal
 121     "end" get %jump-label
 122     "true" resolve-label
 123     t "if-scratch" get load-literal
 124     "end" resolve-label
 125     "if-scratch" get phantom-d get phantom-push
 126     compute-free-vregs ; inline
 127
 128 : define-if>boolean-intrinsic ( word quot inputs -- )
 129     +input+ associate
 130     { { f "if-scratch" } } +scratch+ associate
 131     hash-union
 132     >r [ if>boolean-intrinsic ] curry r>
 133     [with-template] "intrinsic" set-word-prop ;
 134
 135 : define-if-intrinsic ( word quot inputs -- )
 136     3dup define-if>branch-intrinsic define-if>boolean-intrinsic ;
 137
 138 : do-if-intrinsic ( node -- next )
 139     dup node-successor dup #if? [
 140         <label> [ rot if-intrinsic call ] keep
 141         generate-if node-successor
 142     ] [
 143         drop intrinsic call iterate-next
 144     ] if ;
 145
 146 M: #call generate-node
 147     {
 148         { [ dup if-intrinsic ] [ do-if-intrinsic ] }
 149         { [ dup intrinsic ] [ intrinsic call iterate-next ] }
 150         { [ t ] [ node-param generate-call ] }
 151     } cond ;
 152
 153 ! #call-label
 154 M: #call-label generate-node
 155     node-param generate-call ;
 156
 157 ! #dispatch
 158 : dispatch-head ( node -- label/node )
 159     #! Return a list of label/branch pairs.
 160     node-children [ <label> dup %target 2array ] map ;
 161
 162 : dispatch-body ( label/node -- )
 163     <label> swap [
 164         first2 resolve-label generate-branch
 165         dup %jump-label
 166     ] each resolve-label init-templates ;
 167
 168 M: #dispatch generate-node
 169     #! The parameter is a list of nodes, each one is a branch to
 170     #! take in case the top of stack has that type.
 171     %dispatch dispatch-head dispatch-body iterate-next ;
 172
 173 ! #push
 174 UNION: immediate fixnum POSTPONE: f ;
 175
 176 : generate-push ( node -- )
 177     >#push<
 178     dup length ?fp-scratch + 0 ensure-vregs
 179     [ f spec>vreg [ load-literal ] keep ] map
 180     phantom-d get phantom-append ;
 181
 182 M: #push generate-node
 183     generate-push iterate-next ;
 184
 185 ! #shuffle
 186 : phantom-shuffle-input ( n phantom -- seq )
 187     2dup length <= [
 188         cut-phantom
 189     ] [
 190         [ phantom-locs ] keep [ length head-slice* ] keep
 191         [ append ] keep delete-all
 192     ] if ;
 193
 194 : adjust-shuffle ( shuffle -- )
 195     effect-in length neg phantom-d get adjust-phantom ;
 196
 197 : phantom-shuffle ( shuffle -- )
 198     dup effect-in 0 additional-vregs 0 ensure-vregs
 199     [
 200         effect-in length phantom-d get phantom-shuffle-input
 201     ] keep
 202     [ shuffle* ] keep adjust-shuffle
 203     phantom-d get phantom-append ;
 204
 205 M: #shuffle generate-node
 206     node-shuffle phantom-shuffle iterate-next ;
 207
 208 M: #>r generate-node
 209     drop
 210     1 0 additional-vregs 0 ensure-vregs
 211     1 phantom-d get phantom-shuffle-input
 212     -1 phantom-d get adjust-phantom
 213     phantom-r get phantom-append
 214     iterate-next ;
 215
 216 M: #r> generate-node
 217     drop
 218     0 1 additional-vregs 0 ensure-vregs
 219     1 phantom-r get phantom-shuffle-input
 220     -1 phantom-r get adjust-phantom
 221     phantom-d get phantom-append
 222     iterate-next ;
 223
 224 ! #return
 225 M: #return generate-node drop end-basic-block %return f ;
 226
 227 ! These constants must match vm/memory.h
 228 : card-bits 7 ;
 229 : card-mark HEX: 80 ;
 230
 231 ! These constants must match vm/layouts.h
 232 : float-offset 8 float-tag - ;
 233 : string-offset 3 cells object-tag - ;