basis/compiler/cfg/branch-splitting/branch-splitting.factor

   1 ! Copyright (C) 2009, 2011 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators combinators.short-circuit
   4 compiler.cfg compiler.cfg.instructions compiler.cfg.predecessors
   5 compiler.cfg.renaming compiler.cfg.rpo compiler.cfg.utilities
   6 deques dlists fry kernel locals math namespaces sequences sets
   7 vectors ;
   8 IN: compiler.cfg.branch-splitting
   9
  10 : clone-instructions ( insns -- insns' )
  11     [ clone dup rename-insn-temps ] map ;
  12
  13 : clone-basic-block ( bb -- bb' )
  14     <basic-block>
  15         swap
  16         {
  17             [ instructions>> clone-instructions >>instructions ]
  18             [ successors>> clone >>successors ]
  19             [ kill-block?>> >>kill-block? ]
  20             [ number>> >>number ]
  21         } cleave ;
  22
  23 : new-blocks ( bb -- copies )
  24     dup predecessors>> [
  25         [ clone-basic-block ] [ 1vector ] bi*
  26         >>predecessors
  27     ] with map ;
  28
  29 : update-predecessor-successors ( copies old-bb -- )
  30     [ predecessors>> swap ] keep
  31     '[ [ _ ] dip update-successors ] 2each ;
  32
  33 :: update-successor-predecessor ( copies old-bb succ -- )
  34     succ predecessors>> dup >array :> ( preds preds' )
  35     preds delete-all
  36     preds' [
  37         dup old-bb eq?
  38         [ drop copies preds push-all ] [ preds push ] if
  39     ] each ;
  40
  41 : update-successor-predecessors ( copies old-bb -- )
  42     dup successors>>
  43     [ update-successor-predecessor ] 2with each ;
  44
  45 : split-branch ( bb -- )
  46     [ new-blocks ] keep
  47     [ update-predecessor-successors ]
  48     [ update-successor-predecessors ]
  49     2bi ;
  50
  51 UNION: irrelevant ##peek ##replace ##inc ;
  52
  53 : split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ;
  54
  55 : short-tail-block? ( bb -- ? )
  56     [ successors>> empty? ] [ instructions>> length 2 = ] bi and ;
  57
  58 : short-block? ( bb -- ? )
  59     ! If block is empty, always split
  60     [ predecessors>> length ] [ instructions>> length 1 - ] bi * 10 <= ;
  61
  62 : cond-cond-block? ( bb -- ? )
  63     {
  64         [ predecessors>> length 2 = ]
  65         [ successors>> length 2 = ]
  66         [ instructions>> length 20 <= ]
  67     } 1&& ;
  68
  69 : split-branch? ( bb -- ? )
  70     dup loop-entry? [ drop f ] [
  71         dup predecessors>> length 1 <= [ drop f ] [
  72             {
  73                 [ short-block? ]
  74                 [ short-tail-block? ]
  75                 [ cond-cond-block? ]
  76             } 1||
  77         ] if
  78     ] if ;
  79
  80 SYMBOL: worklist
  81 SYMBOL: visited
  82
  83 : add-to-worklist ( bb -- )
  84     dup visited get ?adjoin
  85     [ worklist get push-front ] [ drop ] if ;
  86
  87 : init-worklist ( cfg -- )
  88     <dlist> worklist set
  89     HS{ } clone visited set
  90     entry>> add-to-worklist ;
  91
  92 : split-branches ( cfg -- )
  93     {
  94         [ needs-predecessors ]
  95         [ init-worklist ]
  96         [
  97             ! For back-edge?
  98             post-order drop
  99             worklist get [
 100                 dup split-branch? [ dup split-branch ] when
 101                 successors>> [ add-to-worklist ] each
 102             ] slurp-deque
 103         ]
 104         [ cfg-changed ]
 105     } cleave ;