1 ! Copyright (C) 2006, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs classes classes.private classes.algebra
4 combinators hashtables kernel layouts math namespaces quotations
5 sequences system vectors words effects alien byte-arrays
6 accessors sets math.order cpu.architecture
7 compiler.generator.fixup ;
8 IN: compiler.generator.registers
19 GENERIC: set-operand-class ( class obj -- )
20 GENERIC: operand-class* ( operand -- class )
21 GENERIC: move-spec ( obj -- spec )
22 GENERIC: live-vregs* ( obj -- )
23 GENERIC: live-loc? ( actual current -- ? )
24 GENERIC# (lazy-load) 1 ( value spec -- value )
25 GENERIC: lazy-store ( dst src -- )
26 GENERIC: minimal-ds-loc* ( min obj -- min )
28 ! This will be a multimethod soon
35 : operand-class ( operand -- class )
36 operand-class* object or ;
38 ! Default implementation
39 M: value set-operand-class 2drop ;
40 M: value operand-class* drop f ;
41 M: value live-vregs* drop ;
42 M: value live-loc? 2drop f ;
43 M: value minimal-ds-loc* drop ;
44 M: value lazy-store 2drop ;
46 ! A scratch register for computations
47 TUPLE: vreg n reg-class ;
49 C: <vreg> vreg ( n reg-class -- vreg )
51 M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
52 M: vreg live-vregs* , ;
53 M: vreg move-spec reg-class>> move-spec ;
57 M: float-regs move-spec drop float ;
58 M: float-regs operand-class* drop float ;
60 ! Temporary register for stack shuffling
63 M: temp-reg move-spec drop f ;
65 INSTANCE: temp-reg value
67 ! A data stack location.
68 TUPLE: ds-loc n class ;
70 : <ds-loc> ( n -- loc ) f ds-loc boa ;
72 M: ds-loc minimal-ds-loc* n>> min ;
74 over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
76 ! A retain stack location.
77 TUPLE: rs-loc n class ;
79 : <rs-loc> ( n -- loc ) f rs-loc boa ;
81 over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
83 UNION: loc ds-loc rs-loc ;
85 M: loc operand-class* class>> ;
86 M: loc set-operand-class (>>class) ;
87 M: loc move-spec drop loc ;
91 M: f move-spec drop loc ;
94 ! A stack location which has been loaded into a register. To
95 ! read the location, we just read the register, but when time
96 ! comes to save it back to the stack, we know the register just
97 ! contains a stack value so we don't have to redundantly write
99 TUPLE: cached loc vreg ;
103 M: cached set-operand-class vreg>> set-operand-class ;
104 M: cached operand-class* vreg>> operand-class* ;
105 M: cached move-spec drop cached ;
106 M: cached live-vregs* vreg>> live-vregs* ;
107 M: cached live-loc? loc>> live-loc? ;
108 M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
111 [ "live-locs" get at %move ] [ 2drop ] if ;
112 M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
114 INSTANCE: cached value
117 TUPLE: tagged vreg class ;
119 : <tagged> ( vreg -- tagged )
122 M: tagged v>operand vreg>> v>operand ;
123 M: tagged set-operand-class (>>class) ;
124 M: tagged operand-class* class>> ;
125 M: tagged move-spec drop f ;
126 M: tagged live-vregs* vreg>> , ;
128 INSTANCE: tagged value
130 ! Unboxed alien pointers
131 TUPLE: unboxed-alien vreg ;
132 C: <unboxed-alien> unboxed-alien
133 M: unboxed-alien v>operand vreg>> v>operand ;
134 M: unboxed-alien operand-class* drop simple-alien ;
135 M: unboxed-alien move-spec class ;
136 M: unboxed-alien live-vregs* vreg>> , ;
138 INSTANCE: unboxed-alien value
140 TUPLE: unboxed-byte-array vreg ;
141 C: <unboxed-byte-array> unboxed-byte-array
142 M: unboxed-byte-array v>operand vreg>> v>operand ;
143 M: unboxed-byte-array operand-class* drop c-ptr ;
144 M: unboxed-byte-array move-spec class ;
145 M: unboxed-byte-array live-vregs* vreg>> , ;
147 INSTANCE: unboxed-byte-array value
149 TUPLE: unboxed-f vreg ;
150 C: <unboxed-f> unboxed-f
151 M: unboxed-f v>operand vreg>> v>operand ;
152 M: unboxed-f operand-class* drop \ f ;
153 M: unboxed-f move-spec class ;
154 M: unboxed-f live-vregs* vreg>> , ;
156 INSTANCE: unboxed-f value
158 TUPLE: unboxed-c-ptr vreg ;
159 C: <unboxed-c-ptr> unboxed-c-ptr
160 M: unboxed-c-ptr v>operand vreg>> v>operand ;
161 M: unboxed-c-ptr operand-class* drop c-ptr ;
162 M: unboxed-c-ptr move-spec class ;
163 M: unboxed-c-ptr live-vregs* vreg>> , ;
165 INSTANCE: unboxed-c-ptr value
168 TUPLE: constant value ;
169 C: <constant> constant
170 M: constant operand-class* value>> class ;
171 M: constant move-spec class ;
173 INSTANCE: constant value
177 ! Moving values between locations and registers
178 : %move-bug ( -- * ) "Bug in generator.registers" throw ;
180 : %unbox-c-ptr ( dst src -- )
182 { [ dup \ f class<= ] [ drop %unbox-f ] }
183 { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
184 { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
185 [ drop %unbox-any-c-ptr ]
188 : %move-via-temp ( dst src -- )
189 #! For many transfers, such as loc to unboxed-alien, we
190 #! don't have an intrinsic, so we transfer the source to
191 #! temp then temp to the destination.
193 operand-class temp-reg
199 : %move ( dst src -- )
200 2dup [ move-spec ] bi@ 2array {
201 { { f f } [ %move-bug ] }
202 { { f unboxed-c-ptr } [ %move-bug ] }
203 { { f unboxed-byte-array } [ %move-bug ] }
205 { { f constant } [ value>> swap load-literal ] }
207 { { f float } [ %box-float ] }
208 { { f unboxed-alien } [ %box-alien ] }
209 { { f loc } [ %peek ] }
211 { { float f } [ %unbox-float ] }
212 { { unboxed-alien f } [ %unbox-alien ] }
213 { { unboxed-byte-array f } [ %unbox-byte-array ] }
214 { { unboxed-f f } [ %unbox-f ] }
215 { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
216 { { loc f } [ swap %replace ] }
218 [ drop %move-via-temp ]
221 ! A compile-time stack
222 TUPLE: phantom-stack height stack ;
224 M: phantom-stack clone
225 call-next-method [ clone ] change-stack ;
227 GENERIC: finalize-height ( stack -- )
229 : new-phantom-stack ( class -- stack )
230 >r 0 V{ } clone r> boa ; inline
232 : (loc) ( m stack -- n )
233 #! Utility for methods on <loc>
236 : (finalize-height) ( stack word -- )
237 #! We consolidate multiple stack height changes until the
238 #! last moment, and we emit the final height changing
241 over zero? [ 2drop ] [ execute ] if 0
242 ] curry change-height drop ; inline
244 GENERIC: <loc> ( n stack -- loc )
246 TUPLE: phantom-datastack < phantom-stack ;
248 : <phantom-datastack> ( -- stack )
249 phantom-datastack new-phantom-stack ;
251 M: phantom-datastack <loc> (loc) <ds-loc> ;
253 M: phantom-datastack finalize-height
254 \ %inc-d (finalize-height) ;
256 TUPLE: phantom-retainstack < phantom-stack ;
258 : <phantom-retainstack> ( -- stack )
259 phantom-retainstack new-phantom-stack ;
261 M: phantom-retainstack <loc> (loc) <rs-loc> ;
263 M: phantom-retainstack finalize-height
264 \ %inc-r (finalize-height) ;
266 : phantom-locs ( n phantom -- locs )
267 #! A sequence of n ds-locs or rs-locs indexing the stack.
268 >r <reversed> r> [ <loc> ] curry map ;
270 : phantom-locs* ( phantom -- locs )
271 [ stack>> length ] keep phantom-locs ;
273 : phantoms ( -- phantom phantom )
274 phantom-datastack get phantom-retainstack get ;
276 : (each-loc) ( phantom quot -- )
277 >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
279 : each-loc ( quot -- )
280 phantoms 2array swap [ (each-loc) ] curry each ; inline
282 : adjust-phantom ( n phantom -- )
283 swap [ + ] curry change-height drop ;
285 : cut-phantom ( n phantom -- seq )
286 swap [ cut* swap ] curry change-stack drop ;
288 : phantom-append ( seq stack -- )
289 over length over adjust-phantom stack>> push-all ;
291 : add-locs ( n phantom -- )
292 2dup stack>> length <= [
295 [ phantom-locs ] keep
296 [ stack>> length head-slice* ] keep
297 [ append >vector ] change-stack drop
300 : phantom-input ( n phantom -- seq )
303 >r >r neg r> adjust-phantom r> ;
305 : each-phantom ( quot -- ) phantoms rot bi@ ; inline
307 : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
309 : live-vregs ( -- seq )
310 [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
312 : (live-locs) ( phantom -- seq )
313 #! Discard locs which haven't moved
314 [ phantom-locs* ] [ stack>> ] bi zip
315 [ live-loc? ] assoc-filter
318 : live-locs ( -- seq )
319 [ (live-locs) ] each-phantom append prune ;
321 ! Operands holding pointers to freshly-allocated objects which
322 ! are guaranteed to be in the nursery
323 SYMBOL: fresh-objects
325 ! Computing free registers and initializing allocator
326 : reg-spec>class ( spec -- class )
327 float eq? double-float-regs int-regs ? ;
329 : free-vregs ( reg-class -- seq )
330 #! Free vregs in a given register class
331 \ free-vregs get at ;
333 : alloc-vreg ( spec -- reg )
334 [ reg-spec>class free-vregs pop ] keep {
336 { unboxed-alien [ <unboxed-alien> ] }
337 { unboxed-byte-array [ <unboxed-byte-array> ] }
338 { unboxed-f [ <unboxed-f> ] }
339 { unboxed-c-ptr [ <unboxed-c-ptr> ] }
343 : compatible? ( value spec -- ? )
346 { [ dup unboxed-c-ptr eq? ] [
347 over { unboxed-byte-array unboxed-alien } member?
352 : allocation ( value spec -- reg-class )
354 { [ dup quotation? ] [ 2drop f ] }
355 { [ 2dup compatible? ] [ 2drop f ] }
356 [ nip reg-spec>class ]
359 : alloc-vreg-for ( value spec -- vreg )
360 alloc-vreg swap operand-class
361 over tagged? [ >>class ] [ drop ] if ;
365 dupd alloc-vreg-for dup rot %move
370 : (compute-free-vregs) ( used class -- vector )
371 #! Find all vregs in 'class' which are not in 'used'.
372 [ vregs length reverse ] keep
373 [ <vreg> ] curry map swap diff
376 : compute-free-vregs ( -- )
377 #! Create a new hashtable for thee free-vregs variable.
379 { int-regs double-float-regs }
380 [ 2dup (compute-free-vregs) ] H{ } map>assoc
385 2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
387 : do-shuffle ( hash -- )
392 [ lazy-store ] each-loc
395 : fast-shuffle ( locs -- )
396 #! We have enough free registers to load all shuffle inputs
398 [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
400 : minimal-ds-loc ( phantom -- n )
401 #! When shuffling more values than can fit in registers, we
402 #! need to find an area on the data stack which isn't in
404 [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
406 : find-tmp-loc ( -- n )
407 #! Find an area of the data stack which is not referenced
408 #! from the phantom stacks. We can clobber there all we want
409 [ minimal-ds-loc ] each-phantom min 1- ;
411 : slow-shuffle-mapping ( locs tmp -- pairs )
413 [ swap - <ds-loc> ] curry map zip ;
415 : slow-shuffle ( locs -- )
416 #! We don't have enough free registers to load all shuffle
417 #! inputs, so we use a single temporary register, together
418 #! with the area of the data stack above the stack pointer
419 find-tmp-loc slow-shuffle-mapping [
421 swap dup cached? [ vreg>> ] when %move
423 ] keep >hashtable do-shuffle ;
425 : fast-shuffle? ( live-locs -- ? )
426 #! Test if we have enough free registers to load all
427 #! shuffle inputs at once.
428 int-regs free-vregs [ length ] bi@ <= ;
430 : finalize-locs ( -- )
431 #! Perform any deferred stack shuffling.
433 \ free-vregs [ [ clone ] assoc-map ] change
434 live-locs dup fast-shuffle?
435 [ fast-shuffle ] [ slow-shuffle ] if
438 : finalize-vregs ( -- )
439 #! Store any vregs to their final stack locations.
441 dup loc? over cached? or [ 2drop ] [ %move ] if
444 : reset-phantom ( phantom -- )
445 #! Kill register assignments but preserve constants and
446 #! class information.
449 dup constant? [ nip ] [
450 operand-class over set-operand-class
453 over stack>> delete-all
454 swap stack>> push-all ;
456 : reset-phantoms ( -- )
457 [ reset-phantom ] each-phantom ;
459 : finalize-contents ( -- )
460 finalize-locs finalize-vregs reset-phantoms ;
462 ! Loading stacks to vregs
463 : free-vregs? ( int# float# -- ? )
464 double-float-regs free-vregs length <=
465 >r int-regs free-vregs length <= r> and ;
467 : phantom&spec ( phantom spec -- phantom' spec' )
469 [ length f pad-left ] keep
470 [ <reversed> ] bi@ ; inline
472 : phantom&spec-agree? ( phantom spec quot -- ? )
473 >r phantom&spec r> 2all? ; inline
475 : vreg-substitution ( value vreg -- pair )
476 dupd <cached> 2array ;
478 : substitute-vreg? ( old new -- ? )
479 #! We don't substitute locs for float or alien vregs,
480 #! since in those cases the boxing overhead might kill us.
481 vreg>> tagged? >r loc? r> and ;
483 : substitute-vregs ( values vregs -- )
484 [ vreg-substitution ] 2map
485 [ substitute-vreg? ] assoc-filter >hashtable
486 [ >r stack>> r> substitute-here ] curry each-phantom ;
488 : set-operand ( value var -- )
489 >r dup constant? [ value>> ] when r> set ;
491 : lazy-load ( values template -- )
492 #! Set operand vars here.
493 2dup [ first (lazy-load) ] 2map
494 dup rot [ second set-operand ] 2each
499 [ length phantom-datastack get phantom-input ] keep
502 : output-vregs ( -- seq seq )
503 +output+ +clobber+ [ get [ get ] map ] bi@ ;
505 : clash? ( seq -- ? )
506 phantoms [ stack>> ] bi@ append [
507 dup cached? [ vreg>> ] when swap member?
510 : outputs-clash? ( -- ? )
511 output-vregs append clash? ;
513 : count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
515 : count-input-vregs ( phantom spec -- )
517 >r dup cached? [ vreg>> ] when r> first allocation
520 : count-scratch-regs ( spec -- )
521 [ first reg-spec>class ] map count-vregs ;
523 : guess-vregs ( dinput rinput scratch -- int# float# )
526 0 double-float-regs set
528 phantom-retainstack get swap count-input-vregs
529 phantom-datastack get swap count-input-vregs
530 int-regs get double-float-regs get
533 : alloc-scratch ( -- )
534 +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
536 : guess-template-vregs ( -- int# float# )
537 +input+ get { } +scratch+ get guess-vregs ;
539 : template-inputs ( -- )
540 ! Load input values into registers
542 ! Allocate scratch registers
544 ! If outputs clash, we write values back to the stack
545 outputs-clash? [ finalize-contents ] when ;
547 : template-outputs ( -- )
548 +output+ get [ get ] map phantom-datastack get phantom-append ;
550 : value-matches? ( value spec -- ? )
551 #! If the spec is a quotation and the value is a literal
552 #! fixnum, see if the quotation yields true when applied
553 #! to the fixnum. Otherwise, the values don't match. If the
554 #! spec is not a quotation, its a reg-class, in which case
555 #! the value is always good.
558 [ >r value>> r> call ] [ 2drop f ] if
563 : class-matches? ( actual expected -- ? )
566 { known-tag [ dup [ class-tag >boolean ] when ] }
570 : spec-matches? ( value spec -- ? )
571 2dup first value-matches?
572 >r >r operand-class 2 r> ?nth class-matches? r> and ;
574 : template-matches? ( spec -- ? )
575 phantom-datastack get +input+ rot at
576 [ spec-matches? ] phantom&spec-agree? ;
578 : ensure-template-vregs ( -- )
579 guess-template-vregs free-vregs? [
580 finalize-contents compute-free-vregs
583 : clear-phantoms ( -- )
584 [ stack>> delete-all ] each-phantom ;
588 : set-operand-classes ( classes -- )
589 phantom-datastack get
590 over length over add-locs
591 stack>> [ set-operand-class ] 2reverse-each ;
593 : end-basic-block ( -- )
594 #! Commit all deferred stacking shuffling, and ensure the
595 #! in-memory data and retain stacks are up to date with
596 #! respect to the compiler's current picture.
600 fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
602 : with-template ( quot hash -- )
604 ensure-template-vregs
605 template-inputs call template-outputs
607 compute-free-vregs ; inline
609 : do-template ( pair -- )
610 #! Use with return value from find-template
611 first2 with-template ;
613 : fresh-object ( obj -- ) fresh-objects get push ;
615 : fresh-object? ( obj -- ? ) fresh-objects get memq? ;
617 : init-templates ( -- )
618 #! Initialize register allocator.
619 V{ } clone fresh-objects set
620 <phantom-datastack> phantom-datastack set
621 <phantom-retainstack> phantom-retainstack set
624 : copy-templates ( -- )
625 #! Copies register allocator state, used when compiling
627 fresh-objects [ clone ] change
628 phantom-datastack [ clone ] change
629 phantom-retainstack [ clone ] change
632 : find-template ( templates -- pair/f )
633 #! Pair has shape { quot hash }
634 [ second template-matches? ] find nip ;
636 : operand-tag ( operand -- tag/f )
637 operand-class dup [ class-tag ] when ;
639 UNION: immediate fixnum POSTPONE: f ;
641 : operand-immediate? ( operand -- ? )
642 operand-class immediate class<= ;
644 : phantom-push ( obj -- )
645 1 phantom-datastack get adjust-phantom
646 phantom-datastack get stack>> push ;
648 : phantom-shuffle ( shuffle -- )
649 [ in>> length phantom-datastack get phantom-input ] keep
650 shuffle phantom-datastack get phantom-append ;
652 : phantom->r ( n -- )
653 phantom-datastack get phantom-input
654 phantom-retainstack get phantom-append ;
656 : phantom-r> ( n -- )
657 phantom-retainstack get phantom-input
658 phantom-datastack get phantom-append ;
660 : phantom-drop ( n -- )
661 phantom-datastack get phantom-input drop ;
663 : phantom-rdrop ( n -- )
664 phantom-retainstack get phantom-input drop ;