-USING: eval tools.test compiler.units vocabs words kernel ;
+USING: eval tools.test compiler.units vocabs words kernel
+definitions sequences ;
IN: compiler.tests.redefine10
-! Mixin redefinition did not recompile all necessary words.
-
-[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
+! Mixin redefinition should update predicate call sites
[ ] [
"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 ;"
+ : 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
+[ f ] [
+ 5 "my-inline-3" "compiler.tests.redefine10" lookup execute
+] unit-test
+
+[ f ] [
+ 5 "my-inline-4" "compiler.tests.redefine10" lookup execute
+] unit-test
+
+[ t ] [
+ 5 "my-inline-5" "compiler.tests.redefine10" lookup execute
+] unit-test
+
+[ t ] [
+ 5 "my-inline-6" "compiler.tests.redefine10" lookup execute
+] unit-test
+
[ ] [
"USE: math
IN: compiler.tests.redefine10
] unit-test
[ 2.0 ] [
- 1.0 "my-inline" "compiler.tests.redefine10" lookup execute
+ 1.0 "my-inline-1" "compiler.tests.redefine10" lookup execute
] unit-test
+
+[ 2.0 ] [
+ 1.0 "my-inline-2" "compiler.tests.redefine10" lookup execute
+] unit-test
+
+[ t ] [
+ 1.0 "my-inline-3" "compiler.tests.redefine10" lookup execute
+] unit-test
+
+[ t ] [
+ 1.0 "my-inline-4" "compiler.tests.redefine10" lookup execute
+] unit-test
+
+[ f ] [
+ 1.0 "my-inline-5" "compiler.tests.redefine10" lookup execute
+] unit-test
+
+[ f ] [
+ 1.0 "my-inline-6" "compiler.tests.redefine10" lookup execute
+] unit-test
+
+[
+ {
+ "my-mixin" "my-inline-1" "my-inline-2"
+ } [ "compiler.tests.redefine10" lookup forget ] each
+] with-compilation-unit
--- /dev/null
+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
--- /dev/null
+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
#! 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-folding ( #call -- )
+ dup word>> predicate?
+ [ [ node-input-infos first class>> ] [ word>> ] bi depends-on-generic ]
+ [ word>> inlined-dependency depends-on ]
+ 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
] [ drop ] if ;
: cleanup-inlining ( #call -- nodes )
! 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 ;
[
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
- [ inlined-dependency depends-on ] bi@
+ depends-on-generic
] [
[ next-method-quot ]
[ '[ _ no-next-method ] ] bi or
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 -- )
- [ update-call-sites [ changed-definition ] each ]
+ [ changed-call-sites ]
[ remake-generic drop ]
2bi ;
M: sequence update-methods ( class seq -- )
- implementors [ update-generic ] with each ;
+ [ [ predicate-word changed-call-sites ] with each ]
+ [ implementors [ update-generic ] with each ] 2bi ;
HOOK: recompile compiler-impl ( words -- alist )