basis/compiler/cfg/utilities/utilities.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators.short-circuit compiler.cfg
   4 compiler.cfg.instructions compiler.cfg.rpo cpu.architecture
   5 deques heaps kernel math sequences sets ;
   6 IN: compiler.cfg.utilities
   7
   8 : block>cfg ( bb -- cfg )
   9     f f rot <cfg> ;
  10
  11 : insns>block ( insns n -- bb )
  12     <basic-block> swap >>number swap V{ } like >>instructions ;
  13
  14 : insns>cfg ( insns -- cfg )
  15     0 insns>block block>cfg ;
  16
  17 : back-edge? ( from to -- ? )
  18     [ number>> ] bi@ >= ;
  19
  20 : loop-entry? ( bb -- ? )
  21     dup predecessors>> [ swap back-edge? ] with any? ;
  22
  23 : empty-block? ( bb -- ? )
  24     instructions>> {
  25         [ length 1 = ]
  26         [ first ##branch? ]
  27     } 1&& ;
  28
  29 : (skip-empty-blocks) ( visited bb -- visited bb' )
  30     dup empty-block? [
  31         dup pick ?adjoin [
  32             successors>> first (skip-empty-blocks)
  33         ] when
  34     ] when ; inline recursive
  35
  36 : skip-empty-blocks ( bb -- bb' )
  37     [ HS{ } clone ] dip (skip-empty-blocks) nip ;
  38
  39 :: update-predecessors ( from to bb -- )
  40     ! Whenever 'from' appears in the list of predecessors of 'to'
  41     ! replace it with 'bb'.
  42     to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
  43
  44 :: update-successors ( from to bb -- )
  45     ! Whenever 'to' appears in the list of successors of 'from'
  46     ! replace it with 'bb'.
  47     from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
  48
  49 :: insert-basic-block ( from to insns -- )
  50     insns f insns>block :> bb
  51     V{ from } bb predecessors<<
  52     V{ to } bb successors<<
  53     from to bb update-predecessors
  54     from to bb update-successors ;
  55
  56 : has-phis? ( bb -- ? )
  57     instructions>> first ##phi? ;
  58
  59 : cfg-has-phis? ( cfg -- ? )
  60     post-order [ has-phis? ] any? ;
  61
  62 : if-has-phis ( ..a bb quot: ( ..a bb -- ..b ) -- ..b )
  63     [ dup has-phis? ] dip [ drop ] if ; inline
  64
  65 : each-phi ( ... bb quot: ( ... ##phi -- ... ) -- ... )
  66     [ instructions>> ] dip
  67     '[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
  68
  69 : each-non-phi ( ... bb quot: ( ... insn -- ... ) -- ... )
  70     [ instructions>> ] dip
  71     '[ dup ##phi? [ drop ] _ if ] each ; inline
  72
  73 : predecessor ( bb -- pred )
  74     predecessors>> first ; inline
  75
  76 : <copy> ( dst src -- insn )
  77     any-rep ##copy new-insn ;
  78
  79 : connect-bbs ( from to -- )
  80     [ [ successors>> ] dip suffix! drop ]
  81     [ predecessors>> swap suffix! drop ] 2bi ;
  82
  83 : connect-Nto1-bbs ( froms to -- )
  84     '[ _ connect-bbs ] each ;
  85
  86 ! Abstract generic stuff
  87 MACRO: apply-passes ( passes -- quot: ( obj -- ) )
  88     unclip-last [ [ 1array \ dup prefix ] map [ ] concat-as ] dip suffix ;
  89
  90 : slurp/replenish-deque ( ... deque quot: ( ... obj -- ... seq ) -- ... )
  91       over '[ @ _ push-all-front ] slurp-deque ; inline
  92
  93 : heap-members ( heap -- seq )
  94     data>> [ value>> ] map ;
  95
  96 : heap-pop-while ( heap quot: ( key -- ? ) -- values )
  97     '[ dup heap-empty? [ f f ] [ dup heap-peek @ ] if ]
  98     [ over heap-pop* ] produce 2nip ; inline