-! 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
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
\ 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
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." } ;
-! 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
-layouts namespaces parser prettyprint sequences
-sequences.generalizations sorting splitting strings system vm
-words hints hashtables ;
+math.order math.parser math.statistics memory layouts namespaces
+parser prettyprint sequences sequences.generalizations sorting
+splitting strings system vm words hints hashtables ;
IN: tools.memory
<PRIVATE
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 ]
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. ( -- )
"system.private"
"threads.private"
"tools.dispatch.private"
+ "tools.memory.private"
"tools.profiler.private"
"words"
"words.private"
{ "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-room" "memory" "primitive_code_room" (( -- code-room )) }
+ { "(code-blocks)" "tools.memory.private" "primitive_code_blocks" (( -- array )) }
+ { "(code-room)" "tools.memory.private" "primitive_code_room" (( -- code-room )) }
{ "compact-gc" "memory" "primitive_compact_gc" (( -- )) }
- { "data-room" "memory" "primitive_data_room" (( -- data-room )) }
- { "disable-gc-events" "memory" "primitive_disable_gc_events" (( -- events )) }
- { "enable-gc-events" "memory" "primitive_enable_gc_events" (( -- )) }
+ { "(data-room)" "tools.memory.private" "primitive_data_room" (( -- data-room )) }
+ { "disable-gc-events" "tools.memory.private" "primitive_disable_gc_events" (( -- 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 )) }
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." } ;
-USING: generic kernel kernel.private math memory prettyprint io
-sequences tools.test words namespaces layouts classes
-classes.builtin arrays quotations io.launcher system ;
+USING: accessors kernel kernel.private math memory prettyprint
+io sequences tools.test words namespaces layouts classes
+classes.builtin arrays quotations system ;
+FROM: tools.memory => data-room code-room ;
IN: memory.tests
-[ ] [ { } { } become ] unit-test
-
-! LOL
-[ ] [
- vm
- "-i=" image append
- "-generations=2"
- "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit"
- 4array try-process
-] unit-test
+[ 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
-! Code GC wasn't kicking in when needed
+! Bug found on Windows build box, having too many words in the
+! image breaks 'become'
+[ ] [ 100000 [ f <uninterned-word> ] replicate { } { } become drop ] unit-test
+
+! Bug: code heap collection had to be done when data heap was
+! full, not just when code heap was full. If the code heap
+! 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 ;
-
-[ save-image-and-exit ] must-fail
-
-! Erg's bug
-2 [ [ [ 3 throw ] instances ] must-fail ] times
+! 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
-! Bug found on Windows build box, having too many words in the image breaks 'become'
-[ ] [ 100000 [ f <uninterned-word> ] replicate { } { } become drop ] unit-test
+[ ] [
+ gc
+
+ data-room tenured>> size>>
+
+ 10 [
+ 4 [ 120 1024 * f <array> ] replicate foo set-global
+ 100 [ 256 1024 * f <array> drop ] times
+ ] times
+
+ data-room tenured>> size>>
+ assert=
+] unit-test
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 }
--- /dev/null
+! (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 ;
+
! (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
-ui ui.gadgets.worlds vm vocabs.loader arrays
-tools.time.struct locals ;
+namespaces sequences system ui ui.gadgets.worlds vm
+vocabs.loader arrays locals ;
IN: game.loop
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 -- )
<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
- ] keep record-benchmarking ;
+ draw*
+ ] record-benchmarking ;
: tick ( loop -- )
- [
- [ tick-delegate>> tick* ] with-benchmarking
- ] keep record-benchmarking ;
+ [ tick-delegate>> tick* ] record-benchmarking ;
: increment-tick ( loop -- )
[ 1 + ] change-tick#
[ tick-timer>> ] [ draw-timer>> ] bi [ stop-timer ] bi@ ;
: <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
- f 0 0 f f
- game-loop-benchmark-vector{ } clone
- game-loop boa ;
+ f 0 0 f f f game-loop boa ;
: <game-loop> ( tick-interval-nanos delegate -- loop )
dup <game-loop*> ; inline
stop-loop ;
{ "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
+{ "game.loop" "tools.memory" } "game.loop.benchmark" require-when
--- /dev/null
+unix
\ No newline at end of file
! 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
/* 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
- tenured collection. We are collecting to tenured space, and
- cards were unmarked, so we can't proceed with a to_tenured
- collection. */
+ /* Change the op so that if we fail here, an assertion will be
+ raised. */
current_gc->op = collect_to_tenured_op;
to_tenured_collector collector(this);
{
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();
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()
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 {
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);
}
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;
}
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
- of space */
+ /* Keep trying to GC higher and higher generations until we don't run
+ out of space in the target generation. */
for(;;)
{
try
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);
}
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);
}
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;
}
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
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 */
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 gc(gc_op op, 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_size, bool trace_contexts_p);
void scrub_context(context *ctx);
void scrub_contexts();
void primitive_minor_gc();
projects / factor.git / commitdiff