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

   1 ! Copyright (C) 2009 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators.short-circuit kernel math math.order
   4 sequences assocs namespaces vectors fry arrays splitting
   5 compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
   6 compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
   7 IN: compiler.cfg.branch-splitting
   8
   9 : clone-instructions ( insns -- insns' )
  10     [ clone dup fresh-insn-temps ] map ;
  11
  12 : clone-basic-block ( bb -- bb' )
  13     ! The new block gets the same RPO number as the old one.
  14     ! This is just to make 'back-edge?' work.
  15     <basic-block>
  16         swap
  17         [ instructions>> clone-instructions >>instructions ]
  18         [ successors>> clone >>successors ]
  19         [ number>> >>number ]
  20         tri ;
  21
  22 : new-blocks ( bb -- copies )
  23     dup predecessors>> [
  24         [ clone-basic-block ] dip
  25         1vector >>predecessors
  26     ] with map ;
  27
  28 : update-predecessor-successor ( pred copy old-bb -- )
  29     '[
  30         [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
  31     ] change-successors drop ;
  32
  33 : update-predecessor-successors ( copies old-bb -- )
  34     [ predecessors>> swap ] keep
  35     '[ _ update-predecessor-successor ] 2each ;
  36
  37 : update-successor-predecessor ( copies old-bb succ -- )
  38     [
  39         swap 1array split swap join V{ } like
  40     ] change-predecessors drop ;
  41
  42 : update-successor-predecessors ( copies old-bb -- )
  43     dup successors>> [
  44         update-successor-predecessor
  45     ] with with each ;
  46
  47 : split-branch ( bb -- )
  48     [ new-blocks ] keep
  49     [ update-predecessor-successors ]
  50     [ update-successor-predecessors ]
  51     2bi ;
  52
  53 UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
  54
  55 : split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ;
  56
  57 : short-tail-block? ( bb -- ? )
  58     [ successors>> empty? ] [ instructions>> length 2 = ] bi and ;
  59
  60 : short-block? ( bb -- ? )
  61     ! If block is empty, always split
  62     [ predecessors>> length ] [ instructions>> length 1 - ] bi * 10 <= ;
  63
  64 : cond-cond-block? ( bb -- ? )
  65     {
  66         [ predecessors>> length 2 = ]
  67         [ successors>> length 2 = ]
  68         [ instructions>> length 20 <= ]
  69     } 1&& ;
  70
  71 : split-branch? ( bb -- ? )
  72     dup loop-entry? [ drop f ] [
  73         dup predecessors>> length 1 <= [ drop f ] [
  74             {
  75                 [ short-block? ]
  76                 [ short-tail-block? ]
  77                 [ cond-cond-block? ]
  78             } 1||
  79         ] if
  80     ] if ;
  81
  82 : split-branches ( cfg -- cfg' )
  83     dup [
  84         dup split-branch? [ split-branch ] [ drop ] if
  85     ] each-basic-block
  86     cfg-changed ;