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.29 1987/05/29 02:20:58 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.30 1987/06/02 00:16:04 jinx Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
#include "scheme.h"
#include "primitive.h"
+#include "trap.h"
+#include "lookup.h" /* UNCOMPILED_VARIABLE */
#define In_Fasdump
#include "bchgcc.h"
#include "dump.c"
extern Pointer Make_Prim_Exts();
+static char *dump_file_name;
+static int real_gc_file, dump_file;
+static Pointer *saved_free;
+static Pointer fixup_buffer[GC_DISK_BUFFER_SIZE];
+static Pointer *fixup_buffer_end = &fixup_buffer[GC_DISK_BUFFER_SIZE];
+static Pointer *fixup;
+static fixup_count = 0;
+\f
+/* Utility macros. */
+
+#define fasdump_normal_setup() \
+{ \
+ Old = Get_Pointer(Temp); \
+ if (Type_Code(*Old) == TC_BROKEN_HEART) \
+ { \
+ *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
+ continue; \
+ } \
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+ fasdump_remember_to_fix(Old, *Old); \
+}
+
+#define fasdump_transport_end(length) \
+{ \
+ To_Address += (length); \
+ if (To >= free_buffer_top) \
+ To = dump_and_reset_free_buffer(To - free_buffer_top); \
+}
+
+#define fasdump_normal_transport(copy_code, length) \
+{ \
+ copy_code; \
+ fasdump_transport_end(length); \
+}
+
+#define fasdump_normal_end() \
+{ \
+ *Get_Pointer(Temp) = New_Address; \
+ *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \
+ continue; \
+}
+
+#define fasdump_normal_pointer(copy_code, length) \
+{ \
+ fasdump_normal_setup(); \
+ fasdump_normal_transport(copy_code, length); \
+ fasdump_normal_end(); \
+}
+
+#define fasdump_remember_to_fix(location, contents) \
+{ \
+ if ((fixup == fixup_buffer) && (!reset_fixes())) \
+ return false; \
+ *--fixup = contents; \
+ *--fixup = ((Pointer) location); \
+}
+\f
+void
+fasdump_exit(length)
+ long length;
+{
+ extern int ftruncate(), unlink();
+ fast Pointer *fixes, *fix_address;
+
+ Free = saved_free;
+ gc_file = real_gc_file;
+ ftruncate(dump_file, length);
+ close(dump_file);
+ if (length == 0)
+ unlink(dump_file_name);
+ dump_file_name = ((char *) NULL);
+
+ fixes = fixup;
+
+next_buffer:
+
+ while (fixes != fixup_buffer_end)
+ {
+ fix_address = ((Pointer *) (*fixes++)); /* Where it goes. */
+ *fix_address = *fixes++; /* Put it there. */
+ }
+
+ if (fixup_count >= 0)
+ {
+ lseek(real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0);
+ read(real_gc_file, fixup_buffer, GC_BUFFER_BYTES);
+ fixup_count -= 1;
+ fixes = fixup_buffer;
+ goto next_buffer;
+ }
+
+ fixup = fixes;
+ Fasdump_Exit_Hook();
+ return;
+}
+
+Boolean
+reset_fixes()
+{
+ fixup_count += 1;
+ if ((lseek(real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0) == -1) ||
+ (write(real_gc_file, fixup_buffer, GC_BUFFER_BYTES) != GC_BUFFER_BYTES))
+ return false;
+ fixup = fixup_buffer_end;
+ return true;
+}
+\f
+/* A copy of GCLoop, with minor modifications. */
+
+Boolean
+dumploop(Scan, To_ptr, To_Address_ptr)
+ fast Pointer *Scan;
+ Pointer **To_ptr, **To_Address_ptr;
+{
+ fast Pointer *To, *Old, Temp, *To_Address, New_Address;
+ To = *To_ptr;
+ To_Address = *To_Address_ptr;
+
+ for ( ; Scan != To; Scan++)
+ {
+ Temp = *Scan;
+ Switch_by_GC_Type(Temp)
+ {
+ case TC_BROKEN_HEART:
+ if (Datum(Temp) == 0)
+ break;
+ if (Scan != (Get_Pointer(Temp)))
+ {
+ fprintf(stderr, "\ndumploop: Broken heart in scan.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ if (Scan != scan_buffer_top)
+ goto end_dumploop;
+ /* The -1 is here because of the Scan++ in the for header. */
+ Scan = dump_and_reload_scan_buffer(0) - 1;
+ continue;
+
+ case TC_MANIFEST_NM_VECTOR:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ /* Check whether this bumps over current buffer,
+ and if so we need a new bufferfull. */
+ Scan += Get_Integer(Temp);
+ if (Scan < scan_buffer_top)
+ break;
+ else
+ {
+ unsigned long overflow;
+
+ /* The + & -1 are here because of the Scan++ in the for header. */
+ overflow = (Scan - scan_buffer_top) + 1;
+ Scan = ((dump_and_reload_scan_buffer(overflow / GC_DISK_BUFFER_SIZE) +
+ (overflow % GC_DISK_BUFFER_SIZE)) - 1);
+ break;
+ }
+
+ case_Non_Pointer:
+ break;
+\f
+ case_compiled_entry_point:
+ Old = Get_Pointer(Temp);
+ Compiled_BH(true, continue);
+ {
+ Pointer *Saved_Old = Old;
+
+ fasdump_remember_to_fix(Old, *Old);
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
+ copy_vector();
+ *Saved_Old = New_Address;
+ *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), Saved_Old);
+ continue;
+ }
+
+ case_Cell:
+ fasdump_normal_pointer(copy_cell(), 1);
+
+ case TC_REFERENCE_TRAP:
+ if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ {
+ /* It is a non pointer. */
+ break;
+ }
+ /* It is a pair, fall through. */
+ case TC_WEAK_CONS:
+ case_Fasdump_Pair:
+ fasdump_normal_pointer(copy_pair(), 2);
+
+ case TC_INTERNED_SYMBOL:
+ {
+ fasdump_normal_setup();
+ *To++ = *Old;
+ *To++ = Make_Broken_Heart(0);
+ fasdump_transport_end(2);
+ fasdump_normal_end();
+ }
+
+ case TC_UNINTERNED_SYMBOL:
+ {
+ fasdump_normal_setup();
+ *To++ = *Old;
+ *To++ = UNBOUND_OBJECT;
+ fasdump_transport_end(2);
+ fasdump_normal_end();
+ }
+\f
+ case_Triple:
+ fasdump_normal_pointer(copy_triple(), 3);
+
+ case TC_VARIABLE:
+ {
+ fasdump_normal_setup();
+ *To++ = *Old;
+ *To++ = UNCOMPILED_VARIABLE;
+ *To++ = NIL;
+ fasdump_transport_end(3);
+ fasdump_normal_end();
+ }
+
+ 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_Vector:
+ fasdump_normal_setup();
+ Move_Vector:
+ copy_vector();
+ fasdump_normal_end();
+
+ case TC_FUTURE:
+ fasdump_normal_setup();
+ if (!(Future_Spliceable(Temp)))
+ goto Move_Vector;
+ *Scan = Future_Value(Temp);
+ Scan -= 1;
+ continue;
+
+ default:
+ fprintf(stderr,
+ "\ndumploop: Bad type code = 0x%02x\n",
+ Type_Code(Temp));
+ Invalid_Type_Code();
+ }
+ }
+end_dumploop:
+ *To_ptr = To;
+ *To_Address_ptr = To_Address;
+ return true;
+}
+\f
/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
- Not implemented yet.
+ Dump an object into a file so that it can be loaded using
+ BINARY-FASLOAD. A spare heap is required for this operation. The
+ first argument is the object to be dumped. The second is the
+ filename and the third a flag. The flag, if #!TRUE, means that the
+ object is to be dumped for reloading into constant space. If the
+ flag is NIL, it means that it will be reloaded into the heap. This
+ flag is currently ignored. The primitive returns #!TRUE or NIL
+ indicating whether it successfully dumped the object (it can fail
+ on an object that is too large).
*/
Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56)
{
+ long length, hlength;
+ Pointer Prim_Exts, *dumped_object, *exts, *free_buffer;
+ Pointer header[FASL_HEADER_LENGTH];
Primitive_3_Args();
- Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
- /*NOTREACHED*/
+ if (Type_Code(Arg2) != TC_CHARACTER_STRING)
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ dump_file_name = Scheme_String_To_C_String(Arg2);
+ dump_file = open(dump_file_name, GC_FILE_FLAGS, 0666);
+ if (dump_file < 0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+
+ Prim_Exts = Make_Prim_Exts();
+
+ real_gc_file = gc_file;
+ gc_file = dump_file;
+ saved_free = Free;
+ fixup = fixup_buffer_end;
+ fixup_count = -1;
+\f
+#if (GC_DISK_BUFFER_SIZE <= FASL_HEADER_LENGTH)
+#include "error in bchdmp.c: FASL_HEADER_LENGTH too large"
+#endif
+
+ free_buffer = initialize_free_buffer();
+ Free = ((Pointer *) NULL);
+ free_buffer += FASL_HEADER_LENGTH;
+ *free_buffer++ = Arg1;
+ dumped_object = Free;
+ Free += 1;
+ *free_buffer++ = Prim_Exts;
+ exts = Free;
+ Free += 1;
+
+ if (!dumploop((initialize_scan_buffer() + FASL_HEADER_LENGTH),
+ &free_buffer, &Free))
+ {
+ fasdump_exit(0);
+ PRIMITIVE_RETURN(NIL);
+ }
+ end_transport();
+
+ length = (Free - dumped_object);
+ prepare_dump_header(header, length, dumped_object, dumped_object,
+ 0, Constant_Space, exts);
+ hlength = (FASL_HEADER_LENGTH * sizeof(Pointer));
+ if ((lseek(gc_file, 0, 0) == -1) ||
+ (write(gc_file, ((char *) &header[0]), hlength) != hlength))
+ {
+ fasdump_exit(0);
+ PRIMITIVE_RETURN(NIL);
+ }
+ fasdump_exit((sizeof(Pointer) * length) + hlength);
+ PRIMITIVE_RETURN(TRUTH);
}
\f
/* (DUMP-BAND PROCEDURE FILE-NAME)
- Saves all of the heap and pure space on FILE-NAME. When the
- file is loaded back using BAND_LOAD, PROCEDURE is called with an
- argument of NIL.
+ Saves all of the heap and pure space on FILE-NAME. When the
+ file is loaded back using BAND_LOAD, PROCEDURE is called with an
+ argument of NIL.
*/
Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
{
((long) (Free_Constant-Constant_Space)),
Constant_Space, Free-1);
fclose(File_Handle);
- return TRUTH;
+ PRIMITIVE_RETURN(TRUTH);
}
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.26 1987/02/12 01:17:47 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.27 1987/06/02 00:16:16 jinx Exp $ */
#include "gccode.h"
+#include <fcntl.h>
/* All of these are in objects (Pointer), not bytes. */
#define GC_BUFFER_SPACE (GC_DISK_BUFFER_SIZE + GC_EXTRA_BUFFER_SIZE)
#define GC_BUFFER_BYTES (GC_DISK_BUFFER_SIZE * sizeof(Pointer))
+#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 *free_buffer_top;
extern Pointer *dump_and_reload_scan_buffer();
extern Pointer *dump_and_reset_free_buffer();
-extern void dump_free_directly();
+extern void dump_free_directly(), load_buffer();
extern Pointer *GCLoop();
+extern Pointer *initialize_free_buffer(), *initialize_scan_buffer();
+extern void end_transport(), GC();
+extern int gc_file;
+\f
+/* Some utility macros */
+
+#define copy_cell() \
+{ \
+ *To++ = *Old; \
+}
+
+#define copy_pair() \
+{ \
+ *To++ = *Old++; \
+ *To++ = *Old; \
+}
+
+#define copy_weak_pair() \
+{ \
+ long Car_Type; \
+ \
+ Car_Type = Type_Code(*Old); \
+ *To++ = Make_New_Pointer(TC_NULL, *Old); \
+ Old += 1; \
+ *To++ = *Old; \
+ *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
+ Weak_Chain = Temp; \
+}
+
+#define copy_triple() \
+{ \
+ *To++ = *Old++; \
+ *To++ = *Old++; \
+ *To++ = *Old; \
+}
+
+#define copy_quadruple() \
+{ \
+ *To++ = *Old++; \
+ *To++ = *Old++; \
+ *To++ = *Old++; \
+ *To++ = *Old; \
+}
+\f
+/* Transporting vectors is done in 3 parts:
+ - Finish filling the current free buffer, dump it, and get a new one.
+ - Dump the middle of the vector directly by bufferfulls.
+ - Copy the end of the vector to the new buffer.
+ The last piece of code is the only one executed when the vector does
+ not overflow the current buffer.
+*/
+
+#define copy_vector() \
+{ \
+ Pointer *Saved_Scan = Scan; \
+ unsigned long real_length = 1 + Get_Integer(*Old); \
+ \
+ To_Address += real_length; \
+ Scan = To + real_length; \
+ if (Scan >= free_buffer_top) \
+ { \
+ unsigned long overflow; \
+ \
+ overflow = Scan - free_buffer_top; \
+ while (To != free_buffer_top) \
+ *To++ = *Old++; \
+ To = dump_and_reset_free_buffer(0); \
+ real_length = (overflow / GC_DISK_BUFFER_SIZE); \
+ if (real_length > 0) \
+ dump_free_directly(Old, real_length); \
+ Old += (real_length * GC_DISK_BUFFER_SIZE); \
+ Scan = To + (overflow % GC_DISK_BUFFER_SIZE); \
+ } \
+ while (To != Scan) \
+ *To++ = *Old++; \
+ Scan = Saved_Scan; \
+}
+\f
+/* Utility macros. */
+
+#define relocate_normal_setup() \
+{ \
+ Old = Get_Pointer(Temp); \
+ if (Old >= Low_Constant) \
+ continue; \
+ if (Type_Code(*Old) == TC_BROKEN_HEART) \
+ { \
+ *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
+ continue; \
+ } \
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+}
+
+#define relocate_normal_transport(copy_code, length) \
+{ \
+ copy_code; \
+ To_Address += (length); \
+ if (To >= free_buffer_top) \
+ To = dump_and_reset_free_buffer(To - free_buffer_top); \
+}
+
+#define relocate_normal_end() \
+{ \
+ *Get_Pointer(Temp) = New_Address; \
+ *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \
+ continue; \
+}
+
+#define relocate_normal_pointer(copy_code, length) \
+{ \
+ relocate_normal_setup(); \
+ relocate_normal_transport(copy_code, length); \
+ relocate_normal_end(); \
+}
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.28 1987/04/16 02:06:42 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.29 1987/06/02 00:16:25 jinx Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
#include "scheme.h"
#include "bchgcc.h"
\f
-/* Some utility macros */
-
-#define copy_cell() \
-{ *To++ = *Old; \
-}
-
-#define copy_pair() \
-{ *To++ = *Old++; \
- *To++ = *Old; \
-}
-
-#define copy_weak_pair() \
-{ long Car_Type; \
- \
- Car_Type = Type_Code(*Old); \
- *To++ = Make_New_Pointer(TC_NULL, *Old); \
- Old += 1; \
- *To++ = *Old; \
- *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
- Weak_Chain = Temp; \
-}
-
-#define copy_triple() \
-{ *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old; \
-}
-
-#define copy_quadruple() \
-{ *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old; \
-}
-
-/* Transporting vectors is done in 3 parts:
- - Finish filling the current free buffer, dump it, and get a new one.
- - Dump the middle of the vector directly by bufferfulls.
- - Copy the end of the vector to the new buffer.
- The last piece of code is the only one executed when the vector does
- not overflow the current buffer.
-*/
-
-#define copy_vector() \
-{ Pointer *Saved_Scan = Scan; \
- unsigned long real_length = 1 + Get_Integer(*Old); \
- \
- To_Address += real_length; \
- Scan = To + real_length; \
- if (Scan >= free_buffer_top) \
- { unsigned long overflow; \
- \
- overflow = Scan - free_buffer_top; \
- while (To != free_buffer_top) *To++ = *Old++; \
- To = dump_and_reset_free_buffer(0); \
- real_length = (overflow / GC_DISK_BUFFER_SIZE); \
- if (real_length > 0) dump_free_directly(Old, real_length); \
- Old += (real_length * GC_DISK_BUFFER_SIZE); \
- Scan = To + (overflow % GC_DISK_BUFFER_SIZE); \
- } \
- while (To != Scan) *To++ = *Old++; \
- Scan = Saved_Scan; \
-}
-\f
-#define relocate_normal_setup() \
-{ \
- Old = Get_Pointer(Temp); \
- if (Old >= Low_Constant) continue; \
- if (Type_Code(*Old) == TC_BROKEN_HEART) \
- { *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
- continue; \
- } \
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
-}
-
-#define relocate_normal_transport(copy_code, length) \
-{ copy_code; \
- To_Address += (length); \
- if (To >= free_buffer_top) \
- To = dump_and_reset_free_buffer(To - free_buffer_top); \
-}
-
-#define relocate_normal_end() \
-{ *Get_Pointer(Temp) = New_Address; \
- *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \
- continue; \
-}
-
-#define relocate_normal_pointer(copy_code, length) \
-{ relocate_normal_setup(); \
- relocate_normal_transport(copy_code, length); \
- relocate_normal_end(); \
-}
-\f
-Pointer
-*GCLoop(Scan, To_ptr, To_Address_ptr)
-fast Pointer *Scan;
-Pointer **To_ptr, **To_Address_ptr;
-{ fast Pointer *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
+Pointer *
+GCLoop(Scan, To_ptr, To_Address_ptr)
+ fast Pointer *Scan;
+ Pointer **To_ptr, **To_Address_ptr;
+{
+ fast Pointer *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
To = *To_ptr;
To_Address = *To_Address_ptr;
Low_Constant = Constant_Space;
for ( ; Scan != To; Scan++)
- { Temp = *Scan;
+ {
+ Temp = *Scan;
Switch_by_GC_Type(Temp)
- { case TC_BROKEN_HEART:
+ {
+ case TC_BROKEN_HEART:
if (Scan != (Get_Pointer(Temp)))
- { fprintf(stderr, "GC: Broken heart in scan.\n");
+ {
+ fprintf(stderr, "\nGC: Broken heart in scan.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
- if (Scan != scan_buffer_top) goto end_gcloop;
+ if (Scan != scan_buffer_top)
+ goto end_gcloop;
/* The -1 is here because of the Scan++ in the for header. */
Scan = dump_and_reload_scan_buffer(0) - 1;
continue;
if (Scan < scan_buffer_top)
break;
else
- { unsigned long overflow;
+ {
+ unsigned long overflow;
+
/* The + & -1 are here because of the Scan++ in the for header. */
overflow = (Scan - scan_buffer_top) + 1;
Scan = ((dump_and_reload_scan_buffer(overflow / GC_DISK_BUFFER_SIZE) +
(overflow % GC_DISK_BUFFER_SIZE)) - 1);
break;
}
-
+\f
case_Non_Pointer:
break;
case_compiled_entry_point:
Old = Get_Pointer(Temp);
- if (Old >= Low_Constant) continue;
- Old = Get_Compiled_Block(Old);
- if (Type_Code(*Old) == TC_BROKEN_HEART)
- { *Scan = Relocate_Compiled(Temp, Get_Pointer(*Old), Old);
+ if (Old >= Low_Constant)
continue;
- }
- else
- { Pointer *Saved_Old = Old;
+ Compiled_BH(true, continue);
+ {
+ Pointer *Saved_Old = Old;
+
New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
copy_vector();
*Saved_Old = New_Address;
case_Quadruple:
relocate_normal_pointer(copy_quadruple(), 4);
-
+\f
#ifdef FLOATING_ALIGNMENT
case TC_BIG_FLONUM:
/* This must be fixed. */
case TC_FUTURE:
relocate_normal_setup();
- if (!(Future_Spliceable(Temp))) goto Move_Vector;
+ if (!(Future_Spliceable(Temp)))
+ goto Move_Vector;
*Scan = Future_Value(Temp);
Scan -= 1;
continue;
default:
fprintf(stderr,
- "GCLoop: Bad type code = 0x%02x\n",
+ "\nGCLoop: Bad type code = 0x%02x\n",
Type_Code(Temp));
Invalid_Type_Code();
}
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.29 1987/04/21 14:54:50 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.30 1987/06/02 00:16:36 jinx Exp $ */
/* Memory management top level. Garbage collection to disk.
#include "scheme.h"
#include "primitive.h"
#include "bchgcc.h"
-#include <fcntl.h>
/* Exports */
static long scan_position, free_position;
static Pointer *gc_disk_buffer_1, *gc_disk_buffer_2;
-Pointer *scan_buffer_top, *scan_buffer_bottom, *scan_buffer;
-Pointer *free_buffer_top, *free_buffer_bottom, *free_buffer;
+Pointer *scan_buffer_top, *scan_buffer_bottom;
+Pointer *free_buffer_top, *free_buffer_bottom;
\f
/* Hacking the gc file */
extern char *mktemp();
-static int gc_file;
+int gc_file;
static char *gc_file_name;
static char gc_default_file_name[FILE_NAME_LENGTH] = GC_DEFAULT_FILE_NAME;
int flags;
(void) mktemp(gc_default_file_name);
- flags = (O_RDWR | O_CREAT | O_SYNCIO);
+ flags = GC_FILE_FLAGS;
position = Parse_Option("-gcfile", Saved_argc, Saved_argv, true);
if ((position != NOT_THERE) &&
{
scan_buffer_bottom = free_buffer_bottom;
scan_buffer_top = free_buffer_top;
- scan_buffer = scan_buffer_bottom;
return;
}
scan_buffer_bottom = ((free_buffer_bottom == gc_disk_buffer_1) ?
return;
}
\f
-void
+Pointer *
initialize_scan_buffer()
{
scan_position = 0;
reload_scan_buffer();
- scan_buffer = scan_buffer_bottom;
- return;
+ 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.
*/
-void
+Pointer *
initialize_free_buffer()
{
free_position = 0;
free_buffer_bottom = gc_disk_buffer_1;
free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE;
- free_buffer = free_buffer_bottom;
scan_position = -1;
scan_buffer_bottom = gc_disk_buffer_2;
scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE;
- return;
+ return free_buffer_bottom;
}
+void
+end_transport()
+{
+ dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan");
+ free_position = scan_position;
+ return;
+}
+\f
Pointer *
dump_and_reload_scan_buffer(number_to_skip)
long number_to_skip;
void
GC()
{
- Pointer *Root, *Result, *end_of_constant_area,
- The_Precious_Objects, *Root2;
+ static Pointer *Root, *Result, *end_of_constant_area,
+ The_Precious_Objects, *Root2, *free_buffer;
- initialize_free_buffer();
+ free_buffer = initialize_free_buffer();
Free = Heap_Bottom;
Set_Mem_Top(Heap_Top - GC_Reserve);
Weak_Chain = NIL;
/* Save the microcode registers so that they can be relocated */
+
Terminate_Old_Stacklet();
Terminate_Constant_Space(end_of_constant_area);
-
Root = Free;
The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects);
Set_Fixed_Obj_Slot(Precious_Objects, NIL);
Free += (free_buffer - free_buffer_bottom);
if (free_buffer >= free_buffer_top)
free_buffer = dump_and_reset_free_buffer(free_buffer - free_buffer_top);
-\f
+
/* The 4 step GC */
+
Result = GCLoop(Constant_Space, &free_buffer, &Free);
if (Result != end_of_constant_area)
{
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
- initialize_scan_buffer();
- Result = GCLoop(scan_buffer, &free_buffer, &Free);
+
+ Result = GCLoop(initialize_scan_buffer(), &free_buffer, &Free);
if (free_buffer != Result)
{
fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
+\f
Root2 = Free;
*free_buffer++ = The_Precious_Objects;
Free += (free_buffer - Result);
if (free_buffer >= free_buffer_top)
free_buffer = dump_and_reset_free_buffer(free_buffer - free_buffer_top);
+
Result = GCLoop(Result, &free_buffer, &Free);
if (free_buffer != Result)
{
Microcode_Termination(TERM_EXIT);
/*NOTREACHED*/
}
- dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan");
- free_position = scan_position;
+
+ end_transport();
+
Fix_Weak_Chain();
load_buffer(0, Heap_Bottom,
((Free - Heap_Bottom) * sizeof(Pointer)),
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/bchpur.c,v 9.27 1987/04/16 02:07:10 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.28 1987/06/02 00:16:53 jinx Exp $
*
* This file contains the code for primitives dealing with pure
* and constant space. Garbage collection to disk version.
*
- * Currently this is not implemented. These are just stubs.
+ * Poorly implemented: If there is not enough space, instead of
+ * undoing the changes, it crashes.
+ * It should be changed to do the job in two passes like the
+ * "normal" version.
*
*/
#include "primitive.h"
#include "bchgcc.h"
\f
-/* Stub. Terminates Scheme if invoked. */
+/* Stub. Not needed by this version. Terminates Scheme if invoked. */
Pointer
Purify_Pass_2(info)
/*NOTREACHED*/
}
-/* Stub. Make it look as if it had succeeded. */
+/* Some utility macros. */
+#define relocate_indirect_setup() \
+{ \
+ Old = Get_Pointer(Temp); \
+ if (Old >= Low_Constant) \
+ continue; \
+ if (Type_Code(*Old) == TC_BROKEN_HEART) \
+ { \
+ continue; \
+ } \
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
+}
+
+#define relocate_indirect_end() \
+{ \
+ *Get_Pointer(Temp) = New_Address; \
+ continue; \
+}
+\f
+/* A modified copy of GCLoop. */
+
+Pointer *
+purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode)
+ fast Pointer *Scan;
+ Pointer **To_ptr, **To_Address_ptr;
+ int purify_mode;
+{
+ fast Pointer *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
+
+ To = *To_ptr;
+ To_Address = *To_Address_ptr;
+ Low_Constant = Constant_Space;
+
+ for ( ; Scan != To; Scan++)
+ {
+ Temp = *Scan;
+ Switch_by_GC_Type(Temp)
+ {
+ case TC_BROKEN_HEART:
+ if (Scan != (Get_Pointer(Temp)))
+ {
+ fprintf(stderr, "\npurifyloop: Broken heart in scan.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ if (Scan != scan_buffer_top)
+ goto end_purifyloop;
+ /* The -1 is here because of the Scan++ in the for header. */
+ Scan = dump_and_reload_scan_buffer(0) - 1;
+ continue;
+
+ case TC_MANIFEST_NM_VECTOR:
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ /* Check whether this bumps over current buffer,
+ and if so we need a new bufferfull. */
+ Scan += Get_Integer(Temp);
+ if (Scan < scan_buffer_top)
+ break;
+ else
+ {
+ unsigned long overflow;
+
+ /* The + & -1 are here because of the Scan++ in the for header. */
+ overflow = (Scan - scan_buffer_top) + 1;
+ Scan = ((dump_and_reload_scan_buffer(overflow / GC_DISK_BUFFER_SIZE) +
+ (overflow % GC_DISK_BUFFER_SIZE)) - 1);
+ break;
+ }
+\f
+ case_Non_Pointer:
+ break;
+
+ case_compiled_entry_point:
+ Old = Get_Pointer(Temp);
+ if (Old >= Low_Constant)
+ continue;
+ Compiled_BH(true, continue);
+ {
+ Pointer *Saved_Old = Old;
+
+ New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
+ copy_vector();
+ *Saved_Old = New_Address;
+ *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), Saved_Old);
+ continue;
+ }
+
+ case_Cell:
+ relocate_normal_pointer(copy_cell(), 1);
+
+ case TC_REFERENCE_TRAP:
+ if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ {
+ /* It is a non pointer. */
+ break;
+ }
+ goto purify_pair;
+
+ case TC_INTERNED_SYMBOL:
+ case TC_UNINTERNED_SYMBOL:
+ if (purify_mode == PURE_COPY)
+ {
+ Temp = Vector_Ref(Temp, SYMBOL_NAME);
+ relocate_indirect_setup();
+ copy_vector();
+ relocate_indirect_end();
+ }
+ /* Fall through. */
+
+ case_Fasdump_Pair:
+ purify_pair:
+ relocate_normal_pointer(copy_pair(), 2);
+
+ case TC_VARIABLE:
+ case_Triple:
+ relocate_normal_pointer(copy_triple(), 3);
+
+ case_Quadruple:
+ relocate_normal_pointer(copy_quadruple(), 4);
+\f
+ case TC_ENVIRONMENT:
+ if (purify_mode == PURE_COPY)
+ 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:
+ copy_vector();
+ relocate_normal_end();
+
+ case TC_FUTURE:
+ relocate_normal_setup();
+ if (!(Future_Spliceable(Temp)))
+ goto Move_Vector;
+ *Scan = Future_Value(Temp);
+ Scan -= 1;
+ continue;
+
+ case TC_WEAK_CONS:
+ relocate_normal_pointer(copy_weak_pair(), 2);
+
+ default:
+ fprintf(stderr,
+ "\npurifyloop: Bad type code = 0x%02x\n",
+ Type_Code(Temp));
+ Invalid_Type_Code();
+ }
+ }
+end_purifyloop:
+ *To_ptr = To;
+ *To_Address_ptr = To_Address;
+ return Scan;
+}
+\f
+Pointer
+purify(object, flag)
+ Pointer object, flag;
+{
+ long length, pure_length;
+ Pointer value, *Result, *free_buffer, *block_start;
+
+ free_buffer = initialize_free_buffer();
+ block_start = Free_Constant;
+ *free_buffer++ = NIL; /* Pure block header. */
+ *free_buffer++ = object;
+ Free_Constant += 2;
+ if (flag == TRUTH)
+ {
+ Result = purifyloop(initialize_scan_buffer(),
+ &free_buffer, &Free_Constant,
+ PURE_COPY);
+ if (Result != free_buffer)
+ {
+ fprintf(stderr, "\nPurify: Pure copy ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ pure_length = (Free_Constant - block_start) + 1;
+ }
+ else
+ {
+ pure_length = 3;
+ }
+ *free_buffer++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *free_buffer++ = Make_Non_Pointer(CONSTANT_PART, pure_length);
+ Free_Constant += 2;
+ if (flag == TRUTH)
+ {
+ Result = purifyloop(initialize_scan_buffer(),
+ &free_buffer, &Free_Constant,
+ CONSTANT_COPY);
+ }
+ else
+ {
+ Result = GCLoop(initialize_scan_buffer(), &free_buffer, &Free_Constant);
+ }
+ if (Result != free_buffer)
+ {
+ fprintf(stderr, "\nPurify: Constant Copy ended too early.\n");
+ Microcode_Termination(TERM_BROKEN_HEART);
+ }
+ Free_Constant += 2;
+ length = (Free_Constant - block_start);
+ *free_buffer++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+ *free_buffer++ = Make_Non_Pointer(END_OF_BLOCK, (length - 1));
+ if (!Test_Pure_Space_Top(Free_Constant))
+ {
+ fprintf(stderr, "\nPurify: Object too large.\n");
+ Microcode_Termination(TERM_NO_SPACE);
+ }
+ end_transport();
+ load_buffer(0, block_start,
+ (length * sizeof(Pointer)),
+ "into constant space");
+ *block_start++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR,
+ pure_length);
+ *block_start = Make_Non_Pointer(PURE_PART, (length - 1));
+ GC();
+ return TRUTH;
+}
+\f
+/* (PRIMITIVE-PURIFY OBJECT PURE?)
+
+ Copy an object from the heap into constant space. It should only
+ be used through the wrapper provided in the Scheme runtime system.
+
+ To purify an object we just copy it into Pure Space in two
+ parts with the appropriate headers and footers. The actual
+ copying is done by PurifyLoop above.
+
+ Once the copy is complete we run a full GC which handles the
+ broken hearts which now point into pure space.
+
+ This primitive does not return normally. It always escapes into
+ the interpreter because some of its cached registers (eg. History)
+ have changed.
+*/
Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4)
{
+ Pointer object, purify_result, daemon;
Primitive_2_Args();
- return TRUTH;
+ if ((Arg2 != TRUTH) && (Arg2 != NIL))
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ Touch_In_Primitive(Arg1, object);
+ purify_result = purify(object, Arg2);
+ Pop_Primitive_Frame(2);
+ daemon = Get_Fixed_Obj_Slot(GC_Daemon);
+ if (daemon == NIL)
+ {
+ Val = purify_result;
+ PRIMITIVE_ABORT(PRIM_POP_RETURN);
+ /*NOTREACHED*/
+ }
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
+ Store_Expression(purify_result);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Push(daemon);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ PRIMITIVE_ABORT(PRIM_APPLY);
+ /*NOTREACHED*/
}
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/dump.c,v 9.22 1987/04/03 00:11:11 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.23 1987/06/02 00:17:13 jinx Exp $
*
* This file contains common code for dumping internal format binary files.
*/
\f
#include "fasl.h"
-Write_File(Heap_Count, Heap_Relocation, Dumped_Object,
- Constant_Count, Constant_Relocation, Prim_Exts)
-Pointer *Heap_Relocation, *Dumped_Object,
- *Constant_Relocation, *Prim_Exts;
-long Heap_Count, Constant_Count;
-{ Pointer Buffer[FASL_HEADER_LENGTH];
+void
+prepare_dump_header(Buffer, Heap_Count, Heap_Relocation, Dumped_Object,
+ Constant_Count, Constant_Relocation, Prim_Exts)
+ Pointer *Buffer, *Heap_Relocation, *Dumped_Object,
+ *Constant_Relocation, *Prim_Exts;
+ long Heap_Count, Constant_Count;
+{
long i;
#ifdef DEBUG
#endif
Buffer[FASL_Offset_Ext_Loc] =
Make_Pointer(TC_BROKEN_HEART, Prim_Exts);
- for (i=FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
+ for (i = FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
Buffer[i] = NIL;
- Write_Data(FASL_HEADER_LENGTH, (char *) Buffer);
- if (Heap_Count != 0) Write_Data(Heap_Count, (char *) Heap_Relocation);
+ return;
+}
+
+Write_File(Heap_Count, Heap_Relocation, Dumped_Object,
+ Constant_Count, Constant_Relocation, Prim_Exts)
+ Pointer *Heap_Relocation, *Dumped_Object,
+ *Constant_Relocation, *Prim_Exts;
+ long Heap_Count, Constant_Count;
+{
+ Pointer Buffer[FASL_HEADER_LENGTH];
+
+ prepare_dump_header(Buffer,Heap_Count, Heap_Relocation, Dumped_Object,
+ Constant_Count, Constant_Relocation, Prim_Exts);
+ Write_Data(FASL_HEADER_LENGTH, ((char *) Buffer));
+ if (Heap_Count != 0)
+ Write_Data(Heap_Count, ((char *) Heap_Relocation));
if (Constant_Count != 0)
- Write_Data(Constant_Count, (char *) Constant_Relocation);
+ Write_Data(Constant_Count, ((char *) Constant_Relocation));
}
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/fasdump.c,v 9.26 1987/05/29 02:22:19 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.27 1987/06/02 00:17:22 jinx Exp $
This file contains code for fasdump and dump-band.
*/
heap.
FASDUMP is called with three arguments:
- Argument 1: Base of spare heap
- Argument 2: Top of spare heap
- Argument 3: Hunk 3, #<Object to dump | File name | Flag>
+ Argument 1: Object to dump.
+ Argument 2: File name.
+ Argument 3: Flag.
where the flag is #!true for a dump into constant
space at reload time, () for a dump into heap.
- As with Purify, dumping an object for reloading into constant space
- requires dividing it into pure and constant parts and building a
- standard Pure/Constant block.
+ Currently flag is ignored.
*/
\f
/*
{ if (!DumpLoop(New_Object, PURE_COPY))
{
Fasdump_Exit();
- return NIL;
+ PRIMITIVE_RETURN(NIL);
}
/* Can't align.
Align_Float(NewFree);
if (!DumpLoop(New_Object, CONSTANT_COPY))
{
Fasdump_Exit();
- return NIL;
+ PRIMITIVE_RETURN(NIL);
}
Length = NewFree-New_Object+2;
*NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
{ if (!DumpLoop(New_Object, NORMAL_GC))
{
Fasdump_Exit();
- return NIL;
+ PRIMITIVE_RETURN(NIL);
}
/* Aligning might screw up some of the counters.
Align_Float(NewFree);
0, Constant_Space, New_Object+1);
}
Fasdump_Exit();
- return TRUTH;
+ PRIMITIVE_RETURN(TRUTH);
}
\f
/* (DUMP-BAND PROCEDURE FILE-NAME)
((long) (Free_Constant-Constant_Space)),
Constant_Space, Free-1);
fclose(File_Handle);
- return TRUTH;
+ PRIMITIVE_RETURN(TRUTH);
}
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/purify.c,v 9.26 1987/04/16 02:27:53 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.27 1987/06/02 00:17:36 jinx Exp $
*
* This file contains the code that copies objects into pure
* and constant space.
Real_Transport_Vector(); \
*Get_Pointer(Temp) = New_Address
\f
-Pointer *PurifyLoop(Scan, To_Pointer, GC_Mode)
-fast Pointer *Scan;
-Pointer **To_Pointer;
-int GC_Mode;
-{ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
+Pointer *
+PurifyLoop(Scan, To_Pointer, GC_Mode)
+ fast Pointer *Scan;
+ Pointer **To_Pointer;
+ int GC_Mode;
+{
+ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
To = *To_Pointer;
Low_Constant = Constant_Space;
for ( ; Scan != To; Scan++)
- { Temp = *Scan;
+ {
+ Temp = *Scan;
Switch_by_GC_Type(Temp)
- { case TC_BROKEN_HEART:
+ {
+ case TC_BROKEN_HEART:
if (Scan == (Get_Pointer(Temp)))
- { *To_Pointer = To;
+ {
+ *To_Pointer = To;
return Scan;
}
fprintf(stderr, "Purify: Broken heart in scan.\n");
break;
case_compiled_entry_point:
- if (GC_Mode == PURE_COPY) break;
+ if (GC_Mode == PURE_COPY)
+ break;
Purify_Pointer(Setup_Internal(false,
Transport_Compiled(),
Compiled_BH(false, continue)));
case TC_INTERNED_SYMBOL:
case TC_UNINTERNED_SYMBOL:
if (GC_Mode == PURE_COPY)
- { Temp = Vector_Ref(Temp, SYMBOL_NAME);
+ {
+ Temp = Vector_Ref(Temp, SYMBOL_NAME);
Purify_Pointer(Setup_Internal(false,
Transport_Vector_Indirect(),
Indirect_BH(false)));
\f
Pointer Purify_Pass_2(Info)
Pointer Info;
-{ long Length = Get_Integer(Fast_Vector_Ref(Info, Purify_Length));
+{
+ long Length;
Boolean Purify_Object;
Pointer *New_Object, Relocated_Object, *Result, Answer;
long Pure_Length, Recomputed_Length;
+ Length = Get_Integer(Fast_Vector_Ref(Info, Purify_Length));
if (Fast_Vector_Ref(Info, Purify_Really_Pure) == NIL)
Purify_Object = false;
- else Purify_Object = true;
+ else
+ Purify_Object = true;
Relocated_Object = *Heap_Bottom;
if (!Test_Pure_Space_Top(Free_Constant+Length+6))
return NIL;
*Free_Constant++ = NIL; /* Will hold pure space header */
*Free_Constant++ = Relocated_Object;
if (Purify_Object)
- { Result = PurifyLoop(New_Object+1, &Free_Constant, PURE_COPY);
+ {
+ Result = PurifyLoop(New_Object+1, &Free_Constant, PURE_COPY);
+
if (Free_Constant != Result)
- { fprintf(stderr, "\Purify: Pure Copy ended too early.\n");
+ {
+ fprintf(stderr, "\nPurify: Pure Copy ended too early.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
Pure_Length = (Free_Constant-New_Object) + 1;
}
- else Pure_Length = 3;
+ else
+ Pure_Length = 3;
*Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
*Free_Constant++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
if (Purify_Object)
- { Result = PurifyLoop(New_Object + 1, &Free_Constant, CONSTANT_COPY);
+ {
+ Result = PurifyLoop(New_Object + 1, &Free_Constant, CONSTANT_COPY);
if (Result != Free_Constant)
- { fprintf(stderr, "\Purify: Constant Copy ended too early.\n");
+ {
+ fprintf(stderr, "\nPurify: Pure Copy ended too early.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
}
/* Purify_Pass_2, continued */
else
- { Result = GCLoop(New_Object + 1, &Free_Constant);
+ {
+ Result = GCLoop(New_Object + 1, &Free_Constant);
if (Result != Free_Constant)
- { fprintf(stderr, "\Purify: Constant Copy ended too early.\n");
+ {
+ fprintf(stderr, "\nPurify: Constant Copy ended too early.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
}
*Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
*Free_Constant++ = Make_Non_Pointer(END_OF_BLOCK, Recomputed_Length+5);
if (Length > Recomputed_Length)
- { printf("Purify phase error %x, %x\n", Length, Recomputed_Length);
+ {
+ fprintf(stderr, "\nPurify phase error %x, %x\n",
+ Length, Recomputed_Length);
Microcode_Termination(TERM_EXIT);
}
*New_Object++ =
}
\f
/* (PRIMITIVE-PURIFY OBJECT PURE?)
- Copy an object from the heap into constant space. This requires
- a spare heap, and is tricky to use -- it should only be used
- through the wrapper provided in the Scheme runtime system.
-
- To purify an object we just copy it into Pure Space in two
- parts with the appropriate headers and footers. The actual
- copying is done by PurifyLoop above. If we run out of room
- SCHEME crashes.
-
- Once the copy is complete we run a full GC which handles the
- broken hearts which now point into pure space. On a
- multiprocessor, this primitive uses the master-gc-loop and it
- should only be used as one would use master-gc-loop i.e. with
- everyone else halted.
-
- This primitive does not return normally. It always escapes into
- the interpreter because some of its cached registers (eg. History)
- have changed.
+ Copy an object from the heap into constant space. This requires
+ a spare heap, and is tricky to use -- it should only be used
+ through the wrapper provided in the Scheme runtime system.
+
+ To purify an object we just copy it into Pure Space in two
+ parts with the appropriate headers and footers. The actual
+ copying is done by PurifyLoop above.
+
+ Once the copy is complete we run a full GC which handles the
+ broken hearts which now point into pure space. On a
+ multiprocessor, this primitive uses the master-gc-loop and it
+ should only be used as one would use master-gc-loop i.e. with
+ everyone else halted.
+
+ This primitive does not return normally. It always escapes into
+ the interpreter because some of its cached registers (eg. History)
+ have changed.
*/
Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4)
if (Daemon == NIL)
{
Val = Purify_Pass_2(Purify_Result);
- longjmp( *Back_To_Eval, PRIM_POP_RETURN);
+ PRIMITIVE_ABORT(PRIM_POP_RETURN);
/*NOTREACHED*/
}
Store_Expression(Purify_Result);
Push(Daemon);
Push(STACK_FRAME_HEADER);
Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY); /*NOTREACHED*/
+ PRIMITIVE_ABORT(PRIM_APPLY);
+ /*NOTREACHED*/
}
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/version.h,v 9.60 1987/06/01 16:59:52 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.61 1987/06/02 00:17:51 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 60
+#define SUBVERSION 61
#endif
#ifndef UCODE_TABLES_FILENAME
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.60 1987/06/01 16:59:52 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.61 1987/06/02 00:17:51 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 60
+#define SUBVERSION 61
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff