basis/compiler/cfg/stack-analysis/state/state.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors namespaces assocs sets math deques
   4 compiler.cfg.registers ;
   5 IN: compiler.cfg.stack-analysis.state
   6
   7 TUPLE: state
   8 locs>vregs actual-locs>vregs changed-locs
   9 { ds-height integer }
  10 { rs-height integer }
  11 poisoned? ;
  12
  13 : <state> ( -- state )
  14     state new
  15         H{ } clone >>locs>vregs
  16         H{ } clone >>actual-locs>vregs
  17         H{ } clone >>changed-locs
  18         0 >>ds-height
  19         0 >>rs-height ;
  20
  21 M: state clone
  22     call-next-method
  23         [ clone ] change-locs>vregs
  24         [ clone ] change-actual-locs>vregs
  25         [ clone ] change-changed-locs ;
  26
  27 : loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
  28
  29 : record-peek ( dst loc -- )
  30     state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
  31
  32 : changed-loc ( loc -- )
  33     state get changed-locs>> conjoin ;
  34
  35 : record-replace ( src loc -- )
  36     dup changed-loc state get locs>vregs>> set-at ;
  37
  38 : clear-state ( state -- )
  39     0 >>ds-height 0 >>rs-height
  40     [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
  41     [ clear-assoc ] tri@ ;
  42
  43 GENERIC# translate-loc 1 ( loc state -- loc' )
  44 M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
  45 M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
  46
  47 GENERIC# untranslate-loc 1 ( loc state -- loc' )
  48 M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
  49 M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
  50
  51 SYMBOL: work-list
  52
  53 : add-to-work-list ( bb -- ) work-list get push-front ;