From: Guillermo J. Rozas Date: Sun, 24 Feb 1991 01:11:22 +0000 (+0000) Subject: Put a little patch in uxtrap.c and the memory management to detect X-Git-Tag: 20090517-FFI~10908 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5cfc18ad0ee8dd6b7a67e5a68ad82baf0c5fed51;p=mit-scheme.git Put a little patch in uxtrap.c and the memory management to detect cases when the stack has overflowed and constant space has been overwritten. Ansify various memory management files. --- diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index 0e937ae63..a8b6ccdb2 100644 --- a/v7/src/microcode/bchmmg.c +++ b/v7/src/microcode/bchmmg.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.56 1990/11/13 08:44:07 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.57 1991/02/24 01:10:08 jinx Exp $ -Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1987-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -114,13 +114,12 @@ static CONST char * gc_file_name; static char gc_default_file_name[FILE_NAME_LENGTH] = GC_DEFAULT_FILE_NAME; void -open_gc_file(size) - int size; +DEFUN (open_gc_file, (size), int size) { int position; int flags; - (void) mktemp(gc_default_file_name); + (void) (mktemp (gc_default_file_name)); flags = GC_FILE_FLAGS; gc_file_name = option_gc_file; if (gc_file_name == 0) @@ -130,40 +129,40 @@ open_gc_file(size) } while (1) { - gc_file = open(gc_file_name, flags, GC_FILE_MASK); + 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, - "%s: GC file \"%s\" cannot be opened; ", - scheme_program_name, gc_file_name); + fprintf (stderr, + "%s: GC file \"%s\" cannot be opened; ", + scheme_program_name, gc_file_name); gc_file_name = gc_default_file_name; - fprintf(stderr, - "Using \"%s\" instead.\n", - gc_file_name); + fprintf (stderr, + "Using \"%s\" instead.\n", + gc_file_name); flags |= O_EXCL; continue; } - fprintf(stderr, - "%s: GC file \"%s\" cannot be opened; Aborting.\n", - scheme_program_name, gc_file_name); - exit(1); + fprintf (stderr, + "%s: GC file \"%s\" cannot be opened; Aborting.\n", + scheme_program_name, gc_file_name); + exit (1); } #ifdef _HPUX if (gc_file_name == gc_default_file_name) { - extern prealloc(); - prealloc(gc_file, size); + extern prealloc (); + prealloc (gc_file, size); /* Prealloc may change (it does under 6.5) the file pointer! */ - if ((lseek(gc_file, 0, 0)) == -1) + if ((lseek (gc_file, 0, 0)) == -1) { - fprintf(stderr, - "%s: cannot position at start of GC file \"%s\"; Aborting.\n", - scheme_program_name, gc_file_name); - exit(1); + fprintf (stderr, + "%s: cannot position at start of GC file \"%s\"; Aborting.\n", + scheme_program_name, gc_file_name); + exit (1); } } #endif @@ -172,59 +171,61 @@ open_gc_file(size) } void -close_gc_file() +DEFUN_VOID (close_gc_file) { - if (close(gc_file) == -1) + if ((close (gc_file)) == -1) { - fprintf(stderr, - "%s: Problems closing GC file \"%s\".\n", - scheme_program_name, gc_file_name); + fprintf (stderr, + "%s: Problems closing GC file \"%s\".\n", + scheme_program_name, gc_file_name); } if (gc_file_name == gc_default_file_name) { - unlink(gc_file_name); + unlink (gc_file_name); } return; } void -Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) - int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; +DEFUN (Clear_Memory, + (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size), + int Our_Heap_Size, int Our_Stack_Size, int Our_Constant_Size) { GC_Reserve = 4500; GC_Space_Needed = 0; Heap_Top = (Heap_Bottom + Our_Heap_Size); - SET_MEMTOP(Heap_Top - GC_Reserve); + SET_MEMTOP (Heap_Top - GC_Reserve); Free = Heap_Bottom; Constant_Top = (Constant_Space + Our_Constant_Size); Free_Constant = Constant_Space; - Set_Pure_Top (); + SET_CONSTANT_TOP (); Initialize_Stack (); return; } void -Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) - int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; +DEFUN (Setup_Memory, + (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size), + int Our_Heap_Size, int Our_Stack_Size, int Our_Constant_Size) { SCHEME_OBJECT test_value; int Real_Stack_Size; - Real_Stack_Size = Stack_Allocation_Size(Our_Stack_Size); + Real_Stack_Size = (Stack_Allocation_Size (Our_Stack_Size)); /* Consistency check 1 */ if (Our_Heap_Size == 0) { - fprintf(stderr, "Configuration won't hold initial data.\n"); - exit(1); + fprintf (stderr, "Configuration won't hold initial data.\n"); + exit (1); } /* Allocate. The two GC buffers are not included in the valid Scheme memory. */ - ALLOCATE_HEAP_SPACE(Real_Stack_Size + Our_Heap_Size + - Our_Constant_Size + (2 * GC_BUFFER_SPACE) + - (HEAP_BUFFER_SPACE + 1)); + ALLOCATE_HEAP_SPACE (Real_Stack_Size + Our_Heap_Size + + Our_Constant_Size + (2 * GC_BUFFER_SPACE) + + (HEAP_BUFFER_SPACE + 1)); /* Consistency check 2 */ if (Heap == NULL) @@ -234,9 +235,9 @@ Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) } Heap += HEAP_BUFFER_SPACE; - INITIAL_ALIGN_FLOAT(Heap); + INITIAL_ALIGN_FLOAT (Heap); - Constant_Space = Heap + Our_Heap_Size; + Constant_Space = (Heap + Our_Heap_Size); ALIGN_FLOAT (Constant_Space); /* Trim the system buffer space. */ @@ -254,57 +255,60 @@ Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) || ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address)) { - fprintf(stderr, - "Largest address does not fit in datum field of object.\n"); - fprintf(stderr, - "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n"); - exit(1); + fprintf (stderr, + "Largest address does not fit in datum field of object.\n"); + fprintf (stderr, + "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n"); + exit (1); } Heap_Bottom = Heap; - Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size); + Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size); - open_gc_file(Our_Heap_Size * sizeof(SCHEME_OBJECT)); + open_gc_file (Our_Heap_Size * sizeof(SCHEME_OBJECT)); return; } void -Reset_Memory() +DEFUN_VOID (Reset_Memory) { - close_gc_file(); + close_gc_file (); return; } void -dump_buffer(from, position, nbuffers, name, success) - SCHEME_OBJECT *from; - long *position, nbuffers; - char *name; - Boolean *success; +DEFUN (dump_buffer, + (from, position, nbuffers, name, success), + SCHEME_OBJECT *from AND + long *position AND + long nbuffers AND + char *name AND + Boolean *success) { long bytes_written; if ((current_disk_position != *position) && - (lseek(gc_file, *position, 0) == -1)) + ((lseek (gc_file, *position, 0)) == -1)) { if (success == NULL) { - fprintf(stderr, - "\nCould not position GC file to write the %s buffer.\n", - name); - Microcode_Termination(TERM_EXIT); + fprintf (stderr, + "\nCould not position GC file to write the %s buffer.\n", + name); + Microcode_Termination (TERM_EXIT); /*NOTREACHED*/ } *success = false; return; } - if ((bytes_written = write(gc_file, from, (nbuffers * GC_BUFFER_BYTES))) == - -1) + if ((bytes_written = + (write (gc_file, from, (nbuffers * GC_BUFFER_BYTES)))) + == -1) { if (success == NULL) { - fprintf(stderr, "\nCould not write out the %s buffer.\n", name); - Microcode_Termination(TERM_EXIT); + fprintf (stderr, "\nCould not write out the %s buffer.\n", name); + Microcode_Termination (TERM_EXIT); /*NOTREACHED*/ } *success = false; @@ -317,28 +321,29 @@ dump_buffer(from, position, nbuffers, name, success) } void -load_buffer(position, to, nbytes, name) - long position; - SCHEME_OBJECT *to; - long nbytes; - char *name; +DEFUN (load_buffer, + (position, to, nbytes, name), + long position AND + SCHEME_OBJECT *to AND + long nbytes AND + char *name) { long bytes_read; if (current_disk_position != position) { - if (lseek(gc_file, position, 0) == -1) + if ((lseek (gc_file, position, 0)) == -1) { - fprintf(stderr, "\nCould not position GC file to read %s.\n", name); - Microcode_Termination(TERM_EXIT); + fprintf (stderr, "\nCould not position GC file to read %s.\n", name); + Microcode_Termination (TERM_EXIT); /*NOTREACHED*/ } current_disk_position = position; } - if ((bytes_read = read(gc_file, to, nbytes)) != nbytes) + if ((bytes_read = (read (gc_file, to, nbytes))) != nbytes) { - fprintf(stderr, "\nCould not read into %s.\n", name); - Microcode_Termination(TERM_EXIT); + fprintf (stderr, "\nCould not read into %s.\n", name); + Microcode_Termination (TERM_EXIT); /*NOTREACHED*/ } current_disk_position += bytes_read; @@ -346,7 +351,7 @@ load_buffer(position, to, nbytes, name) } void -reload_scan_buffer() +DEFUN_VOID (reload_scan_buffer) { if (scan_position == free_position) { @@ -354,21 +359,21 @@ reload_scan_buffer() scan_buffer_top = free_buffer_top; return; } - load_buffer(scan_position, scan_buffer_bottom, - GC_BUFFER_BYTES, "the scan buffer"); - *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top); + load_buffer (scan_position, scan_buffer_bottom, + GC_BUFFER_BYTES, "the scan buffer"); + *scan_buffer_top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top)); return; } SCHEME_OBJECT * -initialize_scan_buffer() +DEFUN_VOID (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(); + scan_buffer_top = (scan_buffer_bottom + GC_DISK_BUFFER_SIZE); + reload_scan_buffer (); return (scan_buffer_bottom); } @@ -378,25 +383,26 @@ initialize_scan_buffer() always pointing to a valid buffer. */ SCHEME_OBJECT * -initialize_free_buffer() +DEFUN_VOID (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_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; + scan_buffer_top = (scan_buffer_bottom + GC_DISK_BUFFER_SIZE); /* Force first write to do an lseek. */ current_disk_position = -1; return (free_buffer_bottom); } void -end_transport(success) - Boolean *success; +DEFUN (end_transport, + (success), + Boolean *success) { - dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan", success); + dump_buffer (scan_buffer_bottom, &scan_position, 1, "scan", success); free_position = scan_position; return; } @@ -410,9 +416,10 @@ end_transport(success) */ void -extend_scan_buffer(to_where, current_free) - fast char *to_where; - SCHEME_OBJECT *current_free; +DEFUN (extend_scan_buffer, + (to_where, current_free), + fast char *to_where AND + SCHEME_OBJECT *current_free) { long new_scan_position; @@ -445,20 +452,21 @@ extend_scan_buffer(to_where, current_free) else { extension_overlap_p = false; - load_buffer(new_scan_position, scan_buffer_top, - GC_BUFFER_OVERLAP_BYTES, "the scan buffer"); + 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; +DEFUN (end_scan_buffer_extension, + (to_relocate), + char *to_relocate) { char *result; - dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan", - ((Boolean *) NULL)); + dump_buffer (scan_buffer_bottom, &scan_position, 1, "scan", + ((Boolean *) NULL)); if (!extension_overlap_p) { /* There was no overlap */ @@ -475,11 +483,12 @@ end_scan_buffer_extension(to_relocate) { *dest++ = *source++; } - load_buffer((scan_position + GC_BUFFER_OVERLAP_BYTES), - dest, - GC_BUFFER_REMAINDER_BYTES, - "the scan buffer"); - *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top); + load_buffer ((scan_position + GC_BUFFER_OVERLAP_BYTES), + dest, + GC_BUFFER_REMAINDER_BYTES, + "the scan buffer"); + *scan_buffer_top = + (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top)); } else { @@ -507,11 +516,12 @@ end_scan_buffer_extension(to_relocate) { /* 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_OBJECT (TC_BROKEN_HEART, scan_buffer_top); + load_buffer ((scan_position + extension_overlap_length), + dest, + (GC_BUFFER_BYTES - extension_overlap_length), + "the scan buffer"); + *scan_buffer_top = + (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top)); } } extension_overlap_p = false; @@ -519,23 +529,25 @@ end_scan_buffer_extension(to_relocate) } SCHEME_OBJECT * -dump_and_reload_scan_buffer(number_to_skip, success) - long number_to_skip; - Boolean *success; +DEFUN (dump_and_reload_scan_buffer, + (number_to_skip, success), + long number_to_skip AND + Boolean *success) { - dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan", 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(); + reload_scan_buffer (); return (scan_buffer_bottom); } SCHEME_OBJECT * -dump_and_reset_free_buffer(overflow, success) - fast long overflow; - Boolean *success; +DEFUN (dump_and_reset_free_buffer, + (overflow, success), + fast long overflow AND + Boolean *success) { fast SCHEME_OBJECT *into, *from; @@ -550,17 +562,13 @@ dump_and_reset_free_buffer(overflow, success) free_buffer_bottom = ((scan_buffer_bottom == gc_disk_buffer_1) ? gc_disk_buffer_2 : gc_disk_buffer_1); - free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE; + 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 need only be done when free_buffer_bottom was scan_buffer_bottom, but it does not hurt otherwise unless we were in the @@ -568,47 +576,48 @@ dump_and_reset_free_buffer(overflow, success) It must also be done after the for loop above. */ if (!extension_overlap_p) - { - *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top); - } + *scan_buffer_top = + (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top)); return (into); } void -dump_free_directly(from, nbuffers, success) - SCHEME_OBJECT *from; - long nbuffers; - Boolean *success; +DEFUN (dump_free_directly, + (from, nbuffers, success), + SCHEME_OBJECT *from AND + long nbuffers AND + Boolean *success) { - dump_buffer(from, &free_position, nbuffers, "free", success); + dump_buffer (from, &free_position, nbuffers, "free", success); return; } static long current_buffer_position; void -initialize_new_space_buffer() +DEFUN_VOID (initialize_new_space_buffer) { current_buffer_position = -1; return; } void -flush_new_space_buffer() +DEFUN_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); + dump_buffer (gc_disk_buffer_1, ¤t_buffer_position, + 1, "weak pair buffer", NULL); current_buffer_position = -1; return; } SCHEME_OBJECT * -guarantee_in_memory(addr) - SCHEME_OBJECT *addr; +DEFUN (guarantee_in_memory, + (addr), + SCHEME_OBJECT *addr) { long position, offset; @@ -623,9 +632,9 @@ guarantee_in_memory(addr) position *= GC_BUFFER_BYTES; if (position != current_buffer_position) { - flush_new_space_buffer(); - load_buffer(position, gc_disk_buffer_1, - GC_BUFFER_BYTES, "the weak pair buffer"); + flush_new_space_buffer (); + load_buffer (position, gc_disk_buffer_1, + GC_BUFFER_BYTES, "the weak pair buffer"); current_buffer_position = position; } return (&gc_disk_buffer_1[offset]); @@ -639,7 +648,7 @@ guarantee_in_memory(addr) SCHEME_OBJECT Weak_Chain; void -Fix_Weak_Chain() +DEFUN_VOID (Fix_Weak_Chain) { fast SCHEME_OBJECT *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant; @@ -647,25 +656,25 @@ Fix_Weak_Chain() Low_Constant = Constant_Space; while (Weak_Chain != EMPTY_LIST) { - Old_Weak_Cell = OBJECT_ADDRESS (Weak_Chain); - Scan = guarantee_in_memory(OBJECT_ADDRESS (*Old_Weak_Cell++)); + Old_Weak_Cell = (OBJECT_ADDRESS (Weak_Chain)); + Scan = (guarantee_in_memory (OBJECT_ADDRESS (*Old_Weak_Cell++))); Weak_Chain = *Old_Weak_Cell; Old_Car = *Scan; Temp = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, Old_Car)); Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain)); - switch(GC_Type(Temp)) + switch (GC_Type (Temp)) { case GC_Non_Pointer: *Scan = Temp; continue; case GC_Special: - if (OBJECT_TYPE (Temp) != TC_REFERENCE_TRAP) + if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP) { /* No other special type makes sense here. */ goto fail; } - if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE) + if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE) { *Scan = Temp; continue; @@ -684,13 +693,13 @@ Fix_Weak_Chain() case GC_Quadruple: case GC_Vector: /* Old is still a pointer to old space */ - Old = OBJECT_ADDRESS (Old_Car); + Old = (OBJECT_ADDRESS (Old_Car)); if (Old >= Low_Constant) { *Scan = Temp; continue; } - if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) + if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) { *Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old)); continue; @@ -706,27 +715,27 @@ Fix_Weak_Chain() *Scan = Temp; continue; } - Compiled_BH(false, { *Scan = Temp; continue; }); + Compiled_BH (false, { *Scan = Temp; continue; }); *Scan = SHARP_F; continue; case GC_Undefined: - fprintf(stderr, - "\nFix_Weak_Chain: Clearing bad object 0x%08lx.\n", - Temp); + fprintf (stderr, + "\nFix_Weak_Chain: Clearing bad object 0x%08lx.\n", + Temp); *Scan = SHARP_F; continue; default: /* Non Marked Headers and Broken Hearts */ fail: - fprintf(stderr, - "\nFix_Weak_Chain: Bad Object: 0x%08lx.\n", - Temp); - Microcode_Termination(TERM_INVALID_TYPE_CODE); + fprintf (stderr, + "\nFix_Weak_Chain: Bad Object: 0x%08lx.\n", + Temp); + Microcode_Termination (TERM_INVALID_TYPE_CODE); /*NOTREACHED*/ } } - flush_new_space_buffer(); + flush_new_space_buffer (); return; } @@ -751,60 +760,61 @@ Fix_Weak_Chain() */ void -GC (initial_weak_chain) - SCHEME_OBJECT initial_weak_chain; +DEFUN (GC, + (initial_weak_chain), + SCHEME_OBJECT initial_weak_chain) { SCHEME_OBJECT *Root, *Result, *end_of_constant_area, The_Precious_Objects, *Root2, *free_buffer; - free_buffer = initialize_free_buffer(); + free_buffer = (initialize_free_buffer ()); Free = Heap_Bottom; - SET_MEMTOP(Heap_Top - GC_Reserve); + SET_MEMTOP (Heap_Top - GC_Reserve); Weak_Chain = initial_weak_chain; /* Save the microcode registers so that they can be relocated */ - Terminate_Old_Stacklet(); - Terminate_Constant_Space(end_of_constant_area); + Terminate_Old_Stacklet (); + SEAL_CONSTANT_SPACE (); + end_of_constant_area = (CONSTANT_SPACE_SEAL ()); Root = Free; - The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects); - Set_Fixed_Obj_Slot(Precious_Objects, SHARP_F); - Set_Fixed_Obj_Slot(Lost_Objects_Base, SHARP_F); + The_Precious_Objects = (Get_Fixed_Obj_Slot (Precious_Objects)); + Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F); + Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F); *free_buffer++ = Fixed_Objects; - *free_buffer++ = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History); + *free_buffer++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History)); *free_buffer++ = Undefined_Primitives; *free_buffer++ = Undefined_Primitives_Arity; - *free_buffer++ = Get_Current_Stacklet(); + *free_buffer++ = Get_Current_Stacklet (); *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ? SHARP_F : - MAKE_POINTER_OBJECT (TC_CONTROL_POINT, - Prev_Restore_History_Stacklet)); + (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, + Prev_Restore_History_Stacklet))); *free_buffer++ = Current_State_Point; *free_buffer++ = Fluid_Bindings; Free += (free_buffer - free_buffer_bottom); if (free_buffer >= free_buffer_top) - { - free_buffer = dump_and_reset_free_buffer((free_buffer - free_buffer_top), - NULL); - } + free_buffer = + (dump_and_reset_free_buffer ((free_buffer - free_buffer_top), + NULL)); /* The 4 step GC */ - Result = GCLoop(Constant_Space, &free_buffer, &Free); + Result = (GCLoop (Constant_Space, &free_buffer, &Free)); if (Result != end_of_constant_area) { - fprintf(stderr, "\nGC: Constant Scan ended too early.\n"); - Microcode_Termination(TERM_EXIT); + fprintf (stderr, "\nGC: Constant Scan ended too early.\n"); + Microcode_Termination (TERM_EXIT); /*NOTREACHED*/ } 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); + fprintf (stderr, "\nGC-1: Heap Scan ended too early.\n"); + Microcode_Termination (TERM_EXIT); /*NOTREACHED*/ } @@ -812,25 +822,26 @@ GC (initial_weak_chain) *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), NULL); + free_buffer = + (dump_and_reset_free_buffer ((free_buffer - free_buffer_top), NULL)); - Result = GCLoop(Result, &free_buffer, &Free); + Result = (GCLoop (Result, &free_buffer, &Free)); if (free_buffer != Result) { - fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n"); - Microcode_Termination(TERM_EXIT); + fprintf (stderr, "\nGC-2: Heap Scan ended too early.\n"); + Microcode_Termination (TERM_EXIT); /*NOTREACHED*/ } - end_transport(NULL); + end_transport (NULL); - Fix_Weak_Chain(); + Fix_Weak_Chain (); /* Load new space into memory. */ - load_buffer(0, Heap_Bottom, - ((Free - Heap_Bottom) * sizeof(SCHEME_OBJECT)), - "new space"); + load_buffer (0, Heap_Bottom, + ((Free - Heap_Bottom) * sizeof(SCHEME_OBJECT)), + "new space"); /* Make the microcode registers point to the copies in new-space. */ @@ -839,13 +850,11 @@ GC (initial_weak_chain) Set_Fixed_Obj_Slot (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2)))); - History = OBJECT_ADDRESS (*Root++); + History = (OBJECT_ADDRESS (*Root++)); Undefined_Primitives = *Root++; Undefined_Primitives_Arity = *Root++; - /* Set_Current_Stacklet is sometimes a No-Op! */ - - Set_Current_Stacklet(*Root); + Set_Current_Stacklet (*Root); Root += 1; if (*Root == SHARP_F) { @@ -854,12 +863,13 @@ GC (initial_weak_chain) } else { - Prev_Restore_History_Stacklet = OBJECT_ADDRESS (*Root++); + Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*Root++)); } Current_State_Point = *Root++; Fluid_Bindings = *Root++; Free_Stacklets = NULL; FLUSH_I_CACHE (); + CLEAR_INTERRUPT (INT_GC); return; } @@ -876,35 +886,38 @@ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) SCHEME_OBJECT GC_Daemon_Proc; PRIMITIVE_HEADER (1); PRIMITIVE_CANONICALIZE_CONTEXT (); + + STACK_SANITY_CHECK ("GC"); new_gc_reserve = (arg_nonnegative_integer (1)); if (Free > Heap_Top) termination_gc_out_of_space (); + ENTER_CRITICAL_SECTION ("garbage collector"); gc_counter += 1; GC_Reserve = new_gc_reserve; - GC(EMPTY_LIST); - CLEAR_INTERRUPT(INT_GC); + GC (EMPTY_LIST); POP_PRIMITIVE_FRAME (1); - GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); + GC_Daemon_Proc = (Get_Fixed_Obj_Slot (GC_Daemon)); + RENAME_CRITICAL_SECTION ("garbage collector daemon"); if (GC_Daemon_Proc == SHARP_F) { - Will_Push(CONTINUATION_SIZE); - Store_Return(RC_NORMAL_GC_DONE); - Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free)); - Save_Cont(); - Pushed(); - PRIMITIVE_ABORT(PRIM_POP_RETURN); + Will_Push (CONTINUATION_SIZE); + Store_Return (RC_NORMAL_GC_DONE); + Store_Expression (LONG_TO_UNSIGNED_FIXNUM(MemTop - Free)); + Save_Cont (); + Pushed (); + PRIMITIVE_ABORT (PRIM_POP_RETURN); /*NOTREACHED*/ } - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); - Store_Return(RC_NORMAL_GC_DONE); - Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free)); - Save_Cont(); + Will_Push (CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); + Store_Return (RC_NORMAL_GC_DONE); + Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); + Save_Cont (); STACK_PUSH (GC_Daemon_Proc); STACK_PUSH (STACK_FRAME_HEADER); - Pushed(); - PRIMITIVE_ABORT(PRIM_APPLY); + Pushed (); + PRIMITIVE_ABORT (PRIM_APPLY); /* The following comment is by courtesy of LINT, your friendly sponsor. */ /*NOTREACHED*/ } diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c index bae9e075a..5e6055b71 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.50 1990/06/20 17:38:26 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.51 1991/02/24 01:10:16 jinx Exp $ Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. */ #include "scheme.h" #include "prims.h" #include "bchgcc.h" - + /* Purify modes */ #define NORMAL_GC 0 @@ -75,10 +75,12 @@ MIT in each case. */ /* A modified copy of GCLoop. */ SCHEME_OBJECT * -purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) - fast SCHEME_OBJECT *Scan; - SCHEME_OBJECT **To_ptr, **To_Address_ptr; - int purify_mode; +DEFUN (purifyloop, + (Scan, To_ptr, To_Address_ptr, purify_mode), + fast SCHEME_OBJECT *Scan AND + SCHEME_OBJECT **To_ptr AND + SCHEME_OBJECT **To_Address_ptr AND + int purify_mode) { fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, *To_Address, New_Address; @@ -89,28 +91,30 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) for ( ; Scan != To; Scan++) { Temp = *Scan; - Switch_by_GC_Type(Temp) + Switch_by_GC_Type (Temp) { case TC_BROKEN_HEART: if (Scan != (OBJECT_ADDRESS (Temp))) { - sprintf(gc_death_message_buffer, - "purifyloop: broken heart (0x%lx) in scan", - Temp); - gc_death(TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To); + sprintf (gc_death_message_buffer, + "purifyloop: broken heart (0x%lx) in scan", + Temp); + gc_death (TERM_BROKEN_HEART, + gc_death_message_buffer, + Scan, To); /*NOTREACHED*/ } 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, NULL) - 1; + Scan = ((dump_and_reload_scan_buffer (0, NULL)) - 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 += OBJECT_DATUM (Temp); + Scan += (OBJECT_DATUM (Temp)); if (Scan < scan_buffer_top) { break; @@ -120,8 +124,8 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) 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), NULL) + + overflow = ((Scan - scan_buffer_top) + 1); + Scan = ((dump_and_reload_scan_buffer ((overflow / GC_DISK_BUFFER_SIZE), NULL) + (overflow % GC_DISK_BUFFER_SIZE)) - 1); break; } @@ -129,7 +133,7 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) case_compiled_entry_point: if (purify_mode == PURE_COPY) break; - relocate_compiled_entry(false); + relocate_compiled_entry (false); *Scan = Temp; break; @@ -137,12 +141,12 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) { if (purify_mode == PURE_COPY) { - gc_death(TERM_COMPILER_DEATH, - "purifyloop: linkage section in pure area", - Scan, To); + gc_death (TERM_COMPILER_DEATH, + "purifyloop: linkage section in pure area", + Scan, To); /*NOTREACHED*/ } - if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND) + if ((READ_LINKAGE_KIND (Temp)) != OPERATOR_LINKAGE_KIND) { /* count typeless pointers to quads follow. */ @@ -151,7 +155,7 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) Scan++; max_here = (scan_buffer_top - Scan); - max_count = READ_CACHE_LINKAGE_COUNT(Temp); + max_count = (READ_CACHE_LINKAGE_COUNT (Temp)); while (max_count != 0) { count = ((max_count > max_here) ? max_here : max_count); @@ -159,7 +163,7 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) for ( ; --count >= 0; Scan += 1) { Temp = *Scan; - relocate_typeless_pointer(copy_quadruple(), 4); + relocate_typeless_pointer (copy_quadruple(), 4); } if (max_count != 0) { @@ -213,9 +217,9 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) { if (purify_mode == PURE_COPY) { - gc_death(TERM_COMPILER_DEATH, - "purifyloop: manifest closure in pure area", - Scan, To); + gc_death (TERM_COMPILER_DEATH, + "purifyloop: manifest closure in pure area", + Scan, To); /*NOTREACHED*/ } } @@ -258,19 +262,19 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) char *entry_end; long de, dw; - entry_end = (CLOSURE_ENTRY_END(word_ptr)); + entry_end = (CLOSURE_ENTRY_END (word_ptr)); de = (end_ptr - entry_end); dw = (entry_end - word_ptr); - extend_scan_buffer(((char *) entry_end), To); + extend_scan_buffer (((char *) entry_end), To); relocate_manifest_closure (false); entry_end = ((char *) - (end_scan_buffer_extension((char *) entry_end))); + (end_scan_buffer_extension ((char *) entry_end))); word_ptr = (entry_end - dw); end_ptr = (entry_end + de); } else { - relocate_manifest_closure(false); + relocate_manifest_closure (false); } } Scan = ((SCHEME_OBJECT *) (end_ptr)); @@ -278,10 +282,10 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) } case_Cell: - relocate_normal_pointer(copy_cell(), 1); + relocate_normal_pointer (copy_cell(), 1); case TC_REFERENCE_TRAP: - if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE) + if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE) break; /* It is a non pointer. */ goto purify_pair; @@ -289,32 +293,32 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) case TC_UNINTERNED_SYMBOL: if (purify_mode == PURE_COPY) { - Temp = MEMORY_REF (Temp, SYMBOL_NAME); - relocate_indirect_setup(); - copy_vector(NULL); - relocate_indirect_end(); + Temp = (MEMORY_REF (Temp, SYMBOL_NAME)); + relocate_indirect_setup (); + copy_vector (NULL); + relocate_indirect_end (); } /* Fall through. */ case_Fasdump_Pair: purify_pair: - relocate_normal_pointer(copy_pair(), 2); + relocate_normal_pointer (copy_pair(), 2); case TC_WEAK_CONS: if (purify_mode == PURE_COPY) break; else - relocate_normal_pointer(copy_weak_pair(), 2); + relocate_normal_pointer (copy_weak_pair(), 2); case TC_VARIABLE: case_Triple: - relocate_normal_pointer(copy_triple(), 3); + relocate_normal_pointer (copy_triple(), 3); case_Quadruple: - relocate_normal_pointer(copy_quadruple(), 4); + relocate_normal_pointer (copy_quadruple(), 4); case TC_BIG_FLONUM: - relocate_flonum_setup(); + relocate_flonum_setup (); goto Move_Vector; case TC_COMPILED_CODE_BLOCK: @@ -324,21 +328,21 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode) /* Fall through */ case_Purify_Vector: - relocate_normal_setup(); + relocate_normal_setup (); Move_Vector: - copy_vector(NULL); - relocate_normal_end(); + copy_vector (NULL); + relocate_normal_end (); case TC_FUTURE: relocate_normal_setup(); - if (!(Future_Spliceable(Temp))) + if (!(Future_Spliceable (Temp))) goto Move_Vector; - *Scan = Future_Value(Temp); + *Scan = (Future_Value (Temp)); Scan -= 1; continue; default: - GC_BAD_TYPE("purifyloop"); + GC_BAD_TYPE ("purifyloop"); /* Fall Through */ case_Non_Pointer: @@ -357,33 +361,37 @@ end_purifyloop: */ SCHEME_OBJECT * -purify_header_overflow(free_buffer) - SCHEME_OBJECT *free_buffer; +DEFUN (purify_header_overflow, + (free_buffer), + SCHEME_OBJECT *free_buffer) { SCHEME_OBJECT *scan_buffer; long delta; delta = (free_buffer - free_buffer_top); - free_buffer = dump_and_reset_free_buffer(delta, NULL); - scan_buffer = dump_and_reload_scan_buffer(0, NULL); + free_buffer = (dump_and_reset_free_buffer (delta, NULL)); + scan_buffer = (dump_and_reload_scan_buffer (0, NULL)); if ((scan_buffer + delta) != free_buffer) { - gc_death(TERM_EXIT, "purify: scan and free do not meet at the end", - (scan_buffer + delta), free_buffer); + gc_death (TERM_EXIT, + "purify: scan and free do not meet at the end", + (scan_buffer + delta), free_buffer); /*NOTREACHED*/ } return (free_buffer); } SCHEME_OBJECT -purify(object, flag) - SCHEME_OBJECT object, flag; +DEFUN (purify, + (object, flag), + SCHEME_OBJECT object AND + SCHEME_OBJECT flag) { long length, pure_length; SCHEME_OBJECT value, *Result, *free_buffer, *block_start; Weak_Chain = EMPTY_LIST; - free_buffer = initialize_free_buffer(); + free_buffer = (initialize_free_buffer ()); block_start = Free_Constant; Free_Constant += 2; @@ -392,21 +400,22 @@ purify(object, flag) if (free_buffer >= free_buffer_top) { free_buffer = - dump_and_reset_free_buffer((free_buffer - free_buffer_top), NULL); + (dump_and_reset_free_buffer ((free_buffer - free_buffer_top), NULL)); } if (flag == SHARP_T) { - Result = purifyloop(initialize_scan_buffer(), - &free_buffer, &Free_Constant, - PURE_COPY); + Result = (purifyloop ((initialize_scan_buffer()), + &free_buffer, &Free_Constant, + PURE_COPY)); if (Result != free_buffer) { - gc_death(TERM_BROKEN_HEART, "purify: pure copy ended too early", - Result, free_buffer); + gc_death (TERM_BROKEN_HEART, + "purify: pure copy ended too early", + Result, free_buffer); /*NOTREACHED*/ } - pure_length = (Free_Constant - block_start) + 1; + pure_length = ((Free_Constant - block_start) + 1); } else { @@ -414,64 +423,64 @@ purify(object, flag) } Free_Constant += 2; - *free_buffer++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *free_buffer++ = MAKE_OBJECT (CONSTANT_PART, pure_length); + *free_buffer++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); + *free_buffer++ = (MAKE_OBJECT (CONSTANT_PART, pure_length)); if (free_buffer >= free_buffer_top) { - free_buffer = purify_header_overflow(free_buffer); + free_buffer = (purify_header_overflow (free_buffer)); } if (flag == SHARP_T) { - Result = purifyloop(initialize_scan_buffer(), - &free_buffer, &Free_Constant, - CONSTANT_COPY); + Result = (purifyloop ((initialize_scan_buffer ()), + &free_buffer, &Free_Constant, + CONSTANT_COPY)); } else - { - Result = GCLoop(initialize_scan_buffer(), &free_buffer, &Free_Constant); - } + Result = + (GCLoop ((initialize_scan_buffer()), &free_buffer, &Free_Constant)); if (Result != free_buffer) { - gc_death(TERM_BROKEN_HEART, "purify: constant copy ended too early", - Result, free_buffer); + gc_death (TERM_BROKEN_HEART, "purify: constant copy ended too early", + Result, free_buffer); /*NOTREACHED*/ } Free_Constant += 2; length = (Free_Constant - block_start); - *free_buffer++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *free_buffer++ = MAKE_OBJECT (END_OF_BLOCK, (length - 1)); + *free_buffer++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); + *free_buffer++ = (MAKE_OBJECT (END_OF_BLOCK, (length - 1))); if (free_buffer >= free_buffer_top) { - free_buffer = purify_header_overflow(free_buffer); + free_buffer = purify_header_overflow (free_buffer); } - end_transport(NULL); + end_transport (NULL); - if (!Test_Pure_Space_Top(Free_Constant)) + if (!(TEST_CONSTANT_TOP (Free_Constant))) { - gc_death(TERM_NO_SPACE, "purify: object too large", NULL, NULL); + gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL); /*NOTREACHED*/ } - load_buffer(0, block_start, - (length * sizeof(SCHEME_OBJECT)), - "into constant space"); - *block_start++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length); - *block_start = MAKE_OBJECT (PURE_PART, (length - 1)); - GC(Weak_Chain); - Set_Pure_Top(); + load_buffer (0, block_start, + (length * sizeof(SCHEME_OBJECT)), + "into constant space"); + *block_start++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length)); + *block_start = (MAKE_OBJECT (PURE_PART, (length - 1))); + SET_CONSTANT_TOP (); + GC (Weak_Chain); return (SHARP_T); } /* Stub. Not needed by this version. Terminates Scheme if invoked. */ SCHEME_OBJECT -Purify_Pass_2(info) - SCHEME_OBJECT info; +DEFUN (Purify_Pass_2, + (info), + SCHEME_OBJECT info) { - gc_death(TERM_EXIT, "Purify_Pass_2 invoked", NULL, NULL); + gc_death (TERM_EXIT, "Purify_Pass_2 invoked", NULL, NULL); /*NOTREACHED*/ } @@ -496,10 +505,14 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) SCHEME_OBJECT object, daemon; SCHEME_OBJECT result; PRIMITIVE_HEADER (3); - PRIMITIVE_CANONICALIZE_CONTEXT(); + PRIMITIVE_CANONICALIZE_CONTEXT (); + + STACK_SANITY_CHECK ("PURIFY"); + Save_Time_Zone (Zone_Purify); TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object); CHECK_ARG (2, BOOLEAN_P); GC_Reserve = (arg_nonnegative_integer (3)); + ENTER_CRITICAL_SECTION ("purify"); { SCHEME_OBJECT purify_result; @@ -512,14 +525,15 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) (*Free++) = words_free; } POP_PRIMITIVE_FRAME (3); - daemon = Get_Fixed_Obj_Slot(GC_Daemon); + daemon = (Get_Fixed_Obj_Slot (GC_Daemon)); if (daemon == SHARP_F) { Val = result; EXIT_CRITICAL_SECTION ({}); - PRIMITIVE_ABORT(PRIM_POP_RETURN); + PRIMITIVE_ABORT (PRIM_POP_RETURN); /*NOTREACHED*/ } + RENAME_CRITICAL_SECTION ("purify daemon"); Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); Store_Expression(result); diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index 58028ce98..2d19752ec 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.66 1990/11/15 23:17:06 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.67 1991/02/24 01:10:24 jinx Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -104,9 +104,10 @@ DEFUN (usage, (error_string), CONST char * error_string) #endif main_type -main (argc, argv) - int argc; - CONST char ** argv; +DEFUN (main, + (argc, argv), + int argc AND + CONST char ** argv) { init_exit_scheme (); scheme_program_name = (argv[0]); @@ -168,7 +169,7 @@ main (argc, argv) } SCHEME_OBJECT -make_fixed_objects_vector () +DEFUN_VOID (make_fixed_objects_vector) { extern SCHEME_OBJECT initialize_history (); extern SCHEME_OBJECT make_primitive (); @@ -261,9 +262,10 @@ make_fixed_objects_vector () /* Boot Scheme */ void -Start_Scheme (Start_Prim, File_Name) - int Start_Prim; - char * File_Name; +DEFUN (Start_Scheme, + (Start_Prim, File_Name), + int Start_Prim AND + char * File_Name) { extern SCHEME_OBJECT make_primitive (); SCHEME_OBJECT FName, Init_Prog, *Fasload_Call, prim; @@ -357,7 +359,7 @@ Start_Scheme (Start_Prim, File_Name) } void -Enter_Interpreter () +DEFUN_VOID (Enter_Interpreter) { Interpret (scheme_dumped_p); fprintf (stderr, "\nThe interpreter returned to top level!\n"); @@ -373,8 +375,9 @@ extern SCHEME_OBJECT extern unsigned long gc_counter; -extern void - gc_death(); +extern void EXFUN (gc_death, + (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *)); +extern void EXFUN (stack_death, (const char *)); extern char gc_death_message_buffer[]; @@ -390,10 +393,12 @@ char gc_death_message_buffer[100]; void -gc_death (code, message, scan, free) - long code; - char *message; - SCHEME_OBJECT *scan, *free; +DEFUN (gc_death, + (code, message, scan, free), + long code AND + char *message AND + SCHEME_OBJECT *scan AND + SCHEME_OBJECT *free) { fprintf (stderr, "\n%s.\n", message); fprintf (stderr, "scan = 0x%lx; free = 0x%lx\n", scan, free); @@ -402,6 +407,18 @@ gc_death (code, message, scan, free) Microcode_Termination (code); /*NOTREACHED*/ } + +void +DEFUN (stack_death, (name), const char *name) +{ + fprintf (stderr, + "\n%s: Constant space is no longer sealed!\n", + name); + fprintf (stderr, + "Perhaps a runaway recursion has overflowed the stack.\n"); + Microcode_Termination (TERM_STACK_OVERFLOW); + /*NOTREACHED*/ +} /* Utility primitives. */ diff --git a/v7/src/microcode/default.h b/v7/src/microcode/default.h index b7848b9eb..00ff6be7b 100644 --- a/v7/src/microcode/default.h +++ b/v7/src/microcode/default.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.35 1990/11/13 08:44:27 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.36 1991/02/24 01:10:32 jinx Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -77,7 +77,7 @@ MIT in each case. */ (* (locative)) = (object); \ } #endif - + #ifndef USE_STACKLETS #define Absolute_Stack_Base Constant_Top @@ -92,14 +92,33 @@ do \ } while (0) #endif +#endif /* USE_STACKLETS */ + +#ifndef SET_CONSTANT_TOP +#define SET_CONSTANT_TOP() \ +do \ +{ \ + ALIGN_FLOAT (Free_Constant); \ + SEAL_CONSTANT_SPACE (); \ +} while (0) #endif -#ifndef Set_Pure_Top -#define Set_Pure_Top() ALIGN_FLOAT (Free_Constant) +#ifndef TEST_CONSTANT_TOP +#define TEST_CONSTANT_TOP(New_Top) ((New_Top) <= Constant_Top) #endif -#ifndef Test_Pure_Space_Top -#define Test_Pure_Space_Top(New_Top) ((New_Top) <= Constant_Top) +#ifndef STACK_SANITY_CHECK +#define STACK_SANITY_CHECK(name) \ +do \ +{ \ + if (!(CONSTANT_SPACE_SEALED ())) \ + { \ + extern void EXFUN (stack_death, (const char *)); \ + \ + stack_death (name); \ + /*NOTREACHED */ \ + } \ +} while (0) #endif /* Used in debug.c */ diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index 2434975ca..6b5537c2a 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.59 1990/11/21 07:04:18 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.60 1991/02/24 01:10:39 jinx Exp $ -Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1987-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -116,7 +116,7 @@ DEFUN (read_channel_continue, (header, mode, repeat_p), print_fasl_information(); } - if (!Test_Pure_Space_Top (Free_Constant + Const_Count)) + if (!(TEST_CONSTANT_TOP (Free_Constant + Const_Count))) { if (mode != MODE_CHANNEL) { @@ -247,7 +247,7 @@ DEFUN (read_file_start, (file_name, from_band_load), static SCHEME_OBJECT * DEFUN (read_file_end, (mode), int mode) { - SCHEME_OBJECT *table; + SCHEME_OBJECT *table, *ignore; extern unsigned long checksum_area (); if ((Load_Data (Heap_Count, ((char *) Free))) != Heap_Count) @@ -265,8 +265,9 @@ DEFUN (read_file_end, (mode), int mode) NORMALIZE_REGION(((char *) Free), Heap_Count); Free += Heap_Count; - if ((Load_Data(Const_Count, ((char *) Free_Constant))) != Const_Count) + if ((Load_Data (Const_Count, ((char *) Free_Constant))) != Const_Count) { + SET_CONSTANT_TOP (); if (mode != MODE_CHANNEL) { OS_channel_close_noerror (load_channel); @@ -277,11 +278,12 @@ DEFUN (read_file_end, (mode), int mode) (checksum_area (((unsigned long *) Free_Constant), Const_Count, computed_checksum)); - NORMALIZE_REGION(((char *) Free_Constant), Const_Count); + NORMALIZE_REGION (((char *) Free_Constant), Const_Count); Free_Constant += Const_Count; + SET_CONSTANT_TOP (); table = Free; - if ((Load_Data(Primitive_Table_Size, ((char *) Free))) != + if ((Load_Data (Primitive_Table_Size, ((char *) Free))) != Primitive_Table_Size) { if (mode != MODE_CHANNEL) @@ -294,7 +296,7 @@ DEFUN (read_file_end, (mode), int mode) (checksum_area (((unsigned long *) Free), Primitive_Table_Size, computed_checksum)); - NORMALIZE_REGION(((char *) table), Primitive_Table_Size); + NORMALIZE_REGION (((char *) table), Primitive_Table_Size); Free += Primitive_Table_Size; if (mode != MODE_CHANNEL) @@ -762,7 +764,7 @@ DEFUN (load_file, (mode), int mode) */ Relocate_Block (Orig_Heap, primitive_table); - Relocate_Block (Orig_Constant, Free_Constant); + Relocate_Block (Orig_Constant, Constant_End); } #ifdef BYTE_INVERSION @@ -777,8 +779,7 @@ DEFUN (load_file, (mode), int mode) Intern_Block (Orig_Constant, Constant_End); } - Set_Pure_Top (); - FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, Orig_Constant, Free_Constant); + FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, Orig_Constant, Constant_End); Relocate_Into (temp, Dumped_Object); return (*temp); } @@ -1003,7 +1004,6 @@ DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) /* Reset implementation state paramenters */ INITIALIZE_INTERRUPTS (); Initialize_Stack (); - Set_Pure_Top (); SET_MEMTOP (Heap_Top - GC_Reserve); { SCHEME_OBJECT cutl = (MEMORY_REF (result, 1)); diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c index dc1728089..6ab96393a 100644 --- a/v7/src/microcode/memmag.c +++ b/v7/src/microcode/memmag.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.44 1990/06/20 17:41:31 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.45 1991/02/24 01:10:48 jinx Exp $ -Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1987-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -82,58 +82,60 @@ extern void Clear_Memory(), Setup_Memory(), Reset_Memory(); special: it always points to a cell which is in use. */ void -Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) - int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; +DEFUN (Clear_Memory, + (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size), + int Our_Heap_Size AND int Our_Stack_Size AND int Our_Constant_Size) { GC_Reserve = 4500; GC_Space_Needed = 0; Heap_Top = (Heap_Bottom + Our_Heap_Size); Local_Heap_Base = Heap_Bottom; Unused_Heap_Top = (Heap_Bottom + (2 * Our_Heap_Size)); - SET_MEMTOP(Heap_Top - GC_Reserve); + SET_MEMTOP (Heap_Top - GC_Reserve); Free = Heap_Bottom; Constant_Top = (Constant_Space + Our_Constant_Size); - Free_Constant = Constant_Space; - Set_Pure_Top (); Initialize_Stack (); + Free_Constant = Constant_Space; + SET_CONSTANT_TOP (); return; } /* This procedure allocates and divides the total memory. */ void -Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) - int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size; +DEFUN (Setup_Memory, + (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size), + int Our_Heap_Size AND int Our_Stack_Size AND int Our_Constant_Size) { SCHEME_OBJECT test_value; /* Consistency check 1 */ if (Our_Heap_Size == 0) { - fprintf(stderr, "Configuration won't hold initial data.\n"); - exit(1); + fprintf (stderr, "Configuration won't hold initial data.\n"); + exit (1); } /* Allocate */ Highest_Allocated_Address = - ALLOCATE_HEAP_SPACE(Stack_Allocation_Size(Our_Stack_Size) + - (2 * Our_Heap_Size) + - Our_Constant_Size + - HEAP_BUFFER_SPACE); + ALLOCATE_HEAP_SPACE (Stack_Allocation_Size(Our_Stack_Size) + + (2 * Our_Heap_Size) + + Our_Constant_Size + + HEAP_BUFFER_SPACE); /* Consistency check 2 */ if (Heap == NULL) { - fprintf(stderr, "Not enough memory for this configuration.\n"); - exit(1); + fprintf (stderr, "Not enough memory for this configuration.\n"); + exit (1); } /* Initialize the various global parameters */ Heap += HEAP_BUFFER_SPACE; - INITIAL_ALIGN_FLOAT(Heap); - Unused_Heap = Heap + Our_Heap_Size; + INITIAL_ALIGN_FLOAT (Heap); + Unused_Heap = (Heap + Our_Heap_Size); ALIGN_FLOAT (Unused_Heap); - Constant_Space = Heap + 2*Our_Heap_Size; + Constant_Space = (Heap + (2 * Our_Heap_Size)); ALIGN_FLOAT (Constant_Space); /* Consistency check 3 */ @@ -143,22 +145,22 @@ Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size) if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) || ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address)) { - fprintf(stderr, - "Largest address does not fit in datum field of object.\n"); - fprintf(stderr, - "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n"); - exit(1); + fprintf (stderr, + "Largest address does not fit in datum field of object.\n"); + fprintf (stderr, + "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n"); + exit (1); } Heap_Bottom = Heap; - Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size); + Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size); return; } /* In this version, this does nothing. */ void -Reset_Memory() +DEFUN_VOID (Reset_Memory) { return; } @@ -170,7 +172,7 @@ Reset_Memory() /* Flip into unused heap */ void -GCFlip() +DEFUN_VOID (GCFlip) { SCHEME_OBJECT *Temp; @@ -199,7 +201,7 @@ GCFlip() SCHEME_OBJECT Weak_Chain; void -Fix_Weak_Chain() +DEFUN_VOID (Fix_Weak_Chain) { fast SCHEME_OBJECT *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant; @@ -300,7 +302,8 @@ Fix_Weak_Chain() new space. */ -void GC() +void +DEFUN_VOID (GC) { SCHEME_OBJECT *Root, *Result, *Check_Value, @@ -308,66 +311,65 @@ void GC() /* Save the microcode registers so that they can be relocated */ - Terminate_Old_Stacklet(); - Terminate_Constant_Space(Check_Value); - + Terminate_Old_Stacklet (); + SEAL_CONSTANT_SPACE (); + Check_Value = (CONSTANT_SPACE_SEAL ()); Root = Free; - The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects); - Set_Fixed_Obj_Slot(Precious_Objects, SHARP_F); - Set_Fixed_Obj_Slot(Lost_Objects_Base, SHARP_F); + The_Precious_Objects = (Get_Fixed_Obj_Slot (Precious_Objects)); + Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F); + Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F); *Free++ = Fixed_Objects; - *Free++ = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History); + *Free++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History)); *Free++ = Undefined_Primitives; *Free++ = Undefined_Primitives_Arity; - *Free++ = Get_Current_Stacklet(); + *Free++ = Get_Current_Stacklet (); *Free++ = ((Prev_Restore_History_Stacklet == NULL) ? SHARP_F - : MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Prev_Restore_History_Stacklet)); + : (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Prev_Restore_History_Stacklet))); *Free++ = Current_State_Point; *Free++ = Fluid_Bindings; /* The 4 step GC */ - Result = GCLoop(Constant_Space, &Free); + Result = (GCLoop (Constant_Space, &Free)); if (Result != Check_Value) { - fprintf(stderr, "\nGC: Constant Scan ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); + fprintf (stderr, "\nGC: Constant Scan ended too early.\n"); + Microcode_Termination (TERM_BROKEN_HEART); } - Result = GCLoop(Root, &Free); + Result = (GCLoop (Root, &Free)); if (Free != Result) { - fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); + fprintf (stderr, "\nGC-1: Heap Scan ended too early.\n"); + Microcode_Termination (TERM_BROKEN_HEART); } Root2 = Free; *Free++ = The_Precious_Objects; - Result = GCLoop(Root2, &Free); + Result = (GCLoop (Root2, &Free)); if (Free != Result) { - fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n"); - Microcode_Termination(TERM_BROKEN_HEART); + fprintf (stderr, "\nGC-2: Heap Scan ended too early.\n"); + Microcode_Termination (TERM_BROKEN_HEART); } - Fix_Weak_Chain(); + Fix_Weak_Chain (); /* Make the microcode registers point to the copies in new-space. */ Fixed_Objects = *Root++; - Set_Fixed_Obj_Slot(Precious_Objects, *Root2); + Set_Fixed_Obj_Slot (Precious_Objects, *Root2); Set_Fixed_Obj_Slot (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2)))); - History = OBJECT_ADDRESS (*Root++); + History = (OBJECT_ADDRESS (*Root++)); Undefined_Primitives = *Root++; Undefined_Primitives_Arity = *Root++; - /* Set_Current_Stacklet is sometimes a No-Op! */ - Set_Current_Stacklet(*Root); + Set_Current_Stacklet (*Root); Root += 1; if (*Root == SHARP_F) { @@ -376,12 +378,13 @@ void GC() } else { - Prev_Restore_History_Stacklet = OBJECT_ADDRESS (*Root++); + Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*Root++)); } Current_State_Point = *Root++; Fluid_Bindings = *Root++; Free_Stacklets = NULL; FLUSH_I_CACHE (); + CLEAR_INTERRUPT (INT_GC); return; } @@ -401,45 +404,47 @@ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) extern unsigned long gc_counter; SCHEME_OBJECT GC_Daemon_Proc; PRIMITIVE_HEADER (1); + PRIMITIVE_CANONICALIZE_CONTEXT (); - PRIMITIVE_CANONICALIZE_CONTEXT(); + STACK_SANITY_CHECK ("GC"); new_gc_reserve = (arg_nonnegative_integer (1)); if (Free > Heap_Top) { - fprintf(stderr, - "\nGC has been delayed too long, and you are out of room!\n"); - fprintf(stderr, - "Free = 0x%x; MemTop = 0x%x; Heap_Top = 0x%x\n", - Free, MemTop, Heap_Top); - Microcode_Termination(TERM_NO_SPACE); + fprintf (stderr, + "\nGARBAGE-COLLECT: GC has been delayed too long!\n"); + fprintf (stderr, + "Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n", + Free, MemTop, Heap_Top); + Microcode_Termination (TERM_NO_SPACE); } + ENTER_CRITICAL_SECTION ("garbage collector"); gc_counter += 1; GC_Reserve = new_gc_reserve; - GCFlip(); - GC(); - CLEAR_INTERRUPT(INT_GC); + GCFlip (); + GC (); POP_PRIMITIVE_FRAME (1); - GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); + GC_Daemon_Proc = (Get_Fixed_Obj_Slot (GC_Daemon)); + RENAME_CRITICAL_SECTION ("garbage collector daemon"); if (GC_Daemon_Proc == SHARP_F) { - Will_Push(CONTINUATION_SIZE); - Store_Return(RC_NORMAL_GC_DONE); - Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free)); - Save_Cont(); - Pushed(); - PRIMITIVE_ABORT(PRIM_POP_RETURN); + Will_Push (CONTINUATION_SIZE); + Store_Return (RC_NORMAL_GC_DONE); + Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); + Save_Cont (); + Pushed (); + PRIMITIVE_ABORT (PRIM_POP_RETURN); /*NOTREACHED*/ } - Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); - Store_Return(RC_NORMAL_GC_DONE); - Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free)); - Save_Cont(); + Will_Push (CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); + Store_Return (RC_NORMAL_GC_DONE); + Store_Expression (LONG_TO_UNSIGNED_FIXNUM(MemTop - Free)); + Save_Cont (); STACK_PUSH (GC_Daemon_Proc); STACK_PUSH (STACK_FRAME_HEADER); - Pushed(); - PRIMITIVE_ABORT(PRIM_APPLY); + Pushed (); + PRIMITIVE_ABORT (PRIM_APPLY); /* The following comment is by courtesy of LINT, your friendly sponsor. */ /*NOTREACHED*/ } diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c index fad3d6b20..c2422d6a5 100644 --- a/v7/src/microcode/purify.c +++ b/v7/src/microcode/purify.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.44 1990/06/28 18:19:53 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.45 1991/02/24 01:10:56 jinx Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -42,8 +42,9 @@ MIT in each case. */ /* Imports */ -extern void GCFlip(), GC(); -extern SCHEME_OBJECT *GCLoop(); +extern void EXFUN (GCFlip, (void)); +extern void EXFUN (GC, (void)); +extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); /* This is a copy of GCLoop, with mode handling added, and debugging printout removed. @@ -57,7 +58,7 @@ extern SCHEME_OBJECT *GCLoop(); #define Purify_Pointer(Code) \ { \ - Old = OBJECT_ADDRESS (Temp); \ + Old = (OBJECT_ADDRESS (Temp)); \ if ((GC_Mode == CONSTANT_COPY) && \ (Old > Low_Constant)) \ continue; \ @@ -71,21 +72,22 @@ extern SCHEME_OBJECT *GCLoop(); #define Indirect_BH(In_GC) \ { \ - if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \ + if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) \ continue; \ } #define Transport_Vector_Indirect() \ { \ - Real_Transport_Vector(); \ - *OBJECT_ADDRESS (Temp) = New_Address; \ + Real_Transport_Vector (); \ + *(OBJECT_ADDRESS (Temp)) = New_Address; \ } SCHEME_OBJECT * -PurifyLoop(Scan, To_Pointer, GC_Mode) - fast SCHEME_OBJECT *Scan; - SCHEME_OBJECT **To_Pointer; - int GC_Mode; +DEFUN (PurifyLoop, + (Scan, To_Pointer, GC_Mode), + fast SCHEME_OBJECT *Scan AND + SCHEME_OBJECT **To_Pointer AND + int GC_Mode) { fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, New_Address; @@ -376,8 +378,10 @@ N < | | | #define Purify_N_Slots 2 SCHEME_OBJECT -Purify (Object, Purify_Object) - SCHEME_OBJECT Object, Purify_Object; +DEFUN (Purify, + (Object, Purify_Object), + SCHEME_OBJECT Object AND + SCHEME_OBJECT Purify_Object) { long Length; SCHEME_OBJECT *Heap_Start, *Result, Answer; @@ -405,14 +409,16 @@ Purify (Object, Purify_Object) } SCHEME_OBJECT -Purify_Pass_2 (Info) - SCHEME_OBJECT Info; +DEFUN (Purify_Pass_2, + (Info), + SCHEME_OBJECT Info) { long Length; Boolean Purify_Object; SCHEME_OBJECT *New_Object, Relocated_Object, *Result; long Pure_Length, Recomputed_Length; + STACK_SANITY_CHECK ("PURIFY"); Length = (OBJECT_DATUM (FAST_MEMORY_REF (Info, Purify_Length))); if (FAST_MEMORY_REF (Info, Purify_Really_Pure) == SHARP_F) { @@ -423,7 +429,7 @@ Purify_Pass_2 (Info) Purify_Object = true; } Relocated_Object = *Heap_Bottom; - if (!(Test_Pure_Space_Top (Free_Constant + Length + 6))) + if (!(TEST_CONSTANT_TOP (Free_Constant + Length + 6))) { return (SHARP_F); } @@ -474,7 +480,7 @@ Purify_Pass_2 (Info) Recomputed_Length = ((Free_Constant - New_Object) - 4); *Free_Constant++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); *Free_Constant++ = (MAKE_OBJECT (END_OF_BLOCK, (Recomputed_Length + 5))); - if (!(Test_Pure_Space_Top (Free_Constant))) + if (!(TEST_CONSTANT_TOP (Free_Constant))) { fprintf (stderr, "\nPurify overrun: Constant_Top = 0x%lx, Free_Constant = 0x%lx\n", @@ -484,8 +490,8 @@ Purify_Pass_2 (Info) *New_Object++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length)); *New_Object = (MAKE_OBJECT (PURE_PART, (Recomputed_Length + 5))); + SET_CONSTANT_TOP (); GC (); - Set_Pure_Top (); return (SHARP_T); } @@ -514,9 +520,11 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) long new_gc_reserve; SCHEME_OBJECT Object, Purify_Result, Daemon; PRIMITIVE_HEADER (3); + PRIMITIVE_CANONICALIZE_CONTEXT (); - PRIMITIVE_CANONICALIZE_CONTEXT(); - Save_Time_Zone(Zone_Purify); + STACK_SANITY_CHECK ("PURIFY"); + Save_Time_Zone (Zone_Purify); + TOUCH_IN_PRIMITIVE ((ARG_REF (1)), Object); CHECK_ARG (2, BOOLEAN_P); new_gc_reserve = (arg_nonnegative_integer (3)); @@ -524,33 +532,33 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) run, and then Purify_Pass_2 is called to copy back. */ - TOUCH_IN_PRIMITIVE ((ARG_REF (1)), Object); GC_Reserve = new_gc_reserve; ENTER_CRITICAL_SECTION ("purify pass 1"); Purify_Result = (Purify (Object, (ARG_REF (2)))); POP_PRIMITIVE_FRAME (3); - Daemon = Get_Fixed_Obj_Slot(GC_Daemon); + Daemon = (Get_Fixed_Obj_Slot (GC_Daemon)); if (Daemon == SHARP_F) { SCHEME_OBJECT words_free; RENAME_CRITICAL_SECTION ("purify pass 2"); - Purify_Result = Purify_Pass_2(Purify_Result); + Purify_Result = (Purify_Pass_2 (Purify_Result)); words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); Val = (MAKE_POINTER_OBJECT (TC_LIST, Free)); (*Free++) = Purify_Result; (*Free++) = words_free; - PRIMITIVE_ABORT(PRIM_POP_RETURN); + PRIMITIVE_ABORT (PRIM_POP_RETURN); /*NOTREACHED*/ } + RENAME_CRITICAL_SECTION ("purify daemon 1"); - Store_Expression(Purify_Result); - Store_Return(RC_PURIFY_GC_1); - Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1); - Save_Cont(); + Store_Expression (Purify_Result); + Store_Return (RC_PURIFY_GC_1); + Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1); + Save_Cont (); STACK_PUSH (Daemon); STACK_PUSH (STACK_FRAME_HEADER); - Pushed(); - PRIMITIVE_ABORT(PRIM_APPLY); + Pushed (); + PRIMITIVE_ABORT (PRIM_APPLY); /*NOTREACHED*/ } diff --git a/v7/src/microcode/purutl.c b/v7/src/microcode/purutl.c index 2200c2cea..442e34fdf 100644 --- a/v7/src/microcode/purutl.c +++ b/v7/src/microcode/purutl.c @@ -1,6 +1,8 @@ /* -*-C-*- -Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.40 1991/02/24 01:11:04 jinx Exp $ + +Copyright (c) 1987-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -30,8 +32,6 @@ 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/purutl.c,v 9.39 1990/06/28 18:18:11 jinx Rel $ */ - /* Pure/Constant space utilities. */ #include "scheme.h" @@ -40,8 +40,12 @@ MIT in each case. */ #include "zones.h" static void -Update(From, To, Was, Will_Be) - fast SCHEME_OBJECT *From, *To, *Was, *Will_Be; +DEFUN (Update, + (From, To, Was, Will_Be), + fast SCHEME_OBJECT *From AND + fast SCHEME_OBJECT *To AND + fast SCHEME_OBJECT *Was AND + fast SCHEME_OBJECT *Will_Be) { fast long count; @@ -95,8 +99,10 @@ Update(From, To, Was, Will_Be) } long -Make_Impure(Object, New_Object) - SCHEME_OBJECT Object, *New_Object; +DEFUN (Make_Impure, + (Object, New_Object), + SCHEME_OBJECT Object AND + SCHEME_OBJECT *New_Object) { SCHEME_OBJECT *New_Address, *End_Of_Area; fast SCHEME_OBJECT *Obj_Address, *Constant_Address; @@ -164,40 +170,41 @@ Make_Impure(Object, New_Object) Constant_Address = Free_Constant; - Obj_Address = OBJECT_ADDRESS (Object); - if (!Test_Pure_Space_Top(Constant_Address + Length)) + Obj_Address = (OBJECT_ADDRESS (Object)); + if (!(TEST_CONSTANT_TOP (Constant_Address + Length))) { return (ERR_IMPURIFY_OUT_OF_SPACE); } - Block_Length = OBJECT_DATUM (*(Constant_Address-1)); + Block_Length = (OBJECT_DATUM (* (Constant_Address - 1))); Constant_Address -= 2; New_Address = Constant_Address; for (i = Length; --i >= 0; ) { *Constant_Address++ = *Obj_Address; - *Obj_Address++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, i); + *Obj_Address++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, i)); } - - *Constant_Address++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *Constant_Address++ = MAKE_OBJECT (END_OF_BLOCK, Block_Length + Length); + + *Constant_Address++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); + *Constant_Address++ = (MAKE_OBJECT (END_OF_BLOCK, Block_Length + Length)); *(New_Address + 2 - Block_Length) = - MAKE_OBJECT (PURE_PART, Block_Length + Length); + (MAKE_OBJECT (PURE_PART, Block_Length + Length)); Obj_Address -= Length; Free_Constant = Constant_Address; + SET_CONSTANT_TOP (); /* Run through memory relocating pointers to this object, including * those in pure areas. */ - Set_Pure_Top(); - Terminate_Old_Stacklet(); - Terminate_Constant_Space(End_Of_Area); + Terminate_Old_Stacklet (); + SEAL_CONSTANT_SPACE (); + End_Of_Area = (CONSTANT_SPACE_SEAL ()); ENTER_CRITICAL_SECTION ("impurify"); - Update(Heap_Bottom, Free, Obj_Address, New_Address); - Update(Constant_Space, End_Of_Area, Obj_Address, New_Address); + Update (Heap_Bottom, Free, Obj_Address, New_Address); + Update (Constant_Space, End_Of_Area, Obj_Address, New_Address); EXIT_CRITICAL_SECTION ({}); @@ -222,12 +229,13 @@ The object is placed in constant space instead.") PRIMITIVE_RETURN (new_object); } } - -extern SCHEME_OBJECT * find_constant_space_block(); + +extern SCHEME_OBJECT * EXFUN (find_constant_space_block, (SCHEME_OBJECT *)); SCHEME_OBJECT * -find_constant_space_block(obj_address) - fast SCHEME_OBJECT *obj_address; +DEFUN (find_constant_space_block, + (obj_address), + fast SCHEME_OBJECT *obj_address) { fast SCHEME_OBJECT *where, *low_constant; @@ -246,12 +254,13 @@ find_constant_space_block(obj_address) } Boolean -Pure_Test(obj_address) - SCHEME_OBJECT *obj_address; +DEFUN (Pure_Test, + (obj_address), + SCHEME_OBJECT *obj_address) { SCHEME_OBJECT *block; - block = find_constant_space_block (obj_address); + block = (find_constant_space_block (obj_address)); if (block == ((SCHEME_OBJECT *) NULL)) { return (false); @@ -314,33 +323,35 @@ DEFINE_PRIMITIVE ("GET-NEXT-CONSTANT", Prim_get_next_constant, 0, 0, extern SCHEME_OBJECT *copy_to_constant_space(); SCHEME_OBJECT * -copy_to_constant_space(source, nobjects) - fast SCHEME_OBJECT *source; - long nobjects; +DEFUN (copy_to_constant_space, + (source, nobjects), + fast SCHEME_OBJECT *source AND + long nobjects) { fast SCHEME_OBJECT *dest; fast long i; SCHEME_OBJECT *result; dest = Free_Constant; - if (!Test_Pure_Space_Top(dest + nobjects + 6)) + if (!(TEST_CONSTANT_TOP (dest + nobjects + 6))) { - fprintf(stderr, + fprintf (stderr, "copy_to_constant_space: Not enough constant space!\n"); - Microcode_Termination(TERM_NO_SPACE); + Microcode_Termination (TERM_NO_SPACE); } - *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 3); - *dest++ = MAKE_OBJECT (PURE_PART, nobjects + 5); - *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *dest++ = MAKE_OBJECT (CONSTANT_PART, 3); + *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 3)); + *dest++ = (MAKE_OBJECT (PURE_PART, nobjects + 5)); + *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); + *dest++ = (MAKE_OBJECT (CONSTANT_PART, 3)); result = dest; for (i = nobjects; --i >= 0; ) { *dest++ = *source++; } - *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1); - *dest++ = MAKE_OBJECT (END_OF_BLOCK, nobjects + 5); + *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); + *dest++ = (MAKE_OBJECT (END_OF_BLOCK, nobjects + 5)); Free_Constant = dest; + SET_CONSTANT_TOP (); return result; } diff --git a/v7/src/microcode/stack.h b/v7/src/microcode/stack.h index f371cad6d..2bf102870 100644 --- a/v7/src/microcode/stack.h +++ b/v7/src/microcode/stack.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.28 1990/06/20 17:42:03 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.29 1991/02/24 01:11:10 jinx Exp $ -Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1987-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -104,9 +104,14 @@ MIT in each case. */ /* Used by garbage collector to detect the end of constant space */ -#define Terminate_Constant_Space(Where) \ - *Free_Constant = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant);\ - Where = Free_Constant +#define CONSTANT_SCAN_SEAL() Free_Constant + +#define SEAL_CONSTANT_SPACE() \ + *Free_Constant = \ + (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant)); + +#define CONSTANT_SPACE_SEALED() \ +((*Free_Constant) == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant))) #define Get_Current_Stacklet() \ (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Current_Stacklet)) @@ -302,14 +307,22 @@ do \ /* Used by garbage collector to detect the end of constant space, and to skip over the gap between constant space and the stack. */ -#define Terminate_Constant_Space(Where) \ +#define CONSTANT_SPACE_SEAL() Stack_Top + +#define SEAL_CONSTANT_SPACE() \ +do \ { \ *Free_Constant = \ (MAKE_OBJECT \ (TC_MANIFEST_NM_VECTOR, ((Stack_Pointer - Free_Constant) - 1))); \ - *Stack_Top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top); \ - Where = Stack_Top; \ -} + *(Free_Constant + 1) = \ + (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, (Free_Constant + 1))); \ + *Stack_Top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top)); \ +} while (0) + +#define CONSTANT_SPACE_SEALED() \ +((*(Free_Constant + 1)) == \ + (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, (Free_Constant + 1)))) #define Get_Current_Stacklet() SHARP_F diff --git a/v7/src/microcode/uxtrap.c b/v7/src/microcode/uxtrap.c index 85d964a0b..14e566eba 100644 --- a/v7/src/microcode/uxtrap.c +++ b/v7/src/microcode/uxtrap.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtrap.c,v 1.7 1991/01/16 00:34:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtrap.c,v 1.8 1991/02/24 01:11:22 jinx Exp $ -Copyright (c) 1990, 1991 Massachusetts Institute of Technology +Copyright (c) 1990-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -108,6 +108,7 @@ DEFUN (trap_handler, (message, signo, code, scp), int code AND struct FULL_SIGCONTEXT * scp) { + Boolean constant_space_broken = (!(CONSTANT_SPACE_SEALED ())); enum trap_state old_trap_state = trap_state; trap_state = trap_state_trapped; if (WITHIN_CRITICAL_SECTION_P ()) @@ -118,12 +119,18 @@ DEFUN (trap_handler, (message, signo, code, scp), fprintf (stdout, ">> [signal %d (%s), code %d]\n", signo, (find_signal_name (signo)), code); } - else if (old_trap_state != trap_state_recover) + else if (constant_space_broken || (old_trap_state != trap_state_recover)) { fprintf (stdout, "\n>> A %s has occurred.\n", message); fprintf (stdout, ">> [signal %d (%s), code %d]\n", signo, (find_signal_name (signo)), code); } + if (constant_space_broken) + { + fputs (">> Constant space has been overwritten.\n", stdout); + fputs (">> Probably a runaway recursion has overflowed the stack.\n", + stdout); + } fflush (stdout); switch (old_trap_state) { @@ -147,7 +154,7 @@ DEFUN (trap_handler, (message, signo, code, scp), else trap_immediate_termination (); case trap_state_recover: - if (WITHIN_CRITICAL_SECTION_P ()) + if ((WITHIN_CRITICAL_SECTION_P ()) || constant_space_broken) { fputs (">> Successful recovery is unlikely.\n", stdout); break;