Code cleanups
Slava Pestov
parent
f031a97084
commit
ab428fc259
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes.algebra compiler.units definitions graphs
|
||||
grouping kernel namespaces sequences words
|
||||
grouping kernel namespaces sequences words fry
|
||||
stack-checker.dependencies ;
|
||||
IN: compiler.crossref
|
||||
|
||||
|
|
@ -23,7 +23,7 @@ compiled-generic-crossref [ H{ } clone ] initialize
|
|||
#! don't have to recompile words that folded this away.
|
||||
[ compiled-usage ]
|
||||
[ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
|
||||
[ dependency>= nip ] curry assoc-filter ;
|
||||
'[ nip _ dependency>= ] assoc-filter ;
|
||||
|
||||
: compiled-usages ( seq -- assocs )
|
||||
[ drop word? ] assoc-filter
|
||||
|
|
@ -42,8 +42,8 @@ compiled-generic-crossref [ H{ } clone ] initialize
|
|||
bi-curry* bi ;
|
||||
|
||||
: (compiled-unxref) ( word word-prop variable -- )
|
||||
[ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
|
||||
[ drop [ remove-word-prop ] curry ]
|
||||
[ '[ dup _ word-prop 2 <groups> _ get remove-vertex* ] ]
|
||||
[ drop '[ _ remove-word-prop ] ]
|
||||
2bi bi ;
|
||||
|
||||
: compiled-unxref ( word -- )
|
||||
|
|
|
|||
|
|
@ -1,72 +1,85 @@
|
|||
USING: eval tools.test compiler.units vocabs words kernel
|
||||
definitions sequences ;
|
||||
definitions sequences math classes classes.mixin kernel.private ;
|
||||
IN: compiler.tests.redefine10
|
||||
|
||||
! Mixin redefinition should update predicate call sites
|
||||
|
||||
[ ] [
|
||||
"USING: kernel math classes ;
|
||||
IN: compiler.tests.redefine10
|
||||
MIXIN: my-mixin
|
||||
INSTANCE: fixnum my-mixin
|
||||
: my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
|
||||
: my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ;
|
||||
: my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ;
|
||||
: my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ;
|
||||
: my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ;
|
||||
: my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ;"
|
||||
eval( -- )
|
||||
] unit-test
|
||||
MIXIN: my-mixin
|
||||
INSTANCE: fixnum my-mixin
|
||||
: my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
|
||||
: my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ;
|
||||
: my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ;
|
||||
: my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ;
|
||||
: my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ;
|
||||
: my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ;
|
||||
|
||||
[ f ] [
|
||||
5 "my-inline-3" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
GENERIC: fake-float? ( obj -- ? )
|
||||
|
||||
[ f ] [
|
||||
5 "my-inline-4" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
M: float fake-float? drop t ;
|
||||
M: object fake-float? drop f ;
|
||||
|
||||
[ t ] [
|
||||
5 "my-inline-5" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
: my-fake-inline-3 ( a -- b ) dup my-mixin? [ fake-float? ] [ drop f ] if ;
|
||||
|
||||
[ t ] [
|
||||
5 "my-inline-6" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
: my-baked-inline-3 ( a -- b ) { my-mixin } declare fake-float? ;
|
||||
|
||||
[ ] [
|
||||
"USE: math
|
||||
IN: compiler.tests.redefine10
|
||||
INSTANCE: float my-mixin"
|
||||
eval( -- )
|
||||
] unit-test
|
||||
[ f ] [ 5 my-inline-3 ] unit-test
|
||||
|
||||
[ 2.0 ] [
|
||||
1.0 "my-inline-1" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
[ f ] [ 5 my-fake-inline-3 ] unit-test
|
||||
|
||||
[ 2.0 ] [
|
||||
1.0 "my-inline-2" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
[ f ] [ 5 my-baked-inline-3 ] unit-test
|
||||
|
||||
[ t ] [
|
||||
1.0 "my-inline-3" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
[ f ] [ 5 my-inline-4 ] unit-test
|
||||
|
||||
[ t ] [
|
||||
1.0 "my-inline-4" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
[ t ] [ 5 my-inline-5 ] unit-test
|
||||
|
||||
[ f ] [
|
||||
1.0 "my-inline-5" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
[ t ] [ 5 my-inline-6 ] unit-test
|
||||
|
||||
[ f ] [
|
||||
1.0 "my-inline-6" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
[ ] [ [ float my-mixin add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
"my-mixin" "my-inline-1" "my-inline-2"
|
||||
} [ "compiler.tests.redefine10" lookup forget ] each
|
||||
] with-compilation-unit
|
||||
[ 2.0 ] [ 1.0 my-inline-1 ] unit-test
|
||||
|
||||
[ 2.0 ] [ 1.0 my-inline-2 ] unit-test
|
||||
|
||||
[ t ] [ 1.0 my-inline-3 ] unit-test
|
||||
|
||||
[ t ] [ 1.0 my-fake-inline-3 ] unit-test
|
||||
|
||||
[ t ] [ 1.0 my-baked-inline-3 ] unit-test
|
||||
|
||||
[ t ] [ 1.0 my-inline-4 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-inline-5 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-inline-6 ] unit-test
|
||||
|
||||
[ ] [ [ fixnum my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ f ] [ 5 my-inline-3 ] unit-test
|
||||
|
||||
[ f ] [ 5 my-fake-inline-3 ] unit-test
|
||||
|
||||
[ f ] [ 5 my-baked-inline-3 ] unit-test
|
||||
|
||||
[ f ] [ 5 my-inline-4 ] unit-test
|
||||
|
||||
[ f ] [ 5 my-inline-5 ] unit-test
|
||||
|
||||
[ f ] [ 5 my-inline-6 ] unit-test
|
||||
|
||||
[ ] [ [ float my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ 1.0 ] [ 1.0 my-inline-1 ] unit-test
|
||||
|
||||
[ 1.0 ] [ 1.0 my-inline-2 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-inline-3 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-fake-inline-3 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-baked-inline-3 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-inline-4 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-inline-5 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-inline-6 ] unit-test
|
||||
|
|
|
|||
|
|
@ -50,17 +50,11 @@ PRIVATE>
|
|||
[ f ] dip build-tree-with ;
|
||||
|
||||
:: build-sub-tree ( in-d out-d word/quot -- nodes/f )
|
||||
#! We don't want methods on mixins to have a declaration for that mixin.
|
||||
#! This slows down compiler.tree.propagation.inlining since then every
|
||||
#! inlined usage of a method has an inline-dependency on the mixin, and
|
||||
#! not the more specific type at the call site.
|
||||
f specialize-method? [
|
||||
[
|
||||
in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
|
||||
{
|
||||
{ [ dup not ] [ ] }
|
||||
{ [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
|
||||
[ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
|
||||
} cond
|
||||
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
|
||||
] with-variable ;
|
||||
[
|
||||
in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
|
||||
{
|
||||
{ [ dup not ] [ ] }
|
||||
{ [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
|
||||
[ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
|
||||
} cond
|
||||
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
|
||||
|
|
@ -41,18 +41,13 @@ M: object specializer-declaration class ;
|
|||
: specialize-quot ( quot specializer -- quot' )
|
||||
[ drop ] [ specializer-cases ] 2bi alist>quot ;
|
||||
|
||||
! compiler.tree.propagation.inlining sets this to f
|
||||
SYMBOL: specialize-method?
|
||||
|
||||
t specialize-method? set-global
|
||||
|
||||
: method-declaration ( method -- quot )
|
||||
[ "method-generic" word-prop dispatch# object <array> ]
|
||||
[ "method-class" word-prop ]
|
||||
bi prefix [ declare ] curry [ ] like ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
|
||||
[ method-declaration prepend ]
|
||||
[ "method-generic" word-prop ] bi
|
||||
specializer [ specialize-quot ] when* ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue