From 962d03985227dc3e7ebbfda5d905f638453a23d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 21 Sep 2009 17:42:20 -0500 Subject: [PATCH] Rename specific-method to method-for-class, rename (effective-method) to method-for-object, and make both much faster --- basis/compiler/tests/optimizer.factor | 11 ------ .../tree/propagation/inlining/inlining.factor | 2 +- .../propagation/transforms/transforms.factor | 2 +- .../partial-dispatch/partial-dispatch.factor | 2 +- core/classes/algebra/algebra-docs.factor | 8 ++--- core/classes/algebra/algebra-tests.factor | 8 ++++- core/classes/algebra/algebra.factor | 8 ++--- core/generic/generic-tests.factor | 17 ++++++++++ core/generic/generic.factor | 34 +++++++++++++++---- core/generic/hook/hook.factor | 2 +- core/generic/math/math.factor | 6 ++-- core/generic/single/single.factor | 4 +-- core/generic/standard/standard.factor | 2 +- 13 files changed, 70 insertions(+), 36 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 45ea841a73..18679ce77b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * ) [ t ] [ \ -regression optimized? ] unit-test -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ t ] [ - reversed \ foozul specific-method - reversed \ foozul method - eq? -] unit-test - ! regression : constant-fold-2 ( -- value ) f ; foldable : constant-fold-3 ( -- value ) 4 ; foldable diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0b50632e4e..367427c716 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ; 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ [ in-d>> ] [ [ dispatch# ] keep ] bi* [ swap nth value-info class>> dup ] dip - specific-method + method-for-class ] if ] if ; diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index e08a21d4b9..8aa6a821d8 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -14,7 +14,7 @@ IN: compiler.tree.propagation.transforms ! If first input has a known type and second input is an ! object, we convert this to [ swap equal? ]. in-d>> first2 value-info class>> object class= [ - value-info class>> \ equal? specific-method + value-info class>> \ equal? method-for-class [ swap equal? ] f ? ] [ drop f ] if ] "custom-inlining" set-word-prop diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 7c66c911de..e72d77ee1f 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -147,7 +147,7 @@ SYMBOL: fast-math-ops : math-both-known? ( word left right -- ? ) 3dup math-op [ 2drop 2drop t ] - [ drop math-class-max swap specific-method >boolean ] if ; + [ drop math-class-max swap method-for-class >boolean ] if ; : (derived-ops) ( word assoc -- words ) swap '[ swap first _ eq? nip ] assoc-filter ; diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index cbf6acdeed..2e14af27f3 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -10,7 +10,6 @@ ARTICLE: "class-operations" "Class operations" { $subsection class-and } { $subsection class-or } { $subsection classes-intersect? } -{ $subsection min-class } "Low-level implementation detail:" { $subsection flatten-class } { $subsection flatten-builtin-class } @@ -37,6 +36,7 @@ $nl "Operations:" { $subsection class< } { $subsection sort-classes } +{ $subsection smallest-class } "Metaclass order:" { $subsection rank-class } ; @@ -73,6 +73,6 @@ HELP: classes-intersect? { $values { "first" class } { "second" class } { "?" "a boolean" } } { $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ; -HELP: min-class -{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } } -{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ; +HELP: smallest-class +{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } } +{ $description "Outputs a minimum class from the given sequence." } ; diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index d111d1daa2..855a15b66f 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -4,7 +4,7 @@ tools.test words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors source-files compiler.units growable random stack-checker effects kernel.private sbufs math.order -classes.tuple accessors ; +classes.tuple accessors generic.private ; IN: classes.algebra.tests : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; @@ -150,6 +150,12 @@ UNION: z1 b1 c1 ; ] unit-test ! Test method inlining +[ real ] [ { real sequence } smallest-class ] unit-test +[ real ] [ { sequence real } smallest-class ] unit-test + +: min-class ( class classes -- class/f ) + interesting-classes smallest-class ; + [ f ] [ fixnum { } min-class ] unit-test [ string ] [ diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index df4f8f2563..2d67403f94 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -214,10 +214,10 @@ ERROR: topological-sort-failed ; [ dup largest-class [ over delete-nth ] dip ] produce nip ; -: min-class ( class seq -- class/f ) - over [ classes-intersect? ] curry filter - [ drop f ] [ - [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if +: smallest-class ( classes -- class/f ) + [ f ] [ + natural-sort + [ ] [ [ class<= ] most ] map-reduce ] if-empty ; GENERIC: (flatten-class) ( class -- ) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index a63cab1c5c..e2acbb8fe6 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -186,3 +186,20 @@ GENERIC: move-method-generic ( a -- b ) [ ] [ "IN: generic.tests.a" "move-method-test-1" parse-stream drop ] unit-test [ { string } ] [ \ move-method-generic order ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ t ] [ + reversed \ foozul method-for-class + reversed \ foozul method + eq? +] unit-test + +[ t ] [ + fixnum \ <=> method-for-class + real \ <=> method + eq? +] unit-test \ No newline at end of file diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 4b398f6532..fcb7a53731 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -24,20 +24,42 @@ M: generic definition drop f ; : method ( class generic -- method/f ) "methods" word-prop at ; + + +: method-classes ( generic -- classes ) + "methods" word-prop keys ; + : order ( generic -- seq ) - "methods" word-prop keys sort-classes ; + method-classes sort-classes ; + +: nearest-class ( class generic -- class/f ) + method-classes interesting-classes smallest-class ; -: specific-method ( class generic -- method/f ) - [ nip ] [ order min-class ] 2bi - dup [ swap method ] [ 2drop f ] if ; +: method-for-class ( class generic -- method/f ) + [ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ; GENERIC: effective-method ( generic -- method ) \ effective-method t "no-compile" set-word-prop : next-method-class ( class generic -- class/f ) - order [ class<= ] with filter reverse dup length 1 = - [ drop f ] [ second ] if ; + method-classes [ class< ] with filter smallest-class ; : next-method ( class generic -- method/f ) [ next-method-class ] keep method ; diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor index 5edbc54bd8..5359f473ac 100644 --- a/core/generic/hook/hook.factor +++ b/core/generic/hook/hook.factor @@ -23,4 +23,4 @@ M: hook-combination mega-cache-quot M: hook-generic definer drop \ HOOK: f ; M: hook-generic effective-method - [ "combination" word-prop var>> get ] keep (effective-method) ; \ No newline at end of file + [ "combination" word-prop var>> get ] keep method-for-object ; \ No newline at end of file diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index e0e8b91a2c..297684014b 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -50,7 +50,7 @@ ERROR: no-math-method left right generic ; : object-method ( generic -- quot ) - object bootstrap-word applicable-method ; + object bootstrap-word (math-method) ; : math-method ( word class1 class2 -- quot ) 2dup and [ [ 2array [ declare ] curry nip ] [ math-upgrade nip ] - [ math-class-max over order min-class applicable-method ] + [ math-class-max over nearest-class (math-method) ] 3tri 3append ] [ 2drop object-method diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8a53368062..9e773fe700 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -42,8 +42,8 @@ M: single-combination next-method-quot* ( class generic combination -- quot ) ] [ 3drop f ] if ] with-combination ; -: (effective-method) ( obj word -- method ) - [ [ order [ instance? ] with find-last nip ] keep method ] +: method-for-object ( obj word -- method ) + [ [ method-classes [ instance? ] with filter smallest-class ] keep method ] [ "default-method" word-prop ] bi or ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 0d1220beac..35d299145d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -40,7 +40,7 @@ M: standard-combination dispatch# #>> ; M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep - (effective-method) ; + method-for-object ; : inline-cache-quot ( word methods miss-word -- quot ) [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ; -- 2.34.1