basis/compiler/cfg/stacks/stacks.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math sequences kernel namespaces accessors biassocs compiler.cfg
   4 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
   5 compiler.cfg.predecessors compiler.cfg.stacks.local
   6 compiler.cfg.stacks.height compiler.cfg.stacks.global
   7 compiler.cfg.stacks.finalize ;
   8 IN: compiler.cfg.stacks
   9
  10 : begin-stack-analysis ( -- )
  11     <bihash> locs>vregs set
  12     H{ } clone ds-heights set
  13     H{ } clone rs-heights set
  14     H{ } clone peek-sets set
  15     H{ } clone replace-sets set
  16     H{ } clone kill-sets set
  17     current-height new current-height set ;
  18
  19 : end-stack-analysis ( -- )
  20     cfg get
  21     compute-global-sets
  22     finalize-stack-shuffling
  23     drop ;
  24
  25 : ds-drop ( -- ) -1 inc-d ;
  26
  27 : ds-peek ( -- vreg ) D 0 peek-loc ;
  28
  29 : ds-pop ( -- vreg ) ds-peek ds-drop ;
  30
  31 : ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ;
  32
  33 : ds-load ( n -- vregs )
  34     dup 0 =
  35     [ drop f ]
  36     [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
  37
  38 : ds-store ( vregs -- )
  39     [
  40         <reversed>
  41         [ length inc-d ]
  42         [ [ <ds-loc> replace-loc ] each-index ] bi
  43     ] unless-empty ;
  44
  45 : rs-drop ( -- ) -1 inc-r ;
  46
  47 : rs-load ( n -- vregs )
  48     dup 0 =
  49     [ drop f ]
  50     [ [ <reversed> [ <rs-loc> peek-loc ] map ] [ neg inc-r ] bi ] if ;
  51
  52 : rs-store ( vregs -- )
  53     [
  54         <reversed>
  55         [ length inc-r ]
  56         [ [ <rs-loc> replace-loc ] each-index ] bi
  57     ] unless-empty ;
  58
  59 : (2inputs) ( -- vreg1 vreg2 )
  60     D 1 peek-loc D 0 peek-loc ;
  61
  62 : 2inputs ( -- vreg1 vreg2 )
  63     (2inputs) -2 inc-d ;
  64
  65 : (3inputs) ( -- vreg1 vreg2 vreg3 )
  66     D 2 peek-loc D 1 peek-loc D 0 peek-loc ;
  67
  68 : 3inputs ( -- vreg1 vreg2 vreg3 )
  69     (3inputs) -3 inc-d ;
  70
  71 ! adjust-d/adjust-r: these are called when other instructions which
  72 ! internally adjust the stack height are emitted, such as ##call and
  73 ! ##alien-invoke
  74 : adjust-d ( n -- ) current-height get [ + ] change-d drop ;
  75 : adjust-r ( n -- ) current-height get [ + ] change-r drop ;
  76