basis/compiler/generator/registers/registers.factor

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