2009-05-26 20:31:19 -04:00
|
|
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
2008-09-11 03:05:22 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-10-22 19:39:41 -04:00
|
|
|
USING: kernel accessors namespaces make math sequences sets
|
2009-06-01 04:00:10 -04:00
|
|
|
assocs fry compiler.cfg compiler.cfg.instructions ;
|
2010-02-26 16:01:01 -05:00
|
|
|
FROM: namespaces => set ;
|
2008-09-11 03:05:22 -04:00
|
|
|
IN: compiler.cfg.rpo
|
|
|
|
|
2008-10-22 19:39:41 -04:00
|
|
|
SYMBOL: visited
|
|
|
|
|
|
|
|
: post-order-traversal ( bb -- )
|
2009-05-26 20:31:19 -04:00
|
|
|
dup visited get key? [ drop ] [
|
|
|
|
dup visited get conjoin
|
2008-11-13 04:52:01 -05:00
|
|
|
[
|
|
|
|
successors>> <reversed>
|
|
|
|
[ post-order-traversal ] each
|
|
|
|
] [ , ] bi
|
2008-09-11 03:05:22 -04:00
|
|
|
] if ;
|
|
|
|
|
|
|
|
: number-blocks ( blocks -- )
|
2009-05-29 14:11:34 -04:00
|
|
|
dup length iota <reversed>
|
|
|
|
[ >>number drop ] 2each ;
|
|
|
|
|
|
|
|
: post-order ( cfg -- blocks )
|
|
|
|
dup post-order>> [ ] [
|
|
|
|
[
|
|
|
|
H{ } clone visited set
|
|
|
|
dup entry>> post-order-traversal
|
|
|
|
] { } make dup number-blocks
|
|
|
|
>>post-order post-order>>
|
|
|
|
] ?if ;
|
2008-09-11 03:05:22 -04:00
|
|
|
|
2009-05-26 20:31:19 -04:00
|
|
|
: reverse-post-order ( cfg -- blocks )
|
2009-05-29 14:11:34 -04:00
|
|
|
post-order <reversed> ; inline
|
2008-10-22 19:39:41 -04:00
|
|
|
|
|
|
|
: each-basic-block ( cfg quot -- )
|
2009-05-26 20:31:19 -04:00
|
|
|
[ reverse-post-order ] dip each ; inline
|
2009-07-22 04:08:28 -04:00
|
|
|
|
|
|
|
: optimize-basic-block ( bb quot -- )
|
2010-05-09 21:36:52 -04:00
|
|
|
over kill-block?>> [ 2drop ] [
|
|
|
|
over basic-block set
|
|
|
|
change-instructions drop
|
|
|
|
] if ; inline
|
2009-07-22 04:08:28 -04:00
|
|
|
|
2010-04-30 18:55:20 -04:00
|
|
|
: simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... )
|
|
|
|
'[ _ optimize-basic-block ] each-basic-block ; inline
|
2009-08-08 21:02:56 -04:00
|
|
|
|
2010-05-14 18:18:29 -04:00
|
|
|
: analyze-basic-block ( bb quot -- )
|
|
|
|
over kill-block?>> [ 2drop ] [
|
|
|
|
[ dup basic-block set instructions>> ] dip call
|
|
|
|
] if ; inline
|
|
|
|
|
|
|
|
: simple-analysis ( ... cfg quot: ( ... insns -- ... ) -- ... )
|
|
|
|
'[ _ analyze-basic-block ] each-basic-block ; inline
|
|
|
|
|
2009-08-08 21:02:56 -04:00
|
|
|
: needs-post-order ( cfg -- cfg' )
|
2010-03-09 02:38:10 -05:00
|
|
|
dup post-order drop ;
|