102 lines
2.6 KiB
Factor
102 lines
2.6 KiB
Factor
! Copyright (C) 2004, 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: inference
|
|
USING: generic hashtables inference kernel lists
|
|
matrices namespaces sequences vectors ;
|
|
|
|
! We use the recursive-state variable here, to track nested
|
|
! label scopes, to prevent infinite loops when inlining
|
|
! recursive methods.
|
|
|
|
GENERIC: optimize-node* ( node -- node )
|
|
|
|
: keep-optimizing ( node -- node ? )
|
|
dup optimize-node* dup t =
|
|
[ drop f ] [ nip keep-optimizing t or ] ifte ;
|
|
|
|
DEFER: optimize-node
|
|
|
|
: optimize-children ( node -- )
|
|
f swap [
|
|
node-children [ optimize-node swap >r or r> ] map
|
|
] keep set-node-children ;
|
|
|
|
: optimize-node ( node -- node ? )
|
|
#! Outputs t if any changes were made.
|
|
keep-optimizing >r dup [
|
|
dup optimize-children >r
|
|
dup node-successor optimize-node >r
|
|
over set-node-successor r> r> r> or or
|
|
] [ r> ] ifte ;
|
|
|
|
: optimize-loop ( dataflow -- dataflow )
|
|
recursive-state off
|
|
dup kill-set over kill-node
|
|
dup infer-classes
|
|
optimize-node [ optimize-loop ] when ;
|
|
|
|
: optimize ( dataflow -- dataflow )
|
|
[
|
|
dup solve-recursion dup split-node optimize-loop
|
|
] with-scope ;
|
|
|
|
: prune-if ( node quot -- successor/t )
|
|
over >r call [ r> node-successor ] [ r> drop t ] ifte ;
|
|
inline
|
|
|
|
! Generic nodes
|
|
M: f optimize-node* drop t ;
|
|
|
|
M: node optimize-node* ( node -- t )
|
|
drop t ;
|
|
|
|
! #push
|
|
M: #push optimize-node* ( node -- node/t )
|
|
[ node-out-d empty? ] prune-if ;
|
|
|
|
! #drop
|
|
M: #drop optimize-node* ( node -- node/t )
|
|
[ node-in-d empty? ] prune-if ;
|
|
|
|
! #ifte
|
|
: static-branch? ( node -- lit ? )
|
|
node-in-d first dup literal? ;
|
|
|
|
: static-branch ( conditional n -- node )
|
|
over drop-inputs
|
|
[ >r swap node-children nth r> set-node-successor ] keep ;
|
|
|
|
M: #ifte optimize-node* ( node -- node )
|
|
dup static-branch?
|
|
[ literal-value 0 1 ? static-branch ] [ 2drop t ] ifte ;
|
|
|
|
! #values
|
|
: optimize-fold ( node -- node/t )
|
|
node-successor [ node-successor ] [ t ] ifte* ;
|
|
|
|
M: #values optimize-node* ( node -- node/t )
|
|
optimize-fold ;
|
|
|
|
! #return
|
|
M: #return optimize-node* ( node -- node/t )
|
|
optimize-fold ;
|
|
|
|
! #label
|
|
GENERIC: calls-label? ( label node -- ? )
|
|
|
|
M: node calls-label? 2drop f ;
|
|
|
|
M: #call-label calls-label? node-param eq? ;
|
|
|
|
M: #label optimize-node* ( node -- node/t )
|
|
dup node-param over node-children first calls-label? [
|
|
drop t
|
|
] [
|
|
dup node-children first dup node-successor [
|
|
dup penultimate-node rot
|
|
node-successor swap set-node-successor
|
|
] [
|
|
drop node-successor
|
|
] ifte
|
|
] ifte ;
|