diff --git a/library/compiler/optimizer/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor index ecf566fa03..4d627d5d3e 100644 --- a/library/compiler/optimizer/call-optimizers.factor +++ b/library/compiler/optimizer/call-optimizers.factor @@ -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 ; diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor index 9902d88176..0e05e8ea46 100644 --- a/library/compiler/optimizer/class-infer.factor +++ b/library/compiler/optimizer/class-infer.factor @@ -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 diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor index 2f8e2e007c..92ce37745e 100644 --- a/library/compiler/optimizer/inline-methods.factor +++ b/library/compiler/optimizer/inline-methods.factor @@ -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 ; diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor index 68b677d0cf..c7d2af0882 100644 --- a/library/generic/math-combination.factor +++ b/library/generic/math-combination.factor @@ -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 ] = ; diff --git a/library/tools/describe.factor b/library/tools/describe.factor index 5bceede23e..69c5a66632 100644 --- a/library/tools/describe.factor +++ b/library/tools/describe.factor @@ -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 ;