steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

tools.deploy.shaker: fix regression; strip-compiler-classes wasn't working

db4
Slava Pestov 2009-08-23 17:54:37 -05:00
parent 981e8470bf
commit 387007abfe
1 changed files with 26 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
basis/tools/deploy/shaker/shaker.factor
View File

@ -6,7 +6,7 @@ vocabs sequences sequences.private words memory kernel.private
continuations io vocabs.loader system strings sets vectors quotations continuations io vocabs.loader system strings sets vectors quotations
byte-arrays sorting compiler.units definitions generic byte-arrays sorting compiler.units definitions generic
generic.standard generic.single tools.deploy.config combinators generic.standard generic.single tools.deploy.config combinators
classes slots.private ; classes classes.builtin slots.private grouping ;
QUALIFIED: bootstrap.stage2 QUALIFIED: bootstrap.stage2
QUALIFIED: command-line QUALIFIED: command-line
QUALIFIED: compiler.errors QUALIFIED: compiler.errors
@ -194,12 +194,31 @@ IN: tools.deploy.shaker
strip-word-names? [ dup strip-word-names ] when strip-word-names? [ dup strip-word-names ] when
2drop ; 2drop ;
: compiler-classes ( -- seq )
{ "compiler" "stack-checker" }
[ child-vocabs [ words ] map concat [ class? ] filter ]
map concat unique ;
: prune-decision-tree ( tree classes -- )
[ tuple class>type ] 2dip '[
dup array? [
[
dup array? [
[
2 group
[ drop _ key? not ] assoc-filter
concat
] map
] when
] map
] when
] change-nth ;
: strip-compiler-classes ( -- ) : strip-compiler-classes ( -- )
strip-dictionary? [ strip-dictionary? [
"Stripping compiler classes" show "Stripping compiler classes" show
{ "compiler" "stack-checker" } [ single-generic? ] instances
[ child-vocabs [ words ] map concat [ class? ] filter ] map concat compiler-classes '[ "decision-tree" word-prop _ prune-decision-tree ] each
[ dup implementors [ "methods" word-prop delete-at ] with each ] each
] when ; ] when ;
: recursive-subst ( seq old new -- ) : recursive-subst ( seq old new -- )
@ -440,6 +459,8 @@ SYMBOL: deploy-vocab
"vocab:tools/deploy/shaker/next-methods.factor" run-file ; "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
: (clear-megamorphic-cache) ( i array -- ) : (clear-megamorphic-cache) ( i array -- )
! Can't do any dispatch while clearing caches since that
! might leave them in an inconsistent state.
2dup 1 slot < [ 2dup 1 slot < [
2dup [ f ] 2dip set-array-nth 2dup [ f ] 2dip set-array-nth
[ 1 + ] dip (clear-megamorphic-cache) [ 1 + ] dip (clear-megamorphic-cache)
@ -465,8 +486,8 @@ SYMBOL: deploy-vocab
compute-next-methods compute-next-methods
strip-init-hooks strip-init-hooks
strip-c-io strip-c-io
strip-compiler-classes
strip-default-methods strip-default-methods
strip-compiler-classes
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main deploy-boot-quot deploy-vocab get vocab-main deploy-boot-quot
find-megamorphic-caches find-megamorphic-caches