155 lines
4.1 KiB
Factor
155 lines
4.1 KiB
Factor
! Copyright (C) 2008, 2010 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors arrays assocs classes.algebra combinators
|
|
compiler.tree compiler.tree.dead-code.liveness
|
|
compiler.tree.propagation.info fry kernel locals math math.private
|
|
namespaces sequences stack-checker.backend stack-checker.dependencies
|
|
words ;
|
|
IN: compiler.tree.dead-code.simple
|
|
|
|
: flushable-call? ( #call -- ? )
|
|
dup word>> dup flushable? [
|
|
word>input-infos [
|
|
[ node-input-infos ] dip
|
|
[ value-info<= ] 2all?
|
|
] [ drop t ] if*
|
|
] [ 2drop f ] if ;
|
|
|
|
M: #call mark-live-values*
|
|
dup flushable-call? [ drop ] [ look-at-inputs ] if ;
|
|
|
|
M: #alien-node mark-live-values* look-at-inputs ;
|
|
|
|
M: #return mark-live-values* look-at-inputs ;
|
|
|
|
: look-at-mapping ( value inputs outputs -- )
|
|
[ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
|
|
|
|
M: #copy compute-live-values*
|
|
! If the output of a copy is live, then the corresponding
|
|
! input is live also.
|
|
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
|
|
|
|
M: #call compute-live-values* nip look-at-inputs ;
|
|
|
|
M: #shuffle compute-live-values*
|
|
mapping>> at look-at-value ;
|
|
|
|
M: #alien-node compute-live-values* nip look-at-inputs ;
|
|
|
|
: filter-mapping ( assoc -- assoc' )
|
|
live-values get '[ drop _ key? ] assoc-filter ;
|
|
|
|
: filter-corresponding ( new old -- old' )
|
|
zip filter-mapping values ;
|
|
|
|
: filter-live ( values -- values' )
|
|
dup empty? [ live-values get '[ _ at ] filter ] unless ;
|
|
|
|
:: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
|
|
inputs
|
|
outputs
|
|
outputs
|
|
mapping-keys
|
|
mapping-values
|
|
filter-corresponding zip <#data-shuffle> ; inline
|
|
|
|
:: drop-dead-values ( outputs -- #shuffle )
|
|
outputs length make-values :> new-outputs
|
|
outputs filter-live :> live-outputs
|
|
new-outputs
|
|
live-outputs
|
|
outputs
|
|
new-outputs
|
|
drop-values ;
|
|
|
|
: drop-dead-outputs ( node -- #shuffle )
|
|
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
|
|
|
|
: some-outputs-dead? ( #call -- ? )
|
|
out-d>> [ live-value? not ] any? ;
|
|
|
|
: maybe-drop-dead-outputs ( node -- nodes )
|
|
dup some-outputs-dead? [
|
|
dup drop-dead-outputs 2array
|
|
] when ;
|
|
|
|
M: #introduce remove-dead-code* ( #introduce -- nodes )
|
|
maybe-drop-dead-outputs ;
|
|
|
|
M: #push remove-dead-code*
|
|
dup out-d>> first live-value? [ drop f ] unless ;
|
|
|
|
: dead-flushable-call? ( #call -- ? )
|
|
dup flushable-call? [
|
|
out-d>> [ live-value? not ] all?
|
|
] [ drop f ] if ;
|
|
|
|
: remove-flushable-call ( #call -- node )
|
|
[ word>> add-depends-on-flushable ]
|
|
[ in-d>> <#drop> remove-dead-code* ]
|
|
bi ;
|
|
|
|
: define-simplifications ( word seq -- )
|
|
"simplifications" set-word-prop ;
|
|
|
|
! true if dead
|
|
\ /mod {
|
|
{ { f t } /i }
|
|
{ { t f } mod }
|
|
} define-simplifications
|
|
|
|
\ fixnum/mod {
|
|
{ { f t } fixnum/i }
|
|
{ { t f } fixnum-mod }
|
|
} define-simplifications
|
|
|
|
\ bignum/mod {
|
|
{ { f t } bignum/i }
|
|
{ { t f } bignum-mod }
|
|
} define-simplifications
|
|
|
|
: out-d-matches? ( out-d seq -- ? )
|
|
[ swap live-value? xor ] 2all? ;
|
|
|
|
: (simplify-call) ( #call -- new-word/f )
|
|
[ out-d>> ] [ word>> "simplifications" word-prop ] bi
|
|
[ first out-d-matches? ] with find nip dup [ second ] when ;
|
|
|
|
: simplify-call ( #call -- nodes )
|
|
dup (simplify-call) [
|
|
>>word [ filter-live ] change-out-d
|
|
] [
|
|
maybe-drop-dead-outputs
|
|
] if* ;
|
|
|
|
M: #call remove-dead-code*
|
|
{
|
|
{ [ dup dead-flushable-call? ] [ remove-flushable-call ] }
|
|
{ [ dup word>> "simplifications" word-prop ] [ simplify-call ] }
|
|
[ maybe-drop-dead-outputs ]
|
|
} cond ;
|
|
|
|
M: #shuffle remove-dead-code*
|
|
[ filter-live ] change-in-d
|
|
[ filter-live ] change-out-d
|
|
[ filter-live ] change-in-r
|
|
[ filter-live ] change-out-r
|
|
[ filter-mapping ] change-mapping
|
|
dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
|
|
|
|
M: #copy remove-dead-code*
|
|
[ in-d>> ] [ out-d>> ] bi
|
|
2dup swap zip <#data-shuffle>
|
|
remove-dead-code* ;
|
|
|
|
M: #terminate remove-dead-code*
|
|
[ filter-live ] change-in-d
|
|
[ filter-live ] change-in-r ;
|
|
|
|
M: #alien-node remove-dead-code*
|
|
maybe-drop-dead-outputs ;
|
|
|
|
M: #alien-callback remove-dead-code*
|
|
[ (remove-dead-code) ] change-child ;
|