Add coerce-to-compiled-procedure primitive for inner loops.
Clean up some gc macros.
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.41 1988/02/20 06:15:49 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.42 1988/03/21 21:09:06 jinx Rel $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
#include "fasl.h"
#include "dump.c"
+#ifdef FLOATING_ALIGNMENT
+/* This must be fixed. */
+#include "error: bchdmp does not handle floating alignment."
+#endif
+
extern Pointer
dump_renumber_primitive(),
*initialize_primitive_table(),
\f
/* Utility macros. */
+#define fasdump_remember_to_fix(location, contents) \
+{ \
+ if ((fixup == fixup_buffer) && (!reset_fixes())) \
+ { \
+ return (PRIM_INTERRUPT); \
+ } \
+ *--fixup = contents; \
+ *--fixup = ((Pointer) location); \
+}
+
#define fasdump_normal_setup() \
{ \
Old = Get_Pointer(Temp); \
- if (Type_Code(*Old) == TC_BROKEN_HEART) \
+ if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
{ \
- *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
+ *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old); \
continue; \
} \
New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
#define fasdump_normal_end() \
{ \
*Get_Pointer(Temp) = New_Address; \
- *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \
+ *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), New_Address); \
continue; \
}
fasdump_normal_transport(copy_code, length); \
fasdump_normal_end(); \
}
+\f
+#define fasdump_typeless_setup() \
+{ \
+ Old = ((Pointer *) Temp); \
+ if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ { \
+ *Scan = ((Pointer) Get_Pointer(*Old)); \
+ continue; \
+ } \
+ New_Address = ((Pointer) To_Address); \
+ fasdump_remember_to_fix(Old, *Old); \
+}
-#define fasdump_remember_to_fix(location, contents) \
+#define fasdump_typeless_end() \
{ \
- if ((fixup == fixup_buffer) && (!reset_fixes())) \
+ *Get_Pointer(Temp) = Make_Broken_Heart(C_To_Scheme(New_Address)); \
+ *Scan = ((Pointer) New_Address); \
+ continue; \
+}
+
+#define fasdump_typeless_pointer(copy_code, length) \
+{ \
+ fasdump_typeless_setup(); \
+ fasdump_normal_transport(copy_code, length); \
+ fasdump_typeless_end(); \
+}
+
+#define fasdump_compiled_entry() \
+{ \
+ compiled_code_present_p = true; \
+ Old = Get_Pointer(Temp); \
+ Compiled_BH(false, continue); \
{ \
- return (PRIM_INTERRUPT); \
+ Pointer *Saved_Old = Old; \
+ \
+ fasdump_remember_to_fix(Old, *Old); \
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+ copy_vector(&success); \
+ if (!success) \
+ { \
+ return (PRIM_INTERRUPT); \
+ } \
+ *Saved_Old = New_Address; \
+ *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), \
+ Saved_Old); \
+ continue; \
} \
- *--fixup = contents; \
- *--fixup = ((Pointer) location); \
+}
+
+#define fasdump_linked_operator() \
+{ \
+ Scan = OPERATOR_LINKAGE_ENTRY_ADDRESS(word_ptr); \
+ Temp = *Scan; \
+ fasdump_compiled_entry(); \
+}
+
+#define fasdump_manifest_closure() \
+{ \
+ Scan = MANIFEST_CLOSURE_ENTRY_ADDRESS(word_ptr); \
+ Temp = *Scan; \
+ fasdump_compiled_entry(); \
}
\f
Boolean
case TC_STACK_ENVIRONMENT:
case_Fasload_Non_Pointer:
break;
-
+\f
case_compiled_entry_point:
- compiled_code_present_p = true;
- Old = Get_Pointer(Temp);
- Compiled_BH(true, continue);
+ fasdump_compiled_entry();
+
+ case TC_LINKAGE_SECTION:
+ {
+ if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
{
- Pointer *Saved_Old = Old;
+ /* count typeless pointers to quads follow. */
- fasdump_remember_to_fix(Old, *Old);
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
- copy_vector(&success);
- if (!success)
+ fast long count;
+ long max_count, max_here;
+
+ Scan++;
+ max_here = (scan_buffer_top - Scan);
+ max_count = READ_CACHE_LINKAGE_COUNT(Temp);
+ while (max_count != 0)
{
- return (PRIM_INTERRUPT);
+ count = ((max_count > max_here) ? max_here : max_count);
+ max_count -= count;
+ for ( ; --count >= 0; Scan += 1)
+ {
+ Temp = *Scan;
+ fasdump_typeless_pointer(copy_quadruple(), 4);
+ }
+ if (max_count != 0)
+ {
+ /* We stopped because we needed to relocate too many. */
+ Scan = dump_and_reload_scan_buffer(0, NULL);
+ max_here = GC_DISK_BUFFER_SIZE;
+ }
+ }
+ /* The + & -1 are here because of the Scan++ in the for header. */
+ Scan -= 1;
+ break;
+ }
+\f
+ else
+ {
+ /* Operator linkage */
+
+ fast long count;
+ fast machine_word *word_ptr, *next_ptr;
+ long overflow;
+
+ count = READ_OPERATOR_LINKAGE_COUNT(Temp);
+ word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
+ overflow = ((END_OPERATOR_LINKAGE_AREA(Scan, count)) -
+ scan_buffer_top);
+
+ for (next_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr);
+ (--count >= 0);
+ word_ptr = next_ptr,
+ next_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr))
+ {
+ if (next_ptr > ((machine_word *) scan_buffer_top))
+ {
+ extend_scan_buffer((char *) next_ptr, To);
+ ONCE_ONLY(fasdump_linked_operator());
+ next_ptr = ((machine_word *)
+ end_scan_buffer_extension((char *) next_ptr));
+ overflow -= GC_DISK_BUFFER_SIZE;
+ }
+ else
+ {
+ fasdump_linked_operator();
+ }
}
- *Saved_Old = New_Address;
- *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address),
- Saved_Old);
- continue;
+ Scan = scan_buffer_top + overflow;
+ break;
}
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ machine_word *start_ptr;
+ fast machine_word *word_ptr, *next_ptr;
+
+ Scan += 1;
+ start_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
+
+ for (word_ptr = start_ptr,
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ true;
+ word_ptr = next_ptr,
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ if (!MANIFEST_CLOSURE_VALID_FITS_P(word_ptr, scan_buffer_top))
+ {
+ long dw, ds;
+
+ dw = (word_ptr - ((machine_word *) scan_buffer_top));
+ ds = (word_ptr - start_ptr);
+ word_ptr = (((machine_word *)
+ (dump_and_reload_scan_buffer(0, NULL))) +
+ dw);
+ start_ptr = word_ptr - ds;
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ }
+ if (!VALID_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ break;
+ }
+ else if (next_ptr > ((machine_word *) scan_buffer_top))
+ {
+ long ds;
+
+ ds = (next_ptr - start_ptr);
+ extend_scan_buffer((char *) next_ptr, To);
+ ONCE_ONLY(fasdump_manifest_closure());
+ next_ptr = ((machine_word *)
+ end_scan_buffer_extension((char *) next_ptr));
+ start_ptr = next_ptr - ds;
+ }
+ else
+ {
+ fasdump_manifest_closure();
+ }
+ }
+ Scan = MANIFEST_CLOSURE_END(word_ptr, start_ptr);
+ break;
+ }
\f
case_Cell:
fasdump_normal_pointer(copy_cell(), 1);
case_Quadruple:
fasdump_normal_pointer(copy_quadruple(), 4);
-#ifdef FLOATING_ALIGNMENT
case TC_BIG_FLONUM:
- /* This must be fixed. */
-#include "error: bchdmp does not handle floating alignment."
-#else
- case TC_BIG_FLONUM:
- /* Fall through */
-#endif
case TC_COMPILED_CODE_BLOCK:
case_Purify_Vector:
fasdump_normal_setup();
Primitive_2_Args();
Band_Dump_Permitted();
- Arg1Type = Type_Code(Arg1);
+ Arg1Type = OBJECT_TYPE(Arg1);
if ((Arg1Type != TC_CONTROL_POINT) &&
(Arg1Type != TC_EXTENDED_PROCEDURE) &&
(Arg1Type != TC_PRIMITIVE))
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.31 1988/02/20 06:16:05 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.32 1988/03/21 21:09:28 jinx Rel $ */
#include "gccode.h"
#ifdef bsd
#else
#include <fcntl.h>
#endif
-
+\f
/* All of these are in objects (Pointer), not bytes. */
-#define GC_EXTRA_BUFFER_SIZE 512
-#define GC_DISK_BUFFER_SIZE 1024
-#define GC_BUFFER_SPACE (GC_DISK_BUFFER_SIZE + GC_EXTRA_BUFFER_SIZE)
-#define GC_BUFFER_BYTES (GC_DISK_BUFFER_SIZE * sizeof(Pointer))
+#define GC_EXTRA_BUFFER_SIZE 512
+#define GC_DISK_BUFFER_SIZE 1024
+#define GC_BUFFER_SPACE (GC_DISK_BUFFER_SIZE + GC_EXTRA_BUFFER_SIZE)
+#define GC_BUFFER_BYTES (GC_DISK_BUFFER_SIZE * sizeof(Pointer))
+#define GC_BUFFER_OVERLAP_BYTES (GC_EXTRA_BUFFER_SIZE * sizeof(Pointer))
+#define GC_BUFFER_REMAINDER_BYTES (GC_BUFFER_BYTES - GC_BUFFER_OVERLAP_BYTES)
#define GC_FILE_FLAGS (O_RDWR | O_CREAT) /* O_SYNCIO removed */
#define GC_FILE_MASK 0644 /* Everyone reads, owner writes */
#define GC_DEFAULT_FILE_NAME "/tmp/GCXXXXXX"
-extern Pointer *scan_buffer_top;
-extern Pointer *free_buffer_top;
+extern Pointer *scan_buffer_top, *scan_buffer_bottom;
+extern Pointer *free_buffer_top, *free_buffer_bottom;
extern Pointer *dump_and_reload_scan_buffer();
extern Pointer *dump_and_reset_free_buffer();
extern void dump_free_directly(), load_buffer();
+extern void extend_scan_buffer();
+extern char *end_scan_buffer_extension();
+
extern Pointer *GCLoop();
extern Pointer *initialize_free_buffer(), *initialize_scan_buffer();
extern void end_transport(), GC();
{ \
long Car_Type; \
\
- Car_Type = Type_Code(*Old); \
+ Car_Type = OBJECT_TYPE(*Old); \
*To++ = Make_New_Pointer(TC_NULL, *Old); \
Old += 1; \
*To++ = *Old; \
Scan = To + (overflow % GC_DISK_BUFFER_SIZE); \
} \
while (To != Scan) \
+ { \
*To++ = *Old++; \
+ } \
Scan = Saved_Scan; \
}
\f
Old = Get_Pointer(Temp); \
if (Old >= Low_Constant) \
continue; \
- if (Type_Code(*Old) == TC_BROKEN_HEART) \
+ if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
{ \
- *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
+ *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old); \
continue; \
} \
New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
copy_code; \
To_Address += (length); \
if (To >= free_buffer_top) \
+ { \
To = dump_and_reset_free_buffer((To - free_buffer_top), NULL); \
+ } \
}
#define relocate_normal_end() \
{ \
*Get_Pointer(Temp) = New_Address; \
- *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \
+ *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), New_Address); \
continue; \
}
relocate_normal_transport(copy_code, length); \
relocate_normal_end(); \
}
+\f
+/* Typeless objects (implicit types). */
+
+#define relocate_typeless_setup() \
+{ \
+ Old = ((Pointer *) Temp); \
+ if (Old >= Low_Constant) \
+ continue; \
+ if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ { \
+ *Scan = ((Pointer) Get_Pointer(*Old)); \
+ continue; \
+ } \
+ New_Address = ((Pointer) To_Address); \
+}
+
+#define relocate_typeless_transport(copy_code, length) \
+{ \
+ relocate_normal_transport(copy_code, length); \
+}
+
+#define relocate_typeless_end() \
+{ \
+ *((Pointer *) Temp) = Make_Broken_Heart(C_To_Scheme(New_Address)); \
+ *Scan = New_Address; \
+ continue; \
+}
+
+#define relocate_typeless_pointer(copy_code, length) \
+{ \
+ relocate_typeless_setup(); \
+ relocate_typeless_transport(copy_code, length); \
+ relocate_typeless_end(); \
+}
+\f
+#define relocate_compiled_entry(in_gc_p) \
+{ \
+ Old = Get_Pointer(Temp); \
+ if (Old >= Low_Constant) \
+ continue; \
+ Compiled_BH(in_gc_p, continue); \
+ { \
+ Pointer *Saved_Old = Old; \
+ \
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+ copy_vector(NULL); \
+ *Saved_Old = New_Address; \
+ *Scan = Relocate_Compiled(Temp, \
+ Get_Pointer(New_Address), \
+ Saved_Old); \
+ continue; \
+ } \
+}
+
+#define relocate_linked_operator(in_gc_p) \
+{ \
+ Scan = OPERATOR_LINKAGE_ENTRY_ADDRESS(word_ptr); \
+ Temp = *Scan; \
+ relocate_compiled_entry(in_gc_p); \
+}
+
+#define relocate_manifest_closure(in_gc_p) \
+{ \
+ Scan = MANIFEST_CLOSURE_ENTRY_ADDRESS(word_ptr); \
+ Temp = *Scan; \
+ relocate_compiled_entry(in_gc_p); \
+}
+
+#define ONCE_ONLY(stmt) \
+do \
+{ \
+ stmt; \
+} while (false)
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.32 1988/02/20 06:16:15 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.33 1988/03/21 21:09:41 jinx Rel $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
#include "scheme.h"
#include "bchgcc.h"
+
+#ifdef FLOATING_ALIGNMENT
+/* This must be fixed. */
+#include "error: bchgcl does not handle floating alignment."
+#endif
\f
Pointer *
GCLoop(Scan, To_ptr, To_Address_ptr)
(overflow % GC_DISK_BUFFER_SIZE)) - 1);
break;
}
-\f
+
case_Non_Pointer:
break;
-
+\f
case_compiled_entry_point:
- Old = Get_Pointer(Temp);
- if (Old >= Low_Constant)
- continue;
- Compiled_BH(true, continue);
+ relocate_compiled_entry(true);
+
+ case TC_LINKAGE_SECTION:
+ {
+ if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
{
- Pointer *Saved_Old = Old;
+ /* count typeless pointers to quads follow. */
+
+ fast long count;
+ long max_count, max_here;
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
- copy_vector(NULL);
- *Saved_Old = New_Address;
- *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), Saved_Old);
- continue;
+ Scan++;
+ max_here = (scan_buffer_top - Scan);
+ max_count = READ_CACHE_LINKAGE_COUNT(Temp);
+ while (max_count != 0)
+ {
+ count = ((max_count > max_here) ? max_here : max_count);
+ max_count -= count;
+ for ( ; --count >= 0; Scan += 1)
+ {
+ Temp = *Scan;
+ relocate_typeless_pointer(copy_quadruple(), 4);
+ }
+ if (max_count != 0)
+ {
+ /* We stopped because we needed to relocate too many. */
+ Scan = dump_and_reload_scan_buffer(0, NULL);
+ max_here = GC_DISK_BUFFER_SIZE;
+ }
+ }
+ /* The + & -1 are here because of the Scan++ in the for header. */
+ Scan -= 1;
+ break;
}
+\f
+ else
+ {
+ /* Operator linkage */
+ fast long count;
+ fast machine_word *word_ptr, *next_ptr;
+ long overflow;
+
+ count = READ_OPERATOR_LINKAGE_COUNT(Temp);
+ word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
+ overflow = ((END_OPERATOR_LINKAGE_AREA(Scan, count)) -
+ scan_buffer_top);
+
+ for (next_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr);
+ (--count >= 0);
+ word_ptr = next_ptr,
+ next_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr))
+ {
+ if (next_ptr > ((machine_word *) scan_buffer_top))
+ {
+ extend_scan_buffer((char *) next_ptr, To);
+ ONCE_ONLY(relocate_linked_operator(true));
+ next_ptr = ((machine_word *)
+ end_scan_buffer_extension((char *) next_ptr));
+ overflow -= GC_DISK_BUFFER_SIZE;
+ }
+ else
+ {
+ relocate_linked_operator(true);
+ }
+ }
+ Scan = scan_buffer_top + overflow;
+ break;
+ }
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ machine_word *start_ptr;
+ fast machine_word *word_ptr, *next_ptr;
+
+ Scan += 1;
+ start_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
+
+ for (word_ptr = start_ptr,
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ true;
+ word_ptr = next_ptr,
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ if (!MANIFEST_CLOSURE_VALID_FITS_P(word_ptr, scan_buffer_top))
+ {
+ long dw, ds;
+
+ dw = (word_ptr - ((machine_word *) scan_buffer_top));
+ ds = (word_ptr - start_ptr);
+ word_ptr = (((machine_word *)
+ (dump_and_reload_scan_buffer(0, NULL))) +
+ dw);
+ start_ptr = word_ptr - ds;
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ }
+ if (!VALID_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ break;
+ }
+ else if (next_ptr > ((machine_word *) scan_buffer_top))
+ {
+ long ds;
+
+ ds = (next_ptr - start_ptr);
+ extend_scan_buffer((char *) next_ptr, To);
+ ONCE_ONLY(relocate_manifest_closure(true));
+ next_ptr = ((machine_word *)
+ end_scan_buffer_extension((char *) next_ptr));
+ start_ptr = next_ptr - ds;
+ }
+ else
+ {
+ relocate_manifest_closure(true);
+ }
+ }
+ Scan = MANIFEST_CLOSURE_END(word_ptr, start_ptr);
+ break;
+ }
+\f
case_Cell:
relocate_normal_pointer(copy_cell(), 1);
case TC_REFERENCE_TRAP:
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
{
/* It is a non pointer. */
break;
case_Quadruple:
relocate_normal_pointer(copy_quadruple(), 4);
-\f
-#ifdef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- /* This must be fixed. */
-#include "error: bchgcl does not handle floating alignment."
-#else
+
case TC_BIG_FLONUM:
- /* Fall through */
-#endif
case_Vector:
relocate_normal_setup();
Move_Vector:
case TC_FUTURE:
relocate_normal_setup();
if (!(Future_Spliceable(Temp)))
+ {
goto Move_Vector;
+ }
*Scan = Future_Value(Temp);
Scan -= 1;
continue;
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.40 1988/02/20 19:50:27 jinx Exp $ */
-
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.41 1988/03/21 21:09:57 jinx Rel $ */
+\f
/* Memory management top level. Garbage collection to disk.
The algorithm is basically the same as for the 2 space collector,
except that new space is on the disk, and there are two windows to
- it (the scan and free buffers). For information on the 2 space
- collector, read the comments in the replaced files.
+ it (the scan and free buffers). The two windows are physically the
+ same whent hey correspond to the same section of the disk.
+
+ For information on the 2 space collector, read the comments in the
+ replaced files.
The memory management code is spread over 3 files:
- bchmmg.c: initialization and top level. Replaces memmag.c
- bchdmp.c: object world image dumping. Replaces fasdump.c
Problems with this implementation right now:
- - It only works on Unix (or systems which support Unix i/o calls).
- - Purify is not implemented.
- - Fasdump is not implemented.
+ - Purify kills Scheme if there is not enough space in constant space
+ for the new object.
- Floating alignment is not implemented.
- - Dumpworld will not work because the file is not closed at dump time.
+ - It only works on Unix (or systems which support Unix i/o calls).
+ - Dumpworld cannot work because the file is not closed at dump time or
+ reopened at restart time.
- Command line supplied gc files are not locked, so two processes can try
- to share them.
- - Compiled code handling in bchgcl is not generic, may only work for 68k
- family processors.
+ to share them and get very confused.
*/
#include "scheme.h"
static Pointer *gc_disk_buffer_1, *gc_disk_buffer_2;
Pointer *scan_buffer_top, *scan_buffer_bottom;
Pointer *free_buffer_top, *free_buffer_bottom;
+
+static Boolean extension_overlap_p;
+static long extension_overlap_length;
\f
/* Hacking the gc file */
{
gc_file = open(gc_file_name, flags, GC_FILE_MASK);
if (gc_file != -1)
+ {
break;
+ }
if (gc_file_name != gc_default_file_name)
{
fprintf(stderr,
close_gc_file()
{
if (close(gc_file) == -1)
+ {
fprintf(stderr,
"%s: Problems closing GC file \"%s\".\n",
Saved_argv[0], gc_file_name);
+ }
if (gc_file_name == gc_default_file_name)
+ {
unlink(gc_file_name);
+ }
return;
}
\f
scan_buffer_top = free_buffer_top;
return;
}
- scan_buffer_bottom = ((free_buffer_bottom == gc_disk_buffer_1) ?
- gc_disk_buffer_2 :
- gc_disk_buffer_1);
load_buffer(scan_position, scan_buffer_bottom,
GC_BUFFER_BYTES, "the scan buffer");
- scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE;
*scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
return;
}
initialize_scan_buffer()
{
scan_position = 0;
+ scan_buffer_bottom = ((free_buffer_bottom == gc_disk_buffer_1) ?
+ gc_disk_buffer_2 :
+ gc_disk_buffer_1);
+ scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE;
reload_scan_buffer();
- return scan_buffer_bottom;
+ return (scan_buffer_bottom);
}
/* This hacks the scan buffer also so that Scan is always below
scan_buffer_top until the scan buffer is initialized.
+ Various parts of the garbage collector depend on scan_buffer_top
+ always pointing to a valid buffer.
*/
Pointer *
initialize_free_buffer()
free_position = 0;
free_buffer_bottom = gc_disk_buffer_1;
free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE;
+ extension_overlap_p = false;
scan_position = -1;
scan_buffer_bottom = gc_disk_buffer_2;
scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE;
- return free_buffer_bottom;
+ return (free_buffer_bottom);
}
void
return;
}
\f
+/* These utilities are needed when pointers fall accross window boundaries.
+
+ Between both they effectively do a dump_and_reload_scan_buffer, in two
+ stages.
+
+ Having bcopy would be nice here.
+*/
+
+void
+extend_scan_buffer(to_where, current_free)
+ fast char *to_where;
+ Pointer *current_free;
+{
+ long new_scan_position;
+
+ new_scan_position = (scan_position + GC_BUFFER_BYTES);
+
+ /* Is there overlap?, ie. is the next bufferfull the one cached
+ in the free pointer window? */
+
+ if (new_scan_position == free_position)
+ {
+ fast char *source, *dest;
+ long temp;
+
+ extension_overlap_p = true;
+ source = ((char *) free_buffer_bottom);
+ dest = ((char *) scan_buffer_top);
+ extension_overlap_length = (to_where - dest);
+ temp = (((char *) current_free) - source);
+ if (temp < extension_overlap_length)
+ {
+ /* This should only happen when Scan and Free are very close. */
+ extension_overlap_length = temp;
+ }
+
+ while (dest < to_where)
+ {
+ *dest++ = *source++;
+ }
+ }
+ else
+ {
+ extension_overlap_p = false;
+ load_buffer(new_scan_position, scan_buffer_top,
+ GC_BUFFER_OVERLAP_BYTES, "the scan buffer");
+ }
+ return;
+}
+\f
+char *
+end_scan_buffer_extension(to_relocate)
+ char *to_relocate;
+{
+ char *result;
+
+ dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan",
+ ((Boolean *) NULL));
+ if (!extension_overlap_p)
+ {
+ /* There was no overlap */
+
+ fast Pointer *source, *dest, *limit;
+
+ source = scan_buffer_top;
+ dest = scan_buffer_bottom;
+ limit = &source[GC_EXTRA_BUFFER_SIZE];
+ result = (((char *) scan_buffer_bottom) +
+ (to_relocate - ((char *) scan_buffer_top)));
+
+ while (source < limit)
+ {
+ *dest++ = *source++;
+ }
+ load_buffer((scan_position + GC_BUFFER_OVERLAP_BYTES),
+ dest,
+ GC_BUFFER_REMAINDER_BYTES,
+ "the scan buffer");
+ *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
+ }
+ else
+ {
+ fast char *source, *dest, *limit;
+
+ source = ((char *) scan_buffer_top);
+ dest = ((scan_position == free_position) ?
+ ((char *) free_buffer_bottom) :
+ ((char *) scan_buffer_bottom));
+ limit = &source[extension_overlap_length];
+ result = &dest[to_relocate - source];
+
+ while (source < limit)
+ {
+ *dest++ = *source++;
+ }
+ if (scan_position == free_position)
+ {
+ /* There was overlap, and there still is. */
+
+ scan_buffer_bottom = free_buffer_bottom;
+ scan_buffer_top = free_buffer_top;
+ }
+ else
+ {
+ /* There was overlap, but there no longer is. */
+
+ load_buffer((scan_position + extension_overlap_length),
+ dest,
+ (GC_BUFFER_BYTES - extension_overlap_length),
+ "the scan buffer");
+ *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
+ }
+ }
+ extension_overlap_p = false;
+ return (result);
+}
+\f
Pointer *
dump_and_reload_scan_buffer(number_to_skip, success)
long number_to_skip;
{
dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan", success);
if (number_to_skip != 0)
+ {
scan_position += (number_to_skip * GC_BUFFER_BYTES);
+ }
reload_scan_buffer();
- return scan_buffer_bottom;
+ return (scan_buffer_bottom);
}
Pointer *
free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE;
}
else
+ {
dump_buffer(free_buffer_bottom, &free_position, 1, "free", success);
+ }
for (into = free_buffer_bottom; --overflow >= 0; )
+ {
*into++ = *from++;
+ }
- /* This only needs to be done when they were the same buffer,
- but it does not hurt.
- */
- *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
-
- return into;
+ /* This need only be done when free_buffer_bottom was scan_buffer_bottom,
+ but it does not hurt otherwise unless we were in the
+ extend_scan_buffer/end_scan_buffer_extension window.
+ It must also be done after the for loop above.
+ */
+ if (!extension_overlap_p)
+ {
+ *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
+ }
+ return (into);
}
void
flush_new_space_buffer()
{
if (current_buffer_position == -1)
+ {
return;
+ }
dump_buffer(gc_disk_buffer_1, ¤t_buffer_position,
1, "weak pair buffer", NULL);
current_buffer_position = -1;
long position, offset;
if (addr >= Constant_Space)
- return addr;
+ {
+ return (addr);
+ }
position = (addr - Heap_Bottom);
offset = (position % GC_DISK_BUFFER_SIZE);
GC_BUFFER_BYTES, "the weak pair buffer");
current_buffer_position = position;
}
- return &gc_disk_buffer_1[offset];
+ return (&gc_disk_buffer_1[offset]);
}
\f
/* For a description of the algorithm, see memmag.c.
Scan = guarantee_in_memory(Get_Pointer(*Old_Weak_Cell++));
Weak_Chain = *Old_Weak_Cell;
Old_Car = *Scan;
- Temp = Make_New_Pointer(Type_Code(Weak_Chain), Old_Car);
+ Temp = Make_New_Pointer(OBJECT_TYPE(Weak_Chain), Old_Car);
Weak_Chain = Make_New_Pointer(TC_NULL, Weak_Chain);
switch(GC_Type(Temp))
- { case GC_Non_Pointer:
+ {
+ case GC_Non_Pointer:
*Scan = Temp;
continue;
case GC_Special:
- if (Type_Code(Temp) != TC_REFERENCE_TRAP)
+ if (OBJECT_TYPE(Temp) != TC_REFERENCE_TRAP)
{
/* No other special type makes sense here. */
goto fail;
}
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
{
*Scan = Temp;
continue;
*Scan = Temp;
continue;
}
- if (Type_Code(*Old) == TC_BROKEN_HEART)
+ if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART)
{
- *Scan = Make_New_Pointer(Type_Code(Temp), *Old);
+ *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old);
continue;
}
*Scan = NIL;
fail:
fprintf(stderr,
"\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n",
- Type_Code(Temp), Datum(Temp));
+ OBJECT_TYPE(Temp), OBJECT_DATUM(Temp));
Microcode_Termination(TERM_INVALID_TYPE_CODE);
/*NOTREACHED*/
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.38 1988/02/20 06:16:26 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.39 1988/03/21 21:10:17 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
#include "scheme.h"
#include "primitive.h"
#include "bchgcc.h"
+
+#ifdef FLOATING_ALIGNMENT
+/* This must be fixed. */
+#include "error: bchpur does not handle floating alignment."
+#endif
\f
-/* Stub. Not needed by this version. Terminates Scheme if invoked. */
+/* Purify modes */
-Pointer
-Purify_Pass_2(info)
- Pointer info;
-{
- gc_death(TERM_EXIT, "Purify_Pass_2 invoked", NULL, NULL);
- /*NOTREACHED*/
-}
+#define NORMAL_GC 0
+#define PURE_COPY 1
+#define CONSTANT_COPY 2
/* Some utility macros. */
case_compiled_entry_point:
if (purify_mode == PURE_COPY)
break;
- Old = Get_Pointer(Temp);
- if (Old >= Low_Constant)
- continue;
- Compiled_BH(true, continue);
- {
- Pointer *Saved_Old = Old;
+ relocate_compiled_entry(false);
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
- copy_vector(NULL);
- *Saved_Old = New_Address;
- *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), Saved_Old);
- continue;
+ case TC_LINKAGE_SECTION:
+ {
+ if (purify_mode == PURE_COPY)
+ {
+ gc_death(TERM_COMPILER_DEATH,
+ "purifyloop: linkage section in pure area",
+ Scan, To);
+ /*NOTREACHED*/
+ }
+ if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
+ {
+ /* count typeless pointers to quads follow. */
+
+ fast long count;
+ long max_count, max_here;
+
+ Scan++;
+ max_here = (scan_buffer_top - Scan);
+ max_count = READ_CACHE_LINKAGE_COUNT(Temp);
+ while (max_count != 0)
+ {
+ count = ((max_count > max_here) ? max_here : max_count);
+ max_count -= count;
+ for ( ; --count >= 0; Scan += 1)
+ {
+ Temp = *Scan;
+ relocate_typeless_pointer(copy_quadruple(), 4);
+ }
+ if (max_count != 0)
+ {
+ /* We stopped because we needed to relocate too many. */
+ Scan = dump_and_reload_scan_buffer(0, NULL);
+ max_here = GC_DISK_BUFFER_SIZE;
+ }
+ }
+ /* The + & -1 are here because of the Scan++ in the for header. */
+ Scan -= 1;
+ break;
}
+\f
+ else
+ {
+ /* Operator linkage */
+
+ fast long count;
+ fast machine_word *word_ptr, *next_ptr;
+ long overflow;
+
+ count = READ_OPERATOR_LINKAGE_COUNT(Temp);
+ word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
+ overflow = ((END_OPERATOR_LINKAGE_AREA(Scan, count)) -
+ scan_buffer_top);
+
+ for (next_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr);
+ (--count >= 0);
+ word_ptr = next_ptr,
+ next_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr))
+ {
+ if (next_ptr > ((machine_word *) scan_buffer_top))
+ {
+ extend_scan_buffer((char *) next_ptr, To);
+ ONCE_ONLY(relocate_linked_operator(false));
+ next_ptr = ((machine_word *)
+ end_scan_buffer_extension((char *) next_ptr));
+ overflow -= GC_DISK_BUFFER_SIZE;
+ }
+ else
+ {
+ relocate_linked_operator(false);
+ }
+ }
+ Scan = scan_buffer_top + overflow;
+ break;
+ }
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ if (purify_mode == PURE_COPY)
+ {
+ gc_death(TERM_COMPILER_DEATH,
+ "purifyloop: manifest closure in pure area",
+ Scan, To);
+ /*NOTREACHED*/
+ }
+ }
+ {
+ machine_word *start_ptr;
+ fast machine_word *word_ptr, *next_ptr;
+ Scan += 1;
+ start_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
+
+ for (word_ptr = start_ptr,
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ true;
+ word_ptr = next_ptr,
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ if (!MANIFEST_CLOSURE_VALID_FITS_P(word_ptr, scan_buffer_top))
+ {
+ long dw, ds;
+
+ dw = (word_ptr - ((machine_word *) scan_buffer_top));
+ ds = (word_ptr - start_ptr);
+ word_ptr = (((machine_word *)
+ (dump_and_reload_scan_buffer(0, NULL))) +
+ dw);
+ start_ptr = word_ptr - ds;
+ next_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ }
+ if (!VALID_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ break;
+ }
+ else if (next_ptr > ((machine_word *) scan_buffer_top))
+ {
+ long ds;
+
+ ds = (next_ptr - start_ptr);
+ extend_scan_buffer((char *) next_ptr, To);
+ ONCE_ONLY(relocate_manifest_closure(false));
+ next_ptr = ((machine_word *)
+ end_scan_buffer_extension((char *) next_ptr));
+ start_ptr = next_ptr - ds;
+ }
+ else
+ {
+ relocate_manifest_closure(false);
+ }
+ }
+ Scan = MANIFEST_CLOSURE_END(word_ptr, start_ptr);
+ break;
+ }
+\f
case_Cell:
relocate_normal_pointer(copy_cell(), 1);
break;
/* Fall through */
-#ifdef FLOATING_ALIGNMENT
case TC_BIG_FLONUM:
- /* This must be fixed. */
-#include "error: bchpur does not handle floating alignment."
-#else
- case TC_BIG_FLONUM:
- /* Fall through */
-#endif
case_Purify_Vector:
relocate_normal_setup();
Move_Vector:
{
free_buffer = purify_header_overflow(free_buffer);
}
-
+\f
if (flag == TRUTH)
{
Result = purifyloop(initialize_scan_buffer(),
*block_start = Make_Non_Pointer(PURE_PART, (length - 1));
GC(Weak_Chain);
Set_Pure_Top();
- return TRUTH;
+ return (TRUTH);
+}
+
+/* Stub. Not needed by this version. Terminates Scheme if invoked. */
+
+Pointer
+Purify_Pass_2(info)
+ Pointer info;
+{
+ gc_death(TERM_EXIT, "Purify_Pass_2 invoked", NULL, NULL);
+ /*NOTREACHED*/
}
\f
/* (PRIMITIVE-PURIFY OBJECT PURE?)
projects / mit-scheme.git / commitdiff