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-renamings ( insns -- assoc )
  10     [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
  11
  12 : clone-instructions ( insns -- insns' )
  13     dup clone-renamings renamings [
  14         [
  15             clone
  16             dup rename-insn-defs
  17             dup rename-insn-uses
  18             dup fresh-insn-temps
  19         ] map
  20     ] with-variable ;
  21
  22 : clone-basic-block ( bb -- bb' )
  23     ! The new block gets the same RPO number as the old one.
  24     ! This is just to make 'back-edge?' work.
  25     <basic-block>
  26         swap
  27         [ instructions>> clone-instructions >>instructions ]
  28         [ successors>> clone >>successors ]
  29         [ number>> >>number ]
  30         tri ;
  31
  32 : new-blocks ( bb -- copies )
  33     dup predecessors>> [
  34         [ clone-basic-block ] dip
  35         1vector >>predecessors
  36     ] with map ;
  37
  38 : update-predecessor-successor ( pred copy old-bb -- )
  39     '[
  40         [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
  41     ] change-successors drop ;
  42
  43 : update-predecessor-successors ( copies old-bb -- )
  44     [ predecessors>> swap ] keep
  45     '[ _ update-predecessor-successor ] 2each ;
  46
  47 : update-successor-predecessor ( copies old-bb succ -- )
  48     [
  49         swap 1array split swap join V{ } like
  50     ] change-predecessors drop ;
  51
  52 : update-successor-predecessors ( copies old-bb -- )
  53     dup successors>> [
  54         update-successor-predecessor
  55     ] with with each ;
  56
  57 : split-branch ( bb -- )
  58     [ new-blocks ] keep
  59     [ update-predecessor-successors ]
  60     [ update-successor-predecessors ]
  61     2bi ;
  62
  63 UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
  64
  65 : split-instructions? ( insns -- ? )
  66     [ [ irrelevant? not ] count 5 <= ]
  67     [ last ##fixnum-overflow? not ]
  68     bi and ;
  69
  70 : split-branch? ( bb -- ? )
  71     {
  72         [ dup successors>> [ back-edge? ] with any? not ]
  73         [ predecessors>> length 2 4 between? ]
  74         [ instructions>> split-instructions? ]
  75     } 1&& ;
  76
  77 : split-branches ( cfg -- cfg' )
  78     dup [
  79         dup split-branch? [ split-branch ] [ drop ] if
  80     ] each-basic-block
  81     cfg-changed ;