diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index e85905a551..66a75387f1 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -138,7 +138,8 @@ ERROR: bad-superclass class ; dup boa-check-quot "boa-check" set-word-prop ; : 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 -- ) dup tuple-prototype "prototype" set-word-prop ; @@ -317,7 +318,8 @@ M: tuple hashcode* ] recursive-hashcode ; M: tuple-class new - "prototype" word-prop (clone) ; + dup "prototype" word-prop + [ (clone) ] [ tuple-layout ] ?if ; M: tuple-class boa [ "boa-check" word-prop call ] diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 86691e89a0..8a0f0e5468 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -12,42 +12,36 @@ namespaces continuations layouts accessors ; ] with-directory ; : 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 -[ t ] [ - cell 8 = 8 5 ? 100000 * small-enough? -] unit-test +[ t ] [ 50000 small-enough? ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test -[ t ] [ - cell 8 = 20 10 ? 100000 * small-enough? -] unit-test +[ t ] [ 80000 small-enough? ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test +[ t ] [ 130000 small-enough? ] unit-test + [ "staging.math-compiler-ui-strip.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test -[ t ] [ - cell 8 = 35 17 ? 100000 * small-enough? -] unit-test - [ ] [ "maze" shake-and-bake ] unit-test -[ t ] [ - cell 8 = 30 15 ? 100000 * small-enough? -] unit-test +[ t ] [ 120000 small-enough? ] unit-test + +[ ] [ "tetris" shake-and-bake ] unit-test + +[ t ] [ 120000 small-enough? ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test -[ t ] [ - cell 8 = 50 30 ? 100000 * small-enough? -] unit-test +[ t ] [ 250000 small-enough? ] unit-test { "tools.deploy.test.1" diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 05bf3c9642..2dd334d024 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces assocs kernel parser lexer strings.parser tools.deploy.config vocabs sequences words words.private memory kernel.private continuations io prettyprint vocabs.loader debugger system -strings sets ; +strings sets vectors quotations byte-arrays ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes QUALIFIED: command-line @@ -79,8 +79,8 @@ IN: tools.deploy.shaker [ [ props>> swap - '[ drop , member? not ] assoc-filter - sift-assoc f assoc-like + '[ drop , member? not ] assoc-filter sift-assoc + dup assoc-empty? [ drop f ] [ >alist >vector ] if ] keep (>>props) ] with each ; @@ -93,7 +93,10 @@ IN: tools.deploy.shaker "compiled-uses" "constraints" "declared-effect" + "default" + "default-method" "default-output-classes" + "derived-from" "identities" "if-intrinsics" "infer" @@ -103,15 +106,18 @@ IN: tools.deploy.shaker "loc" "members" "methods" + "method-class" + "method-generic" "combination" "cannot-infer" - "default-method" + "no-compile" "optimizer-hooks" "output-classes" "participants" "predicate" "predicate-definition" "predicating" + "tuple-dispatch-generic" "slots" "slot-names" "specializer" @@ -127,6 +133,8 @@ IN: tools.deploy.shaker strip-prettyprint? [ { + "break-before" + "break-after" "delimiter" "flushable" "foldable" @@ -265,13 +273,27 @@ IN: tools.deploy.shaker 21 setenv ] [ 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 -- ) "Finishing up" show >r { } set-datastack r> { } set-retainstack V{ } set-namestack V{ } set-catchstack - "Saving final image" show [ save-image-and-exit ] call-clear ; @@ -295,7 +317,10 @@ SYMBOL: deploy-vocab deploy-vocab get vocab-main set-boot-quot* stripped-word-props >r stripped-globals strip-globals - r> strip-words ; + r> strip-words + compress-byte-arrays + compress-quotations + compress-strings ; : (deploy) ( final-image vocab config -- ) #! Does the actual work of a deployment in the slave diff --git a/vm/code_gc.c b/vm/code_gc.c index e0abdc5a61..03661999c5 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -308,6 +308,8 @@ DEFINE_PRIMITIVE(code_room) /* Dump all code blocks for debugging */ void dump_heap(F_HEAP *heap) { + CELL size = 0; + F_BLOCK *scan = first_block(heap); while(scan) @@ -319,9 +321,11 @@ void dump_heap(F_HEAP *heap) status = "free"; break; case B_ALLOCATED: + size += object_size(block_to_compiled(scan)->relocation); status = "allocated"; break; case B_MARKED: + size += object_size(block_to_compiled(scan)->relocation); status = "marked"; break; default: @@ -333,6 +337,8 @@ void dump_heap(F_HEAP *heap) scan = next_block(heap,scan); } + + printf("%ld bytes of relocation data\n",size); } /* Compute where each block is going to go, after compaction */