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

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 <tuple> ] ?if ;
 
 M: tuple-class boa
     [ "boa-check" word-prop call ]

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 ] [
+[ t ] [ 50000 small-enough? ] unit-test
-    cell 8 = 8 5 ? 100000 * small-enough?
-] 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
 
+[ 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 ] [
+[ 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
 
-[ t ] [
+[ t ] [ 250000 small-enough? ] unit-test
-    cell 8 = 50 30 ? 100000 * small-enough?
-] unit-test
 
 {
     "tools.deploy.test.1"

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
+            '[ drop , member? not ] assoc-filter sift-assoc
-            sift-assoc f assoc-like
+            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

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 */