when things are purified.
/* -*-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
}
}
\f
+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;
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));
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));
/* -*-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
* weak_pair_stack_ptr,
* weak_pair_stack_limit,
* virtual_scan_pointer;
-
+\f
extern SCHEME_OBJECT
* EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **, SCHEME_OBJECT **)),
* EXFUN (dump_and_reload_scan_buffer, (long, Boolean *)),
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 *));
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); \
#define relocate_normal_setup() \
{ \
Old = (OBJECT_ADDRESS (Temp)); \
- if (Old >= Low_Constant) \
+ if (Old < low_heap) \
continue; \
if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) \
{ \
#define relocate_typeless_setup() \
{ \
Old = (SCHEME_ADDR_TO_ADDR (Temp)); \
- if (Old >= Low_Constant) \
+ if (Old < low_heap) \
continue; \
if (BROKEN_HEART_P (* Old)) \
{ \
#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); \
{ \
/* -*-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
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++)
{
/* -*-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
- 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.
------------------------------------------
| 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.
*/
\f
/* Exports */
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. */
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;
return;
}
\f
+#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)
DEALLOCATE_REGISTERS ();
return;
}
-
+\f
#define BLOCK_TO_IO_SIZE(size) \
((ALIGN_UP_TO_IO_PAGE ((size) * (sizeof (SCHEME_OBJECT)))) \
/ (sizeof (SCHEME_OBJECT)))
-\f
+
static int
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",
}
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);
}
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 ();
/*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",
/*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);
-\f
/* Consistency check 3 */
test_value =
(MAKE_POINTER_OBJECT (LAST_TYPE_CODE, Highest_Allocated_Address));
/*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,
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);
}
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;
{
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);
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))
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)))
{
{
long position, offset;
- if (addr >= Constant_Space)
+ if (addr < Constant_Top)
return (addr);
position = (addr - aligned_heap);
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)
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);
return;
}
\f
+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;
+}
+\f
/* Here is the set up for the full garbage collection:
- First it makes the constant space and stack into one large area
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;
\f
- 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,
/*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)
{
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++));
-\f
- 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;
}
-
+\f
/* (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*/
}
\f
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));
/* -*-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
#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; \
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++)
{
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. */
}
\f
case_Cell:
+ if (purify_mode == CONSTANT_COPY)
+ break;
relocate_normal_pointer (copy_cell(), 1);
case TC_REFERENCE_TRAP:
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:
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);
\f
case TC_BIG_FLONUM:
+ if (purify_mode == CONSTANT_COPY)
+ break;
relocate_flonum_setup ();
goto Move_Vector;
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;
case_Non_Pointer:
break;
-
}
}
end_purifyloop:
(* To_Address_ptr) = To_Address;
return (Scan);
}
-\f
+
/* This is not paranoia!
The two words in the header may overflow the free buffer.
*/
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));
return (free_buffer);
}
\f
-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));
\f
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;
}
\f
/* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN)
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 ();
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*/
}
/* -*-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
if ((the_datum >= Heap_Base) &&
(the_datum < Dumped_Heap_Top))
- {
result += Heap_Relocation;
- }
#if FALSE
else if (( the_datum >= Const_Base) &&
(the_datum < Dumped_Constant_Top))
- {
result += Constant_Relocation;
- }
#endif /* false */
else
- {
out_of_range_pointer(object);
- }
return (result);
}
\f
\f
SCHEME_OBJECT *
DEFUN (setup_primitive_upgrade, (Heap),
- SCHEME_OBJECT *Heap)
+ SCHEME_OBJECT * Heap)
{
fast long count, length;
SCHEME_OBJECT *old_prims_vector;
{
/* Load the Data */
- SCHEME_OBJECT *Heap, *Storage;
+ SCHEME_OBJECT
+ * Heap,
+ * Lowest_Allocated_Address,
+ * Highest_Allocated_Address;
long Initial_Free;
switch (Read_Header ())
/* 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) :
(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",
}
}
- 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",
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;
}
}
fflush (portable_file);
- free ((char *) Storage);
+ free ((char *) Lowest_Allocated_Address);
}
}
\f
/* -*-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
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*/
}
/* -*-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
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
\f
-#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 (); \
#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
\f
#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
\f
/* Used in interpret.c */
/* -*-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
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 ())
{
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);
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;
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);
&& ((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 =
: ((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)));
/* -*-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
#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 */
\f
/* Address of the most recent return code in the stack. This is
only meaningful while in compiled code. *** This must be changed
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;
\f
/* Environment lookup utilities. */
extern long EXFUN (Lex_Ref, (SCHEME_OBJECT, SCHEME_OBJECT));
/* Memory management utilities */
-extern SCHEME_OBJECT EXFUN (Purify_Pass_2, (SCHEME_OBJECT));
extern Boolean EXFUN (Pure_Test, (SCHEME_OBJECT *));
\f
/* Interpreter utilities */
/* -*-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
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);
/* -*-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
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);
\f
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);
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*/
/* 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)
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;
}
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;
}
\f
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));
return (Result);
}
-#define Relocate_Into(Loc, P) (Loc) = Relocate(P)
+#define RELOCATE relocate
+#define RELOCATE_INTO(Loc, P) (Loc) = relocate(P)
\f
#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 */
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),
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:
{
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;
}
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);
}
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;
\f
#ifdef BYTE_INVERSION
case TC_CHARACTER_STRING:
- String_Inversion (Relocate (OBJECT_DATUM (Temp)));
+ String_Inversion (RELOCATE (OBJECT_DATUM (Temp)));
goto normal_pointer;
#endif
#endif
address = (OBJECT_DATUM (Temp));
*Scan++ = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (Temp)),
- (Relocate (address))));
+ (RELOCATE (address))));
break;
}
}
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);
}
\f
/* (BINARY-FASLOAD FILE-NAME-OR-CHANNEL)
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
{
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;
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 ();
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 *)));
}
/* Reset implementation state paramenters */
INITIALIZE_INTERRUPTS ();
- Initialize_Stack ();
+ INITIALIZE_STACK ();
SET_MEMTOP (Heap_Top - GC_Reserve);
{
SCHEME_OBJECT cutl = (MEMORY_REF (result, 1));
/* -*-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
{ \
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, \
#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)); \
#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, \
/* -*-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
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
/* -*-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
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; \
-}
\f
#define Prepare_Eval_Repeat() \
{ \
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;
\f
case RC_PCOMB1_APPLY:
Import_Registers ();
break;
-/* Interpret() continues on the next page */
-\f
-/* 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();
/* -*-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
(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]))
/* -*-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
\f
/* 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).
*/
\f
+#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 ();
+}
+\f
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)
{
DEALLOCATE_REGISTERS ();
return;
}
-\f
+
/* This procedure allocates and divides the total memory. */
void
}
/* 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))
failed_consistency_check ();
}
- Heap_Bottom = Heap;
Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
return;
}
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;
}
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);
case GC_Quadruple:
case GC_Vector:
Old = OBJECT_ADDRESS (Old_Car);
- if (Old >= Low_Constant)
+ if (Old < low_heap)
{
*Scan = Temp;
continue;
case GC_Compiled:
Old = OBJECT_ADDRESS (Old_Car);
- if (Old >= Low_Constant)
+ if (Old < low_heap)
{
*Scan = Temp;
continue;
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);
/* 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");
Root += 1;
}
else
- {
Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*Root++));
- }
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
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");
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*/
}
\f
/* -*-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
IFVERBOSE (TellUserEx (MB_OKCANCEL, "WinntExceptionTransferHook."));
if (clear_real_stack)
- Initialize_Stack ();
+ INITIALIZE_STACK ();
else
{
Stack_Pointer = real_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;
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"));
? ((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)));
\f
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;
(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");
}
\f
switch (old_trap_state)
}
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;
{
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.
*/
/* -*-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
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))
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))
(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 */
/* -*-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
{
c = *temp++;
if (isgraph ((int) c))
- {
putchar (c);
- }
else
- {
putchar (' ');
- }
}
printf ("\" = ");
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);
}
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;
}
\f
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;
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);
area -= 1;
}
else
- {
Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
- }
}
return (area);
}
{
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
}
\f
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));
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;
- }
}
\f
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;
printf ("\n");
}
if (argc != 1)
- {
exit (0);
- }
free ((char *) Data);
counter = 1;
}
/* -*-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
quit (1);
}
-static SCHEME_OBJECT *Storage;
+static SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address;
long
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 +
((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));
}
\f
fprintf (stderr, "%s: Error writing the output file.\n", program_name);
quit (1);
}
- free ((char *) Storage);
+ free ((char *) Lowest_Allocated_Address);
}
}
\f
/* -*-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
/* Imports */
-extern void EXFUN (GCFlip, (void));
extern void EXFUN (GC, (void));
extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
\f
{ \
Old = (OBJECT_ADDRESS (Temp)); \
if ((GC_Mode == CONSTANT_COPY) && \
- (Old > Low_Constant)) \
+ (Old < low_heap)) \
continue; \
Code; \
}
{ \
Old = (SCHEME_ADDR_TO_ADDR (Temp)); \
if ((GC_Mode == CONSTANT_COPY) && \
- (Old > Low_Constant)) \
+ (Old < low_heap)) \
continue; \
Code; \
}
}
\f
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
break;
});
\f
- /* 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.
*To_Pointer = To;
return (To);
-} /* PurifyLoop */
+} /* purifyloop */
\f
/* 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)
. ^
| SNMH | Pure Size N |
|----------------------|
- >>Base of Memory (Heap below here)<<
-*/
-\f
-/* 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);
-}
+*/
\f
-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 */
-\f
-/* 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);
}
\f
/* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN)
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
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);
/* -*-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
#include "zones.h"
\f
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
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;
}
-
+\f
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 */
}
-\f
case TC_MANIFEST_CLOSURE:
{
fast long count;
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;
}
\f
+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;
be pure.
*/
- Switch_by_GC_Type(Object)
+ Switch_by_GC_Type (Object)
{
case TC_BROKEN_HEART:
case TC_MANIFEST_NM_VECTOR:
case TC_FUTURE:
case_Vector:
- Length = VECTOR_LENGTH (Object) + 1;
+ Length = ((VECTOR_LENGTH (Object)) + 1);
break;
case_Quadruple:
#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;
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);
}
\f
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);
{
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);
}
}
}
-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);
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);
}
}
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)))));
}
\f
DEFINE_PRIMITIVE ("PURE?", Prim_pure_p, 1, 1,
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)))
/* -*-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
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))); \
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) \
{ \
/* 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)
Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Stack_Pointer - Stack_Guard)); \
}
-
+\f
#ifdef ENABLE_DEBUGGING_TOOLS
#define Terminate_Old_Stacklet() \
Internal_Terminate_Old_Stacklet(); \
}
-#else
+#else /* not ENABLE_DEBUGGING_TOOLS */
#define Terminate_Old_Stacklet() Internal_Terminate_Old_Stacklet()
-#endif
-\f
-/* 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))
((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)) \
{ \
Unused_Length) + 1; \
Old_Stacklet_Top += Unused_Length; \
while (--Used_Length >= 0) \
- { \
*temp++ = *Old_Stacklet_Top++; \
- } \
Free = temp; \
} \
} \
\
if (OBJECT_ADDRESS (Previous_Stacklet)== \
Prev_Restore_History_Stacklet) \
- { \
Prev_Restore_History_Stacklet = NULL; \
- } \
Set_Current_Stacklet(Previous_Stacklet); \
} \
}
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) {}
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))) + \
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)) \
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()
/* -*-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
#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. */
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
/* -*-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
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;
/* -*-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
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
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 ())
{
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);
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;
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);
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));
\f
/* -*-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
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 143
+#define SUBVERSION 144
#endif
/* -*-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
if ((the_datum >= Heap_Base) &&
(the_datum < Dumped_Heap_Top))
- {
result += Heap_Relocation;
- }
#if FALSE
else if (( the_datum >= Const_Base) &&
(the_datum < Dumped_Constant_Top))
- {
result += Constant_Relocation;
- }
#endif /* false */
else
- {
out_of_range_pointer(object);
- }
return (result);
}
\f
\f
SCHEME_OBJECT *
DEFUN (setup_primitive_upgrade, (Heap),
- SCHEME_OBJECT *Heap)
+ SCHEME_OBJECT * Heap)
{
fast long count, length;
SCHEME_OBJECT *old_prims_vector;
{
/* Load the Data */
- SCHEME_OBJECT *Heap, *Storage;
+ SCHEME_OBJECT
+ * Heap,
+ * Lowest_Allocated_Address,
+ * Highest_Allocated_Address;
long Initial_Free;
switch (Read_Header ())
/* 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) :
(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",
}
}
- 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",
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;
}
}
fflush (portable_file);
- free ((char *) Storage);
+ free ((char *) Lowest_Allocated_Address);
}
}
\f
/* -*-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
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; \
-}
\f
#define Prepare_Eval_Repeat() \
{ \
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;
\f
case RC_PCOMB1_APPLY:
Import_Registers ();
break;
-/* Interpret() continues on the next page */
-\f
-/* 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();
/* -*-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
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))
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))
(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 */
/* -*-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
{
c = *temp++;
if (isgraph ((int) c))
- {
putchar (c);
- }
else
- {
putchar (' ');
- }
}
printf ("\" = ");
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);
}
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;
}
\f
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;
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);
area -= 1;
}
else
- {
Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
- }
}
return (area);
}
{
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
}
\f
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));
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;
- }
}
\f
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;
printf ("\n");
}
if (argc != 1)
- {
exit (0);
- }
free ((char *) Data);
counter = 1;
}
/* -*-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
quit (1);
}
-static SCHEME_OBJECT *Storage;
+static SCHEME_OBJECT * Lowest_Allocated_Address, * Highest_Allocated_Address;
long
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 +
((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));
}
\f
fprintf (stderr, "%s: Error writing the output file.\n", program_name);
quit (1);
}
- free ((char *) Storage);
+ free ((char *) Lowest_Allocated_Address);
}
}
\f
/* -*-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
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 143
+#define SUBVERSION 144
#endif
projects / mit-scheme.git / commitdiff