From e6282fe1a8b47dc8794031fb7b36b8f105398799 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jul 2008 01:37:11 -0500 Subject: [PATCH] Performance improvements --- core/generic/standard/engines/engines.factor | 14 ++++++-------- .../engines/predicate/predicate.factor | 19 +++++++++++++------ core/generic/standard/standard.factor | 16 +++++++++++++++- core/optimizer/inlining/inlining.factor | 18 ++++++++++-------- .../specializers/specializers.factor | 13 +------------ 5 files changed, 45 insertions(+), 35 deletions(-) diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index 20e22fde82..bdac7c1dfe 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -1,16 +1,16 @@ -USING: assocs kernel namespaces quotations generic math -sequences combinators words classes.algebra ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel kernel.private namespaces quotations +generic math sequences combinators words classes.algebra arrays +; IN: generic.standard.engines SYMBOL: default SYMBOL: assumed +SYMBOL: (dispatch#) GENERIC: engine>quot ( engine -- quot ) -M: quotation engine>quot ; - -M: method-body engine>quot 1quotation ; - : engines>quots ( assoc -- assoc' ) [ engine>quot ] assoc-map ; @@ -36,8 +36,6 @@ M: method-body engine>quot 1quotation ; r> execute r> pick set-at ] if ; inline -SYMBOL: (dispatch#) - : (picker) ( n -- quot ) { { 0 [ [ dup ] ] } diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index 9c810592a0..8846c9eee7 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: generic.standard.engines generic namespaces kernel -sequences classes.algebra accessors words combinators -assocs ; +kernel.private sequences classes.algebra accessors words +combinators assocs arrays ; IN: generic.standard.engines.predicate TUPLE: predicate-dispatch-engine methods ; @@ -24,8 +26,13 @@ C: predicate-dispatch-engine : sort-methods ( assoc -- assoc' ) >alist [ keys sort-classes ] keep extract-keys ; +: methods-with-default ( engine -- assoc ) + methods>> clone default get object bootstrap-word pick set-at ; + M: predicate-dispatch-engine engine>quot - methods>> clone - default get object bootstrap-word pick set-at engines>quots - sort-methods prune-redundant-predicates - class-predicates alist>quot ; + methods-with-default + engines>quots + sort-methods + prune-redundant-predicates + class-predicates + alist>quot ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index f8b3c00c31..2a99588db8 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -10,7 +10,16 @@ IN: generic.standard GENERIC: dispatch# ( word -- n ) -M: word dispatch# "combination" word-prop dispatch# ; +M: generic dispatch# + "combination" word-prop dispatch# ; + +GENERIC: method-declaration ( class generic -- quot ) + +M: generic method-declaration + "combination" word-prop method-declaration ; + +M: quotation engine>quot + assumed get generic get method-declaration prepend ; : unpickers { @@ -135,6 +144,9 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; +M: standard-combination method-declaration + dispatch# object swap prefix [ declare ] curry [ ] like ; + M: standard-combination next-method-quot* [ single-next-method-quot picker prepend @@ -157,6 +169,8 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; +M: hook-combination method-declaration 2drop [ ] ; + M: hook-generic extra-values drop 1 ; M: hook-generic effective-method diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 295dcaf496..618a2c746d 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -191,6 +191,10 @@ DEFER: (flat-length) : apply-identities ( node -- node/f ) dup find-identity f splice-quot ; +: splice-word-def ( #call word def -- node ) + [ drop +inlined+ depends-on ] [ swap 1array ] 2bi + splice-quot ; + : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ >r node-input-classes r> specialized-length tail* @@ -199,22 +203,20 @@ DEFER: (flat-length) 2drop f ] if ; -: splice-word-def ( #call word -- node ) - dup +inlined+ depends-on - dup def>> swap 1array splice-quot ; +: already-inlined? ( #call -- ? ) + [ param>> ] [ history>> ] bi memq? ; : optimistic-inline ( #call -- node ) - dup node-param over node-history memq? [ - drop t - ] [ - dup node-param splice-word-def + dup already-inlined? [ drop t ] [ + dup param>> dup def>> splice-word-def ] if ; : should-inline? ( word -- ? ) flat-length 11 <= ; : method-body-inline? ( #call -- ? ) - node-param dup method-body? [ should-inline? ] [ drop f ] if ; + param>> dup [ method-body? ] [ "default" word-prop not ] bi and + [ should-inline? ] [ drop f ] if ; M: #call optimize-node* { diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 90ae7fc6f9..18c960b129 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -18,13 +18,6 @@ IN: optimizer.specializers unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; -: tag-specializer ( quot -- newquot ) - [ - [ dup tag ] % - num-tags get swap , - \ dispatch , - ] [ ] make ; - : specializer-cases ( quot word -- default alist ) dup [ array? ] all? [ 1array ] unless [ [ make-specializer ] keep @@ -39,11 +32,7 @@ IN: optimizer.specializers method-declaration [ declare ] curry prepend ; : specialize-quot ( quot specializer -- quot' ) - dup { number } = [ - drop tag-specializer - ] [ - specializer-cases alist>quot - ] if ; + specializer-cases alist>quot ; : standard-method? ( method -- ? ) dup method-body? [