basis/compiler/cfg/write-barrier/write-barrier.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors namespaces assocs sets sequences
   4 fry combinators.short-circuit locals make arrays
   5 compiler.cfg
   6 compiler.cfg.dominance
   7 compiler.cfg.predecessors
   8 compiler.cfg.loop-detection
   9 compiler.cfg.rpo
  10 compiler.cfg.instructions
  11 compiler.cfg.registers
  12 compiler.cfg.dataflow-analysis
  13 compiler.cfg.utilities ;
  14 IN: compiler.cfg.write-barrier
  15
  16 ! Eliminate redundant write barrier hits.
  17
  18 ! Objects which have already been marked, as well as
  19 ! freshly-allocated objects
  20 SYMBOL: safe
  21
  22 ! Objects which have been mutated
  23 SYMBOL: mutated
  24
  25 GENERIC: eliminate-write-barrier ( insn -- ? )
  26
  27 M: ##allot eliminate-write-barrier
  28     dst>> safe get conjoin t ;
  29
  30 M: ##write-barrier eliminate-write-barrier
  31     src>> dup safe get key? not
  32     [ safe get conjoin t ] [ drop f ] if ;
  33
  34 M: insn eliminate-write-barrier drop t ;
  35
  36 ! This doesn't actually benefit from being a dataflow analysis
  37 ! might as well be dominator-based
  38 ! Dealing with phi functions would help, though
  39 FORWARD-ANALYSIS: safe
  40
  41 : has-allocation? ( bb -- ? )
  42     instructions>> [ { [ ##allocation? ] [ ##call? ] } 1|| ] any? ;
  43
  44 M: safe-analysis transfer-set
  45     drop [ H{ } assoc-clone-like safe set ] dip
  46     instructions>> [
  47         eliminate-write-barrier drop
  48     ] each safe get ;
  49
  50 M: safe-analysis join-sets
  51     drop has-allocation? [ drop H{ } clone ] [ assoc-refine ] if ;
  52
  53 : write-barriers-step ( bb -- )
  54     dup safe-in H{ } assoc-clone-like safe set
  55     instructions>> [ eliminate-write-barrier ] filter-here ;
  56
  57 GENERIC: remove-dead-barrier ( insn -- ? )
  58
  59 M: ##write-barrier remove-dead-barrier
  60     src>> mutated get key? ;
  61
  62 M: ##set-slot remove-dead-barrier
  63     obj>> mutated get conjoin t ;
  64
  65 M: ##set-slot-imm remove-dead-barrier
  66     obj>> mutated get conjoin t ;
  67
  68 M: insn remove-dead-barrier drop t ;
  69
  70 : remove-dead-barriers ( bb -- )
  71     H{ } clone mutated set
  72     instructions>> [ remove-dead-barrier ] filter-here ;
  73
  74 ! Availability of slot
  75 ! Anticipation of this and set-slot would help too, maybe later
  76 FORWARD-ANALYSIS: slot
  77
  78 UNION: access ##read ##write ;
  79
  80 M: slot-analysis transfer-set
  81     drop [ H{ } assoc-clone-like ] dip
  82     instructions>> over '[
  83         dup access? [
  84             obj>> _ conjoin
  85         ] [ drop ] if
  86     ] each ;
  87
  88 : slot-available? ( vreg bb -- ? )
  89     slot-in key? ;
  90
  91 : make-barriers ( vregs -- bb )
  92     [ [ next-vreg next-vreg ##write-barrier ] each ] V{ } make <simple-block> ;
  93
  94 : emit-barriers ( vregs loop -- )
  95     swap [
  96         [ [ header>> predecessors>> ] [ ends>> keys ] bi diff ]
  97         [ header>> ] bi
  98     ] [ make-barriers ] bi*
  99     insert-basic-block ;
 100
 101 : write-barriers ( bbs -- bb=>barriers )
 102     [
 103         dup instructions>>
 104         [ ##write-barrier? ] filter
 105         [ src>> ] map
 106     ] { } map>assoc
 107     [ nip empty? not ] assoc-filter ;
 108
 109 : filter-dominant ( bb=>barriers bbs -- barriers )
 110     '[ drop _ [ dominates? ] with all? ] assoc-filter
 111     values concat prune ;
 112
 113 : dominant-write-barriers ( loop -- vregs )
 114     [ blocks>> values write-barriers ] [ ends>> keys ] bi filter-dominant ;
 115
 116 : safe-loops ( -- loops )
 117     loops get values
 118     [ blocks>> keys [ has-allocation? not ] all? ] filter ;
 119
 120 :: insert-extra-barriers ( cfg -- )
 121     safe-loops [| loop |
 122         cfg needs-dominance needs-predecessors drop
 123         loop dominant-write-barriers
 124         loop header>> '[ _ slot-available? ] filter
 125         [ loop emit-barriers cfg cfg-changed drop ] unless-empty
 126     ] each ;
 127
 128 : contains-write-barrier? ( cfg -- ? )
 129     post-order [ instructions>> [ ##write-barrier? ] any? ] any? ;
 130
 131 : eliminate-write-barriers ( cfg -- cfg' )
 132     dup contains-write-barrier? [
 133         needs-loops
 134         dup [ remove-dead-barriers ] each-basic-block
 135         dup compute-slot-sets
 136         dup insert-extra-barriers
 137         dup compute-safe-sets
 138         dup [ write-barriers-step ] each-basic-block
 139     ] when ;