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

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