basis/compiler/cfg/liveness/liveness.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators combinators.short-circuit
   4 compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.predecessors
   5 compiler.cfg.registers compiler.cfg.rpo
   6 compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities
   7 cpu.architecture deques dlists fry kernel locals namespaces
   8 sequences sets ;
   9 FROM: namespaces => set ;
  10 IN: compiler.cfg.liveness
  11
  12 SYMBOL: live-ins
  13
  14 : live-in ( bb -- set )
  15     live-ins get at ;
  16
  17 SYMBOL: live-outs
  18
  19 : live-out ( bb -- set )
  20     live-outs get at ;
  21
  22 SYMBOL: edge-live-ins
  23
  24 : edge-live-in ( predecessor basic-block -- set )
  25     edge-live-ins get at at ;
  26
  27 SYMBOL: base-pointers
  28
  29 GENERIC: visit-insn ( live-set insn -- )
  30
  31 ! This would be much better if live-set was a real set
  32 : kill-defs ( live-set insn -- )
  33     defs-vregs [ ?leader ] map
  34     '[ drop ?leader _ in? ] assoc-reject! drop ; inline
  35
  36 : gen-uses ( live-set insn -- )
  37     uses-vregs [ swap conjoin ] with each ; inline
  38
  39 M: vreg-insn visit-insn ( live-set insn -- )
  40     [ kill-defs ] [ gen-uses ] 2bi ;
  41
  42 DEFER: lookup-base-pointer
  43
  44 GENERIC: lookup-base-pointer* ( vreg insn -- vreg/f )
  45
  46 M: ##tagged>integer lookup-base-pointer* nip src>> ;
  47
  48 M: ##unbox-any-c-ptr lookup-base-pointer*
  49     ! If the input to unbox-any-c-ptr was an alien and not a
  50     ! byte array, then the derived pointer will be outside of
  51     ! the data heap. The GC has to handle this case and ignore
  52     ! it.
  53     nip src>> ;
  54
  55 M: ##copy lookup-base-pointer* nip src>> lookup-base-pointer ;
  56
  57 M: ##add-imm lookup-base-pointer* nip src1>> lookup-base-pointer ;
  58
  59 M: ##sub-imm lookup-base-pointer* nip src1>> lookup-base-pointer ;
  60
  61 M: ##parallel-copy lookup-base-pointer* values>> value-at ;
  62
  63 M: ##add lookup-base-pointer*
  64     ! If both operands have a base pointer, then the user better
  65     ! not be doing memory reads and writes on the object, since
  66     ! we don't give it a base pointer in that case at all.
  67     nip [ src1>> ] [ src2>> ] bi [ lookup-base-pointer ] bi@ xor ;
  68
  69 M: ##sub lookup-base-pointer*
  70     nip src1>> lookup-base-pointer ;
  71
  72 M: vreg-insn lookup-base-pointer* 2drop f ;
  73
  74 : lookup-base-pointer ( vreg -- vreg/f )
  75     base-pointers get ?at [
  76         f over base-pointers get set-at
  77         [ dup ?leader insn-of lookup-base-pointer* ] keep
  78         dupd base-pointers get set-at
  79     ] unless ;
  80
  81 :: visit-derived-root ( vreg derived-roots gc-roots -- )
  82     vreg lookup-base-pointer :> base
  83     base [
  84         { vreg base } derived-roots push
  85         base gc-roots adjoin
  86     ] when ;
  87
  88 : visit-gc-root ( vreg derived-roots gc-roots -- )
  89     pick rep-of {
  90         { tagged-rep [ nip adjoin ] }
  91         { int-rep [ visit-derived-root ] }
  92         [ 4drop ]
  93     } case ;
  94
  95 : gc-roots ( live-set -- derived-roots gc-roots )
  96     keys V{ } clone HS{ } clone
  97     [ '[ _ _ visit-gc-root ] each ] 2keep members ;
  98
  99 : fill-gc-map ( live-set gc-map -- )
 100     [ gc-roots ] dip [ gc-roots<< ] [ derived-roots<< ] bi ;
 101
 102 M: gc-map-insn visit-insn ( live-set insn -- )
 103     [ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ;
 104
 105 M: ##phi visit-insn kill-defs ;
 106
 107 M: insn visit-insn 2drop ;
 108
 109 : transfer-liveness ( live-set insns -- )
 110     <reversed> [ visit-insn ] with each ;
 111
 112 : compute-live-in ( basic-block -- live-in )
 113     [ live-out clone dup ] keep instructions>> transfer-liveness ;
 114
 115 : compute-edge-live-in ( basic-block -- edge-live-in )
 116     H{ } clone [
 117         '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
 118     ] keep ;
 119
 120 : update-live-in ( basic-block -- changed? )
 121     [ [ compute-live-in ] keep live-ins get maybe-set-at ]
 122     [ [ compute-edge-live-in ] keep edge-live-ins get maybe-set-at ]
 123     bi or ;
 124
 125 : compute-live-out ( basic-block -- live-out )
 126     [ successors>> [ live-in ] map ]
 127     [ dup successors>> [ edge-live-in ] with map ] bi
 128     append assoc-combine ;
 129
 130 : update-live-out ( basic-block -- changed? )
 131     [ compute-live-out ] keep
 132     live-outs get maybe-set-at ;
 133
 134 : update-live-out/in ( basic-block -- changed? )
 135     { [ update-live-out ] [ update-live-in ] } 1&& ;
 136
 137 : liveness-step ( basic-block -- basic-blocks )
 138     [ update-live-out/in ] keep predecessors>> { } ? ;
 139
 140 : init-liveness ( -- )
 141     H{ } clone live-ins set
 142     H{ } clone edge-live-ins set
 143     H{ } clone live-outs set
 144     H{ } clone base-pointers set ;
 145
 146 : compute-live-sets ( cfg -- )
 147     init-liveness
 148     dup needs-predecessors dup compute-insns
 149     post-order <hashed-dlist> [ push-all-front ] keep
 150     [ liveness-step ] slurp/replenish-deque ;
 151
 152 : live-in? ( vreg bb -- ? ) live-in key? ;
 153
 154 : live-out? ( vreg bb -- ? ) live-out key? ;