diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index e9ee569fd6..60e73cb249 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -203,7 +203,14 @@ M: f ' ! Words +DEFER: emit-word + +: emit-generic ( generic -- ) + dup "default-method" word-prop method-word emit-word + "methods" word-prop [ nip method-word emit-word ] assoc-each ; + : emit-word ( word -- ) + dup generic? [ dup emit-generic ] when [ dup hashcode ' , dup word-name ' , @@ -224,7 +231,7 @@ M: f ' [ % dup word-vocabulary % " " % word-name % ] "" make throw ; : transfer-word ( word -- word ) - dup target-word [ ] [ word-name no-word ] ?if ; + dup target-word swap or ; : fixup-word ( word -- offset ) transfer-word dup objects get at @@ -248,7 +255,7 @@ M: wrapper ' emit-seq ; : pack-string ( string -- newstr ) - dup length 1+ bootstrap-cell align 0 pad-right ; + dup length bootstrap-cell align 0 pad-right ; : emit-string ( string -- ptr ) string type-number object tag-number [ @@ -285,17 +292,20 @@ M: float-array ' float-array emit-dummy-array ; ] emit-object ; : emit-tuple ( obj -- pointer ) - objects get [ + [ [ tuple>array unclip transfer-word , % ] { } make tuple type-number dup emit-array - ] cache ; inline + ] + ! Hack + over class word-name "tombstone" = + [ objects get swap cache ] [ call ] if ; M: tuple ' emit-tuple ; M: tombstone ' delegate "((tombstone))" "((empty))" ? "hashtables.private" lookup - word-def first emit-tuple ; + word-def first objects get [ emit-tuple ] cache ; M: array ' array type-number object tag-number emit-array ; @@ -313,41 +323,6 @@ M: quotation ' ] emit-object ] cache ; -! Vectors and sbufs - -M: vector ' - dup length swap underlying ' - tuple type-number tuple tag-number [ - 4 emit-fixnum - vector ' emit - f ' emit - emit ! array ptr - emit-fixnum ! length - ] emit-object ; - -M: sbuf ' - dup length swap underlying ' - tuple type-number tuple tag-number [ - 4 emit-fixnum - sbuf ' emit - f ' emit - emit ! array ptr - emit-fixnum ! length - ] emit-object ; - -! Hashes - -M: hashtable ' - [ hash-array ' ] keep - tuple type-number tuple tag-number [ - 5 emit-fixnum - hashtable ' emit - f ' emit - dup hash-count emit-fixnum - hash-deleted emit-fixnum - emit ! array ptr - ] emit-object ; - ! Curries M: curry ' diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 545d904c9c..550aac71b0 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -118,11 +118,11 @@ H{ } clone update-map set H{ } clone typemap set num-types get f builtins set -! These symbols are needed by the code that executes below -{ - { "object" "kernel" } - { "null" "kernel" } -} [ create drop ] assoc-each +! Forward definitions +"object" "kernel" create t "class" set-word-prop +"object" "kernel" create union-class "metaclass" set-word-prop + +"null" "kernel" create drop "fixnum" "math" create "fixnum?" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 8af1bfdec9..cc328e9760 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -32,6 +32,7 @@ vocabs.loader system ; "io.streams.c" require "vocabs.loader" require + "syntax" require "bootstrap.layouts" require diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 5a5a8d1c67..7a0fab8a99 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -15,7 +15,7 @@ IN: bootstrap.stage2 vm file-name windows? [ "." split1 drop ] when ".image" append "output-image" set-global - "math tools help compiler ui ui.tools io" "include" set-global + "math help compiler tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/classes/classes.factor b/core/classes/classes.factor index a6a1db7045..151429bf69 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: classes USING: arrays definitions assocs kernel diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 0adbdc080d..332903d36b 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,19 +1,34 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -generic.standard namespaces arrays ; +generic.standard namespaces arrays math quotations ; IN: classes.union PREDICATE: class union-class "metaclass" word-prop union-class eq? ; ! Union classes for dispatch on multiple classes. +: small-union-predicate-quot ( members -- quot ) + dup empty? [ + drop [ drop f ] + ] [ + unclip first "predicate" word-prop swap + [ >r "predicate" word-prop [ dup ] swap append r> ] + assoc-map alist>quot + ] if ; + +: big-union-predicate-quot ( members -- quot ) + [ small-union-predicate-quot ] [ dup ] + class-hash-dispatch-quot ; + : union-predicate-quot ( members -- quot ) - 0 (dispatch#) [ - [ [ drop t ] ] { } map>assoc - object bootstrap-word [ drop f ] 2array add* - single-combination - ] with-variable ; + [ [ drop t ] ] { } map>assoc + dup length 4 <= [ + small-union-predicate-quot + ] [ + flatten-methods + big-union-predicate-quot + ] if ; : define-union-predicate ( class -- ) dup predicate-word diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 1e6d4f8a17..631c2e4f53 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -26,7 +26,7 @@ IN: compiler >r dupd save-effect r> f pick compiler-error over compiled-unxref - over word-vocabulary [ compiled-xref ] [ 2drop ] if ; + compiled-xref ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/effects/effects.factor b/core/effects/effects.factor old mode 100644 new mode 100755 index ee929507c8..10ebca6dea --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -42,12 +42,16 @@ M: integer (stack-picture) drop "object" ; ] "" make ; : stack-effect ( word -- effect/f ) - dup symbol? [ - drop 0 1 - ] [ - { "declared-effect" "inferred-effect" } - swap word-props [ at ] curry map [ ] find nip - ] if ; + { + { [ dup symbol? ] [ drop 0 1 ] } + { [ dup "parent-generic" word-prop ] [ + "parent-generic" word-prop stack-effect + ] } + { [ t ] [ + { "declared-effect" "inferred-effect" } + swap word-props [ at ] curry map [ ] find nip + ] } + } cond ; M: effect clone [ effect-in clone ] keep effect-out clone ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index de80872b73..3d66241bc3 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -154,9 +154,17 @@ M: #if generate-node ] generate-1 ] keep ; +: tail-dispatch? ( node -- ? ) + #! Is the dispatch a jump to a tail call to a word? + dup #call? swap node-successor #return? and ; + : dispatch-branches ( node -- ) node-children [ - compiling-word get dispatch-branch %dispatch-label + dup tail-dispatch? [ + node-param + ] [ + compiling-word get dispatch-branch + ] if %dispatch-label ] each ; M: #dispatch generate-node diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index f1cdae1c91..f4da9575e9 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -125,16 +125,12 @@ HELP: method { $description "Looks up a method definition." } { $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ; -{ method method-def method-loc define-method POSTPONE: M: } related-words +{ method define-method POSTPONE: M: } related-words HELP: { $values { "def" "a quotation" } { "method" "a new method definition" } } { $description "Creates a new "{ $link method } " instance." } ; -HELP: sort-methods -{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } } -{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ; - HELP: methods { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } { $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c75dd41d74..951813dbcd 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -5,12 +5,7 @@ definitions kernel.private classes classes.private quotations arrays vocabs ; IN: generic -PREDICATE: word generic "combination" word-prop >boolean ; - -M: generic definer drop f f ; - -M: generic definition drop f ; - +! Method combination protocol GENERIC: perform-combination ( word combination -- quot ) M: object perform-combination @@ -22,22 +17,22 @@ M: object perform-combination #! the method will throw an error. We don't want that. nip [ "Invalid method combination" throw ] curry [ ] like ; +GENERIC: method-prologue ( class combination -- quot ) + +M: object method-prologue 2drop [ ] ; + +GENERIC: make-default-method ( generic combination -- method ) + +PREDICATE: word generic "combination" word-prop >boolean ; + +M: generic definer drop f f ; + +M: generic definition drop f ; + : make-generic ( word -- ) dup dup "combination" word-prop perform-combination define ; -: init-methods ( word -- ) - dup "methods" word-prop - H{ } assoc-like - "methods" set-word-prop ; - -: define-generic ( word combination -- ) - dupd "combination" set-word-prop - dup init-methods make-generic ; - -TUPLE: method loc def ; - -: ( def -- method ) - { set-method-def } \ method construct ; +TUPLE: method word def specializer generic loc ; : method ( class generic -- method/f ) "methods" word-prop at ; @@ -48,12 +43,10 @@ PREDICATE: pair method-spec : order ( generic -- seq ) "methods" word-prop keys sort-classes ; -: sort-methods ( assoc -- newassoc ) - [ keys sort-classes ] keep - [ dupd at method-def ] curry { } map>assoc ; - : methods ( word -- assoc ) - "methods" word-prop sort-methods ; + "methods" word-prop + [ keys sort-classes ] keep + [ dupd at method-word ] curry { } map>assoc ; TUPLE: check-method class generic ; @@ -66,10 +59,31 @@ TUPLE: check-method class generic ; swap [ "methods" word-prop swap call ] keep make-generic ; inline -: define-method ( method class generic -- ) - >r >r r> bootstrap-word r> check-method +: method-word-name ( class word -- string ) + word-name "/" rot word-name 3append ; + +: make-method-def ( quot word combination -- quot ) + "combination" word-prop method-prologue swap append ; + +: ( quot class generic -- word ) + [ make-method-def ] 2keep + [ method-word-name f dup ] keep + "parent-generic" set-word-prop + dup rot define ; + +: ( quot class generic -- method ) + check-method + [ ] 3keep f \ method construct-boa ; + +: define-method ( quot class generic -- ) + >r bootstrap-word r> + [ ] 2keep [ set-at ] with-methods ; +: define-default-method ( generic combination -- ) + dupd make-default-method object bootstrap-word pick + "default-method" set-word-prop ; + ! Definition protocol M: method-spec where dup first2 method [ method-loc ] [ second where ] ?if ; @@ -105,3 +119,14 @@ M: class forget* ( class -- ) M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; + +: init-methods ( word -- ) + dup "methods" word-prop + H{ } assoc-like + "methods" set-word-prop ; + +: define-generic ( word combination -- ) + 2dup "combination" set-word-prop + dupd define-default-method + dup init-methods + make-generic ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index d5079c5dfb..8cf83b0ba7 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ; : no-math-method ( left right generic -- * ) \ no-math-method construct-boa throw ; +: default-math-method ( generic -- quot ) + [ no-math-method ] curry [ ] like ; + : applicable-method ( generic class -- quot ) over method - [ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ; + [ method-word word-def ] + [ default-math-method ] ?if ; : object-method ( generic -- quot ) object bootstrap-word applicable-method ; @@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ; TUPLE: math-combination ; +M: math-combination make-default-method + drop default-math-method ; + M: math-combination perform-combination drop \ over [ diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 6cc7f7f3e8..94ac82a0e4 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,6 +8,10 @@ IN: generic.standard TUPLE: standard-combination # ; +M: standard-combination method-prologue + standard-combination-# object + swap add [ declare ] curry ; + C: standard-combination SYMBOL: (dispatch#) @@ -31,10 +35,10 @@ TUPLE: no-method object generic ; : no-method ( object generic -- * ) \ no-method construct-boa throw ; -: error-method ( word -- method ) +: error-method ( word -- quot ) picker swap [ no-method ] curry append ; -: empty-method ( word -- method ) +: empty-method ( word -- quot ) [ picker % [ delegate dup ] % unpicker over add , @@ -65,13 +69,15 @@ TUPLE: no-method object generic ; ] if ; : default-method ( word -- pair ) - empty-method object bootstrap-word swap 2array ; + "default-method" word-prop method-word + object bootstrap-word swap 2array ; : method-alist>quot ( alist base-class -- quot ) bootstrap-word swap simplify-alist class-predicates alist>quot ; : small-generic ( methods -- def ) + [ 1quotation ] assoc-map object method-alist>quot ; : hash-methods ( methods -- buckets ) @@ -83,9 +89,12 @@ TUPLE: no-method object generic ; ] if ] distribute-buckets ; +: class-hash-dispatch-quot ( methods quot picker -- quot ) + >r >r hash-methods r> map + hash-dispatch-quot r> [ class-hash ] rot 3append ; + : big-generic ( methods -- quot ) - hash-methods [ small-generic ] map - hash-dispatch-quot picker [ class-hash ] rot 3append ; + [ small-generic ] picker class-hash-dispatch-quot ; : vtable-class ( n -- class ) type>class [ hi-tag bootstrap-word ] unless* ; @@ -100,7 +109,8 @@ TUPLE: no-method object generic ; : build-type-vtable ( alist-seq -- alist-seq ) dup length [ - vtable-class swap simplify-alist + vtable-class + swap [ word-def ] assoc-map simplify-alist class-predicates alist>quot ] 2map ; @@ -137,30 +147,35 @@ TUPLE: no-method object generic ; : standard-methods ( word -- alist ) dup methods swap default-method add* ; +M: standard-combination make-default-method + standard-combination-# (dispatch#) + [ empty-method ] with-variable ; + M: standard-combination perform-combination standard-combination-# (dispatch#) [ [ standard-methods ] keep "inline" word-prop [ small-generic ] [ single-combination ] if ] with-variable ; -: default-hook-method ( word -- pair ) - error-method object bootstrap-word swap 2array ; - -: hook-methods ( word -- methods ) - dup methods [ [ drop ] swap append ] assoc-map - swap default-hook-method add* ; - TUPLE: hook-combination var ; C: hook-combination -M: hook-combination perform-combination +M: hook-combination method-prologue + 2drop [ drop ] ; + +: with-hook ( combination quot -- quot' ) 0 (dispatch#) [ - [ - hook-combination-var [ get ] curry % - hook-methods single-combination % - ] [ ] make - ] with-variable ; + swap slip + hook-combination-var [ get ] curry + swap append + ] with-variable ; inline + +M: hook-combination make-default-method + [ error-method ] with-hook ; + +M: hook-combination perform-combination + [ standard-methods single-combination ] with-hook ; : define-simple-generic ( word -- ) T{ standard-combination f 0 } define-generic ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 121c555d29..34179bbf32 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -9,9 +9,13 @@ IN: inference.backend : recursive-label ( word -- label/f ) recursive-state get at ; +: inline? ( word -- ? ) + dup "parent-generic" word-prop + [ inline? ] [ "inline" word-prop ] ?if ; + : local-recursive-state ( -- assoc ) recursive-state get dup keys - [ dup word? [ "inline" word-prop ] when not ] find drop + [ dup word? [ inline? ] when not ] find drop [ head-slice ] when* ; : inline-recursive-label ( word -- label/f ) @@ -157,7 +161,7 @@ TUPLE: too-many-r> ; meta-d get push-all ; : if-inline ( word true false -- ) - >r >r dup "inline" word-prop r> r> if ; inline + >r >r dup inline? r> r> if ; inline : consume/produce ( effect node -- ) over effect-in over consume-values @@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ; #merge node, ; inline : make-call-node ( word effect -- ) - swap dup "inline" word-prop + swap dup inline? over dup recursive-label eq? not and [ meta-d get clone -rot recursive-label #call-label [ consume/produce ] keep diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor old mode 100644 new mode 100755 index 4843a9ff26..27b1b1e0ec --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -245,11 +245,19 @@ M: #dispatch optimize-node* : dispatching-class ( node word -- class ) [ dispatch# node-class# ] keep specific-method ; +: flat-length ( seq -- n ) + [ + dup quotation? over array? or + [ flat-length ] [ drop 1 ] if + ] map sum ; + : will-inline-method ( node word -- method-spec/t quot/t ) #! t indicates failure tuck dispatching-class dup [ swap [ 2array ] 2keep - method method-def + method method-word + dup word-def flat-length 5 >= + [ 1quotation ] [ word-def ] if ] [ 2drop t t ] if ; diff --git a/core/words/words.factor b/core/words/words.factor index 5dc89212a8..b4062d8f02 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -154,7 +154,8 @@ SYMBOL: changed-words } reset-props ; : reset-generic ( word -- ) - dup reset-word { "methods" "combination" } reset-props ; + dup reset-word + { "methods" "combination" "default-method" } reset-props ; : gensym ( -- word ) "G:" \ gensym counter number>string append f ; diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor new file mode 100755 index 0000000000..34df715f89 --- /dev/null +++ b/extra/benchmark/dispatch5/dispatch5.factor @@ -0,0 +1,77 @@ +USING: classes kernel sequences vocabs math ; +IN: benchmark.dispatch5 + +MIXIN: g + +TUPLE: x1 ; +INSTANCE: x1 g +TUPLE: x2 ; +INSTANCE: x2 g +TUPLE: x3 ; +INSTANCE: x3 g +TUPLE: x4 ; +INSTANCE: x4 g +TUPLE: x5 ; +INSTANCE: x5 g +TUPLE: x6 ; +INSTANCE: x6 g +TUPLE: x7 ; +INSTANCE: x7 g +TUPLE: x8 ; +INSTANCE: x8 g +TUPLE: x9 ; +INSTANCE: x9 g +TUPLE: x10 ; +INSTANCE: x10 g +TUPLE: x11 ; +INSTANCE: x11 g +TUPLE: x12 ; +INSTANCE: x12 g +TUPLE: x13 ; +INSTANCE: x13 g +TUPLE: x14 ; +INSTANCE: x14 g +TUPLE: x15 ; +INSTANCE: x15 g +TUPLE: x16 ; +INSTANCE: x16 g +TUPLE: x17 ; +INSTANCE: x17 g +TUPLE: x18 ; +INSTANCE: x18 g +TUPLE: x19 ; +INSTANCE: x19 g +TUPLE: x20 ; +INSTANCE: x20 g +TUPLE: x21 ; +INSTANCE: x21 g +TUPLE: x22 ; +INSTANCE: x22 g +TUPLE: x23 ; +INSTANCE: x23 g +TUPLE: x24 ; +INSTANCE: x24 g +TUPLE: x25 ; +INSTANCE: x25 g +TUPLE: x26 ; +INSTANCE: x26 g +TUPLE: x27 ; +INSTANCE: x27 g +TUPLE: x28 ; +INSTANCE: x28 g +TUPLE: x29 ; +INSTANCE: x29 g +TUPLE: x30 ; +INSTANCE: x30 g + +: my-classes ( -- seq ) + "benchmark.dispatch5" words [ tuple-class? ] subset ; + +: a-bunch-of-objects ( -- seq ) + my-classes [ construct-empty ] map ; + +: dispatch-benchmark ( -- ) + 1000000 a-bunch-of-objects + [ f [ g? or ] reduce drop ] curry times ; + +MAIN: dispatch-benchmark diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 4cd25baeb9..c0da9c51bc 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -27,7 +27,7 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add spin define-method ; + pick add spin define-method ; : define-consult ( class group quot -- ) >r group-words r> diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor old mode 100644 new mode 100755 index dfb421c8f8..663df61926 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -14,8 +14,7 @@ IN: tools.crossref : (method-usage) ( word generic -- methods ) tuck methods - [ second quot-uses key? ] with subset - 0 + [ second uses member? ] with subset keys swap [ 2array ] curry map ; : method-usage ( word seq -- methods ) diff --git a/vm/types.c b/vm/types.c index 11e92ec754..78e74535b8 100755 --- a/vm/types.c +++ b/vm/types.c @@ -463,10 +463,6 @@ F_STRING* allot_string_internal(CELL capacity) { F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); - /* strings are null-terminated in memory, even though they also - have a length field. The null termination allows us to add - the sizeof(F_STRING) to a Factor string to get a C-style - char* string for C library calls. */ string->length = tag_fixnum(capacity); string->hashcode = F; string->aux = F; diff --git a/vm/types.h b/vm/types.h index e5003ea069..62b2e06dd0 100755 --- a/vm/types.h +++ b/vm/types.h @@ -11,7 +11,7 @@ INLINE CELL string_capacity(F_STRING* str) INLINE CELL string_size(CELL size) { - return sizeof(F_STRING) + size + 1; + return sizeof(F_STRING) + size; } DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)