basis/compiler/cfg/utilities/utilities.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators combinators.short-circuit
   4 cpu.architecture kernel layouts locals make math namespaces sequences
   5 sets vectors fry arrays compiler.cfg compiler.cfg.instructions
   6 compiler.cfg.rpo compiler.utilities ;
   7 IN: compiler.cfg.utilities
   8
   9 PREDICATE: kill-block < basic-block
  10     instructions>> {
  11         [ length 2 >= ]
  12         [ penultimate kill-vreg-insn? ]
  13     } 1&& ;
  14
  15 : back-edge? ( from to -- ? )
  16     [ number>> ] bi@ >= ;
  17
  18 : loop-entry? ( bb -- ? )
  19     dup predecessors>> [ swap back-edge? ] with any? ;
  20
  21 : empty-block? ( bb -- ? )
  22     instructions>> {
  23         [ length 1 = ]
  24         [ first ##branch? ]
  25     } 1&& ;
  26
  27 SYMBOL: visited
  28
  29 : (skip-empty-blocks) ( bb -- bb' )
  30     dup visited get key? [
  31         dup empty-block? [
  32             dup visited get conjoin
  33             successors>> first (skip-empty-blocks)
  34         ] when
  35     ] unless ;
  36
  37 : skip-empty-blocks ( bb -- bb' )
  38     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
  39
  40 :: insert-basic-block ( froms to bb -- )
  41     bb froms V{ } like >>predecessors drop
  42     bb to 1vector >>successors drop
  43     to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
  44     froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
  45
  46 : add-instructions ( bb quot -- )
  47     [ instructions>> building ] dip '[
  48         building get pop
  49         [ @ ] dip
  50         ,
  51     ] with-variable ; inline
  52
  53 : <simple-block> ( insns -- bb )
  54     <basic-block>
  55     swap >vector
  56     \ ##branch new-insn over push
  57     >>instructions ;
  58
  59 : insert-simple-basic-block ( from to insns -- )
  60     [ 1vector ] 2dip <simple-block> insert-basic-block ;
  61
  62 : has-phis? ( bb -- ? )
  63     instructions>> first ##phi? ;
  64
  65 : cfg-has-phis? ( cfg -- ? )
  66     post-order [ has-phis? ] any? ;
  67
  68 : if-has-phis ( ..a bb quot: ( ..a bb -- ..b ) -- ..b )
  69     [ dup has-phis? ] dip [ drop ] if ; inline
  70
  71 : each-phi ( ... bb quot: ( ... ##phi -- ... ) -- ... )
  72     [ instructions>> ] dip
  73     '[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
  74
  75 : each-non-phi ( ... bb quot: ( ... insn -- ... ) -- ... )
  76     [ instructions>> ] dip
  77     '[ dup ##phi? [ drop ] _ if ] each ; inline
  78
  79 : predecessor ( bb -- pred )
  80     predecessors>> first ; inline
  81