Performance improvements
parent
d5a526707e
commit
e6282fe1a8
|
@ -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 ] ] }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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*
|
||||
{
|
||||
|
|
|
@ -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? [
|
||||
|
|
Loading…
Reference in New Issue