Two more problems found in string.c; these relate to the creation of
temporary strings to hold results of transcoding, in string_concat and
string_compare.
As per the latest (I think) decision from Dan ("Avoiding the deadlands", 9th
April: http://www.mail-archive.com/perl6-internals@perl.org/msg09072.html),
the following patch does the following:
1) Add BUFFER_neonate_FLAG (actually renamed BUFFER_needs_GC_FLAG, since
this is not used at present, and can always be added again if it is needed
in the future) - feel free to change the name to anything you fancy
2) Add neonate counters to interpreter structure (I added three separate
counters; as it is really only required as a flag to indicate that cleanup
is needed, one would probably suffice)
3) Change GC routines to treat 'neonate' string/buffer headers in the same
way as constants
4) Change string_concat and string_compare to set and clear the 'neonate'
flag as required
Still required as per the above-referenced decision:
1) Implement equivalent flag for PMCs (unless the 'immune' flag serves the
same purpose?)
2) Procedure to clear neonate flag on all headers from time to time
Note that this patch gives compiler warnings in string.c because of the
'const' attribute on the parameters, and therefore should not be applied in
its current form; I'm sure somebody can figure out how best to resolve the
warnings.
--
Peter Gibbs
EmKel Systems
Index: include/parrot/interpreter.h
===================================================================
RCS file: /home/perlcvs/parrot/include/parrot/interpreter.h,v
retrieving revision 1.40
diff -u -r1.40 interpreter.h
--- include/parrot/interpreter.h 3 Apr 2002 04:01:41 -0000 1.40
+++ include/parrot/interpreter.h 22 Apr 2002 12:58:47 -0000
@@ -142,6 +142,9 @@
requests are there? */
UINTVAL GC_block_level; /* How many outstanding GC block
requests are there? */
+ UINTVAL neonate_strings; /* How many protected newborn strings ? */
+ UINTVAL neonate_buffers; /* How many protected newborn buffers ? */
+ UINTVAL neonate_PMCs; /* How many protected newborn PMCs ? */
} Interp;
#define PCONST(i) PF_CONST(interpreter->code, (i))
Index: interpreter.c
===================================================================
RCS file: /home/perlcvs/parrot/interpreter.c,v
retrieving revision 1.84
diff -u -r1.84 interpreter.c
--- interpreter.c 15 Apr 2002 18:05:18 -0000 1.84
+++ interpreter.c 22 Apr 2002 13:05:56 -0000
@@ -497,6 +497,9 @@
interpreter->memory_collected = 0;
interpreter->DOD_block_level = 1;
interpreter->GC_block_level = 1;
+ interpreter->neonate_strings = 0;
+ interpreter->neonate_buffers = 0;
+ interpreter->neonate_PMCs = 0;
/* Set up the memory allocation system */
mem_setup_allocator(interpreter);
Index: include/parrot/string.h
===================================================================
RCS file: /home/perlcvs/parrot/include/parrot/string.h,v
retrieving revision 1.35
diff -u -r1.35 string.h
--- include/parrot/string.h 24 Mar 2002 22:30:06 -0000 1.35
+++ include/parrot/string.h 22 Apr 2002 12:59:23 -0000
@@ -65,8 +65,8 @@
/* Private flag for the GC system. Set if the buffer's in use as
* far as the GC's concerned */
BUFFER_live_FLAG = 1 << 12,
- /* Mark the bufffer as needing GC */
- BUFFER_needs_GC_FLAG = 1 << 13,
+ /* Mark the bufffer as newborn, for protection from infant death */
+ BUFFER_neonate_FLAG = 1 << 13,
/* Mark the buffer as on the free list */
BUFFER_on_free_list_FLAG = 1 << 14,
/* This is a constant--don't kill it! */
Index: resources.c
===================================================================
RCS file: /home/perlcvs/parrot/resources.c,v
retrieving revision 1.45
diff -u -r1.45 resources.c
--- resources.c 19 Apr 2002 01:33:56 -0000 1.45
+++ resources.c 22 Apr 2002 13:00:47 -0000
@@ -341,7 +314,8 @@
STRING *string_array = cur_string_arena->start_STRING;
for (i = 0; i < cur_string_arena->used; i++) {
/* Tentatively unused, unless it's a constant */
- if (!(string_array[i].flags & BUFFER_constant_FLAG)) {
+ if (!(string_array[i].flags &
+ (BUFFER_constant_FLAG | BUFFER_neonate_FLAG))) {
string_array[i].flags &= ~BUFFER_live_FLAG;
}
}
@@ -353,7 +327,8 @@
Buffer *buffer_array = cur_buffer_arena->start_Buffer;
for (i = 0; i < cur_buffer_arena->used; i++) {
/* Tentatively unused, unless it's a constant */
- if (!(buffer_array[i].flags & BUFFER_constant_FLAG)) {
+ if (!(buffer_array[i].flags &
+ (BUFFER_constant_FLAG | BUFFER_neonate_FLAG))) {
buffer_array[i].flags &= ~BUFFER_live_FLAG;
}
}
Index: string.c
===================================================================
RCS file: /home/perlcvs/parrot/string.c,v
retrieving revision 1.73
diff -u -r1.73 string.c
--- string.c 15 Apr 2002 20:34:28 -0000 1.73
+++ string.c 22 Apr 2002 12:59:55 -0000
@@ -277,6 +277,8 @@
if (a->type != b->type || a->encoding != b->encoding) {
b = string_transcode(interpreter, b, a->encoding, a->type,
NULL);
+ interpreter->neonate_strings++;
+ b->flags |= BUFFER_neonate_FLAG;
}
result = string_make(interpreter, NULL, a->bufused +
b->bufused,
a->encoding, 0, a->type);
@@ -285,6 +287,10 @@
b->bufstart, b->bufused);
result->strlen = a->strlen + b->strlen;
result->bufused = a->bufused + b->bufused;
+ if (b->flags & BUFFER_neonate_FLAG) {
+ b->flags &= ~BUFFER_neonate_FLAG;
+ interpreter->neonate_strings--;
+ }
}
else {
return string_copy(interpreter, a);
@@ -576,8 +582,12 @@
if (s1->type != s2->type || s1->encoding != s2->encoding) {
s1 = string_transcode(interpreter, s1, NULL, string_unicode_type,
NULL);
+ interpreter->neonate_strings++;
+ s1->flags |= BUFFER_neonate_FLAG;
s2 = string_transcode(interpreter, s2, NULL, string_unicode_type,
NULL);
+ interpreter->neonate_strings++;
+ s2->flags |= BUFFER_neonate_FLAG;
}
s1start = s1->bufstart;
@@ -599,6 +609,15 @@
cmp = 1;
if (cmp == 0 && s2start < s2end)
cmp = -1;
+
+ if (s1->flags & BUFFER_neonate_FLAG) {
+ s1->flags &= ~BUFFER_neonate_FLAG;
+ interpreter->neonate_strings--;
+ }
+ if (s2->flags & BUFFER_neonate_FLAG) {
+ s2->flags &= ~BUFFER_neonate_FLAG;
+ interpreter->neonate_strings--;
+ }
return cmp;
}
