core/generator/registers/registers.factor

   1 ! Copyright (C) 2006, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs classes classes.private classes.algebra
   4 combinators cpu.architecture generator.fixup hashtables kernel
   5 layouts math namespaces quotations sequences system vectors
   6 words effects alien byte-arrays
   7 accessors sets math.order ;
   8 IN: generator.registers
   9
  10 SYMBOL: +input+
  11 SYMBOL: +output+
  12 SYMBOL: +scratch+
  13 SYMBOL: +clobber+
  14 SYMBOL: known-tag
  15
  16 <PRIVATE
  17
  18 ! Value protocol
  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 )
  27
  28 ! This will be a multimethod soon
  29 DEFER: %move
  30
  31 MIXIN: value
  32
  33 PRIVATE>
  34
  35 : operand-class ( operand -- class )
  36     operand-class* object or ;
  37
  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 ;
  45
  46 ! A scratch register for computations
  47 TUPLE: vreg n reg-class ;
  48
  49 C: <vreg> vreg ( n reg-class -- vreg )
  50
  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 ;
  54
  55 INSTANCE: vreg value
  56
  57 M: float-regs move-spec drop float ;
  58 M: float-regs operand-class* drop float ;
  59
  60 ! Temporary register for stack shuffling
  61 SINGLETON: temp-reg
  62
  63 M: temp-reg move-spec drop f ;
  64
  65 INSTANCE: temp-reg value
  66
  67 ! A data stack location.
  68 TUPLE: ds-loc n class ;
  69
  70 : <ds-loc> ( n -- loc ) f ds-loc boa ;
  71
  72 M: ds-loc minimal-ds-loc* ds-loc-n min ;
  73 M: ds-loc operand-class* ds-loc-class ;
  74 M: ds-loc set-operand-class set-ds-loc-class ;
  75 M: ds-loc live-loc?
  76     over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
  77
  78 ! A retain stack location.
  79 TUPLE: rs-loc n class ;
  80
  81 : <rs-loc> ( n -- loc ) f rs-loc boa ;
  82 M: rs-loc operand-class* rs-loc-class ;
  83 M: rs-loc set-operand-class set-rs-loc-class ;
  84 M: rs-loc live-loc?
  85     over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
  86
  87 UNION: loc ds-loc rs-loc ;
  88
  89 M: loc move-spec drop loc ;
  90
  91 INSTANCE: loc value
  92
  93 M: f move-spec drop loc ;
  94 M: f operand-class* ;
  95
  96 ! A stack location which has been loaded into a register. To
  97 ! read the location, we just read the register, but when time
  98 ! comes to save it back to the stack, we know the register just
  99 ! contains a stack value so we don't have to redundantly write
 100 ! it back.
 101 TUPLE: cached loc vreg ;
 102
 103 C: <cached> cached
 104
 105 M: cached set-operand-class cached-vreg set-operand-class ;
 106 M: cached operand-class* cached-vreg operand-class* ;
 107 M: cached move-spec drop cached ;
 108 M: cached live-vregs* cached-vreg live-vregs* ;
 109 M: cached live-loc? cached-loc live-loc? ;
 110 M: cached (lazy-load) >r cached-vreg r> (lazy-load) ;
 111 M: cached lazy-store
 112     2dup cached-loc live-loc?
 113     [ "live-locs" get at %move ] [ 2drop ] if ;
 114 M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
 115
 116 INSTANCE: cached value
 117
 118 ! A tagged pointer
 119 TUPLE: tagged vreg class ;
 120
 121 : <tagged> ( vreg -- tagged )
 122     f tagged boa ;
 123
 124 M: tagged v>operand tagged-vreg v>operand ;
 125 M: tagged set-operand-class set-tagged-class ;
 126 M: tagged operand-class* tagged-class ;
 127 M: tagged move-spec drop f ;
 128 M: tagged live-vregs* tagged-vreg , ;
 129
 130 INSTANCE: tagged value
 131
 132 ! Unboxed alien pointers
 133 TUPLE: unboxed-alien vreg ;
 134 C: <unboxed-alien> unboxed-alien
 135 M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
 136 M: unboxed-alien operand-class* drop simple-alien ;
 137 M: unboxed-alien move-spec class ;
 138 M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
 139
 140 INSTANCE: unboxed-alien value
 141
 142 TUPLE: unboxed-byte-array vreg ;
 143 C: <unboxed-byte-array> unboxed-byte-array
 144 M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
 145 M: unboxed-byte-array operand-class* drop c-ptr ;
 146 M: unboxed-byte-array move-spec class ;
 147 M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
 148
 149 INSTANCE: unboxed-byte-array value
 150
 151 TUPLE: unboxed-f vreg ;
 152 C: <unboxed-f> unboxed-f
 153 M: unboxed-f v>operand unboxed-f-vreg v>operand ;
 154 M: unboxed-f operand-class* drop \ f ;
 155 M: unboxed-f move-spec class ;
 156 M: unboxed-f live-vregs* unboxed-f-vreg , ;
 157
 158 INSTANCE: unboxed-f value
 159
 160 TUPLE: unboxed-c-ptr vreg ;
 161 C: <unboxed-c-ptr> unboxed-c-ptr
 162 M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
 163 M: unboxed-c-ptr operand-class* drop c-ptr ;
 164 M: unboxed-c-ptr move-spec class ;
 165 M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
 166
 167 INSTANCE: unboxed-c-ptr value
 168
 169 ! A constant value
 170 TUPLE: constant value ;
 171 C: <constant> constant
 172 M: constant operand-class* constant-value class ;
 173 M: constant move-spec class ;
 174
 175 INSTANCE: constant value
 176
 177 <PRIVATE
 178
 179 ! Moving values between locations and registers
 180 : %move-bug ( -- * ) "Bug in generator.registers" throw ;
 181
 182 : %unbox-c-ptr ( dst src -- )
 183     dup operand-class {
 184         { [ dup \ f class<= ] [ drop %unbox-f ] }
 185         { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
 186         { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
 187         [ drop %unbox-any-c-ptr ]
 188     } cond ; inline
 189
 190 : %move-via-temp ( dst src -- )
 191     #! For many transfers, such as loc to unboxed-alien, we
 192     #! don't have an intrinsic, so we transfer the source to
 193     #! temp then temp to the destination.
 194     temp-reg over %move
 195     operand-class temp-reg
 196     tagged new
 197         swap >>vreg
 198         swap >>class
 199     %move ;
 200
 201 : %move ( dst src -- )
 202     2dup [ move-spec ] bi@ 2array {
 203         { { f f } [ %move-bug ] }
 204         { { f unboxed-c-ptr } [ %move-bug ] }
 205         { { f unboxed-byte-array } [ %move-bug ] }
 206
 207         { { f constant } [ constant-value swap load-literal ] }
 208
 209         { { f float } [ %box-float ] }
 210         { { f unboxed-alien } [ %box-alien ] }
 211         { { f loc } [ %peek ] }
 212
 213         { { float f } [ %unbox-float ] }
 214         { { unboxed-alien f } [ %unbox-alien ] }
 215         { { unboxed-byte-array f } [ %unbox-byte-array ] }
 216         { { unboxed-f f } [ %unbox-f ] }
 217         { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
 218         { { loc f } [ swap %replace ] }
 219
 220         [ drop %move-via-temp ]
 221     } case ;
 222
 223 ! A compile-time stack
 224 TUPLE: phantom-stack height stack ;
 225
 226 M: phantom-stack clone
 227     call-next-method [ clone ] change-stack ;
 228
 229 GENERIC: finalize-height ( stack -- )
 230
 231 : new-phantom-stack ( class -- stack )
 232     >r 0 V{ } clone r> boa ; inline
 233
 234 : (loc) ( m stack -- n )
 235     #! Utility for methods on <loc>
 236     height>> - ;
 237
 238 : (finalize-height) ( stack word -- )
 239     #! We consolidate multiple stack height changes until the
 240     #! last moment, and we emit the final height changing
 241     #! instruction here.
 242     [
 243         over zero? [ 2drop ] [ execute ] if 0
 244     ] curry change-height drop ; inline
 245
 246 GENERIC: <loc> ( n stack -- loc )
 247
 248 TUPLE: phantom-datastack < phantom-stack ;
 249
 250 : <phantom-datastack> ( -- stack )
 251     phantom-datastack new-phantom-stack ;
 252
 253 M: phantom-datastack <loc> (loc) <ds-loc> ;
 254
 255 M: phantom-datastack finalize-height
 256     \ %inc-d (finalize-height) ;
 257
 258 TUPLE: phantom-retainstack < phantom-stack ;
 259
 260 : <phantom-retainstack> ( -- stack )
 261     phantom-retainstack new-phantom-stack ;
 262
 263 M: phantom-retainstack <loc> (loc) <rs-loc> ;
 264
 265 M: phantom-retainstack finalize-height
 266     \ %inc-r (finalize-height) ;
 267
 268 : phantom-locs ( n phantom -- locs )
 269     #! A sequence of n ds-locs or rs-locs indexing the stack.
 270     >r <reversed> r> [ <loc> ] curry map ;
 271
 272 : phantom-locs* ( phantom -- locs )
 273     [ stack>> length ] keep phantom-locs ;
 274
 275 : phantoms ( -- phantom phantom )
 276     phantom-datastack get phantom-retainstack get ;
 277
 278 : (each-loc) ( phantom quot -- )
 279     >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
 280
 281 : each-loc ( quot -- )
 282     phantoms 2array swap [ (each-loc) ] curry each ; inline
 283
 284 : adjust-phantom ( n phantom -- )
 285     swap [ + ] curry change-height drop ;
 286
 287 : cut-phantom ( n phantom -- seq )
 288     swap [ cut* swap ] curry change-stack drop ;
 289
 290 : phantom-append ( seq stack -- )
 291     over length over adjust-phantom stack>> push-all ;
 292
 293 : add-locs ( n phantom -- )
 294     2dup stack>> length <= [
 295         2drop
 296     ] [
 297         [ phantom-locs ] keep
 298         [ stack>> length head-slice* ] keep
 299         [ append >vector ] change-stack drop
 300     ] if ;
 301
 302 : phantom-input ( n phantom -- seq )
 303     2dup add-locs
 304     2dup cut-phantom
 305     >r >r neg r> adjust-phantom r> ;
 306
 307 : each-phantom ( quot -- ) phantoms rot bi@ ; inline
 308
 309 : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
 310
 311 : live-vregs ( -- seq )
 312     [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
 313
 314 : (live-locs) ( phantom -- seq )
 315     #! Discard locs which haven't moved
 316     [ phantom-locs* ] [ stack>> ] bi zip
 317     [ live-loc? ] assoc-filter
 318     values ;
 319
 320 : live-locs ( -- seq )
 321     [ (live-locs) ] each-phantom append prune ;
 322
 323 ! Operands holding pointers to freshly-allocated objects which
 324 ! are guaranteed to be in the nursery
 325 SYMBOL: fresh-objects
 326
 327 ! Computing free registers and initializing allocator
 328 : reg-spec>class ( spec -- class )
 329     float eq? double-float-regs int-regs ? ;
 330
 331 : free-vregs ( reg-class -- seq )
 332     #! Free vregs in a given register class
 333     \ free-vregs get at ;
 334
 335 : alloc-vreg ( spec -- reg )
 336     [ reg-spec>class free-vregs pop ] keep {
 337         { f [ <tagged> ] }
 338         { unboxed-alien [ <unboxed-alien> ] }
 339         { unboxed-byte-array [ <unboxed-byte-array> ] }
 340         { unboxed-f [ <unboxed-f> ] }
 341         { unboxed-c-ptr [ <unboxed-c-ptr> ] }
 342         [ drop ]
 343     } case ;
 344
 345 : compatible? ( value spec -- ? )
 346     >r move-spec r> {
 347         { [ 2dup = ] [ t ] }
 348         { [ dup unboxed-c-ptr eq? ] [
 349             over { unboxed-byte-array unboxed-alien } member?
 350         ] }
 351         [ f ]
 352     } cond 2nip ;
 353
 354 : allocation ( value spec -- reg-class )
 355     {
 356         { [ dup quotation? ] [ 2drop f ] }
 357         { [ 2dup compatible? ] [ 2drop f ] }
 358         [ nip reg-spec>class ]
 359     } cond ;
 360
 361 : alloc-vreg-for ( value spec -- vreg )
 362     alloc-vreg swap operand-class
 363     over tagged? [ >>class ] [ drop ] if ;
 364
 365 M: value (lazy-load)
 366     2dup allocation [
 367         dupd alloc-vreg-for dup rot %move
 368     ] [
 369         drop
 370     ] if ;
 371
 372 : (compute-free-vregs) ( used class -- vector )
 373     #! Find all vregs in 'class' which are not in 'used'.
 374     [ vregs length reverse ] keep
 375     [ <vreg> ] curry map swap diff
 376     >vector ;
 377
 378 : compute-free-vregs ( -- )
 379     #! Create a new hashtable for thee free-vregs variable.
 380     live-vregs
 381     { int-regs double-float-regs }
 382     [ 2dup (compute-free-vregs) ] H{ } map>assoc
 383     \ free-vregs set
 384     drop ;
 385
 386 M: loc lazy-store
 387     2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
 388
 389 : do-shuffle ( hash -- )
 390     dup assoc-empty? [
 391         drop
 392     ] [
 393         "live-locs" set
 394         [ lazy-store ] each-loc
 395     ] if ;
 396
 397 : fast-shuffle ( locs -- )
 398     #! We have enough free registers to load all shuffle inputs
 399     #! at once
 400     [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
 401
 402 : minimal-ds-loc ( phantom -- n )
 403     #! When shuffling more values than can fit in registers, we
 404     #! need to find an area on the data stack which isn't in
 405     #! use.
 406     [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
 407
 408 : find-tmp-loc ( -- n )
 409     #! Find an area of the data stack which is not referenced
 410     #! from the phantom stacks. We can clobber there all we want
 411     [ minimal-ds-loc ] each-phantom min 1- ;
 412
 413 : slow-shuffle-mapping ( locs tmp -- pairs )
 414     >r dup length r>
 415     [ swap - <ds-loc> ] curry map zip ;
 416
 417 : slow-shuffle ( locs -- )
 418     #! We don't have enough free registers to load all shuffle
 419     #! inputs, so we use a single temporary register, together
 420     #! with the area of the data stack above the stack pointer
 421     find-tmp-loc slow-shuffle-mapping [
 422         [
 423             swap dup cached? [ cached-vreg ] when %move
 424         ] assoc-each
 425     ] keep >hashtable do-shuffle ;
 426
 427 : fast-shuffle? ( live-locs -- ? )
 428     #! Test if we have enough free registers to load all
 429     #! shuffle inputs at once.
 430     int-regs free-vregs [ length ] bi@ <= ;
 431
 432 : finalize-locs ( -- )
 433     #! Perform any deferred stack shuffling.
 434     [
 435         \ free-vregs [ [ clone ] assoc-map ] change
 436         live-locs dup fast-shuffle?
 437         [ fast-shuffle ] [ slow-shuffle ] if
 438     ] with-scope ;
 439
 440 : finalize-vregs ( -- )
 441     #! Store any vregs to their final stack locations.
 442     [
 443         dup loc? over cached? or [ 2drop ] [ %move ] if
 444     ] each-loc ;
 445
 446 : reset-phantom ( phantom -- )
 447     #! Kill register assignments but preserve constants and
 448     #! class information.
 449     dup phantom-locs*
 450     over stack>> [
 451         dup constant? [ nip ] [
 452             operand-class over set-operand-class
 453         ] if
 454     ] 2map
 455     over stack>> delete-all
 456     swap stack>> push-all ;
 457
 458 : reset-phantoms ( -- )
 459     [ reset-phantom ] each-phantom ;
 460
 461 : finalize-contents ( -- )
 462     finalize-locs finalize-vregs reset-phantoms ;
 463
 464 ! Loading stacks to vregs
 465 : free-vregs? ( int# float# -- ? )
 466     double-float-regs free-vregs length <=
 467     >r int-regs free-vregs length <= r> and ;
 468
 469 : phantom&spec ( phantom spec -- phantom' spec' )
 470     >r stack>> r>
 471     [ length f pad-left ] keep
 472     [ <reversed> ] bi@ ; inline
 473
 474 : phantom&spec-agree? ( phantom spec quot -- ? )
 475     >r phantom&spec r> 2all? ; inline
 476
 477 : vreg-substitution ( value vreg -- pair )
 478     dupd <cached> 2array ;
 479
 480 : substitute-vreg? ( old new -- ? )
 481     #! We don't substitute locs for float or alien vregs,
 482     #! since in those cases the boxing overhead might kill us.
 483     cached-vreg tagged? >r loc? r> and ;
 484
 485 : substitute-vregs ( values vregs -- )
 486     [ vreg-substitution ] 2map
 487     [ substitute-vreg? ] assoc-filter >hashtable
 488     [ >r stack>> r> substitute-here ] curry each-phantom ;
 489
 490 : set-operand ( value var -- )
 491     >r dup constant? [ constant-value ] when r> set ;
 492
 493 : lazy-load ( values template -- )
 494     #! Set operand vars here.
 495     2dup [ first (lazy-load) ] 2map
 496     dup rot [ second set-operand ] 2each
 497     substitute-vregs ;
 498
 499 : load-inputs ( -- )
 500     +input+ get
 501     [ length phantom-datastack get phantom-input ] keep
 502     lazy-load ;
 503
 504 : output-vregs ( -- seq seq )
 505     +output+ +clobber+ [ get [ get ] map ] bi@ ;
 506
 507 : clash? ( seq -- ? )
 508     phantoms [ stack>> ] bi@ append [
 509         dup cached? [ cached-vreg ] when swap member?
 510     ] with contains? ;
 511
 512 : outputs-clash? ( -- ? )
 513     output-vregs append clash? ;
 514
 515 : count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
 516
 517 : count-input-vregs ( phantom spec -- )
 518     phantom&spec [
 519         >r dup cached? [ cached-vreg ] when r> first allocation
 520     ] 2map count-vregs ;
 521
 522 : count-scratch-regs ( spec -- )
 523     [ first reg-spec>class ] map count-vregs ;
 524
 525 : guess-vregs ( dinput rinput scratch -- int# float# )
 526     [
 527         0 int-regs set
 528         0 double-float-regs set
 529         count-scratch-regs
 530         phantom-retainstack get swap count-input-vregs
 531         phantom-datastack get swap count-input-vregs
 532         int-regs get double-float-regs get
 533     ] with-scope ;
 534
 535 : alloc-scratch ( -- )
 536     +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
 537
 538 : guess-template-vregs ( -- int# float# )
 539     +input+ get { } +scratch+ get guess-vregs ;
 540
 541 : template-inputs ( -- )
 542     ! Load input values into registers
 543     load-inputs
 544     ! Allocate scratch registers
 545     alloc-scratch
 546     ! If outputs clash, we write values back to the stack
 547     outputs-clash? [ finalize-contents ] when ;
 548
 549 : template-outputs ( -- )
 550     +output+ get [ get ] map phantom-datastack get phantom-append ;
 551
 552 : value-matches? ( value spec -- ? )
 553     #! If the spec is a quotation and the value is a literal
 554     #! fixnum, see if the quotation yields true when applied
 555     #! to the fixnum. Otherwise, the values don't match. If the
 556     #! spec is not a quotation, its a reg-class, in which case
 557     #! the value is always good.
 558     dup quotation? [
 559         over constant?
 560         [ >r constant-value r> call ] [ 2drop f ] if
 561     ] [
 562         2drop t
 563     ] if ;
 564
 565 : class-matches? ( actual expected -- ? )
 566     {
 567         { f [ drop t ] }
 568         { known-tag [ dup [ class-tag >boolean ] when ] }
 569         [ class<= ]
 570     } case ;
 571
 572 : spec-matches? ( value spec -- ? )
 573     2dup first value-matches?
 574     >r >r operand-class 2 r> ?nth class-matches? r> and ;
 575
 576 : template-matches? ( spec -- ? )
 577     phantom-datastack get +input+ rot at
 578     [ spec-matches? ] phantom&spec-agree? ;
 579
 580 : ensure-template-vregs ( -- )
 581     guess-template-vregs free-vregs? [
 582         finalize-contents compute-free-vregs
 583     ] unless ;
 584
 585 : clear-phantoms ( -- )
 586     [ stack>> delete-all ] each-phantom ;
 587
 588 PRIVATE>
 589
 590 : set-operand-classes ( classes -- )
 591     phantom-datastack get
 592     over length over add-locs
 593     stack>> [ set-operand-class ] 2reverse-each ;
 594
 595 : end-basic-block ( -- )
 596     #! Commit all deferred stacking shuffling, and ensure the
 597     #! in-memory data and retain stacks are up to date with
 598     #! respect to the compiler's current picture.
 599     finalize-contents
 600     clear-phantoms
 601     finalize-heights
 602     fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
 603
 604 : with-template ( quot hash -- )
 605     clone [
 606         ensure-template-vregs
 607         template-inputs call template-outputs
 608     ] bind
 609     compute-free-vregs ; inline
 610
 611 : do-template ( pair -- )
 612     #! Use with return value from find-template
 613     first2 with-template ;
 614
 615 : fresh-object ( obj -- ) fresh-objects get push ;
 616
 617 : fresh-object? ( obj -- ? ) fresh-objects get memq? ;
 618
 619 : init-templates ( -- )
 620     #! Initialize register allocator.
 621     V{ } clone fresh-objects set
 622     <phantom-datastack> phantom-datastack set
 623     <phantom-retainstack> phantom-retainstack set
 624     compute-free-vregs ;
 625
 626 : copy-templates ( -- )
 627     #! Copies register allocator state, used when compiling
 628     #! branches.
 629     fresh-objects [ clone ] change
 630     phantom-datastack [ clone ] change
 631     phantom-retainstack [ clone ] change
 632     compute-free-vregs ;
 633
 634 : find-template ( templates -- pair/f )
 635     #! Pair has shape { quot hash }
 636     [ second template-matches? ] find nip ;
 637
 638 : operand-tag ( operand -- tag/f )
 639     operand-class dup [ class-tag ] when ;
 640
 641 UNION: immediate fixnum POSTPONE: f ;
 642
 643 : operand-immediate? ( operand -- ? )
 644     operand-class immediate class<= ;
 645
 646 : phantom-push ( obj -- )
 647     1 phantom-datastack get adjust-phantom
 648     phantom-datastack get stack>> push ;
 649
 650 : phantom-shuffle ( shuffle -- )
 651     [ effect-in length phantom-datastack get phantom-input ] keep
 652     shuffle* phantom-datastack get phantom-append ;
 653
 654 : phantom->r ( n -- )
 655     phantom-datastack get phantom-input
 656     phantom-retainstack get phantom-append ;
 657
 658 : phantom-r> ( n -- )
 659     phantom-retainstack get phantom-input
 660     phantom-datastack get phantom-append ;