123 lines
3.7 KiB
Factor
123 lines
3.7 KiB
Factor
! Copyright (C) 2004, 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: optimizer
|
|
USING: arrays generic hashtables inference kernel lists math
|
|
namespaces sequences words ;
|
|
|
|
! Method inlining optimization
|
|
: dispatch# ( #call -- n )
|
|
node-param "combination" word-prop first ;
|
|
|
|
: dispatching-class ( node -- seq )
|
|
dup dispatch# over node-in-d reverse-slice nth
|
|
swap node-class ;
|
|
|
|
: already-inlined? ( node -- ? )
|
|
#! Was this node inlined from definition of 'word'?
|
|
dup node-param swap node-history memq? ;
|
|
|
|
: specific-method ( word class -- ? ) swap order min-class ;
|
|
|
|
: inlining-class ( #call -- class )
|
|
#! If the generic dispatch can be eliminated, return the
|
|
#! class of the method that will always be invoked here.
|
|
dup node-param swap dispatching-class
|
|
specific-method ;
|
|
|
|
: will-inline-method ( node -- quot/t )
|
|
#! t indicates failure
|
|
dup inlining-class dup [
|
|
swap node-param "methods" word-prop hash
|
|
] [
|
|
2drop t
|
|
] if ;
|
|
|
|
: post-inline ( #return/#values #call/#merge -- )
|
|
dup [
|
|
[
|
|
>r node-in-d r> node-out-d
|
|
2array unify-lengths first2
|
|
] keep subst-values
|
|
] [
|
|
2drop
|
|
] if ;
|
|
|
|
: subst-node ( old new -- )
|
|
#! The last node of 'new' becomes 'old', then values are
|
|
#! substituted. A subsequent optimizer phase kills the
|
|
#! last node of 'new' and the first node of 'old'.
|
|
last-node 2dup swap post-inline set-node-successor ;
|
|
|
|
: (inline-method) ( #call quot -- node )
|
|
dup t eq? [
|
|
2drop t
|
|
] [
|
|
over node-in-d dataflow-with
|
|
[ >r node-param r> remember-node ] 2keep
|
|
[ subst-node ] keep
|
|
] if ;
|
|
|
|
: inline-standard-method ( node -- node )
|
|
dup will-inline-method (inline-method) ;
|
|
|
|
: comparable? ( actual testing -- ? )
|
|
#! If actual is a subset of testing or if the two classes
|
|
#! are disjoint, return t.
|
|
2dup class< >r classes-intersect? not r> or ;
|
|
|
|
: optimize-predicate? ( #call -- ? )
|
|
dup node-param "predicating" word-prop dup [
|
|
>r dup node-in-d node-classes* first r> comparable?
|
|
] [
|
|
2drop f
|
|
] if ;
|
|
|
|
: inline-literals ( node literals -- node )
|
|
#! Make #shuffle -> #push -> #return -> successor
|
|
over drop-inputs [
|
|
>r >list [ literalize ] map dataflow [ subst-node ] keep
|
|
r> set-node-successor
|
|
] keep ;
|
|
|
|
: optimize-predicate ( #call -- node )
|
|
dup node-param "predicating" word-prop >r
|
|
dup dup node-in-d node-classes* first r> class<
|
|
1array inline-literals ;
|
|
|
|
: math-both-known? ( word left right -- ? )
|
|
math-class-max specific-method ;
|
|
|
|
: partial-math ( word class left/right -- vtable )
|
|
dup \ dup \ over ? [
|
|
( word class left/right class )
|
|
>r 3dup r> swap [ swap ] unless math-method
|
|
] math-vtable >r 3drop r> ;
|
|
|
|
: will-inline-math-method ( word left right -- quot/t )
|
|
#! t indicates failure
|
|
{
|
|
{ [ 3dup math-both-known? ] [ math-method ] }
|
|
{ [ 3dup drop specific-method ] [ drop t partial-math ] }
|
|
{ [ 3dup nip specific-method ] [ nip f partial-math ] }
|
|
{ [ t ] [ 3drop t ] }
|
|
} cond ;
|
|
|
|
: inline-math-method ( #call -- node )
|
|
dup node-param
|
|
over dup node-in-d [ swap node-class ] map-with first2
|
|
will-inline-math-method (inline-method) ;
|
|
|
|
: inline-standard-method? ( #call -- ? )
|
|
dup already-inlined? not swap node-param standard-generic?
|
|
and ;
|
|
|
|
: inline-math-method? ( #call -- ? )
|
|
dup node-history empty? swap node-param 2generic? and ;
|
|
|
|
: inline-method ( #call -- node )
|
|
{
|
|
{ [ dup inline-standard-method? ] [ inline-standard-method ] }
|
|
{ [ dup inline-math-method? ] [ inline-math-method ] }
|
|
{ [ t ] [ drop t ] }
|
|
} cond ;
|