Merge branch 'master' of git://github.com/slavapestov/factor
commit
1c8b4f08a4
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test combinators.smart math kernel accessors ;
|
||||
USING: accessors arrays combinators.smart kernel math
|
||||
tools.test ;
|
||||
IN: combinators.smart.tests
|
||||
|
||||
: test-bi ( -- 9 11 )
|
||||
|
@ -59,3 +60,6 @@ IN: combinators.smart.tests
|
|||
|
||||
[ 7 ] [ 10 3 smart-if-test ] unit-test
|
||||
[ 16 ] [ 25 41 smart-if-test ] unit-test
|
||||
|
||||
[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
|
||||
[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test
|
||||
|
|
|
@ -51,3 +51,6 @@ MACRO: nullary ( quot -- quot' )
|
|||
|
||||
MACRO: smart-if ( pred true false -- )
|
||||
'[ _ preserving _ _ if ] ;
|
||||
|
||||
MACRO: smart-apply ( quot n -- )
|
||||
[ dup inputs ] dip '[ _ _ mnapply ] ;
|
||||
|
|
|
@ -3,18 +3,16 @@
|
|||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
generic.single combinators deques search-deques macros
|
||||
source-files.errors combinators.short-circuit
|
||||
source-files.errors combinators.short-circuit classes.algebra
|
||||
|
||||
stack-checker stack-checker.dependencies stack-checker.inlining
|
||||
stack-checker.errors
|
||||
|
||||
compiler.errors compiler.units compiler.utilities
|
||||
compiler.errors compiler.units compiler.utilities compiler.crossref
|
||||
|
||||
compiler.tree.builder
|
||||
compiler.tree.optimizer
|
||||
|
||||
compiler.crossref
|
||||
|
||||
compiler.cfg
|
||||
compiler.cfg.builder
|
||||
compiler.cfg.optimizer
|
||||
|
@ -40,19 +38,18 @@ SYMBOL: compiled
|
|||
: recompile-callers? ( word -- ? )
|
||||
changed-effects get key? ;
|
||||
|
||||
: recompile-callers ( words -- )
|
||||
#! If a word's stack effect changed, recompile all words that
|
||||
#! have compiled calls to it.
|
||||
: recompile-callers ( word -- )
|
||||
#! If a word's stack effect changed, recompile all words
|
||||
#! that have compiled calls to it.
|
||||
dup recompile-callers?
|
||||
[ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
|
||||
[ effect-dependencies-of keys [ queue-compile ] each ] [ drop ] if ;
|
||||
|
||||
: compiler-message ( string -- )
|
||||
"trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
|
||||
|
||||
: start ( word -- )
|
||||
dup name>> compiler-message
|
||||
H{ } clone dependencies set
|
||||
H{ } clone generic-dependencies set
|
||||
init-dependencies
|
||||
clear-compiler-error ;
|
||||
|
||||
GENERIC: no-compile? ( word -- ? )
|
||||
|
@ -88,9 +85,9 @@ M: word combinator? inline? ;
|
|||
[ compiled-unxref ]
|
||||
[
|
||||
dup crossref? [
|
||||
dependencies get
|
||||
generic-dependencies get
|
||||
compiled-xref
|
||||
[ dependencies get generic-dependencies get compiled-xref ]
|
||||
[ conditional-dependencies get save-conditional-dependencies ]
|
||||
bi
|
||||
] [ drop ] if
|
||||
] tri ;
|
||||
|
||||
|
@ -183,6 +180,14 @@ t compile-dependencies? set-global
|
|||
|
||||
SINGLETON: optimizing-compiler
|
||||
|
||||
M: optimizing-compiler update-call-sites ( class generic -- words )
|
||||
#! Words containing call sites with inferred type 'class'
|
||||
#! which inlined a method on 'generic'
|
||||
compiled-generic-usage swap '[
|
||||
nip dup forgotten-class?
|
||||
[ drop f ] [ _ classes-intersect? ] if
|
||||
] assoc-filter keys ;
|
||||
|
||||
M: optimizing-compiler recompile ( words -- alist )
|
||||
[
|
||||
<hashed-dlist> compile-queue set
|
||||
|
@ -198,7 +203,7 @@ M: optimizing-compiler recompile ( words -- alist )
|
|||
|
||||
M: optimizing-compiler to-recompile ( -- words )
|
||||
changed-definitions get compiled-usages
|
||||
changed-generics get compiled-generic-usages
|
||||
maybe-changed get outdated-conditional-usages
|
||||
append assoc-combine keys ;
|
||||
|
||||
M: optimizing-compiler process-forgotten-words
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! 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
|
||||
stack-checker.dependencies ;
|
||||
USING: arrays assocs classes.algebra compiler.units definitions
|
||||
graphs grouping kernel namespaces sequences words fry
|
||||
stack-checker.dependencies combinators ;
|
||||
IN: compiler.crossref
|
||||
|
||||
SYMBOL: compiled-crossref
|
||||
|
@ -13,56 +13,99 @@ SYMBOL: compiled-generic-crossref
|
|||
|
||||
compiled-generic-crossref [ H{ } clone ] initialize
|
||||
|
||||
: compiled-usage ( word -- assoc )
|
||||
: effect-dependencies-of ( word -- assoc )
|
||||
compiled-crossref get at ;
|
||||
|
||||
: (compiled-usages) ( word -- assoc )
|
||||
#! If the word is not flushable anymore, we have to recompile
|
||||
#! all words which flushable away a call (presumably when the
|
||||
#! word was still flushable). If the word is flushable, we
|
||||
#! 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 ;
|
||||
: definition-dependencies-of ( word -- assoc )
|
||||
effect-dependencies-of [ nip definition-dependency dependency>= ] assoc-filter ;
|
||||
|
||||
: compiled-usages ( seq -- assocs )
|
||||
: conditional-dependencies-of ( word -- assoc )
|
||||
effect-dependencies-of [ nip conditional-dependency dependency>= ] assoc-filter ;
|
||||
|
||||
: compiled-usages ( assoc -- assocs )
|
||||
[ drop word? ] assoc-filter
|
||||
[ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
|
||||
[ [ drop definition-dependencies-of ] { } assoc>map ] keep suffix ;
|
||||
|
||||
: dependencies-satisfied? ( word cache -- ? )
|
||||
[ "dependency-checks" word-prop ] dip
|
||||
'[ _ [ satisfied? ] cache ] all? ;
|
||||
|
||||
: outdated-conditional-usages ( assoc -- assocs )
|
||||
H{ } clone '[
|
||||
drop
|
||||
conditional-dependencies-of
|
||||
[ drop _ dependencies-satisfied? not ] assoc-filter
|
||||
] { } assoc>map ;
|
||||
|
||||
: compiled-generic-usage ( word -- assoc )
|
||||
compiled-generic-crossref get at ;
|
||||
|
||||
: (compiled-generic-usages) ( generic class -- assoc )
|
||||
[ compiled-generic-usage ] dip
|
||||
[
|
||||
2dup [ valid-class? ] both?
|
||||
[ classes-intersect? ] [ 2drop f ] if nip
|
||||
] curry assoc-filter ;
|
||||
: only-xref ( assoc -- assoc' )
|
||||
[ drop crossref? ] { } assoc-filter-as ;
|
||||
|
||||
: compiled-generic-usages ( assoc -- assocs )
|
||||
[ (compiled-generic-usages) ] { } assoc>map ;
|
||||
: set-compiled-generic-uses ( word alist -- )
|
||||
concat f like "compiled-generic-uses" set-word-prop ;
|
||||
|
||||
: (compiled-xref) ( word dependencies word-prop variable -- )
|
||||
[ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
|
||||
: split-dependencies ( assoc -- effect-deps cond-deps def-deps )
|
||||
[ nip effect-dependency eq? ] assoc-partition
|
||||
[ nip conditional-dependency eq? ] assoc-partition ;
|
||||
|
||||
: (store-dependencies) ( word assoc prop -- )
|
||||
[ keys f like ] dip set-word-prop ;
|
||||
|
||||
: store-dependencies ( word assoc -- )
|
||||
split-dependencies
|
||||
"effect-dependencies" "definition-dependencies" "conditional-dependencies"
|
||||
[ (store-dependencies) ] tri-curry@ tri-curry* tri ;
|
||||
|
||||
: (compiled-xref) ( word dependencies generic-dependencies -- )
|
||||
compiled-crossref compiled-generic-crossref
|
||||
[ get add-vertex* ] bi-curry@ bi-curry* bi ;
|
||||
|
||||
: compiled-xref ( word dependencies generic-dependencies -- )
|
||||
[ [ drop crossref? ] { } assoc-filter-as ] bi@
|
||||
[ "compiled-uses" compiled-crossref (compiled-xref) ]
|
||||
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
|
||||
bi-curry* bi ;
|
||||
[ only-xref ] bi@
|
||||
[ nip set-compiled-generic-uses ]
|
||||
[ drop store-dependencies ]
|
||||
[ (compiled-xref) ]
|
||||
3tri ;
|
||||
|
||||
: (compiled-unxref) ( word word-prop variable -- )
|
||||
[ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
|
||||
[ drop [ remove-word-prop ] curry ]
|
||||
2bi bi ;
|
||||
: set-at-each ( keys assoc value -- )
|
||||
'[ _ [ _ ] 2dip set-at ] each ;
|
||||
|
||||
: join-dependencies ( effect-deps cond-deps def-deps -- assoc )
|
||||
H{ } clone [
|
||||
[ effect-dependency set-at-each ]
|
||||
[ conditional-dependency set-at-each ]
|
||||
[ definition-dependency set-at-each ] tri-curry tri*
|
||||
] keep ;
|
||||
|
||||
: load-dependencies ( word -- assoc )
|
||||
[ "effect-dependencies" word-prop ]
|
||||
[ "definition-dependencies" word-prop ]
|
||||
[ "conditional-dependencies" word-prop ] tri
|
||||
join-dependencies ;
|
||||
|
||||
: (compiled-unxref) ( word dependencies variable -- )
|
||||
get remove-vertex* ;
|
||||
|
||||
: compiled-generic-uses ( word -- alist )
|
||||
"compiled-generic-uses" word-prop 2 <groups> ;
|
||||
|
||||
: compiled-unxref ( word -- )
|
||||
[ "compiled-uses" compiled-crossref (compiled-unxref) ]
|
||||
[ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
|
||||
bi ;
|
||||
{
|
||||
[ dup load-dependencies compiled-crossref (compiled-unxref) ]
|
||||
[ dup compiled-generic-uses compiled-generic-crossref (compiled-unxref) ]
|
||||
[ "effect-dependencies" remove-word-prop ]
|
||||
[ "definition-dependencies" remove-word-prop ]
|
||||
[ "conditional-dependencies" remove-word-prop ]
|
||||
[ "compiled-generic-uses" remove-word-prop ]
|
||||
} cleave ;
|
||||
|
||||
: delete-compiled-xref ( word -- )
|
||||
[ compiled-unxref ]
|
||||
[ compiled-crossref get delete-at ]
|
||||
[ compiled-generic-crossref get delete-at ]
|
||||
tri ;
|
||||
|
||||
: save-conditional-dependencies ( word deps -- )
|
||||
keys f like "dependency-checks" set-word-prop ;
|
||||
|
|
|
@ -1,26 +1,83 @@
|
|||
USING: eval tools.test compiler.units vocabs words kernel ;
|
||||
USING: eval tools.test compiler.units vocabs words kernel
|
||||
definitions sequences math classes classes.mixin kernel.private ;
|
||||
IN: compiler.tests.redefine10
|
||||
|
||||
! Mixin redefinition did not recompile all necessary words.
|
||||
! Mixin redefinition should update predicate call sites
|
||||
|
||||
[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [
|
||||
"USING: kernel math classes ;
|
||||
IN: compiler.tests.redefine10
|
||||
MIXIN: my-mixin
|
||||
INSTANCE: fixnum my-mixin
|
||||
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;"
|
||||
eval( -- )
|
||||
] unit-test
|
||||
: 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 ;
|
||||
|
||||
[ ] [
|
||||
"USE: math
|
||||
IN: compiler.tests.redefine10
|
||||
INSTANCE: float my-mixin"
|
||||
eval( -- )
|
||||
] unit-test
|
||||
GENERIC: fake-float? ( obj -- ? )
|
||||
|
||||
[ 2.0 ] [
|
||||
1.0 "my-inline" "compiler.tests.redefine10" lookup execute
|
||||
] unit-test
|
||||
M: float fake-float? drop t ;
|
||||
M: object fake-float? drop f ;
|
||||
|
||||
: my-fake-inline-3 ( a -- b ) dup my-mixin? [ fake-float? ] [ drop f ] if ;
|
||||
|
||||
: my-baked-inline-3 ( a -- b ) { my-mixin } declare fake-float? ;
|
||||
|
||||
[ 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
|
||||
|
||||
[ t ] [ 5 my-inline-5 ] unit-test
|
||||
|
||||
[ t ] [ 5 my-inline-6 ] unit-test
|
||||
|
||||
[ ] [ [ float my-mixin add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ 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-inline-4 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-inline-5 ] unit-test
|
||||
|
||||
[ f ] [ 1.0 my-inline-6 ] unit-test
|
||||
|
|
|
@ -0,0 +1,25 @@
|
|||
USING: kernel tools.test eval words ;
|
||||
IN: compiler.tests.redefine18
|
||||
|
||||
! Mixin bug found by Doug
|
||||
|
||||
GENERIC: g1 ( a -- b )
|
||||
GENERIC: g2 ( a -- b )
|
||||
|
||||
MIXIN: c
|
||||
SINGLETON: a
|
||||
INSTANCE: a c
|
||||
|
||||
M: c g1 g2 ;
|
||||
M: a g2 drop a ;
|
||||
|
||||
MIXIN: d
|
||||
INSTANCE: d c
|
||||
|
||||
M: d g2 drop d ;
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine18 SINGLETON: b INSTANCE: b d" eval( -- ) ] unit-test
|
||||
|
||||
[ d ] [ "b" "compiler.tests.redefine18" lookup g1 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine18 FORGET: b" eval( -- ) ] unit-test
|
|
@ -0,0 +1,23 @@
|
|||
USING: kernel classes.mixin compiler.units tools.test generic ;
|
||||
IN: compiler.tests.redefine19
|
||||
|
||||
GENERIC: g ( a -- b )
|
||||
|
||||
MIXIN: m1 M: m1 g drop 1 ;
|
||||
MIXIN: m2 M: m2 g drop 2 ;
|
||||
|
||||
TUPLE: c ;
|
||||
|
||||
INSTANCE: c m2
|
||||
|
||||
: foo ( -- b ) c new g ;
|
||||
|
||||
[ 2 ] [ foo ] unit-test
|
||||
|
||||
[ ] [ [ c m1 add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ { m2 m1 } ] [ \ g order ] unit-test
|
||||
|
||||
[ 1 ] [ foo ] unit-test
|
||||
|
||||
[ ] [ [ c m1 remove-mixin-instance ] with-compilation-unit ] unit-test
|
|
@ -0,0 +1,23 @@
|
|||
IN: compiler.tests.redefine20
|
||||
USING: kernel sequences compiler.units definitions classes.mixin
|
||||
tools.test ;
|
||||
|
||||
GENERIC: cnm-recompile-test ( a -- b )
|
||||
|
||||
M: object cnm-recompile-test drop object ;
|
||||
|
||||
M: sequence cnm-recompile-test drop sequence ;
|
||||
|
||||
TUPLE: funny ;
|
||||
|
||||
M: funny cnm-recompile-test call-next-method ;
|
||||
|
||||
[ object ] [ funny new cnm-recompile-test ] unit-test
|
||||
|
||||
[ ] [ [ funny sequence add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ sequence ] [ funny new cnm-recompile-test ] unit-test
|
||||
|
||||
[ ] [ [ funny sequence remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ object ] [ funny new cnm-recompile-test ] unit-test
|
|
@ -50,11 +50,6 @@ 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'
|
||||
{
|
||||
|
@ -62,5 +57,4 @@ PRIVATE>
|
|||
{ [ 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 ;
|
||||
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences combinators fry
|
||||
classes.algebra namespaces assocs words math math.private
|
||||
|
@ -36,32 +36,51 @@ GENERIC: cleanup* ( node -- node/nodes )
|
|||
#! do it since the logic is a bit more involved
|
||||
[ cleanup* ] map-flat ;
|
||||
|
||||
! Constant folding
|
||||
: cleanup-folding? ( #call -- ? )
|
||||
node-output-infos
|
||||
[ f ] [ [ literal?>> ] all? ] if-empty ;
|
||||
|
||||
: cleanup-folding ( #call -- nodes )
|
||||
: (cleanup-folding) ( #call -- nodes )
|
||||
#! Replace a #call having a known result with a #drop of its
|
||||
#! inputs followed by #push nodes for the outputs.
|
||||
[ word>> inlined-dependency depends-on ]
|
||||
[
|
||||
[ node-output-infos ] [ out-d>> ] bi
|
||||
[ [ literal>> ] dip #push ] 2map
|
||||
]
|
||||
[ in-d>> #drop ]
|
||||
tri prefix ;
|
||||
bi prefix ;
|
||||
|
||||
: record-predicate-folding ( #call -- )
|
||||
[ node-input-infos first class>> ]
|
||||
[ word>> "predicating" word-prop ]
|
||||
[ node-output-infos first literal>> ] tri
|
||||
[ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
|
||||
|
||||
: record-folding ( #call -- )
|
||||
dup word>> predicate?
|
||||
[ record-predicate-folding ]
|
||||
[ word>> depends-on-definition ]
|
||||
if ;
|
||||
|
||||
: cleanup-folding ( #call -- nodes )
|
||||
[ (cleanup-folding) ] [ record-folding ] bi ;
|
||||
|
||||
! Method inlining
|
||||
: add-method-dependency ( #call -- )
|
||||
dup method>> word? [
|
||||
[ word>> ] [ class>> ] bi depends-on-generic
|
||||
[ [ class>> ] [ word>> ] bi depends-on-generic ]
|
||||
[ [ class>> ] [ word>> ] [ method>> ] tri depends-on-method ]
|
||||
bi
|
||||
] [ drop ] if ;
|
||||
|
||||
: cleanup-inlining ( #call -- nodes )
|
||||
[
|
||||
: record-inlining ( #call -- )
|
||||
dup method>>
|
||||
[ add-method-dependency ]
|
||||
[ word>> inlined-dependency depends-on ] if
|
||||
] [ body>> cleanup ] bi ;
|
||||
[ word>> depends-on-definition ] if ;
|
||||
|
||||
: cleanup-inlining ( #call -- nodes )
|
||||
[ record-inlining ] [ body>> cleanup ] bi ;
|
||||
|
||||
! Removing overflow checks
|
||||
: (remove-overflow-check?) ( #call -- ? )
|
||||
|
|
|
@ -9,14 +9,6 @@ compiler.tree.propagation.info
|
|||
compiler.tree.dead-code.liveness ;
|
||||
IN: compiler.tree.dead-code.simple
|
||||
|
||||
GENERIC: flushable? ( word -- ? )
|
||||
|
||||
M: predicate flushable? drop t ;
|
||||
|
||||
M: word flushable? "flushable" word-prop ;
|
||||
|
||||
M: method-body flushable? "method-generic" word-prop flushable? ;
|
||||
|
||||
: flushable-call? ( #call -- ? )
|
||||
dup word>> dup flushable? [
|
||||
"input-classes" word-prop dup [
|
||||
|
@ -98,7 +90,7 @@ M: #push remove-dead-code*
|
|||
] [ drop f ] if ;
|
||||
|
||||
: remove-flushable-call ( #call -- node )
|
||||
[ word>> flushed-dependency depends-on ]
|
||||
[ word>> depends-on-flushable ]
|
||||
[ in-d>> #drop remove-dead-code* ]
|
||||
bi ;
|
||||
|
||||
|
|
|
@ -79,3 +79,16 @@ TUPLE: a-tuple x ;
|
|||
[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
|
||||
|
||||
[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
|
||||
|
||||
! See if redefining a tuple class bumps effect counter
|
||||
TUPLE: my-tuple a b c ;
|
||||
|
||||
: my-quot ( -- quot ) [ my-tuple boa ] ;
|
||||
|
||||
: my-word ( a b c q -- result ) call( a b c -- result ) ;
|
||||
|
||||
[ T{ my-tuple f 1 2 3 } ] [ 1 2 3 my-quot my-word ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tree.propagation.call-effect.tests TUPLE: my-tuple a b ;" eval( -- ) ] unit-test
|
||||
|
||||
[ 1 2 3 my-quot my-word ] [ wrong-values? ] must-fail-with
|
||||
|
|
|
@ -2,14 +2,19 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators combinators.private effects
|
||||
fry kernel kernel.private make sequences continuations
|
||||
quotations words math stack-checker combinators.short-circuit
|
||||
stack-checker.transforms compiler.tree.propagation.info
|
||||
quotations words math stack-checker stack-checker.dependencies
|
||||
combinators.short-circuit stack-checker.transforms
|
||||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.inlining compiler.units ;
|
||||
IN: compiler.tree.propagation.call-effect
|
||||
|
||||
! call( and execute( have complex expansions.
|
||||
|
||||
! call( uses the following strategy:
|
||||
! If the input quotation is a literal, or built up from curry and
|
||||
! compose with terminal quotations literal, it is inlined at the
|
||||
! call site.
|
||||
|
||||
! For dynamic call sites, call( uses the following strategy:
|
||||
! - Inline caching. If the quotation is the same as last time, just call it unsafely
|
||||
! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
|
||||
! and compare it with declaration. If matches, call it unsafely.
|
||||
|
@ -58,7 +63,7 @@ M: compose cached-effect
|
|||
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
|
||||
|
||||
: safe-infer ( quot -- effect )
|
||||
[ infer ] [ 2drop +unknown+ ] recover ;
|
||||
[ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ;
|
||||
|
||||
: cached-effect-valid? ( quot -- ? )
|
||||
cache-counter>> effect-counter eq? ; inline
|
||||
|
|
|
@ -318,7 +318,7 @@ generic-comparison-ops [
|
|||
dup literal>> class?
|
||||
[
|
||||
literal>>
|
||||
[ inlined-dependency depends-on ]
|
||||
[ depends-on-conditionally ]
|
||||
[ predicate-output-infos ]
|
||||
bi
|
||||
] [ 2drop object-info ] if
|
||||
|
|
|
@ -36,7 +36,7 @@ M: #declare propagate-before
|
|||
#! classes mentioned in the declaration are redefined, since
|
||||
#! now we're making assumptions but their definitions.
|
||||
declaration>> [
|
||||
[ inlined-dependency depends-on ]
|
||||
[ depends-on-conditionally ]
|
||||
[ <class-info> swap refine-value-info ]
|
||||
bi
|
||||
] assoc-each ;
|
||||
|
@ -110,8 +110,9 @@ M: #declare propagate-before
|
|||
#! is redefined, since now we're making assumptions but the
|
||||
#! class definition itself.
|
||||
[ in-d>> first value-info ]
|
||||
[ "predicating" word-prop dup inlined-dependency depends-on ] bi*
|
||||
predicate-output-infos 1array ;
|
||||
[ "predicating" word-prop ] bi*
|
||||
[ nip depends-on-conditionally ]
|
||||
[ predicate-output-infos 1array ] 2bi ;
|
||||
|
||||
: default-output-value-infos ( #call word -- infos )
|
||||
"default-output-classes" word-prop
|
||||
|
|
|
@ -163,10 +163,12 @@ ERROR: bad-partial-eval quot word ;
|
|||
|
||||
: inline-new ( class -- quot/f )
|
||||
dup tuple-class? [
|
||||
dup inlined-dependency depends-on
|
||||
[ all-slots [ initial>> literalize ] map ]
|
||||
[ tuple-layout '[ _ <tuple-boa> ] ]
|
||||
bi append >quotation
|
||||
dup tuple-layout
|
||||
[ depends-on-tuple-layout ]
|
||||
[ drop all-slots [ initial>> literalize ] [ ] map-as ]
|
||||
[ nip ]
|
||||
2tri
|
||||
'[ @ _ <tuple-boa> ]
|
||||
] [ drop f ] if ;
|
||||
|
||||
\ new [ inline-new ] 1 define-partial-eval
|
||||
|
@ -293,6 +295,6 @@ CONSTANT: lookup-table-at-max 256
|
|||
! calls when a C type is redefined
|
||||
\ heap-size [
|
||||
dup word? [
|
||||
[ inlined-dependency depends-on ] [ heap-size '[ _ ] ] bi
|
||||
[ depends-on-definition ] [ heap-size '[ _ ] ] bi
|
||||
] [ drop f ] if
|
||||
] 1 define-partial-eval
|
||||
|
|
|
@ -108,3 +108,8 @@ IN: generalizations.tests
|
|||
2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread*
|
||||
] unit-test
|
||||
|
||||
[ { 1 2 } { 3 4 } { 5 6 } ]
|
||||
[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test
|
||||
|
||||
[ { 1 2 3 } { 4 5 6 } ]
|
||||
[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test
|
||||
|
|
|
@ -124,6 +124,10 @@ MACRO: cleave* ( n -- )
|
|||
MACRO: mnswap ( m n -- )
|
||||
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
|
||||
|
||||
MACRO: mnapply ( quot m n -- )
|
||||
swap
|
||||
[ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ;
|
||||
|
||||
MACRO: nweave ( n -- )
|
||||
[ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
|
||||
'[ _ _ ncleave ] ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! Copyright (C) 2005, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.order strings arrays vectors sequences
|
||||
sequences.private accessors fry ;
|
||||
|
@ -20,14 +20,16 @@ M: chunking-seq set-nth group@ <slice> 0 swap copy ;
|
|||
|
||||
M: chunking-seq like drop { } like ; inline
|
||||
|
||||
INSTANCE: chunking-seq sequence
|
||||
|
||||
MIXIN: subseq-chunking
|
||||
|
||||
INSTANCE: subseq-chunking sequence
|
||||
|
||||
M: subseq-chunking nth group@ subseq ; inline
|
||||
|
||||
MIXIN: slice-chunking
|
||||
|
||||
INSTANCE: slice-chunking sequence
|
||||
|
||||
M: slice-chunking nth group@ <slice> ; inline
|
||||
|
||||
M: slice-chunking nth-unsafe group@ slice boa ; inline
|
||||
|
|
|
@ -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* ;
|
||||
|
||||
|
|
|
@ -287,7 +287,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
|
|||
: decode-macroblock ( -- blocks )
|
||||
jpeg> components>>
|
||||
[
|
||||
[ mb-dim first2 * iota ]
|
||||
[ mb-dim first2 * ]
|
||||
[ [ decode-block ] curry replicate ] bi
|
||||
] map concat ;
|
||||
|
||||
|
|
|
@ -32,4 +32,4 @@ M: macro definition "macro" word-prop ;
|
|||
M: macro reset-word
|
||||
[ call-next-method ] [ f "macro" set-word-prop ] bi ;
|
||||
|
||||
M: macro bump-effect-counter* drop t ;
|
||||
M: macro always-bump-effect-counter? drop t ;
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
USING: accessors alien.c-types alien.data byte-arrays
|
||||
combinators.short-circuit continuations destructors init kernel
|
||||
locals namespaces random windows.advapi32 windows.errors
|
||||
windows.kernel32 windows.types math.bitwise ;
|
||||
windows.kernel32 windows.types math.bitwise sequences fry
|
||||
literals ;
|
||||
IN: random.windows
|
||||
|
||||
TUPLE: windows-rng provider type ;
|
||||
|
@ -58,13 +59,23 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
|
|||
[ CryptGenRandom win32-error=0/f ] keep
|
||||
] with-destructors ;
|
||||
|
||||
[
|
||||
MS_DEF_PROV
|
||||
PROV_RSA_FULL <windows-rng> system-random-generator set-global
|
||||
ERROR: no-windows-crypto-provider error ;
|
||||
|
||||
[ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
|
||||
[ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
|
||||
secure-random-generator set-global
|
||||
: try-crypto-providers ( seq -- windows-rng )
|
||||
[ first2 <windows-rng> ] attempt-all
|
||||
dup windows-rng? [ no-windows-crypto-provider ] unless ;
|
||||
|
||||
[
|
||||
{
|
||||
${ MS_ENHANCED_PROV PROV_RSA_FULL }
|
||||
${ MS_DEF_PROV PROV_RSA_FULL }
|
||||
} try-crypto-providers
|
||||
system-random-generator set-global
|
||||
|
||||
{
|
||||
${ MS_STRONG_PROV PROV_RSA_FULL }
|
||||
${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
|
||||
} try-crypto-providers secure-random-generator set-global
|
||||
] "random.windows" add-startup-hook
|
||||
|
||||
[
|
||||
|
|
|
@ -74,7 +74,7 @@ GENERIC: apply-object ( obj -- )
|
|||
|
||||
M: wrapper apply-object
|
||||
wrapped>>
|
||||
[ dup word? [ called-dependency depends-on ] [ drop ] if ]
|
||||
[ dup word? [ depends-on-effect ] [ drop ] if ]
|
||||
[ push-literal ]
|
||||
bi ;
|
||||
|
||||
|
|
|
@ -1,37 +1 @@
|
|||
IN: stack-checker.dependencies.tests
|
||||
USING: tools.test stack-checker.dependencies words kernel namespaces
|
||||
definitions ;
|
||||
|
||||
: computing-dependencies ( quot -- dependencies )
|
||||
H{ } clone [ dependencies rot with-variable ] keep ;
|
||||
inline
|
||||
|
||||
SYMBOL: a
|
||||
SYMBOL: b
|
||||
|
||||
[ ] [ a called-dependency depends-on ] unit-test
|
||||
|
||||
[ H{ { a called-dependency } } ] [
|
||||
[ a called-dependency depends-on ] computing-dependencies
|
||||
] unit-test
|
||||
|
||||
[ H{ { a called-dependency } { b inlined-dependency } } ] [
|
||||
[
|
||||
a called-dependency depends-on b inlined-dependency depends-on
|
||||
] computing-dependencies
|
||||
] unit-test
|
||||
|
||||
[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
|
||||
[
|
||||
a inlined-dependency depends-on
|
||||
a called-dependency depends-on
|
||||
b inlined-dependency depends-on
|
||||
] computing-dependencies
|
||||
] unit-test
|
||||
|
||||
[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
|
||||
[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
|
||||
[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
|
||||
[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
|
||||
[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
|
||||
[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
|
||||
|
|
|
@ -1,23 +1,24 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs classes.algebra fry kernel math namespaces
|
||||
sequences words ;
|
||||
USING: assocs accessors classes.algebra fry generic kernel math
|
||||
namespaces sequences words sets ;
|
||||
FROM: classes.tuple.private => tuple-layout ;
|
||||
IN: stack-checker.dependencies
|
||||
|
||||
! Words that the current quotation depends on
|
||||
SYMBOL: dependencies
|
||||
|
||||
SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
|
||||
SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
|
||||
|
||||
: index>= ( obj1 obj2 seq -- ? )
|
||||
[ index ] curry bi@ >= ;
|
||||
|
||||
: dependency>= ( how1 how2 -- ? )
|
||||
{ called-dependency flushed-dependency inlined-dependency }
|
||||
{ effect-dependency conditional-dependency definition-dependency }
|
||||
index>= ;
|
||||
|
||||
: strongest-dependency ( how1 how2 -- how )
|
||||
[ called-dependency or ] bi@ [ dependency>= ] most ;
|
||||
[ effect-dependency or ] bi@ [ dependency>= ] most ;
|
||||
|
||||
: depends-on ( word how -- )
|
||||
over primitive? [ 2drop ] [
|
||||
|
@ -26,12 +27,96 @@ SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
|
|||
] [ 3drop ] if
|
||||
] if ;
|
||||
|
||||
: depends-on-effect ( word -- )
|
||||
effect-dependency depends-on ;
|
||||
|
||||
: depends-on-conditionally ( word -- )
|
||||
conditional-dependency depends-on ;
|
||||
|
||||
: depends-on-definition ( word -- )
|
||||
definition-dependency depends-on ;
|
||||
|
||||
! Generic words that the current quotation depends on
|
||||
SYMBOL: generic-dependencies
|
||||
|
||||
: ?class-or ( class/f class -- class' )
|
||||
swap [ class-or ] when* ;
|
||||
: ?class-or ( class class/f -- class' )
|
||||
[ class-or ] when* ;
|
||||
|
||||
: depends-on-generic ( generic class -- )
|
||||
: depends-on-generic ( class generic -- )
|
||||
generic-dependencies get dup
|
||||
[ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
|
||||
[ [ ?class-or ] change-at ] [ 3drop ] if ;
|
||||
|
||||
! Conditional dependencies are re-evaluated when classes change;
|
||||
! if any fail, the word is recompiled
|
||||
SYMBOL: conditional-dependencies
|
||||
|
||||
GENERIC: satisfied? ( dependency -- ? )
|
||||
|
||||
: add-conditional-dependency ( ... class -- )
|
||||
boa conditional-dependencies get
|
||||
dup [ conjoin ] [ 2drop ] if ; inline
|
||||
|
||||
TUPLE: depends-on-class<= class1 class2 ;
|
||||
|
||||
: depends-on-class<= ( class1 class2 -- )
|
||||
\ depends-on-class<= add-conditional-dependency ;
|
||||
|
||||
M: depends-on-class<= satisfied?
|
||||
[ class1>> ] [ class2>> ] bi class<= ;
|
||||
|
||||
TUPLE: depends-on-classes-disjoint class1 class2 ;
|
||||
|
||||
: depends-on-classes-disjoint ( class1 class2 -- )
|
||||
\ depends-on-classes-disjoint add-conditional-dependency ;
|
||||
|
||||
M: depends-on-classes-disjoint satisfied?
|
||||
[ class1>> ] [ class2>> ] bi classes-intersect? not ;
|
||||
|
||||
TUPLE: depends-on-next-method class generic next-method ;
|
||||
|
||||
: depends-on-next-method ( class generic next-method -- )
|
||||
over depends-on-conditionally
|
||||
\ depends-on-next-method add-conditional-dependency ;
|
||||
|
||||
M: depends-on-next-method satisfied?
|
||||
[ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ;
|
||||
|
||||
TUPLE: depends-on-method class generic method ;
|
||||
|
||||
: depends-on-method ( class generic method -- )
|
||||
over depends-on-conditionally
|
||||
\ depends-on-method add-conditional-dependency ;
|
||||
|
||||
M: depends-on-method satisfied?
|
||||
[ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ;
|
||||
|
||||
TUPLE: depends-on-tuple-layout class layout ;
|
||||
|
||||
: depends-on-tuple-layout ( class layout -- )
|
||||
[ drop depends-on-conditionally ]
|
||||
[ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
|
||||
|
||||
M: depends-on-tuple-layout satisfied?
|
||||
[ class>> tuple-layout ] [ layout>> ] bi eq? ;
|
||||
|
||||
TUPLE: depends-on-flushable word ;
|
||||
|
||||
: depends-on-flushable ( word -- )
|
||||
[ depends-on-conditionally ]
|
||||
[ \ depends-on-flushable add-conditional-dependency ] bi ;
|
||||
|
||||
M: depends-on-flushable satisfied?
|
||||
word>> flushable? ;
|
||||
|
||||
: init-dependencies ( -- )
|
||||
H{ } clone dependencies set
|
||||
H{ } clone generic-dependencies set
|
||||
H{ } clone conditional-dependencies set ;
|
||||
|
||||
: without-dependencies ( quot -- )
|
||||
[
|
||||
dependencies off
|
||||
generic-dependencies off
|
||||
conditional-dependencies off
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
|
|
@ -140,7 +140,7 @@ SYMBOL: enter-out
|
|||
|
||||
: inline-word ( word -- )
|
||||
commit-literals
|
||||
[ inlined-dependency depends-on ]
|
||||
[ depends-on-definition ]
|
||||
[
|
||||
dup inline-recursive-label [
|
||||
call-recursive-inline-word
|
||||
|
|
|
@ -273,7 +273,7 @@ M: bad-executable summary
|
|||
\ clear t "no-compile" set-word-prop
|
||||
|
||||
: non-inline-word ( word -- )
|
||||
dup called-dependency depends-on
|
||||
dup depends-on-effect
|
||||
{
|
||||
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
|
||||
{ [ dup "special" word-prop ] [ infer-special ] }
|
||||
|
|
|
@ -124,15 +124,15 @@ IN: stack-checker.transforms
|
|||
|
||||
\ 3|| t "no-compile" set-word-prop
|
||||
|
||||
\ (call-next-method) [
|
||||
[
|
||||
: add-next-method-dependency ( method -- )
|
||||
[ "method-class" word-prop ]
|
||||
[ "method-generic" word-prop ] bi
|
||||
[ inlined-dependency depends-on ] bi@
|
||||
] [
|
||||
[ next-method-quot ]
|
||||
[ '[ _ no-next-method ] ] bi or
|
||||
] bi
|
||||
2dup next-method
|
||||
depends-on-next-method ;
|
||||
|
||||
\ (call-next-method) [
|
||||
[ add-next-method-dependency ]
|
||||
[ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi
|
||||
] 1 define-transform
|
||||
|
||||
\ (call-next-method) t "no-compile" set-word-prop
|
||||
|
@ -140,10 +140,10 @@ IN: stack-checker.transforms
|
|||
! Constructors
|
||||
\ boa [
|
||||
dup tuple-class? [
|
||||
dup inlined-dependency depends-on
|
||||
[ "boa-check" word-prop [ ] or ]
|
||||
[ tuple-layout '[ _ <tuple-boa> ] ]
|
||||
bi append
|
||||
dup tuple-layout
|
||||
[ depends-on-tuple-layout ]
|
||||
[ [ "boa-check" word-prop [ ] or ] dip ] 2bi
|
||||
'[ @ _ <tuple-boa> ]
|
||||
] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays accessors io.backend io.streams.c init fry
|
||||
namespaces math make assocs kernel parser parser.notes lexer
|
||||
|
@ -128,6 +128,7 @@ IN: tools.deploy.shaker
|
|||
"combination"
|
||||
"compiled-generic-uses"
|
||||
"compiled-uses"
|
||||
"conditional-dependencies"
|
||||
"constant"
|
||||
"constraints"
|
||||
"custom-inlining"
|
||||
|
@ -159,7 +160,6 @@ IN: tools.deploy.shaker
|
|||
"members"
|
||||
"memo-quot"
|
||||
"methods"
|
||||
"mixin"
|
||||
"method-class"
|
||||
"method-generic"
|
||||
"modular-arithmetic"
|
||||
|
|
|
@ -40,7 +40,7 @@ IN: tools.profiler
|
|||
: profiler-usage ( word -- words )
|
||||
[ smart-usage [ word? ] filter ]
|
||||
[ compiled-generic-usage keys ]
|
||||
[ compiled-usage keys ]
|
||||
[ effect-dependencies-of keys ]
|
||||
tri 3append prune ;
|
||||
|
||||
: usage-counters ( word -- alist )
|
||||
|
|
|
@ -4,6 +4,7 @@ combinators.short-circuit definitions effects fry hints
|
|||
math kernel kernel.private namespaces parser quotations
|
||||
sequences slots words locals
|
||||
locals.parser macros stack-checker.dependencies ;
|
||||
FROM: classes.tuple.private => tuple-layout ;
|
||||
IN: typed
|
||||
|
||||
ERROR: type-mismatch-error word expected-types ;
|
||||
|
@ -31,6 +32,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
|
|||
|
||||
: (unboxer) ( type -- quot )
|
||||
dup unboxable-tuple-class? [
|
||||
dup dup tuple-layout depends-on-tuple-layout
|
||||
all-slots [
|
||||
[ name>> reader-word 1quotation ]
|
||||
[ class>> (unboxer) ] bi compose
|
||||
|
@ -49,7 +51,10 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
|
|||
|
||||
: (unboxed-types) ( type -- types )
|
||||
dup unboxable-tuple-class?
|
||||
[ all-slots [ class>> (unboxed-types) ] map concat ]
|
||||
[
|
||||
dup dup tuple-layout depends-on-tuple-layout
|
||||
all-slots [ class>> (unboxed-types) ] map concat
|
||||
]
|
||||
[ 1array ] if ;
|
||||
|
||||
: unboxed-types ( types -- types' )
|
||||
|
@ -75,7 +80,12 @@ DEFER: make-boxer
|
|||
|
||||
: boxer ( type -- quot )
|
||||
dup unboxable-tuple-class?
|
||||
[ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ]
|
||||
[
|
||||
dup dup tuple-layout depends-on-tuple-layout
|
||||
[ all-slots [ class>> ] map make-boxer ]
|
||||
[ [ boa ] curry ]
|
||||
bi compose
|
||||
]
|
||||
[ drop [ ] ] if ;
|
||||
|
||||
: make-boxer ( types -- quot )
|
||||
|
@ -84,18 +94,15 @@ DEFER: make-boxer
|
|||
|
||||
! defining typed words
|
||||
|
||||
: (depends-on) ( types -- types )
|
||||
dup [ inlined-dependency depends-on ] each ; inline
|
||||
|
||||
MACRO: (typed) ( word def effect -- quot )
|
||||
[ swap ] dip
|
||||
[
|
||||
nip effect-in-types (depends-on) swap
|
||||
nip effect-in-types swap
|
||||
[ [ unboxed-types ] [ make-boxer ] bi ] dip
|
||||
'[ _ declare @ @ ]
|
||||
]
|
||||
[
|
||||
effect-out-types (depends-on)
|
||||
effect-out-types
|
||||
dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
|
||||
] 2bi ;
|
||||
|
||||
|
@ -118,9 +125,9 @@ M: typed-gensym crossref?
|
|||
[ 2nip ] 3tri define-declared ;
|
||||
|
||||
MACRO: typed ( quot word effect -- quot' )
|
||||
[ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
|
||||
[ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
|
||||
[
|
||||
nip effect-out-types (depends-on) dup typed-stack-effect?
|
||||
nip effect-out-types dup typed-stack-effect?
|
||||
[ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
|
||||
] 2bi ;
|
||||
|
||||
|
|
|
@ -126,6 +126,9 @@ call( -- )
|
|||
prepare-slots make-slots 1 finalize-slots
|
||||
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
|
||||
|
||||
: define-builtin-predicate ( class -- )
|
||||
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
|
||||
|
||||
: define-builtin ( symbol slotspec -- )
|
||||
[ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
|
||||
|
||||
|
|
|
@ -79,9 +79,9 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
|
||||
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
|
||||
|
||||
[ t ] [ growable tuple sequence class-and class<= ] unit-test
|
||||
[ f ] [ growable tuple sequence class-and class<= ] unit-test
|
||||
|
||||
[ t ] [ growable assoc class-and tuple class<= ] unit-test
|
||||
[ f ] [ growable assoc class-and tuple class<= ] unit-test
|
||||
|
||||
[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
|
||||
|
||||
|
@ -130,6 +130,14 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
[ t ] [ a union-with-one-member class<= ] unit-test
|
||||
[ f ] [ union-with-one-member class-not integer class<= ] unit-test
|
||||
|
||||
MIXIN: empty-mixin
|
||||
|
||||
[ f ] [ empty-mixin class-not null class<= ] unit-test
|
||||
[ f ] [ empty-mixin null class<= ] unit-test
|
||||
|
||||
[ t ] [ array sequence vector class-not class-and class<= ] unit-test
|
||||
[ f ] [ vector sequence vector class-not class-and class<= ] unit-test
|
||||
|
||||
! class-and
|
||||
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
|
||||
|
||||
|
@ -146,8 +154,6 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
[ t ] [ slice reversed null class-and* ] unit-test
|
||||
[ t ] [ \ f class-not \ f null class-and* ] unit-test
|
||||
|
||||
[ t ] [ vector virtual-sequence null class-and* ] unit-test
|
||||
|
||||
[ t ] [ vector array class-not vector class-and* ] unit-test
|
||||
|
||||
! class-or
|
||||
|
@ -160,6 +166,7 @@ INSTANCE: union-with-one-member mixin-with-one-member
|
|||
|
||||
! classes-intersect?
|
||||
[ t ] [ both tuple classes-intersect? ] unit-test
|
||||
|
||||
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
|
||||
|
||||
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel classes combinators accessors sequences arrays
|
||||
vectors assocs namespaces words sorting layouts math hashtables
|
||||
|
@ -34,22 +34,18 @@ DEFER: (class-or)
|
|||
|
||||
GENERIC: (flatten-class) ( class -- )
|
||||
|
||||
: normalize-class ( class -- class' )
|
||||
{
|
||||
{ [ dup members ] [ members <anonymous-union> normalize-class ] }
|
||||
{ [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
GENERIC: normalize-class ( class -- class' )
|
||||
|
||||
M: object normalize-class ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: valid-class? ( obj -- ? )
|
||||
GENERIC: forgotten-class? ( obj -- ? )
|
||||
|
||||
M: class valid-class? drop t ;
|
||||
M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
|
||||
M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
|
||||
M: anonymous-complement valid-class? class>> valid-class? ;
|
||||
M: word valid-class? drop f ;
|
||||
M: word forgotten-class? "forgotten" word-prop ;
|
||||
M: anonymous-union forgotten-class? members>> [ forgotten-class? ] any? ;
|
||||
M: anonymous-intersection forgotten-class? participants>> [ forgotten-class? ] any? ;
|
||||
M: anonymous-complement forgotten-class? class>> forgotten-class? ;
|
||||
|
||||
: class<= ( first second -- ? )
|
||||
class<=-cache get [ (class<=) ] 2cache ;
|
||||
|
@ -93,6 +89,9 @@ M: word valid-class? drop f ;
|
|||
: left-anonymous-union<= ( first second -- ? )
|
||||
[ members>> ] dip [ class<= ] curry all? ;
|
||||
|
||||
: right-union<= ( first second -- ? )
|
||||
members [ class<= ] with any? ;
|
||||
|
||||
: right-anonymous-union<= ( first second -- ? )
|
||||
members>> [ class<= ] with any? ;
|
||||
|
||||
|
@ -117,7 +116,7 @@ M: word valid-class? drop f ;
|
|||
[ class-not normalize-class ] map
|
||||
<anonymous-union>
|
||||
] }
|
||||
[ <anonymous-complement> ]
|
||||
[ drop object ]
|
||||
} cond ;
|
||||
|
||||
: left-anonymous-complement<= ( first second -- ? )
|
||||
|
@ -147,6 +146,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
|
|||
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
|
||||
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
|
||||
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
|
||||
{ [ dup members ] [ right-union<= ] }
|
||||
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
|
||||
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
|
||||
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors classes classes.algebra classes.algebra.private
|
||||
words kernel kernel.private namespaces sequences math
|
||||
|
@ -20,11 +20,6 @@ M: object class tag type>class ; inline
|
|||
|
||||
M: builtin-class rank-class drop 0 ;
|
||||
|
||||
GENERIC: define-builtin-predicate ( class -- )
|
||||
|
||||
M: builtin-class define-builtin-predicate
|
||||
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
|
||||
|
||||
M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
|
||||
|
||||
M: builtin-class (flatten-class) dup set ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays definitions assocs kernel kernel.private
|
||||
slots.private namespaces make sequences strings words words.symbol
|
||||
|
@ -37,11 +37,16 @@ PREDICATE: class < word "class" word-prop ;
|
|||
|
||||
: classes ( -- seq ) implementors-map get keys ;
|
||||
|
||||
: predicate-word ( word -- predicate )
|
||||
: create-predicate-word ( word -- predicate )
|
||||
[ name>> "?" append ] [ vocabulary>> ] bi create ;
|
||||
|
||||
: predicate-word ( word -- predicate )
|
||||
"predicate" word-prop first ;
|
||||
|
||||
PREDICATE: predicate < word "predicating" word-prop >boolean ;
|
||||
|
||||
M: predicate flushable? drop t ;
|
||||
|
||||
M: predicate forget*
|
||||
[ call-next-method ] [ f "predicating" set-word-prop ] bi ;
|
||||
|
||||
|
@ -49,8 +54,7 @@ M: predicate reset-word
|
|||
[ call-next-method ] [ f "predicating" set-word-prop ] bi ;
|
||||
|
||||
: define-predicate ( class quot -- )
|
||||
[ "predicate" word-prop first ] dip
|
||||
(( object -- ? )) define-declared ;
|
||||
[ predicate-word ] dip (( object -- ? )) define-declared ;
|
||||
|
||||
: superclass ( class -- super )
|
||||
#! Output f for non-classes to work with algebra code
|
||||
|
@ -133,19 +137,24 @@ M: sequence implementors [ implementors ] gather ;
|
|||
dup deferred? [ define-symbol ] [ drop ] if ;
|
||||
|
||||
: (define-class) ( word props -- )
|
||||
reset-caches
|
||||
[ drop update-map- ]
|
||||
[
|
||||
[
|
||||
{
|
||||
[ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
|
||||
[ dup class? [ drop ] [ implementors-map+ ] if ]
|
||||
[ reset-class ]
|
||||
[ ?define-symbol ]
|
||||
[ changed-definition ]
|
||||
[ ]
|
||||
} cleave
|
||||
] dip [ assoc-union ] curry change-props
|
||||
dup predicate-word
|
||||
dup create-predicate-word
|
||||
[ 1quotation "predicate" set-word-prop ]
|
||||
[ swap "predicating" set-word-prop ]
|
||||
[ drop t "class" set-word-prop ]
|
||||
2tri
|
||||
]
|
||||
[ drop update-map+ ]
|
||||
2tri ;
|
||||
|
||||
PRIVATE>
|
||||
|
@ -161,13 +170,7 @@ GENERIC: update-methods ( class seq -- )
|
|||
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
|
||||
|
||||
: define-class ( word superclass members participants metaclass -- )
|
||||
#! If it was already a class, update methods after.
|
||||
reset-caches
|
||||
make-class-props
|
||||
[ drop update-map- ]
|
||||
[ (define-class) ]
|
||||
[ drop update-map+ ]
|
||||
2tri ;
|
||||
make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
|
||||
|
||||
: forget-predicate ( class -- )
|
||||
dup "predicate" word-prop
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words accessors sequences kernel assocs combinators classes
|
||||
classes.algebra classes.algebra.private classes.builtin
|
||||
|
@ -8,6 +8,8 @@ IN: classes.intersection
|
|||
PREDICATE: intersection-class < class
|
||||
"metaclass" word-prop intersection-class eq? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: intersection-predicate-quot ( members -- quot )
|
||||
[
|
||||
[ drop t ]
|
||||
|
@ -23,16 +25,14 @@ PREDICATE: intersection-class < class
|
|||
|
||||
M: intersection-class update-class define-intersection-predicate ;
|
||||
|
||||
: define-intersection-class ( class participants -- )
|
||||
[ [ f f ] dip intersection-class define-class ]
|
||||
[ drop update-classes ]
|
||||
2bi ;
|
||||
|
||||
M: intersection-class rank-class drop 2 ;
|
||||
|
||||
M: intersection-class instance?
|
||||
"participants" word-prop [ instance? ] with all? ;
|
||||
|
||||
M: intersection-class normalize-class
|
||||
participants <anonymous-intersection> normalize-class ;
|
||||
|
||||
M: intersection-class (flatten-class)
|
||||
participants <anonymous-intersection> (flatten-class) ;
|
||||
|
||||
|
@ -47,3 +47,10 @@ M: anonymous-intersection (flatten-class)
|
|||
[ intersect-flattened-classes ] map-reduce
|
||||
[ dup set ] each
|
||||
] if-empty ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-intersection-class ( class participants -- )
|
||||
[ [ f f ] dip intersection-class define-class ]
|
||||
[ drop update-classes ]
|
||||
2bi ;
|
||||
|
|
|
@ -38,8 +38,8 @@ MIXIN: mx1
|
|||
INSTANCE: integer mx1
|
||||
|
||||
[ t ] [ integer mx1 class<= ] unit-test
|
||||
[ t ] [ mx1 integer class<= ] unit-test
|
||||
[ t ] [ mx1 number class<= ] unit-test
|
||||
[ f ] [ mx1 integer class<= ] unit-test
|
||||
[ f ] [ mx1 number class<= ] unit-test
|
||||
|
||||
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )
|
||||
|
||||
|
|
|
@ -1,20 +1,81 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.union words kernel sequences
|
||||
USING: classes classes.algebra classes.algebra.private
|
||||
classes.union classes.union.private words kernel sequences
|
||||
definitions combinators arrays assocs generic accessors ;
|
||||
IN: classes.mixin
|
||||
|
||||
PREDICATE: mixin-class < union-class "mixin" word-prop ;
|
||||
|
||||
M: mixin-class normalize-class ;
|
||||
|
||||
M: mixin-class (classes-intersect?)
|
||||
members [ classes-intersect? ] with any? ;
|
||||
|
||||
M: mixin-class reset-class
|
||||
[ call-next-method ] [ { "mixin" } reset-props ] bi ;
|
||||
|
||||
M: mixin-class rank-class drop 3 ;
|
||||
|
||||
TUPLE: check-mixin-class class ;
|
||||
|
||||
: check-mixin-class ( mixin -- mixin )
|
||||
dup mixin-class? [
|
||||
\ check-mixin-class boa throw
|
||||
] unless ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: redefine-mixin-class ( class members -- )
|
||||
[ (define-union-class) ]
|
||||
[ drop changed-conditionally ]
|
||||
[ drop t "mixin" set-word-prop ]
|
||||
2bi ;
|
||||
2tri ;
|
||||
|
||||
: if-mixin-member? ( class mixin true false -- )
|
||||
[ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
|
||||
|
||||
: change-mixin-class ( class mixin quot -- )
|
||||
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
|
||||
swap redefine-mixin-class ; inline
|
||||
|
||||
: (add-mixin-instance) ( class mixin -- )
|
||||
#! Call update-methods before adding the member:
|
||||
#! - Call sites of generics specializing on 'mixin'
|
||||
#! where the inferred type is 'class' are updated,
|
||||
#! - Call sites where the inferred type is a subtype
|
||||
#! of 'mixin' disjoint from 'class' are not updated
|
||||
dup class-usages {
|
||||
[ nip update-methods ]
|
||||
[ drop [ suffix ] change-mixin-class ]
|
||||
[ drop [ f ] 2dip "instances" word-prop set-at ]
|
||||
[ 2nip [ update-class ] each ]
|
||||
} 3cleave ;
|
||||
|
||||
: (remove-mixin-instance) ( class mixin -- )
|
||||
#! Call update-methods after removing the member:
|
||||
#! - Call sites of generics specializing on 'mixin'
|
||||
#! where the inferred type is 'class' are updated,
|
||||
#! - Call sites where the inferred type is a subtype
|
||||
#! of 'mixin' disjoint from 'class' are not updated
|
||||
dup class-usages {
|
||||
[ drop [ swap remove ] change-mixin-class ]
|
||||
[ drop "instances" word-prop delete-at ]
|
||||
[ 2nip [ update-class ] each ]
|
||||
[ nip update-methods ]
|
||||
} 3cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# add-mixin-instance 1 ( class mixin -- )
|
||||
|
||||
M: class add-mixin-instance
|
||||
[ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
|
||||
|
||||
: remove-mixin-instance ( class mixin -- )
|
||||
[ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
|
||||
|
||||
M: mixin-class class-forgotten remove-mixin-instance ;
|
||||
|
||||
: define-mixin-class ( class -- )
|
||||
dup mixin-class? [
|
||||
|
@ -26,73 +87,19 @@ M: mixin-class rank-class drop 3 ;
|
|||
tri
|
||||
] if ;
|
||||
|
||||
TUPLE: check-mixin-class class ;
|
||||
|
||||
: check-mixin-class ( mixin -- mixin )
|
||||
dup mixin-class? [
|
||||
\ check-mixin-class boa throw
|
||||
] unless ;
|
||||
|
||||
: if-mixin-member? ( class mixin true false -- )
|
||||
[ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
|
||||
|
||||
: change-mixin-class ( class mixin quot -- )
|
||||
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
|
||||
swap redefine-mixin-class ; inline
|
||||
|
||||
: update-classes/new ( mixin -- )
|
||||
class-usages
|
||||
[ [ update-class ] each ]
|
||||
[ implementors [ remake-generic ] each ] bi ;
|
||||
|
||||
: (add-mixin-instance) ( class mixin -- )
|
||||
[ [ suffix ] change-mixin-class ]
|
||||
[ [ f ] 2dip "instances" word-prop set-at ]
|
||||
2bi ;
|
||||
|
||||
GENERIC# add-mixin-instance 1 ( class mixin -- )
|
||||
|
||||
M: class add-mixin-instance
|
||||
#! Note: we call update-classes on the new member, not the
|
||||
#! mixin. This ensures that we only have to update the
|
||||
#! methods whose specializer intersects the new member, not
|
||||
#! the entire mixin (since the other mixin members are not
|
||||
#! affected at all). Also, all usages of the mixin will get
|
||||
#! updated by transitivity; the mixins usages appear in
|
||||
#! class-usages of the member, now that it's been added.
|
||||
[ 2drop ] [
|
||||
[ (add-mixin-instance) ] 2keep
|
||||
[ nip ] [ [ new-class? ] either? ] 2bi
|
||||
[ update-classes/new ] [ update-classes ] if
|
||||
] if-mixin-member? ;
|
||||
|
||||
: (remove-mixin-instance) ( class mixin -- )
|
||||
[ [ swap remove ] change-mixin-class ]
|
||||
[ "instances" word-prop delete-at ]
|
||||
2bi ;
|
||||
|
||||
: remove-mixin-instance ( class mixin -- )
|
||||
#! The order of the three clauses is important here. The last
|
||||
#! one must come after the other two so that the entries it
|
||||
#! adds to changed-generics are not overwritten.
|
||||
[
|
||||
[ (remove-mixin-instance) ]
|
||||
[ nip update-classes ]
|
||||
[ class-usages update-methods ]
|
||||
2tri
|
||||
] [ 2drop ] if-mixin-member? ;
|
||||
|
||||
M: mixin-class class-forgotten remove-mixin-instance ;
|
||||
|
||||
! Definition protocol implementation ensures that removing an
|
||||
! INSTANCE: declaration from a source file updates the mixin.
|
||||
TUPLE: mixin-instance class mixin ;
|
||||
|
||||
C: <mixin-instance> mixin-instance
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: >mixin-instance< ( mixin-instance -- class mixin )
|
||||
[ class>> ] [ mixin>> ] bi ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: mixin-instance where >mixin-instance< "instances" word-prop at ;
|
||||
|
||||
M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser vocabs.parser words kernel classes compiler.units lexer ;
|
||||
IN: classes.parser
|
||||
|
@ -9,7 +9,7 @@ IN: classes.parser
|
|||
: create-class-in ( string -- word )
|
||||
current-vocab create
|
||||
dup save-class-location
|
||||
dup predicate-word dup set-word save-location ;
|
||||
dup create-predicate-word dup set-word save-location ;
|
||||
|
||||
: CREATE-CLASS ( -- word )
|
||||
scan create-class-in ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.algebra classes.algebra.private kernel
|
||||
namespaces make words sequences quotations arrays kernel.private
|
||||
|
@ -8,6 +8,8 @@ IN: classes.predicate
|
|||
PREDICATE: predicate-class < class
|
||||
"metaclass" word-prop predicate-class eq? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: predicate-quot ( class -- quot )
|
||||
|
||||
M: predicate-class predicate-quot
|
||||
|
@ -18,6 +20,8 @@ M: predicate-class predicate-quot
|
|||
[ drop f ] , \ if ,
|
||||
] [ ] make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-predicate-class ( class superclass definition -- )
|
||||
[ drop f f predicate-class define-class ]
|
||||
[ nip "predicate-definition" set-word-prop ]
|
||||
|
|
|
@ -1,11 +1,16 @@
|
|||
! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.algebra classes.algebra.private
|
||||
classes.predicate kernel sequences words ;
|
||||
classes.predicate classes.predicate.private kernel sequences
|
||||
words ;
|
||||
IN: classes.singleton
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
PREDICATE: singleton-class < predicate-class
|
||||
[ "predicate-definition" word-prop ]
|
||||
[ singleton-predicate-quot ]
|
||||
|
|
|
@ -200,6 +200,8 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
|
|||
tuple>array
|
||||
tuple-slots
|
||||
}
|
||||
"Tuples can be compared for slot equality even if the tuple class overrides " { $link equal? } ":"
|
||||
{ $subsections tuple= }
|
||||
"Tuple classes can also be defined at run time:"
|
||||
{ $subsections define-tuple-class }
|
||||
{ $see-also "slots" "mirrors" } ;
|
||||
|
@ -348,8 +350,7 @@ HELP: tuple-class
|
|||
|
||||
HELP: tuple=
|
||||
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
|
||||
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
|
||||
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
|
||||
{ $description "Checks if two tuples have equal slot values. This is the default behavior of " { $link = } " on tuples, unless the tuple class subclasses " { $link identity-tuple } " or implements a method on " { $link equal? } ". In cases where equality has been redefined, this word can be used to get the default semantics if needed." } ;
|
||||
|
||||
HELP: tuple
|
||||
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
|
||||
|
|
|
@ -223,7 +223,7 @@ M: tuple-class update-class
|
|||
2drop
|
||||
[
|
||||
[ update-tuples-after ]
|
||||
[ changed-definition ]
|
||||
[ changed-conditionally ]
|
||||
bi
|
||||
] each-subclass
|
||||
]
|
||||
|
|
|
@ -1,13 +1,15 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words sequences kernel assocs combinators classes
|
||||
classes.algebra classes.algebra.private namespaces arrays math
|
||||
quotations ;
|
||||
classes.private classes.algebra classes.algebra.private
|
||||
namespaces arrays math quotations definitions ;
|
||||
IN: classes.union
|
||||
|
||||
PREDICATE: union-class < class
|
||||
"metaclass" word-prop union-class eq? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: union-predicate-quot ( members -- quot )
|
||||
[
|
||||
[ drop f ]
|
||||
|
@ -24,15 +26,23 @@ PREDICATE: union-class < class
|
|||
M: union-class update-class define-union-predicate ;
|
||||
|
||||
: (define-union-class) ( class members -- )
|
||||
f swap f union-class define-class ;
|
||||
f swap f union-class make-class-props (define-class) ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-union-class ( class members -- )
|
||||
[ (define-union-class) ] [ drop update-classes ] 2bi ;
|
||||
[ (define-union-class) ]
|
||||
[ drop changed-conditionally ]
|
||||
[ drop update-classes ]
|
||||
2tri ;
|
||||
|
||||
M: union-class rank-class drop 2 ;
|
||||
|
||||
M: union-class instance?
|
||||
"members" word-prop [ instance? ] with any? ;
|
||||
|
||||
M: union-class normalize-class
|
||||
members <anonymous-union> normalize-class ;
|
||||
|
||||
M: union-class (flatten-class)
|
||||
members <anonymous-union> (flatten-class) ;
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel continuations assocs namespaces
|
||||
sequences words vocabs definitions hashtables init sets
|
||||
|
@ -43,6 +43,20 @@ PRIVATE>
|
|||
|
||||
SYMBOL: compiler-impl
|
||||
|
||||
HOOK: update-call-sites compiler-impl ( class generic -- words )
|
||||
|
||||
: changed-call-sites ( class generic -- )
|
||||
update-call-sites [ changed-definition ] each ;
|
||||
|
||||
M: generic update-generic ( class generic -- )
|
||||
[ changed-call-sites ]
|
||||
[ remake-generic drop ]
|
||||
[ changed-conditionally drop ]
|
||||
2tri ;
|
||||
|
||||
M: sequence update-methods ( class seq -- )
|
||||
implementors [ update-generic ] with each ;
|
||||
|
||||
HOOK: recompile compiler-impl ( words -- alist )
|
||||
|
||||
HOOK: to-recompile compiler-impl ( -- words )
|
||||
|
@ -52,12 +66,14 @@ HOOK: process-forgotten-words compiler-impl ( words -- )
|
|||
: compile ( words -- ) recompile modify-code-heap ;
|
||||
|
||||
! Non-optimizing compiler
|
||||
M: f recompile
|
||||
[ dup def>> ] { } map>assoc ;
|
||||
M: f update-call-sites
|
||||
2drop { } ;
|
||||
|
||||
M: f to-recompile
|
||||
changed-definitions get [ drop word? ] assoc-filter
|
||||
changed-generics get assoc-union keys ;
|
||||
changed-definitions get [ drop word? ] assoc-filter keys ;
|
||||
|
||||
M: f recompile
|
||||
[ dup def>> ] { } map>assoc ;
|
||||
|
||||
M: f process-forgotten-words drop ;
|
||||
|
||||
|
@ -92,9 +108,9 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
! inline caching
|
||||
: effect-counter ( -- n ) 47 special-object ; inline
|
||||
|
||||
GENERIC: bump-effect-counter* ( defspec -- ? )
|
||||
GENERIC: always-bump-effect-counter? ( defspec -- ? )
|
||||
|
||||
M: object bump-effect-counter* drop f ;
|
||||
M: object always-bump-effect-counter? drop f ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -108,6 +124,7 @@ M: object bump-effect-counter* drop f ;
|
|||
dup new-definitions get first update
|
||||
dup new-definitions get second update
|
||||
dup changed-definitions get update
|
||||
dup maybe-changed get update
|
||||
dup dup changed-vocabs update ;
|
||||
|
||||
: process-forgotten-definitions ( -- )
|
||||
|
@ -117,9 +134,10 @@ M: object bump-effect-counter* drop f ;
|
|||
bi ;
|
||||
|
||||
: bump-effect-counter? ( -- ? )
|
||||
changed-effects get new-words get assoc-diff assoc-empty? not
|
||||
changed-definitions get [ drop bump-effect-counter* ] assoc-any?
|
||||
or ;
|
||||
changed-effects get
|
||||
maybe-changed get
|
||||
changed-definitions get [ drop always-bump-effect-counter? ] assoc-filter
|
||||
3array assoc-combine new-words get assoc-diff assoc-empty? not ;
|
||||
|
||||
: bump-effect-counter ( -- )
|
||||
bump-effect-counter? [
|
||||
|
@ -148,25 +166,23 @@ PRIVATE>
|
|||
: with-nested-compilation-unit ( quot -- )
|
||||
[
|
||||
H{ } clone changed-definitions set
|
||||
H{ } clone changed-generics set
|
||||
H{ } clone maybe-changed set
|
||||
H{ } clone changed-effects set
|
||||
H{ } clone outdated-generics set
|
||||
H{ } clone outdated-tuples set
|
||||
H{ } clone new-words set
|
||||
H{ } clone new-classes set
|
||||
[ finish-compilation-unit ] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: with-compilation-unit ( quot -- )
|
||||
[
|
||||
H{ } clone changed-definitions set
|
||||
H{ } clone changed-generics set
|
||||
H{ } clone maybe-changed set
|
||||
H{ } clone changed-effects set
|
||||
H{ } clone outdated-generics set
|
||||
H{ } clone forgotten-definitions set
|
||||
H{ } clone outdated-tuples set
|
||||
H{ } clone new-words set
|
||||
H{ } clone new-classes set
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[ finish-compilation-unit ] [ ] cleanup
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! Copyright (C) 2006, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences namespaces assocs math accessors ;
|
||||
IN: definitions
|
||||
|
@ -15,28 +15,23 @@ SYMBOL: changed-definitions
|
|||
: changed-definition ( defspec -- )
|
||||
dup changed-definitions get set-in-unit ;
|
||||
|
||||
SYMBOL: changed-effects
|
||||
SYMBOL: maybe-changed
|
||||
|
||||
SYMBOL: changed-generics
|
||||
: changed-conditionally ( class -- )
|
||||
dup maybe-changed get set-in-unit ;
|
||||
|
||||
SYMBOL: changed-effects
|
||||
|
||||
SYMBOL: outdated-generics
|
||||
|
||||
SYMBOL: new-words
|
||||
|
||||
SYMBOL: new-classes
|
||||
|
||||
: new-word ( word -- )
|
||||
dup new-words get set-in-unit ;
|
||||
|
||||
: new-word? ( word -- ? )
|
||||
new-words get key? ;
|
||||
|
||||
: new-class ( word -- )
|
||||
dup new-classes get set-in-unit ;
|
||||
|
||||
: new-class? ( word -- ? )
|
||||
new-classes get key? ;
|
||||
|
||||
GENERIC: where ( defspec -- loc )
|
||||
|
||||
M: object where drop f ;
|
||||
|
|
|
@ -87,21 +87,16 @@ TUPLE: check-method class generic ;
|
|||
\ check-method boa throw
|
||||
] unless ; inline
|
||||
|
||||
: changed-generic ( class generic -- )
|
||||
changed-generics get
|
||||
[ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
|
||||
|
||||
: remake-generic ( generic -- )
|
||||
dup outdated-generics get set-in-unit ;
|
||||
|
||||
: remake-generics ( -- )
|
||||
outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
|
||||
|
||||
GENERIC: update-generic ( class generic -- )
|
||||
|
||||
: with-methods ( class generic quot -- )
|
||||
[ drop changed-generic ]
|
||||
[ [ "methods" word-prop ] dip call ]
|
||||
[ drop remake-generic drop ]
|
||||
3tri ; inline
|
||||
[ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
|
||||
|
||||
: method-word-name ( class generic -- string )
|
||||
[ name>> ] bi@ "=>" glue ;
|
||||
|
@ -109,6 +104,9 @@ TUPLE: check-method class generic ;
|
|||
PREDICATE: method-body < word
|
||||
"method-generic" word-prop >boolean ;
|
||||
|
||||
M: method-body flushable?
|
||||
"method-generic" word-prop flushable? ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method-generic" word-prop stack-effect ;
|
||||
|
||||
|
@ -174,11 +172,6 @@ M: method-body forget*
|
|||
[ call-next-method ] bi
|
||||
] if ;
|
||||
|
||||
M: sequence update-methods ( class seq -- )
|
||||
implementors [
|
||||
[ changed-generic ] [ remake-generic drop ] 2bi
|
||||
] with each ;
|
||||
|
||||
: define-generic ( word combination effect -- )
|
||||
[ nip swap set-stack-effect ]
|
||||
[
|
||||
|
|
|
@ -672,6 +672,9 @@ HELP: object
|
|||
HELP: null
|
||||
{ $class-description
|
||||
"The canonical empty class with no instances."
|
||||
}
|
||||
{ $notes
|
||||
"Unlike " { $snippet "null" } " in Java or " { $snippet "NULL" } " in C++, this is not a value signifying empty, or nothing. Use " { $link f } " for this purpose."
|
||||
} ;
|
||||
|
||||
HELP: most
|
||||
|
|
|
@ -110,9 +110,14 @@ M: word make-inline
|
|||
: define-inline ( word def effect -- )
|
||||
[ define-declared ] [ 2drop make-inline ] 3bi ;
|
||||
|
||||
GENERIC: flushable? ( word -- ? )
|
||||
|
||||
M: word flushable? "flushable" word-prop ;
|
||||
|
||||
GENERIC: reset-word ( word -- )
|
||||
|
||||
M: word reset-word
|
||||
dup flushable? [ dup changed-conditionally ] when
|
||||
{
|
||||
"unannotated-def" "parsing" "inline" "recursive"
|
||||
"foldable" "flushable" "reading" "writing" "reader"
|
||||
|
|
|
@ -128,6 +128,20 @@ TR: hyphens>underscores "-" "_" ;
|
|||
[ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
|
||||
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
|
||||
|
||||
:: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
|
||||
program-instance name attribute-index :> idx
|
||||
idx 0 >= [
|
||||
idx glEnableVertexAttribArray
|
||||
idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
|
||||
] when ; inline
|
||||
|
||||
:: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
|
||||
program-instance name attribute-index :> idx
|
||||
idx 0 >= [
|
||||
idx glEnableVertexAttribArray
|
||||
idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
|
||||
] when ; inline
|
||||
|
||||
:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
|
||||
vertex-attribute name>> hyphens>underscores :> name
|
||||
vertex-attribute component-type>> :> type
|
||||
|
@ -141,23 +155,9 @@ TR: hyphens>underscores "-" "_" ;
|
|||
{ [ name not ] [ [ 2drop ] ] }
|
||||
{
|
||||
[ type unnormalized-integer-components? ]
|
||||
[
|
||||
{
|
||||
name attribute-index [ glEnableVertexAttribArray ] keep
|
||||
dim gl-type stride offset
|
||||
} >quotation :> dip-block
|
||||
|
||||
{ dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
|
||||
]
|
||||
[ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
|
||||
}
|
||||
[
|
||||
{
|
||||
name attribute-index [ glEnableVertexAttribArray ] keep
|
||||
dim gl-type normalize? stride offset
|
||||
} >quotation :> dip-block
|
||||
|
||||
{ dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
|
||||
]
|
||||
[ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
|
||||
} cond ;
|
||||
|
||||
:: [bind-vertex-format] ( vertex-attributes -- quot )
|
||||
|
|
Loading…
Reference in New Issue