-! 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 ;
} 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 )
{ [ 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 ;
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 [
[
#! 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
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 ;
! 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 < ;
] 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 ] = ;