From 661709e6a55e3d6e4bf9f55a9dc1d50857615e10 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Mon, 21 Mar 1988 21:10:17 +0000 Subject: [PATCH] Fix bchscheme to handle new representation of compiled procedures. Add coerce-to-compiled-procedure primitive for inner loops. Clean up some gc macros. --- v7/src/microcode/bchdmp.c | 224 ++++++++++++++++++++++++++++++++------ v7/src/microcode/bchgcc.h | 106 ++++++++++++++++-- v7/src/microcode/bchgcl.c | 151 +++++++++++++++++++++---- v7/src/microcode/bchmmg.c | 212 ++++++++++++++++++++++++++++++------ v7/src/microcode/bchpur.c | 185 ++++++++++++++++++++++++++----- 5 files changed, 751 insertions(+), 127 deletions(-) diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c index 286ad1968..4ccfcff91 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.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 @@ -46,6 +46,11 @@ MIT in each case. */ #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(), @@ -63,12 +68,22 @@ static Boolean compiled_code_present_p; /* 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)); \ @@ -97,7 +112,7 @@ static Boolean compiled_code_present_p; #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; \ } @@ -107,15 +122,67 @@ static Boolean compiled_code_present_p; fasdump_normal_transport(copy_code, length); \ fasdump_normal_end(); \ } + +#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(); \ } Boolean @@ -274,26 +341,128 @@ dumploop(Scan, To_ptr, To_Address_ptr) case TC_STACK_ENVIRONMENT: case_Fasload_Non_Pointer: break; - + 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; + } + + 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; } + } + + 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; + } case_Cell: fasdump_normal_pointer(copy_cell(), 1); @@ -344,14 +513,7 @@ dumploop(Scan, To_ptr, To_Address_ptr) 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(); @@ -520,7 +682,7 @@ DEFINE_PRIMITIVE("DUMP-BAND", Prim_Band_Dump, 2) 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)) diff --git a/v7/src/microcode/bchgcc.h b/v7/src/microcode/bchgcc.h index 3b0e305ce..b0010ce6f 100644 --- a/v7/src/microcode/bchgcc.h +++ b/v7/src/microcode/bchgcc.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/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 @@ -38,24 +38,29 @@ MIT in each case. */ #else #include #endif - + /* 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(); @@ -81,7 +86,7 @@ extern char gc_death_message_buffer[]; { \ long Car_Type; \ \ - Car_Type = Type_Code(*Old); \ + Car_Type = OBJECT_TYPE(*Old); \ *To++ = Make_New_Pointer(TC_NULL, *Old); \ Old += 1; \ *To++ = *Old; \ @@ -136,7 +141,9 @@ extern char gc_death_message_buffer[]; Scan = To + (overflow % GC_DISK_BUFFER_SIZE); \ } \ while (To != Scan) \ + { \ *To++ = *Old++; \ + } \ Scan = Saved_Scan; \ } @@ -147,9 +154,9 @@ extern char gc_death_message_buffer[]; 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)); \ @@ -160,13 +167,15 @@ extern char gc_death_message_buffer[]; 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; \ } @@ -176,3 +185,76 @@ extern char gc_death_message_buffer[]; relocate_normal_transport(copy_code, length); \ relocate_normal_end(); \ } + +/* 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(); \ +} + +#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) diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c index f9964766a..6fa063d3c 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.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 @@ -39,6 +39,11 @@ MIT in each case. */ #include "scheme.h" #include "bchgcc.h" + +#ifdef FLOATING_ALIGNMENT +/* This must be fixed. */ +#include "error: bchgcl does not handle floating alignment." +#endif Pointer * GCLoop(Scan, To_ptr, To_Address_ptr) @@ -88,30 +93,137 @@ GCLoop(Scan, To_ptr, To_Address_ptr) (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); + 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; } + + 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; + } + } + + 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; + } + 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; @@ -126,15 +238,8 @@ GCLoop(Scan, To_ptr, To_Address_ptr) case_Quadruple: relocate_normal_pointer(copy_quadruple(), 4); - -#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: @@ -144,7 +249,9 @@ GCLoop(Scan, To_ptr, To_Address_ptr) case TC_FUTURE: relocate_normal_setup(); if (!(Future_Spliceable(Temp))) + { goto Move_Vector; + } *Scan = Future_Value(Temp); Scan -= 1; continue; diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index 5bab22f82..454a0b74d 100644 --- a/v7/src/microcode/bchmmg.c +++ b/v7/src/microcode/bchmmg.c @@ -30,14 +30,17 @@ 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.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 $ */ + /* 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 @@ -46,15 +49,14 @@ MIT in each case. */ - 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" @@ -98,6 +100,9 @@ static long scan_position, free_position; 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; /* Hacking the gc file */ @@ -134,7 +139,9 @@ open_gc_file(size) { 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, @@ -168,11 +175,15 @@ void 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; } @@ -333,12 +344,8 @@ reload_scan_buffer() 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; } @@ -347,12 +354,18 @@ Pointer * 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() @@ -360,10 +373,11 @@ 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 @@ -375,6 +389,123 @@ end_transport(success) return; } +/* 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; +} + +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); +} + Pointer * dump_and_reload_scan_buffer(number_to_skip, success) long number_to_skip; @@ -382,9 +513,11 @@ dump_and_reload_scan_buffer(number_to_skip, success) { 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 * @@ -408,17 +541,25 @@ dump_and_reset_free_buffer(overflow, success) 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 @@ -444,7 +585,9 @@ 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; @@ -458,7 +601,9 @@ guarantee_in_memory(addr) long position, offset; if (addr >= Constant_Space) - return addr; + { + return (addr); + } position = (addr - Heap_Bottom); offset = (position % GC_DISK_BUFFER_SIZE); @@ -471,7 +616,7 @@ guarantee_in_memory(addr) GC_BUFFER_BYTES, "the weak pair buffer"); current_buffer_position = position; } - return &gc_disk_buffer_1[offset]; + return (&gc_disk_buffer_1[offset]); } /* For a description of the algorithm, see memmag.c. @@ -494,21 +639,22 @@ Fix_Weak_Chain() 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; @@ -533,9 +679,9 @@ Fix_Weak_Chain() *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; @@ -558,7 +704,7 @@ Fix_Weak_Chain() 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*/ } diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c index b4fd6476e..968bb4e8c 100644 --- a/v7/src/microcode/bchpur.c +++ b/v7/src/microcode/bchpur.c @@ -1,6 +1,6 @@ /* -*-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 @@ -45,16 +45,17 @@ MIT in each case. */ #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 -/* 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. */ @@ -134,20 +135,143 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) 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; } + + 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; + } + } + + 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; + } + case_Cell: relocate_normal_pointer(copy_cell(), 1); @@ -190,14 +314,7 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) 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: @@ -295,7 +412,7 @@ purify(object, flag) { free_buffer = purify_header_overflow(free_buffer); } - + if (flag == TRUTH) { Result = purifyloop(initialize_scan_buffer(), @@ -338,7 +455,17 @@ purify(object, flag) *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*/ } /* (PRIMITIVE-PURIFY OBJECT PURE?) -- 2.25.1