From 0a019635310a426feabc790ce1a6d176575ab616 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Thu, 14 Oct 1993 19:23:18 +0000 Subject: [PATCH] Change Scheme memory layout and make constant space grow as needed when things are purified. --- v7/src/microcode/bchdmp.c | 33 +++- v7/src/microcode/bchgcc.h | 20 +- v7/src/microcode/bchgcl.c | 6 +- v7/src/microcode/bchmmg.c | 366 ++++++++++++++++++++---------------- v7/src/microcode/bchpur.c | 309 ++++++++++++++++++++---------- v7/src/microcode/bintopsb.c | 36 ++-- v7/src/microcode/boot.c | 9 +- v7/src/microcode/default.h | 74 +++++--- v7/src/microcode/dostrap.c | 24 +-- v7/src/microcode/extern.h | 41 ++-- v7/src/microcode/fasdump.c | 50 +++-- v7/src/microcode/fasload.c | 171 +++++++++++------ v7/src/microcode/gccode.h | 18 +- v7/src/microcode/gcloop.c | 12 +- v7/src/microcode/interp.c | 62 +----- v7/src/microcode/intrpt.h | 4 +- v7/src/microcode/memmag.c | 216 ++++++++++++--------- v7/src/microcode/nttrap.c | 24 +-- v7/src/microcode/object.h | 69 +++---- v7/src/microcode/ppband.c | 55 +----- v7/src/microcode/psbtobin.c | 19 +- v7/src/microcode/purify.c | 252 ++++++++++--------------- v7/src/microcode/purutl.c | 130 +++++++------ v7/src/microcode/stack.h | 98 +++------- v7/src/microcode/storage.c | 40 ++-- v7/src/microcode/sysprim.c | 4 +- v7/src/microcode/uxtrap.c | 30 ++- v7/src/microcode/version.h | 4 +- v8/src/microcode/bintopsb.c | 36 ++-- v8/src/microcode/interp.c | 62 +----- v8/src/microcode/object.h | 69 +++---- v8/src/microcode/ppband.c | 55 +----- v8/src/microcode/psbtobin.c | 19 +- v8/src/microcode/version.h | 4 +- 34 files changed, 1203 insertions(+), 1218 deletions(-) diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c index 6acaf589e..1f6f3843d 100644 --- a/v7/src/microcode/bchdmp.c +++ b/v7/src/microcode/bchdmp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bchdmp.c,v 9.72 1993/09/09 18:12:44 gjr Exp $ +$Id: bchdmp.c,v 9.73 1993/10/14 19:18:42 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -839,14 +839,16 @@ DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0) } } +extern SCHEME_OBJECT compiler_utilities; + /* (DUMP-BAND PROCEDURE FILE-NAME) Saves all of the heap and pure space on FILE-NAME. When the file is loaded back using BAND_LOAD, PROCEDURE is called with an - argument of #F. */ + argument of #F. +*/ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) { - extern SCHEME_OBJECT compiler_utilities; SCHEME_OBJECT Combination, *table_start, *table_end, *saved_free; long table_length; Boolean result; @@ -855,6 +857,10 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) Band_Dump_Permitted (); CHECK_ARG (1, INTERPRETER_APPLICABLE_P); CHECK_ARG (2, STRING_P); + if (Unused_Heap_Bottom < Heap_Bottom) + /* Cause the image to be in the low heap, to increase + the probability that no relocation is needed on reload. */ + Primitive_GC (0); Primitive_GC_If_Needed (5); saved_free = Free; Combination = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free)); @@ -872,14 +878,29 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) result = false; else { + SCHEME_OBJECT * faligned_heap, * faligned_constant; CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0))); + + OS_file_remove_link (filename); dump_channel = (OS_open_dump_file (filename)); if (dump_channel == NO_CHANNEL) error_bad_range_arg (2); + + for (faligned_heap = Heap_Bottom; + (! (FLOATING_ALIGNED_P (faligned_heap))); + faligned_heap += 1) + ; + + for (faligned_constant = Constant_Space; + (! (FLOATING_ALIGNED_P (faligned_constant))); + faligned_constant += 1) + ; + result = (Write_File ((Free - 1), - ((long) (Free - Heap_Bottom)), Heap_Bottom, - ((long) (Free_Constant - Constant_Space)), - Constant_Space, + ((long) (Free - faligned_heap)), + faligned_heap, + ((long) (Free_Constant - faligned_constant)), + faligned_constant, table_start, table_length, ((long) (table_end - table_start)), (compiler_utilities != SHARP_F), true)); diff --git a/v7/src/microcode/bchgcc.h b/v7/src/microcode/bchgcc.h index 6984f5e14..a499f930a 100644 --- a/v7/src/microcode/bchgcc.h +++ b/v7/src/microcode/bchgcc.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bchgcc.h,v 9.54 1993/08/23 02:21:13 gjr Exp $ +$Id: bchgcc.h,v 9.55 1993/10/14 19:13:10 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -155,7 +155,7 @@ extern SCHEME_OBJECT * weak_pair_stack_ptr, * weak_pair_stack_limit, * virtual_scan_pointer; - + extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **, SCHEME_OBJECT **)), * EXFUN (dump_and_reload_scan_buffer, (long, Boolean *)), @@ -172,7 +172,13 @@ extern void EXFUN (extend_scan_buffer, (char *, SCHEME_OBJECT *)), EXFUN (gc_death, (long, char *, SCHEME_OBJECT *, SCHEME_OBJECT *)), EXFUN (restore_gc_file, (void)), - EXFUN (initialize_weak_pair_transport, (SCHEME_OBJECT *)); + EXFUN (initialize_weak_pair_transport, (SCHEME_OBJECT *)), + EXFUN (fix_weak_chain_1, (void)), + EXFUN (fix_weak_chain_2, (void)), + EXFUN (GC_end_root_relocation, (SCHEME_OBJECT *, SCHEME_OBJECT *)); + +extern long + EXFUN (GC_relocate_root, (SCHEME_OBJECT **)); extern char * EXFUN (end_scan_buffer_extension, (char *)); @@ -218,7 +224,7 @@ extern int weak_car = (*Old++); \ car_type = (OBJECT_TYPE (weak_car)); \ if ((car_type == TC_NULL) \ - || ((OBJECT_ADDRESS (weak_car)) >= Low_Constant)) \ + || ((OBJECT_ADDRESS (weak_car)) < low_heap)) \ { \ *To++ = weak_car; \ *To++ = (*Old); \ @@ -304,7 +310,7 @@ extern int #define relocate_normal_setup() \ { \ Old = (OBJECT_ADDRESS (Temp)); \ - if (Old >= Low_Constant) \ + if (Old < low_heap) \ continue; \ if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) \ { \ @@ -369,7 +375,7 @@ do { \ #define relocate_typeless_setup() \ { \ Old = (SCHEME_ADDR_TO_ADDR (Temp)); \ - if (Old >= Low_Constant) \ + if (Old < low_heap) \ continue; \ if (BROKEN_HEART_P (* Old)) \ { \ @@ -405,7 +411,7 @@ do { \ #define relocate_compiled_entry(in_gc_p) do \ { \ Old = (OBJECT_ADDRESS (Temp)); \ - if (Old >= Low_Constant) \ + if (Old < low_heap) \ continue; \ Compiled_BH (in_gc_p, continue); \ { \ diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c index b920a12e4..6d56220e9 100644 --- a/v7/src/microcode/bchgcl.c +++ b/v7/src/microcode/bchgcl.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bchgcl.c,v 9.46 1993/08/23 02:21:42 gjr Exp $ +$Id: bchgcl.c,v 9.47 1993/10/14 19:19:19 gjr Exp $ Copyright (c) 1987-1992 Massachusetts Institute of Technology @@ -46,12 +46,12 @@ DEFUN (GCLoop, (Scan, To_ptr, To_Address_ptr), SCHEME_OBJECT ** To_Address_ptr) { fast SCHEME_OBJECT - * To, * Old, Temp, * Low_Constant, + * To, * Old, Temp, * low_heap, * To_Address, New_Address; To = (* To_ptr); To_Address = (* To_Address_ptr); - Low_Constant = Constant_Space; + low_heap = Constant_Top; for ( ; Scan != To; Scan++) { diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index 390e13655..95dad964d 100644 --- a/v7/src/microcode/bchmmg.c +++ b/v7/src/microcode/bchmmg.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bchmmg.c,v 9.81 1993/09/08 04:39:30 gjr Exp $ +$Id: bchmmg.c,v 9.82 1993/10/14 19:12:41 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -93,8 +93,6 @@ MIT in each case. */ - bchutl.c: utilities common to bchmmg.c and bchdrn.c. Problems with this implementation right now: - - Purify kills Scheme if there is not enough space in constant space - for the new object. - It only works on Unix (or systems which support Unix I/O calls). - Dumpworld does not work because the file is not closed at dump time or reopened at restart time. @@ -106,24 +104,25 @@ oo ------------------------------------------ | GC Buffer Space | (not always contiguous) | | - ------------------------------------------ - | Control Stack || | - | \/ | - ------------------------------------------ - | Constant + Pure Space /\ | - | || | - ------------------------------------------ + ------------------------------------------ <- fixed boundary (currently) | Heap Space | | | - ------------------------------------------ + ------------------------------------------ <- boundary moved by purify + | Constant + Pure Space /\ | + | || | + ------------------------------------------ <- fixed boundary (currently) + | Control Stack || | + | \/ | + ------------------------------------------ <- fixed boundary (currently) 0 + Each area has a pointer to its starting address and a pointer to - the next free cell. The GC buffer space contains two (or more) - buffers used during the garbage collection process. One is the - scan buffer and the other is the free buffer, and they are dumped - and loaded from disk as necessary. At the beginning and at the end - a single buffer is used, since transporting will occur into the - area being scanned. + the next free cell (for the stack, it is a pointer to the last cell + in use). The GC buffer space contains two (or more) buffers used + during the garbage collection process. One is the scan buffer and + the other is the free buffer, and they are dumped and loaded from + disk as necessary. At the beginning and at the end a single buffer + is used, since transporting will occur into the area being scanned. */ /* Exports */ @@ -183,8 +182,12 @@ static long scan_position, free_position, pre_read_position, - extension_overlap_length, - saved_heap_size; + extension_overlap_length; + +static long + saved_heap_size, + saved_constant_size, + saved_stack_size; static unsigned long read_queue_bitmask; /* Change MAX_READ_OVERLAP if you change this. */ @@ -2010,7 +2013,9 @@ DEFUN (open_gc_file, (size, unlink_p), if (exists_p && ((file_info.st_mode & S_IFMT) == S_IFCHR)) { +#if defined(F_GETFL) && defined(F_SETFL) && defined(O_NONBLOCK) int flags; +#endif Boolean ignore; static char message[] = "This is a test message to the GC file.\n"; char * buffer; @@ -2052,26 +2057,64 @@ DEFUN (open_gc_file, (size, unlink_p), return; } +#define CONSTANT_SPACE_FUDGE 128 + +extern void EXFUN (reset_allocator_parameters, (void)); +extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *)); + +Boolean +DEFUN (update_allocator_parameters, (ctop), SCHEME_OBJECT * ctop) +{ + /* buffer for impurify, etc. */ + ctop = ((SCHEME_OBJECT *) + (ALIGN_UP_TO_IO_PAGE (ctop + CONSTANT_SPACE_FUDGE))); + if (ctop >= Highest_Allocated_Address) + return (FALSE); + + Constant_Top = ctop; + Heap_Bottom = Constant_Top; + Heap_Top = ((SCHEME_OBJECT *) + (ALIGN_DOWN_TO_IO_PAGE (Highest_Allocated_Address))); + aligned_heap = Heap_Bottom; + Local_Heap_Base = Heap_Bottom; + Unused_Heap_Bottom = Heap_Top; + Unused_Heap_Top = Highest_Allocated_Address; + Free = Heap_Bottom; + SET_MEMTOP (Heap_Top - GC_Reserve); + return (TRUE); +} + void -DEFUN (Clear_Memory, (heap_size, stack_size, constant_space_size), - int heap_size - AND int stack_size - AND int constant_space_size) +DEFUN_VOID (reset_allocator_parameters) { GC_Reserve = 4500; GC_Space_Needed = 0; - Heap_Top = (Heap_Bottom + heap_size); - SET_MEMTOP (Heap_Top - GC_Reserve); - Free = Heap_Bottom; - Constant_Top = (Constant_Space + constant_space_size); - Initialize_Stack (); - STACK_RESET (); + Stack_Bottom = ((SCHEME_OBJECT *) + (ALIGN_UP_TO_IO_PAGE (Lowest_Allocated_Address))); + Stack_Top = ((SCHEME_OBJECT *) + (ALIGN_DOWN_TO_IO_PAGE + (Stack_Bottom + (STACK_ALLOCATION_SIZE (saved_stack_size))))); + Constant_Space = Stack_Top; Free_Constant = Constant_Space; + (void) update_allocator_parameters (Free_Constant); SET_CONSTANT_TOP (); + ALIGN_FLOAT (Free); + INITIALIZE_STACK (); + STACK_RESET (); return; } -static PTR Lowest_Allocated_Address; +void +DEFUN (Clear_Memory, (heap_size, stack_size, constant_space_size), + int heap_size + AND int stack_size + AND int constant_space_size) +{ + saved_heap_size = heap_size; + saved_constant_size = constant_space_size; + saved_stack_size = stack_size; + reset_allocator_parameters (); +} void DEFUN_VOID (Reset_Memory) @@ -2081,11 +2124,11 @@ DEFUN_VOID (Reset_Memory) DEALLOCATE_REGISTERS (); return; } - + #define BLOCK_TO_IO_SIZE(size) \ ((ALIGN_UP_TO_IO_PAGE ((size) * (sizeof (SCHEME_OBJECT)))) \ / (sizeof (SCHEME_OBJECT))) - + static int DEFUN (set_gc_buffer_sizes, (new_buffer_shift), unsigned long new_buffer_shift) { @@ -2095,7 +2138,7 @@ DEFUN (set_gc_buffer_sizes, (new_buffer_shift), unsigned long new_buffer_shift) new_buffer_size = (1L << new_buffer_shift); new_buffer_bytes = (new_buffer_size * (sizeof (SCHEME_OBJECT))); - if (!ALIGNED_TO_IO_PAGE_P (new_buffer_bytes)) + if (! (ALIGNED_TO_IO_PAGE_P (new_buffer_bytes))) { fprintf (stderr, "%s (Setup_Memory): improper new_buffer_size.\n", @@ -2109,11 +2152,11 @@ DEFUN (set_gc_buffer_sizes, (new_buffer_shift), unsigned long new_buffer_shift) } new_buffer_byte_shift = (next_exponent_of_two (new_buffer_bytes)); - if ((1L << new_buffer_byte_shift) != new_buffer_bytes) + if ((((unsigned long) 1L) << new_buffer_byte_shift) != new_buffer_bytes) { fprintf (stderr, - "%s (Setup_Memory): gc_buffer_bytes (= 0x%lx) is not a power of 2.\n", + "%s (Setup_Memory): gc_buffer_bytes (0x%lx) is not a power of 2.\n", scheme_program_name, new_buffer_bytes); return (-1); } @@ -2153,7 +2196,8 @@ DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size), AND int constant_space_size) { SCHEME_OBJECT test_value; - int real_stack_size, fudge_space; + int real_stack_size; + long gc_buffer_allocation; ALLOCATE_REGISTERS (); @@ -2168,30 +2212,32 @@ DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size), /*NOTREACHED*/ } - real_stack_size = (Stack_Allocation_Size (stack_size)); + real_stack_size = (STACK_ALLOCATION_SIZE (stack_size)); /* add log(1024)/log(2) to exponent */ - if ((set_gc_buffer_sizes (10 + (next_exponent_of_two - (option_gc_window_size)))) + if ((set_gc_buffer_sizes (10 + + (next_exponent_of_two (option_gc_window_size)))) != 0) parameterization_termination (1, 1); /* Use multiples of IO_PAGE_SIZE. */ - fudge_space = ((BLOCK_TO_IO_SIZE (HEAP_BUFFER_SPACE + 1)) - + (IO_PAGE_SIZE / (sizeof (SCHEME_OBJECT)))); heap_size = (BLOCK_TO_IO_SIZE (heap_size)); constant_space_size = (BLOCK_TO_IO_SIZE (constant_space_size)); real_stack_size = (BLOCK_TO_IO_SIZE (real_stack_size)); + gc_buffer_allocation = (GC_BUFFER_ALLOCATION (2 * gc_total_buffer_size)); /* Allocate. */ - ALLOCATE_HEAP_SPACE (fudge_space + heap_size - + constant_space_size + real_stack_size - + (GC_BUFFER_ALLOCATION (2 * gc_total_buffer_size))); + ALLOCATE_HEAP_SPACE ((heap_size + + constant_space_size + real_stack_size + + gc_buffer_allocation + + (IO_PAGE_SIZE / (sizeof (SCHEME_OBJECT)))), + Lowest_Allocated_Address, + Highest_Allocated_Address); /* Consistency check 2 */ - if (Heap == NULL) + if (Lowest_Allocated_Address == NULL) { fprintf (stderr, "%s (Setup_Memory): Not enough memory for this configuration.\n", @@ -2201,19 +2247,6 @@ DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size), /*NOTREACHED*/ } - Lowest_Allocated_Address = ((PTR) Heap); - Heap += HEAP_BUFFER_SPACE; - Heap = ((SCHEME_OBJECT *) (ALIGN_UP_TO_IO_PAGE (Heap))); - aligned_heap = Heap; - Constant_Space = (Heap + heap_size); - - /* - The two GC buffers are not included in the valid Scheme memory. - */ - - Highest_Allocated_Address = ((Constant_Space + constant_space_size - + real_stack_size) - 1); - /* Consistency check 3 */ test_value = (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address)); @@ -2234,24 +2267,9 @@ DEFUN (Setup_Memory, (heap_size, stack_size, constant_space_size), /*NOTREACHED*/ } - /* This does not use INITIAL_ALIGN_HEAP because it would - make Heap point to the previous GC_BUFFER frame. - INITIAL_ALIGN_HEAP should have its phase changed so that it would - be a NOP below, and constant space should use it too. - */ - - ALIGN_FLOAT (Heap); - ALIGN_FLOAT (Constant_Space); - heap_size = (Constant_Space - Heap); - constant_space_size = ((Highest_Allocated_Address - Constant_Space) - - real_stack_size); - saved_heap_size = ((long) heap_size); - - Heap_Bottom = Heap; Clear_Memory (heap_size, stack_size, constant_space_size); - INITIALIZE_GC_BUFFERS (1, - (Highest_Allocated_Address + 1), + (Highest_Allocated_Address - gc_buffer_allocation), (heap_size * (sizeof (SCHEME_OBJECT))), option_gc_read_overlap, option_gc_write_overlap, @@ -2349,7 +2367,7 @@ DEFUN (dump_and_reload_scan_buffer, (number_to_skip, success), long number_to_skip AND Boolean * success) { DUMP_BUFFER (scan_buffer, scan_position, gc_buffer_bytes, - success, "the scan buffer"); + success, "the scan buffer"); reload_scan_buffer (1 + number_to_skip); return (scan_buffer_bottom); } @@ -2624,7 +2642,7 @@ DEFUN_VOID (initialize_free_buffer) scan_position = -1L; scan_buffer = NULL; scan_buffer_bottom = NULL; - scan_buffer_top = (Highest_Allocated_Address + 2); + scan_buffer_top = Highest_Allocated_Address; /* Force first write to do an lseek. */ gc_file_current_position = -1; next_scan_buffer = NULL; @@ -2712,7 +2730,7 @@ DEFUN_VOID (pre_read_weak_pair_buffers) { pair_addr = (OBJECT_ADDRESS (next)); obj_addr = (OBJECT_ADDRESS (*pair_addr++)); - if (! (obj_addr >= Constant_Space)) + if (! (obj_addr < Constant_Top)) { position = (obj_addr - aligned_heap); position = (position >> gc_buffer_shift); @@ -2746,7 +2764,8 @@ DEFUN_VOID (pre_read_weak_pair_buffers) SCHEME_OBJECT DEFUN (read_newspace_address, (addr), SCHEME_OBJECT * addr) { - unsigned long position, offset; + long position; + unsigned long offset; SCHEME_OBJECT result; if ((addr >= Constant_Space) && (addr < Free_Constant)) @@ -2775,7 +2794,7 @@ DEFUN (read_newspace_address, (addr), SCHEME_OBJECT * addr) result = (* (scan_buffer_bottom + offset)); else if (position == free_position) result = (* (free_buffer_bottom + offset)); - else if ((position == (scan_position + gc_buffer_bytes)) + else if ((position == ((long) (scan_position + gc_buffer_bytes))) && scan_buffer_extended_p && ((read_overlap != 0) || (offset < gc_extra_buffer_size))) { @@ -2858,7 +2877,7 @@ DEFUN (guarantee_in_memory, (addr), SCHEME_OBJECT * addr) { long position, offset; - if (addr >= Constant_Space) + if (addr < Constant_Top) return (addr); position = (addr - aligned_heap); @@ -2918,7 +2937,7 @@ DEFUN (update_weak_pointer, (Temp), SCHEME_OBJECT Temp) case GC_Quadruple: case GC_Vector: Old = (OBJECT_ADDRESS (Temp)); - if (Old >= Constant_Space) + if (Old < Constant_Top) return (Temp); if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) @@ -2928,7 +2947,7 @@ DEFUN (update_weak_pointer, (Temp), SCHEME_OBJECT Temp) case GC_Compiled: Old = (OBJECT_ADDRESS (Temp)); - if (Old >= Constant_Space) + if (Old < Constant_Top) return (Temp); Compiled_BH (false, { return Temp; }); return (SHARP_F); @@ -3001,6 +3020,69 @@ DEFUN_VOID (fix_weak_chain_2) return; } +long +DEFUN (GC_relocate_root, (free_buffer_ptr), SCHEME_OBJECT ** free_buffer_ptr) +{ + long skip; + SCHEME_OBJECT * initial_free_buffer, * free_buffer; + + free_buffer = * free_buffer_ptr; + initial_free_buffer = free_buffer; + SET_MEMTOP (Heap_Top - GC_Reserve); + + /* Save the microcode registers so that they can be relocated */ + + 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++ = (Get_Current_Stacklet ()); + *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ? + SHARP_F : + (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, + Prev_Restore_History_Stacklet))); + + *free_buffer++ = Current_State_Point; + *free_buffer++ = Fluid_Bindings; + skip = (free_buffer - initial_free_buffer); + if (free_buffer >= free_buffer_top) + free_buffer = + (dump_and_reset_free_buffer ((free_buffer - free_buffer_top), + NULL)); + * free_buffer_ptr = free_buffer; + return (skip); +} + +void +DEFUN (GC_end_root_relocation, (root, root2), + SCHEME_OBJECT * root AND SCHEME_OBJECT * root2) +{ + /* 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 + (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2)))); + + History = (OBJECT_ADDRESS (*root++)); + Set_Current_Stacklet (* root); + root += 1; + if ((* root) != SHARP_F) + Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*root++)); + else + { + Prev_Restore_History_Stacklet = NULL; + root += 1; + } + Current_State_Point = *root++; + Fluid_Bindings = *root++; + Free_Stacklets = NULL; + COMPILER_TRANSPORT_END (); + CLEAR_INTERRUPT (INT_GC); + return; +} + /* Here is the set up for the full garbage collection: - First it makes the constant space and stack into one large area @@ -3028,49 +3110,35 @@ DEFUN (GC, (weak_pair_transport_initialized_p), SCHEME_OBJECT * root, * result, * end_of_constant_area, the_precious_objects, * root2, - * free_buffer, * block_start, * initial_free_buffer; + * free_buffer, * block_start, * saved_ctop; + long skip_length; + + saved_ctop = Constant_Top; + if (((Constant_Top - Free_Constant) < CONSTANT_SPACE_FUDGE) + && (update_allocator_parameters (Free_Constant))) + Constant_Top = saved_ctop; - if (!weak_pair_transport_initialized_p) - initialize_weak_pair_transport (Free_Constant + 2); + if (! weak_pair_transport_initialized_p) + initialize_weak_pair_transport (Stack_Bottom); free_buffer = (initialize_free_buffer ()); Free = Heap_Bottom; + ALIGN_FLOAT (Free); block_start = aligned_heap; - if (block_start != Free) - free_buffer += (Free - block_start); - initial_free_buffer = free_buffer; - - SET_MEMTOP (Heap_Top - GC_Reserve); - - /* Save the microcode registers so that they can be relocated */ + skip_length = (Free - block_start); + free_buffer += skip_length; Terminate_Old_Stacklet (); SEAL_CONSTANT_SPACE (); - end_of_constant_area = (CONSTANT_SPACE_SEAL ()); - root = Free; + end_of_constant_area = (CONSTANT_AREA_END ()); 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++ = Get_Current_Stacklet (); - *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ? - SHARP_F : - (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, - Prev_Restore_History_Stacklet))); - - *free_buffer++ = Current_State_Point; - *free_buffer++ = Fluid_Bindings; - Free += (free_buffer - initial_free_buffer); + root = Free; - if (free_buffer >= free_buffer_top) - free_buffer = - (dump_and_reset_free_buffer ((free_buffer - free_buffer_top), - NULL)); /* The 4 step GC */ - result = (GCLoop (Constant_Space, &free_buffer, &Free)); + Free += (GC_relocate_root (&free_buffer)); + + result = (GCLoop ((CONSTANT_AREA_START ()), &free_buffer, &Free)); if (result != end_of_constant_area) { fprintf (stderr, @@ -3081,8 +3149,7 @@ DEFUN (GC, (weak_pair_transport_initialized_p), /*NOTREACHED*/ } - result = (GCLoop (((initialize_scan_buffer (block_start)) - + (Heap_Bottom - block_start)), + result = (GCLoop (((initialize_scan_buffer (block_start)) + skip_length), &free_buffer, &Free)); if (free_buffer != result) { @@ -3119,80 +3186,55 @@ DEFUN (GC, (weak_pair_transport_initialized_p), final_reload (block_start, (Free - block_start), "new space"); fix_weak_chain_2 (); - /* 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 - (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2)))); - - History = (OBJECT_ADDRESS (*root++)); - - Set_Current_Stacklet (*root); - root += 1; - if (*root == SHARP_F) - { - Prev_Restore_History_Stacklet = NULL; - root += 1; - } - else - Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*root++)); - Current_State_Point = *root++; - Fluid_Bindings = *root++; - Free_Stacklets = NULL; - COMPILER_TRANSPORT_END (); - CLEAR_INTERRUPT (INT_GC); + GC_end_root_relocation (root, root2); + Constant_Top = saved_ctop; + SET_CONSTANT_TOP (); return; } - + /* (GARBAGE-COLLECT SLACK) Requests a garbage collection leaving the specified amount of slack - for the top of heap check on the next GC. The primitive ends by invoking - the GC daemon if there is one. + for the top of heap check on the next GC. The primitive ends by + invoking the GC daemon if there is one. */ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) { - long new_gc_reserve; extern unsigned long gc_counter; - SCHEME_OBJECT GC_Daemon_Proc; + SCHEME_OBJECT daemon; 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 (); + GC_Reserve = (arg_nonnegative_integer (1)); + POP_PRIMITIVE_FRAME (1); + ENTER_CRITICAL_SECTION ("garbage collector"); run_pre_gc_hooks (); gc_counter += 1; - GC_Reserve = new_gc_reserve; GC (0); run_post_gc_hooks (); - POP_PRIMITIVE_FRAME (1); - GC_Daemon_Proc = (Get_Fixed_Obj_Slot (GC_Daemon)); + daemon = (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); - /*NOTREACHED*/ - } - Will_Push (CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); + Will_Push (CONTINUATION_SIZE); Store_Return (RC_NORMAL_GC_DONE); Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); Save_Cont (); - STACK_PUSH (GC_Daemon_Proc); + Pushed (); + + RENAME_CRITICAL_SECTION ("garbage collector daemon"); + if (daemon == SHARP_F) + PRIMITIVE_ABORT (PRIM_POP_RETURN); + /*NOTREACHED*/ + + Will_Push (2); + STACK_PUSH (daemon); STACK_PUSH (STACK_FRAME_HEADER); Pushed (); PRIMITIVE_ABORT (PRIM_APPLY); - /* The following comment is by courtesy of LINT, your friendly sponsor. */ /*NOTREACHED*/ } @@ -3283,7 +3325,7 @@ DEFUN_VOID (statistics_read) signal_error_from_primitive (ERR_UNDEFINED_PRIMITIVE); vector = (VECTOR_ARG (1)); - if (len != (VECTOR_LENGTH (vector))) + if (len != ((int) (VECTOR_LENGTH (vector)))) error_bad_range_arg (1); for (cntr = 0, ptr = &all_gc_statistics[0], scan = (VECTOR_LOC (vector, 0)); diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c index f19e081c1..959bed4ef 100644 --- a/v7/src/microcode/bchpur.c +++ b/v7/src/microcode/bchpur.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bchpur.c,v 9.61 1993/08/23 02:22:09 gjr Exp $ +$Id: bchpur.c,v 9.62 1993/10/14 19:13:42 gjr Exp $ Copyright (c) 1987-1992 Massachusetts Institute of Technology @@ -57,8 +57,8 @@ MIT in each case. */ #define relocate_indirect_setup() \ { \ - Old = OBJECT_ADDRESS (Temp); \ - if (Old >= Low_Constant) \ + Old = (OBJECT_ADDRESS (Temp)); \ + if (Old < low_heap) \ continue; \ if (BROKEN_HEART_P (* Old)) \ continue; \ @@ -81,12 +81,12 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), int purify_mode) { fast SCHEME_OBJECT - * To, * Old, Temp, * Low_Constant, + * To, * Old, Temp, * low_heap, * To_Address, New_Address; To = (* To_ptr); To_Address = (* To_Address_ptr); - Low_Constant = Constant_Space; + low_heap = Constant_Top; for ( ; Scan != To; Scan++) { @@ -94,16 +94,6 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), Switch_by_GC_Type (Temp) { case TC_BROKEN_HEART: - if (Temp != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Scan))) - { - 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. */ @@ -296,6 +286,8 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), } case_Cell: + if (purify_mode == CONSTANT_COPY) + break; relocate_normal_pointer (copy_cell(), 1); case TC_REFERENCE_TRAP: @@ -312,10 +304,14 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), copy_vector (NULL); relocate_indirect_end (); } - /* Fall through. */ + else + goto really_purify_pair; case_Fasdump_Pair: purify_pair: + if (purify_mode == CONSTANT_COPY) + break; + really_purify_pair: relocate_normal_pointer (copy_pair(), 2); case TC_WEAK_CONS: @@ -326,12 +322,18 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), case TC_VARIABLE: case_Triple: + if (purify_mode == CONSTANT_COPY) + break; relocate_normal_pointer (copy_triple(), 3); case_Quadruple: + if (purify_mode == CONSTANT_COPY) + break; relocate_normal_pointer (copy_quadruple(), 4); case TC_BIG_FLONUM: + if (purify_mode == CONSTANT_COPY) + break; relocate_flonum_setup (); goto Move_Vector; @@ -339,15 +341,21 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), case TC_ENVIRONMENT: if (purify_mode == PURE_COPY) break; - /* Fall through */ + else + goto really_purify_vector; case_Purify_Vector: + if (purify_mode == CONSTANT_COPY) + break; + really_purify_vector: relocate_normal_setup (); Move_Vector: copy_vector (NULL); relocate_normal_end (); case TC_FUTURE: + if (purify_mode == CONSTANT_COPY) + break; relocate_normal_setup(); if (!(Future_Spliceable (Temp))) goto Move_Vector; @@ -361,7 +369,6 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), case_Non_Pointer: break; - } } end_purifyloop: @@ -369,7 +376,7 @@ end_purifyloop: (* To_Address_ptr) = To_Address; return (Scan); } - + /* This is not paranoia! The two words in the header may overflow the free buffer. */ @@ -377,8 +384,8 @@ end_purifyloop: static SCHEME_OBJECT * DEFUN (purify_header_overflow, (free_buffer), SCHEME_OBJECT * free_buffer) { - SCHEME_OBJECT * scan_buffer; long delta; + SCHEME_OBJECT * scan_buffer; delta = (free_buffer - free_buffer_top); free_buffer = (dump_and_reset_free_buffer (delta, NULL)); @@ -393,102 +400,216 @@ DEFUN (purify_header_overflow, (free_buffer), SCHEME_OBJECT * free_buffer) return (free_buffer); } -static SCHEME_OBJECT -DEFUN (purify, (object, flag), - SCHEME_OBJECT object AND SCHEME_OBJECT flag) +static void +DEFUN (purify, (object, purify_mode), + SCHEME_OBJECT object AND Boolean purify_mode) { long length, pure_length, delta; SCHEME_OBJECT * result, * free_buffer_ptr, - * old_free, * block_start, - * scan_start, * new_free; + * old_free_const, * block_start, + * scan_start, * new_free_const, * pending_scan, + * root, * root2, the_precious_objects, + * saved_const_top, * saved_vsp, * saved_sbb, * saved_sbt; + extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *)); - initialize_weak_pair_transport (Constant_Top); + run_pre_gc_hooks (); + STACK_SANITY_CHECK ("PURIFY"); + initialize_weak_pair_transport (Stack_Bottom); free_buffer_ptr = (initialize_free_buffer ()); - old_free = Free_Constant; - new_free = old_free; - block_start = ((SCHEME_OBJECT *) (ALIGN_DOWN_TO_IO_PAGE (old_free))); - delta = (old_free - block_start); - if (delta != 0) - { - fast SCHEME_OBJECT *ptr, *ptrend; - - for (ptr = block_start, ptrend = old_free; ptr != ptrend; ) - * free_buffer_ptr++ = *ptr++; - } - - new_free += 2; + Terminate_Old_Stacklet (); + SEAL_CONSTANT_SPACE (); + the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects)); + + Constant_Top = Free_Constant; + old_free_const = Free_Constant; + new_free_const = old_free_const; + block_start = ((SCHEME_OBJECT *) (ALIGN_DOWN_TO_IO_PAGE (old_free_const))); + delta = (old_free_const - block_start); + + free_buffer_ptr += delta; + new_free_const += 2; * free_buffer_ptr++ = SHARP_F; /* Pure block header. */ * free_buffer_ptr++ = object; if (free_buffer_ptr >= free_buffer_top) free_buffer_ptr = (dump_and_reset_free_buffer ((free_buffer_ptr - free_buffer_top), NULL)); - if (flag != SHARP_T) + if (! purify_mode) pure_length = 3; else { scan_start = ((initialize_scan_buffer (block_start)) + delta); result = (purifyloop (scan_start, &free_buffer_ptr, - &new_free, PURE_COPY)); + &new_free_const, PURE_COPY)); if (result != free_buffer_ptr) gc_death (TERM_BROKEN_HEART, "purify: pure copy ended too early", result, free_buffer_ptr); /*NOTREACHED*/ - pure_length = ((new_free - old_free) + 1); + pure_length = ((new_free_const - old_free_const) + 1); } - new_free += 2; - * free_buffer_ptr++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); + * free_buffer_ptr++ = + (purify_mode + ? (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, new_free_const)) + : (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1))); * free_buffer_ptr++ = (MAKE_OBJECT (CONSTANT_PART, pure_length)); + new_free_const += 2; if (free_buffer_ptr >= free_buffer_top) free_buffer_ptr = (purify_header_overflow (free_buffer_ptr)); scan_start = ((initialize_scan_buffer (block_start)) + delta); - if (flag == SHARP_T) - result = (purifyloop (scan_start, &free_buffer_ptr, - &new_free, CONSTANT_COPY)); + if (! purify_mode) + result = (GCLoop (scan_start, &free_buffer_ptr, &new_free_const)); else - result = (GCLoop (scan_start, &free_buffer_ptr, &new_free)); + { + SCHEME_OBJECT * pure_area_limit = (new_free_const - 2); + + result = (purifyloop (scan_start, &free_buffer_ptr, + &new_free_const, CONSTANT_COPY)); + if ((* result) != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, pure_area_limit))) + gc_death (TERM_BROKEN_HEART, + "purify: constant forwarding ended too early", + result, free_buffer_ptr); + * result = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); + result = (GCLoop ((result + 2), &free_buffer_ptr, &new_free_const)); + } if (result != free_buffer_ptr) gc_death (TERM_BROKEN_HEART, "purify: constant copy ended too early", result, free_buffer_ptr); /*NOTREACHED*/ - new_free += 2; - length = (new_free - old_free); + pending_scan = result; + new_free_const += 2; + length = (new_free_const - old_free_const); * free_buffer_ptr++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); * free_buffer_ptr++ = (MAKE_OBJECT (END_OF_BLOCK, (length - 1))); if (free_buffer_ptr >= free_buffer_top) - free_buffer_ptr = (purify_header_overflow (free_buffer_ptr)); - end_transport (NULL); + free_buffer_ptr = + (dump_and_reset_free_buffer ((free_buffer_ptr - free_buffer_top), + NULL)); - if (!(TEST_CONSTANT_TOP (new_free))) + Free_Constant = new_free_const; + if (! (update_allocator_parameters (Free_Constant))) gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL); /*NOTREACHED*/ - final_reload (block_start, - (new_free - block_start), - "the new constant space block"); + while (! (FLOATING_ALIGNED_P (Free_Constant))) + { + *free_buffer_ptr++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); + Free_Constant++; + } - * old_free++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length)); - * old_free = (MAKE_OBJECT (PURE_PART, (length - 1))); - Free_Constant = new_free; - SET_CONSTANT_TOP (); + if (Constant_Top > Free_Constant) + { + /* This assumes that the distance between the new constant space + and the new free constant is smaller than a bufferfull. + */ + + long bump = (Constant_Top - Free_Constant); + + *free_buffer_ptr = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, + (bump - 1))); + free_buffer_ptr += bump; + if (free_buffer_ptr >= free_buffer_top) + free_buffer_ptr = + (dump_and_reset_free_buffer ((free_buffer_ptr - free_buffer_top), + NULL)); + } - GC (1); - return (SHARP_T); -} + while (! (FLOATING_ALIGNED_P (Free))) + { + *free_buffer_ptr++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); + Free++; + } -/* Stub. Not needed by this version. Terminates Scheme if invoked. */ + root = Free; + Free += (GC_relocate_root (&free_buffer_ptr)); -SCHEME_OBJECT -DEFUN (Purify_Pass_2, (info), SCHEME_OBJECT info) -{ - gc_death (TERM_EXIT, "Purify_Pass_2 invoked", NULL, NULL); - /*NOTREACHED*/ + saved_const_top = Constant_Top; + saved_vsp = virtual_scan_pointer; + saved_sbb = scan_buffer_bottom; + saved_sbt = scan_buffer_top; + + virtual_scan_pointer = ((SCHEME_OBJECT *) NULL); + scan_buffer_bottom = ((SCHEME_OBJECT *) NULL); + scan_buffer_top = Highest_Allocated_Address; + Constant_Top = old_free_const; + + result = (GCLoop ((CONSTANT_AREA_START ()), &free_buffer_ptr, &Free)); + if (result != old_free_const) + { + fprintf (stderr, + "\n%s (purify): The Constant Space scan ended too early.\n", + scheme_program_name); + fflush (stderr); + Microcode_Termination (TERM_EXIT); + /*NOTREACHED*/ + } + + virtual_scan_pointer = saved_vsp; + scan_buffer_bottom = saved_sbb; + scan_buffer_top = saved_sbt; + + result = (GCLoop (pending_scan, &free_buffer_ptr, &Free)); + if (free_buffer_ptr != result) + { + fprintf (stderr, + "\n%s (GC): The Heap scan ended too early.\n", + scheme_program_name); + fflush (stderr); + Microcode_Termination (TERM_EXIT); + /*NOTREACHED*/ + } + + root2 = Free; + *free_buffer_ptr++ = the_precious_objects; + Free += (free_buffer_ptr - result); + if (free_buffer_ptr >= free_buffer_top) + free_buffer_ptr = + (dump_and_reset_free_buffer ((free_buffer_ptr - free_buffer_top), NULL)); + + result = (GCLoop (result, &free_buffer_ptr, &Free)); + if (free_buffer_ptr != result) + { + fprintf (stderr, + "\n%s (GC): The Precious Object scan ended too early.\n", + scheme_program_name); + fflush (stderr); + Microcode_Termination (TERM_EXIT); + /*NOTREACHED*/ + } + end_transport (NULL); + fix_weak_chain_1 (); + + /* Load new space into memory carefully to prevent the shared + buffer from losing any values. + */ + + { + long counter; + + for (counter = 0; counter < delta; counter++) + scan_buffer_bottom[counter] = block_start[counter]; + + final_reload (block_start, (Free - block_start), "new space"); + + for (counter = 0; counter < delta; counter++) + block_start[counter] = scan_buffer_bottom[counter]; + } + fix_weak_chain_2 (); + + GC_end_root_relocation (root, root2); + + * old_free_const++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, + pure_length)); + * old_free_const = (MAKE_OBJECT (PURE_PART, (length - 1))); + Constant_Top = saved_const_top; + SEAL_CONSTANT_SPACE (); + run_post_gc_hooks (); + return; } /* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN) @@ -498,19 +619,20 @@ DEFUN (Purify_Pass_2, (info), SCHEME_OBJECT info) To purify an object we just copy it into Pure Space in two parts with the appropriate headers and footers. The actual - copying is done by PurifyLoop above. + copying is done by purifyloop above. Once the copy is complete we run a full GC which handles the broken hearts which now point into pure space. This primitive does not return normally. It always escapes into the interpreter because some of its cached registers (eg. History) - have changed. */ + have changed. +*/ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) { - SCHEME_OBJECT object, daemon; - SCHEME_OBJECT result; + Boolean purify_mode; + SCHEME_OBJECT object, result, daemon; PRIMITIVE_HEADER (3); PRIMITIVE_CANONICALIZE_CONTEXT (); @@ -518,39 +640,34 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) Save_Time_Zone (Zone_Purify); TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object); CHECK_ARG (2, BOOLEAN_P); + purify_mode = (BOOLEAN_ARG (2)); GC_Reserve = (arg_nonnegative_integer (3)); - ENTER_CRITICAL_SECTION ("purify"); - run_pre_gc_hooks (); - { - SCHEME_OBJECT purify_result; - SCHEME_OBJECT words_free; - - purify_result = (purify (object, (ARG_REF (2)))); - words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); - result = (MAKE_POINTER_OBJECT (TC_LIST, Free)); - (* Free++) = purify_result; - (* Free++) = words_free; - } - run_post_gc_hooks (); POP_PRIMITIVE_FRAME (3); + + ENTER_CRITICAL_SECTION ("purify"); + purify (object, purify_mode); + result = (MAKE_POINTER_OBJECT (TC_LIST, Free)); + Free += 2; + Free[-2] = SHARP_T; + Free[-1] = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); + + Will_Push (CONTINUATION_SIZE); + Store_Return (RC_NORMAL_GC_DONE); + Store_Expression (result); + Save_Cont (); + Pushed (); + + RENAME_CRITICAL_SECTION ("purify daemon"); daemon = (Get_Fixed_Obj_Slot (GC_Daemon)); if (daemon == SHARP_F) - { - Val = result; - EXIT_CRITICAL_SECTION ({}); PRIMITIVE_ABORT (PRIM_POP_RETURN); /*NOTREACHED*/ - } - RENAME_CRITICAL_SECTION ("purify daemon"); - Will_Push (CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1)); - Store_Expression (result); - Store_Return (RC_NORMAL_GC_DONE); - Save_Cont (); + Will_Push (2); STACK_PUSH (daemon); STACK_PUSH (STACK_FRAME_HEADER); Pushed (); - PRIMITIVE_ABORT(PRIM_APPLY); + PRIMITIVE_ABORT (PRIM_APPLY); /*NOTREACHED*/ } diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c index 2fd83bfa2..7153d4a9e 100644 --- a/v7/src/microcode/bintopsb.c +++ b/v7/src/microcode/bintopsb.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bintopsb.c,v 9.55 1992/10/31 23:41:13 jinx Exp $ +$Id: bintopsb.c,v 9.56 1993/10/14 19:16:56 gjr Exp $ Copyright (c) 1987-1992 Massachusetts Institute of Technology @@ -822,9 +822,7 @@ DEFUN (relocate, (object), if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) - { result += Heap_Relocation; - } #if FALSE @@ -832,16 +830,12 @@ DEFUN (relocate, (object), else if (( the_datum >= Const_Base) && (the_datum < Dumped_Constant_Top)) - { result += Constant_Relocation; - } #endif /* false */ else - { out_of_range_pointer(object); - } return (result); } @@ -911,7 +905,7 @@ DEFUN (upgrade_primitive, (prim), SCHEME_OBJECT * DEFUN (setup_primitive_upgrade, (Heap), - SCHEME_OBJECT *Heap) + SCHEME_OBJECT * Heap) { fast long count, length; SCHEME_OBJECT *old_prims_vector; @@ -1350,7 +1344,10 @@ DEFUN_VOID (do_it) { /* Load the Data */ - SCHEME_OBJECT *Heap, *Storage; + SCHEME_OBJECT + * Heap, + * Lowest_Allocated_Address, + * Highest_Allocated_Address; long Initial_Free; switch (Read_Header ()) @@ -1467,7 +1464,9 @@ DEFUN_VOID (do_it) /* This is way larger than needed, but... what the hell? */ - Size = ((3 * (Heap_Count + Const_Count)) + + Size = ((TRAP_MAX_IMMEDIATE + 1) + + ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))) + + (3 * (Heap_Count + Const_Count)) + (NROOTS + 1) + (upgrade_primitives_p ? (3 * PRIMITIVE_UPGRADE_SPACE) : @@ -1476,9 +1475,11 @@ DEFUN_VOID (do_it) (2 * (Heap_Count + Const_Count)) : 0)); - ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE); + ALLOCATE_HEAP_SPACE (Size, + Lowest_Allocated_Address, + Highest_Allocated_Address); - if (Heap == ((SCHEME_OBJECT *) 0)) + if (Lowest_Allocated_Address == ((SCHEME_OBJECT *) NULL)) { fprintf (stderr, "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n", @@ -1487,9 +1488,8 @@ DEFUN_VOID (do_it) } } - Storage = Heap; - Heap += HEAP_BUFFER_SPACE; - INITIAL_ALIGN_FLOAT (Heap); + Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1)); + ALIGN_FLOAT (Heap); if ((Load_Data (Heap_Count, Heap)) != Heap_Count) { fprintf (stderr, "%s: Could not load the heap's contents.\n", @@ -1513,15 +1513,11 @@ DEFUN_VOID (do_it) compiled_entry_table_end = compiled_entry_table; if (allow_compiled_p) - { compiled_entry_table_end += (2 * (Heap_Count + Const_Count)); - } primitive_table = compiled_entry_table_end; if (upgrade_primitives_p) - { primitive_table_end = (setup_primitive_upgrade (primitive_table)); - } else { fast SCHEME_OBJECT *table; @@ -1744,7 +1740,7 @@ DEFUN_VOID (do_it) } } fflush (portable_file); - free ((char *) Storage); + free ((char *) Lowest_Allocated_Address); } } diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index 2fbca582f..93349f182 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: boot.c,v 9.84 1993/08/24 06:07:52 cph Exp $ +$Id: boot.c,v 9.85 1993/10/14 19:20:09 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -515,9 +515,10 @@ DEFUN (gc_death, (code, message, scan, free), void DEFUN (stack_death, (name), CONST char * name) { - outf_fatal ("\n%s: Constant space is no longer sealed!\n", - name); - outf_fatal ("Perhaps a runaway recursion has overflowed the stack.\n"); + outf_fatal + ("\n%s: The stack has overflowed and overwritten adjacent memory.\n", + name); + outf_fatal ("This was probably caused by a runaway recursion.\n"); Microcode_Termination (TERM_STACK_OVERFLOW); /*NOTREACHED*/ } diff --git a/v7/src/microcode/default.h b/v7/src/microcode/default.h index 694de5bea..cde246753 100644 --- a/v7/src/microcode/default.h +++ b/v7/src/microcode/default.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: default.h,v 9.39 1992/09/26 02:54:57 cph Exp $ +$Id: default.h,v 9.40 1993/10/14 19:19:55 gjr Exp $ Copyright (c) 1988-1992 Massachusetts Institute of Technology @@ -67,36 +67,48 @@ MIT in each case. */ Fixed_Objects = Save_FO #endif - /* Atomic swapping hook. Used extensively. */ #ifndef SWAP_POINTERS -#define SWAP_POINTERS(locative, object, target) \ +#define SWAP_POINTERS(locative, object, target) do \ { \ (target) = (* (locative)); \ (* (locative)) = (object); \ -} +} while (0) #endif -#ifndef USE_STACKLETS - -#define Absolute_Stack_Base Constant_Top - -#ifndef Initialize_Stack -#define Initialize_Stack() \ -do \ +#ifndef INITIALIZE_STACK +#define INITIALIZE_STACK() do \ { \ - Stack_Top = Highest_Allocated_Address; \ Stack_Pointer = Stack_Top; \ - SET_STACK_GUARD (Absolute_Stack_Base + STACK_GUARD_SIZE); \ + SET_STACK_GUARD (Stack_Bottom + STACK_GUARD_SIZE); \ + * Stack_Bottom \ + = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Bottom)); \ } while (0) #endif -#endif /* USE_STACKLETS */ +#ifndef STACK_ALLOCATION_SIZE +#define STACK_ALLOCATION_SIZE(Stack_Blocks) (Stack_Blocks) +#endif + +#ifndef STACK_OVERFLOWED_P +#define STACK_OVERFLOWED_P() \ + ((* Stack_Bottom) != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Bottom))) +#endif + +#ifndef STACK_SANITY_CHECK +#define STACK_SANITY_CHECK(name) do \ +{ \ + extern void EXFUN (stack_death, (CONST char *)); \ + \ + if (STACK_OVERFLOWED_P ()) \ + stack_death (name); \ + /*NOTREACHED */ \ +} while (0) +#endif #ifndef SET_CONSTANT_TOP -#define SET_CONSTANT_TOP() \ -do \ +#define SET_CONSTANT_TOP() do \ { \ ALIGN_FLOAT (Free_Constant); \ SEAL_CONSTANT_SPACE (); \ @@ -107,17 +119,19 @@ do \ #define TEST_CONSTANT_TOP(New_Top) ((New_Top) <= Constant_Top) #endif -#ifndef STACK_SANITY_CHECK -#define STACK_SANITY_CHECK(name) \ -do \ +#ifndef CONSTANT_AREA_END +#define CONSTANT_AREA_END() Free_Constant +#endif + +#ifndef CONSTANT_AREA_START +#define CONSTANT_AREA_START() Stack_Pointer +#endif CONSTANT_AREA_START + +#ifndef SEAL_CONSTANT_SPACE +#define SEAL_CONSTANT_SPACE() do \ { \ - if (!(CONSTANT_SPACE_SEALED ())) \ - { \ - extern void EXFUN (stack_death, (CONST char *)); \ - \ - stack_death (name); \ - /*NOTREACHED */ \ - } \ + * Free_Constant = \ + (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant)); \ } while (0) #endif @@ -156,9 +170,11 @@ do \ #endif #ifndef Fasdump_Free_Calc -#define Fasdump_Free_Calc(NewFree, NewMemtop, ignored) \ - NewFree = Unused_Heap; \ - NewMemTop = Unused_Heap_Top +#define Fasdump_Free_Calc(NewFree, NewMemtop, ignored) do \ +{ \ + NewFree = Unused_Heap_Bottom; \ + NewMemTop = Unused_Heap_Top; \ +} while (0) #endif /* Used in interpret.c */ diff --git a/v7/src/microcode/dostrap.c b/v7/src/microcode/dostrap.c index ba9725093..dc2d142ca 100644 --- a/v7/src/microcode/dostrap.c +++ b/v7/src/microcode/dostrap.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: dostrap.c,v 1.4 1993/07/17 03:37:05 gjr Exp $ +$Id: dostrap.c,v 1.5 1993/10/14 19:21:13 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -117,17 +117,13 @@ DEFUN (trap_handler, (message, trapno, info, scp), struct FULL_SIGCONTEXT * scp) { int code = ((SIGINFO_VALID_P (info)) ? (SIGINFO_CODE (info)) : 0); - Boolean constant_space_broken = (!(CONSTANT_SPACE_SEALED ())); + Boolean stack_overflowed_p = (STACK_OVERFLOWED_P ()); enum trap_state old_trap_state = trap_state; if (old_trap_state == trap_state_exitting_hard) - { _exit (1); - } else if (old_trap_state == trap_state_exitting_soft) - { trap_immediate_termination (); - } trap_state = trap_state_trapped; if (WITHIN_CRITICAL_SECTION_P ()) { @@ -137,17 +133,17 @@ DEFUN (trap_handler, (message, trapno, info, scp), fprintf (stdout, ">> [exception %d (%s), code %d = 0x%x]\n", trapno, (find_trap_name (trapno)), code, code); } - else if (constant_space_broken || (old_trap_state != trap_state_recover)) + else if (stack_overflowed_p || (old_trap_state != trap_state_recover)) { fprintf (stdout, "\n>> A %s (%d) has occurred.\n", message, trapno); fprintf (stdout, ">> [exception %d (%s), code %d = 0x%x]\n", trapno, (find_trap_name (trapno)), code, code); } - if (constant_space_broken) + if (stack_overflowed_p) { - fputs (">> Constant space has been overwritten.\n", stdout); - fputs (">> Probably a runaway recursion has overflowed the stack.\n", + fputs (">> The stack has overflowed overwriting adjacent memory.\n", stdout); + fputs (">> This was probably caused by a runaway recursion.\n", stdout); } fflush (stdout); @@ -175,7 +171,7 @@ DEFUN (trap_handler, (message, trapno, info, scp), else trap_immediate_termination (); case trap_state_recover: - if ((WITHIN_CRITICAL_SECTION_P ()) || constant_space_broken) + if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p) { fputs (">> Successful recovery is unlikely.\n", stdout); break; @@ -430,7 +426,7 @@ DEFUN (setup_trap_frame, (trapno, info, scp, trinfo, new_stack_pointer), trap_code = (find_trap_code_name (trapno, info, scp)); if (!stack_recovered_p) { - Initialize_Stack (); + INITIALIZE_STACK (); Will_Push (CONTINUATION_SIZE); Store_Return (RC_END_OF_COMPUTATION); Store_Expression (SHARP_F); @@ -634,7 +630,7 @@ DEFUN (continue_from_trap, (trapno, info, scp), && ((scp->sc_ss & 0xffff) == scheme_ss))) && ((scp->sc_ds & 0xffff) == (initial_C_ds & 0xffff)) && ((scheme_sp < ((long) Stack_Top)) && - (scheme_sp >= ((long) Absolute_Stack_Base)) && + (scheme_sp >= ((long) Stack_Bottom)) && ((scheme_sp & STACK_ALIGNMENT_MASK) == 0))); new_stack_pointer = @@ -643,7 +639,7 @@ DEFUN (continue_from_trap, (trapno, info, scp), : ((pc_in_C && ((scp->sc_ss & 0xffff) == (initial_C_ss & 0xffff)) && (Stack_Pointer < Stack_Top) - && (Stack_Pointer > Absolute_Stack_Base)) + && (Stack_Pointer > Stack_Bottom)) ? Stack_Pointer : ((SCHEME_OBJECT *) 0))); diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h index f149a2015..eef496e3c 100644 --- a/v7/src/microcode/extern.h +++ b/v7/src/microcode/extern.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: extern.h,v 9.50 1993/06/24 04:44:10 gjr Exp $ +$Id: extern.h,v 9.51 1993/10/14 19:14:51 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -93,24 +93,24 @@ extern SCHEME_OBJECT Registers []; #endif extern SCHEME_OBJECT - * Ext_History, /* History register */ - * Free, /* Next free word in heap */ - * MemTop, /* Top of heap space available */ - * Ext_Stack_Pointer, /* Next available slot in control stack */ - * Stack_Top, /* Top of control stack */ - * Stack_Guard, /* Guard area at end of stack */ - * Free_Stacklets, /* Free list of stacklets */ - * Constant_Space, /* Bottom of constant+pure space */ - * Free_Constant, /* Next free cell in constant+pure area */ - * Constant_Top, /* Top of constant+pure space */ - * Heap_Top, /* Top of current heap space */ - * Heap_Bottom, /* Bottom of current heap space */ - * Unused_Heap_Top, /* Top of unused heap for GC */ - * Unused_Heap, /* Bottom of unused heap for GC */ - * Local_Heap_Base, /* Per-processor CONSing area */ - * Heap, /* Bottom of all heap space */ - Current_State_Point, /* Dynamic state point */ - Fluid_Bindings; /* Fluid bindings AList */ + * MemTop, /* Top of free space available */ + * Free, /* Next free word in heap */ + * Heap_Top, /* Top of current heap */ + * Heap_Bottom, /* Bottom of current heap */ + * Unused_Heap_Top, /* Top of unused heap */ + * Unused_Heap_Bottom, /* Bottom of unused heap */ + * Stack_Guard, /* Guard area at end of stack */ + * Ext_Stack_Pointer, /* Next available slot in control stack */ + * Stack_Bottom, /* Bottom of control stack */ + * Stack_Top, /* Top of control stack */ + * Free_Constant, /* Next free word in constant space */ + * Constant_Space, /* Bottom of constant+pure space */ + * Constant_Top, /* Top of constant+pure space */ + * Local_Heap_Base, /* Per-processor CONSing area */ + * Free_Stacklets, /* Free list of stacklets */ + * Ext_History, /* History register */ + Current_State_Point, /* Dynamic state point */ + Fluid_Bindings; /* Fluid bindings AList */ /* Address of the most recent return code in the stack. This is only meaningful while in compiled code. *** This must be changed @@ -154,7 +154,7 @@ extern struct obstack scratch_obstack; extern long Heap_Size; extern long Constant_Size; extern long Stack_Size; -extern SCHEME_OBJECT * Highest_Allocated_Address; +extern SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address; /* Environment lookup utilities. */ extern long EXFUN (Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT)); @@ -230,7 +230,6 @@ extern void EXFUN /* Memory management utilities */ -extern SCHEME_OBJECT EXFUN (Purify_Pass_2, (SCHEME_OBJECT)); extern Boolean EXFUN (Pure_Test, (SCHEME_OBJECT *)); /* Interpreter utilities */ diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index 5af401e40..2410f9d71 100644 --- a/v7/src/microcode/fasdump.c +++ b/v7/src/microcode/fasdump.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fasdump.c,v 9.56 1993/08/21 01:54:24 gjr Exp $ +$Id: fasdump.c,v 9.57 1993/10/14 19:18:15 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -522,47 +522,57 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) long table_length; Boolean result; PRIMITIVE_HEADER (2); + Band_Dump_Permitted (); CHECK_ARG (1, INTERPRETER_APPLICABLE_P); CHECK_ARG (2, STRING_P); - if (Unused_Heap < Heap_Bottom) - { + if (Unused_Heap_Bottom < Heap_Bottom) /* Cause the image to be in the low heap, to increase the probability that no relocation is needed on reload. */ Primitive_GC (0); - } Primitive_GC_If_Needed (5); saved_free = Free; - Combination = MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free); + Combination = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free)); Free[COMB_1_FN] = (ARG_REF (1)); Free[COMB_1_ARG_1] = SHARP_F; Free += 2; - *Free++ = Combination; - *Free++ = compiler_utilities; - *Free = MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)); - Free++; /* Some compilers are TOO clever about this and increment Free + (* Free++) = Combination; + (* Free++) = compiler_utilities; + (* Free) = (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2))); + Free ++; /* Some compilers are TOO clever about this and increment Free before calculating Free-2! */ table_start = Free; - table_end = cons_whole_primitive_table(Free, Heap_Top, &table_length); + table_end = (cons_whole_primitive_table (Free, Heap_Top, &table_length)); if (table_end >= Heap_Top) - { result = false; - } else { + SCHEME_OBJECT * faligned_heap, * faligned_constant; CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0))); + OS_file_remove_link (filename); dump_channel = (OS_open_dump_file (filename)); if (dump_channel == NO_CHANNEL) error_bad_range_arg (2); - result = Write_File((Free - 1), - ((long) (Free - Heap_Bottom)), Heap_Bottom, - ((long) (Free_Constant - Constant_Space)), - Constant_Space, - table_start, table_length, - ((long) (table_end - table_start)), - (compiler_utilities != SHARP_F), true); - /* The and is short-circuit, so it must be done in this order. */ + + for (faligned_heap = Heap_Bottom; + (! (FLOATING_ALIGNED_P (faligned_heap))); + faligned_heap += 1) + ; + + for (faligned_constant = Constant_Space; + (! (FLOATING_ALIGNED_P (faligned_constant))); + faligned_constant += 1) + ; + + result = (Write_File ((Free - 1), + ((long) (Free - faligned_heap)), + faligned_heap, + ((long) (Free_Constant - faligned_constant)), + faligned_constant, + table_start, table_length, + ((long) (table_end - table_start)), + (compiler_utilities != SHARP_F), true)); OS_channel_close_noerror (dump_channel); if (!result) OS_file_remove (filename); diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index 4a301506e..d73e3f688 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fasload.c,v 9.71 1993/08/22 20:25:13 gjr Exp $ +$Id: fasload.c,v 9.72 1993/10/14 19:17:45 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -118,21 +118,37 @@ DEFUN (read_channel_continue, (header, mode, repeat_p), if (Or2 (Reloc_Debug, File_Load_Debug)) print_fasl_information(); - if (!(TEST_CONSTANT_TOP (Free_Constant + Const_Count))) + if (! (TEST_CONSTANT_TOP (Free_Constant + Const_Count))) { - if (mode != MODE_CHANNEL) - OS_channel_close_noerror (load_channel); - signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG); - /*NOTREACHED*/ + extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *)); + + switch (mode) + { + case MODE_CHANNEL: + break; + + case MODE_BAND: + if (update_allocator_parameters (Free_Constant + Const_Count)) + { + SET_CONSTANT_TOP (); + ALIGN_FLOAT (Free); + break; + } + + default: + OS_channel_close_noerror (load_channel); + signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG); + /*NOTREACHED*/ + } } heap_length = (Heap_Count + Primitive_Table_Size + Primitive_Table_Length); if (GC_Check (heap_length)) { - if (repeat_p || - (heap_length == failed_heap_length) || - (mode == MODE_BAND)) + if (repeat_p + || (heap_length == failed_heap_length) + || (mode == MODE_BAND)) { if (mode != MODE_CHANNEL) OS_channel_close_noerror (load_channel); @@ -161,8 +177,8 @@ DEFUN (read_channel_continue, (header, mode, repeat_p), reentry_record[0] = (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, header)); suspend_primitive (CONT_FASLOAD, - ((sizeof (reentry_record)) / - (sizeof (SCHEME_OBJECT))), + ((sizeof (reentry_record)) + / (sizeof (SCHEME_OBJECT))), &reentry_record[0]); immediate_interrupt (); /*NOTREACHED*/ @@ -201,7 +217,7 @@ DEFUN (read_channel_start, (channel, mode), Tchannel channel AND int mode) /* NOTREACHED */ } - if ((Load_Data (FASL_HEADER_LENGTH, ((char *) (Free + 1)))) + if ((Load_Data (FASL_HEADER_LENGTH, ((char *) (Stack_Bottom + 1)))) != FASL_HEADER_LENGTH) { if (mode != MODE_CHANNEL) @@ -209,7 +225,7 @@ DEFUN (read_channel_start, (channel, mode), Tchannel channel AND int mode) signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA); } - read_channel_continue ((Free + 1), mode, false); + read_channel_continue ((Stack_Bottom + 1), mode, false); return; } @@ -225,8 +241,7 @@ DEFUN (read_file_start, (file_name, from_band_load), debug_edit_flags (); if (channel == NO_CHANNEL) error_bad_range_arg (1); - read_channel_start (channel, - (from_band_load ? MODE_BAND : MODE_FNAME)); + read_channel_start (channel, (from_band_load ? MODE_BAND : MODE_FNAME)); return; } @@ -310,9 +325,9 @@ relocation_type static Boolean Warned = false; static SCHEME_OBJECT * -DEFUN (Relocate, (P), long P) +DEFUN (relocate, (P), long P) { - SCHEME_OBJECT *Result; + SCHEME_OBJECT * Result; if ((P >= Heap_Base) && (P < Dumped_Heap_Top)) Result = ((SCHEME_OBJECT *) (P + heap_relocation)); @@ -338,35 +353,38 @@ DEFUN (Relocate, (P), long P) return (Result); } -#define Relocate_Into(Loc, P) (Loc) = Relocate(P) +#define RELOCATE relocate +#define RELOCATE_INTO(Loc, P) (Loc) = relocate(P) #else /* not ENABLE_DEBUGGING_TOOLS */ -#define Relocate_Into(Loc, P) \ +#define RELOCATE_INTO(Loc, P) do \ { \ - if ((P) < Dumped_Heap_Top) \ - (Loc) = ((SCHEME_OBJECT *) ((P) + heap_relocation)); \ - else if ((P) < Dumped_Constant_Top) \ - (Loc) = ((SCHEME_OBJECT *) ((P) + const_relocation)); \ + long _P = (P); \ + \ + if ((P >= Heap_Base) && (_P < Dumped_Heap_Top)) \ + (Loc) = ((SCHEME_OBJECT *) (_P + heap_relocation)); \ + else if ((P >= Const_Base) && (_P < Dumped_Constant_Top)) \ + (Loc) = ((SCHEME_OBJECT *) (_P + const_relocation)); \ else \ - (Loc) = ((SCHEME_OBJECT *) ((P) + stack_relocation)); \ -} + (Loc) = ((SCHEME_OBJECT *) (_P + stack_relocation)); \ +} while (0) #ifndef Conditional_Bug -#define Relocate(P) \ -((P < Const_Base) ? \ - ((SCHEME_OBJECT *) (P + heap_relocation)) : \ - ((P < Dumped_Constant_Top) ? \ - ((SCHEME_OBJECT *) (P + const_relocation)) : \ - ((SCHEME_OBJECT *) (P + stack_relocation)))) +#define RELOCATE(P) \ +((((P) >= Heap_Base) && ((P) < Dumped_Heap_Top)) \ + ? ((SCHEME_OBJECT *) ((P) + heap_relocation)) \ + : ((((P) >= Const_Base) && ((P) < Dumped_Constant_Top)) \ + ? ((SCHEME_OBJECT *) ((P) + const_relocation)) \ + : ((SCHEME_OBJECT *) ((P) + stack_relocation)))) #else /* Conditional_Bug */ -static SCHEME_OBJECT *Relocate_Temp; +static SCHEME_OBJECT * relocate_temp; -#define Relocate(P) \ - (Relocate_Into(Relocate_Temp, P), Relocate_Temp) +#define RELOCATE(P) \ + (RELOCATE_INTO (Relocate_Temp, P), relocate_temp) #endif /* Conditional_Bug */ #endif /* ENABLE_DEBUGGING_TOOLS */ @@ -383,7 +401,8 @@ DEFUN (primitive_dumped_number, (datum), unsigned long datum) return ((high_bits != 0) ? high_bits : datum); } -#define PRIMITIVE_DUMPED_NUMBER(prim) (primitive_dumped_number (OBJECT_DATUM (prim))) +#define PRIMITIVE_DUMPED_NUMBER(prim) \ + (primitive_dumped_number (OBJECT_DATUM (prim))) static void DEFUN (Relocate_Block, (Scan, Stop_At), @@ -417,7 +436,8 @@ DEFUN (Relocate_Block, (Scan, Stop_At), case TC_PCOMB0: *Scan++ = OBJECT_NEW_TYPE - (TC_PCOMB0, (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)])); + (TC_PCOMB0, + (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)])); break; case TC_MANIFEST_NM_VECTOR: @@ -451,7 +471,7 @@ DEFUN (Relocate_Block, (Scan, Stop_At), { address = (ADDRESS_TO_DATUM (SCHEME_ADDR_TO_ADDR ((SCHEME_OBJECT *) (* Scan)))); - *Scan++ = (ADDR_TO_SCHEME_ADDR (Relocate (address))); + *Scan++ = (ADDR_TO_SCHEME_ADDR (RELOCATE (address))); } break; } @@ -474,7 +494,7 @@ DEFUN (Relocate_Block, (Scan, Stop_At), word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr)); EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, Scan); address = (ADDRESS_TO_DATUM (SCHEME_ADDR_TO_ADDR (address))); - address = ((long) (Relocate (address))); + address = ((long) (RELOCATE (address))); STORE_OPERATOR_LINKAGE_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)), Scan); } @@ -514,7 +534,7 @@ DEFUN (Relocate_Block, (Scan, Stop_At), word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr)); EXTRACT_CLOSURE_ENTRY_ADDRESS (address, Scan); address = (ADDRESS_TO_DATUM (SCHEME_ADDR_TO_ADDR (address))); - address = ((long) (Relocate (address))); + address = ((long) (RELOCATE (address))); STORE_CLOSURE_ENTRY_ADDRESS ((ADDR_TO_SCHEME_ADDR (address)), Scan); } Scan = area_end; @@ -524,7 +544,7 @@ DEFUN (Relocate_Block, (Scan, Stop_At), #ifdef BYTE_INVERSION case TC_CHARACTER_STRING: - String_Inversion (Relocate (OBJECT_DATUM (Temp))); + String_Inversion (RELOCATE (OBJECT_DATUM (Temp))); goto normal_pointer; #endif @@ -545,7 +565,7 @@ DEFUN (Relocate_Block, (Scan, Stop_At), #endif address = (OBJECT_DATUM (Temp)); *Scan++ = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (Temp)), - (Relocate (address)))); + (RELOCATE (address)))); break; } } @@ -742,8 +762,8 @@ DEFUN (load_file, (mode), int mode) FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, Orig_Constant, Constant_End); - Relocate_Into (temp, Dumped_Object); - return (*temp); + RELOCATE_INTO (temp, Dumped_Object); + return (* temp); } /* (BINARY-FASLOAD FILE-NAME-OR-CHANNEL) @@ -866,10 +886,19 @@ DEFUN_VOID (compiler_reset_error) struct memmag_state { - SCHEME_OBJECT *free; - SCHEME_OBJECT *memtop; - SCHEME_OBJECT *free_constant; - SCHEME_OBJECT *stack_pointer; + SCHEME_OBJECT * heap_bottom; + SCHEME_OBJECT * heap_top; + SCHEME_OBJECT * unused_heap_bottom; + SCHEME_OBJECT * unused_heap_top; + SCHEME_OBJECT * free; + SCHEME_OBJECT * memtop; + SCHEME_OBJECT * constant_space; + SCHEME_OBJECT * constant_top; + SCHEME_OBJECT * free_constant; + SCHEME_OBJECT * stack_pointer; + SCHEME_OBJECT * stack_bottom; + SCHEME_OBJECT * stack_top; + SCHEME_OBJECT * stack_guard; }; static void @@ -877,10 +906,19 @@ DEFUN (abort_band_load, (ap), PTR ap) { struct memmag_state * mp = ((struct memmag_state *) ap); - Free = (mp->free); + Heap_Bottom = mp->heap_bottom; + Heap_Top = mp->heap_top; + Unused_Heap_Bottom = mp->unused_heap_bottom; + Unused_Heap_Top = mp->unused_heap_top; + Free = mp->free; + Free_Constant = mp->free_constant; + Constant_Space = mp->constant_space; + Constant_Top = mp->constant_top; + Stack_Pointer = mp->stack_pointer; + Stack_Bottom = mp->stack_bottom; + Stack_Top = mp->stack_top; + Stack_Guard = mp->stack_guard; SET_MEMTOP (mp->memtop); - Free_Constant = (mp->free_constant); - Stack_Pointer = (mp->stack_pointer); END_BAND_LOAD (false, false); return; @@ -923,25 +961,36 @@ DEFUN (terminate_band_load, (ap), PTR ap) DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) { + extern void EXFUN (reset_allocator_parameters, (void)); SCHEME_OBJECT result; PRIMITIVE_HEADER (1); PRIMITIVE_CANONICALIZE_CONTEXT (); + { CONST char * file_name = (STRING_ARG (1)); transaction_begin (); { - struct memmag_state * ap = (dstack_alloc (sizeof (struct memmag_state))); - ap->free = Free; - ap->memtop = MemTop; - ap->free_constant = Free_Constant; - ap->stack_pointer = Stack_Pointer; - transaction_record_action (tat_abort, abort_band_load, ap); + struct memmag_state * mp = (dstack_alloc (sizeof (struct memmag_state))); + + mp->heap_bottom = Heap_Bottom; + mp->heap_top = Heap_Top; + mp->unused_heap_bottom = Unused_Heap_Bottom; + mp->unused_heap_top = Unused_Heap_Top; + mp->free = Free; + mp->memtop = MemTop; + mp->free_constant = Free_Constant; + mp->constant_space = Constant_Space; + mp->constant_top = Constant_Top; + mp->stack_pointer = Stack_Pointer; + mp->stack_bottom = Stack_Bottom; + mp->stack_top = Stack_Top; + mp->stack_guard = Stack_Guard; + transaction_record_action (tat_abort, abort_band_load, mp); } - Free = Heap_Bottom; + + reset_allocator_parameters (); SET_MEMTOP (Heap_Top); START_BAND_LOAD (); - Free_Constant = Constant_Space; - Stack_Pointer = Highest_Allocated_Address; read_file_start (file_name, true); transaction_commit (); @@ -950,9 +999,7 @@ DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) long length = ((strlen (file_name)) + 1); char * band_name = (malloc (length)); if (band_name != 0) - { strcpy (band_name, file_name); - } transaction_begin (); { char ** ap = (dstack_alloc (sizeof (char *))); @@ -968,7 +1015,7 @@ DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) } /* Reset implementation state paramenters */ INITIALIZE_INTERRUPTS (); - Initialize_Stack (); + INITIALIZE_STACK (); SET_MEMTOP (Heap_Top - GC_Reserve); { SCHEME_OBJECT cutl = (MEMORY_REF (result, 1)); diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h index a2ac0c91e..a3834f439 100644 --- a/v7/src/microcode/gccode.h +++ b/v7/src/microcode/gccode.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: gccode.h,v 9.51 1993/08/24 00:19:49 gjr Exp $ +$Id: gccode.h,v 9.52 1993/10/14 19:21:29 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -202,7 +202,8 @@ do \ { \ if And2 (In_GC, Consistency_Check) \ { \ - if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \ + if ((Old >= Highest_Allocated_Address) \ + || (Old < Lowest_Allocated_Address)) \ { \ sprintf \ (gc_death_message_buffer, \ @@ -237,7 +238,7 @@ do \ #define Setup_Internal(In_GC, Transport_Code, Already_Relocated_Code) \ { \ GC_Consistency_Check (In_GC); \ - if (Old >= Low_Constant) \ + if (Old < low_heap) \ continue; \ Already_Relocated_Code; \ New_Address = (MAKE_BROKEN_HEART (To)); \ @@ -405,13 +406,14 @@ extern void EXFUN (check_transport_vector_lossage, #define Real_Transport_Vector() \ { \ - SCHEME_OBJECT *Saved_Scan; \ + SCHEME_OBJECT * Saved_Scan; \ \ Saved_Scan = Scan; \ - Scan = (To + 1 + (OBJECT_DATUM (*Old))); \ - if ((Consistency_Check) && \ - (Scan >= Low_Constant) && \ - (To < Low_Constant)) \ + Scan = (To + 1 + (OBJECT_DATUM (* Old))); \ + if ((Consistency_Check) \ + && (Scan > Heap_Top) \ + && (To < Heap_Top) \ + && (To >= Heap_Bottom)) \ { \ sprintf \ (gc_death_message_buffer, \ diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c index 611341b1f..f3d32ce3c 100644 --- a/v7/src/microcode/gcloop.c +++ b/v7/src/microcode/gcloop.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: gcloop.c,v 9.42 1993/08/21 02:27:45 gjr Exp $ +$Id: gcloop.c,v 9.43 1993/10/14 19:22:37 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -129,17 +129,19 @@ DEFUN (GCLoop, fast SCHEME_OBJECT * Scan AND SCHEME_OBJECT ** To_Pointer) { - fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, New_Address; + fast SCHEME_OBJECT + * To, * Old, Temp, + * low_heap, New_Address; #ifdef ENABLE_GC_DEBUGGING_TOOLS SCHEME_OBJECT object_referencing; #endif INITIALIZE_GC_HISTORY (); - To = *To_Pointer; - Low_Constant = Constant_Space; + To = * To_Pointer; + low_heap = Constant_Top; for ( ; Scan != To; Scan++) { - Temp = *Scan; + Temp = * Scan; #ifdef ENABLE_GC_DEBUGGING_TOOLS object_referencing = Temp; #endif diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index df5a3642f..805969d8a 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: interp.c,v 9.78 1993/09/07 21:47:14 gjr Exp $ +$Id: interp.c,v 9.79 1993/10/14 19:15:10 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -121,16 +121,6 @@ if (GC_Check(Amount)) \ Prepare_Eval_Repeat(); \ Immediate_GC(Amount); \ } - -#define RESULT_OF_PURIFY(success) \ -{ \ - SCHEME_OBJECT words_free; \ - \ - words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); \ - Val = (MAKE_POINTER_OBJECT (TC_LIST, Free)); \ - (*Free++) = (success); \ - (*Free++) = words_free; \ -} #define Prepare_Eval_Repeat() \ { \ @@ -1988,18 +1978,18 @@ return_from_compiled_code: break; case RC_NORMAL_GC_DONE: - Val = Fetch_Expression(); + Val = (Fetch_Expression ()); if (GC_Space_Needed < 0) { /* Paranoia */ GC_Space_Needed = 0; } - if (GC_Check(GC_Space_Needed)) + if (GC_Check (GC_Space_Needed)) termination_gc_out_of_space (); GC_Space_Needed = 0; EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); }); - End_GC_Hook(); + End_GC_Hook (); break; case RC_PCOMB1_APPLY: @@ -2102,50 +2092,6 @@ Primitive_Internal_Apply: Import_Registers (); break; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_PURIFY_GC_1: - { - SCHEME_OBJECT GC_Daemon_Proc, Result; - - RENAME_CRITICAL_SECTION ("purify pass 2"); - Export_Registers(); - Result = Purify_Pass_2(Fetch_Expression()); - Import_Registers(); - if (Result == SHARP_F) - { - /* The object does not fit in Constant space. - There is no need to run the daemons, and we should let - the runtime system know what happened. */ - RESULT_OF_PURIFY (SHARP_F); - EXIT_CRITICAL_SECTION ({ Export_Registers(); }); - break; - } - GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); - if (GC_Daemon_Proc == SHARP_F) - { - RESULT_OF_PURIFY (SHARP_T); - EXIT_CRITICAL_SECTION ({ Export_Registers(); }); - break; - } - RENAME_CRITICAL_SECTION( "purify daemon 2"); - Store_Expression(SHARP_F); - Store_Return(RC_PURIFY_GC_2); - Save_Cont(); - Will_Push(2); - STACK_PUSH (GC_Daemon_Proc); - STACK_PUSH (STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } - - case RC_PURIFY_GC_2: - RESULT_OF_PURIFY (SHARP_T); - EXIT_CRITICAL_SECTION ({ Export_Registers(); }); - break; - case RC_REPEAT_DISPATCH: Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ())); Restore_Env(); diff --git a/v7/src/microcode/intrpt.h b/v7/src/microcode/intrpt.h index e7527e2f6..970205adf 100644 --- a/v7/src/microcode/intrpt.h +++ b/v7/src/microcode/intrpt.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: intrpt.h,v 1.15 1993/09/13 18:35:35 gjr Exp $ +$Id: intrpt.h,v 1.16 1993/10/14 19:23:18 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -88,7 +88,7 @@ MIT in each case. */ (Registers[REGBLOCK_STACK_GUARD]) = \ ((INTERRUPT_ENABLED_P (INT_Stack_Overflow)) \ ? ((SCHEME_OBJECT) (ADDR_TO_SCHEME_ADDR (Stack_Guard))) \ - : ((SCHEME_OBJECT) (ADDR_TO_SCHEME_ADDR (Absolute_Stack_Base)))); \ + : ((SCHEME_OBJECT) (ADDR_TO_SCHEME_ADDR (Stack_Bottom)))); \ } while (0) #define FETCH_INTERRUPT_MASK() ((long) (Registers[REGBLOCK_INT_MASK])) diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c index 15afe0f3c..6956233b6 100644 --- a/v7/src/microcode/memmag.c +++ b/v7/src/microcode/memmag.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: memmag.c,v 9.55 1993/09/08 04:39:01 gjr Exp $ +$Id: memmag.c,v 9.56 1993/10/14 19:14:24 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -67,57 +67,99 @@ extern void /* Memory Allocation, sequential processor: - ------------------------------------------ - | Control Stack || | - | \/ | - ------------------------------------------ +oo + ------------------------------------------ <- fixed boundary (currently) + | Heap 2 | + | | + ------------------------------------------ <- boundary moved by purify + | Heap 1 | + | | + ------------------------------------------ <- boundary moved by purify | Constant + Pure Space /\ | | || | - ------------------------------------------ - | | - | Heap Space | - ------------------------------------------ + ------------------------------------------ <- fixed boundary (currently) + | Control Stack || | + | \/ | + ------------------------------------------ <- fixed boundary (currently) +0 - Each area has a pointer to its starting address and a pointer to the - next free cell. In addition, there is a pointer to the top of the + Each area has a pointer to its starting address and a pointer to + the next free cell (for the stack, it is a pointer to the last cell + in use). In addition, there is a pointer to the top of the useable area of the heap (the heap is subdivided into two areas for the purposes of GC, and this pointer indicates the top of the half currently in use). */ +#define CONSTANT_SPACE_FUDGE 128 + /* Initialize free pointers within areas. Stack_Pointer is - special: it always points to a cell which is in use. */ + special: it always points to a cell which is in use. + */ + +static long saved_heap_size, saved_constant_size, saved_stack_size; +extern void EXFUN (reset_allocator_parameters, (void)); +extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *)); + +Boolean +DEFUN (update_allocator_parameters, (ctop), SCHEME_OBJECT * ctop) +{ + /* buffer for impurify, etc. */ + SCHEME_OBJECT * nctop = (ctop + CONSTANT_SPACE_FUDGE); + unsigned long temp; + + if (nctop >= (Highest_Allocated_Address + 1)) + return (FALSE); + + Constant_Top = nctop; + temp = ((Highest_Allocated_Address - Constant_Top) / 2); + Heap_Bottom = Constant_Top; + Heap_Top = (Heap_Bottom + temp); + Local_Heap_Base = Heap_Bottom; + Unused_Heap_Bottom = Heap_Top; + Unused_Heap_Top = Highest_Allocated_Address; + Free = Heap_Bottom; + return (TRUE); +} void -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) +DEFUN_VOID (reset_allocator_parameters) { 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); - Free = Heap_Bottom; - Constant_Top = (Constant_Space + Our_Constant_Size); - Initialize_Stack (); - STACK_RESET (); + Stack_Bottom = Lowest_Allocated_Address; + Stack_Top = (Stack_Bottom + (STACK_ALLOCATION_SIZE (saved_stack_size))); + Constant_Space = Stack_Top; Free_Constant = Constant_Space; + ALIGN_FLOAT (Free_Constant); + (void) update_allocator_parameters (Free_Constant); SET_CONSTANT_TOP (); + ALIGN_FLOAT (Free); + SET_MEMTOP (Heap_Top - GC_Reserve); + INITIALIZE_STACK (); + STACK_RESET (); return; } +void +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) +{ + saved_heap_size = Our_Heap_Size; + saved_constant_size = Our_Constant_Size; + saved_stack_size = Our_Stack_Size; + reset_allocator_parameters (); +} + static void DEFUN_VOID (failed_consistency_check) { - outf_flush_fatal (); - exit (1); + outf_flush_fatal (); + exit (1); } -static PTR Lowest_Allocated_Address; - void DEFUN_VOID (Reset_Memory) { @@ -125,7 +167,7 @@ DEFUN_VOID (Reset_Memory) DEALLOCATE_REGISTERS (); return; } - + /* This procedure allocates and divides the total memory. */ void @@ -145,31 +187,24 @@ DEFUN (Setup_Memory, } /* 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), + Lowest_Allocated_Address, + Highest_Allocated_Address); /* Consistency check 2 */ - if (Heap == NULL) + if (Lowest_Allocated_Address == NULL) { outf_fatal ("Not enough memory for this configuration.\n"); failed_consistency_check (); } - /* Initialize the various global parameters */ - Lowest_Allocated_Address = ((PTR) Heap); - Heap += HEAP_BUFFER_SPACE; - INITIAL_ALIGN_FLOAT (Heap); - Unused_Heap = (Heap + Our_Heap_Size); - ALIGN_FLOAT (Unused_Heap); - Constant_Space = (Heap + (2 * Our_Heap_Size)); - ALIGN_FLOAT (Constant_Space); - /* Consistency check 3 */ - test_value = (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address)); + test_value = (MAKE_POINTER_OBJECT (LAST_TYPE_CODE, + Highest_Allocated_Address)); if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) || ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address)) @@ -182,7 +217,6 @@ DEFUN (Setup_Memory, failed_consistency_check (); } - Heap_Bottom = Heap; Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size); return; } @@ -191,21 +225,36 @@ DEFUN (Setup_Memory, The main garbage collector loop is in gcloop.c */ -/* Flip into unused heap */ +/* Flip into unused heap, extending constant space if we are flipping + to the low heap, and the fudge area has shrunk. + */ void DEFUN_VOID (GCFlip) { - SCHEME_OBJECT *Temp; - - Temp = Unused_Heap; - Unused_Heap = Heap_Bottom; - Heap_Bottom = Temp; - Temp = Unused_Heap_Top; - Unused_Heap_Top = Heap_Top; - Heap_Top = Temp; - Free = Heap_Bottom; - SET_MEMTOP(Heap_Top - GC_Reserve); + if (((Constant_Top - Free_Constant) < CONSTANT_SPACE_FUDGE) + && (Unused_Heap_Bottom < Heap_Bottom) + && (update_allocator_parameters (Free_Constant))) + SET_CONSTANT_TOP (); + else + { + SCHEME_OBJECT * temp_bottom, * temp_top; + + temp_bottom = Unused_Heap_Bottom; + temp_top = Unused_Heap_Top; + + Unused_Heap_Bottom = Heap_Bottom; + Unused_Heap_Top = Heap_Top; + + Heap_Bottom = temp_bottom; + Heap_Top = temp_top; + + Free = Heap_Bottom; + } + + ALIGN_FLOAT (Free); + SET_MEMTOP (Heap_Top - GC_Reserve); + Weak_Chain = EMPTY_LIST; return; } @@ -225,9 +274,11 @@ SCHEME_OBJECT Weak_Chain; void DEFUN_VOID (Fix_Weak_Chain) { - fast SCHEME_OBJECT *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant; + fast SCHEME_OBJECT + * Old_Weak_Cell, * Scan, Old_Car, + Temp, * Old, * low_heap; - Low_Constant = Constant_Space; + low_heap = Constant_Top; while (Weak_Chain != EMPTY_LIST) { Old_Weak_Cell = OBJECT_ADDRESS (Weak_Chain); @@ -267,7 +318,7 @@ DEFUN_VOID (Fix_Weak_Chain) case GC_Quadruple: case GC_Vector: Old = OBJECT_ADDRESS (Old_Car); - if (Old >= Low_Constant) + if (Old < low_heap) { *Scan = Temp; continue; @@ -278,7 +329,7 @@ DEFUN_VOID (Fix_Weak_Chain) case GC_Compiled: Old = OBJECT_ADDRESS (Old_Car); - if (Old >= Low_Constant) + if (Old < low_heap) { *Scan = Temp; continue; @@ -326,14 +377,14 @@ void DEFUN_VOID (GC) { SCHEME_OBJECT - *Root, *Result, *Check_Value, - The_Precious_Objects, *Root2; + * Root, * Result, * Check_Value, + The_Precious_Objects, * Root2; /* Save the microcode registers so that they can be relocated */ Terminate_Old_Stacklet (); SEAL_CONSTANT_SPACE (); - Check_Value = (CONSTANT_SPACE_SEAL ()); + Check_Value = (CONSTANT_AREA_END ()); Root = Free; The_Precious_Objects = (Get_Fixed_Obj_Slot (Precious_Objects)); Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F); @@ -377,7 +428,7 @@ DEFUN_VOID (GC) /* The 4 step GC */ - Result = (GCLoop (Constant_Space, &Free)); + Result = (GCLoop ((CONSTANT_AREA_START ()), &Free)); if (Result != Check_Value) { outf_fatal ("\nGC: Constant Scan ended too early.\n"); @@ -444,9 +495,7 @@ DEFUN_VOID (GC) Root += 1; } else - { Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*Root++)); - } Current_State_Point = *Root++; Fluid_Bindings = *Root++; Free_Stacklets = NULL; @@ -467,14 +516,12 @@ DEFUN_VOID (GC) DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) { - long new_gc_reserve; extern unsigned long gc_counter; - SCHEME_OBJECT GC_Daemon_Proc; + SCHEME_OBJECT daemon; PRIMITIVE_HEADER (1); PRIMITIVE_CANONICALIZE_CONTEXT (); STACK_SANITY_CHECK ("GC"); - new_gc_reserve = (arg_nonnegative_integer (1)); if (Free > Heap_Top) { outf_fatal ("\nGARBAGE-COLLECT: GC has been delayed too long!\n"); @@ -483,36 +530,33 @@ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) Microcode_Termination (TERM_NO_SPACE); } + GC_Reserve = (arg_nonnegative_integer (1)); + POP_PRIMITIVE_FRAME (1); + ENTER_CRITICAL_SECTION ("garbage collector"); run_pre_gc_hooks (); gc_counter += 1; - GC_Reserve = new_gc_reserve; GCFlip (); GC (); run_post_gc_hooks (); - POP_PRIMITIVE_FRAME (1); - GC_Daemon_Proc = (Get_Fixed_Obj_Slot (GC_Daemon)); + daemon = (Get_Fixed_Obj_Slot (GC_Daemon)); + + Will_Push (CONTINUATION_SIZE); + Store_Return (RC_NORMAL_GC_DONE); + Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); + Save_Cont (); + Pushed (); 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 (); + if (daemon == SHARP_F) 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 (); - STACK_PUSH (GC_Daemon_Proc); + + Will_Push (2); + STACK_PUSH (daemon); STACK_PUSH (STACK_FRAME_HEADER); Pushed (); PRIMITIVE_ABORT (PRIM_APPLY); - /* The following comment is by courtesy of LINT, your friendly sponsor. */ /*NOTREACHED*/ } diff --git a/v7/src/microcode/nttrap.c b/v7/src/microcode/nttrap.c index 3bf72e5ef..cec5d1264 100644 --- a/v7/src/microcode/nttrap.c +++ b/v7/src/microcode/nttrap.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: nttrap.c,v 1.8 1993/09/21 18:08:09 gjr Exp $ +$Id: nttrap.c,v 1.9 1993/10/14 19:11:56 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -472,7 +472,7 @@ DEFUN_VOID (WinntExceptionTransferHook) IFVERBOSE (TellUserEx (MB_OKCANCEL, "WinntExceptionTransferHook.")); if (clear_real_stack) - Initialize_Stack (); + INITIALIZE_STACK (); else { Stack_Pointer = real_stack_pointer; @@ -537,7 +537,7 @@ DEFUN (setup_trap_frame, (code, context, trinfo, new_stack_pointer), if (win32_under_win32s_p ()) { if (! stack_recovered_p) - Initialize_Stack (); + INITIALIZE_STACK (); clear_real_stack = FALSE; real_stack_pointer = Stack_Pointer; real_stack_guard = Stack_Guard; @@ -730,7 +730,7 @@ pc_in_hyperspace: scheme_sp_valid = (pc_in_scheme && ((scheme_sp < ((long) Stack_Top)) && - (scheme_sp >= ((long) Absolute_Stack_Base)) && + (scheme_sp >= ((long) Stack_Bottom)) && ((scheme_sp & STACK_ALIGNMENT_MASK) == 0))); IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 2")); @@ -740,7 +740,7 @@ pc_in_hyperspace: ? ((SCHEME_OBJECT *) scheme_sp) : ((pc_in_C && (Stack_Pointer < Stack_Top) - && (Stack_Pointer > Absolute_Stack_Base)) + && (Stack_Pointer > Stack_Bottom)) ? Stack_Pointer : ((SCHEME_OBJECT *) 0))); @@ -1053,7 +1053,7 @@ static void DEFUN (nt_trap_handler, (code, context), DWORD code AND PCONTEXT context) { - Boolean constant_space_broken = (! (CONSTANT_SPACE_SEALED ())); + Boolean stack_overflowed_p = (STACK_OVERFLOWED_P ()); enum trap_state old_trap_state = trap_state; int flags; @@ -1075,15 +1075,15 @@ DEFUN (nt_trap_handler, (code, context), (CRITICAL_SECTION_NAME ())); describe_trap ("trap is", code); } - else if (constant_space_broken || (old_trap_state != trap_state_recover)) + else if (stack_overflowed_p || (old_trap_state != trap_state_recover)) { trap_noise (">> The system has trapped.\n"); describe_trap ("trap is", code); } - if (constant_space_broken) + if (stack_overflowed_p) { - trap_noise (">> Constant space has been overwritten.\n"); - trap_noise (">> Probably a runaway recursion has overflowed the stack.\n"); + trap_noise (">> The stack has overflowed overwriting adjacent memory.\n"); + trap_noise (">> This was probably caused by a runaway recursion.\n"); } switch (old_trap_state) @@ -1106,7 +1106,7 @@ DEFUN (nt_trap_handler, (code, context), } case trap_state_recover: - if ((WITHIN_CRITICAL_SECTION_P ()) || constant_space_broken) + if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p) { trap_noise (">> Successful recovery is unlikely.\n"); break; @@ -1259,7 +1259,7 @@ DEFUN_VOID (winnt_stack_reset) { unsigned long boundary; - /* This presumes that the distance between Absolute_Stack_Base and + /* This presumes that the distance between Stack_Bottom and Stack_Guard is at least a page. */ diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h index bb4653ae1..4d0ed3f82 100644 --- a/v7/src/microcode/object.h +++ b/v7/src/microcode/object.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: object.h,v 9.42 1993/08/21 03:58:18 gjr Exp $ +$Id: object.h,v 9.43 1993/10/14 19:19:02 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -141,13 +141,16 @@ MIT in each case. */ typedef long relocation_type; /* Used to relocate pointers on fasload */ -/* The "-1" in the value returned is a guarantee that there is one - word reserved exclusively for use by the garbage collector. */ -#define ALLOCATE_HEAP_SPACE(space) \ - (Heap = \ - ((SCHEME_OBJECT *) \ - (HEAP_MALLOC ((sizeof (SCHEME_OBJECT)) * (space)))), \ - ((Heap + (space)) - 1)) +#define ALLOCATE_HEAP_SPACE(space,low,high) do \ +{ \ + unsigned long _space = (space); \ + SCHEME_OBJECT * _low \ + = ((SCHEME_OBJECT *) \ + (HEAP_MALLOC ((sizeof (SCHEME_OBJECT)) * _space))); \ + \ + (low) = _low; \ + (high) = (_low + _space); \ +} while (0) #ifndef DATUM_TO_ADDRESS #define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) (datum)) @@ -165,14 +168,14 @@ typedef SCHEME_OBJECT * relocation_type; extern SCHEME_OBJECT * memory_base; -/* The "-1" in the value returned is a guarantee that there is one - word reserved exclusively for use by the garbage collector. */ -#define ALLOCATE_HEAP_SPACE(space) \ - (memory_base = \ - ((SCHEME_OBJECT *) \ - (HEAP_MALLOC ((sizeof (SCHEME_OBJECT)) * (space)))), \ - Heap = memory_base, \ - ((memory_base + (space)) - 1)) +#define ALLOCATE_HEAP_SPACE(space,low,high) do \ +{ \ + unsigned long _space = (space); \ + memory_base = ((SCHEME_OBJECT *) \ + (HEAP_MALLOC ((sizeof (SCHEME_OBJECT)) * _space))); \ + (low) = memory_base; \ + (high) = (memory_base + _space); \ +} while (0) #ifndef DATUM_TO_ADDRESS #define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) ((datum) + memory_base)) @@ -490,35 +493,17 @@ if ((ADDRESS_CONSTANT_P (OBJECT_ADDRESS (Old_Pointer))) && \ (Pure_Test (OBJECT_ADDRESS (Old_Pointer)))) \ signal_error_from_primitive (ERR_WRITE_INTO_PURE_SPACE); \ -#ifdef FLOATING_ALIGNMENT - -#define FLOATING_BUFFER_SPACE \ - ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))) - -#define HEAP_BUFFER_SPACE \ - (TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE) +#ifndef FLOATING_ALIGNMENT +#define FLOATING_ALIGNMENT 0 +#endif /* not FLOATING_ALIGNMENT */ -/* The space is there, find the correct position. */ +#define FLOATING_ALIGNED_P(ptr) \ + ((((unsigned long) ((ptr) + 1)) & FLOATING_ALIGNMENT) == 0) -#define INITIAL_ALIGN_FLOAT(Where) \ +#define ALIGN_FLOAT(Where) do \ { \ - while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ - Where -= 1; \ -} - -#define ALIGN_FLOAT(Where) \ -{ \ - while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ + while (! (FLOATING_ALIGNED_P (Where))) \ *Where++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); \ -} - -#else /* not FLOATING_ALIGNMENT */ - -#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1) - -#define INITIAL_ALIGN_FLOAT(Where) -#define ALIGN_FLOAT(Where) - -#endif /* not FLOATING_ALIGNMENT */ +} while (0) #endif /* SCM_OBJECT_H */ diff --git a/v7/src/microcode/ppband.c b/v7/src/microcode/ppband.c index c77ebe7d9..96b179040 100644 --- a/v7/src/microcode/ppband.c +++ b/v7/src/microcode/ppband.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: ppband.c,v 9.45 1993/06/24 07:09:15 gjr Exp $ +$Id: ppband.c,v 9.46 1993/10/14 19:16:32 gjr Exp $ Copyright (c) 1987-1992 Massachusetts Institute of Technology @@ -144,13 +144,9 @@ DEFUN (print_long_as_string, (string), char *string) { c = *temp++; if (isgraph ((int) c)) - { putchar (c); - } else - { putchar (' '); - } } printf ("\" = "); @@ -230,25 +226,17 @@ DEFUN (scheme_string, (From, Quoted), long From AND Boolean Quoted) if (&Chars[Count] < ((char *) end_of_memory)) { if (Quoted) - { putchar ('\"'); - } for (i = 0; i < Count; i++) - { printf ("%c", *Chars++); - } if (Quoted) - { putchar ('\"'); - } putchar ('\n'); return (true); } } if (Quoted) - { printf ("String not in memory; datum = %lx\n", From); - } return (false); } @@ -262,31 +250,29 @@ DEFUN (scheme_symbol, (From), long From) symbol = &Data[From+SYMBOL_NAME]; if ((symbol >= end_of_memory) || (!(scheme_string (via (From + SYMBOL_NAME), false)))) - { printf ("symbol not in memory; datum = %lx\n", From); - } return; } static char string_buffer[10]; -#define PRINT_OBJECT(type, datum) \ +#define PRINT_OBJECT(type, datum) do \ { \ printf ("[%s %lx]", type, datum); \ -} +} while (0) -#define NON_POINTER(string) \ +#define NON_POINTER(string) do \ { \ the_string = string; \ Points_To = The_Datum; \ break; \ -} +} while (0) -#define POINTER(string) \ +#define POINTER(string) do \ { \ the_string = string; \ break; \ -} +} while (0) char *Type_Names[] = TYPE_NAME_TABLE; @@ -357,24 +343,16 @@ DEFUN (Display, (Location, Type, The_Datum), case TC_REFERENCE_TRAP: if (The_Datum <= TRAP_MAX_IMMEDIATE) - { NON_POINTER ("REFERENCE-TRAP"); - } else - { POINTER ("REFERENCE-TRAP"); - } case TC_BROKEN_HEART: if (The_Datum == 0) - { Points_To = 0; - } default: if (Type <= LAST_TYPE_CODE) - { POINTER (Type_Names[Type]); - } else { sprintf (&string_buf[0], "0x%02lx ", Type); @@ -420,9 +398,7 @@ DEFUN (show_area, (area, start, end, name), area -= 1; } else - { Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area))); - } } return (area); } @@ -445,9 +421,7 @@ DEFUN (main, (argc, argv), { case FASL_FILE_FINE : if (counter != 0) - { printf ("\f\n\t*** New object ***\n\n"); - } break; /* There should really be a difference between no header @@ -482,7 +456,8 @@ DEFUN (main, (argc, argv), } load_length = (Heap_Count + Const_Count + Primitive_Table_Size); - Data = ((SCHEME_OBJECT *) malloc (sizeof (SCHEME_OBJECT) * (load_length + 4))); + Data = ((SCHEME_OBJECT *) + (malloc (sizeof (SCHEME_OBJECT) * (load_length + 4)))); if (Data == NULL) { fprintf (stderr, "Allocation of %ld words failed.\n", (load_length + 4)); @@ -496,29 +471,19 @@ DEFUN (main, (argc, argv), printf ("Expected %ld objects. Obtained %ld objects.\n\n", ((long) load_length), ((long) total_length)); if (total_length < Heap_Count) - { Heap_Count = total_length; - } total_length -= Heap_Count; if (total_length < Const_Count) - { Const_Count = total_length; - } total_length -= Const_Count; if (total_length < Primitive_Table_Size) - { Primitive_Table_Size = total_length; - } } if (Heap_Count > 0) - { Next = show_area (Data, 0, Heap_Count, "Heap"); - } if (Const_Count > 0) - { Next = show_area (Next, Heap_Count, Const_Count, "Constant Space"); - } if ((Primitive_Table_Size > 0) && (Next < end_of_memory)) { long arity, size; @@ -547,9 +512,7 @@ DEFUN (main, (argc, argv), printf ("\n"); } if (argc != 1) - { exit (0); - } free ((char *) Data); counter = 1; } diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c index b03114d45..4c3dd6016 100644 --- a/v7/src/microcode/psbtobin.c +++ b/v7/src/microcode/psbtobin.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: psbtobin.c,v 9.49 1993/06/24 07:09:36 gjr Exp $ +$Id: psbtobin.c,v 9.50 1993/10/14 19:17:26 gjr Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -939,7 +939,7 @@ DEFUN_VOID (short_header_read) quit (1); } -static SCHEME_OBJECT *Storage; +static SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address; long DEFUN_VOID (Read_Header_and_Allocate) @@ -1043,7 +1043,7 @@ DEFUN_VOID (Read_Header_and_Allocate) #endif Size = (6 + /* SNMV */ - HEAP_BUFFER_SPACE + + (TRAP_MAX_IMMEDIATE + 1) + Heap_Count + Heap_Objects + Constant_Count + Constant_Objects + Pure_Count + Pure_Objects + @@ -1057,16 +1057,17 @@ DEFUN_VOID (Read_Header_and_Allocate) ((Primitive_Table_Length * (2 + STRING_CHARS)) + (char_to_pointer (NPChars)))); - ALLOCATE_HEAP_SPACE (Size); - if (Heap == NULL) + ALLOCATE_HEAP_SPACE (Size, + Lowest_Allocated_Address, + Highest_Allocated_Address); + if (Lowest_Allocated_Address == NULL) { fprintf (stderr, "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n", program_name, Size); quit (1); } - Storage = Heap; - Heap += (TRAP_MAX_IMMEDIATE + 1); + Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1)); return (Size - (TRAP_MAX_IMMEDIATE + 1)); } @@ -1237,7 +1238,7 @@ DEFUN_VOID (do_it) fprintf (stderr, "%s: Error writing the output file.\n", program_name); quit (1); } - free ((char *) Storage); + free ((char *) Lowest_Allocated_Address); } } diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c index 05a36b6de..415b0bc62 100644 --- a/v7/src/microcode/purify.c +++ b/v7/src/microcode/purify.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: purify.c,v 9.51 1993/08/22 22:39:04 gjr Exp $ +$Id: purify.c,v 9.52 1993/10/14 19:14:00 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -42,7 +42,6 @@ MIT in each case. */ /* Imports */ -extern void EXFUN (GCFlip, (void)); extern void EXFUN (GC, (void)); extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); @@ -60,7 +59,7 @@ extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); { \ Old = (OBJECT_ADDRESS (Temp)); \ if ((GC_Mode == CONSTANT_COPY) && \ - (Old > Low_Constant)) \ + (Old < low_heap)) \ continue; \ Code; \ } @@ -69,7 +68,7 @@ extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); { \ Old = (SCHEME_ADDR_TO_ADDR (Temp)); \ if ((GC_Mode == CONSTANT_COPY) && \ - (Old > Low_Constant)) \ + (Old < low_heap)) \ continue; \ Code; \ } @@ -92,22 +91,23 @@ extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); } SCHEME_OBJECT * -DEFUN (PurifyLoop, - (Scan, To_Pointer, 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; + fast SCHEME_OBJECT + * To, * Old, Temp, + * low_heap, New_Address; #ifdef ENABLE_GC_DEBUGGING_TOOLS SCHEME_OBJECT object_referencing; #endif - To = *To_Pointer; - Low_Constant = Constant_Space; + To = * To_Pointer; + low_heap = Constant_Top; for ( ; Scan != To; Scan++) { - Temp = *Scan; + Temp = * Scan; #ifdef ENABLE_GC_DEBUGGING_TOOLS object_referencing = Temp; #endif @@ -312,7 +312,7 @@ DEFUN (PurifyLoop, break; }); - /* No need to handle futures specially here, since PurifyLoop + /* No need to handle futures specially here, since purifyloop is always invoked after running GCLoop, which will have spliced all spliceable futures unless the GC itself of the GC dameons spliced them, but this should not occur. @@ -347,32 +347,26 @@ DEFUN (PurifyLoop, *To_Pointer = To; return (To); -} /* PurifyLoop */ +} /* purifyloop */ /* Description of the algorithm for PURIFY: - The algorithm is trickier than would first appear necessary. This - is because the size of the object being purified must be - calculated. The idea is that the entire object is copied into the - new heap, and then a normal GC is done (the broken hearts created - by the copy will, of course, now be used to relocate references to - parts of the object). If there is not enough room in constant - space for the object, processing stops with a #!false return and - the world flipped into the new heap. Otherwise, the - process is repeated, moving the object into constant space on the - first pass and then doing a GC back into the original heap. - - Notice that in order to make a pure object, the copy process - proceeds in two halves. During the first half (which collects the - pure part) Compiled Code, Environments, Symbols, and Variables - (i.e. things whose contents change) are NOT copied. Then a header - is put down indicating constant (not pure) area, and then they ARE - copied. + Purify increases the size of constant space at the expense of both + heaps. A GC-like relocation is performed with the object being + purified as the root. The object is copied and relocated from the + high heap to the area adjacent to constant space. Then the GC is + finished after changing the end of constant-space marker. + + In order to make a pure object, the copy process proceeds in two + halves. During the first half (which collects the pure part) + Compiled Code, Environments, Symbols, and Variables (i.e. things + whose contents change) are NOT copied. Then a header is put down + indicating constant (not pure) area, and then they ARE copied. The constant area contains a contiguous set of blocks of the following format: - >>Top of Memory (Stack above here)<< + >>Heap above here<< . (direction of growth) . ^ @@ -405,128 +399,73 @@ N < | | | | SNMH | Pure Size N | |----------------------| - >>Base of Memory (Heap below here)<< -*/ - -/* The result returned by Purify is a vector containing this data */ - -#define Purify_Vector_Header 0 -#define Purify_Length 1 -#define Purify_Really_Pure 2 -#define Purify_N_Slots 2 - -SCHEME_OBJECT -DEFUN (Purify, - (Object, Purify_Object), - SCHEME_OBJECT Object AND - SCHEME_OBJECT Purify_Object) -{ - long Length; - SCHEME_OBJECT *Heap_Start, *Result, Answer; - -/* Pass 1 -- Copy object to new heap, then GC into that heap */ + >>Top of Stack (Stack below here)<< - run_pre_gc_hooks (); - GCFlip (); - Heap_Start = Free; - *Free++ = Object; - Result = GCLoop (Heap_Start, &Free); - if (Free != Result) - { - outf_fatal ("\nPurify: Pure Scan ended too early.\n"); - Microcode_Termination (TERM_BROKEN_HEART); - } - Length = ((Free - Heap_Start) - 1); /* Length of object */ - GC (); - Free[Purify_Vector_Header] = - MAKE_OBJECT (TC_MANIFEST_VECTOR, Purify_N_Slots); - Free[Purify_Length] = LONG_TO_UNSIGNED_FIXNUM(Length); - Free[Purify_Really_Pure] = Purify_Object; - Answer = MAKE_POINTER_OBJECT (TC_VECTOR, Free); - Free += (Purify_N_Slots + 1); - run_post_gc_hooks (); - return (Answer); -} +*/ -SCHEME_OBJECT -DEFUN (Purify_Pass_2, - (Info), - SCHEME_OBJECT Info) +static void +DEFUN (purify, (object, purify_mode), + SCHEME_OBJECT object AND Boolean purify_mode) { - long Length; - Boolean Purify_Object; - SCHEME_OBJECT *New_Object, Relocated_Object, *Result; - long Pure_Length, Recomputed_Length; + long length, pure_length; + SCHEME_OBJECT * new_object, * result; + extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *)); run_pre_gc_hooks (); STACK_SANITY_CHECK ("PURIFY"); - Length = (OBJECT_DATUM (FAST_MEMORY_REF (Info, Purify_Length))); - if (FAST_MEMORY_REF (Info, Purify_Really_Pure) == SHARP_F) - Purify_Object = false; - else - Purify_Object = true; - Relocated_Object = *Heap_Bottom; - if (!(TEST_CONSTANT_TOP (Free_Constant + Length + 6))) - return (SHARP_F); - New_Object = Free_Constant; - GCFlip (); + Weak_Chain = EMPTY_LIST; + Constant_Top = Free_Constant; + new_object = Free_Constant; *Free_Constant++ = SHARP_F; /* Will hold pure space header */ - *Free_Constant++ = Relocated_Object; - if (Purify_Object) + *Free_Constant++ = object; + if (! (purify_mode)) + pure_length = 3; + else { - Result = PurifyLoop ((New_Object + 1), &Free_Constant, PURE_COPY); + result = (purifyloop ((new_object + 1), &Free_Constant, PURE_COPY)); - if (Free_Constant != Result) + if (result != Free_Constant) { +purification_failure: outf_fatal ("\nPurify: Pure Copy ended too early.\n"); Microcode_Termination (TERM_BROKEN_HEART); } - Pure_Length = ((Free_Constant - New_Object) + 1); + pure_length = ((Free_Constant - new_object) + 1); } - else - Pure_Length = 3; *Free_Constant++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); - *Free_Constant++ = (MAKE_OBJECT (CONSTANT_PART, Pure_Length)); - if (Purify_Object) + *Free_Constant++ = (MAKE_OBJECT (CONSTANT_PART, pure_length)); + Constant_Top = Free_Constant; + if (purify_mode) { - Result = PurifyLoop ((New_Object + 1), &Free_Constant, CONSTANT_COPY); - if (Result != Free_Constant) + result = (purifyloop ((new_object + 1), &Free_Constant, CONSTANT_COPY)); + if (result != Free_Constant) { outf_fatal ("\nPurify: Pure Copy ended too early.\n"); Microcode_Termination (TERM_BROKEN_HEART); } } - -/* Purify_Pass_2 continues on the next page */ - -/* Purify_Pass_2, continued */ - else { - Result = GCLoop ((New_Object + 1), &Free_Constant); - if (Result != Free_Constant) - { - outf_fatal ("\nPurify: Constant Copy ended too early.\n"); - Microcode_Termination (TERM_BROKEN_HEART); - } + result = (GCLoop ((new_object + 1), &Free_Constant)); + if (result != Free_Constant) + goto purification_failure; } - Recomputed_Length = ((Free_Constant - New_Object) - 4); + + 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_CONSTANT_TOP (Free_Constant))) - { - outf_fatal ( - "\nPurify overrun: Constant_Top = 0x%lx, Free_Constant = 0x%lx\n", - Constant_Top, Free_Constant); - Microcode_Termination (TERM_EXIT); - } - *New_Object++ = - (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length)); - *New_Object = (MAKE_OBJECT (PURE_PART, (Recomputed_Length + 5))); + *Free_Constant++ = (MAKE_OBJECT (END_OF_BLOCK, (length + 5))); + *new_object++ = + (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length)); + *new_object = (MAKE_OBJECT (PURE_PART, (length + 5))); + if (! (update_allocator_parameters (Free_Constant))) + gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL); + /*NOTREACHED*/ + SET_CONSTANT_TOP (); + ALIGN_FLOAT (Free); + SET_MEMTOP (Heap_Top - GC_Reserve); GC (); run_post_gc_hooks (); - return (SHARP_T); } /* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN) @@ -536,7 +475,7 @@ DEFUN (Purify_Pass_2, To purify an object we just copy it into Pure Space in two parts with the appropriate headers and footers. The actual - copying is done by PurifyLoop above. + copying is done by purifyloop above. Once the copy is complete we run a full GC which handles the broken hearts which now point into pure space. On a @@ -544,53 +483,54 @@ DEFUN (Purify_Pass_2, should only be used as one would use master-gc-loop i.e. with everyone else halted. - This primitive does not return normally. It always escapes into - the interpreter because some of its cached registers (eg. History) - have changed. + This primitive always "returns" by escaping to the interpreter + because some of its cached registers (eg. History) have changed. */ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) { - long new_gc_reserve; - SCHEME_OBJECT Object, Purify_Result, Daemon; + Boolean purify_mode; + SCHEME_OBJECT object, result, daemon; PRIMITIVE_HEADER (3); PRIMITIVE_CANONICALIZE_CONTEXT (); STACK_SANITY_CHECK ("PURIFY"); Save_Time_Zone (Zone_Purify); - TOUCH_IN_PRIMITIVE ((ARG_REF (1)), Object); + TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object); CHECK_ARG (2, BOOLEAN_P); - new_gc_reserve = (arg_nonnegative_integer (3)); + purify_mode = (BOOLEAN_ARG (2)); + GC_Reserve = (arg_nonnegative_integer (3)); + + /* Purify only works from the high heap. + If in the low heap, tell the runtime system. + */ - /* Pass 1 (Purify, above) does a first copy. Then any GC daemons - run, and then Purify_Pass_2 is called to copy back. - */ + if (Heap_Bottom < Unused_Heap_Bottom) + PRIMITIVE_RETURN (SHARP_F); - 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)); - if (Daemon == SHARP_F) - { - SCHEME_OBJECT words_free; - - RENAME_CRITICAL_SECTION ("purify pass 2"); - 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; + + ENTER_CRITICAL_SECTION ("purify"); + purify (object, purify_mode); + result = (MAKE_POINTER_OBJECT (TC_LIST, Free)); + Free += 2; + Free[-2] = SHARP_T; + Free[-1] = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); + + Will_Push (CONTINUATION_SIZE); + Store_Return (RC_NORMAL_GC_DONE); + Store_Expression (result); + Save_Cont (); + Pushed (); + + RENAME_CRITICAL_SECTION ("purify daemon"); + daemon = (Get_Fixed_Obj_Slot (GC_Daemon)); + if (daemon == SHARP_F) 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 (); - STACK_PUSH (Daemon); + Will_Push (2); + STACK_PUSH (daemon); STACK_PUSH (STACK_FRAME_HEADER); Pushed (); PRIMITIVE_ABORT (PRIM_APPLY); diff --git a/v7/src/microcode/purutl.c b/v7/src/microcode/purutl.c index f6ac23e73..044092e1d 100644 --- a/v7/src/microcode/purutl.c +++ b/v7/src/microcode/purutl.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: purutl.c,v 9.45 1993/08/22 22:39:05 gjr Exp $ +$Id: purutl.c,v 9.46 1993/10/14 19:16:10 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -40,23 +40,22 @@ MIT in each case. */ #include "zones.h" static void -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) +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; for (; From < To; From++) { - if (GC_Type_Special (*From)) + if (GC_Type_Special (* From)) { - switch (OBJECT_TYPE (*From)) + switch (OBJECT_TYPE (* From)) { case TC_MANIFEST_NM_VECTOR: - From += (OBJECT_DATUM (*From)); + From += (OBJECT_DATUM (* From)); continue; /* The following two type codes assume that none of the protected @@ -64,33 +63,37 @@ DEFUN (Update, This may be seriously wrong! */ case TC_LINKAGE_SECTION: - switch (READ_LINKAGE_KIND (*From)) + switch (READ_LINKAGE_KIND (* From)) { case REFERENCE_LINKAGE_KIND: case ASSIGNMENT_LINKAGE_KIND: { - From += (READ_CACHE_LINKAGE_COUNT (*From)); + From += (READ_CACHE_LINKAGE_COUNT (* From)); continue; } case OPERATOR_LINKAGE_KIND: case GLOBAL_OPERATOR_LINKAGE_KIND: { - count = (READ_OPERATOR_LINKAGE_COUNT (*From)); + count = (READ_OPERATOR_LINKAGE_COUNT (* From)); From = (END_OPERATOR_LINKAGE_AREA (From, count)); continue; } - + default: +#ifdef BAD_TYPES_LETHAL { gc_death (TERM_EXIT, "Impurify: Unknown compiler linkage kind.", From, NULL); /*NOTREACHED*/ } +#else /* not BAD_TYPES_LETHAL */ + outf_error ("\nupdate (impurify): Bad type code = 0x %02x.\n", + (OBJECT_TYPE (* From))); +#endif /* BAD_TYPES_LETHAL */ } - case TC_MANIFEST_CLOSURE: { fast long count; @@ -105,22 +108,22 @@ DEFUN (Update, continue; } } - if (GC_Type_Non_Pointer(*From)) + if (GC_Type_Non_Pointer(* From)) continue; - if (OBJECT_ADDRESS (*From) == Was) - *From = MAKE_POINTER_OBJECT (OBJECT_TYPE (*From), Will_Be); + if ((OBJECT_ADDRESS (* From)) == Was) + * From = (MAKE_POINTER_OBJECT (OBJECT_TYPE (* From), Will_Be)); } return; } +extern SCHEME_OBJECT * EXFUN (find_constant_space_block, (SCHEME_OBJECT *)); + long -DEFUN (Make_Impure, - (Object, New_Object), - SCHEME_OBJECT Object AND - SCHEME_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; + fast SCHEME_OBJECT * Obj_Address, * Constant_Address; + SCHEME_OBJECT * New_Address, * End_Of_Area; long Length, Block_Length; fast long i; @@ -129,7 +132,7 @@ DEFUN (Make_Impure, be pure. */ - Switch_by_GC_Type(Object) + Switch_by_GC_Type (Object) { case TC_BROKEN_HEART: case TC_MANIFEST_NM_VECTOR: @@ -145,7 +148,7 @@ DEFUN (Make_Impure, case TC_FUTURE: case_Vector: - Length = VECTOR_LENGTH (Object) + 1; + Length = ((VECTOR_LENGTH (Object)) + 1); break; case_Quadruple: @@ -182,25 +185,38 @@ DEFUN (Make_Impure, #endif /* BAD_TYPES_LETHAL */ } + Constant_Address = Free_Constant; + #ifdef FLOATING_ALIGNMENT /* Undo ALIGN_FLOAT(Free_Constant) in SET_CONSTANT_TOP (). */ - while ((*(Free_Constant - 1)) == (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))) - Free_Constant -= 1; - -#endif - - /* Add a copy of the object to the last constant block in memory. - */ + while ((* (Constant_Address - 1)) + == (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))) + Constant_Address -= 1; - Constant_Address = Free_Constant; +#endif /* FLOATING_ALIGNMENT */ Obj_Address = (OBJECT_ADDRESS (Object)); - if (!(TEST_CONSTANT_TOP (Constant_Address + Length))) + + if (! (TEST_CONSTANT_TOP (Constant_Address + Length))) { - return (ERR_IMPURIFY_OUT_OF_SPACE); + /* Make the whole block impure! */ + + SCHEME_OBJECT * block = (find_constant_space_block (Obj_Address)); + + if (block == ((SCHEME_OBJECT *) NULL)) + return (ERR_IMPURIFY_OUT_OF_SPACE); + + * block = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)); + * New_Object = Object; + return (PRIM_DONE); } + + /* + Add a copy of the object to the last constant block in memory. + */ + Block_Length = (OBJECT_DATUM (* (Constant_Address - 1))); Constant_Address -= 2; New_Address = Constant_Address; @@ -225,22 +241,25 @@ DEFUN (Make_Impure, Terminate_Old_Stacklet (); SEAL_CONSTANT_SPACE (); - End_Of_Area = (CONSTANT_SPACE_SEAL ()); + End_Of_Area = (CONSTANT_AREA_END ()); 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_AREA_START ()), End_Of_Area, Obj_Address, New_Address); EXIT_CRITICAL_SECTION ({}); - *New_Object = (MAKE_POINTER_OBJECT (OBJECT_TYPE (Object), New_Address)); + * New_Object = (MAKE_POINTER_OBJECT (OBJECT_TYPE (Object), New_Address)); return (PRIM_DONE); } DEFINE_PRIMITIVE ("PRIMITIVE-IMPURIFY", Prim_impurify, 1, 1, - "Remove OBJECT from pure space so it can be side effected.\n\ -The object is placed in constant space instead.") + "(object)\n\ +Remove OBJECT from pure space so it can be side effected.\n\ +The object is placed in constant space instead if it fits,\n\ +otherwise the whole block where it lives in pure space is marked\n\ +as being in constant space.") { PRIMITIVE_HEADER (1); { @@ -248,7 +267,7 @@ The object is placed in constant space instead.") SCHEME_OBJECT new_object; TOUCH_IN_PRIMITIVE ((ARG_REF (1)), old_object); { - fast long result = (Make_Impure (old_object, (&new_object))); + long result = (make_impure (old_object, (&new_object))); if (result != PRIM_DONE) signal_error_from_primitive (result); } @@ -256,14 +275,11 @@ The object is placed in constant space instead.") } } -extern SCHEME_OBJECT * EXFUN (find_constant_space_block, (SCHEME_OBJECT *)); - SCHEME_OBJECT * -DEFUN (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; + fast SCHEME_OBJECT * where, * low_constant; low_constant = Constant_Space; where = (Free_Constant - 1); @@ -278,13 +294,13 @@ DEFUN (find_constant_space_block, datum of 0 and are correctly skipped over. */ - if (*where = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))) + if (* where = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))) { where -= 1; continue; } #endif - where -= (1 + OBJECT_DATUM (*where)); + where -= (1 + (OBJECT_DATUM (* where))); if (where < obj_address) return (where + 1); } @@ -292,17 +308,15 @@ DEFUN (find_constant_space_block, } Boolean -DEFUN (Pure_Test, - (obj_address), - SCHEME_OBJECT *obj_address) +DEFUN (Pure_Test, (obj_address), SCHEME_OBJECT * obj_address) { - SCHEME_OBJECT *block; + SCHEME_OBJECT * block; block = (find_constant_space_block (obj_address)); if (block == ((SCHEME_OBJECT *) NULL)) return (false); return - ((Boolean) (obj_address <= (block + (OBJECT_DATUM (*block))))); + ((Boolean) (obj_address <= (block + (OBJECT_DATUM (* block))))); } DEFINE_PRIMITIVE ("PURE?", Prim_pure_p, 1, 1, @@ -363,9 +377,9 @@ DEFUN (copy_to_constant_space, fast SCHEME_OBJECT *source AND long nobjects) { - fast SCHEME_OBJECT *dest; fast long i; - SCHEME_OBJECT *result; + fast SCHEME_OBJECT * dest; + SCHEME_OBJECT * result; dest = Free_Constant; if (!(TEST_CONSTANT_TOP (dest + nobjects + 6))) diff --git a/v7/src/microcode/stack.h b/v7/src/microcode/stack.h index 2db397022..63af89159 100644 --- a/v7/src/microcode/stack.h +++ b/v7/src/microcode/stack.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: stack.h,v 9.35 1993/09/08 04:38:21 gjr Exp $ +$Id: stack.h,v 9.36 1993/10/14 19:20:58 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -55,12 +55,10 @@ MIT in each case. */ Stack is made up of linked small parts, each in the heap */ -#define Initialize_Stack() \ +#define INITIALIZE_STACK() do \ { \ if (GC_Check(Default_Stacklet_Size)) \ - { \ Microcode_Termination(TERM_STACK_ALLOCATION_FAILED); \ - } \ SET_STACK_GUARD (Free + STACKLET_HEADER_SIZE); \ *Free = \ (MAKE_OBJECT (TC_MANIFEST_VECTOR, (Default_Stacklet_Size - 1))); \ @@ -69,7 +67,11 @@ MIT in each case. */ Free_Stacklets = NULL; \ Prev_Restore_History_Stacklet = NULL; \ Prev_Restore_History_Offset = 0; \ -} +} while (0) + +/* This is a lie, but OK in the context in which it is used. */ + +#define STACK_OVERFLOWED_P() FALSE #define Internal_Will_Push(N) \ { \ @@ -83,7 +85,7 @@ MIT in each case. */ /* No space required independent of the heap for the stacklets */ -#define Stack_Allocation_Size(Stack_Blocks) 0 +#define STACK_ALLOCATION_SIZE(Stack_Blocks) 0 #define Current_Stacklet (Stack_Guard - STACKLET_HEADER_SIZE) @@ -97,7 +99,7 @@ MIT in each case. */ Current_Stacklet[STACKLET_UNUSED_LENGTH] = \ MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Stack_Pointer - Stack_Guard)); \ } - + #ifdef ENABLE_DEBUGGING_TOOLS #define Terminate_Old_Stacklet() \ @@ -111,22 +113,15 @@ MIT in each case. */ Internal_Terminate_Old_Stacklet(); \ } -#else +#else /* not ENABLE_DEBUGGING_TOOLS */ #define Terminate_Old_Stacklet() Internal_Terminate_Old_Stacklet() -#endif - -/* Used by garbage collector to detect the end of constant space */ - -#define CONSTANT_SCAN_SEAL() Free_Constant +#endif /* ENABLE_DEBUGGING_TOOLS */ -#define SEAL_CONSTANT_SPACE() \ - *Free_Constant = \ - (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant)); +/* Used by garbage collector to detect the end of constant space */ -#define CONSTANT_SPACE_SEALED() \ -((*Free_Constant) == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant))) +#define CONSTANT_AREA_START() Constant_Space #define Get_Current_Stacklet() \ (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Current_Stacklet)) @@ -251,9 +246,7 @@ Pushed() ((1 + VECTOR_LENGTH (Previous_Stacklet)) - \ CONTINUATION_SIZE)); \ if (Old_Stacklet_Top == Prev_Restore_History_Stacklet) \ - { \ Prev_Restore_History_Stacklet = NULL; \ - } \ if (First_Continuation[CONTINUATION_RETURN_CODE] == \ MAKE_OBJECT (TC_RETURN_CODE, RC_JOIN_STACKLETS)) \ { \ @@ -275,9 +268,7 @@ Pushed() Unused_Length) + 1; \ Old_Stacklet_Top += Unused_Length; \ while (--Used_Length >= 0) \ - { \ *temp++ = *Old_Stacklet_Top++; \ - } \ Free = temp; \ } \ } \ @@ -287,9 +278,7 @@ Pushed() \ if (OBJECT_ADDRESS (Previous_Stacklet)== \ Prev_Restore_History_Stacklet) \ - { \ Prev_Restore_History_Stacklet = NULL; \ - } \ Set_Current_Stacklet(Previous_Stacklet); \ } \ } @@ -300,45 +289,20 @@ Pushed() Full size stack in a statically allocated area */ -#define Stack_Check(P) \ -do \ +#define Stack_Check(P) do \ { \ if ((P) <= Stack_Guard) \ - { \ - if ((P) <= Absolute_Stack_Base) \ - { \ - Microcode_Termination (TERM_STACK_OVERFLOW); \ - } \ - REQUEST_INTERRUPT (INT_Stack_Overflow); \ - } \ + { \ + if ((P) <= Stack_Bottom) \ + Microcode_Termination (TERM_STACK_OVERFLOW); \ + REQUEST_INTERRUPT (INT_Stack_Overflow); \ + } \ } while (0) #define Internal_Will_Push(N) Stack_Check(Stack_Pointer - (N)) -#define Stack_Allocation_Size(Stack_Blocks) (Stack_Blocks) - #define Terminate_Old_Stacklet() -/* Used by garbage collector to detect the end of constant space, and to - skip over the gap between constant space and the stack. */ - -#define CONSTANT_SPACE_SEAL() Stack_Top - -#define SEAL_CONSTANT_SPACE() \ -do \ -{ \ - *Free_Constant = \ - (MAKE_OBJECT \ - (TC_MANIFEST_NM_VECTOR, ((Stack_Pointer - Free_Constant) - 1))); \ - *(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 #define Set_Current_Stacklet(Where) {} @@ -368,20 +332,16 @@ do \ control point. Also disables the history collection mechanism, since the saved history would be incorrect on the new stack. */ -#define Our_Throw(From_Pop_Return, P) \ +#define Our_Throw(From_Pop_Return, P) do \ { \ SCHEME_OBJECT Control_Point; \ fast SCHEME_OBJECT *To_Where, *From_Where; \ fast long len, valid, invalid; \ \ Control_Point = (P); \ - if (Consistency_Check) \ - { \ - if (OBJECT_TYPE (Control_Point) != TC_CONTROL_POINT) \ - { \ - Microcode_Termination (TERM_BAD_STACK); \ - } \ - } \ + if ((Consistency_Check) \ + && (OBJECT_TYPE (Control_Point) != TC_CONTROL_POINT)) \ + Microcode_Termination (TERM_BAD_STACK); \ len = VECTOR_LENGTH (Control_Point); \ invalid = ((OBJECT_DATUM (MEMORY_REF (Control_Point, \ STACKLET_UNUSED_LENGTH))) + \ @@ -393,17 +353,13 @@ do \ Stack_Check (To_Where); \ Stack_Pointer = To_Where; \ while (--valid >= 0) \ - { \ *To_Where++ = *From_Where++; \ - } \ if (Consistency_Check) \ { \ if ((To_Where != Stack_Top) || \ (From_Where != \ MEMORY_LOC (Control_Point, (1 + len)))) \ - { \ Microcode_Termination (TERM_BAD_STACK); \ - } \ } \ STACK_RESET (); \ if (!(From_Pop_Return)) \ @@ -412,20 +368,14 @@ do \ Prev_Restore_History_Offset = 0; \ if ((!Valid_Fixed_Obj_Vector ()) || \ (Get_Fixed_Obj_Slot (Dummy_History) == SHARP_F)) \ - { \ History = Make_Dummy_History (); \ - } \ else \ - { \ History = OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)); \ - } \ } \ else if (Prev_Restore_History_Stacklet == \ OBJECT_ADDRESS (Control_Point)) \ - { \ Prev_Restore_History_Stacklet = NULL; \ - } \ -} +} while (0) #define Our_Throw_Part_2() diff --git a/v7/src/microcode/storage.c b/v7/src/microcode/storage.c index e9fa28da2..8bd14d217 100644 --- a/v7/src/microcode/storage.c +++ b/v7/src/microcode/storage.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: storage.c,v 9.52 1992/09/26 02:55:04 cph Exp $ +$Id: storage.c,v 9.53 1993/10/14 19:21:51 gjr Exp $ Copyright (c) 1987-92 Massachusetts Institute of Technology @@ -45,24 +45,24 @@ SCHEME_OBJECT #ifndef DOS386 * MemTop, /* Top of free space available */ #endif /* DOS386 */ - * Ext_History, /* History register */ - * Free, /* Next free word in storage */ - * Ext_Stack_Pointer, /* Next available slot in control stack */ - * Stack_Top, /* Top of control stack */ - * Stack_Guard, /* Guard area at end of stack */ - * Free_Stacklets, /* Free list of stacklets */ - * Constant_Space, /* Bottom of constant+pure space */ - * Free_Constant, /* Next free cell in constant+pure area */ - * Constant_Top, /* Top of constant+pure space */ - * Heap_Top, /* Top of current heap */ - * Heap_Bottom, /* Bottom of current heap */ - * Unused_Heap_Top, /* Top of other heap */ - * Unused_Heap, /* Bottom of other heap */ - * Local_Heap_Base, /* Per-processor CONSing area */ - * Heap, /* Bottom of entire heap */ - Current_State_Point, /* Used by dynamic winder */ - Fluid_Bindings, /* Fluid bindings AList */ - * last_return_code; /* Address of the most recent return code in the stack. + * Free, /* Next free word in heap */ + * Heap_Top, /* Top of current heap */ + * Heap_Bottom, /* Bottom of current heap */ + * Unused_Heap_Top, /* Top of unused heap */ + * Unused_Heap_Bottom, /* Bottom of unused heap */ + * Stack_Guard, /* Guard area at end of stack */ + * Ext_Stack_Pointer, /* Next available slot in control stack */ + * Stack_Bottom, /* Bottom of control stack */ + * Stack_Top, /* Top of control stack */ + * Free_Constant, /* Next free word in constant space */ + * Constant_Space, /* Bottom of constant+pure space */ + * Constant_Top, /* Top of constant+pure space */ + * Local_Heap_Base, /* Per-processor CONSing area */ + * Free_Stacklets, /* Free list of stacklets */ + * Ext_History, /* History register */ + Current_State_Point, /* Dynamic state point */ + Fluid_Bindings, /* Fluid bindings AList */ + * last_return_code; /* Address of the most recent return code in the stack. This is only meaningful while in compiled code. *** This must be changed when stacklets are used. */ @@ -84,7 +84,7 @@ long Prev_Restore_History_Offset; long Heap_Size; long Constant_Size; long Stack_Size; -SCHEME_OBJECT * Highest_Allocated_Address; +SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address; #ifndef HEAP_IN_LOW_MEMORY SCHEME_OBJECT * memory_base; #endif diff --git a/v7/src/microcode/sysprim.c b/v7/src/microcode/sysprim.c index 385c178cb..abd9d3ed4 100644 --- a/v7/src/microcode/sysprim.c +++ b/v7/src/microcode/sysprim.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: sysprim.c,v 9.38 1993/01/07 23:53:46 cph Exp $ +$Id: sysprim.c,v 9.39 1993/10/14 19:22:57 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -136,7 +136,7 @@ DEFINE_PRIMITIVE ("GC-SPACE-STATUS", Prim_gc_space_status, 0, 0, 0) heap_limit = MemTop; heap_high = Heap_Top; #ifndef USE_STACKLETS - stack_low = Absolute_Stack_Base; + stack_low = Stack_Bottom; stack_free = Stack_Pointer; stack_limit = Stack_Guard; stack_high = Stack_Top; diff --git a/v7/src/microcode/uxtrap.c b/v7/src/microcode/uxtrap.c index 25b57f090..7d3343ece 100644 --- a/v7/src/microcode/uxtrap.c +++ b/v7/src/microcode/uxtrap.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: uxtrap.c,v 1.23 1993/08/28 22:46:05 gjr Exp $ +$Id: uxtrap.c,v 1.24 1993/10/14 19:20:41 gjr Exp $ Copyright (c) 1990-1993 Massachusetts Institute of Technology @@ -90,14 +90,14 @@ DEFUN_VOID (trap_immediate_termination) static void DEFUN_VOID (trap_dump_core) { - if (option_disable_core_dump) + if (! (option_disable_core_dump)) + UX_dump_core (); + else { fputs (">> Core dumps are disabled - Terminating normally.\n", stdout); fflush (stdout); termination_trap (); } - else - UX_dump_core (); } static void @@ -120,17 +120,13 @@ DEFUN (trap_handler, (message, signo, info, scp), struct FULL_SIGCONTEXT * scp) { int code = ((SIGINFO_VALID_P (info)) ? (SIGINFO_CODE (info)) : 0); - Boolean constant_space_broken = (!(CONSTANT_SPACE_SEALED ())); + Boolean stack_overflowed_p = (STACK_OVERFLOWED_P ()); enum trap_state old_trap_state = trap_state; if (old_trap_state == trap_state_exitting_hard) - { _exit (1); - } else if (old_trap_state == trap_state_exitting_soft) - { trap_immediate_termination (); - } trap_state = trap_state_trapped; if (WITHIN_CRITICAL_SECTION_P ()) { @@ -140,17 +136,17 @@ DEFUN (trap_handler, (message, signo, info, scp), fprintf (stdout, ">> [signal %d (%s), code %d]\n", signo, (find_signal_name (signo)), code); } - else if (constant_space_broken || (old_trap_state != trap_state_recover)) + else if (stack_overflowed_p || (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) + if (stack_overflowed_p) { - fputs (">> Constant space has been overwritten.\n", stdout); - fputs (">> Probably a runaway recursion has overflowed the stack.\n", + fputs (">> The stack has overflowed overwriting adjacent memory.\n", stdout); + fputs (">> This was probably caused by a runaway recursion.\n", stdout); } fflush (stdout); @@ -178,7 +174,7 @@ DEFUN (trap_handler, (message, signo, info, scp), else trap_immediate_termination (); case trap_state_recover: - if ((WITHIN_CRITICAL_SECTION_P ()) || constant_space_broken) + if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p) { fputs (">> Successful recovery is unlikely.\n", stdout); break; @@ -332,7 +328,7 @@ DEFUN (setup_trap_frame, (signo, info, scp, trinfo, new_stack_pointer), signal_code = (find_signal_code_name (signo, info, scp)); if (!stack_recovered_p) { - Initialize_Stack (); + INITIALIZE_STACK (); Will_Push (CONTINUATION_SIZE); Store_Return (RC_END_OF_COMPUTATION); Store_Expression (SHARP_F); @@ -498,14 +494,14 @@ DEFUN (continue_from_trap, (signo, info, scp), scheme_sp_valid = (pc_in_scheme && ((scheme_sp < ((long) Stack_Top)) && - (scheme_sp >= ((long) Absolute_Stack_Base)) && + (scheme_sp >= ((long) Stack_Bottom)) && ((scheme_sp & STACK_ALIGNMENT_MASK) == 0))); new_stack_pointer = (scheme_sp_valid ? ((SCHEME_OBJECT *) scheme_sp) : (pc_in_C && (Stack_Pointer < Stack_Top) - && (Stack_Pointer > Absolute_Stack_Base)) + && (Stack_Pointer > Stack_Bottom)) ? Stack_Pointer : ((SCHEME_OBJECT *) 0)); diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 9cdd4233b..99bacf5e8 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: version.h,v 11.143 1993/09/11 03:10:22 gjr Exp $ +$Id: version.h,v 11.144 1993/10/14 19:20:27 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 143 +#define SUBVERSION 144 #endif diff --git a/v8/src/microcode/bintopsb.c b/v8/src/microcode/bintopsb.c index 2fd83bfa2..7153d4a9e 100644 --- a/v8/src/microcode/bintopsb.c +++ b/v8/src/microcode/bintopsb.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bintopsb.c,v 9.55 1992/10/31 23:41:13 jinx Exp $ +$Id: bintopsb.c,v 9.56 1993/10/14 19:16:56 gjr Exp $ Copyright (c) 1987-1992 Massachusetts Institute of Technology @@ -822,9 +822,7 @@ DEFUN (relocate, (object), if ((the_datum >= Heap_Base) && (the_datum < Dumped_Heap_Top)) - { result += Heap_Relocation; - } #if FALSE @@ -832,16 +830,12 @@ DEFUN (relocate, (object), else if (( the_datum >= Const_Base) && (the_datum < Dumped_Constant_Top)) - { result += Constant_Relocation; - } #endif /* false */ else - { out_of_range_pointer(object); - } return (result); } @@ -911,7 +905,7 @@ DEFUN (upgrade_primitive, (prim), SCHEME_OBJECT * DEFUN (setup_primitive_upgrade, (Heap), - SCHEME_OBJECT *Heap) + SCHEME_OBJECT * Heap) { fast long count, length; SCHEME_OBJECT *old_prims_vector; @@ -1350,7 +1344,10 @@ DEFUN_VOID (do_it) { /* Load the Data */ - SCHEME_OBJECT *Heap, *Storage; + SCHEME_OBJECT + * Heap, + * Lowest_Allocated_Address, + * Highest_Allocated_Address; long Initial_Free; switch (Read_Header ()) @@ -1467,7 +1464,9 @@ DEFUN_VOID (do_it) /* This is way larger than needed, but... what the hell? */ - Size = ((3 * (Heap_Count + Const_Count)) + + Size = ((TRAP_MAX_IMMEDIATE + 1) + + ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))) + + (3 * (Heap_Count + Const_Count)) + (NROOTS + 1) + (upgrade_primitives_p ? (3 * PRIMITIVE_UPGRADE_SPACE) : @@ -1476,9 +1475,11 @@ DEFUN_VOID (do_it) (2 * (Heap_Count + Const_Count)) : 0)); - ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE); + ALLOCATE_HEAP_SPACE (Size, + Lowest_Allocated_Address, + Highest_Allocated_Address); - if (Heap == ((SCHEME_OBJECT *) 0)) + if (Lowest_Allocated_Address == ((SCHEME_OBJECT *) NULL)) { fprintf (stderr, "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n", @@ -1487,9 +1488,8 @@ DEFUN_VOID (do_it) } } - Storage = Heap; - Heap += HEAP_BUFFER_SPACE; - INITIAL_ALIGN_FLOAT (Heap); + Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1)); + ALIGN_FLOAT (Heap); if ((Load_Data (Heap_Count, Heap)) != Heap_Count) { fprintf (stderr, "%s: Could not load the heap's contents.\n", @@ -1513,15 +1513,11 @@ DEFUN_VOID (do_it) compiled_entry_table_end = compiled_entry_table; if (allow_compiled_p) - { compiled_entry_table_end += (2 * (Heap_Count + Const_Count)); - } primitive_table = compiled_entry_table_end; if (upgrade_primitives_p) - { primitive_table_end = (setup_primitive_upgrade (primitive_table)); - } else { fast SCHEME_OBJECT *table; @@ -1744,7 +1740,7 @@ DEFUN_VOID (do_it) } } fflush (portable_file); - free ((char *) Storage); + free ((char *) Lowest_Allocated_Address); } } diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index df5a3642f..805969d8a 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: interp.c,v 9.78 1993/09/07 21:47:14 gjr Exp $ +$Id: interp.c,v 9.79 1993/10/14 19:15:10 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -121,16 +121,6 @@ if (GC_Check(Amount)) \ Prepare_Eval_Repeat(); \ Immediate_GC(Amount); \ } - -#define RESULT_OF_PURIFY(success) \ -{ \ - SCHEME_OBJECT words_free; \ - \ - words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free)); \ - Val = (MAKE_POINTER_OBJECT (TC_LIST, Free)); \ - (*Free++) = (success); \ - (*Free++) = words_free; \ -} #define Prepare_Eval_Repeat() \ { \ @@ -1988,18 +1978,18 @@ return_from_compiled_code: break; case RC_NORMAL_GC_DONE: - Val = Fetch_Expression(); + Val = (Fetch_Expression ()); if (GC_Space_Needed < 0) { /* Paranoia */ GC_Space_Needed = 0; } - if (GC_Check(GC_Space_Needed)) + if (GC_Check (GC_Space_Needed)) termination_gc_out_of_space (); GC_Space_Needed = 0; EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); }); - End_GC_Hook(); + End_GC_Hook (); break; case RC_PCOMB1_APPLY: @@ -2102,50 +2092,6 @@ Primitive_Internal_Apply: Import_Registers (); break; -/* Interpret() continues on the next page */ - -/* Interpret(), continued */ - - case RC_PURIFY_GC_1: - { - SCHEME_OBJECT GC_Daemon_Proc, Result; - - RENAME_CRITICAL_SECTION ("purify pass 2"); - Export_Registers(); - Result = Purify_Pass_2(Fetch_Expression()); - Import_Registers(); - if (Result == SHARP_F) - { - /* The object does not fit in Constant space. - There is no need to run the daemons, and we should let - the runtime system know what happened. */ - RESULT_OF_PURIFY (SHARP_F); - EXIT_CRITICAL_SECTION ({ Export_Registers(); }); - break; - } - GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon); - if (GC_Daemon_Proc == SHARP_F) - { - RESULT_OF_PURIFY (SHARP_T); - EXIT_CRITICAL_SECTION ({ Export_Registers(); }); - break; - } - RENAME_CRITICAL_SECTION( "purify daemon 2"); - Store_Expression(SHARP_F); - Store_Return(RC_PURIFY_GC_2); - Save_Cont(); - Will_Push(2); - STACK_PUSH (GC_Daemon_Proc); - STACK_PUSH (STACK_FRAME_HEADER); - Pushed(); - goto Internal_Apply; - } - - case RC_PURIFY_GC_2: - RESULT_OF_PURIFY (SHARP_T); - EXIT_CRITICAL_SECTION ({ Export_Registers(); }); - break; - case RC_REPEAT_DISPATCH: Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ())); Restore_Env(); diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h index bb4653ae1..4d0ed3f82 100644 --- a/v8/src/microcode/object.h +++ b/v8/src/microcode/object.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: object.h,v 9.42 1993/08/21 03:58:18 gjr Exp $ +$Id: object.h,v 9.43 1993/10/14 19:19:02 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -141,13 +141,16 @@ MIT in each case. */ typedef long relocation_type; /* Used to relocate pointers on fasload */ -/* The "-1" in the value returned is a guarantee that there is one - word reserved exclusively for use by the garbage collector. */ -#define ALLOCATE_HEAP_SPACE(space) \ - (Heap = \ - ((SCHEME_OBJECT *) \ - (HEAP_MALLOC ((sizeof (SCHEME_OBJECT)) * (space)))), \ - ((Heap + (space)) - 1)) +#define ALLOCATE_HEAP_SPACE(space,low,high) do \ +{ \ + unsigned long _space = (space); \ + SCHEME_OBJECT * _low \ + = ((SCHEME_OBJECT *) \ + (HEAP_MALLOC ((sizeof (SCHEME_OBJECT)) * _space))); \ + \ + (low) = _low; \ + (high) = (_low + _space); \ +} while (0) #ifndef DATUM_TO_ADDRESS #define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) (datum)) @@ -165,14 +168,14 @@ typedef SCHEME_OBJECT * relocation_type; extern SCHEME_OBJECT * memory_base; -/* The "-1" in the value returned is a guarantee that there is one - word reserved exclusively for use by the garbage collector. */ -#define ALLOCATE_HEAP_SPACE(space) \ - (memory_base = \ - ((SCHEME_OBJECT *) \ - (HEAP_MALLOC ((sizeof (SCHEME_OBJECT)) * (space)))), \ - Heap = memory_base, \ - ((memory_base + (space)) - 1)) +#define ALLOCATE_HEAP_SPACE(space,low,high) do \ +{ \ + unsigned long _space = (space); \ + memory_base = ((SCHEME_OBJECT *) \ + (HEAP_MALLOC ((sizeof (SCHEME_OBJECT)) * _space))); \ + (low) = memory_base; \ + (high) = (memory_base + _space); \ +} while (0) #ifndef DATUM_TO_ADDRESS #define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) ((datum) + memory_base)) @@ -490,35 +493,17 @@ if ((ADDRESS_CONSTANT_P (OBJECT_ADDRESS (Old_Pointer))) && \ (Pure_Test (OBJECT_ADDRESS (Old_Pointer)))) \ signal_error_from_primitive (ERR_WRITE_INTO_PURE_SPACE); \ -#ifdef FLOATING_ALIGNMENT - -#define FLOATING_BUFFER_SPACE \ - ((FLOATING_ALIGNMENT + 1) / (sizeof (SCHEME_OBJECT))) - -#define HEAP_BUFFER_SPACE \ - (TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE) +#ifndef FLOATING_ALIGNMENT +#define FLOATING_ALIGNMENT 0 +#endif /* not FLOATING_ALIGNMENT */ -/* The space is there, find the correct position. */ +#define FLOATING_ALIGNED_P(ptr) \ + ((((unsigned long) ((ptr) + 1)) & FLOATING_ALIGNMENT) == 0) -#define INITIAL_ALIGN_FLOAT(Where) \ +#define ALIGN_FLOAT(Where) do \ { \ - while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ - Where -= 1; \ -} - -#define ALIGN_FLOAT(Where) \ -{ \ - while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ + while (! (FLOATING_ALIGNED_P (Where))) \ *Where++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)); \ -} - -#else /* not FLOATING_ALIGNMENT */ - -#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1) - -#define INITIAL_ALIGN_FLOAT(Where) -#define ALIGN_FLOAT(Where) - -#endif /* not FLOATING_ALIGNMENT */ +} while (0) #endif /* SCM_OBJECT_H */ diff --git a/v8/src/microcode/ppband.c b/v8/src/microcode/ppband.c index c77ebe7d9..96b179040 100644 --- a/v8/src/microcode/ppband.c +++ b/v8/src/microcode/ppband.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: ppband.c,v 9.45 1993/06/24 07:09:15 gjr Exp $ +$Id: ppband.c,v 9.46 1993/10/14 19:16:32 gjr Exp $ Copyright (c) 1987-1992 Massachusetts Institute of Technology @@ -144,13 +144,9 @@ DEFUN (print_long_as_string, (string), char *string) { c = *temp++; if (isgraph ((int) c)) - { putchar (c); - } else - { putchar (' '); - } } printf ("\" = "); @@ -230,25 +226,17 @@ DEFUN (scheme_string, (From, Quoted), long From AND Boolean Quoted) if (&Chars[Count] < ((char *) end_of_memory)) { if (Quoted) - { putchar ('\"'); - } for (i = 0; i < Count; i++) - { printf ("%c", *Chars++); - } if (Quoted) - { putchar ('\"'); - } putchar ('\n'); return (true); } } if (Quoted) - { printf ("String not in memory; datum = %lx\n", From); - } return (false); } @@ -262,31 +250,29 @@ DEFUN (scheme_symbol, (From), long From) symbol = &Data[From+SYMBOL_NAME]; if ((symbol >= end_of_memory) || (!(scheme_string (via (From + SYMBOL_NAME), false)))) - { printf ("symbol not in memory; datum = %lx\n", From); - } return; } static char string_buffer[10]; -#define PRINT_OBJECT(type, datum) \ +#define PRINT_OBJECT(type, datum) do \ { \ printf ("[%s %lx]", type, datum); \ -} +} while (0) -#define NON_POINTER(string) \ +#define NON_POINTER(string) do \ { \ the_string = string; \ Points_To = The_Datum; \ break; \ -} +} while (0) -#define POINTER(string) \ +#define POINTER(string) do \ { \ the_string = string; \ break; \ -} +} while (0) char *Type_Names[] = TYPE_NAME_TABLE; @@ -357,24 +343,16 @@ DEFUN (Display, (Location, Type, The_Datum), case TC_REFERENCE_TRAP: if (The_Datum <= TRAP_MAX_IMMEDIATE) - { NON_POINTER ("REFERENCE-TRAP"); - } else - { POINTER ("REFERENCE-TRAP"); - } case TC_BROKEN_HEART: if (The_Datum == 0) - { Points_To = 0; - } default: if (Type <= LAST_TYPE_CODE) - { POINTER (Type_Names[Type]); - } else { sprintf (&string_buf[0], "0x%02lx ", Type); @@ -420,9 +398,7 @@ DEFUN (show_area, (area, start, end, name), area -= 1; } else - { Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area))); - } } return (area); } @@ -445,9 +421,7 @@ DEFUN (main, (argc, argv), { case FASL_FILE_FINE : if (counter != 0) - { printf ("\f\n\t*** New object ***\n\n"); - } break; /* There should really be a difference between no header @@ -482,7 +456,8 @@ DEFUN (main, (argc, argv), } load_length = (Heap_Count + Const_Count + Primitive_Table_Size); - Data = ((SCHEME_OBJECT *) malloc (sizeof (SCHEME_OBJECT) * (load_length + 4))); + Data = ((SCHEME_OBJECT *) + (malloc (sizeof (SCHEME_OBJECT) * (load_length + 4)))); if (Data == NULL) { fprintf (stderr, "Allocation of %ld words failed.\n", (load_length + 4)); @@ -496,29 +471,19 @@ DEFUN (main, (argc, argv), printf ("Expected %ld objects. Obtained %ld objects.\n\n", ((long) load_length), ((long) total_length)); if (total_length < Heap_Count) - { Heap_Count = total_length; - } total_length -= Heap_Count; if (total_length < Const_Count) - { Const_Count = total_length; - } total_length -= Const_Count; if (total_length < Primitive_Table_Size) - { Primitive_Table_Size = total_length; - } } if (Heap_Count > 0) - { Next = show_area (Data, 0, Heap_Count, "Heap"); - } if (Const_Count > 0) - { Next = show_area (Next, Heap_Count, Const_Count, "Constant Space"); - } if ((Primitive_Table_Size > 0) && (Next < end_of_memory)) { long arity, size; @@ -547,9 +512,7 @@ DEFUN (main, (argc, argv), printf ("\n"); } if (argc != 1) - { exit (0); - } free ((char *) Data); counter = 1; } diff --git a/v8/src/microcode/psbtobin.c b/v8/src/microcode/psbtobin.c index b03114d45..4c3dd6016 100644 --- a/v8/src/microcode/psbtobin.c +++ b/v8/src/microcode/psbtobin.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: psbtobin.c,v 9.49 1993/06/24 07:09:36 gjr Exp $ +$Id: psbtobin.c,v 9.50 1993/10/14 19:17:26 gjr Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -939,7 +939,7 @@ DEFUN_VOID (short_header_read) quit (1); } -static SCHEME_OBJECT *Storage; +static SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address; long DEFUN_VOID (Read_Header_and_Allocate) @@ -1043,7 +1043,7 @@ DEFUN_VOID (Read_Header_and_Allocate) #endif Size = (6 + /* SNMV */ - HEAP_BUFFER_SPACE + + (TRAP_MAX_IMMEDIATE + 1) + Heap_Count + Heap_Objects + Constant_Count + Constant_Objects + Pure_Count + Pure_Objects + @@ -1057,16 +1057,17 @@ DEFUN_VOID (Read_Header_and_Allocate) ((Primitive_Table_Length * (2 + STRING_CHARS)) + (char_to_pointer (NPChars)))); - ALLOCATE_HEAP_SPACE (Size); - if (Heap == NULL) + ALLOCATE_HEAP_SPACE (Size, + Lowest_Allocated_Address, + Highest_Allocated_Address); + if (Lowest_Allocated_Address == NULL) { fprintf (stderr, "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n", program_name, Size); quit (1); } - Storage = Heap; - Heap += (TRAP_MAX_IMMEDIATE + 1); + Heap = (Lowest_Allocated_Address + (TRAP_MAX_IMMEDIATE + 1)); return (Size - (TRAP_MAX_IMMEDIATE + 1)); } @@ -1237,7 +1238,7 @@ DEFUN_VOID (do_it) fprintf (stderr, "%s: Error writing the output file.\n", program_name); quit (1); } - free ((char *) Storage); + free ((char *) Lowest_Allocated_Address); } } diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index 9cdd4233b..99bacf5e8 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: version.h,v 11.143 1993/09/11 03:10:22 gjr Exp $ +$Id: version.h,v 11.144 1993/10/14 19:20:27 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 143 +#define SUBVERSION 144 #endif -- 2.25.1