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 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* n>> min ;
  73 M: ds-loc live-loc?
  74     over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
  75
  76 ! A retain stack location.
  77 TUPLE: rs-loc n class ;
  78
  79 : <rs-loc> ( n -- loc ) f rs-loc boa ;
  80 M: rs-loc live-loc?
  81     over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
  82
  83 UNION: loc ds-loc rs-loc ;
  84
  85 M: loc operand-class* class>> ;
  86 M: loc set-operand-class (>>class) ;
  87 M: loc move-spec drop loc ;
  88
  89 INSTANCE: loc value
  90
  91 M: f move-spec drop loc ;
  92 M: f operand-class* ;
  93
  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
  98 ! it back.
  99 TUPLE: cached loc vreg ;
 100
 101 C: <cached> cached
 102
 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) ;
 109 M: cached lazy-store
 110     2dup loc>> live-loc?
 111     [ "live-locs" get at %move ] [ 2drop ] if ;
 112 M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
 113
 114 INSTANCE: cached value
 115
 116 ! A tagged pointer
 117 TUPLE: tagged vreg class ;
 118
 119 : <tagged> ( vreg -- tagged )
 120     f tagged boa ;
 121
 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>> , ;
 127
 128 INSTANCE: tagged value
 129
 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>> , ;
 137
 138 INSTANCE: unboxed-alien value
 139
 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>> , ;
 146
 147 INSTANCE: unboxed-byte-array value
 148
 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>> , ;
 155
 156 INSTANCE: unboxed-f value
 157
 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>> , ;
 164
 165 INSTANCE: unboxed-c-ptr value
 166
 167 ! A constant value
 168 TUPLE: constant value ;
 169 C: <constant> constant
 170 M: constant operand-class* value>> class ;
 171 M: constant move-spec class ;
 172
 173 INSTANCE: constant value
 174
 175 <PRIVATE
 176
 177 ! Moving values between locations and registers
 178 : %move-bug ( -- * ) "Bug in generator.registers" throw ;
 179
 180 : %unbox-c-ptr ( dst src -- )
 181     dup operand-class {
 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 ]
 186     } cond ; inline
 187
 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.
 192     temp-reg over %move
 193     operand-class temp-reg
 194     tagged new
 195         swap >>vreg
 196         swap >>class
 197     %move ;
 198
 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 ] }
 204
 205         { { f constant } [ value>> swap load-literal ] }
 206
 207         { { f float } [ %box-float ] }
 208         { { f unboxed-alien } [ %box-alien ] }
 209         { { f loc } [ %peek ] }
 210
 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 ] }
 217
 218         [ drop %move-via-temp ]
 219     } case ;
 220
 221 ! A compile-time stack
 222 TUPLE: phantom-stack height stack ;
 223
 224 M: phantom-stack clone
 225     call-next-method [ clone ] change-stack ;
 226
 227 GENERIC: finalize-height ( stack -- )
 228
 229 : new-phantom-stack ( class -- stack )
 230     >r 0 V{ } clone r> boa ; inline
 231
 232 : (loc) ( m stack -- n )
 233     #! Utility for methods on <loc>
 234     height>> - ;
 235
 236 : (finalize-height) ( stack word -- )
 237     #! We consolidate multiple stack height changes until the
 238     #! last moment, and we emit the final height changing
 239     #! instruction here.
 240     [
 241         over zero? [ 2drop ] [ execute ] if 0
 242     ] curry change-height drop ; inline
 243
 244 GENERIC: <loc> ( n stack -- loc )
 245
 246 TUPLE: phantom-datastack < phantom-stack ;
 247
 248 : <phantom-datastack> ( -- stack )
 249     phantom-datastack new-phantom-stack ;
 250
 251 M: phantom-datastack <loc> (loc) <ds-loc> ;
 252
 253 M: phantom-datastack finalize-height
 254     \ %inc-d (finalize-height) ;
 255
 256 TUPLE: phantom-retainstack < phantom-stack ;
 257
 258 : <phantom-retainstack> ( -- stack )
 259     phantom-retainstack new-phantom-stack ;
 260
 261 M: phantom-retainstack <loc> (loc) <rs-loc> ;
 262
 263 M: phantom-retainstack finalize-height
 264     \ %inc-r (finalize-height) ;
 265
 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 ;
 269
 270 : phantom-locs* ( phantom -- locs )
 271     [ stack>> length ] keep phantom-locs ;
 272
 273 : phantoms ( -- phantom phantom )
 274     phantom-datastack get phantom-retainstack get ;
 275
 276 : (each-loc) ( phantom quot -- )
 277     >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
 278
 279 : each-loc ( quot -- )
 280     phantoms 2array swap [ (each-loc) ] curry each ; inline
 281
 282 : adjust-phantom ( n phantom -- )
 283     swap [ + ] curry change-height drop ;
 284
 285 : cut-phantom ( n phantom -- seq )
 286     swap [ cut* swap ] curry change-stack drop ;
 287
 288 : phantom-append ( seq stack -- )
 289     over length over adjust-phantom stack>> push-all ;
 290
 291 : add-locs ( n phantom -- )
 292     2dup stack>> length <= [
 293         2drop
 294     ] [
 295         [ phantom-locs ] keep
 296         [ stack>> length head-slice* ] keep
 297         [ append >vector ] change-stack drop
 298     ] if ;
 299
 300 : phantom-input ( n phantom -- seq )
 301     2dup add-locs
 302     2dup cut-phantom
 303     >r >r neg r> adjust-phantom r> ;
 304
 305 : each-phantom ( quot -- ) phantoms rot bi@ ; inline
 306
 307 : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
 308
 309 : live-vregs ( -- seq )
 310     [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
 311
 312 : (live-locs) ( phantom -- seq )
 313     #! Discard locs which haven't moved
 314     [ phantom-locs* ] [ stack>> ] bi zip
 315     [ live-loc? ] assoc-filter
 316     values ;
 317
 318 : live-locs ( -- seq )
 319     [ (live-locs) ] each-phantom append prune ;
 320
 321 ! Operands holding pointers to freshly-allocated objects which
 322 ! are guaranteed to be in the nursery
 323 SYMBOL: fresh-objects
 324
 325 ! Computing free registers and initializing allocator
 326 : reg-spec>class ( spec -- class )
 327     float eq? double-float-regs int-regs ? ;
 328
 329 : free-vregs ( reg-class -- seq )
 330     #! Free vregs in a given register class
 331     \ free-vregs get at ;
 332
 333 : alloc-vreg ( spec -- reg )
 334     [ reg-spec>class free-vregs pop ] keep {
 335         { f [ <tagged> ] }
 336         { unboxed-alien [ <unboxed-alien> ] }
 337         { unboxed-byte-array [ <unboxed-byte-array> ] }
 338         { unboxed-f [ <unboxed-f> ] }
 339         { unboxed-c-ptr [ <unboxed-c-ptr> ] }
 340         [ drop ]
 341     } case ;
 342
 343 : compatible? ( value spec -- ? )
 344     >r move-spec r> {
 345         { [ 2dup = ] [ t ] }
 346         { [ dup unboxed-c-ptr eq? ] [
 347             over { unboxed-byte-array unboxed-alien } member?
 348         ] }
 349         [ f ]
 350     } cond 2nip ;
 351
 352 : allocation ( value spec -- reg-class )
 353     {
 354         { [ dup quotation? ] [ 2drop f ] }
 355         { [ 2dup compatible? ] [ 2drop f ] }
 356         [ nip reg-spec>class ]
 357     } cond ;
 358
 359 : alloc-vreg-for ( value spec -- vreg )
 360     alloc-vreg swap operand-class
 361     over tagged? [ >>class ] [ drop ] if ;
 362
 363 M: value (lazy-load)
 364     2dup allocation [
 365         dupd alloc-vreg-for dup rot %move
 366     ] [
 367         drop
 368     ] if ;
 369
 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
 374     >vector ;
 375
 376 : compute-free-vregs ( -- )
 377     #! Create a new hashtable for thee free-vregs variable.
 378     live-vregs
 379     { int-regs double-float-regs }
 380     [ 2dup (compute-free-vregs) ] H{ } map>assoc
 381     \ free-vregs set
 382     drop ;
 383
 384 M: loc lazy-store
 385     2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
 386
 387 : do-shuffle ( hash -- )
 388     dup assoc-empty? [
 389         drop
 390     ] [
 391         "live-locs" set
 392         [ lazy-store ] each-loc
 393     ] if ;
 394
 395 : fast-shuffle ( locs -- )
 396     #! We have enough free registers to load all shuffle inputs
 397     #! at once
 398     [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
 399
 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
 403     #! use.
 404     [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
 405
 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- ;
 410
 411 : slow-shuffle-mapping ( locs tmp -- pairs )
 412     >r dup length r>
 413     [ swap - <ds-loc> ] curry map zip ;
 414
 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 [
 420         [
 421             swap dup cached? [ vreg>> ] when %move
 422         ] assoc-each
 423     ] keep >hashtable do-shuffle ;
 424
 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@ <= ;
 429
 430 : finalize-locs ( -- )
 431     #! Perform any deferred stack shuffling.
 432     [
 433         \ free-vregs [ [ clone ] assoc-map ] change
 434         live-locs dup fast-shuffle?
 435         [ fast-shuffle ] [ slow-shuffle ] if
 436     ] with-scope ;
 437
 438 : finalize-vregs ( -- )
 439     #! Store any vregs to their final stack locations.
 440     [
 441         dup loc? over cached? or [ 2drop ] [ %move ] if
 442     ] each-loc ;
 443
 444 : reset-phantom ( phantom -- )
 445     #! Kill register assignments but preserve constants and
 446     #! class information.
 447     dup phantom-locs*
 448     over stack>> [
 449         dup constant? [ nip ] [
 450             operand-class over set-operand-class
 451         ] if
 452     ] 2map
 453     over stack>> delete-all
 454     swap stack>> push-all ;
 455
 456 : reset-phantoms ( -- )
 457     [ reset-phantom ] each-phantom ;
 458
 459 : finalize-contents ( -- )
 460     finalize-locs finalize-vregs reset-phantoms ;
 461
 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 ;
 466
 467 : phantom&spec ( phantom spec -- phantom' spec' )
 468     >r stack>> r>
 469     [ length f pad-left ] keep
 470     [ <reversed> ] bi@ ; inline
 471
 472 : phantom&spec-agree? ( phantom spec quot -- ? )
 473     >r phantom&spec r> 2all? ; inline
 474
 475 : vreg-substitution ( value vreg -- pair )
 476     dupd <cached> 2array ;
 477
 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 ;
 482
 483 : substitute-vregs ( values vregs -- )
 484     [ vreg-substitution ] 2map
 485     [ substitute-vreg? ] assoc-filter >hashtable
 486     [ >r stack>> r> substitute-here ] curry each-phantom ;
 487
 488 : set-operand ( value var -- )
 489     >r dup constant? [ value>> ] when r> set ;
 490
 491 : lazy-load ( values template -- )
 492     #! Set operand vars here.
 493     2dup [ first (lazy-load) ] 2map
 494     dup rot [ second set-operand ] 2each
 495     substitute-vregs ;
 496
 497 : load-inputs ( -- )
 498     +input+ get
 499     [ length phantom-datastack get phantom-input ] keep
 500     lazy-load ;
 501
 502 : output-vregs ( -- seq seq )
 503     +output+ +clobber+ [ get [ get ] map ] bi@ ;
 504
 505 : clash? ( seq -- ? )
 506     phantoms [ stack>> ] bi@ append [
 507         dup cached? [ vreg>> ] when swap member?
 508     ] with contains? ;
 509
 510 : outputs-clash? ( -- ? )
 511     output-vregs append clash? ;
 512
 513 : count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
 514
 515 : count-input-vregs ( phantom spec -- )
 516     phantom&spec [
 517         >r dup cached? [ vreg>> ] when r> first allocation
 518     ] 2map count-vregs ;
 519
 520 : count-scratch-regs ( spec -- )
 521     [ first reg-spec>class ] map count-vregs ;
 522
 523 : guess-vregs ( dinput rinput scratch -- int# float# )
 524     [
 525         0 int-regs set
 526         0 double-float-regs set
 527         count-scratch-regs
 528         phantom-retainstack get swap count-input-vregs
 529         phantom-datastack get swap count-input-vregs
 530         int-regs get double-float-regs get
 531     ] with-scope ;
 532
 533 : alloc-scratch ( -- )
 534     +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
 535
 536 : guess-template-vregs ( -- int# float# )
 537     +input+ get { } +scratch+ get guess-vregs ;
 538
 539 : template-inputs ( -- )
 540     ! Load input values into registers
 541     load-inputs
 542     ! Allocate scratch registers
 543     alloc-scratch
 544     ! If outputs clash, we write values back to the stack
 545     outputs-clash? [ finalize-contents ] when ;
 546
 547 : template-outputs ( -- )
 548     +output+ get [ get ] map phantom-datastack get phantom-append ;
 549
 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.
 556     dup quotation? [
 557         over constant?
 558         [ >r value>> r> call ] [ 2drop f ] if
 559     ] [
 560         2drop t
 561     ] if ;
 562
 563 : class-matches? ( actual expected -- ? )
 564     {
 565         { f [ drop t ] }
 566         { known-tag [ dup [ class-tag >boolean ] when ] }
 567         [ class<= ]
 568     } case ;
 569
 570 : spec-matches? ( value spec -- ? )
 571     2dup first value-matches?
 572     >r >r operand-class 2 r> ?nth class-matches? r> and ;
 573
 574 : template-matches? ( spec -- ? )
 575     phantom-datastack get +input+ rot at
 576     [ spec-matches? ] phantom&spec-agree? ;
 577
 578 : ensure-template-vregs ( -- )
 579     guess-template-vregs free-vregs? [
 580         finalize-contents compute-free-vregs
 581     ] unless ;
 582
 583 : clear-phantoms ( -- )
 584     [ stack>> delete-all ] each-phantom ;
 585
 586 PRIVATE>
 587
 588 : set-operand-classes ( classes -- )
 589     phantom-datastack get
 590     over length over add-locs
 591     stack>> [ set-operand-class ] 2reverse-each ;
 592
 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.
 597     finalize-contents
 598     clear-phantoms
 599     finalize-heights
 600     fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
 601
 602 : with-template ( quot hash -- )
 603     clone [
 604         ensure-template-vregs
 605         template-inputs call template-outputs
 606     ] bind
 607     compute-free-vregs ; inline
 608
 609 : do-template ( pair -- )
 610     #! Use with return value from find-template
 611     first2 with-template ;
 612
 613 : fresh-object ( obj -- ) fresh-objects get push ;
 614
 615 : fresh-object? ( obj -- ? ) fresh-objects get memq? ;
 616
 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
 622     compute-free-vregs ;
 623
 624 : copy-templates ( -- )
 625     #! Copies register allocator state, used when compiling
 626     #! branches.
 627     fresh-objects [ clone ] change
 628     phantom-datastack [ clone ] change
 629     phantom-retainstack [ clone ] change
 630     compute-free-vregs ;
 631
 632 : find-template ( templates -- pair/f )
 633     #! Pair has shape { quot hash }
 634     [ second template-matches? ] find nip ;
 635
 636 : operand-tag ( operand -- tag/f )
 637     operand-class dup [ class-tag ] when ;
 638
 639 UNION: immediate fixnum POSTPONE: f ;
 640
 641 : operand-immediate? ( operand -- ? )
 642     operand-class immediate class<= ;
 643
 644 : phantom-push ( obj -- )
 645     1 phantom-datastack get adjust-phantom
 646     phantom-datastack get stack>> push ;
 647
 648 : phantom-shuffle ( shuffle -- )
 649     [ in>> length phantom-datastack get phantom-input ] keep
 650     shuffle phantom-datastack get phantom-append ;
 651
 652 : phantom->r ( n -- )
 653     phantom-datastack get phantom-input
 654     phantom-retainstack get phantom-append ;
 655
 656 : phantom-r> ( n -- )
 657     phantom-retainstack get phantom-input
 658     phantom-datastack get phantom-append ;
 659
 660 : phantom-drop ( n -- )
 661     phantom-datastack get phantom-input drop ;
 662
 663 : phantom-rdrop ( n -- )
 664     phantom-retainstack get phantom-input drop ;