80 lines
2.3 KiB
Factor
80 lines
2.3 KiB
Factor
! Copyright (C) 2004, 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: inference
|
|
USING: namespaces generic hashtables kernel lists sequences
|
|
vectors words ;
|
|
|
|
! Method inlining optimization
|
|
|
|
: min-class ( class seq -- class/f )
|
|
#! Is this class the smallest class in the sequence?
|
|
[ dupd class-and null = not ] subset [ class< not ] sort
|
|
tuck [ class< ] all-with? [ first ] [ drop f ] ifte ;
|
|
|
|
GENERIC: dispatching-values ( node word -- seq )
|
|
|
|
M: object dispatching-values 2drop { } ;
|
|
|
|
M: simple-generic dispatching-values drop node-in-d peek 1vector ;
|
|
|
|
M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
|
|
|
|
: node-classes* ( node seq -- seq )
|
|
>r node-classes r>
|
|
[ swap hash [ object ] unless* ] map-with ;
|
|
|
|
: dispatching-classes ( node -- seq )
|
|
dup dup node-param dispatching-values node-classes* ;
|
|
|
|
: already-inlined? ( node -- ? )
|
|
#! Was this node inlined from definition of 'word'?
|
|
dup node-param swap node-history memq? ;
|
|
|
|
: inlining-class ( #call -- class )
|
|
#! If the generic dispatch can be eliminated, return the
|
|
#! class of the method that will always be invoked here.
|
|
dup already-inlined? [
|
|
drop f
|
|
] [
|
|
dup dispatching-classes dup empty? [
|
|
2drop f
|
|
] [
|
|
dup [ = ] every? [
|
|
first swap node-param order min-class
|
|
] [
|
|
2drop f
|
|
] ifte
|
|
] ifte
|
|
] ifte ;
|
|
|
|
: will-inline ( node -- quot )
|
|
dup inlining-class swap node-param "methods" word-prop hash ;
|
|
|
|
: method-dataflow ( node -- dataflow )
|
|
dup will-inline swap node-in-d dataflow-with
|
|
dup solve-recursion ;
|
|
|
|
: inline-method ( node -- node )
|
|
#! We set the #call node's param to f so that it gets killed
|
|
#! later.
|
|
dup method-dataflow
|
|
[ >r node-param r> remember-node ] 2keep
|
|
[ subst-node ] keep ;
|
|
|
|
: related? ( actual testing -- ? )
|
|
#! If actual is a subset of testing or if the two classes
|
|
#! are disjoint, return t.
|
|
2dup class< >r class-and null = r> or ;
|
|
|
|
: optimize-predicate? ( #call -- ? )
|
|
dup node-param "predicating" word-prop dup [
|
|
>r dup node-in-d node-classes* first r> related?
|
|
] [
|
|
2drop f
|
|
] ifte ;
|
|
|
|
: optimize-predicate ( #call -- node )
|
|
dup node-param "predicating" word-prop >r
|
|
dup dup node-in-d node-classes* first r> class<
|
|
1vector inline-literals ;
|