Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-07-05 03:47:35 -05:00
commit 65036db93e
4 changed files with 52 additions and 25 deletions

View File

@ -138,7 +138,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ; dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype ) : tuple-prototype ( class -- prototype )
[ all-slots [ initial>> ] map ] keep slots>tuple ; [ all-slots [ initial>> ] map ] keep
over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- ) : define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ; dup tuple-prototype "prototype" set-word-prop ;
@ -317,7 +318,8 @@ M: tuple hashcode*
] recursive-hashcode ; ] recursive-hashcode ;
M: tuple-class new M: tuple-class new
"prototype" word-prop (clone) ; dup "prototype" word-prop
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa M: tuple-class boa
[ "boa-check" word-prop call ] [ "boa-check" word-prop call ]

View File

@ -12,42 +12,36 @@ namespaces continuations layouts accessors ;
] with-directory ; ] with-directory ;
: small-enough? ( n -- ? ) : small-enough? ( n -- ? )
>r "test.image" temp-file file-info size>> r> <= ; >r "test.image" temp-file file-info size>> r> cell 4 / * <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test [ ] [ "hello-world" shake-and-bake ] unit-test
[ t ] [ [ t ] [ 50000 small-enough? ] unit-test
cell 8 = 8 5 ? 100000 * small-enough?
] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test
[ t ] [ [ t ] [ 80000 small-enough? ] unit-test
cell 8 = 20 10 ? 100000 * small-enough?
] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test
[ t ] [ 130000 small-enough? ] unit-test
[ "staging.math-compiler-ui-strip.image" ] [ [ "staging.math-compiler-ui-strip.image" ] [
"hello-ui" deploy-config "hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind [ bootstrap-profile staging-image-name file-name ] bind
] unit-test ] unit-test
[ t ] [
cell 8 = 35 17 ? 100000 * small-enough?
] unit-test
[ ] [ "maze" shake-and-bake ] unit-test [ ] [ "maze" shake-and-bake ] unit-test
[ t ] [ [ t ] [ 120000 small-enough? ] unit-test
cell 8 = 30 15 ? 100000 * small-enough?
] unit-test [ ] [ "tetris" shake-and-bake ] unit-test
[ t ] [ 120000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ [ t ] [ 250000 small-enough? ] unit-test
cell 8 = 50 30 ? 100000 * small-enough?
] unit-test
{ {
"tools.deploy.test.1" "tools.deploy.test.1"

View File

@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces
assocs kernel parser lexer strings.parser tools.deploy.config assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system continuations io prettyprint vocabs.loader debugger system
strings sets ; strings sets vectors quotations byte-arrays ;
QUALIFIED: bootstrap.stage2 QUALIFIED: bootstrap.stage2
QUALIFIED: classes QUALIFIED: classes
QUALIFIED: command-line QUALIFIED: command-line
@ -79,8 +79,8 @@ IN: tools.deploy.shaker
[ [
[ [
props>> swap props>> swap
'[ drop , member? not ] assoc-filter '[ drop , member? not ] assoc-filter sift-assoc
sift-assoc f assoc-like dup assoc-empty? [ drop f ] [ >alist >vector ] if
] keep (>>props) ] keep (>>props)
] with each ; ] with each ;
@ -93,7 +93,10 @@ IN: tools.deploy.shaker
"compiled-uses" "compiled-uses"
"constraints" "constraints"
"declared-effect" "declared-effect"
"default"
"default-method"
"default-output-classes" "default-output-classes"
"derived-from"
"identities" "identities"
"if-intrinsics" "if-intrinsics"
"infer" "infer"
@ -103,15 +106,18 @@ IN: tools.deploy.shaker
"loc" "loc"
"members" "members"
"methods" "methods"
"method-class"
"method-generic"
"combination" "combination"
"cannot-infer" "cannot-infer"
"default-method" "no-compile"
"optimizer-hooks" "optimizer-hooks"
"output-classes" "output-classes"
"participants" "participants"
"predicate" "predicate"
"predicate-definition" "predicate-definition"
"predicating" "predicating"
"tuple-dispatch-generic"
"slots" "slots"
"slot-names" "slot-names"
"specializer" "specializer"
@ -127,6 +133,8 @@ IN: tools.deploy.shaker
strip-prettyprint? [ strip-prettyprint? [
{ {
"break-before"
"break-after"
"delimiter" "delimiter"
"flushable" "flushable"
"foldable" "foldable"
@ -265,13 +273,27 @@ IN: tools.deploy.shaker
21 setenv 21 setenv
] [ drop ] if ; ] [ drop ] if ;
: compress ( pred string -- )
"Compressing " prepend show
instances
dup H{ } clone [ [ ] cache ] curry map
become ; inline
: compress-byte-arrays ( -- )
[ byte-array? ] "byte arrays" compress ;
: compress-quotations ( -- )
[ quotation? ] "quotations" compress ;
: compress-strings ( -- )
[ string? ] "strings" compress ;
: finish-deploy ( final-image -- ) : finish-deploy ( final-image -- )
"Finishing up" show "Finishing up" show
>r { } set-datastack r> >r { } set-datastack r>
{ } set-retainstack { } set-retainstack
V{ } set-namestack V{ } set-namestack
V{ } set-catchstack V{ } set-catchstack
"Saving final image" show "Saving final image" show
[ save-image-and-exit ] call-clear ; [ save-image-and-exit ] call-clear ;
@ -295,7 +317,10 @@ SYMBOL: deploy-vocab
deploy-vocab get vocab-main set-boot-quot* deploy-vocab get vocab-main set-boot-quot*
stripped-word-props >r stripped-word-props >r
stripped-globals strip-globals stripped-globals strip-globals
r> strip-words ; r> strip-words
compress-byte-arrays
compress-quotations
compress-strings ;
: (deploy) ( final-image vocab config -- ) : (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave #! Does the actual work of a deployment in the slave

View File

@ -308,6 +308,8 @@ DEFINE_PRIMITIVE(code_room)
/* Dump all code blocks for debugging */ /* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap) void dump_heap(F_HEAP *heap)
{ {
CELL size = 0;
F_BLOCK *scan = first_block(heap); F_BLOCK *scan = first_block(heap);
while(scan) while(scan)
@ -319,9 +321,11 @@ void dump_heap(F_HEAP *heap)
status = "free"; status = "free";
break; break;
case B_ALLOCATED: case B_ALLOCATED:
size += object_size(block_to_compiled(scan)->relocation);
status = "allocated"; status = "allocated";
break; break;
case B_MARKED: case B_MARKED:
size += object_size(block_to_compiled(scan)->relocation);
status = "marked"; status = "marked";
break; break;
default: default:
@ -333,6 +337,8 @@ void dump_heap(F_HEAP *heap)
scan = next_block(heap,scan); scan = next_block(heap,scan);
} }
printf("%ld bytes of relocation data\n",size);
} }
/* Compute where each block is going to go, after compaction */ /* Compute where each block is going to go, after compaction */