From: Guillermo J. Rozas Date: Tue, 2 Jun 1987 00:17:51 +0000 (+0000) Subject: Add fasdump and purify to bchscheme. X-Git-Tag: 20090517-FFI~13433 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b4f064e15d7169d3d649d3b1fb6a87b2c1e1ff90;p=mit-scheme.git Add fasdump and purify to bchscheme. --- diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c index b3a11ca9c..01503c052 100644 --- a/v7/src/microcode/bchdmp.c +++ b/v7/src/microcode/bchdmp.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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 @@ -39,28 +39,343 @@ MIT in each case. */ #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; + +/* 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); \ +} + +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; +} + +/* 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; + + 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(); + } + + 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; +} + /* (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; + +#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); } /* (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) { @@ -99,5 +414,5 @@ 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); } diff --git a/v7/src/microcode/bchgcc.h b/v7/src/microcode/bchgcc.h index f916712b4..7d42087a3 100644 --- a/v7/src/microcode/bchgcc.h +++ b/v7/src/microcode/bchgcc.h @@ -30,9 +30,10 @@ Technology nor of any adaptation thereof in any advertising, 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 /* All of these are in objects (Pointer), not bytes. */ @@ -41,6 +42,7 @@ MIT in each case. */ #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" @@ -48,6 +50,120 @@ extern Pointer *scan_buffer_top; 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; + +/* 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; \ +} + +/* 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(); \ +} diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c index a7b0c2226..444855a78 100644 --- a/v7/src/microcode/bchgcl.c +++ b/v7/src/microcode/bchgcl.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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 @@ -40,119 +40,30 @@ MIT in each case. */ #include "scheme.h" #include "bchgcc.h" -/* 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; \ -} - -#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(); \ -} - -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; @@ -165,27 +76,27 @@ Pointer **To_ptr, **To_Address_ptr; 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; } - + 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; @@ -212,7 +123,7 @@ Pointer **To_ptr, **To_Address_ptr; case_Quadruple: relocate_normal_pointer(copy_quadruple(), 4); - + #ifdef FLOATING_ALIGNMENT case TC_BIG_FLONUM: /* This must be fixed. */ @@ -229,7 +140,8 @@ Pointer **To_ptr, **To_Address_ptr; 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; @@ -239,7 +151,7 @@ Pointer **To_ptr, **To_Address_ptr; default: fprintf(stderr, - "GCLoop: Bad type code = 0x%02x\n", + "\nGCLoop: Bad type code = 0x%02x\n", Type_Code(Temp)); Invalid_Type_Code(); } diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index 6419aa02a..9cc362651 100644 --- a/v7/src/microcode/bchmmg.c +++ b/v7/src/microcode/bchmmg.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -60,7 +60,6 @@ MIT in each case. */ #include "scheme.h" #include "primitive.h" #include "bchgcc.h" -#include /* Exports */ @@ -97,14 +96,14 @@ extern void Clear_Memory(), Setup_Memory(), Reset_Memory(); 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; /* 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; @@ -115,7 +114,7 @@ open_gc_file() 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) && @@ -303,7 +302,6 @@ reload_scan_buffer() { 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) ? @@ -316,31 +314,37 @@ reload_scan_buffer() return; } -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; +} + Pointer * dump_and_reload_scan_buffer(number_to_skip) long number_to_skip; @@ -537,18 +541,18 @@ Fix_Weak_Chain() 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); @@ -567,8 +571,9 @@ GC() Free += (free_buffer - free_buffer_bottom); if (free_buffer >= free_buffer_top) free_buffer = dump_and_reset_free_buffer(free_buffer - free_buffer_top); - + /* The 4 step GC */ + Result = GCLoop(Constant_Space, &free_buffer, &Free); if (Result != end_of_constant_area) { @@ -576,19 +581,21 @@ GC() 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*/ } + 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) { @@ -596,8 +603,9 @@ GC() 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)), diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c index 8c86fd7b9..a1247e364 100644 --- a/v7/src/microcode/bchpur.c +++ b/v7/src/microcode/bchpur.c @@ -30,12 +30,15 @@ Technology nor of any adaptation thereof in any advertising, 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. * */ @@ -43,7 +46,7 @@ MIT in each case. */ #include "primitive.h" #include "bchgcc.h" -/* Stub. Terminates Scheme if invoked. */ +/* Stub. Not needed by this version. Terminates Scheme if invoked. */ Pointer Purify_Pass_2(info) @@ -54,11 +57,275 @@ Pointer 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; \ +} + +/* 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; + } + + 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); + + 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; +} + +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; +} + +/* (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*/ } diff --git a/v7/src/microcode/dump.c b/v7/src/microcode/dump.c index 569de1df9..9c12b1430 100644 --- a/v7/src/microcode/dump.c +++ b/v7/src/microcode/dump.c @@ -30,19 +30,20 @@ Technology nor of any adaptation thereof in any advertising, 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. */ #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 @@ -76,10 +77,24 @@ long Heap_Count, Constant_Count; #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)); } diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index 5f778b5c6..e8dc97a5c 100644 --- a/v7/src/microcode/fasdump.c +++ b/v7/src/microcode/fasdump.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. */ @@ -61,15 +61,13 @@ Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free; heap. FASDUMP is called with three arguments: - Argument 1: Base of spare heap - Argument 2: Top of spare heap - Argument 3: Hunk 3, # + 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. */ /* @@ -251,7 +249,7 @@ Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56) { if (!DumpLoop(New_Object, PURE_COPY)) { Fasdump_Exit(); - return NIL; + PRIMITIVE_RETURN(NIL); } /* Can't align. Align_Float(NewFree); @@ -262,7 +260,7 @@ Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56) 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); @@ -280,7 +278,7 @@ Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56) { if (!DumpLoop(New_Object, NORMAL_GC)) { Fasdump_Exit(); - return NIL; + PRIMITIVE_RETURN(NIL); } /* Aligning might screw up some of the counters. Align_Float(NewFree); @@ -290,7 +288,7 @@ Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56) 0, Constant_Space, New_Object+1); } Fasdump_Exit(); - return TRUTH; + PRIMITIVE_RETURN(TRUTH); } /* (DUMP-BAND PROCEDURE FILE-NAME) @@ -335,5 +333,5 @@ 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); } diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c index 2cfb7bdbe..41a89c401 100644 --- a/v7/src/microcode/purify.c +++ b/v7/src/microcode/purify.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -68,20 +68,25 @@ if (Type_Code(*Old) == TC_BROKEN_HEART) continue; Real_Transport_Vector(); \ *Get_Pointer(Temp) = 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; +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"); @@ -96,7 +101,8 @@ int GC_Mode; 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))); @@ -125,7 +131,8 @@ int GC_Mode; 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))); @@ -283,14 +290,17 @@ Pointer Object, Purify_Object; 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; @@ -299,20 +309,26 @@ Pointer Info; *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); } } @@ -322,9 +338,11 @@ Pointer Info; /* 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); } } @@ -332,7 +350,9 @@ Pointer Info; *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++ = @@ -344,24 +364,23 @@ Pointer Info; } /* (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) @@ -385,7 +404,7 @@ 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); @@ -395,5 +414,6 @@ Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4) Push(Daemon); Push(STACK_FRAME_HEADER); Pushed(); - longjmp(*Back_To_Eval, PRIM_APPLY); /*NOTREACHED*/ + PRIMITIVE_ABORT(PRIM_APPLY); + /*NOTREACHED*/ } diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 01f65ff1a..81c7761ad 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 9 #endif #ifndef SUBVERSION -#define SUBVERSION 60 +#define SUBVERSION 61 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index d56a94a66..1338bb80d 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 9 #endif #ifndef SUBVERSION -#define SUBVERSION 60 +#define SUBVERSION 61 #endif #ifndef UCODE_TABLES_FILENAME