Aggressive arithmetic inlining

slava 2006-05-02 07:05:57 +00:00
parent eb4ba47ef1
commit fd3f37c8e3
5 changed files with 76 additions and 54 deletions

View File

@ -1,5 +1,5 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer
USING: arrays errors generic hashtables inference kernel lists
math math-internals sequences words ;
@ -63,7 +63,7 @@ math math-internals sequences words ;
} define-optimizers
: useless-coerce? ( node -- )
dup node-in-d first over node-classes ?hash
dup node-in-d first over node-class
swap node-param "infer-effect" word-prop second first eq? ;
: call>no-op ( node -- node )
@ -185,7 +185,6 @@ M: #call optimize-node* ( node -- node/t )
{ [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity nip ] [ apply-identities ] }
{ [ dup optimizer-hooks ] [ optimize-hooks ] }
{ [ dup inlining-class ] [ inline-method ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ t ] [ drop t ] }
{ [ t ] [ inline-method ] }
} cond ;

View File

@ -6,6 +6,9 @@ kernel-internals math namespaces sequences words ;
! Infer possible classes of values in a dataflow IR.
: node-class ( value node -- class )
node-classes ?hash [ object ] unless* ;
! Variables used by the class inferencer
! Current value --> class mapping

View File

@ -5,55 +5,33 @@ USING: arrays generic hashtables inference kernel lists math
namespaces sequences words ;
! Method inlining optimization
: dispatch# ( #call -- n )
node-param "combination" word-prop first ;
GENERIC: dispatching-values ( node word -- seq )
M: object dispatching-values 2drop { } ;
M: standard-generic dispatching-values
"combination" word-prop first swap
node-in-d reverse-slice nth 1array ;
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 node-in-d empty? [
drop { }
] [
dup dup node-param dispatching-values node-classes*
] if ;
: 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 already-inlined? [
drop f
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
] [
dup dispatching-classes dup empty? [
2drop f
] [
dup all-eq? [
first swap node-param order min-class
] [
2drop f
] if
] if
2drop t
] if ;
: 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 ;
: post-inline ( #return/#values #call/#merge -- )
dup [
[
@ -70,10 +48,17 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
#! last node of 'new' and the first node of 'old'.
last-node 2dup swap post-inline set-node-successor ;
: inline-method ( node -- node )
dup method-dataflow
[ >r node-param r> remember-node ] 2keep
[ subst-node ] keep ;
: (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
@ -98,3 +83,40 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
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 ;

View File

@ -7,7 +7,11 @@ math namespaces sequences words ;
! Math combination for generic dyadic upgrading arithmetic.
: math-priority ( class -- n )
"math-priority" word-prop [ 100 ] unless* ;
dup "members" word-prop [
0 [ math-priority max ] reduce
] [
"math-priority" word-prop [ 100 ] unless*
] ?if ;
: math-class< ( class class -- ? )
[ math-priority ] 2apply < ;
@ -67,11 +71,5 @@ TUPLE: no-math-method left right generic ;
] if nip
] math-vtable nip ;
: partial-math-dispatch ( 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> ;
PREDICATE: generic 2generic ( word -- ? )
"combination" word-prop [ math-combination ] = ;

View File

@ -31,7 +31,7 @@ M: object summary
: slot-sheet ( obj -- sheet )
dup class "slots" word-prop
dup [ second ] map -rot
dup [ third ] map -rot
[ first slot ] map-with
2array ;