2010-04-24 02:38:43 -04:00
|
|
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
2008-10-22 19:37:47 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2009-07-12 23:22:46 -04:00
|
|
|
USING: accessors assocs combinators combinators.short-circuit
|
2009-07-28 07:51:03 -04:00
|
|
|
cpu.architecture kernel layouts locals make math namespaces sequences
|
2009-09-09 14:44:54 -04:00
|
|
|
sets vectors fry arrays compiler.cfg compiler.cfg.instructions
|
|
|
|
compiler.cfg.rpo compiler.utilities ;
|
2008-10-22 19:37:47 -04:00
|
|
|
IN: compiler.cfg.utilities
|
2009-07-19 20:45:23 -04:00
|
|
|
|
2009-07-12 23:22:46 -04:00
|
|
|
: back-edge? ( from to -- ? )
|
|
|
|
[ number>> ] bi@ >= ;
|
|
|
|
|
2009-07-28 09:47:50 -04:00
|
|
|
: loop-entry? ( bb -- ? )
|
|
|
|
dup predecessors>> [ swap back-edge? ] with any? ;
|
|
|
|
|
2009-07-12 23:22:46 -04:00
|
|
|
: empty-block? ( bb -- ? )
|
|
|
|
instructions>> {
|
|
|
|
[ length 1 = ]
|
|
|
|
[ first ##branch? ]
|
|
|
|
} 1&& ;
|
|
|
|
|
2013-03-08 15:16:02 -05:00
|
|
|
: (skip-empty-blocks) ( visited bb -- visited bb' )
|
2013-03-23 20:46:45 -04:00
|
|
|
dup empty-block? [
|
|
|
|
dup pick ?adjoin [
|
2009-07-12 23:22:46 -04:00
|
|
|
successors>> first (skip-empty-blocks)
|
|
|
|
] when
|
2013-03-23 20:46:45 -04:00
|
|
|
] when ; inline recursive
|
2009-07-12 23:22:46 -04:00
|
|
|
|
|
|
|
: skip-empty-blocks ( bb -- bb' )
|
2013-03-08 14:04:47 -05:00
|
|
|
[ HS{ } clone ] dip (skip-empty-blocks) nip ;
|
2009-07-12 23:22:46 -04:00
|
|
|
|
2010-04-27 10:51:00 -04:00
|
|
|
:: update-predecessors ( from to bb -- )
|
2010-07-02 15:44:12 -04:00
|
|
|
! Whenever 'from' appears in the list of predecessors of 'to'
|
|
|
|
! replace it with 'bb'.
|
2010-04-27 10:51:00 -04:00
|
|
|
to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
|
|
|
|
|
|
|
|
:: update-successors ( from to bb -- )
|
2010-07-02 15:44:12 -04:00
|
|
|
! Whenever 'to' appears in the list of successors of 'from'
|
|
|
|
! replace it with 'bb'.
|
2010-04-27 10:51:00 -04:00
|
|
|
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
|
|
|
|
|
|
|
|
:: insert-basic-block ( from to insns -- )
|
|
|
|
! Insert basic block on the edge between 'from' and 'to'.
|
|
|
|
<basic-block> :> bb
|
2010-05-05 16:52:54 -04:00
|
|
|
insns V{ } like bb instructions<<
|
|
|
|
V{ from } bb predecessors<<
|
|
|
|
V{ to } bb successors<<
|
2010-04-27 10:51:00 -04:00
|
|
|
from to bb update-predecessors
|
|
|
|
from to bb update-successors ;
|
2009-07-12 23:22:46 -04:00
|
|
|
|
2009-08-02 09:20:50 -04:00
|
|
|
: add-instructions ( bb quot -- )
|
|
|
|
[ instructions>> building ] dip '[
|
|
|
|
building get pop
|
2009-08-13 21:26:44 -04:00
|
|
|
[ @ ] dip
|
2009-08-02 09:20:50 -04:00
|
|
|
,
|
|
|
|
] with-variable ; inline
|
|
|
|
|
2009-07-26 22:10:33 -04:00
|
|
|
: has-phis? ( bb -- ? )
|
|
|
|
instructions>> first ##phi? ;
|
|
|
|
|
2009-07-28 08:40:09 -04:00
|
|
|
: cfg-has-phis? ( cfg -- ? )
|
2009-07-28 07:48:20 -04:00
|
|
|
post-order [ has-phis? ] any? ;
|
|
|
|
|
2010-03-09 02:38:10 -05:00
|
|
|
: if-has-phis ( ..a bb quot: ( ..a bb -- ..b ) -- ..b )
|
2009-07-26 22:10:33 -04:00
|
|
|
[ dup has-phis? ] dip [ drop ] if ; inline
|
2009-07-28 22:31:08 -04:00
|
|
|
|
2010-03-09 02:38:10 -05:00
|
|
|
: each-phi ( ... bb quot: ( ... ##phi -- ... ) -- ... )
|
2009-08-02 07:16:58 -04:00
|
|
|
[ instructions>> ] dip
|
|
|
|
'[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
|
|
|
|
|
2010-03-09 02:38:10 -05:00
|
|
|
: each-non-phi ( ... bb quot: ( ... insn -- ... ) -- ... )
|
2009-08-08 05:02:18 -04:00
|
|
|
[ instructions>> ] dip
|
|
|
|
'[ dup ##phi? [ drop ] _ if ] each ; inline
|
|
|
|
|
2009-07-28 22:31:08 -04:00
|
|
|
: predecessor ( bb -- pred )
|
|
|
|
predecessors>> first ; inline
|
|
|
|
|
2010-04-24 02:38:43 -04:00
|
|
|
: <copy> ( dst src -- insn )
|
2011-11-13 01:04:26 -05:00
|
|
|
any-rep ##copy new-insn ;
|