/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.56 1990/11/13 08:44:07 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.57 1991/02/24 01:10:08 jinx Exp $
-Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1987-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
static char gc_default_file_name[FILE_NAME_LENGTH] = GC_DEFAULT_FILE_NAME;
void
-open_gc_file(size)
- int size;
+DEFUN (open_gc_file, (size), int size)
{
int position;
int flags;
- (void) mktemp(gc_default_file_name);
+ (void) (mktemp (gc_default_file_name));
flags = GC_FILE_FLAGS;
gc_file_name = option_gc_file;
if (gc_file_name == 0)
}
while (1)
{
- gc_file = open(gc_file_name, flags, GC_FILE_MASK);
+ gc_file = (open (gc_file_name, flags, GC_FILE_MASK));
if (gc_file != -1)
{
break;
}
if (gc_file_name != gc_default_file_name)
{
- fprintf(stderr,
- "%s: GC file \"%s\" cannot be opened; ",
- scheme_program_name, gc_file_name);
+ fprintf (stderr,
+ "%s: GC file \"%s\" cannot be opened; ",
+ scheme_program_name, gc_file_name);
gc_file_name = gc_default_file_name;
- fprintf(stderr,
- "Using \"%s\" instead.\n",
- gc_file_name);
+ fprintf (stderr,
+ "Using \"%s\" instead.\n",
+ gc_file_name);
flags |= O_EXCL;
continue;
}
- fprintf(stderr,
- "%s: GC file \"%s\" cannot be opened; Aborting.\n",
- scheme_program_name, gc_file_name);
- exit(1);
+ fprintf (stderr,
+ "%s: GC file \"%s\" cannot be opened; Aborting.\n",
+ scheme_program_name, gc_file_name);
+ exit (1);
}
#ifdef _HPUX
if (gc_file_name == gc_default_file_name)
{
- extern prealloc();
- prealloc(gc_file, size);
+ extern prealloc ();
+ prealloc (gc_file, size);
/* Prealloc may change (it does under 6.5) the file pointer! */
- if ((lseek(gc_file, 0, 0)) == -1)
+ if ((lseek (gc_file, 0, 0)) == -1)
{
- fprintf(stderr,
- "%s: cannot position at start of GC file \"%s\"; Aborting.\n",
- scheme_program_name, gc_file_name);
- exit(1);
+ fprintf (stderr,
+ "%s: cannot position at start of GC file \"%s\"; Aborting.\n",
+ scheme_program_name, gc_file_name);
+ exit (1);
}
}
#endif
}
void
-close_gc_file()
+DEFUN_VOID (close_gc_file)
{
- if (close(gc_file) == -1)
+ if ((close (gc_file)) == -1)
{
- fprintf(stderr,
- "%s: Problems closing GC file \"%s\".\n",
- scheme_program_name, gc_file_name);
+ fprintf (stderr,
+ "%s: Problems closing GC file \"%s\".\n",
+ scheme_program_name, gc_file_name);
}
if (gc_file_name == gc_default_file_name)
{
- unlink(gc_file_name);
+ unlink (gc_file_name);
}
return;
}
\f
void
-Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
- int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+DEFUN (Clear_Memory,
+ (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size),
+ int Our_Heap_Size, int Our_Stack_Size, int Our_Constant_Size)
{
GC_Reserve = 4500;
GC_Space_Needed = 0;
Heap_Top = (Heap_Bottom + Our_Heap_Size);
- SET_MEMTOP(Heap_Top - GC_Reserve);
+ SET_MEMTOP (Heap_Top - GC_Reserve);
Free = Heap_Bottom;
Constant_Top = (Constant_Space + Our_Constant_Size);
Free_Constant = Constant_Space;
- Set_Pure_Top ();
+ SET_CONSTANT_TOP ();
Initialize_Stack ();
return;
}
void
-Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
- int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+DEFUN (Setup_Memory,
+ (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size),
+ int Our_Heap_Size, int Our_Stack_Size, int Our_Constant_Size)
{
SCHEME_OBJECT test_value;
int Real_Stack_Size;
- Real_Stack_Size = Stack_Allocation_Size(Our_Stack_Size);
+ Real_Stack_Size = (Stack_Allocation_Size (Our_Stack_Size));
/* Consistency check 1 */
if (Our_Heap_Size == 0)
{
- fprintf(stderr, "Configuration won't hold initial data.\n");
- exit(1);
+ fprintf (stderr, "Configuration won't hold initial data.\n");
+ exit (1);
}
/* Allocate.
The two GC buffers are not included in the valid Scheme memory.
*/
- ALLOCATE_HEAP_SPACE(Real_Stack_Size + Our_Heap_Size +
- Our_Constant_Size + (2 * GC_BUFFER_SPACE) +
- (HEAP_BUFFER_SPACE + 1));
+ ALLOCATE_HEAP_SPACE (Real_Stack_Size + Our_Heap_Size +
+ Our_Constant_Size + (2 * GC_BUFFER_SPACE) +
+ (HEAP_BUFFER_SPACE + 1));
/* Consistency check 2 */
if (Heap == NULL)
}
Heap += HEAP_BUFFER_SPACE;
- INITIAL_ALIGN_FLOAT(Heap);
+ INITIAL_ALIGN_FLOAT (Heap);
- Constant_Space = Heap + Our_Heap_Size;
+ Constant_Space = (Heap + Our_Heap_Size);
ALIGN_FLOAT (Constant_Space);
/* Trim the system buffer space. */
if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
{
- fprintf(stderr,
- "Largest address does not fit in datum field of object.\n");
- fprintf(stderr,
- "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n");
- exit(1);
+ fprintf (stderr,
+ "Largest address does not fit in datum field of object.\n");
+ fprintf (stderr,
+ "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n");
+ exit (1);
}
Heap_Bottom = Heap;
- Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
+ Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
- open_gc_file(Our_Heap_Size * sizeof(SCHEME_OBJECT));
+ open_gc_file (Our_Heap_Size * sizeof(SCHEME_OBJECT));
return;
}
void
-Reset_Memory()
+DEFUN_VOID (Reset_Memory)
{
- close_gc_file();
+ close_gc_file ();
return;
}
\f
void
-dump_buffer(from, position, nbuffers, name, success)
- SCHEME_OBJECT *from;
- long *position, nbuffers;
- char *name;
- Boolean *success;
+DEFUN (dump_buffer,
+ (from, position, nbuffers, name, success),
+ SCHEME_OBJECT *from AND
+ long *position AND
+ long nbuffers AND
+ char *name AND
+ Boolean *success)
{
long bytes_written;
if ((current_disk_position != *position) &&
- (lseek(gc_file, *position, 0) == -1))
+ ((lseek (gc_file, *position, 0)) == -1))
{
if (success == NULL)
{
- fprintf(stderr,
- "\nCould not position GC file to write the %s buffer.\n",
- name);
- Microcode_Termination(TERM_EXIT);
+ fprintf (stderr,
+ "\nCould not position GC file to write the %s buffer.\n",
+ name);
+ Microcode_Termination (TERM_EXIT);
/*NOTREACHED*/
}
*success = false;
return;
}
- if ((bytes_written = write(gc_file, from, (nbuffers * GC_BUFFER_BYTES))) ==
- -1)
+ if ((bytes_written =
+ (write (gc_file, from, (nbuffers * GC_BUFFER_BYTES))))
+ == -1)
{
if (success == NULL)
{
- fprintf(stderr, "\nCould not write out the %s buffer.\n", name);
- Microcode_Termination(TERM_EXIT);
+ fprintf (stderr, "\nCould not write out the %s buffer.\n", name);
+ Microcode_Termination (TERM_EXIT);
/*NOTREACHED*/
}
*success = false;
}
\f
void
-load_buffer(position, to, nbytes, name)
- long position;
- SCHEME_OBJECT *to;
- long nbytes;
- char *name;
+DEFUN (load_buffer,
+ (position, to, nbytes, name),
+ long position AND
+ SCHEME_OBJECT *to AND
+ long nbytes AND
+ char *name)
{
long bytes_read;
if (current_disk_position != position)
{
- if (lseek(gc_file, position, 0) == -1)
+ if ((lseek (gc_file, position, 0)) == -1)
{
- fprintf(stderr, "\nCould not position GC file to read %s.\n", name);
- Microcode_Termination(TERM_EXIT);
+ fprintf (stderr, "\nCould not position GC file to read %s.\n", name);
+ Microcode_Termination (TERM_EXIT);
/*NOTREACHED*/
}
current_disk_position = position;
}
- if ((bytes_read = read(gc_file, to, nbytes)) != nbytes)
+ if ((bytes_read = (read (gc_file, to, nbytes))) != nbytes)
{
- fprintf(stderr, "\nCould not read into %s.\n", name);
- Microcode_Termination(TERM_EXIT);
+ fprintf (stderr, "\nCould not read into %s.\n", name);
+ Microcode_Termination (TERM_EXIT);
/*NOTREACHED*/
}
current_disk_position += bytes_read;
}
void
-reload_scan_buffer()
+DEFUN_VOID (reload_scan_buffer)
{
if (scan_position == free_position)
{
scan_buffer_top = free_buffer_top;
return;
}
- load_buffer(scan_position, scan_buffer_bottom,
- GC_BUFFER_BYTES, "the scan buffer");
- *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top);
+ load_buffer (scan_position, scan_buffer_bottom,
+ GC_BUFFER_BYTES, "the scan buffer");
+ *scan_buffer_top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
return;
}
\f
SCHEME_OBJECT *
-initialize_scan_buffer()
+DEFUN_VOID (initialize_scan_buffer)
{
scan_position = 0;
scan_buffer_bottom = ((free_buffer_bottom == gc_disk_buffer_1) ?
gc_disk_buffer_2 :
gc_disk_buffer_1);
- scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE;
- reload_scan_buffer();
+ scan_buffer_top = (scan_buffer_bottom + GC_DISK_BUFFER_SIZE);
+ reload_scan_buffer ();
return (scan_buffer_bottom);
}
always pointing to a valid buffer.
*/
SCHEME_OBJECT *
-initialize_free_buffer()
+DEFUN_VOID (initialize_free_buffer)
{
free_position = 0;
free_buffer_bottom = gc_disk_buffer_1;
- free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE;
+ free_buffer_top = (free_buffer_bottom + GC_DISK_BUFFER_SIZE);
extension_overlap_p = false;
scan_position = -1;
scan_buffer_bottom = gc_disk_buffer_2;
- scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE;
+ scan_buffer_top = (scan_buffer_bottom + GC_DISK_BUFFER_SIZE);
/* Force first write to do an lseek. */
current_disk_position = -1;
return (free_buffer_bottom);
}
void
-end_transport(success)
- Boolean *success;
+DEFUN (end_transport,
+ (success),
+ Boolean *success)
{
- dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan", success);
+ dump_buffer (scan_buffer_bottom, &scan_position, 1, "scan", success);
free_position = scan_position;
return;
}
*/
void
-extend_scan_buffer(to_where, current_free)
- fast char *to_where;
- SCHEME_OBJECT *current_free;
+DEFUN (extend_scan_buffer,
+ (to_where, current_free),
+ fast char *to_where AND
+ SCHEME_OBJECT *current_free)
{
long new_scan_position;
else
{
extension_overlap_p = false;
- load_buffer(new_scan_position, scan_buffer_top,
- GC_BUFFER_OVERLAP_BYTES, "the scan buffer");
+ load_buffer (new_scan_position, scan_buffer_top,
+ GC_BUFFER_OVERLAP_BYTES, "the scan buffer");
}
return;
}
\f
char *
-end_scan_buffer_extension(to_relocate)
- char *to_relocate;
+DEFUN (end_scan_buffer_extension,
+ (to_relocate),
+ char *to_relocate)
{
char *result;
- dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan",
- ((Boolean *) NULL));
+ dump_buffer (scan_buffer_bottom, &scan_position, 1, "scan",
+ ((Boolean *) NULL));
if (!extension_overlap_p)
{
/* There was no overlap */
{
*dest++ = *source++;
}
- load_buffer((scan_position + GC_BUFFER_OVERLAP_BYTES),
- dest,
- GC_BUFFER_REMAINDER_BYTES,
- "the scan buffer");
- *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top);
+ load_buffer ((scan_position + GC_BUFFER_OVERLAP_BYTES),
+ dest,
+ GC_BUFFER_REMAINDER_BYTES,
+ "the scan buffer");
+ *scan_buffer_top =
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
}
else
{
{
/* There was overlap, but there no longer is. */
- load_buffer((scan_position + extension_overlap_length),
- dest,
- (GC_BUFFER_BYTES - extension_overlap_length),
- "the scan buffer");
- *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top);
+ load_buffer ((scan_position + extension_overlap_length),
+ dest,
+ (GC_BUFFER_BYTES - extension_overlap_length),
+ "the scan buffer");
+ *scan_buffer_top =
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
}
}
extension_overlap_p = false;
}
\f
SCHEME_OBJECT *
-dump_and_reload_scan_buffer(number_to_skip, success)
- long number_to_skip;
- Boolean *success;
+DEFUN (dump_and_reload_scan_buffer,
+ (number_to_skip, success),
+ long number_to_skip AND
+ Boolean *success)
{
- dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan", success);
+ dump_buffer (scan_buffer_bottom, &scan_position, 1, "scan", success);
if (number_to_skip != 0)
{
scan_position += (number_to_skip * GC_BUFFER_BYTES);
}
- reload_scan_buffer();
+ reload_scan_buffer ();
return (scan_buffer_bottom);
}
SCHEME_OBJECT *
-dump_and_reset_free_buffer(overflow, success)
- fast long overflow;
- Boolean *success;
+DEFUN (dump_and_reset_free_buffer,
+ (overflow, success),
+ fast long overflow AND
+ Boolean *success)
{
fast SCHEME_OBJECT *into, *from;
free_buffer_bottom = ((scan_buffer_bottom == gc_disk_buffer_1) ?
gc_disk_buffer_2 :
gc_disk_buffer_1);
- free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE;
+ free_buffer_top = (free_buffer_bottom + GC_DISK_BUFFER_SIZE);
}
else
- {
dump_buffer(free_buffer_bottom, &free_position, 1, "free", success);
- }
for (into = free_buffer_bottom; --overflow >= 0; )
- {
*into++ = *from++;
- }
/* This need only be done when free_buffer_bottom was scan_buffer_bottom,
but it does not hurt otherwise unless we were in the
It must also be done after the for loop above.
*/
if (!extension_overlap_p)
- {
- *scan_buffer_top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top);
- }
+ *scan_buffer_top =
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan_buffer_top));
return (into);
}
void
-dump_free_directly(from, nbuffers, success)
- SCHEME_OBJECT *from;
- long nbuffers;
- Boolean *success;
+DEFUN (dump_free_directly,
+ (from, nbuffers, success),
+ SCHEME_OBJECT *from AND
+ long nbuffers AND
+ Boolean *success)
{
- dump_buffer(from, &free_position, nbuffers, "free", success);
+ dump_buffer (from, &free_position, nbuffers, "free", success);
return;
}
\f
static long current_buffer_position;
void
-initialize_new_space_buffer()
+DEFUN_VOID (initialize_new_space_buffer)
{
current_buffer_position = -1;
return;
}
void
-flush_new_space_buffer()
+DEFUN_VOID (flush_new_space_buffer)
{
if (current_buffer_position == -1)
{
return;
}
- dump_buffer(gc_disk_buffer_1, ¤t_buffer_position,
- 1, "weak pair buffer", NULL);
+ dump_buffer (gc_disk_buffer_1, ¤t_buffer_position,
+ 1, "weak pair buffer", NULL);
current_buffer_position = -1;
return;
}
SCHEME_OBJECT *
-guarantee_in_memory(addr)
- SCHEME_OBJECT *addr;
+DEFUN (guarantee_in_memory,
+ (addr),
+ SCHEME_OBJECT *addr)
{
long position, offset;
position *= GC_BUFFER_BYTES;
if (position != current_buffer_position)
{
- flush_new_space_buffer();
- load_buffer(position, gc_disk_buffer_1,
- GC_BUFFER_BYTES, "the weak pair buffer");
+ flush_new_space_buffer ();
+ load_buffer (position, gc_disk_buffer_1,
+ GC_BUFFER_BYTES, "the weak pair buffer");
current_buffer_position = position;
}
return (&gc_disk_buffer_1[offset]);
SCHEME_OBJECT Weak_Chain;
void
-Fix_Weak_Chain()
+DEFUN_VOID (Fix_Weak_Chain)
{
fast SCHEME_OBJECT *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
Low_Constant = Constant_Space;
while (Weak_Chain != EMPTY_LIST)
{
- Old_Weak_Cell = OBJECT_ADDRESS (Weak_Chain);
- Scan = guarantee_in_memory(OBJECT_ADDRESS (*Old_Weak_Cell++));
+ Old_Weak_Cell = (OBJECT_ADDRESS (Weak_Chain));
+ Scan = (guarantee_in_memory (OBJECT_ADDRESS (*Old_Weak_Cell++)));
Weak_Chain = *Old_Weak_Cell;
Old_Car = *Scan;
Temp = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, Old_Car));
Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
- switch(GC_Type(Temp))
+ switch (GC_Type (Temp))
{ case GC_Non_Pointer:
*Scan = Temp;
continue;
case GC_Special:
- if (OBJECT_TYPE (Temp) != TC_REFERENCE_TRAP)
+ if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP)
{
/* No other special type makes sense here. */
goto fail;
}
- if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
+ if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
{
*Scan = Temp;
continue;
case GC_Quadruple:
case GC_Vector:
/* Old is still a pointer to old space */
- Old = OBJECT_ADDRESS (Old_Car);
+ Old = (OBJECT_ADDRESS (Old_Car));
if (Old >= Low_Constant)
{
*Scan = Temp;
continue;
}
- if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART)
+ if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART)
{
*Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old));
continue;
*Scan = Temp;
continue;
}
- Compiled_BH(false, { *Scan = Temp; continue; });
+ Compiled_BH (false, { *Scan = Temp; continue; });
*Scan = SHARP_F;
continue;
case GC_Undefined:
- fprintf(stderr,
- "\nFix_Weak_Chain: Clearing bad object 0x%08lx.\n",
- Temp);
+ fprintf (stderr,
+ "\nFix_Weak_Chain: Clearing bad object 0x%08lx.\n",
+ Temp);
*Scan = SHARP_F;
continue;
default: /* Non Marked Headers and Broken Hearts */
fail:
- fprintf(stderr,
- "\nFix_Weak_Chain: Bad Object: 0x%08lx.\n",
- Temp);
- Microcode_Termination(TERM_INVALID_TYPE_CODE);
+ fprintf (stderr,
+ "\nFix_Weak_Chain: Bad Object: 0x%08lx.\n",
+ Temp);
+ Microcode_Termination (TERM_INVALID_TYPE_CODE);
/*NOTREACHED*/
}
}
- flush_new_space_buffer();
+ flush_new_space_buffer ();
return;
}
\f
*/
\f
void
-GC (initial_weak_chain)
- SCHEME_OBJECT initial_weak_chain;
+DEFUN (GC,
+ (initial_weak_chain),
+ SCHEME_OBJECT initial_weak_chain)
{
SCHEME_OBJECT
*Root, *Result, *end_of_constant_area,
The_Precious_Objects, *Root2, *free_buffer;
- free_buffer = initialize_free_buffer();
+ free_buffer = (initialize_free_buffer ());
Free = Heap_Bottom;
- SET_MEMTOP(Heap_Top - GC_Reserve);
+ SET_MEMTOP (Heap_Top - GC_Reserve);
Weak_Chain = initial_weak_chain;
/* Save the microcode registers so that they can be relocated */
- Terminate_Old_Stacklet();
- Terminate_Constant_Space(end_of_constant_area);
+ Terminate_Old_Stacklet ();
+ SEAL_CONSTANT_SPACE ();
+ end_of_constant_area = (CONSTANT_SPACE_SEAL ());
Root = Free;
- The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects);
- Set_Fixed_Obj_Slot(Precious_Objects, SHARP_F);
- Set_Fixed_Obj_Slot(Lost_Objects_Base, SHARP_F);
+ The_Precious_Objects = (Get_Fixed_Obj_Slot (Precious_Objects));
+ Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F);
+ Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F);
*free_buffer++ = Fixed_Objects;
- *free_buffer++ = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History);
+ *free_buffer++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History));
*free_buffer++ = Undefined_Primitives;
*free_buffer++ = Undefined_Primitives_Arity;
- *free_buffer++ = Get_Current_Stacklet();
+ *free_buffer++ = Get_Current_Stacklet ();
*free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
SHARP_F :
- MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
- Prev_Restore_History_Stacklet));
+ (MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
+ Prev_Restore_History_Stacklet)));
*free_buffer++ = Current_State_Point;
*free_buffer++ = Fluid_Bindings;
Free += (free_buffer - free_buffer_bottom);
if (free_buffer >= free_buffer_top)
- {
- free_buffer = dump_and_reset_free_buffer((free_buffer - free_buffer_top),
- NULL);
- }
+ free_buffer =
+ (dump_and_reset_free_buffer ((free_buffer - free_buffer_top),
+ NULL));
/* The 4 step GC */
- Result = GCLoop(Constant_Space, &free_buffer, &Free);
+ Result = (GCLoop (Constant_Space, &free_buffer, &Free));
if (Result != end_of_constant_area)
{
- fprintf(stderr, "\nGC: Constant Scan ended too early.\n");
- Microcode_Termination(TERM_EXIT);
+ fprintf (stderr, "\nGC: Constant Scan ended too early.\n");
+ Microcode_Termination (TERM_EXIT);
/*NOTREACHED*/
}
Result = GCLoop(initialize_scan_buffer(), &free_buffer, &Free);
if (free_buffer != Result)
{
- fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
- Microcode_Termination(TERM_EXIT);
+ fprintf (stderr, "\nGC-1: Heap Scan ended too early.\n");
+ Microcode_Termination (TERM_EXIT);
/*NOTREACHED*/
}
\f
*free_buffer++ = The_Precious_Objects;
Free += (free_buffer - Result);
if (free_buffer >= free_buffer_top)
- free_buffer = dump_and_reset_free_buffer((free_buffer - free_buffer_top), NULL);
+ free_buffer =
+ (dump_and_reset_free_buffer ((free_buffer - free_buffer_top), NULL));
- Result = GCLoop(Result, &free_buffer, &Free);
+ Result = (GCLoop (Result, &free_buffer, &Free));
if (free_buffer != Result)
{
- fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
- Microcode_Termination(TERM_EXIT);
+ fprintf (stderr, "\nGC-2: Heap Scan ended too early.\n");
+ Microcode_Termination (TERM_EXIT);
/*NOTREACHED*/
}
- end_transport(NULL);
+ end_transport (NULL);
- Fix_Weak_Chain();
+ Fix_Weak_Chain ();
/* Load new space into memory. */
- load_buffer(0, Heap_Bottom,
- ((Free - Heap_Bottom) * sizeof(SCHEME_OBJECT)),
- "new space");
+ load_buffer (0, Heap_Bottom,
+ ((Free - Heap_Bottom) * sizeof(SCHEME_OBJECT)),
+ "new space");
/* Make the microcode registers point to the copies in new-space. */
Set_Fixed_Obj_Slot
(Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2))));
- History = OBJECT_ADDRESS (*Root++);
+ History = (OBJECT_ADDRESS (*Root++));
Undefined_Primitives = *Root++;
Undefined_Primitives_Arity = *Root++;
- /* Set_Current_Stacklet is sometimes a No-Op! */
-
- Set_Current_Stacklet(*Root);
+ Set_Current_Stacklet (*Root);
Root += 1;
if (*Root == SHARP_F)
{
}
else
{
- Prev_Restore_History_Stacklet = OBJECT_ADDRESS (*Root++);
+ Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*Root++));
}
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
FLUSH_I_CACHE ();
+ CLEAR_INTERRUPT (INT_GC);
return;
}
\f
SCHEME_OBJECT GC_Daemon_Proc;
PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT ();
+
+ STACK_SANITY_CHECK ("GC");
new_gc_reserve = (arg_nonnegative_integer (1));
if (Free > Heap_Top)
termination_gc_out_of_space ();
+
ENTER_CRITICAL_SECTION ("garbage collector");
gc_counter += 1;
GC_Reserve = new_gc_reserve;
- GC(EMPTY_LIST);
- CLEAR_INTERRUPT(INT_GC);
+ GC (EMPTY_LIST);
POP_PRIMITIVE_FRAME (1);
- GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
+ GC_Daemon_Proc = (Get_Fixed_Obj_Slot (GC_Daemon));
+
RENAME_CRITICAL_SECTION ("garbage collector daemon");
if (GC_Daemon_Proc == SHARP_F)
{
- Will_Push(CONTINUATION_SIZE);
- Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
- Save_Cont();
- Pushed();
- PRIMITIVE_ABORT(PRIM_POP_RETURN);
+ Will_Push (CONTINUATION_SIZE);
+ Store_Return (RC_NORMAL_GC_DONE);
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
+ Save_Cont ();
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
- Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
- Save_Cont();
+ Will_Push (CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
+ Store_Return (RC_NORMAL_GC_DONE);
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
+ Save_Cont ();
STACK_PUSH (GC_Daemon_Proc);
STACK_PUSH (STACK_FRAME_HEADER);
- Pushed();
- PRIMITIVE_ABORT(PRIM_APPLY);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
/* The following comment is by courtesy of LINT, your friendly sponsor. */
/*NOTREACHED*/
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.50 1990/06/20 17:38:26 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.51 1991/02/24 01:10:16 jinx Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
#include "bchgcc.h"
-\f
+
/* Purify modes */
#define NORMAL_GC 0
/* A modified copy of GCLoop. */
SCHEME_OBJECT *
-purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode)
- fast SCHEME_OBJECT *Scan;
- SCHEME_OBJECT **To_ptr, **To_Address_ptr;
- int purify_mode;
+DEFUN (purifyloop,
+ (Scan, To_ptr, To_Address_ptr, purify_mode),
+ fast SCHEME_OBJECT *Scan AND
+ SCHEME_OBJECT **To_ptr AND
+ SCHEME_OBJECT **To_Address_ptr AND
+ int purify_mode)
{
fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
for ( ; Scan != To; Scan++)
{
Temp = *Scan;
- Switch_by_GC_Type(Temp)
+ Switch_by_GC_Type (Temp)
{
case TC_BROKEN_HEART:
if (Scan != (OBJECT_ADDRESS (Temp)))
{
- sprintf(gc_death_message_buffer,
- "purifyloop: broken heart (0x%lx) in scan",
- Temp);
- gc_death(TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
+ sprintf (gc_death_message_buffer,
+ "purifyloop: broken heart (0x%lx) in scan",
+ Temp);
+ gc_death (TERM_BROKEN_HEART,
+ gc_death_message_buffer,
+ Scan, To);
/*NOTREACHED*/
}
if (Scan != scan_buffer_top)
goto end_purifyloop;
/* The -1 is here because of the Scan++ in the for header. */
- Scan = dump_and_reload_scan_buffer(0, NULL) - 1;
+ Scan = ((dump_and_reload_scan_buffer (0, NULL)) - 1);
continue;
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
- Scan += OBJECT_DATUM (Temp);
+ Scan += (OBJECT_DATUM (Temp));
if (Scan < scan_buffer_top)
{
break;
unsigned long overflow;
/* The + & -1 are here because of the Scan++ in the for header. */
- overflow = (Scan - scan_buffer_top) + 1;
- Scan = ((dump_and_reload_scan_buffer((overflow / GC_DISK_BUFFER_SIZE), NULL) +
+ overflow = ((Scan - scan_buffer_top) + 1);
+ Scan = ((dump_and_reload_scan_buffer ((overflow / GC_DISK_BUFFER_SIZE), NULL) +
(overflow % GC_DISK_BUFFER_SIZE)) - 1);
break;
}
case_compiled_entry_point:
if (purify_mode == PURE_COPY)
break;
- relocate_compiled_entry(false);
+ relocate_compiled_entry (false);
*Scan = Temp;
break;
{
if (purify_mode == PURE_COPY)
{
- gc_death(TERM_COMPILER_DEATH,
- "purifyloop: linkage section in pure area",
- Scan, To);
+ gc_death (TERM_COMPILER_DEATH,
+ "purifyloop: linkage section in pure area",
+ Scan, To);
/*NOTREACHED*/
}
- if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
+ if ((READ_LINKAGE_KIND (Temp)) != OPERATOR_LINKAGE_KIND)
{
/* count typeless pointers to quads follow. */
Scan++;
max_here = (scan_buffer_top - Scan);
- max_count = READ_CACHE_LINKAGE_COUNT(Temp);
+ max_count = (READ_CACHE_LINKAGE_COUNT (Temp));
while (max_count != 0)
{
count = ((max_count > max_here) ? max_here : max_count);
for ( ; --count >= 0; Scan += 1)
{
Temp = *Scan;
- relocate_typeless_pointer(copy_quadruple(), 4);
+ relocate_typeless_pointer (copy_quadruple(), 4);
}
if (max_count != 0)
{
{
if (purify_mode == PURE_COPY)
{
- gc_death(TERM_COMPILER_DEATH,
- "purifyloop: manifest closure in pure area",
- Scan, To);
+ gc_death (TERM_COMPILER_DEATH,
+ "purifyloop: manifest closure in pure area",
+ Scan, To);
/*NOTREACHED*/
}
}
char *entry_end;
long de, dw;
- entry_end = (CLOSURE_ENTRY_END(word_ptr));
+ entry_end = (CLOSURE_ENTRY_END (word_ptr));
de = (end_ptr - entry_end);
dw = (entry_end - word_ptr);
- extend_scan_buffer(((char *) entry_end), To);
+ extend_scan_buffer (((char *) entry_end), To);
relocate_manifest_closure (false);
entry_end = ((char *)
- (end_scan_buffer_extension((char *) entry_end)));
+ (end_scan_buffer_extension ((char *) entry_end)));
word_ptr = (entry_end - dw);
end_ptr = (entry_end + de);
}
else
{
- relocate_manifest_closure(false);
+ relocate_manifest_closure (false);
}
}
Scan = ((SCHEME_OBJECT *) (end_ptr));
}
\f
case_Cell:
- relocate_normal_pointer(copy_cell(), 1);
+ relocate_normal_pointer (copy_cell(), 1);
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
+ if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
break; /* It is a non pointer. */
goto purify_pair;
case TC_UNINTERNED_SYMBOL:
if (purify_mode == PURE_COPY)
{
- Temp = MEMORY_REF (Temp, SYMBOL_NAME);
- relocate_indirect_setup();
- copy_vector(NULL);
- relocate_indirect_end();
+ Temp = (MEMORY_REF (Temp, SYMBOL_NAME));
+ relocate_indirect_setup ();
+ copy_vector (NULL);
+ relocate_indirect_end ();
}
/* Fall through. */
case_Fasdump_Pair:
purify_pair:
- relocate_normal_pointer(copy_pair(), 2);
+ relocate_normal_pointer (copy_pair(), 2);
case TC_WEAK_CONS:
if (purify_mode == PURE_COPY)
break;
else
- relocate_normal_pointer(copy_weak_pair(), 2);
+ relocate_normal_pointer (copy_weak_pair(), 2);
case TC_VARIABLE:
case_Triple:
- relocate_normal_pointer(copy_triple(), 3);
+ relocate_normal_pointer (copy_triple(), 3);
case_Quadruple:
- relocate_normal_pointer(copy_quadruple(), 4);
+ relocate_normal_pointer (copy_quadruple(), 4);
\f
case TC_BIG_FLONUM:
- relocate_flonum_setup();
+ relocate_flonum_setup ();
goto Move_Vector;
case TC_COMPILED_CODE_BLOCK:
/* Fall through */
case_Purify_Vector:
- relocate_normal_setup();
+ relocate_normal_setup ();
Move_Vector:
- copy_vector(NULL);
- relocate_normal_end();
+ copy_vector (NULL);
+ relocate_normal_end ();
case TC_FUTURE:
relocate_normal_setup();
- if (!(Future_Spliceable(Temp)))
+ if (!(Future_Spliceable (Temp)))
goto Move_Vector;
- *Scan = Future_Value(Temp);
+ *Scan = (Future_Value (Temp));
Scan -= 1;
continue;
default:
- GC_BAD_TYPE("purifyloop");
+ GC_BAD_TYPE ("purifyloop");
/* Fall Through */
case_Non_Pointer:
*/
SCHEME_OBJECT *
-purify_header_overflow(free_buffer)
- SCHEME_OBJECT *free_buffer;
+DEFUN (purify_header_overflow,
+ (free_buffer),
+ SCHEME_OBJECT *free_buffer)
{
SCHEME_OBJECT *scan_buffer;
long delta;
delta = (free_buffer - free_buffer_top);
- free_buffer = dump_and_reset_free_buffer(delta, NULL);
- scan_buffer = dump_and_reload_scan_buffer(0, NULL);
+ free_buffer = (dump_and_reset_free_buffer (delta, NULL));
+ scan_buffer = (dump_and_reload_scan_buffer (0, NULL));
if ((scan_buffer + delta) != free_buffer)
{
- gc_death(TERM_EXIT, "purify: scan and free do not meet at the end",
- (scan_buffer + delta), free_buffer);
+ gc_death (TERM_EXIT,
+ "purify: scan and free do not meet at the end",
+ (scan_buffer + delta), free_buffer);
/*NOTREACHED*/
}
return (free_buffer);
}
\f
SCHEME_OBJECT
-purify(object, flag)
- SCHEME_OBJECT object, flag;
+DEFUN (purify,
+ (object, flag),
+ SCHEME_OBJECT object AND
+ SCHEME_OBJECT flag)
{
long length, pure_length;
SCHEME_OBJECT value, *Result, *free_buffer, *block_start;
Weak_Chain = EMPTY_LIST;
- free_buffer = initialize_free_buffer();
+ free_buffer = (initialize_free_buffer ());
block_start = Free_Constant;
Free_Constant += 2;
if (free_buffer >= free_buffer_top)
{
free_buffer =
- dump_and_reset_free_buffer((free_buffer - free_buffer_top), NULL);
+ (dump_and_reset_free_buffer ((free_buffer - free_buffer_top), NULL));
}
if (flag == SHARP_T)
{
- Result = purifyloop(initialize_scan_buffer(),
- &free_buffer, &Free_Constant,
- PURE_COPY);
+ Result = (purifyloop ((initialize_scan_buffer()),
+ &free_buffer, &Free_Constant,
+ PURE_COPY));
if (Result != free_buffer)
{
- gc_death(TERM_BROKEN_HEART, "purify: pure copy ended too early",
- Result, free_buffer);
+ gc_death (TERM_BROKEN_HEART,
+ "purify: pure copy ended too early",
+ Result, free_buffer);
/*NOTREACHED*/
}
- pure_length = (Free_Constant - block_start) + 1;
+ pure_length = ((Free_Constant - block_start) + 1);
}
else
{
}
Free_Constant += 2;
- *free_buffer++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *free_buffer++ = MAKE_OBJECT (CONSTANT_PART, pure_length);
+ *free_buffer++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ *free_buffer++ = (MAKE_OBJECT (CONSTANT_PART, pure_length));
if (free_buffer >= free_buffer_top)
{
- free_buffer = purify_header_overflow(free_buffer);
+ free_buffer = (purify_header_overflow (free_buffer));
}
\f
if (flag == SHARP_T)
{
- Result = purifyloop(initialize_scan_buffer(),
- &free_buffer, &Free_Constant,
- CONSTANT_COPY);
+ Result = (purifyloop ((initialize_scan_buffer ()),
+ &free_buffer, &Free_Constant,
+ CONSTANT_COPY));
}
else
- {
- Result = GCLoop(initialize_scan_buffer(), &free_buffer, &Free_Constant);
- }
+ Result =
+ (GCLoop ((initialize_scan_buffer()), &free_buffer, &Free_Constant));
if (Result != free_buffer)
{
- gc_death(TERM_BROKEN_HEART, "purify: constant copy ended too early",
- Result, free_buffer);
+ gc_death (TERM_BROKEN_HEART, "purify: constant copy ended too early",
+ Result, free_buffer);
/*NOTREACHED*/
}
Free_Constant += 2;
length = (Free_Constant - block_start);
- *free_buffer++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *free_buffer++ = MAKE_OBJECT (END_OF_BLOCK, (length - 1));
+ *free_buffer++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ *free_buffer++ = (MAKE_OBJECT (END_OF_BLOCK, (length - 1)));
if (free_buffer >= free_buffer_top)
{
- free_buffer = purify_header_overflow(free_buffer);
+ free_buffer = purify_header_overflow (free_buffer);
}
- end_transport(NULL);
+ end_transport (NULL);
- if (!Test_Pure_Space_Top(Free_Constant))
+ if (!(TEST_CONSTANT_TOP (Free_Constant)))
{
- gc_death(TERM_NO_SPACE, "purify: object too large", NULL, NULL);
+ gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL);
/*NOTREACHED*/
}
- load_buffer(0, block_start,
- (length * sizeof(SCHEME_OBJECT)),
- "into constant space");
- *block_start++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length);
- *block_start = MAKE_OBJECT (PURE_PART, (length - 1));
- GC(Weak_Chain);
- Set_Pure_Top();
+ load_buffer (0, block_start,
+ (length * sizeof(SCHEME_OBJECT)),
+ "into constant space");
+ *block_start++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length));
+ *block_start = (MAKE_OBJECT (PURE_PART, (length - 1)));
+ SET_CONSTANT_TOP ();
+ GC (Weak_Chain);
return (SHARP_T);
}
/* Stub. Not needed by this version. Terminates Scheme if invoked. */
SCHEME_OBJECT
-Purify_Pass_2(info)
- SCHEME_OBJECT info;
+DEFUN (Purify_Pass_2,
+ (info),
+ SCHEME_OBJECT info)
{
- gc_death(TERM_EXIT, "Purify_Pass_2 invoked", NULL, NULL);
+ gc_death (TERM_EXIT, "Purify_Pass_2 invoked", NULL, NULL);
/*NOTREACHED*/
}
\f
SCHEME_OBJECT object, daemon;
SCHEME_OBJECT result;
PRIMITIVE_HEADER (3);
- PRIMITIVE_CANONICALIZE_CONTEXT();
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
+
+ STACK_SANITY_CHECK ("PURIFY");
+ Save_Time_Zone (Zone_Purify);
TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
CHECK_ARG (2, BOOLEAN_P);
GC_Reserve = (arg_nonnegative_integer (3));
+
ENTER_CRITICAL_SECTION ("purify");
{
SCHEME_OBJECT purify_result;
(*Free++) = words_free;
}
POP_PRIMITIVE_FRAME (3);
- daemon = Get_Fixed_Obj_Slot(GC_Daemon);
+ daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
if (daemon == SHARP_F)
{
Val = result;
EXIT_CRITICAL_SECTION ({});
- PRIMITIVE_ABORT(PRIM_POP_RETURN);
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
+
RENAME_CRITICAL_SECTION ("purify daemon");
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
Store_Expression(result);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.66 1990/11/15 23:17:06 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.67 1991/02/24 01:10:24 jinx Exp $
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#endif
main_type
-main (argc, argv)
- int argc;
- CONST char ** argv;
+DEFUN (main,
+ (argc, argv),
+ int argc AND
+ CONST char ** argv)
{
init_exit_scheme ();
scheme_program_name = (argv[0]);
}
\f
SCHEME_OBJECT
-make_fixed_objects_vector ()
+DEFUN_VOID (make_fixed_objects_vector)
{
extern SCHEME_OBJECT initialize_history ();
extern SCHEME_OBJECT make_primitive ();
/* Boot Scheme */
void
-Start_Scheme (Start_Prim, File_Name)
- int Start_Prim;
- char * File_Name;
+DEFUN (Start_Scheme,
+ (Start_Prim, File_Name),
+ int Start_Prim AND
+ char * File_Name)
{
extern SCHEME_OBJECT make_primitive ();
SCHEME_OBJECT FName, Init_Prog, *Fasload_Call, prim;
}
void
-Enter_Interpreter ()
+DEFUN_VOID (Enter_Interpreter)
{
Interpret (scheme_dumped_p);
fprintf (stderr, "\nThe interpreter returned to top level!\n");
extern unsigned long
gc_counter;
-extern void
- gc_death();
+extern void EXFUN (gc_death,
+ (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *));
+extern void EXFUN (stack_death, (const char *));
extern char
gc_death_message_buffer[];
gc_death_message_buffer[100];
void
-gc_death (code, message, scan, free)
- long code;
- char *message;
- SCHEME_OBJECT *scan, *free;
+DEFUN (gc_death,
+ (code, message, scan, free),
+ long code AND
+ char *message AND
+ SCHEME_OBJECT *scan AND
+ SCHEME_OBJECT *free)
{
fprintf (stderr, "\n%s.\n", message);
fprintf (stderr, "scan = 0x%lx; free = 0x%lx\n", scan, free);
Microcode_Termination (code);
/*NOTREACHED*/
}
+
+void
+DEFUN (stack_death, (name), const char *name)
+{
+ fprintf (stderr,
+ "\n%s: Constant space is no longer sealed!\n",
+ name);
+ fprintf (stderr,
+ "Perhaps a runaway recursion has overflowed the stack.\n");
+ Microcode_Termination (TERM_STACK_OVERFLOW);
+ /*NOTREACHED*/
+}
\f
/* Utility primitives. */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.35 1990/11/13 08:44:27 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.36 1991/02/24 01:10:32 jinx Exp $
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(* (locative)) = (object); \
}
#endif
-
+\f
#ifndef USE_STACKLETS
#define Absolute_Stack_Base Constant_Top
} while (0)
#endif
+#endif /* USE_STACKLETS */
+
+#ifndef SET_CONSTANT_TOP
+#define SET_CONSTANT_TOP() \
+do \
+{ \
+ ALIGN_FLOAT (Free_Constant); \
+ SEAL_CONSTANT_SPACE (); \
+} while (0)
#endif
-#ifndef Set_Pure_Top
-#define Set_Pure_Top() ALIGN_FLOAT (Free_Constant)
+#ifndef TEST_CONSTANT_TOP
+#define TEST_CONSTANT_TOP(New_Top) ((New_Top) <= Constant_Top)
#endif
-#ifndef Test_Pure_Space_Top
-#define Test_Pure_Space_Top(New_Top) ((New_Top) <= Constant_Top)
+#ifndef STACK_SANITY_CHECK
+#define STACK_SANITY_CHECK(name) \
+do \
+{ \
+ if (!(CONSTANT_SPACE_SEALED ())) \
+ { \
+ extern void EXFUN (stack_death, (const char *)); \
+ \
+ stack_death (name); \
+ /*NOTREACHED */ \
+ } \
+} while (0)
#endif
\f
/* Used in debug.c */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.59 1990/11/21 07:04:18 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.60 1991/02/24 01:10:39 jinx Exp $
-Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1987-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
print_fasl_information();
}
- if (!Test_Pure_Space_Top (Free_Constant + Const_Count))
+ if (!(TEST_CONSTANT_TOP (Free_Constant + Const_Count)))
{
if (mode != MODE_CHANNEL)
{
static SCHEME_OBJECT *
DEFUN (read_file_end, (mode), int mode)
{
- SCHEME_OBJECT *table;
+ SCHEME_OBJECT *table, *ignore;
extern unsigned long checksum_area ();
if ((Load_Data (Heap_Count, ((char *) Free))) != Heap_Count)
NORMALIZE_REGION(((char *) Free), Heap_Count);
Free += Heap_Count;
- if ((Load_Data(Const_Count, ((char *) Free_Constant))) != Const_Count)
+ if ((Load_Data (Const_Count, ((char *) Free_Constant))) != Const_Count)
{
+ SET_CONSTANT_TOP ();
if (mode != MODE_CHANNEL)
{
OS_channel_close_noerror (load_channel);
(checksum_area (((unsigned long *) Free_Constant),
Const_Count,
computed_checksum));
- NORMALIZE_REGION(((char *) Free_Constant), Const_Count);
+ NORMALIZE_REGION (((char *) Free_Constant), Const_Count);
Free_Constant += Const_Count;
+ SET_CONSTANT_TOP ();
table = Free;
- if ((Load_Data(Primitive_Table_Size, ((char *) Free))) !=
+ if ((Load_Data (Primitive_Table_Size, ((char *) Free))) !=
Primitive_Table_Size)
{
if (mode != MODE_CHANNEL)
(checksum_area (((unsigned long *) Free),
Primitive_Table_Size,
computed_checksum));
- NORMALIZE_REGION(((char *) table), Primitive_Table_Size);
+ NORMALIZE_REGION (((char *) table), Primitive_Table_Size);
Free += Primitive_Table_Size;
if (mode != MODE_CHANNEL)
*/
Relocate_Block (Orig_Heap, primitive_table);
- Relocate_Block (Orig_Constant, Free_Constant);
+ Relocate_Block (Orig_Constant, Constant_End);
}
\f
#ifdef BYTE_INVERSION
Intern_Block (Orig_Constant, Constant_End);
}
- Set_Pure_Top ();
- FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, Orig_Constant, Free_Constant);
+ FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, Orig_Constant, Constant_End);
Relocate_Into (temp, Dumped_Object);
return (*temp);
}
/* Reset implementation state paramenters */
INITIALIZE_INTERRUPTS ();
Initialize_Stack ();
- Set_Pure_Top ();
SET_MEMTOP (Heap_Top - GC_Reserve);
{
SCHEME_OBJECT cutl = (MEMORY_REF (result, 1));
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.44 1990/06/20 17:41:31 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.45 1991/02/24 01:10:48 jinx Exp $
-Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1987-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
special: it always points to a cell which is in use. */
void
-Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
- int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+DEFUN (Clear_Memory,
+ (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size),
+ int Our_Heap_Size AND int Our_Stack_Size AND int Our_Constant_Size)
{
GC_Reserve = 4500;
GC_Space_Needed = 0;
Heap_Top = (Heap_Bottom + Our_Heap_Size);
Local_Heap_Base = Heap_Bottom;
Unused_Heap_Top = (Heap_Bottom + (2 * Our_Heap_Size));
- SET_MEMTOP(Heap_Top - GC_Reserve);
+ SET_MEMTOP (Heap_Top - GC_Reserve);
Free = Heap_Bottom;
Constant_Top = (Constant_Space + Our_Constant_Size);
- Free_Constant = Constant_Space;
- Set_Pure_Top ();
Initialize_Stack ();
+ Free_Constant = Constant_Space;
+ SET_CONSTANT_TOP ();
return;
}
/* This procedure allocates and divides the total memory. */
void
-Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
- int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+DEFUN (Setup_Memory,
+ (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size),
+ int Our_Heap_Size AND int Our_Stack_Size AND int Our_Constant_Size)
{
SCHEME_OBJECT test_value;
/* Consistency check 1 */
if (Our_Heap_Size == 0)
{
- fprintf(stderr, "Configuration won't hold initial data.\n");
- exit(1);
+ fprintf (stderr, "Configuration won't hold initial data.\n");
+ exit (1);
}
/* Allocate */
Highest_Allocated_Address =
- ALLOCATE_HEAP_SPACE(Stack_Allocation_Size(Our_Stack_Size) +
- (2 * Our_Heap_Size) +
- Our_Constant_Size +
- HEAP_BUFFER_SPACE);
+ ALLOCATE_HEAP_SPACE (Stack_Allocation_Size(Our_Stack_Size) +
+ (2 * Our_Heap_Size) +
+ Our_Constant_Size +
+ HEAP_BUFFER_SPACE);
/* Consistency check 2 */
if (Heap == NULL)
{
- fprintf(stderr, "Not enough memory for this configuration.\n");
- exit(1);
+ fprintf (stderr, "Not enough memory for this configuration.\n");
+ exit (1);
}
/* Initialize the various global parameters */
Heap += HEAP_BUFFER_SPACE;
- INITIAL_ALIGN_FLOAT(Heap);
- Unused_Heap = Heap + Our_Heap_Size;
+ INITIAL_ALIGN_FLOAT (Heap);
+ Unused_Heap = (Heap + Our_Heap_Size);
ALIGN_FLOAT (Unused_Heap);
- Constant_Space = Heap + 2*Our_Heap_Size;
+ Constant_Space = (Heap + (2 * Our_Heap_Size));
ALIGN_FLOAT (Constant_Space);
/* Consistency check 3 */
if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
{
- fprintf(stderr,
- "Largest address does not fit in datum field of object.\n");
- fprintf(stderr,
- "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n");
- exit(1);
+ fprintf (stderr,
+ "Largest address does not fit in datum field of object.\n");
+ fprintf (stderr,
+ "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n");
+ exit (1);
}
Heap_Bottom = Heap;
- Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
+ Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
return;
}
/* In this version, this does nothing. */
void
-Reset_Memory()
+DEFUN_VOID (Reset_Memory)
{
return;
}
/* Flip into unused heap */
void
-GCFlip()
+DEFUN_VOID (GCFlip)
{
SCHEME_OBJECT *Temp;
SCHEME_OBJECT Weak_Chain;
void
-Fix_Weak_Chain()
+DEFUN_VOID (Fix_Weak_Chain)
{
fast SCHEME_OBJECT *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
new space.
*/
\f
-void GC()
+void
+DEFUN_VOID (GC)
{
SCHEME_OBJECT
*Root, *Result, *Check_Value,
/* Save the microcode registers so that they can be relocated */
- Terminate_Old_Stacklet();
- Terminate_Constant_Space(Check_Value);
-
+ Terminate_Old_Stacklet ();
+ SEAL_CONSTANT_SPACE ();
+ Check_Value = (CONSTANT_SPACE_SEAL ());
Root = Free;
- The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects);
- Set_Fixed_Obj_Slot(Precious_Objects, SHARP_F);
- Set_Fixed_Obj_Slot(Lost_Objects_Base, SHARP_F);
+ The_Precious_Objects = (Get_Fixed_Obj_Slot (Precious_Objects));
+ Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F);
+ Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F);
*Free++ = Fixed_Objects;
- *Free++ = MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History);
+ *Free++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History));
*Free++ = Undefined_Primitives;
*Free++ = Undefined_Primitives_Arity;
- *Free++ = Get_Current_Stacklet();
+ *Free++ = Get_Current_Stacklet ();
*Free++ =
((Prev_Restore_History_Stacklet == NULL)
? SHARP_F
- : MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Prev_Restore_History_Stacklet));
+ : (MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Prev_Restore_History_Stacklet)));
*Free++ = Current_State_Point;
*Free++ = Fluid_Bindings;
/* The 4 step GC */
- Result = GCLoop(Constant_Space, &Free);
+ Result = (GCLoop (Constant_Space, &Free));
if (Result != Check_Value)
{
- fprintf(stderr, "\nGC: Constant Scan ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
+ fprintf (stderr, "\nGC: Constant Scan ended too early.\n");
+ Microcode_Termination (TERM_BROKEN_HEART);
}
- Result = GCLoop(Root, &Free);
+ Result = (GCLoop (Root, &Free));
if (Free != Result)
{
- fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
+ fprintf (stderr, "\nGC-1: Heap Scan ended too early.\n");
+ Microcode_Termination (TERM_BROKEN_HEART);
}
\f
Root2 = Free;
*Free++ = The_Precious_Objects;
- Result = GCLoop(Root2, &Free);
+ Result = (GCLoop (Root2, &Free));
if (Free != Result)
{
- fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
+ fprintf (stderr, "\nGC-2: Heap Scan ended too early.\n");
+ Microcode_Termination (TERM_BROKEN_HEART);
}
- Fix_Weak_Chain();
+ Fix_Weak_Chain ();
/* Make the microcode registers point to the copies in new-space. */
Fixed_Objects = *Root++;
- Set_Fixed_Obj_Slot(Precious_Objects, *Root2);
+ Set_Fixed_Obj_Slot (Precious_Objects, *Root2);
Set_Fixed_Obj_Slot
(Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2))));
- History = OBJECT_ADDRESS (*Root++);
+ History = (OBJECT_ADDRESS (*Root++));
Undefined_Primitives = *Root++;
Undefined_Primitives_Arity = *Root++;
- /* Set_Current_Stacklet is sometimes a No-Op! */
- Set_Current_Stacklet(*Root);
+ Set_Current_Stacklet (*Root);
Root += 1;
if (*Root == SHARP_F)
{
}
else
{
- Prev_Restore_History_Stacklet = OBJECT_ADDRESS (*Root++);
+ Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*Root++));
}
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
FLUSH_I_CACHE ();
+ CLEAR_INTERRUPT (INT_GC);
return;
}
\f
extern unsigned long gc_counter;
SCHEME_OBJECT GC_Daemon_Proc;
PRIMITIVE_HEADER (1);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
- PRIMITIVE_CANONICALIZE_CONTEXT();
+ STACK_SANITY_CHECK ("GC");
new_gc_reserve = (arg_nonnegative_integer (1));
if (Free > Heap_Top)
{
- fprintf(stderr,
- "\nGC has been delayed too long, and you are out of room!\n");
- fprintf(stderr,
- "Free = 0x%x; MemTop = 0x%x; Heap_Top = 0x%x\n",
- Free, MemTop, Heap_Top);
- Microcode_Termination(TERM_NO_SPACE);
+ fprintf (stderr,
+ "\nGARBAGE-COLLECT: GC has been delayed too long!\n");
+ fprintf (stderr,
+ "Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n",
+ Free, MemTop, Heap_Top);
+ Microcode_Termination (TERM_NO_SPACE);
}
+
ENTER_CRITICAL_SECTION ("garbage collector");
gc_counter += 1;
GC_Reserve = new_gc_reserve;
- GCFlip();
- GC();
- CLEAR_INTERRUPT(INT_GC);
+ GCFlip ();
+ GC ();
POP_PRIMITIVE_FRAME (1);
- GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
+ GC_Daemon_Proc = (Get_Fixed_Obj_Slot (GC_Daemon));
+
RENAME_CRITICAL_SECTION ("garbage collector daemon");
if (GC_Daemon_Proc == SHARP_F)
{
- Will_Push(CONTINUATION_SIZE);
- Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
- Save_Cont();
- Pushed();
- PRIMITIVE_ABORT(PRIM_POP_RETURN);
+ Will_Push (CONTINUATION_SIZE);
+ Store_Return (RC_NORMAL_GC_DONE);
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
+ Save_Cont ();
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
- Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
- Save_Cont();
+ Will_Push (CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
+ Store_Return (RC_NORMAL_GC_DONE);
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
+ Save_Cont ();
STACK_PUSH (GC_Daemon_Proc);
STACK_PUSH (STACK_FRAME_HEADER);
- Pushed();
- PRIMITIVE_ABORT(PRIM_APPLY);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
/* The following comment is by courtesy of LINT, your friendly sponsor. */
/*NOTREACHED*/
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.44 1990/06/28 18:19:53 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.45 1991/02/24 01:10:56 jinx Exp $
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
/* Imports */
-extern void GCFlip(), GC();
-extern SCHEME_OBJECT *GCLoop();
+extern void EXFUN (GCFlip, (void));
+extern void EXFUN (GC, (void));
+extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
\f
/* This is a copy of GCLoop, with mode handling added, and
debugging printout removed.
#define Purify_Pointer(Code) \
{ \
- Old = OBJECT_ADDRESS (Temp); \
+ Old = (OBJECT_ADDRESS (Temp)); \
if ((GC_Mode == CONSTANT_COPY) && \
(Old > Low_Constant)) \
continue; \
#define Indirect_BH(In_GC) \
{ \
- if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
+ if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) \
continue; \
}
#define Transport_Vector_Indirect() \
{ \
- Real_Transport_Vector(); \
- *OBJECT_ADDRESS (Temp) = New_Address; \
+ Real_Transport_Vector (); \
+ *(OBJECT_ADDRESS (Temp)) = New_Address; \
}
\f
SCHEME_OBJECT *
-PurifyLoop(Scan, To_Pointer, GC_Mode)
- fast SCHEME_OBJECT *Scan;
- SCHEME_OBJECT **To_Pointer;
- int GC_Mode;
+DEFUN (PurifyLoop,
+ (Scan, To_Pointer, GC_Mode),
+ fast SCHEME_OBJECT *Scan AND
+ SCHEME_OBJECT **To_Pointer AND
+ int GC_Mode)
{
fast SCHEME_OBJECT *To, *Old, Temp, *Low_Constant, New_Address;
#define Purify_N_Slots 2
SCHEME_OBJECT
-Purify (Object, Purify_Object)
- SCHEME_OBJECT Object, Purify_Object;
+DEFUN (Purify,
+ (Object, Purify_Object),
+ SCHEME_OBJECT Object AND
+ SCHEME_OBJECT Purify_Object)
{
long Length;
SCHEME_OBJECT *Heap_Start, *Result, Answer;
}
\f
SCHEME_OBJECT
-Purify_Pass_2 (Info)
- SCHEME_OBJECT Info;
+DEFUN (Purify_Pass_2,
+ (Info),
+ SCHEME_OBJECT Info)
{
long Length;
Boolean Purify_Object;
SCHEME_OBJECT *New_Object, Relocated_Object, *Result;
long Pure_Length, Recomputed_Length;
+ STACK_SANITY_CHECK ("PURIFY");
Length = (OBJECT_DATUM (FAST_MEMORY_REF (Info, Purify_Length)));
if (FAST_MEMORY_REF (Info, Purify_Really_Pure) == SHARP_F)
{
Purify_Object = true;
}
Relocated_Object = *Heap_Bottom;
- if (!(Test_Pure_Space_Top (Free_Constant + Length + 6)))
+ if (!(TEST_CONSTANT_TOP (Free_Constant + Length + 6)))
{
return (SHARP_F);
}
Recomputed_Length = ((Free_Constant - New_Object) - 4);
*Free_Constant++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
*Free_Constant++ = (MAKE_OBJECT (END_OF_BLOCK, (Recomputed_Length + 5)));
- if (!(Test_Pure_Space_Top (Free_Constant)))
+ if (!(TEST_CONSTANT_TOP (Free_Constant)))
{
fprintf (stderr,
"\nPurify overrun: Constant_Top = 0x%lx, Free_Constant = 0x%lx\n",
*New_Object++ =
(MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length));
*New_Object = (MAKE_OBJECT (PURE_PART, (Recomputed_Length + 5)));
+ SET_CONSTANT_TOP ();
GC ();
- Set_Pure_Top ();
return (SHARP_T);
}
\f
long new_gc_reserve;
SCHEME_OBJECT Object, Purify_Result, Daemon;
PRIMITIVE_HEADER (3);
+ PRIMITIVE_CANONICALIZE_CONTEXT ();
- PRIMITIVE_CANONICALIZE_CONTEXT();
- Save_Time_Zone(Zone_Purify);
+ STACK_SANITY_CHECK ("PURIFY");
+ Save_Time_Zone (Zone_Purify);
+ TOUCH_IN_PRIMITIVE ((ARG_REF (1)), Object);
CHECK_ARG (2, BOOLEAN_P);
new_gc_reserve = (arg_nonnegative_integer (3));
run, and then Purify_Pass_2 is called to copy back.
*/
- TOUCH_IN_PRIMITIVE ((ARG_REF (1)), Object);
GC_Reserve = new_gc_reserve;
ENTER_CRITICAL_SECTION ("purify pass 1");
Purify_Result = (Purify (Object, (ARG_REF (2))));
POP_PRIMITIVE_FRAME (3);
- Daemon = Get_Fixed_Obj_Slot(GC_Daemon);
+ Daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
if (Daemon == SHARP_F)
{
SCHEME_OBJECT words_free;
RENAME_CRITICAL_SECTION ("purify pass 2");
- Purify_Result = Purify_Pass_2(Purify_Result);
+ Purify_Result = (Purify_Pass_2 (Purify_Result));
words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
Val = (MAKE_POINTER_OBJECT (TC_LIST, Free));
(*Free++) = Purify_Result;
(*Free++) = words_free;
- PRIMITIVE_ABORT(PRIM_POP_RETURN);
+ PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
+
RENAME_CRITICAL_SECTION ("purify daemon 1");
- Store_Expression(Purify_Result);
- Store_Return(RC_PURIFY_GC_1);
- Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Save_Cont();
+ Store_Expression (Purify_Result);
+ Store_Return (RC_PURIFY_GC_1);
+ Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
+ Save_Cont ();
STACK_PUSH (Daemon);
STACK_PUSH (STACK_FRAME_HEADER);
- Pushed();
- PRIMITIVE_ABORT(PRIM_APPLY);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
}
/* -*-C-*-
-Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.40 1991/02/24 01:11:04 jinx Exp $
+
+Copyright (c) 1987-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.39 1990/06/28 18:18:11 jinx Rel $ */
-
/* Pure/Constant space utilities. */
#include "scheme.h"
#include "zones.h"
\f
static void
-Update(From, To, Was, Will_Be)
- fast SCHEME_OBJECT *From, *To, *Was, *Will_Be;
+DEFUN (Update,
+ (From, To, Was, Will_Be),
+ fast SCHEME_OBJECT *From AND
+ fast SCHEME_OBJECT *To AND
+ fast SCHEME_OBJECT *Was AND
+ fast SCHEME_OBJECT *Will_Be)
{
fast long count;
}
\f
long
-Make_Impure(Object, New_Object)
- SCHEME_OBJECT Object, *New_Object;
+DEFUN (Make_Impure,
+ (Object, New_Object),
+ SCHEME_OBJECT Object AND
+ SCHEME_OBJECT *New_Object)
{
SCHEME_OBJECT *New_Address, *End_Of_Area;
fast SCHEME_OBJECT *Obj_Address, *Constant_Address;
Constant_Address = Free_Constant;
- Obj_Address = OBJECT_ADDRESS (Object);
- if (!Test_Pure_Space_Top(Constant_Address + Length))
+ Obj_Address = (OBJECT_ADDRESS (Object));
+ if (!(TEST_CONSTANT_TOP (Constant_Address + Length)))
{
return (ERR_IMPURIFY_OUT_OF_SPACE);
}
- Block_Length = OBJECT_DATUM (*(Constant_Address-1));
+ Block_Length = (OBJECT_DATUM (* (Constant_Address - 1)));
Constant_Address -= 2;
New_Address = Constant_Address;
for (i = Length; --i >= 0; )
{
*Constant_Address++ = *Obj_Address;
- *Obj_Address++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, i);
+ *Obj_Address++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, i));
}
-\f
- *Constant_Address++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *Constant_Address++ = MAKE_OBJECT (END_OF_BLOCK, Block_Length + Length);
+
+ *Constant_Address++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ *Constant_Address++ = (MAKE_OBJECT (END_OF_BLOCK, Block_Length + Length));
*(New_Address + 2 - Block_Length) =
- MAKE_OBJECT (PURE_PART, Block_Length + Length);
+ (MAKE_OBJECT (PURE_PART, Block_Length + Length));
Obj_Address -= Length;
Free_Constant = Constant_Address;
+ SET_CONSTANT_TOP ();
/* Run through memory relocating pointers to this object, including
* those in pure areas.
*/
- Set_Pure_Top();
- Terminate_Old_Stacklet();
- Terminate_Constant_Space(End_Of_Area);
+ Terminate_Old_Stacklet ();
+ SEAL_CONSTANT_SPACE ();
+ End_Of_Area = (CONSTANT_SPACE_SEAL ());
ENTER_CRITICAL_SECTION ("impurify");
- Update(Heap_Bottom, Free, Obj_Address, New_Address);
- Update(Constant_Space, End_Of_Area, Obj_Address, New_Address);
+ Update (Heap_Bottom, Free, Obj_Address, New_Address);
+ Update (Constant_Space, End_Of_Area, Obj_Address, New_Address);
EXIT_CRITICAL_SECTION ({});
PRIMITIVE_RETURN (new_object);
}
}
-\f
-extern SCHEME_OBJECT * find_constant_space_block();
+
+extern SCHEME_OBJECT * EXFUN (find_constant_space_block, (SCHEME_OBJECT *));
SCHEME_OBJECT *
-find_constant_space_block(obj_address)
- fast SCHEME_OBJECT *obj_address;
+DEFUN (find_constant_space_block,
+ (obj_address),
+ fast SCHEME_OBJECT *obj_address)
{
fast SCHEME_OBJECT *where, *low_constant;
}
Boolean
-Pure_Test(obj_address)
- SCHEME_OBJECT *obj_address;
+DEFUN (Pure_Test,
+ (obj_address),
+ SCHEME_OBJECT *obj_address)
{
SCHEME_OBJECT *block;
- block = find_constant_space_block (obj_address);
+ block = (find_constant_space_block (obj_address));
if (block == ((SCHEME_OBJECT *) NULL))
{
return (false);
extern SCHEME_OBJECT *copy_to_constant_space();
SCHEME_OBJECT *
-copy_to_constant_space(source, nobjects)
- fast SCHEME_OBJECT *source;
- long nobjects;
+DEFUN (copy_to_constant_space,
+ (source, nobjects),
+ fast SCHEME_OBJECT *source AND
+ long nobjects)
{
fast SCHEME_OBJECT *dest;
fast long i;
SCHEME_OBJECT *result;
dest = Free_Constant;
- if (!Test_Pure_Space_Top(dest + nobjects + 6))
+ if (!(TEST_CONSTANT_TOP (dest + nobjects + 6)))
{
- fprintf(stderr,
+ fprintf (stderr,
"copy_to_constant_space: Not enough constant space!\n");
- Microcode_Termination(TERM_NO_SPACE);
+ Microcode_Termination (TERM_NO_SPACE);
}
- *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 3);
- *dest++ = MAKE_OBJECT (PURE_PART, nobjects + 5);
- *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *dest++ = MAKE_OBJECT (CONSTANT_PART, 3);
+ *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 3));
+ *dest++ = (MAKE_OBJECT (PURE_PART, nobjects + 5));
+ *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ *dest++ = (MAKE_OBJECT (CONSTANT_PART, 3));
result = dest;
for (i = nobjects; --i >= 0; )
{
*dest++ = *source++;
}
- *dest++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *dest++ = MAKE_OBJECT (END_OF_BLOCK, nobjects + 5);
+ *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
+ *dest++ = (MAKE_OBJECT (END_OF_BLOCK, nobjects + 5));
Free_Constant = dest;
+ SET_CONSTANT_TOP ();
return result;
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.28 1990/06/20 17:42:03 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.29 1991/02/24 01:11:10 jinx Exp $
-Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1987-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
/* Used by garbage collector to detect the end of constant space */
-#define Terminate_Constant_Space(Where) \
- *Free_Constant = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant);\
- Where = Free_Constant
+#define CONSTANT_SCAN_SEAL() Free_Constant
+
+#define SEAL_CONSTANT_SPACE() \
+ *Free_Constant = \
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant));
+
+#define CONSTANT_SPACE_SEALED() \
+((*Free_Constant) == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Free_Constant)))
#define Get_Current_Stacklet() \
(MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Current_Stacklet))
/* Used by garbage collector to detect the end of constant space, and to
skip over the gap between constant space and the stack. */
-#define Terminate_Constant_Space(Where) \
+#define CONSTANT_SPACE_SEAL() Stack_Top
+
+#define SEAL_CONSTANT_SPACE() \
+do \
{ \
*Free_Constant = \
(MAKE_OBJECT \
(TC_MANIFEST_NM_VECTOR, ((Stack_Pointer - Free_Constant) - 1))); \
- *Stack_Top = MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top); \
- Where = Stack_Top; \
-}
+ *(Free_Constant + 1) = \
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, (Free_Constant + 1))); \
+ *Stack_Top = (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, Stack_Top)); \
+} while (0)
+
+#define CONSTANT_SPACE_SEALED() \
+((*(Free_Constant + 1)) == \
+ (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, (Free_Constant + 1))))
#define Get_Current_Stacklet() SHARP_F
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtrap.c,v 1.7 1991/01/16 00:34:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/uxtrap.c,v 1.8 1991/02/24 01:11:22 jinx Exp $
-Copyright (c) 1990, 1991 Massachusetts Institute of Technology
+Copyright (c) 1990-1991 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
int code AND
struct FULL_SIGCONTEXT * scp)
{
+ Boolean constant_space_broken = (!(CONSTANT_SPACE_SEALED ()));
enum trap_state old_trap_state = trap_state;
trap_state = trap_state_trapped;
if (WITHIN_CRITICAL_SECTION_P ())
fprintf (stdout, ">> [signal %d (%s), code %d]\n",
signo, (find_signal_name (signo)), code);
}
- else if (old_trap_state != trap_state_recover)
+ else if (constant_space_broken || (old_trap_state != trap_state_recover))
{
fprintf (stdout, "\n>> A %s has occurred.\n", message);
fprintf (stdout, ">> [signal %d (%s), code %d]\n",
signo, (find_signal_name (signo)), code);
}
+ if (constant_space_broken)
+ {
+ fputs (">> Constant space has been overwritten.\n", stdout);
+ fputs (">> Probably a runaway recursion has overflowed the stack.\n",
+ stdout);
+ }
fflush (stdout);
switch (old_trap_state)
{
else
trap_immediate_termination ();
case trap_state_recover:
- if (WITHIN_CRITICAL_SECTION_P ())
+ if ((WITHIN_CRITICAL_SECTION_P ()) || constant_space_broken)
{
fputs (">> Successful recovery is unlikely.\n", stdout);
break;
projects / mit-scheme.git / commitdiff