Merge remote-tracking branch 'upstream/master'

basis/stack-checker/known-words/known-words.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2010 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2004, 2011 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors alien alien.accessors alien.private arrays
 byte-arrays classes continuations.private effects generic
@@ -10,7 +10,7 @@ quotations.private sbufs sbufs.private sequences
 sequences.private slots.private strings strings.private system
 threads.private classes.tuple classes.tuple.private vectors
 vectors.private words words.private definitions assocs summary
-compiler.units system.private combinators
+compiler.units system.private combinators tools.memory.private
 combinators.short-circuit locals locals.backend locals.types
 combinators.private stack-checker.values generic.single
 generic.single.private alien.libraries tools.dispatch.private
@@ -348,13 +348,13 @@ M: object infer-call* \ call bad-macro-input ;
 \ callstack-for { c-ptr } { callstack } define-primitive \ callstack make-flushable
 \ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable
 \ check-datastack { array integer integer } { object } define-primitive \ check-datastack make-flushable
-\ code-room { } { byte-array } define-primitive \ code-room  make-flushable
+\ (code-room) { } { byte-array } define-primitive \ (code-room)  make-flushable
 \ compact-gc { } { } define-primitive
 \ compute-identity-hashcode { object } { } define-primitive
 \ context-object { fixnum } { object } define-primitive \ context-object make-flushable
 \ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable
 \ current-callback { } { fixnum } define-primitive \ current-callback make-flushable
-\ data-room { } { byte-array } define-primitive \ data-room make-flushable
+\ (data-room) { } { byte-array } define-primitive \ (data-room) make-flushable
 \ datastack { } { array } define-primitive \ datastack make-flushable
 \ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable
 \ die { } { } define-primitive

basis/tools/memory/memory-docs.factor

@@ -48,3 +48,11 @@ HELP: gc-summary.
 
 HELP: gc-events
 { $var-description "A sequence of " { $link gc-event } " instances, set by " { $link collect-gc-events } ". Can be inspected directly, or with the " { $link gc-events. } ", " { $link gc-stats. } " and " { $link gc-summary. } " words." } ;
+
+HELP: data-room
+{ $values { "data-heap-room" data-heap-room } }
+{ $description "Queries the VM for memory usage information." } ;
+
+HELP: code-room
+{ $values { "mark-sweep-sizes" mark-sweep-sizes } }
+{ $description "Queries the VM for memory usage information." } ;

basis/tools/memory/memory.factor

@@ -1,12 +1,11 @@
-! Copyright (C) 2005, 2010 Slava Pestov.
+! Copyright (C) 2005, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs binary-search classes
 classes.struct combinators combinators.smart continuations fry
 generalizations generic grouping io io.styles kernel make math
-math.order math.parser math.statistics memory memory.private
+math.order math.parser math.statistics memory layouts namespaces
-layouts namespaces parser prettyprint sequences
+parser prettyprint sequences sequences.generalizations sorting
-sequences.generalizations sorting splitting strings system vm
+splitting strings system vm words hints hashtables ;
-words hints hashtables ;
 IN: tools.memory
 
 <PRIVATE
@@ -58,9 +57,12 @@ IN: tools.memory
 
 PRIVATE>
 
+: data-room ( -- data-heap-room )
+    (data-room) data-heap-room memory>struct ;
+
 : data-room. ( -- )
     "== Data heap ==" print nl
-    data-room data-heap-room memory>struct {
+    data-room {
         [ nursery-room. nl ]
         [ aging-room. nl ]
         [ tenured-room. nl ]
@@ -286,9 +288,12 @@ INSTANCE: code-blocks immutable-sequence
 
 PRIVATE>
 
+: code-room ( -- mark-sweep-sizes )
+    (code-room) mark-sweep-sizes memory>struct ;
+
 : code-room. ( -- )
     "== Code heap ==" print nl
-    code-room mark-sweep-sizes memory>struct mark-sweep-table. nl
+    code-room mark-sweep-table. nl
     code-blocks code-block-stats code-block-table. ;
 
 : room. ( -- )

core/bootstrap/primitives.factor

@@ -103,6 +103,7 @@ call( -- )
     "system.private"
     "threads.private"
     "tools.dispatch.private"
+    "tools.memory.private"
     "tools.profiler.private"
     "words"
     "words.private"
@@ -515,12 +516,12 @@ tuple
     { "float>bignum" "math.private" "primitive_float_to_bignum" (( x -- y )) }
     { "float>fixnum" "math.private" "primitive_float_to_fixnum" (( x -- y )) }
     { "all-instances" "memory" "primitive_all_instances" (( -- array )) }
-    { "(code-blocks)" "memory.private" "primitive_code_blocks" (( -- array )) }
+    { "(code-blocks)" "tools.memory.private" "primitive_code_blocks" (( -- array )) }
-    { "code-room" "memory" "primitive_code_room" (( -- code-room )) }
+    { "(code-room)" "tools.memory.private" "primitive_code_room" (( -- code-room )) }
     { "compact-gc" "memory" "primitive_compact_gc" (( -- )) }
-    { "data-room" "memory" "primitive_data_room" (( -- data-room )) }
+    { "(data-room)" "tools.memory.private" "primitive_data_room" (( -- data-room )) }
-    { "disable-gc-events" "memory" "primitive_disable_gc_events" (( -- events )) }
+    { "disable-gc-events" "tools.memory.private" "primitive_disable_gc_events" (( -- events )) }
-    { "enable-gc-events" "memory" "primitive_enable_gc_events" (( -- )) }
+    { "enable-gc-events" "tools.memory.private" "primitive_enable_gc_events" (( -- )) }
     { "gc" "memory" "primitive_full_gc" (( -- )) }
     { "minor-gc" "memory" "primitive_minor_gc" (( -- )) }
     { "size" "memory" "primitive_size" (( obj -- n )) }

core/memory/memory-docs.factor

@@ -9,14 +9,6 @@ HELP: instances
 HELP: gc ( -- )
 { $description "Performs a full garbage collection." } ;
 
-HELP: data-room ( -- data-room )
-{ $values { "data-room" data-room } }
-{ $description "Queries the VM for memory usage information." } ;
-
-HELP: code-room ( -- code-room )
-{ $values { "code-room" code-room } }
-{ $description "Queries the VM for memory usage information." } ;
-
 HELP: size ( obj -- n )
 { $values { "obj" "an object" } { "n" "a size in bytes" } }
 { $description "Outputs the size of the object in memory, in bytes. Tagged immediate objects such as fixnums and " { $link f } " will yield a size of 0." } ;

core/memory/memory-tests.factor

@@ -1,34 +1,56 @@
-USING: generic kernel kernel.private math memory prettyprint io
+USING: accessors kernel kernel.private math memory prettyprint
-sequences tools.test words namespaces layouts classes
+io sequences tools.test words namespaces layouts classes
-classes.builtin arrays quotations io.launcher system ;
+classes.builtin arrays quotations system ;
+FROM: tools.memory => data-room code-room ;
 IN: memory.tests
 
+[ save-image-and-exit ] must-fail
+
+! Tests for 'instances'
+[ [ ] instances ] must-infer
+2 [ [ [ 3 throw ] instances ] must-fail ] times
+
+! Tests for 'become'
 [ ] [ { } { } become ] unit-test
 
-! LOL
+! Bug found on Windows build box, having too many words in the
-[ ] [
+! image breaks 'become'
-    vm
+[ ] [ 100000 [ f <uninterned-word> ] replicate { } { } become drop ] unit-test
-    "-i=" image append
-    "-generations=2"
-    "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit"
-    4array try-process
-] unit-test
 
-[ [ ] instances ] must-infer
+! Bug: code heap collection had to be done when data heap was
-
+! full, not just when code heap was full. If the code heap
-! Code GC wasn't kicking in when needed
+! contained dead code blocks referring to large data heap
+! objects, those large objects would continue to live on even
+! if the code blocks were not reachable, as long as the code
+! heap did not fill up.
 : leak-step ( -- ) 800000 f <array> 1quotation call( -- obj ) drop ;
 
 : leak-loop ( -- ) 100 [ leak-step ] times ;
 
 [ ] [ leak-loop ] unit-test
 
-TUPLE: testing x y z ;
+! Bug: allocation of large objects directly into tenured space
+! can proceed past the high water mark.
+!
+! Suppose the nursery and aging spaces are mostly comprised of
+! reachable objects. When doing a full GC, objects from young
+! generations ere promoted *before* unreachable objects in
+! tenured space are freed by the sweep phase. So if large object
+! allocation filled up the heap past the high water mark, this
+! promotion might trigger heap growth, even if most of those
+! large objects are unreachable.
+SYMBOL: foo
 
-[ save-image-and-exit ] must-fail
+[ ] [
+    gc
 
-! Erg's bug
+    data-room tenured>> size>>
-2 [ [ [ 3 throw ] instances ] must-fail ] times
     
-! Bug found on Windows build box, having too many words in the image breaks 'become'
+    10 [
-[ ] [ 100000 [ f <uninterned-word> ] replicate { } { } become drop ] unit-test
+        4 [ 120 1024 * f <array> ] replicate foo set-global
+        100 [ 256 1024 * f <array> drop ] times
+    ] times
+    
+    data-room tenured>> size>>
+    assert=
+] unit-test

extra/bunny/deploy.factor

@@ -2,11 +2,13 @@ USING: tools.deploy.config ;
 H{
     { deploy-name "Bunny" }
     { deploy-ui? t }
+    { deploy-help? f }
     { deploy-c-types? f }
+    { deploy-console? t }
     { deploy-unicode? f }
     { "stop-after-last-window?" t }
     { deploy-io 3 }
-    { deploy-reflection 2 }
+    { deploy-reflection 1 }
     { deploy-word-props? f }
     { deploy-math? t }
     { deploy-threads? t }

extra/game/loop/benchmark/benchmark.factor

@@ -0,0 +1,37 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types classes.struct game.loop
+game.loop.private kernel sequences specialized-vectors
+tools.time.struct ;
+IN: game.loop.benchmark
+
+STRUCT: game-loop-benchmark
+    { benchmark-data-pair benchmark-data-pair }
+    { tick# ulonglong }
+    { frame# ulonglong } ;
+
+SPECIALIZED-VECTOR: game-loop-benchmark
+
+: <game-loop-benchmark> ( benchmark-data-pair tick frame -- obj )
+    \ game-loop-benchmark <struct>
+        swap >>frame#
+        swap >>tick#
+        swap >>benchmark-data-pair ; inline
+
+: ensure-benchmark-data ( loop -- vector )
+    dup benchmark-data>> [
+        game-loop-benchmark-vector{ } clone
+        >>benchmark-data
+    ] unless
+    benchmark-data>> ; inline
+
+M: game-loop record-benchmarking ( loop quot: ( loop -- benchmark-data-pair ) -- )
+    [
+        [ [ call( loop -- ) ] with-benchmarking ]
+        [ drop tick#>> ]
+        [ drop frame#>> ]
+        2tri
+        <game-loop-benchmark>
+    ]
+    [ drop ensure-benchmark-data ]
+    2bi push ;
+                                

extra/game/loop/loop.factor

@@ -1,9 +1,8 @@
 ! (c)2009 Joe Groff bsd license
 USING: accessors timers alien.c-types calendar classes.struct
 continuations destructors fry kernel math math.order memory
-namespaces sequences specialized-vectors system
+namespaces sequences system ui ui.gadgets.worlds vm
-ui ui.gadgets.worlds vm vocabs.loader arrays
+vocabs.loader arrays locals ;
-tools.time.struct locals ;
 IN: game.loop
 
 TUPLE: game-loop
@@ -17,19 +16,6 @@ TUPLE: game-loop
     draw-timer
     benchmark-data ;
 
-STRUCT: game-loop-benchmark
-    { benchmark-data-pair benchmark-data-pair }
-    { tick# ulonglong }
-    { frame# ulonglong } ;
-
-SPECIALIZED-VECTOR: game-loop-benchmark
-
-: <game-loop-benchmark> ( benchmark-data-pair tick frame -- obj )
-    \ game-loop-benchmark <struct>
-        swap >>frame#
-        swap >>tick#
-        swap >>benchmark-data-pair ; inline
-
 GENERIC: tick* ( delegate -- )
 GENERIC: draw* ( tick-slice delegate -- )
 
@@ -48,26 +34,24 @@ TUPLE: game-loop-error game-loop error ;
 
 <PRIVATE
 
-: record-benchmarking ( benchark-data-pair loop -- )
-    [ tick#>> ]
-    [ frame#>> <game-loop-benchmark> ]
-    [ benchmark-data>> ] tri push ;
-
 : last-tick-percent-offset ( loop -- float )
     [ draw-timer>> iteration-start-nanos>> nano-count swap - ]
     [ tick-interval-nanos>> ] bi /f 1.0 min ;
 
+GENERIC# record-benchmarking 1 ( loop quot -- )
+
+M: object record-benchmarking
+    call( loop -- ) ;
+
 : redraw ( loop -- )
     [ 1 + ] change-frame#
     [
         [ last-tick-percent-offset ] [ draw-delegate>> ] bi
-        [ draw* ] with-benchmarking
+        draw*
-    ] keep record-benchmarking ;
+    ] record-benchmarking ;
 
 : tick ( loop -- )
-    [
+    [ tick-delegate>> tick* ] record-benchmarking ;
-        [ tick-delegate>> tick* ] with-benchmarking
-    ] keep record-benchmarking ;
 
 : increment-tick ( loop -- )
     [ 1 + ] change-tick#
@@ -105,9 +89,7 @@ PRIVATE>
     [ tick-timer>> ] [ draw-timer>> ] bi [ stop-timer ] bi@ ;
 
 : <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
-    f 0 0 f f
+    f 0 0 f f f game-loop boa ;
-    game-loop-benchmark-vector{ } clone
-    game-loop boa ;
 
 : <game-loop> ( tick-interval-nanos delegate -- loop )
     dup <game-loop*> ; inline
@@ -116,3 +98,4 @@ M: game-loop dispose
     stop-loop ;
 
 { "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
+{ "game.loop" "tools.memory" } "game.loop.benchmark" require-when

extra/readline/ffi/platforms.txt

@@ -0,0 +1 @@
+unix

extra/tools/time/struct/struct.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types classes.struct kernel memory
-system vm ;
+tools.memory system vm ;
 IN: tools.time.struct
 
 STRUCT: benchmark-data

vm/aging_collector.cpp

@@ -14,10 +14,8 @@ void factor_vm::collect_aging()
 	/* Promote objects referenced from tenured space to tenured space, copy
 	everything else to the aging semi-space, and reset the nursery pointer. */
 	{
-		/* Change the op so that if we fail here, we proceed to a full
+		/* Change the op so that if we fail here, an assertion will be
-		tenured collection. We are collecting to tenured space, and
+		raised. */
-		cards were unmarked, so we can't proceed with a to_tenured
-		collection. */
 		current_gc->op = collect_to_tenured_op;
 
 		to_tenured_collector collector(this);

vm/compaction.cpp

@@ -330,14 +330,22 @@ void factor_vm::collect_compact(bool trace_contexts_p)
 {
 	collect_mark_impl(trace_contexts_p);
 	collect_compact_impl(trace_contexts_p);
+	
+	if(data->high_fragmentation_p())
+	{
+		/* Compaction did not free up enough memory. Grow the heap. */
+		set_current_gc_op(collect_growing_heap_op);
+		collect_growing_heap(0,trace_contexts_p);
+	}
+
 	code->flush_icache();
 }
 
-void factor_vm::collect_growing_heap(cell requested_bytes, bool trace_contexts_p)
+void factor_vm::collect_growing_heap(cell requested_size, bool trace_contexts_p)
 {
 	/* Grow the data heap and copy all live objects to the new heap. */
 	data_heap *old = data;
-	set_data_heap(data->grow(requested_bytes));
+	set_data_heap(data->grow(requested_size));
 	collect_mark_impl(trace_contexts_p);
 	collect_compact_code_impl(trace_contexts_p);
 	code->flush_icache();

vm/data_heap.cpp

@@ -100,12 +100,12 @@ void data_heap::reset_generation(tenured_space *gen)
 
 bool data_heap::high_fragmentation_p()
 {
-	return (tenured->largest_free_block() <= nursery->size + aging->size);
+	return (tenured->largest_free_block() <= high_water_mark());
 }
 
 bool data_heap::low_memory_p()
 {
-	return (tenured->free_space() <= nursery->size + aging->size);
+	return (tenured->free_space() <= high_water_mark());
 }
 
 void data_heap::mark_all_cards()

vm/data_heap.hpp

@@ -32,6 +32,9 @@ struct data_heap {
 	bool high_fragmentation_p();
 	bool low_memory_p();
 	void mark_all_cards();
+	cell high_water_mark() {
+		return nursery->size + aging->size;
+	}
 };
 
 struct data_heap_room {

vm/full_collector.cpp

@@ -112,11 +112,14 @@ void factor_vm::collect_full(bool trace_contexts_p)
 
 	if(data->low_memory_p())
 	{
+		/* Full GC did not free up enough memory. Grow the heap. */
 		set_current_gc_op(collect_growing_heap_op);
 		collect_growing_heap(0,trace_contexts_p);
 	}
 	else if(data->high_fragmentation_p())
 	{
+		/* Enough free memory, but it is not contiguous. Perform a
+		compaction. */
 		set_current_gc_op(collect_compact_op);
 		collect_compact_impl(trace_contexts_p);
 	}

vm/gc.cpp

@@ -116,19 +116,19 @@ void factor_vm::start_gc_again()
 	switch(current_gc->op)
 	{
 	case collect_nursery_op:
+		/* Nursery collection can fail if aging does not have enough
+		free space to fit all live objects from nursery. */
 		current_gc->op = collect_aging_op;
 		break;
 	case collect_aging_op:
+		/* Aging collection can fail if the aging semispace cannot fit
+		all the live objects from the other aging semispace and the
+		nursery. */
 		current_gc->op = collect_to_tenured_op;
 		break;
-	case collect_to_tenured_op:
-		current_gc->op = collect_full_op;
-		break;
-	case collect_full_op:
-	case collect_compact_op:
-		current_gc->op = collect_growing_heap_op;
-		break;
 	default:
+		/* Nothing else should fail mid-collection due to insufficient
+		space in the target generation. */
 		critical_error("Bad GC op",current_gc->op);
 		break;
 	}
@@ -143,15 +143,21 @@ void factor_vm::set_current_gc_op(gc_op op)
 	if(gc_events) current_gc->event->op = op;
 }
 
-void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
+void factor_vm::gc(gc_op op, cell requested_size, bool trace_contexts_p)
 {
 	assert(!gc_off);
 	assert(!current_gc);
 
+	/* Important invariant: tenured space must have enough contiguous free
+	space to fit the entire contents of the aging space and nursery. This is
+	because when doing a full collection, objects from younger generations
+	are promoted before any unreachable tenured objects are freed. */
+	assert(!data->high_fragmentation_p());
+
 	current_gc = new gc_state(op,this);
 
-	/* Keep trying to GC higher and higher generations until we don't run out
+	/* Keep trying to GC higher and higher generations until we don't run
-	of space */
+	out of space in the target generation. */
 	for(;;)
 	{
 		try
@@ -164,17 +170,23 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
 				collect_nursery();
 				break;
 			case collect_aging_op:
+				/* We end up here if the above fails. */
 				collect_aging();
 				if(data->high_fragmentation_p())
 				{
+					/* Change GC op so that if we fail again,
+					we crash. */
 					set_current_gc_op(collect_full_op);
 					collect_full(trace_contexts_p);
 				}
 				break;
 			case collect_to_tenured_op:
+				/* We end up here if the above fails. */
 				collect_to_tenured();
 				if(data->high_fragmentation_p())
 				{
+					/* Change GC op so that if we fail again,
+					we crash. */
 					set_current_gc_op(collect_full_op);
 					collect_full(trace_contexts_p);
 				}
@@ -186,7 +198,7 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
 				collect_compact(trace_contexts_p);
 				break;
 			case collect_growing_heap_op:
-				collect_growing_heap(requested_bytes,trace_contexts_p);
+				collect_growing_heap(requested_size,trace_contexts_p);
 				break;
 			default:
 				critical_error("Bad GC op",current_gc->op);
@@ -197,7 +209,7 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
 		}
 		catch(const must_start_gc_again &)
 		{
-			/* We come back here if a generation is full */
+			/* We come back here if the target generation is full. */
 			start_gc_again();
 			continue;
 		}
@@ -207,6 +219,9 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
 
 	delete current_gc;
 	current_gc = NULL;
+
+	/* Check the invariant again, just in case. */
+	assert(!data->high_fragmentation_p());
 }
 
 /* primitive_minor_gc() is invoked by inline GC checks, and it needs to fill in
@@ -283,12 +298,13 @@ void factor_vm::primitive_compact_gc()
 object *factor_vm::allot_large_object(cell type, cell size)
 {
 	/* If tenured space does not have enough room, collect and compact */
-	if(!data->tenured->can_allot_p(size))
+	cell requested_size = size + data->high_water_mark();
+	if(!data->tenured->can_allot_p(requested_size))
 	{
 		primitive_compact_gc();
 
 		/* If it still won't fit, grow the heap */
-		if(!data->tenured->can_allot_p(size))
+		if(!data->tenured->can_allot_p(requested_size))
 		{
 			gc(collect_growing_heap_op,
 				size, /* requested size */

vm/vm.hpp

@@ -314,8 +314,8 @@ struct factor_vm
 	void collect_compact_impl(bool trace_contexts_p);
 	void collect_compact_code_impl(bool trace_contexts_p);
 	void collect_compact(bool trace_contexts_p);
-	void collect_growing_heap(cell requested_bytes, bool trace_contexts_p);
+	void collect_growing_heap(cell requested_size, bool trace_contexts_p);
-	void gc(gc_op op, cell requested_bytes, bool trace_contexts_p);
+	void gc(gc_op op, cell requested_size, bool trace_contexts_p);
 	void scrub_context(context *ctx);
 	void scrub_contexts();
 	void primitive_minor_gc();