Performance improvements

db4
Slava Pestov 2008-07-06 01:37:11 -05:00
parent d5a526707e
commit e6282fe1a8
5 changed files with 45 additions and 35 deletions

View File

@ -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 ] ] }

View File

@ -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> 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 ;

View File

@ -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 <array> 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

View File

@ -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*
{

View File

@ -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 <array> ,
\ 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? [