# New Ticket Created by Leopold Toetsch
# Please include the string: [perl #18142]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=18142 >
Attached is a (big) patch that implements Parrot_destroy.
Test results with --gc-debug: All tests successful.
Test results with leak detection[1]/--gc-debug:
Failed Test Status Wstat Total Fail Failed List of failed
-------------------------------------------------------------------------------
t/op/hacks.t 2 1 50,00% 1
t/op/interp.t 2 2 100,00% 1-2
t/op/rx.t 23 7 30,43% 8-9, 12-14, 21-22
t/op/stacks.t 35 2 5,71% 31-32
t/pmc/pmc.t 83 4 4,82% 62-64, 76
7 subtests skipped.
Failed 5/34 test scripts, 85.29% okay. 16/495 subtests failed, 96.77% okay.
Some notes WRT still exisiting leaks:
- hacks.t: PIO related, open does new_IO which doesn't seem to store
this structure somewhere. Explicit closing the handle would help, as
done now in embed.c
- interp.t: crashes with ATEXIT_DESTROY (2 interpreters interfere)
- rx.t: Bitmaps leakage
- stacks.t: leaking intstack
- pmc.t: leaking intqueue
TODO:
- header file changes WRT global warnings
- probably remove intqueue from classes
- move the stack destroying code to stacks, reuse it in
classes/coroutine.pmc
- fix PIO_destroy
- to clean up properly after exceptions, I added a define locally to
interpreter.c: ATEXT_DESTROY, which installs an atexit-handler. This
works only for one existing interpreter, due to the __interpreter
global. We should either keep an interpreter array or fix
internal_exception to take an Parrot_Interp*, so that Parrot_destroy
can be called.
- Running with --gc=malloc is broken (mostly COWed strings).
- (unrelated) mmap in Parrot_readbc is not used now, missing
HAS_HEADER_SYSMMAN definition
Some notes to the changes:
- classe/*.pmc missing flags setting in clone, destroy
- dod.c made free_unused_* global
- embed.c PIO_close
- headers.c honor active_destroy, destroy_headers
- chartype.c usascii (better latin1) is default
- interpreter Parrot_destroy
- io/io.c PIO_destroy / _close
- res*.c destroy_memory_pools
- t/src/manifest accout for skipped test
[1] I used run-yamd (s. attached testyamd script) for running all tests
through the memory debugger and made leaking tests fail. This is part
of YAMD (Yet Another Memory Debugger).
Please test the patch on different platforms. Mine is i386/linux.
Have fun,
leo
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/40716/32820/b03730/parrot_destroy.patch
--- parrot/classes/continuation.pmc Mon Oct 21 13:56:24 2002
+++ parrot-leo/classes/continuation.pmc Tue Oct 29 10:47:04 2002
@@ -60,6 +60,7 @@
= mem_sys_allocate(sizeof(struct Parrot_Continuation));
ret->vtable = &Parrot_base_vtables[enum_class_Continuation];
ret->data = retc;
+ ret->flags |= PMC_custom_mark_FLAG | PMC_active_destroy_FLAG;
memcpy(retc, SELF->data, sizeof(struct Parrot_Continuation));
/* we may have copied our stack already, so we need to re-COW
* it */
--- parrot/classes/coroutine.pmc Mon Oct 21 13:56:24 2002
+++ parrot-leo/classes/coroutine.pmc Tue Oct 29 10:57:23 2002
@@ -33,6 +33,9 @@
}
void destroy () {
+ /* XXX stack_destroy for deeper stacks */
+ mem_sys_free(((struct Parrot_Coroutine *)SELF->data)->ctx.user_stack);
+ mem_sys_free(((struct Parrot_Coroutine *)SELF->data)->ctx.control_stack);
mem_sys_free(SELF->data);
}
@@ -84,6 +87,7 @@
PMC * ret = new_pmc_header(INTERP);
ret->vtable = &Parrot_base_vtables[enum_class_Coroutine];
ret->data = retc = mem_sys_allocate(sizeof(struct Parrot_Coroutine));
+ ret->flags |= PMC_custom_mark_FLAG | PMC_active_destroy_FLAG;
memcpy(ret->data, SELF->data, sizeof(struct Parrot_Coroutine));
stack_mark_cow(retc->ctx.user_stack);
stack_mark_cow(retc->ctx.control_stack);
--- parrot/classes/sub.pmc Mon Aug 5 08:49:15 2002
+++ parrot-leo/classes/sub.pmc Tue Oct 29 10:45:50 2002
@@ -54,6 +54,7 @@
PMC* clone () {
PMC * ret = new_pmc_header(INTERP);
ret->vtable = &Parrot_base_vtables[enum_class_Sub];
+ ret->flags |= PMC_active_destroy_FLAG;
ret->data = mem_sys_allocate(sizeof(struct Parrot_Sub));
memcpy(ret->data, SELF->data, sizeof(struct Parrot_Sub));
return ret;
--- parrot/dod.c Mon Oct 28 14:59:42 2002
+++ parrot-leo/dod.c Tue Oct 29 10:44:16 2002
@@ -279,7 +279,7 @@
}
/* Free up any PMCs that aren't in use */
-static void
+void
free_unused_PMCs(struct Parrot_Interp *interpreter)
{
struct Small_Object_Arena *cur_arena;
@@ -365,7 +365,7 @@
#endif /* GC_IS_MALLOC */
/* Put any buffers that are now unused, on to the free list
* Avoid buffers that are immune from collection (ie, constant) */
-static void
+void
free_unused_buffers(struct Parrot_Interp *interpreter,
struct Small_Object_Pool *pool)
{
--- parrot/embed.c Mon Oct 28 14:59:43 2002
+++ parrot-leo/embed.c Tue Oct 29 08:45:48 2002
@@ -171,6 +171,7 @@
"Parrot VM: Problem reading packfile from PIO.\n");
return NULL;
}
+ PIO_close(interpreter, io);
}
else {
/* if we've gotten here, we opted not to use PIO to read the file.
@@ -372,13 +373,6 @@
interpreter->mem_allocs_since_last_collect
);
}
-}
-
-void
-Parrot_destroy(struct Parrot_Interp *interp)
-{
- /* XXX Leaks tons of memory. */
- mem_sys_free(interp);
}
/* XXX Doesn't handle arguments with spaces */
--- parrot/headers.c Mon Oct 28 14:59:43 2002
+++ parrot-leo/headers.c Tue Oct 29 10:44:26 2002
@@ -34,8 +34,9 @@
add_free_pmc(struct Parrot_Interp *interpreter,
struct Small_Object_Pool *pool, void *pmc)
{
+ if ( ((PMC *)pmc)->flags & PMC_active_destroy_FLAG )
+ ((PMC *)pmc)->vtable->destroy(interpreter, (PMC*) pmc);
((PMC *)pmc)->flags = PMC_on_free_list_FLAG;
- /* XXX custom destroy ?! */
/* Don't let it point to garbage memory */
((PMC *)pmc)->data = NULL;
@@ -400,9 +401,10 @@
void
Parrot_initialize_header_pools(struct Parrot_Interp *interpreter)
{
+#if 0
Parrot_allocate(interpreter, &interpreter->arena_base->extra_buffer_headers, 0);
add_extra_buffer_header(interpreter,&interpreter->arena_base->extra_buffer_headers);
-
+#endif
/* Init the constant string header pool */
interpreter->arena_base->constant_string_header_pool =
new_string_pool(interpreter, 1);
@@ -416,10 +418,50 @@
/* Init the PMC header pool */
interpreter->arena_base->pmc_pool = new_pmc_pool(interpreter);
+}
+void
+Parrot_destroy_header_pools(struct Parrot_Interp *interpreter)
+{
+ struct Small_Object_Pool *header_pool;
+ struct Small_Object_Arena *cur_arena, *next;
+ int i, j;
+ /* run twice to get rid of COWed strings
+ * in the 2nd pass, the pools themself are freed */
+ for (i = 1; i < 2; i++) {
+ for (j = -4; j < (INTVAL) interpreter->arena_base->num_sized; j++) {
+ if (j == -4)
+ header_pool = interpreter->arena_base->
+ constant_string_header_pool;
+ else if (j == -3)
+ header_pool = interpreter->arena_base->pmc_pool;
+ else if (j == -2)
+ header_pool = interpreter->arena_base->string_header_pool;
+ else if (j == -1)
+ header_pool = interpreter->arena_base->buffer_header_pool;
+ else
+ header_pool = interpreter->arena_base->sized_header_pools[j];
+ if (header_pool) {
+ if (j == -3)
+ free_unused_PMCs(interpreter);
+ else
+ free_unused_buffers(interpreter, header_pool);
+ }
+ if (i == 1 && header_pool) {
+ for (cur_arena = header_pool->last_Arena; cur_arena; ) {
+ next = cur_arena->prev;
+ mem_sys_free(cur_arena->start_objects);
+ mem_sys_free(cur_arena);
+ cur_arena = next;
+ }
+ free(header_pool);
+ }
-
+ }
+ }
+ mem_sys_free(interpreter->arena_base->sized_header_pools);
}
+
#if 0
/* if we want these names, they must be added in DOD */
--- parrot/include/parrot/chartype.h Wed Jun 26 03:00:03 2002
+++ parrot-leo/include/parrot/chartype.h Fri Oct 25 15:53:45 2002
@@ -16,8 +16,8 @@
typedef Parrot_UInt (*Parrot_CharType_Transcoder)(Parrot_UInt c);
enum {
- enum_chartype_unicode,
enum_chartype_usascii,
+ enum_chartype_unicode,
enum_chartype_MAX
};
--- parrot/interpreter.c Mon Oct 28 14:59:43 2002
+++ parrot-leo/interpreter.c Tue Oct 29 11:11:29 2002
@@ -22,6 +22,8 @@
# include "parrot/oplib/core_ops_cg.h"
#endif
+#define ATEXIT_DESTROY
+
extern op_lib_t *PARROT_CORE_PREDEREF_OPLIB_INIT(void);
@@ -393,6 +395,10 @@
/*=for api interpreter make_interpreter
* Create the Parrot interpreter. Allocate memory and clear the registers.
*/
+#ifdef ATEXIT_DESTROY
+static struct Parrot_Interp * __interpreter;
+void Parrot_really_destroy(void);
+#endif
struct Parrot_Interp *
make_interpreter(Interp_flags flags)
{
@@ -538,9 +544,116 @@
interpreter->resume_offset = 0;
interpreter->prederef_code = (void **)NULL;
+#ifdef ATEXIT_DESTROY
+ atexit(Parrot_really_destroy);
+ __interpreter = interpreter;
+#endif
return interpreter;
}
+void
+Parrot_destroy(struct Parrot_Interp *interpreter)
+{
+#ifdef ATEXIT_DESTROY
+}
+void
+Parrot_really_destroy(void)
+{
+ Interp * interpreter = __interpreter;
+#endif
+ int i;
+ Parrot_destroy_header_pools(interpreter);
+ Parrot_destroy_memory_pools(interpreter);
+ mem_sys_free(interpreter->arena_base);
+
+ /* XXX walk the stash, pmc's are already dead */
+ mem_sys_free(interpreter->perl_stash);
+ if (interpreter->profile)
+ mem_sys_free(interpreter->profile);
+ mem_sys_free(interpreter->warns );
+
+ /* register */
+ for (i = 0; i< 4; i++) {
+ struct IRegChunk *top, *next;
+ switch(i) {
+ case 0:
+ top = interpreter->ctx.int_reg_top;
+ break;
+ case 1:
+ top = (struct IRegChunk*) interpreter->ctx.num_reg_top;
+ break;
+ case 2:
+ top = (struct IRegChunk*) interpreter->ctx.string_reg_top;
+ break;
+ case 3:
+ top = (struct IRegChunk*) interpreter->ctx.pmc_reg_top;
+ break;
+ }
+ for (; top ; ) {
+ next = top->next;
+ mem_sys_free(top);
+ top = next;
+ }
+ }
+ /* stacks */
+ for (i = 0; i< 3; i++) {
+ Stack_Chunk_t *top, *next;
+ switch(i) {
+ case 0:
+ top = interpreter->ctx.pad_stack;
+ break;
+ case 1:
+ top = interpreter->ctx.user_stack;
+ break;
+ case 2:
+ top = interpreter->ctx.control_stack;
+ break;
+ }
+ while (top->next)
+ top = top->next;
+ while(top) {
+ next = top->prev;
+ mem_sys_free(top);
+ top = next;
+ }
+ }
+ /* intstack */
+ {
+ IntStack top, next, chunk;
+ chunk = top = interpreter->ctx.intstack;
+ while(chunk != top) {
+ next = chunk->prev;
+ mem_sys_free(chunk);
+ chunk = next;
+ }
+ mem_sys_free(top);
+ }
+ /* packfile */
+ {
+ struct PackFile *pf = interpreter->code;
+#if 0
+ PackFile_destroy(pf);
+#else
+ if (pf) {
+ mem_sys_free(pf->header);
+ mem_sys_free(pf->fixup_table);
+ for (i = 0; i < pf->const_table->const_count; i++) {
+ mem_sys_free(pf->const_table->constants[i]);
+ }
+ if (pf->const_table->constants)
+ mem_sys_free(pf->const_table->constants);
+ mem_sys_free(pf->const_table);
+ mem_sys_free(pf->byte_code);
+ mem_sys_free(pf);
+ }
+#endif
+ }
+
+ PIO_destroy(interpreter);
+
+ mem_sys_free(interpreter);
+}
+
/*
* Local variables:
--- parrot/io/io.c Mon Oct 28 14:59:45 2002
+++ parrot-leo/io/io.c Tue Oct 29 09:35:25 2002
@@ -135,6 +135,37 @@
}
}
+void
+PIO_destroy(theINTERP)
+{
+ ParrotIOLayer *p, *down;
+ ParrotIO *io;
+ int i;
+
+ /* XXX is this all correct? */
+
+ fflush(stdout);
+ fflush(stdout);
+
+ for (i = 0 ; i < PIO_NR_OPEN; i++) {
+ if ( (io = GET_INTERP_IOD(interpreter)->table[i]) ) {
+#if 0
+ PIO_flush(interpreter, io);
+ PIO_close(interpreter, io);
+#endif
+ mem_sys_free(io);
+ }
+ }
+ for (p = GET_INTERP_IO(interpreter); p; ) {
+ down = p->down;
+ if (p->api->Delete)
+ (*p->api->Delete) (p);
+ //mem_sys_free(p);
+ p = down;
+ }
+ mem_sys_free(GET_INTERP_IOD(interpreter)->table);
+ mem_sys_free(interpreter->piodata);
+}
/*
* IO system destructor, flush streams, free structures, etc.
@@ -486,12 +517,15 @@
INTVAL
PIO_close(theINTERP, ParrotIO *io)
{
+ INTVAL res;
if (io) {
ParrotIOLayer *l = io->stack;
while (l) {
if (l->api->Close) {
PIO_flush(interpreter, io);
- return (*l->api->Close) (interpreter, l, io);
+ res = (*l->api->Close) (interpreter, l, io);
+ mem_sys_free(io);
+ return res;
}
l = PIO_DOWNLAYER(l);
}
--- parrot/packfile.c Mon Oct 28 14:59:43 2002
+++ parrot-leo/packfile.c Mon Oct 28 17:33:14 2002
@@ -442,6 +442,7 @@
}
}
+ mem_sys_free(packed);
return ((size_t)(cursor - packed) * sizeof(opcode_t)) == packed_size;
}
--- parrot/res_lea.c Sat Oct 5 11:40:33 2002
+++ parrot-leo/res_lea.c Mon Oct 28 20:26:46 2002
@@ -73,6 +73,10 @@
Parrot_initialize_memory_pools(struct Parrot_Interp *interpreter)
{
}
+void
+Parrot_destroy_memory_pools(Interp *interpreter)
+{
+}
/*
* Local variables:
--- parrot/resources.c Mon Oct 28 14:59:43 2002
+++ parrot-leo/resources.c Mon Oct 28 16:11:43 2002
@@ -531,6 +531,27 @@
new_memory_pool(8192, NULL);
}
+void
+Parrot_destroy_memory_pools(Interp *interpreter)
+{
+ int i;
+ for (i = 0; i < 2; i++) {
+ struct Memory_Pool *pool = i ?
+ interpreter->arena_base->constant_string_pool :
+ interpreter->arena_base->memory_pool;
+ struct Memory_Block *cur_block, *next_block;
+
+ cur_block = pool->top_block;
+ while (cur_block) {
+ next_block = cur_block->prev;
+ mem_sys_free(cur_block);
+ cur_block = next_block;
+ }
+
+ mem_sys_free(pool);
+ }
+}
+
/*
* Local variables:
--- parrot/t/src/manifest.t Wed Oct 23 05:16:28 2002
+++ parrot-leo/t/src/manifest.t Mon Oct 28 19:20:37 2002
@@ -17,6 +17,7 @@
sub read_manifest;
SKIP: {
+ ok ("ok 3", "ok 3") unless -e 'CVS';
skip ('No CVS version', 1) unless -e 'CVS';
local @cvs_entries;
--- parrot/testyamd Tue Oct 29 11:31:12 2002
+++ parrot-leo/testyamd Tue Oct 29 09:58:47 2002
@@ -0,0 +1,20 @@
+#!/bin/sh
+#
+# run parrot tests under run-yamd
+#
+
+cleanup() {
+ mv parrot.orig parrot
+ exit
+}
+
+trap cleanup 1 2 3
+mv parrot parrot.orig
+echo "run-yamd -l2 -n ./parrot.orig \$@ 2>&1 | perl -ne'
+ BEGIN { undef $/; $|=1; };
+ print \$1 if (/\*{9,9}\n(.*?)\*{9,9}/s);
+ print \$1 if (/((?:WARNI|ERROR).*)/);
+ 1;'" > parrot
+chmod 755 parrot
+make test
+cleanup
