core/compiler/generator/templates.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: compiler
   4 USING: arrays generic hashtables inference io kernel math
   5 namespaces prettyprint sequences vectors words ;
   6
   7 ! Set this to t so that end-basic-block compiles a GC check
   8 : maybe-gc ( n -- ) \ maybe-gc get push ;
   9
  10 ! Register allocation
  11
  12 ! Hash mapping reg-classes to mutable vectors
  13 : free-vregs ( reg-class -- seq ) \ free-vregs get hash ;
  14
  15 : alloc-reg ( reg-class -- vreg ) free-vregs pop ;
  16
  17 : take-reg ( vreg -- ) dup delegate free-vregs delete ;
  18
  19 : reg-spec>class ( spec -- class )
  20     float eq? T{ float-regs f 8 } T{ int-regs } ? ;
  21
  22 : spec>vreg ( spec -- vreg )
  23     dup integer? [
  24         <int-vreg> dup take-reg
  25     ] [
  26         reg-spec>class alloc-reg
  27     ] if ;
  28
  29 ! A data stack location.
  30 TUPLE: ds-loc n ;
  31
  32 ! A call stack location.
  33 TUPLE: cs-loc n ;
  34
  35 UNION: loc ds-loc cs-loc ;
  36
  37 TUPLE: phantom-stack height ;
  38
  39 C: phantom-stack ( -- stack )
  40     0 over set-phantom-stack-height
  41     V{ } clone over set-delegate ;
  42
  43 GENERIC: finalize-height ( stack -- )
  44
  45 GENERIC: <loc> ( n stack -- loc )
  46
  47 : (loc)
  48     #! Utility for methods on <loc>
  49     phantom-stack-height - ;
  50
  51 : (finalize-height) ( stack word -- )
  52     #! We consolidate multiple stack height changes until the
  53     #! last moment, and we emit the final height changing
  54     #! instruction here.
  55     swap [
  56         phantom-stack-height
  57         dup zero? [ 2drop ] [ swap execute ] if
  58         0
  59     ] keep set-phantom-stack-height ; inline
  60
  61 TUPLE: phantom-datastack ;
  62
  63 C: phantom-datastack
  64     [ >r <phantom-stack> r> set-delegate ] keep ;
  65
  66 M: phantom-datastack <loc> (loc) <ds-loc> ;
  67
  68 M: phantom-datastack finalize-height
  69     \ %inc-d (finalize-height) ;
  70
  71 TUPLE: phantom-callstack ;
  72
  73 C: phantom-callstack
  74     [ >r <phantom-stack> r> set-delegate ] keep ;
  75
  76 M: phantom-callstack <loc> (loc) <cs-loc> ;
  77
  78 M: phantom-callstack finalize-height
  79     \ %inc-r (finalize-height) ;
  80
  81 : phantom-locs ( n phantom -- locs )
  82     #! A sequence of n ds-locs or cs-locs indexing the stack.
  83     swap <reversed> [ swap <loc> ] map-with ;
  84
  85 : phantom-locs* ( phantom -- locs )
  86     dup length swap phantom-locs ;
  87
  88 : adjust-phantom ( n phantom -- )
  89     [ phantom-stack-height + ] keep set-phantom-stack-height ;
  90
  91 GENERIC: cut-phantom ( n phantom -- seq )
  92
  93 M: phantom-stack cut-phantom
  94     [ delegate cut* swap ] keep set-delegate ;
  95
  96 SYMBOL: phantom-d
  97 SYMBOL: phantom-r
  98
  99 : phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
 100
 101 : finalize-heights ( -- )
 102     phantoms [ finalize-height ] 2apply ;
 103
 104 : vreg>stack ( value loc -- )
 105     over loc? over not or [ 2drop ] [ %replace ] if ;
 106
 107 : vregs>stack ( phantom -- )
 108     [ dup phantom-locs* [ vreg>stack ] 2each ] keep delete-all ;
 109
 110 : (live-locs) ( seq -- seq )
 111     dup phantom-locs* [ 2array ] 2map
 112     [ first2 over loc? >r = not r> and ] subset
 113     0 <column> ;
 114
 115 : stack>new-vreg ( loc spec -- vreg )
 116     spec>vreg [ swap %peek ] keep ;
 117
 118 : live-locs ( phantom phantom -- hash )
 119     [ (live-locs) ] 2apply append prune
 120     [ dup f stack>new-vreg ] map>hash ;
 121
 122 : lazy-store ( value loc -- )
 123     over loc? [
 124         2dup =
 125         [ 2drop ] [ >r \ live-locs get hash r> vreg>stack ] if
 126     ] [
 127         2drop
 128     ] if ;
 129
 130 : flush-locs ( phantom phantom -- )
 131     2dup live-locs \ live-locs set
 132     [ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;
 133
 134 : finalize-contents ( -- )
 135     phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
 136
 137 : end-basic-block ( -- )
 138     finalize-contents finalize-heights
 139     \ maybe-gc get dup empty? [
 140         drop
 141     ] [
 142         delete-all
 143         "simple_gc" f %alien-invoke
 144     ] if ;
 145
 146 : used-vregs ( -- seq ) phantoms append [ vreg? ] subset ;
 147
 148 : (compute-free-vregs) ( used class -- vector )
 149     dup vregs length reverse [ swap <vreg> ] map-with diff
 150     >vector ;
 151
 152 : compute-free-vregs ( -- )
 153     used-vregs
 154     { T{ int-regs } T{ float-regs f 8 } }
 155     [ 2dup (compute-free-vregs) ] map>hash \ free-vregs set
 156     drop ;
 157
 158 : init-templates ( -- )
 159     V{ } clone \ maybe-gc set
 160     <phantom-datastack> phantom-d set
 161     <phantom-callstack> phantom-r set
 162     compute-free-vregs ;
 163
 164 : keep-templates ( quot -- )
 165     [
 166         V{ } clone \ maybe-gc set
 167         phantom-d [ clone ] change
 168         phantom-r [ clone ] change
 169         compute-free-vregs
 170         call
 171     ] with-scope ; inline
 172
 173 : additional-vregs ( seq seq -- n )
 174     2array phantoms 2array [ [ length ] map ] 2apply v-
 175     [ 0 max ] map sum ;
 176
 177 : free-vregs# ( -- int# float# )
 178     T{ int-regs } free-vregs length
 179     phantoms [ [ loc? ] subset length ] 2apply + -
 180     T{ float-regs f 8 } free-vregs length ;
 181
 182 : ensure-vregs ( int# float# -- )
 183     compute-free-vregs free-vregs# swapd <= >r <= r> and
 184     [ finalize-contents compute-free-vregs ] unless ;
 185
 186 : (lazy-load) ( spec value -- value )
 187     {
 188         { [ dup loc? ] [ >r spec>vreg dup r> %peek ] }
 189         { [ dup [ float-regs? ] is? ] [ nip ] }
 190         { [ over float eq? ] [ >r spec>vreg dup r> %move ] }
 191         { [ t ] [ nip ] }
 192     } cond ;
 193
 194 : lazy-load ( values template -- )
 195     dup length neg phantom-d get adjust-phantom
 196     [ first2 >r swap (lazy-load) r> set ] 2each ;
 197
 198 : compatible-vreg? ( n vreg -- ? )
 199     dup [ int-regs? ] is? [ vreg-n = ] [ 2drop f ] if ;
 200
 201 : compatible-values? ( value template -- ? )
 202     {
 203         { [ over loc? ] [ 2drop t ] }
 204         { [ dup not ] [ drop [ float-regs? ] is? not ] }
 205         { [ dup float eq? ] [ 2drop t ] }
 206         { [ dup integer? ] [ swap compatible-vreg? ] }
 207     } cond ;
 208
 209 : template-match? ( template phantom -- ? )
 210     [ <reversed> ] 2apply
 211     t [ swap first compatible-values? and ] 2reduce ;
 212
 213 : split-template ( template phantom -- slow fast )
 214     over length over length <=
 215     [ drop { } swap ] [ length swap cut* ] if ;
 216
 217 : match-template ( template -- slow fast )
 218     phantom-d get 2dup template-match?
 219     [ split-template ] [ drop { } ] if ;
 220
 221 : fast-input ( template -- )
 222     phantom-d get over length swap cut-phantom swap lazy-load ;
 223
 224 : phantom-push ( obj stack -- )
 225     1 over adjust-phantom push ;
 226
 227 : phantom-append ( seq stack -- )
 228     over length over adjust-phantom swap nappend ;
 229
 230 SYMBOL: +input+
 231 SYMBOL: +output+
 232 SYMBOL: +scratch+
 233 SYMBOL: +clobber+
 234
 235 : fix-spec ( spec -- spec )
 236     H{
 237         { +input+ { } }
 238         { +output+ { } }
 239         { +scratch+ { } }
 240         { +clobber+ { } }
 241     } swap hash-union ;
 242
 243 : output-vregs ( -- seq seq )
 244     +output+ +clobber+ [ get [ get ] map ] 2apply ;
 245
 246 : outputs-clash? ( -- ? )
 247     output-vregs append phantoms append
 248     [ swap member? ] contains-with? ;
 249
 250 : slow-input ( template -- )
 251     #! Are we loading stuff from the stack? Then flush out
 252     #! remaining vregs, not slurped in by fast-input.
 253     #! Do the outputs clash with vregs on the phantom stacks?
 254     #! Then we must flush them first.
 255     dup empty? not outputs-clash? or [ finalize-contents ] when
 256     [ length phantom-d get phantom-locs ] keep lazy-load ;
 257
 258 : requested-vregs ( template -- int# float# )
 259     dup length swap [ float eq? ] subset length [ - ] keep ;
 260
 261 : (requests-class?) ( class template -- ? )
 262     [ second reg-spec>class eq? ] contains-with? ;
 263
 264 : requests-class? ( class -- ? )
 265     dup +input+ get (requests-class?) swap
 266     +scratch+ get (requests-class?) or ;
 267
 268 : ?fp-scratch ( -- n )
 269     T{ float-regs f 8 } requests-class? 1 0 ? ;
 270
 271 : fp-scratch ( -- vreg )
 272     "fp-scratch" get [
 273         T{ int-regs } alloc-reg dup "fp-scratch" set
 274     ] unless* ;
 275
 276 : guess-vregs ( -- int# float# )
 277     +input+ get { } additional-vregs ?fp-scratch +
 278     +scratch+ get 0 <column> requested-vregs >r + r> ;
 279
 280 : alloc-scratch ( -- )
 281     +scratch+ get [ first2 >r spec>vreg r> set ] each ;
 282
 283 : template-inputs ( -- )
 284     ! Ensure we have enough to hold any new stack elements we
 285     ! will read (if any), and scratch.
 286     guess-vregs ensure-vregs
 287     ! Split the template into available (fast) parts and those
 288     ! that require allocating registers and reading the stack
 289     +input+ get match-template fast-input slow-input
 290     ! Finally allocate scratch registers
 291     alloc-scratch ;
 292
 293 : template-outputs ( -- )
 294     +output+ get [ get ] map phantom-d get phantom-append ;
 295
 296 : with-template ( quot spec -- )
 297     fix-spec [ template-inputs call template-outputs ] bind
 298     compute-free-vregs ; inline
 299
 300 : operand ( var -- op ) get v>operand ; inline
 301
 302 : unique-operands ( operands quot -- )
 303     >r [ operand ] map prune r> each ; inline