/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/comutl.c,v 1.10 1987/12/09 22:35:43 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/comutl.c,v 1.11 1988/03/12 16:04:26 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
#include "scheme.h"
#include "primitive.h"
-#include "gccode.h"
extern Pointer *compiled_entry_to_block_address();
extern long compiled_entry_to_block_offset();
+extern void compiled_entry_type();
\f
-#define COMPILED_CODE_ADDRESS_P(object) \
- (((OBJECT_TYPE (object)) == TC_COMPILED_EXPRESSION) || \
- ((OBJECT_TYPE (object)) == TC_RETURN_ADDRESS))
+#define COMPILED_CODE_ADDRESS_P(object) \
+ ((OBJECT_TYPE (object)) == TC_COMPILED_ENTRY)
-Pointer *
-compiled_entry_to_block_address(ce)
- Pointer ce;
-{
-#ifdef Get_Compiled_Block
-
- Pointer *block;
-
- block = Get_Pointer(ce);
- Get_Compiled_Block(block, block);
- return block;
-
-#else
-
- error_external_return();
- /*NOTREACHED*/
-
-#endif
-}
-
-long
-compiled_entry_to_block_offset(ce)
- Pointer ce;
-{
- Pointer *address;
-
- address = Get_Pointer(ce);
- return (((unsigned long) address) -
- ((unsigned long) compiled_entry_to_block_address(address)));
-}
-\f
DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK",
Prim_comp_code_address_block, 1)
{
PRIMITIVE_RETURN (Make_Pointer (TC_COMPILED_CODE_BLOCK, address));
}
-DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET", Prim_comp_code_address_offset, 1)
+DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET",
+ Prim_comp_code_address_offset, 1)
{
long offset;
Primitive_1_Arg ();
PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM(STACK_TOP_TO_DATUM()));
}
+
+DEFINE_PRIMITIVE("COMPILED-ENTRY-KIND", Prim_Compiled_Entry_Type, 1)
+{
+ fast Pointer *temp;
+ Pointer result;
+ PRIMITIVE_HEADER(1);
+
+ CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
+
+ Primitive_GC_If_Needed(3);
+ temp = Free;
+ Free = &temp[3];
+ compiled_entry_type(ARG_REF(1), temp);
+ temp[0] = MAKE_UNSIGNED_FIXNUM(((long) temp[0]));
+ temp[1] = MAKE_SIGNED_FIXNUM(((long) temp[1]));
+ temp[2] = MAKE_SIGNED_FIXNUM(((long) temp[2]));
+ PRIMITIVE_RETURN (Make_Pointer(TC_HUNK3, temp));
+}
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/const.h,v 9.27 1988/02/06 20:39:40 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.28 1988/03/12 16:04:43 jinx Rel $
*
* Named constants used throughout the interpreter
*
#define PRIM_NO_TRAP_APPLY -6
#define PRIM_POP_RETURN -7
#define PRIM_TOUCH -8
+#define PRIM_APPLY_INTERRUPT -9
#define ABORT_NAME_TABLE \
{ \
/* -5 */ "NO-TRAP-EVAL", \
/* -6 */ "NO-TRAP_APPLY", \
/* -7 */ "POP-RETURN", \
- /* -8 */ "TOUCH" \
+ /* -8 */ "TOUCH", \
+ /* -9 */ "APPLY-INTERRUPT" \
}
/* Some numbers of parameters which mean something special */
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/errors.h,v 9.29 1988/02/06 20:40:00 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.30 1988/03/12 16:04:57 jinx Rel $
*
* Error and termination code declarations.
*
#define ERR_ARG_1_BAD_RANGE 0x10
#define ERR_ARG_2_BAD_RANGE 0x11
#define ERR_ARG_3_BAD_RANGE 0x12
-/* #define ERR_BAD_COMBINATION 0x13 */
+#define ERR_BAD_COMBINATION 0x13
/* #define ERR_FASDUMP_OVERFLOW 0x14 */
#define ERR_BAD_INTERRUPT_CODE 0x15 /* Not generated */
/* #define ERR_NO_ERRORS 0x16 */
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/fasdump.c,v 9.35 1988/02/20 06:17:33 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.36 1988/03/12 16:05:10 jinx Exp $
This file contains code for fasdump and dump-band.
*/
contents (e) To_Pointer is now NewFree.
*/
+#define Setup_Pointer_for_Dump(Extra_Code) \
+Dump_Pointer(Fasdump_Setup_Pointer(Extra_Code, Normal_BH(false, continue)))
+
#define Dump_Pointer(Code) \
Old = Get_Pointer(Temp); \
Code
-#define Setup_Pointer_for_Dump(Extra_Code) \
-Dump_Pointer(Fasdump_Setup_Pointer(Extra_Code, Normal_BH(false, continue)))
+#define Dump_Compiled_Entry() \
+{ \
+ Dump_Pointer(Fasdump_Setup_Pointer(Transport_Compiled(), \
+ Compiled_BH(false, continue))); \
+}
/* Dump_Mode is currently a fossil. It should be resurrected. */
and 2 for the Fixup.
*/
+#define NORMAL_GC 0
+#define PURE_COPY 1
+#define CONSTANT_COPY 2
+
#define FASDUMP_FIX_BUFFER 10
long
case TC_STACK_ENVIRONMENT:
case_Fasload_Non_Pointer:
break;
+\f
+ /* Compiled code relocation. */
- case_compiled_entry_point:
+ case TC_LINKAGE_SECTION:
+ {
compiled_code_present_p = true;
- Dump_Pointer(Fasdump_Setup_Pointer(Transport_Compiled(),
- Compiled_BH(false, continue)));
+ if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
+ {
+ /* Assumes that all others are objects of type TC_QUAD without
+ their type codes.
+ */
+
+ fast long count;
+
+ Scan++;
+ for (count = READ_CACHE_LINKAGE_COUNT(Temp);
+ --count >= 0;
+ Scan += 1)
+ {
+ Temp = *Scan;
+ Setup_Pointer_for_Dump(Transport_Quadruple());
+ }
+ Scan -= 1;
+ break;
+ }
+ else
+ {
+ fast long count;
+ fast machine_word *word_ptr;
+ Pointer *end_scan;
+
+ count = READ_OPERATOR_LINKAGE_COUNT(Temp);
+ word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
+ end_scan = END_OPERATOR_LINKAGE_AREA(Scan, count);
+
+ while(--count >= 0)
+ {
+ Scan = ((Pointer *) word_ptr);
+ word_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr);
+ Temp = *Scan;
+ Dump_Compiled_Entry();
+ }
+ Scan = end_scan;
+ break;
+ }
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ machine_word *start_ptr;
+ fast machine_word *word_ptr;
+ Pointer *saved_scan;
+
+ saved_scan = ++Scan;
+ word_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
+ start_ptr = word_ptr;
+
+ while (VALID_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ Scan = MANIFEST_CLOSURE_ENTRY_ADDRESS(word_ptr);
+ word_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ Temp = *Scan;
+ Dump_Compiled_Entry();
+ }
+ Scan = saved_scan + MANIFEST_CLOSURE_SIZE(word_ptr, start_ptr);
+ break;
+ }
+ case_compiled_entry_point:
+ compiled_code_present_p = true;
+ Dump_Compiled_Entry();
+ break;
+\f
case_Cell:
Setup_Pointer_for_Dump(Transport_Cell());
+ break;
case TC_REFERENCE_TRAP:
if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
case TC_WEAK_CONS:
case_Fasdump_Pair:
Setup_Pointer_for_Dump(Transport_Pair());
+ break;
case TC_INTERNED_SYMBOL:
Setup_Pointer_for_Dump(Fasdump_Symbol(Make_Broken_Heart(0)));
+ break;
case TC_UNINTERNED_SYMBOL:
Setup_Pointer_for_Dump(Fasdump_Symbol(UNBOUND_OBJECT));
+ break;
case_Triple:
Setup_Pointer_for_Dump(Transport_Triple());
+ break;
case TC_VARIABLE:
Setup_Pointer_for_Dump(Fasdump_Variable());
+ break;
/* DumpLoop continues on the next page */
\f
case_Quadruple:
Setup_Pointer_for_Dump(Transport_Quadruple());
+ break;
-#ifdef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- Setup_Pointer_for_Dump(Transport_Flonum());
-#else
case TC_BIG_FLONUM:
- /* Fall through */
-#endif
+ Setup_Pointer_for_Dump({
+ Transport_Flonum();
+ break;
+ });
+
case TC_COMPILED_CODE_BLOCK:
case_Purify_Vector:
Setup_Pointer_for_Dump(Transport_Vector());
+ break;
case TC_ENVIRONMENT:
/* Make fasdump fail */
case TC_FUTURE:
Setup_Pointer_for_Dump(Transport_Future());
+ break;
default:
sprintf(gc_death_message_buffer,
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/fasload.c,v 9.34 1988/02/10 15:43:35 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.35 1988/03/12 16:05:26 jinx Exp $
The "fast loader" which reads in and relocates binary files and then
interns symbols. It is called with one argument: the (character
*/
void
-Relocate_Block(Next_Pointer, Stop_At)
- fast Pointer *Next_Pointer, *Stop_At;
+Relocate_Block(Scan, Stop_At)
+ fast Pointer *Scan, *Stop_At;
{
extern Pointer *load_renumber_table;
+ fast Pointer Temp;
+ fast long address;
if (Reloc_Debug)
{
fprintf(stderr,
- "Relocation beginning, block = 0x%x, length = 0x%x, end = 0x%x.\n",
- Next_Pointer, (Stop_At - Next_Pointer) - 1, Stop_At);
+ "\nRelocate_Block: block = 0x%x, length = 0x%x, end = 0x%x.\n",
+ Scan, ((Stop_At - Scan) - 1), Stop_At);
}
- while (Next_Pointer < Stop_At)
- {
- fast Pointer Temp;
- Temp = *Next_Pointer;
+ while (Scan < Stop_At)
+ {
+ Temp = *Scan;
Switch_by_GC_Type(Temp)
{
case TC_BROKEN_HEART:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_Fasload_Non_Pointer:
- Next_Pointer += 1;
+ Scan += 1;
break;
case TC_PRIMITIVE:
- *Next_Pointer++ = load_renumber_table[PRIMITIVE_NUMBER(Temp)];
+ *Scan++ = load_renumber_table[PRIMITIVE_NUMBER(Temp)];
break;
case TC_PCOMB0:
- *Next_Pointer++ =
+ *Scan++ =
Make_Non_Pointer(TC_PCOMB0,
load_renumber_table[PRIMITIVE_NUMBER(Temp)]);
break;
case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += Get_Integer(Temp)+1;
+ Scan += (Get_Integer(Temp) + 1);
break;
+\f
+ case TC_LINKAGE_SECTION:
+ {
+ if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
+ {
+ /* Assumes that all others are objects of type TC_QUAD without
+ their type codes.
+ */
+
+ fast long count;
+
+ Scan++;
+ for (count = READ_CACHE_LINKAGE_COUNT(Temp);
+ --count >= 0;
+ )
+ {
+ address = ((long) *Scan);
+ *Scan++ = ((Pointer) Relocate(address));
+ }
+ break;
+ }
+ else
+ {
+ fast long count;
+ fast machine_word *word_ptr;
+ Pointer *end_scan;
+
+ count = READ_OPERATOR_LINKAGE_COUNT(Temp);
+ word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
+ end_scan = END_OPERATOR_LINKAGE_AREA(Scan, count);
+
+ while(--count >= 0)
+ {
+ Scan = ((Pointer *) word_ptr);
+ word_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr);
+ address = ((long) *Scan);
+ *Scan = ((Pointer) Relocate(address));
+ }
+ Scan = &end_scan[1];
+ break;
+ }
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ machine_word *start_ptr;
+ fast machine_word *word_ptr;
+ Pointer *saved_scan;
+
+ saved_scan = ++Scan;
+ word_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
+ start_ptr = word_ptr;
+
+ while (VALID_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ Scan = MANIFEST_CLOSURE_ENTRY_ADDRESS(word_ptr);
+ word_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ address = ((long) *Scan);
+ *Scan = ((Pointer) Relocate(address));
+ }
+ Scan = saved_scan + (1 + MANIFEST_CLOSURE_SIZE(word_ptr, start_ptr));
+ break;
+ }
\f
#ifdef BYTE_INVERSION
case TC_CHARACTER_STRING:
- String_Inversion(Relocate(Datum(Temp)));
+ String_Inversion(Relocate(OBJECT_DATUM(Temp)));
goto normal_pointer;
#endif
case TC_REFERENCE_TRAP:
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
+ if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
{
- Next_Pointer += 1;
+ Scan += 1;
break;
}
/* It is a pointer, fall through. */
/* Compiled entry points and stack environments work automagically. */
/* This should be more strict. */
- default:
- {
-normal_pointer:
- {
- fast long Next;
- Next = Datum(Temp);
- *Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next));
- }
+ default:
+ normal_pointer:
+ address = OBJECT_DATUM(Temp);
+ *Scan++ = Make_Pointer(OBJECT_TYPE(Temp), Relocate(address));
+ break;
}
- }
}
return;
}
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/gccode.h,v 9.34 1988/02/20 06:17:48 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.35 1988/03/12 16:05:46 jinx Exp $
*
* This file contains the macros for use in code which does GC-like
* loops over memory. It is only included in a few files, unlike
TC_MANIFEST_NM_VECTOR
TC_MANIFEST_SPECIAL_NM_VECTOR
TC_REFERENCE_TRAP
+ TC_MANIFEST_CLOSURE
+ TC_LINKAGE_SECTION
*/
#define case_compiled_entry_point \
- case TC_COMPILED_EXPRESSION: \
- case TC_RETURN_ADDRESS \
+ case TC_COMPILED_ENTRY
#define case_Cell \
case TC_CELL
case TC_IN_PACKAGE: \
case TC_LEXPR: \
case TC_DISJUNCTION: \
- case TC_COMPILED_PROCEDURE: \
case TC_COMPLEX: \
case TC_ENTITY: \
case TC_RATNUM
\f
/* Macros for the garbage collector and related programs. */
-#define NORMAL_GC 0
-#define PURE_COPY 1
-#define CONSTANT_COPY 2
-
/* Pointer setup for the GC Type handlers. */
+#define GC_Consistency_Check(In_GC) \
+{ \
+ if And2(In_GC, Consistency_Check) \
+ { \
+ if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \
+ { \
+ sprintf(gc_death_message_buffer, \
+ "setup_internal: out of range pointer (0x%lx)", \
+ Temp); \
+ gc_death(TERM_EXIT, gc_death_message_buffer, Scan, To); \
+ /*NOTREACHED*/ \
+ } \
+ } \
+}
+
/* Check whether it has been relocated. */
#define Normal_BH(In_GC, then_what) \
-if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
{ \
- *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old); \
- then_what; \
+ if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ { \
+ *Scan = Make_New_Pointer(OBJECT_TYPE(Temp), *Old); \
+ then_what; \
+ } \
}
-#define Setup_Internal(In_GC, Extra_Code, BH_Code) \
-if And2(In_GC, Consistency_Check) \
+#define Setup_Internal(In_GC, Transport_Code, Already_Relocated_Code) \
{ \
- if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \
+ GC_Consistency_Check(In_GC); \
+ if (Old >= Low_Constant) \
{ \
- sprintf(gc_death_message_buffer, \
- "setup_internal: out of range pointer (0x%lx)", \
- Temp); \
- gc_death(TERM_EXIT, gc_death_message_buffer, Scan, To); \
- /*NOTREACHED*/ \
+ continue; \
} \
-} \
-if (Old >= Low_Constant) \
+ Already_Relocated_Code; \
+ New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
+ Transport_Code; \
+}
+
+#define Setup_Pointer(In_GC, Transport_Code) \
{ \
- continue; \
-} \
-BH_Code; \
-New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
-Extra_Code; \
-continue
-
-#define Setup_Pointer(In_GC, Extra_Code) \
-Setup_Internal(In_GC, Extra_Code, Normal_BH(In_GC, continue))
-
-#define Pointer_End() \
-*Get_Pointer(Temp) = New_Address; \
-*Scan = Make_New_Pointer(Type_Code(Temp), New_Address)
+ Setup_Internal(In_GC, Transport_Code, Normal_BH(In_GC, continue)); \
+}
+
+#define Pointer_End() \
+{ \
+ *Get_Pointer(Temp) = New_Address; \
+ *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \
+}
\f
/* GC Type handlers. These do the actual work. */
-#define Transport_Cell() \
-*To++ = *Old; \
-Pointer_End()
-
-#define Transport_Pair() \
-*To++ = *Old++; \
-*To++ = *Old; \
-Pointer_End()
-
-#define Transport_Triple() \
-*To++ = *Old++; \
-*To++ = *Old++; \
-*To++ = *Old; \
-Pointer_End()
-
-#define Transport_Quadruple() \
-*To++ = *Old++; \
-*To++ = *Old++; \
-*To++ = *Old++; \
-*To++ = *Old; \
-Pointer_End()
+#define Transport_Cell() \
+{ \
+ *To++ = *Old; \
+ Pointer_End(); \
+}
+
+#define Transport_Pair() \
+{ \
+ *To++ = *Old++; \
+ *To++ = *Old; \
+ Pointer_End(); \
+}
+
+#define Transport_Triple() \
+{ \
+ *To++ = *Old++; \
+ *To++ = *Old++; \
+ *To++ = *Old; \
+ Pointer_End(); \
+}
+
+#define Transport_Quadruple() \
+{ \
+ *To++ = *Old++; \
+ *To++ = *Old++; \
+ *To++ = *Old++; \
+ *To++ = *Old; \
+ Pointer_End(); \
+}
\f
#ifndef In_Fasdump
Scan = Saved_Scan; \
}
-#else In_Fasdump
+#else /* In_Fasdump */
#define Real_Transport_Vector() \
{ \
#endif
\f
+#define Transport_Vector() \
+{ \
+Move_Vector: \
+ Real_Transport_Vector(); \
+ Pointer_End(); \
+}
#ifdef FLOATING_ALIGNMENT
-#define Transport_Flonum() \
- Align_Float(To); \
- New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
- Real_Transport_Vector(); \
- Pointer_End()
-#endif
-#define Transport_Vector() \
-Move_Vector: \
- Real_Transport_Vector(); \
- Pointer_End()
+#define Transport_Flonum() \
+{ \
+ Align_Float(To); \
+ New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
+ Real_Transport_Vector(); \
+ Pointer_End(); \
+}
+
+#else
+
+#define Transport_Flonum() \
+{ \
+ goto Move_Vector; \
+}
+
+#endif
-#define Transport_Future() \
-if (!(Future_Spliceable(Temp))) \
- goto Move_Vector; \
-*Scan = Future_Value(Temp); \
-Scan -= 1
+#define Transport_Future() \
+{ \
+ if (!(Future_Spliceable(Temp))) \
+ goto Move_Vector; \
+ *Scan = Future_Value(Temp); \
+ Scan -= 1; \
+}
\f
/* Weak Pointer code. The idea here is to support a post-GC pass which
removes any objects in the CAR of a WEAK_CONS cell which is no longer
extern Pointer Weak_Chain;
-#define Transport_Weak_Cons() \
-{ long Car_Type = Type_Code(*Old); \
- *To++ = Make_New_Pointer(TC_NULL, *Old); \
- Old += 1; \
- *To++ = *Old; \
- *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
- Weak_Chain = Temp; \
- Pointer_End(); \
+#define Transport_Weak_Cons() \
+{ \
+ long Car_Type; \
+ \
+ Car_Type = OBJECT_TYPE(*Old); \
+ *To++ = Make_New_Pointer(TC_NULL, *Old); \
+ Old += 1; \
+ *To++ = *Old; \
+ *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
+ Weak_Chain = Temp; \
+ Pointer_End(); \
}
\f
/* Special versions of the above for DumpLoop in Fasdump. This code
*/
#define Fasdump_Setup_Pointer(Extra_Code, BH_Code) \
-BH_Code; \
+{ \
+ BH_Code; \
\
-/* It must be transported to New Space */ \
+ /* It must be transported to New Space */ \
\
-New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
-if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
-{ \
- NewFree = To; \
- Fixup = Fixes; \
- return (PRIM_INTERRUPT); \
-} \
-*--Fixes = *Old; \
-*--Fixes = C_To_Scheme(Old); \
-Extra_Code; \
-continue
+ New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
+ if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
+ { \
+ NewFree = To; \
+ Fixup = Fixes; \
+ return (PRIM_INTERRUPT); \
+ } \
+ *--Fixes = *Old; \
+ *--Fixes = C_To_Scheme(Old); \
+ Extra_Code; \
+}
/* Undefine Symbols */
-#define Fasdump_Symbol(global_value) \
-*To++ = *Old; \
-*To++ = global_value; \
-Pointer_End()
+#define Fasdump_Symbol(global_value) \
+{ \
+ *To++ = *Old; \
+ *To++ = global_value; \
+ Pointer_End(); \
+}
-#define Fasdump_Variable() \
-*To++ = *Old; \
-*To++ = UNCOMPILED_VARIABLE; \
-*To++ = NIL; \
-Pointer_End()
+#define Fasdump_Variable() \
+{ \
+ *To++ = *Old; \
+ *To++ = UNCOMPILED_VARIABLE; \
+ *To++ = NIL; \
+ Pointer_End(); \
+}
\f
/* Compiled Code Relocation Utilities */
#endif
#else
-/* Is there anything else that can be done here? */
+typedef unsigned long machine_word;
-#define Relocate_Compiled(object, new_block, old_block) \
- (gc_death(TERM_COMPILER_DEATH, \
- "relocate_compiled: No compiler support!", \
- Scan, To), \
- NIL)
+/* Is there anything else that can be done here? */
-#define Compiled_BH(flag, then_what) \
-{ \
+#define GC_NO_COMPILER_STMT() \
gc_death(TERM_COMPILER_DEATH, \
"relocate_compiled: No compiler support!", \
- Scan, To); \
- /*NOTREACHED*/ \
-}
+ Scan, To)
+
+#define GC_NO_COMPILER_EXPR() \
+ (GC_NO_COMPILER_STMT(), NIL)
+
+#define Relocate_Compiled(object, new_block, old_block) \
+ GC_NO_COMPILER_EXPR()
+
+#define Transport_Compiled() GC_NO_COMPILER_STMT()
+
+#define Compiled_BH(flag, then_what) GC_NO_COMPILER_STMT()
+
+#define Get_Compiled_Block(var, address) GC_NO_COMPILER_STMT()
+
+#define READ_MANIFEST_CLOSURE_SIZE(scan) GC_NO_COMPILER_EXPR()
+
+#define FIRST_MANIFEST_CLOSURE_ENTRY(scan) GC_NO_COMPILER_EXPR()
+
+#define NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr) GC_NO_COMPILER_EXPR()
+
+#define END_MANIFEST_CLOSURE_AREA(scan, count) GC_NO_COMPILER_EXPR()
+
+#define READ_LINKAGE_KIND(header) GC_NO_COMPILER_EXPR()
+
+#define READ_CACHE_LINKAGE_COUNT(header) GC_NO_COMPILER_EXPR()
+
+#define READ_OPERATOR_LINKAGE_COUNT(header) GC_NO_COMPILER_EXPR()
+
+#define END_OPERATOR_LINKAGE_AREA(scan, count) GC_NO_COMPILER_EXPR()
+
+#define FIRST_OPERATOR_LINKAGE_ENTRY(scan) GC_NO_COMPILER_EXPR()
+
+#define NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr) GC_NO_COMPILER_EXPR()
-#define Transport_Compiled()
+#define OPERATOR_LINKAGE_KIND 0
#endif
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/gcloop.c,v 9.26 1988/02/20 06:18:04 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.27 1988/03/12 16:06:06 jinx Exp $
*
* This file contains the code for the most primitive part
* of garbage collection.
extern Pointer *GCLoop();
-#define GC_Pointer(Code) \
-Old = Get_Pointer(Temp); \
-Code
-
-#define Setup_Pointer_for_GC(Extra_Code) \
-GC_Pointer(Setup_Pointer(true, Extra_Code))
+#define GC_Pointer(Code) \
+{ \
+ Old = Get_Pointer(Temp); \
+ Code; \
+}
+#define Setup_Pointer_for_GC(Extra_Code) \
+{ \
+ GC_Pointer(Setup_Pointer(true, Extra_Code)); \
+}
+\f
#ifdef ENABLE_DEBUGGING_TOOLS
-static Pointer *gc_scan_trap = NULL;
-static Pointer *gc_free_trap = NULL;
-static Pointer gc_trap = Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE);
+
+Pointer
+ *gc_scan_trap = NULL,
+ *gc_free_trap = NULL,
+ gc_trap = Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE);
+
+#define HANDLE_GC_TRAP() \
+{ \
+ if ((Temp == gc_trap) || \
+ (Scan == gc_scan_trap) || \
+ (To == gc_free_trap)) \
+ { \
+ fprintf(stderr, "\nGCLoop: trap.\n"); \
+ } \
+}
+
+#else
+
+#define HANDLE_GC_TRAP()
+
#endif
\f
-Pointer
-*GCLoop(Scan, To_Pointer)
-fast Pointer *Scan;
-Pointer **To_Pointer;
-{ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
+Pointer *
+GCLoop(Scan, To_Pointer)
+ fast Pointer *Scan;
+ Pointer **To_Pointer;
+{
+ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
To = *To_Pointer;
Low_Constant = Constant_Space;
for ( ; Scan != To; Scan++)
- { Temp = *Scan;
-
-#ifdef ENABLE_DEBUGGING_TOOLS
- if ((Temp == gc_trap) || (Scan == gc_scan_trap) || (To == gc_free_trap))
- {
- fprintf(stderr, "\nGCLoop: trap.\n");
- }
-#endif
+ {
+ Temp = *Scan;
+ HANDLE_GC_TRAP();
Switch_by_GC_Type(Temp)
- { case TC_BROKEN_HEART:
+ {
+ case TC_BROKEN_HEART:
if (Scan == (Get_Pointer(Temp)))
{
*To_Pointer = To;
case_Non_Pointer:
break;
+\f
+ /* Compiled code relocation. */
+
+ case TC_LINKAGE_SECTION:
+ {
+ if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
+ {
+ /* Assumes that all others are objects of type TC_QUAD without
+ their type codes.
+ */
+
+ fast long count;
+
+ Scan++;
+ for (count = READ_CACHE_LINKAGE_COUNT(Temp);
+ --count >= 0;
+ Scan += 1)
+ {
+ Temp = *Scan;
+ Setup_Pointer_for_GC(Transport_Quadruple());
+ }
+ Scan -= 1;
+ break;
+ }
+ else
+ {
+ fast long count;
+ fast machine_word *word_ptr;
+ Pointer *end_scan;
+
+ count = READ_OPERATOR_LINKAGE_COUNT(Temp);
+ word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
+ end_scan = END_OPERATOR_LINKAGE_AREA(Scan, count);
+
+ while(--count >= 0)
+ {
+ Scan = ((Pointer *) word_ptr);
+ word_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr);
+ Temp = *Scan;
+ GC_Pointer(Setup_Internal(true,
+ Transport_Compiled(),
+ Compiled_BH(true, continue)));
+ }
+ Scan = end_scan;
+ break;
+ }
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ machine_word *start_ptr;
+ fast machine_word *word_ptr;
+ Pointer *saved_scan;
+
+ saved_scan = ++Scan;
+ word_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
+ start_ptr = word_ptr;
+
+ while (VALID_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ Scan = MANIFEST_CLOSURE_ENTRY_ADDRESS(word_ptr);
+ word_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ Temp = *Scan;
+ GC_Pointer(Setup_Internal(true,
+ Transport_Compiled(),
+ Compiled_BH(true, continue)));
+ }
+ Scan = saved_scan + MANIFEST_CLOSURE_SIZE(word_ptr, start_ptr);
+ break;
+ }
case_compiled_entry_point:
GC_Pointer(Setup_Internal(true,
Transport_Compiled(),
Compiled_BH(true, continue)));
-
+ break;
+\f
case_Cell:
Setup_Pointer_for_GC(Transport_Cell());
+ break;
case TC_REFERENCE_TRAP:
if (OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE)
/* It is a non pointer. */
break;
}
- /* It is a pair, fall through. */
+ /* Fall Through. */
+
case_Pair:
Setup_Pointer_for_GC(Transport_Pair());
+ break;
case TC_VARIABLE:
case_Triple:
Setup_Pointer_for_GC(Transport_Triple());
-
-/* GCLoop continues on the next page */
-\f
-/* GCLoop, continued */
+ break;
case_Quadruple:
Setup_Pointer_for_GC(Transport_Quadruple());
+ break;
-#ifdef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- Setup_Pointer_for_GC(Transport_Flonum());
-#else
case TC_BIG_FLONUM:
- /* Fall through */
-#endif
+ Setup_Pointer_for_GC({
+ Transport_Flonum();
+ break;
+ });
+
case_Vector:
Setup_Pointer_for_GC(Transport_Vector());
+ break;
case TC_FUTURE:
Setup_Pointer_for_GC(Transport_Future());
+ break;
case TC_WEAK_CONS:
Setup_Pointer_for_GC(Transport_Weak_Cons());
+ break;
default:
sprintf(gc_death_message_buffer,
/*NOTREACHED*/
} /* Switch_by_GC_Type */
} /* For loop */
+
*To_Pointer = To;
return (To);
+
} /* GCLoop */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.27 1988/02/12 16:51:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.28 1988/03/12 16:06:21 jinx Rel $
*
* This file contains the table which maps between Types and
* GC Types.
GC_Vector, /* TC_VECTOR */
GC_Non_Pointer, /* TC_RETURN_CODE */
GC_Triple, /* TC_COMBINATION_2 */
- GC_Pair, /* TC_COMPILED_PROCEDURE */
+ GC_Special, /* TC_MANIFEST_CLOSURE */
GC_Vector, /* TC_BIG_FIXNUM */
GC_Pair, /* TC_PROCEDURE */
GC_Pair, /* TC_ENTITY */
GC_Vector, /* TC_COMBINATION */
GC_Special, /* TC_MANIFEST_NM_VECTOR */
- GC_Compiled, /* TC_COMPILED_EXPRESSION */
+ GC_Compiled, /* TC_COMPILED_ENTRY */
GC_Pair, /* TC_LEXPR */
GC_Vector, /* TC_PCOMB3 */
GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */
GC_Cell, /* TC_CELL */
GC_Pair, /* TC_WEAK_CONS */
GC_Quadruple, /* TC_QUAD */
- GC_Compiled, /* TC_RETURN_ADDRESS */
+ GC_Special, /* TC_LINKAGE_SECTION */
GC_Pair, /* TC_RATNUM */
GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
GC_Pair, /* TC_COMPLEX */
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/interp.c,v 9.39 1988/02/20 06:18:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.40 1988/03/12 16:06:40 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
{
case PRIM_APPLY:
LOG_FUTURES();
+ case CODE_MAP(PRIM_APPLY):
goto Internal_Apply;
case PRIM_NO_TRAP_APPLY:
LOG_FUTURES();
+ case CODE_MAP(PRIM_NO_TRAP_APPLY):
goto Apply_Non_Trapping;
case PRIM_DO_EXPRESSION:
+ Val = Fetch_Expression();
LOG_FUTURES();
- Reduces_To(Fetch_Expression());
+ case CODE_MAP(PRIM_DO_EXPRESSION):
+ Reduces_To(Val);
case PRIM_NO_TRAP_EVAL:
+ Val = Fetch_Expression();
LOG_FUTURES();
- New_Reduction(Fetch_Expression(), Fetch_Env());
+ case CODE_MAP(PRIM_NO_TRAP_EVAL):
+ New_Reduction(Val, Fetch_Env());
goto Eval_Non_Trapping;
case 0: /* first time */
case PRIM_POP_RETURN:
LOG_FUTURES();
+ case CODE_MAP(PRIM_POP_RETURN):
goto Pop_Return;
\f
case PRIM_TOUCH:
+ {
+ Pointer temp;
+
+ temp = Val;
BACK_OUT_AFTER_PRIMITIVE();
+ Val = temp;
LOG_FUTURES();
/* fall through */
+ }
+
case CODE_MAP(PRIM_TOUCH):
TOUCH_SETUP(Val);
goto Internal_Apply;
case TC_CHARACTER_STRING:
case TC_CHARACTER:
case TC_COMPILED_CODE_BLOCK:
- case TC_COMPILED_PROCEDURE:
case TC_COMPLEX:
case TC_CONTROL_POINT:
case TC_DELAYED:
Save_Env();
Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed());
- case TC_COMPILED_EXPRESSION:
+ case TC_COMPILED_ENTRY:
{
Pointer compiled_expression;
define_compiler_restart (RC_COMP_INTERRUPT_RESTART,
comp_interrupt_restart)
- define_compiler_restart (RC_COMP_LEXPR_INTERRUPT_RESTART,
- comp_lexpr_interrupt_restart)
-
define_compiler_restart (RC_COMP_LOOKUP_APPLY_RESTART,
comp_lookup_apply_restart)
define_compiler_restart (RC_COMP_SAFE_REFERENCE_RESTART,
comp_safe_reference_restart)
- define_compiler_restart (RC_COMP_CACHE_LOOKUP_RESTART,
- comp_cache_lookup_restart)
-
define_compiler_restart (RC_COMP_LOOKUP_TRAP_RESTART,
comp_lookup_trap_restart)
- define_compiler_restart (RC_COMP_CACHE_ASSIGN_RESTART,
- comp_cache_assignment_restart)
-
define_compiler_restart (RC_COMP_ASSIGNMENT_TRAP_RESTART,
comp_assignment_trap_restart)
- define_compiler_restart (RC_COMP_CACHE_OPERATOR_RESTART,
- comp_cache_operator_restart)
-
define_compiler_restart (RC_COMP_OP_REF_TRAP_RESTART,
- comp_op_ref_trap_restart)
+ comp_op_lookup_trap_restart)
define_compiler_restart (RC_COMP_CACHE_REF_APPLY_RESTART,
- comp_cache_ref_apply_restart)
+ comp_cache_lookup_apply_restart)
define_compiler_restart (RC_COMP_SAFE_REF_TRAP_RESTART,
- comp_safe_ref_trap_restart)
+ comp_safe_lookup_trap_restart)
define_compiler_restart (RC_COMP_UNASSIGNED_TRAP_RESTART,
comp_unassigned_p_trap_restart)
+
+ define_compiler_restart (RC_COMP_LINK_CACHES_RESTART,
+ comp_link_caches_restart)
\f
case RC_REENTER_COMPILED_CODE:
compiled_code_restart();
Save_Cont(); \
}
-#define Apply_Error(N) \
-{ \
- Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
- Val = NIL; \
- Pop_Return_Error(N); \
+#define Apply_Error(N)
+{
+ Store_Return(RC_INTERNAL_APPLY);
+ Store_Expression(NIL);
+ Val = NIL;
+ Pop_Return_Error(N);
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- case TC_COMPILED_PROCEDURE:
+ case TC_COMPILED_ENTRY:
{
apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
switch (Which_Way)
{
case PRIM_DONE:
- { compiled_code_done();
+ {
+ compiled_code_done();
goto Pop_Return;
}
case PRIM_APPLY:
- { compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
+ {
+ compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
goto Internal_Apply;
}
- case ERR_COMPILED_CODE_ERROR:
- { /* The compiled code is signalling a microcode error. */
- compiled_error_backout();
- /* The Save_Cont is done by Pop_Return_Error. */
- Pop_Return_Error( compiled_code_error_code);
- }
-
case PRIM_INTERRUPT:
{
compiled_error_backout();
Save_Cont();
Interrupt(PENDING_INTERRUPTS());
}
+
+
+ case PRIM_APPLY_INTERRUPT:
+ {
+ apply_compiled_backout();
+ Prepare_Apply_Interrupt();
+ Interrupt(PENDING_INTERRUPTS());
+ }
+
+ case ERR_COMPILED_CODE_ERROR:
+ {
+ /* The compiled code is signalling a microcode error. */
+ compiled_error_backout();
+ /* The Save_Cont is done by Pop_Return_Error. */
+ Pop_Return_Error( compiled_code_error_code);
+ }
\f
+ case ERR_INAPPLICABLE_OBJECT:
+ /* This error code means that apply_compiled_procedure
+ was called on an object which is not a compiled procedure.
+
+ Fall through...
+ */
+
case ERR_WRONG_NUMBER_OF_ARGUMENTS:
{
apply_compiled_backout();
}
\f
case ERR_EXECUTE_MANIFEST_VECTOR:
- { /* This error code means that enter_compiled_expression
+ {
+ /* This error code means that enter_compiled_expression
was called in a system without compiler support.
*/
+
execute_compiled_backout();
- Val = Make_Non_Pointer( TC_COMPILED_EXPRESSION,
+ Val = Make_Non_Pointer( TC_COMPILED_ENTRY,
Fetch_Expression());
Pop_Return_Error( Which_Way);
}
- case ERR_INAPPLICABLE_OBJECT:
- { /* This error code means that apply_compiled_procedure
+ case ERR_BAD_COMBINATION:
+ {
+ /* This error code means that apply_compiled_procedure
was called in a system without compiler support.
*/
+
apply_compiled_backout();
Apply_Error( Which_Way);
}
case ERR_INAPPLICABLE_CONTINUATION:
- { /* This error code means that return_to_compiled_code
+ {
+ /* This error code means that return_to_compiled_code
or some other compiler continuation was called in a
system without compiler support.
*/
+
Store_Expression(NIL);
Store_Return(RC_REENTER_COMPILED_CODE);
Pop_Return_Error(Which_Way);
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/purify.c,v 9.31 1988/02/20 06:18:49 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.32 1988/03/12 16:07:11 jinx Exp $
*
* This file contains the code that copies objects into pure
* and constant space.
extern void GCFlip(), GC();
extern Pointer *GCLoop();
\f
-/* This is a copy of GCLoop, with GC_Mode handling added, and
+/* This is a copy of GCLoop, with mode handling added, and
debugging printout removed.
*/
-#define Purify_Pointer(Code) \
-Old = Get_Pointer(Temp); \
-if ((GC_Mode == CONSTANT_COPY) && \
- (Old > Low_Constant)) \
- continue; \
-Code
+/* Purify modes */
-#define Setup_Pointer_for_Purify(Extra_Code) \
-Purify_Pointer(Setup_Pointer(false, Extra_Code))
+#define NORMAL_GC 0
+#define PURE_COPY 1
+#define CONSTANT_COPY 2
-#define Indirect_BH(In_GC) \
-if (Type_Code(*Old) == TC_BROKEN_HEART) continue;
+#define Purify_Pointer(Code) \
+{ \
+ Old = Get_Pointer(Temp); \
+ if ((GC_Mode == CONSTANT_COPY) && \
+ (Old > Low_Constant)) \
+ continue; \
+ Code; \
+}
+
+#define Setup_Pointer_for_Purify(Extra_Code) \
+{ \
+ Purify_Pointer(Setup_Pointer(false, Extra_Code)); \
+}
-#define Transport_Vector_Indirect() \
-Real_Transport_Vector(); \
-*Get_Pointer(Temp) = New_Address
+#define Indirect_BH(In_GC) \
+{ \
+ if (OBJECT_TYPE(*Old) == TC_BROKEN_HEART) \
+ continue; \
+}
+
+#define Transport_Vector_Indirect() \
+{ \
+ Real_Transport_Vector(); \
+ *Get_Pointer(Temp) = New_Address; \
+}
\f
Pointer *
PurifyLoop(Scan, To_Pointer, GC_Mode)
case_Non_Pointer:
break;
+\f
+ /* Compiled code relocation. */
- case_compiled_entry_point:
+ case TC_LINKAGE_SECTION:
+ {
if (GC_Mode == PURE_COPY)
+ {
+ gc_death(TERM_COMPILER_DEATH,
+ "purifyloop: linkage section in pure area",
+ Scan, To);
+ /*NOTREACHED*/
+ }
+ if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
+ {
+ /* Assumes that all others are objects of type TC_QUAD without
+ their type codes.
+ */
+
+ fast long count;
+
+ Scan++;
+ for (count = READ_CACHE_LINKAGE_COUNT(Temp);
+ --count >= 0;
+ Scan += 1)
+ {
+ Temp = *Scan;
+ Setup_Pointer_for_Purify(Transport_Quadruple());
+ }
+ Scan -= 1;
+ break;
+ }
+ else
+ {
+ fast long count;
+ fast machine_word *word_ptr;
+ Pointer *end_scan;
+
+ count = READ_OPERATOR_LINKAGE_COUNT(Temp);
+ word_ptr = FIRST_OPERATOR_LINKAGE_ENTRY(Scan);
+ end_scan = END_OPERATOR_LINKAGE_AREA(Scan, count);
+
+ while(--count >= 0)
+ {
+ Scan = ((Pointer *) word_ptr);
+ word_ptr = NEXT_LINKAGE_OPERATOR_ENTRY(word_ptr);
+ Temp = *Scan;
+ Purify_Pointer(Setup_Internal(false,
+ Transport_Compiled(),
+ Compiled_BH(false, continue)));
+ }
+ Scan = end_scan;
break;
- Purify_Pointer(Setup_Internal(false,
- Transport_Compiled(),
- Compiled_BH(false, continue)));
+ }
+ }
+\f
+ case TC_MANIFEST_CLOSURE:
+ {
+ machine_word *start_ptr;
+ fast machine_word *word_ptr;
+ Pointer *saved_scan;
- case_Cell:
- Setup_Pointer_for_Purify(Transport_Cell());
+ if (GC_Mode == PURE_COPY)
+ {
+ gc_death(TERM_COMPILER_DEATH,
+ "purifyloop: manifest closure in pure area",
+ Scan, To);
+ /*NOTREACHED*/
+ }
-/* PurifyLoop continues on the next page */
+ saved_scan = ++Scan;
+ word_ptr = FIRST_MANIFEST_CLOSURE_ENTRY(Scan);
+ start_ptr = word_ptr;
+
+ while (VALID_MANIFEST_CLOSURE_ENTRY(word_ptr))
+ {
+ Scan = MANIFEST_CLOSURE_ENTRY_ADDRESS(word_ptr);
+ word_ptr = NEXT_MANIFEST_CLOSURE_ENTRY(word_ptr);
+ Temp = *Scan;
+ Purify_Pointer(Setup_Internal(false,
+ Transport_Compiled(),
+ Compiled_BH(false, continue)));
+ }
+ Scan = saved_scan + MANIFEST_CLOSURE_SIZE(word_ptr, start_ptr);
+ break;
+ }
+
+ case_compiled_entry_point:
+ if (GC_Mode != PURE_COPY)
+ {
+ Purify_Pointer(Setup_Internal(false,
+ Transport_Compiled(),
+ Compiled_BH(false, continue)));
+ }
+ break;
\f
-/* PurifyLoop, continued */
+ case_Cell:
+ Setup_Pointer_for_Purify(Transport_Cell());
+ break;
/*
Symbols, variables, and reference traps cannot be put into
*/
case TC_REFERENCE_TRAP:
- if ((Datum(Temp) <= TRAP_MAX_IMMEDIATE) || (GC_Mode == PURE_COPY))
+ if ((OBJECT_DATUM(Temp) <= TRAP_MAX_IMMEDIATE) ||
+ (GC_Mode == PURE_COPY))
{
/* It is a non pointer. */
break;
Purify_Pointer(Setup_Internal(false,
Transport_Vector_Indirect(),
Indirect_BH(false)));
+ break;
}
+
/* Fall through */
+
case_Fasdump_Pair:
purify_pair:
Setup_Pointer_for_Purify(Transport_Pair());
+ break;
case TC_WEAK_CONS:
Setup_Pointer_for_Purify(Transport_Weak_Cons());
+ break;
case TC_VARIABLE:
case_Triple:
Setup_Pointer_for_Purify(Transport_Triple());
+ break;
/* PurifyLoop continues on the next page */
\f
case_Quadruple:
Setup_Pointer_for_Purify(Transport_Quadruple());
+ break;
/* No need to handle futures specially here, since PurifyLoop
is always invoked after running GCLoop, which will have
GC dameons spliced them, but this should not occur.
*/
- case TC_COMPILED_CODE_BLOCK:
case TC_FUTURE:
case TC_ENVIRONMENT:
+ case TC_COMPILED_CODE_BLOCK:
if (GC_Mode == PURE_COPY)
{
- /* This should actually do an indirect pair transport of
- the procedure, at least.
+ /* For environments, this should actually do an indirect pair
+ transport of the procedure, at least.
*/
break;
}
/* Fall through */
-#ifndef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- /* Fall through */
-#endif
+
case_Purify_Vector:
purify_vector:
Setup_Pointer_for_Purify(Transport_Vector());
+ break;
-#ifdef FLOATING_ALIGNMENT
case TC_BIG_FLONUM:
- Setup_Pointer_for_Purify(Transport_Flonum());
-#endif
+ Setup_Pointer_for_Purify({
+ Transport_Flonum();
+ break;
+ });
default:
sprintf(gc_death_message_buffer,
/*NOTREACHED*/
} /* Switch_by_GC_Type */
} /* For loop */
+
*To_Pointer = To;
return (To);
+
} /* PurifyLoop */
\f
/* Description of the algorithm for PURIFY:
*Free_Constant++ = Relocated_Object;
if (Purify_Object)
{
- Result = PurifyLoop(New_Object+1, &Free_Constant, PURE_COPY);
+ Result = PurifyLoop(New_Object + 1, &Free_Constant, PURE_COPY);
if (Free_Constant != Result)
{
Microcode_Termination(TERM_BROKEN_HEART);
}
}
- Recomputed_Length = (Free_Constant-New_Object)-4;
+ Recomputed_Length = ((Free_Constant - New_Object) - 4);
*Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *Free_Constant++ = Make_Non_Pointer(END_OF_BLOCK, Recomputed_Length+5);
+ *Free_Constant++ = Make_Non_Pointer(END_OF_BLOCK, (Recomputed_Length + 5));
if (Length > Recomputed_Length)
{
fprintf(stderr, "\nPurify phase error %x, %x\n",
}
*New_Object++ =
Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length);
- *New_Object = Make_Non_Pointer(PURE_PART, Recomputed_Length+5);
+ *New_Object = Make_Non_Pointer(PURE_PART, (Recomputed_Length + 5));
GC();
Set_Pure_Top();
- return TRUTH;
+ return (TRUTH);
}
\f
/* (PRIMITIVE-PURIFY OBJECT PURE?)
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.32 1987/11/17 08:15:51 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.33 1988/03/12 16:07:29 jinx Rel $ */
/* Pure/Constant space utilities. */
Update(From, To, Was, Will_Be)
fast Pointer *From, *To, *Was, *Will_Be;
{
+ fast long count;
+
for (; From < To; From++)
{
if (GC_Type_Special(*From))
{
- if (OBJECT_TYPE(*From) == TC_MANIFEST_NM_VECTOR)
- From += Get_Integer(*From);
- continue;
+ switch(OBJECT_TYPE(*From))
+ {
+ case TC_MANIFEST_NM_VECTOR:
+ From += OBJECT_DATUM(*From);
+ continue;
+
+ /* The following two type codes assume that none of the protected
+ objects can be updated.
+ This may be seriously wrong!
+ */
+ case TC_LINKAGE_SECTION:
+ if (READ_LINKAGE_KIND(*From) != OPERATOR_LINKAGE_KIND)
+ {
+ From += READ_CACHE_LINKAGE_COUNT(*From);
+ continue;
+ }
+ else
+ {
+ count = READ_OPERATOR_LINKAGE_COUNT(*From);
+ From = END_OPERATOR_LINKAGE_AREA(From, count);
+ continue;
+ }
+
+ case TC_MANIFEST_CLOSURE:
+ count = READ_OPERATOR_LINKAGE_COUNT(*From);
+ From = END_OPERATOR_LINKAGE_AREA(From, count);
+ continue;
+
+ default:
+ continue;
+ }
}
if (GC_Type_Non_Pointer(*From))
continue;
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_Non_Pointer:
- fprintf(stderr, "\nImpurify Non-Pointer.\n");
+ fprintf(stderr, "\nImpurify Non-Pointer (0x%lx)\n", Object);
Microcode_Termination(TERM_NON_POINTER_RELOCATION);
case TC_BIG_FLONUM:
Length = 1;
break;
+ case TC_LINKAGE_SECTION:
+ case TC_MANIFEST_CLOSURE:
+ case_compiled_entry_point:
default:
- fprintf(stderr, "\nImpurify: Bad type code = 0x%02x\n",
+ fprintf(stderr, "\nImpurify: Bad type code = 0x%02x.\n",
OBJECT_TYPE(Object));
Invalid_Type_Code();
}
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/returns.h,v 9.30 1988/02/06 20:41:26 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.31 1988/03/12 16:07:42 jinx Rel $
*
* Return codes. These are placed in Return when an
* interpreter operation needs to operate in several
#define RC_COMP_UNASSIGNED_P_RESTART 0x4D
#define RC_COMP_UNBOUND_P_RESTART 0x4E
#define RC_COMP_DEFINITION_RESTART 0x4F
-#define RC_COMP_LEXPR_INTERRUPT_RESTART 0x50
+/* formerly RC_COMP_LEXPR_INTERRUPT_RESTART 0x50 */
#define RC_COMP_SAFE_REFERENCE_RESTART 0x51
-#define RC_COMP_CACHE_LOOKUP_RESTART 0x52
+/* formerly RC_COMP_CACHE_LOOKUP_RESTART 0x52 */
#define RC_COMP_LOOKUP_TRAP_RESTART 0x53
#define RC_COMP_ASSIGNMENT_TRAP_RESTART 0x54
-#define RC_COMP_CACHE_OPERATOR_RESTART 0x55
+/* formerly RC_COMP_CACHE_OPERATOR_RESTART 0x55 */
#define RC_COMP_OP_REF_TRAP_RESTART 0x56
#define RC_COMP_CACHE_REF_APPLY_RESTART 0x57
#define RC_COMP_SAFE_REF_TRAP_RESTART 0x58
#define RC_COMP_UNASSIGNED_TRAP_RESTART 0x59
-#define RC_COMP_CACHE_ASSIGN_RESTART 0x5A
+/* formerly RC_COMP_CACHE_ASSIGN_RESTART 0x5A */
+#define RC_COMP_LINK_CACHES_RESTART 0x5B
/* When adding return codes, add them to the table below as well! */
-#define MAX_RETURN_CODE 0x5A
+#define MAX_RETURN_CODE 0x5B
\f
#define RETURN_NAME_TABLE \
{ \
/* 0x4D */ "COMPILER_UNASSIGNED_P_RESTART", \
/* 0x4E */ "COMPILER_UNBOUND_P_RESTART", \
/* 0x4F */ "COMPILER_DEFINITION_RESTART", \
-/* 0x50 */ "COMPILER_LEXPR_GC_RESTART", \
+/* 0x50 */ "", \
/* 0x51 */ "COMPILER_SAFE_REFERENCE_RESTART", \
-/* 0x52 */ "COMPILER_CACHE_LOOKUP_RESTART", \
+/* 0x52 */ "", \
/* 0x53 */ "COMPILER_LOOKUP_TRAP_RESTART", \
/* 0x54 */ "COMPILER_ASSIGNMENT_TRAP_RESTART", \
-/* 0x55 */ "COMPILER_CACHE_OPERATOR_RESTART", \
+/* 0X55 */ "", \
/* 0x56 */ "COMPILER_OPERATOR_REFERENCE_TRAP_RESTART", \
/* 0x57 */ "COMPILER_CACHE_REFERENCE_APPLY_RESTART", \
/* 0x58 */ "COMPILER_SAFE_REFERENCE_TRAP_RESTART", \
/* 0x59 */ "COMPILER_UNASSIGNED_P_TRAP_RESTART", \
-/* 0x5A */ "COMPILER_CACHE_ASSIGNMENT_RESTART" \
+/* 0x5A */ "", \
+/* 0x5A */ "COMPILER_LINK_CACHES_RESTART" \
}
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/types.h,v 9.27 1988/02/12 16:52:46 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.28 1988/03/12 16:07:56 jinx Rel $
*
* Type code definitions, numerical order
*
#define TC_VECTOR 0x0A
#define TC_RETURN_CODE 0x0B
#define TC_COMBINATION_2 0x0C
-#define TC_COMPILED_PROCEDURE 0x0D
+#define TC_MANIFEST_CLOSURE 0x0D
#define TC_BIG_FIXNUM 0x0E
#define TC_PROCEDURE 0x0F
#define TC_ENTITY 0x10 /* PRIMITIVE_EXTERNAL */
#define TC_IN_PACKAGE 0x25
#define TC_COMBINATION 0x26
#define TC_MANIFEST_NM_VECTOR 0x27
-#define TC_COMPILED_EXPRESSION 0x28
+#define TC_COMPILED_ENTRY 0x28
#define TC_LEXPR 0x29
#define TC_PCOMB3 0x2A
#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B
#define TC_CELL 0x36
#define TC_WEAK_CONS 0x37
#define TC_QUAD 0x38 /* TRAP */
-#define TC_RETURN_ADDRESS 0x39
+#define TC_LINKAGE_SECTION 0x39
#define TC_RATNUM 0x3A /* COMPILER_LINK */
#define TC_STACK_ENVIRONMENT 0x3B
#define TC_COMPLEX 0x3C
/* 0x0A */ "VECTOR", \
/* 0x0B */ "RETURN-CODE", \
/* 0x0C */ "COMBINATION-2", \
- /* 0x0D */ "COMPILED-PROCEDURE", \
+ /* 0x0D */ "MANIFEST-CLOSURE", \
/* 0x0E */ "BIG-FIXNUM", \
/* 0x0F */ "PROCEDURE", \
/* 0x10 */ "ENTITY", \
/* 0x25 */ "IN-PACKAGE", \
/* 0x26 */ "COMBINATION", \
/* 0x27 */ "MANIFEST-NM-VECTOR", \
- /* 0x28 */ "COMPILED-EXPRESSION", \
+ /* 0x28 */ "COMPILED-ENTRY", \
/* 0x29 */ "LEXPR", \
/* 0x2A */ "PCOMB3", \
/* 0x2B */ "MANIFEST-SPECIAL-NM-VECTOR", \
/* 0x36 */ "CELL", \
/* 0x37 */ "WEAK-CONS", \
/* 0x38 */ "QUAD", \
- /* 0x39 */ "RETURN-ADDRESS", \
+ /* 0x39 */ "LINKAGE-SECTION", \
/* 0x3A */ "RATNUM", \
/* 0x3B */ "STACK-ENVIRONMENT", \
/* 0x3C */ "COMPLEX", \
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.42 1988/02/12 16:53:42 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.43 1988/03/12 16:08:08 jinx Exp $
(declare (usual-integrations))
VECTOR ;0A
(RETURN-CODE RETURN-ADDRESS) ;0B
COMBINATION-2 ;0C
- COMPILED-PROCEDURE ;0D
+ MANIFEST-CLOSURE ;0D
(BIGNUM BIG-FIXNUM) ;0E
PROCEDURE ;0F
(ENTITY) ;10
IN-PACKAGE ;25
COMBINATION ;26
MANIFEST-NM-VECTOR ;27
- COMPILED-EXPRESSION ;28
+ COMPILED-ENTRY ;28
LEXPR ;29
PRIMITIVE-COMBINATION-3 ;2A
MANIFEST-SPECIAL-NM-VECTOR ;2B
CELL ;36
WEAK-CONS ;37
QUAD ;38
- COMPILER-RETURN-ADDRESS ;39
+ LINKAGE-SECTION ;39
RATNUM ;3A
STACK-ENVIRONMENT ;3B
(RECNUM COMPLEX) ;3C
COMPILER-UNASSIGNED?-RESTART ;4D
COMPILER-UNBOUND?-RESTART ;4E
COMPILER-DEFINITION-RESTART ;4F
- COMPILER-LEXPR-INTERRUPT-RESTART ;50
+ #F ;50
COMPILER-SAFE-REFERENCE-RESTART ;51
- COMPILER-CACHE-VARIABLE-RESTART ;52
+ #F ;52
COMPILER-REFERENCE-TRAP-RESTART ;53
COMPILER-ASSIGNMENT-TRAP-RESTART ;54
- COMPILER-UUO-LINK-RESTART ;55
- COMPILER-UUO-LINK-TRAP-RESTART ;56
- COMPILER-CACHE-REFERENCE-APPLY-RESTART ;57
+ #F ;55
+ COMPILER-OPERATOR-LOOKUP-TRAP-RESTART ;56
+ COMPILER-LOOKUP-APPLY-TRAP-RESTART ;57
COMPILER-SAFE-REFERENCE-TRAP-RESTART ;58
COMPILER-UNASSIGNED?-TRAP-RESTART ;59
- COMPILER-CACHE-ASSIGNMENT-RESTART ;5A
+ #F ;5A
+ COMPILER-LINK-CACHES-RESTART ;5B
))
\f
;;; [] Errors
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.42 1988/02/12 16:53:42 jinx Exp $"
\ No newline at end of file
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.43 1988/03/12 16:08:08 jinx Exp $"
\ No newline at end of file
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/utils.c,v 9.36 1987/12/04 22:20:24 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.37 1988/03/12 16:08:24 jinx Rel $ */
/* This file contains utilities for interrupts, errors, etc. */
primitive = Fetch_Expression();
nargs = PRIMITIVE_N_ARGUMENTS(primitive);
- if (OBJECT_TYPE(Stack_Ref(nargs)) == TC_RETURN_ADDRESS)
+ if (OBJECT_TYPE(Stack_Ref(nargs)) == TC_COMPILED_ENTRY)
{
compiler_apply_procedure(nargs);
}
signal_error_from_primitive (error_code)
long error_code;
{
-
PRIMITIVE_ABORT(error_code);
/*NOTREACHED*/
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.27 1988/02/29 01:33:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.28 1988/03/12 16:08:44 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 27
+#define SUBVERSION 28
#endif
#ifndef UCODE_TABLES_FILENAME
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.27 1988/02/06 20:39:40 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.28 1988/03/12 16:04:43 jinx Rel $
*
* Named constants used throughout the interpreter
*
#define PRIM_NO_TRAP_APPLY -6
#define PRIM_POP_RETURN -7
#define PRIM_TOUCH -8
+#define PRIM_APPLY_INTERRUPT -9
#define ABORT_NAME_TABLE \
{ \
/* -5 */ "NO-TRAP-EVAL", \
/* -6 */ "NO-TRAP_APPLY", \
/* -7 */ "POP-RETURN", \
- /* -8 */ "TOUCH" \
+ /* -8 */ "TOUCH", \
+ /* -9 */ "APPLY-INTERRUPT" \
}
/* Some numbers of parameters which mean something special */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.27 1988/02/12 16:51:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.28 1988/03/12 16:06:21 jinx Rel $
*
* This file contains the table which maps between Types and
* GC Types.
GC_Vector, /* TC_VECTOR */
GC_Non_Pointer, /* TC_RETURN_CODE */
GC_Triple, /* TC_COMBINATION_2 */
- GC_Pair, /* TC_COMPILED_PROCEDURE */
+ GC_Special, /* TC_MANIFEST_CLOSURE */
GC_Vector, /* TC_BIG_FIXNUM */
GC_Pair, /* TC_PROCEDURE */
GC_Pair, /* TC_ENTITY */
GC_Vector, /* TC_COMBINATION */
GC_Special, /* TC_MANIFEST_NM_VECTOR */
- GC_Compiled, /* TC_COMPILED_EXPRESSION */
+ GC_Compiled, /* TC_COMPILED_ENTRY */
GC_Pair, /* TC_LEXPR */
GC_Vector, /* TC_PCOMB3 */
GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */
GC_Cell, /* TC_CELL */
GC_Pair, /* TC_WEAK_CONS */
GC_Quadruple, /* TC_QUAD */
- GC_Compiled, /* TC_RETURN_ADDRESS */
+ GC_Special, /* TC_LINKAGE_SECTION */
GC_Pair, /* TC_RATNUM */
GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
GC_Pair, /* TC_COMPLEX */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.39 1988/02/20 06:18:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.40 1988/03/12 16:06:40 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
{
case PRIM_APPLY:
LOG_FUTURES();
+ case CODE_MAP(PRIM_APPLY):
goto Internal_Apply;
case PRIM_NO_TRAP_APPLY:
LOG_FUTURES();
+ case CODE_MAP(PRIM_NO_TRAP_APPLY):
goto Apply_Non_Trapping;
case PRIM_DO_EXPRESSION:
+ Val = Fetch_Expression();
LOG_FUTURES();
- Reduces_To(Fetch_Expression());
+ case CODE_MAP(PRIM_DO_EXPRESSION):
+ Reduces_To(Val);
case PRIM_NO_TRAP_EVAL:
+ Val = Fetch_Expression();
LOG_FUTURES();
- New_Reduction(Fetch_Expression(), Fetch_Env());
+ case CODE_MAP(PRIM_NO_TRAP_EVAL):
+ New_Reduction(Val, Fetch_Env());
goto Eval_Non_Trapping;
case 0: /* first time */
case PRIM_POP_RETURN:
LOG_FUTURES();
+ case CODE_MAP(PRIM_POP_RETURN):
goto Pop_Return;
\f
case PRIM_TOUCH:
+ {
+ Pointer temp;
+
+ temp = Val;
BACK_OUT_AFTER_PRIMITIVE();
+ Val = temp;
LOG_FUTURES();
/* fall through */
+ }
+
case CODE_MAP(PRIM_TOUCH):
TOUCH_SETUP(Val);
goto Internal_Apply;
case TC_CHARACTER_STRING:
case TC_CHARACTER:
case TC_COMPILED_CODE_BLOCK:
- case TC_COMPILED_PROCEDURE:
case TC_COMPLEX:
case TC_CONTROL_POINT:
case TC_DELAYED:
Save_Env();
Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed());
- case TC_COMPILED_EXPRESSION:
+ case TC_COMPILED_ENTRY:
{
Pointer compiled_expression;
define_compiler_restart (RC_COMP_INTERRUPT_RESTART,
comp_interrupt_restart)
- define_compiler_restart (RC_COMP_LEXPR_INTERRUPT_RESTART,
- comp_lexpr_interrupt_restart)
-
define_compiler_restart (RC_COMP_LOOKUP_APPLY_RESTART,
comp_lookup_apply_restart)
define_compiler_restart (RC_COMP_SAFE_REFERENCE_RESTART,
comp_safe_reference_restart)
- define_compiler_restart (RC_COMP_CACHE_LOOKUP_RESTART,
- comp_cache_lookup_restart)
-
define_compiler_restart (RC_COMP_LOOKUP_TRAP_RESTART,
comp_lookup_trap_restart)
- define_compiler_restart (RC_COMP_CACHE_ASSIGN_RESTART,
- comp_cache_assignment_restart)
-
define_compiler_restart (RC_COMP_ASSIGNMENT_TRAP_RESTART,
comp_assignment_trap_restart)
- define_compiler_restart (RC_COMP_CACHE_OPERATOR_RESTART,
- comp_cache_operator_restart)
-
define_compiler_restart (RC_COMP_OP_REF_TRAP_RESTART,
- comp_op_ref_trap_restart)
+ comp_op_lookup_trap_restart)
define_compiler_restart (RC_COMP_CACHE_REF_APPLY_RESTART,
- comp_cache_ref_apply_restart)
+ comp_cache_lookup_apply_restart)
define_compiler_restart (RC_COMP_SAFE_REF_TRAP_RESTART,
- comp_safe_ref_trap_restart)
+ comp_safe_lookup_trap_restart)
define_compiler_restart (RC_COMP_UNASSIGNED_TRAP_RESTART,
comp_unassigned_p_trap_restart)
+
+ define_compiler_restart (RC_COMP_LINK_CACHES_RESTART,
+ comp_link_caches_restart)
\f
case RC_REENTER_COMPILED_CODE:
compiled_code_restart();
Save_Cont(); \
}
-#define Apply_Error(N) \
-{ \
- Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
- Val = NIL; \
- Pop_Return_Error(N); \
+#define Apply_Error(N)
+{
+ Store_Return(RC_INTERNAL_APPLY);
+ Store_Expression(NIL);
+ Val = NIL;
+ Pop_Return_Error(N);
}
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
- case TC_COMPILED_PROCEDURE:
+ case TC_COMPILED_ENTRY:
{
apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
switch (Which_Way)
{
case PRIM_DONE:
- { compiled_code_done();
+ {
+ compiled_code_done();
goto Pop_Return;
}
case PRIM_APPLY:
- { compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
+ {
+ compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
goto Internal_Apply;
}
- case ERR_COMPILED_CODE_ERROR:
- { /* The compiled code is signalling a microcode error. */
- compiled_error_backout();
- /* The Save_Cont is done by Pop_Return_Error. */
- Pop_Return_Error( compiled_code_error_code);
- }
-
case PRIM_INTERRUPT:
{
compiled_error_backout();
Save_Cont();
Interrupt(PENDING_INTERRUPTS());
}
+
+
+ case PRIM_APPLY_INTERRUPT:
+ {
+ apply_compiled_backout();
+ Prepare_Apply_Interrupt();
+ Interrupt(PENDING_INTERRUPTS());
+ }
+
+ case ERR_COMPILED_CODE_ERROR:
+ {
+ /* The compiled code is signalling a microcode error. */
+ compiled_error_backout();
+ /* The Save_Cont is done by Pop_Return_Error. */
+ Pop_Return_Error( compiled_code_error_code);
+ }
\f
+ case ERR_INAPPLICABLE_OBJECT:
+ /* This error code means that apply_compiled_procedure
+ was called on an object which is not a compiled procedure.
+
+ Fall through...
+ */
+
case ERR_WRONG_NUMBER_OF_ARGUMENTS:
{
apply_compiled_backout();
}
\f
case ERR_EXECUTE_MANIFEST_VECTOR:
- { /* This error code means that enter_compiled_expression
+ {
+ /* This error code means that enter_compiled_expression
was called in a system without compiler support.
*/
+
execute_compiled_backout();
- Val = Make_Non_Pointer( TC_COMPILED_EXPRESSION,
+ Val = Make_Non_Pointer( TC_COMPILED_ENTRY,
Fetch_Expression());
Pop_Return_Error( Which_Way);
}
- case ERR_INAPPLICABLE_OBJECT:
- { /* This error code means that apply_compiled_procedure
+ case ERR_BAD_COMBINATION:
+ {
+ /* This error code means that apply_compiled_procedure
was called in a system without compiler support.
*/
+
apply_compiled_backout();
Apply_Error( Which_Way);
}
case ERR_INAPPLICABLE_CONTINUATION:
- { /* This error code means that return_to_compiled_code
+ {
+ /* This error code means that return_to_compiled_code
or some other compiler continuation was called in a
system without compiler support.
*/
+
Store_Expression(NIL);
Store_Return(RC_REENTER_COMPILED_CODE);
Pop_Return_Error(Which_Way);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.30 1988/02/06 20:41:26 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.31 1988/03/12 16:07:42 jinx Rel $
*
* Return codes. These are placed in Return when an
* interpreter operation needs to operate in several
#define RC_COMP_UNASSIGNED_P_RESTART 0x4D
#define RC_COMP_UNBOUND_P_RESTART 0x4E
#define RC_COMP_DEFINITION_RESTART 0x4F
-#define RC_COMP_LEXPR_INTERRUPT_RESTART 0x50
+/* formerly RC_COMP_LEXPR_INTERRUPT_RESTART 0x50 */
#define RC_COMP_SAFE_REFERENCE_RESTART 0x51
-#define RC_COMP_CACHE_LOOKUP_RESTART 0x52
+/* formerly RC_COMP_CACHE_LOOKUP_RESTART 0x52 */
#define RC_COMP_LOOKUP_TRAP_RESTART 0x53
#define RC_COMP_ASSIGNMENT_TRAP_RESTART 0x54
-#define RC_COMP_CACHE_OPERATOR_RESTART 0x55
+/* formerly RC_COMP_CACHE_OPERATOR_RESTART 0x55 */
#define RC_COMP_OP_REF_TRAP_RESTART 0x56
#define RC_COMP_CACHE_REF_APPLY_RESTART 0x57
#define RC_COMP_SAFE_REF_TRAP_RESTART 0x58
#define RC_COMP_UNASSIGNED_TRAP_RESTART 0x59
-#define RC_COMP_CACHE_ASSIGN_RESTART 0x5A
+/* formerly RC_COMP_CACHE_ASSIGN_RESTART 0x5A */
+#define RC_COMP_LINK_CACHES_RESTART 0x5B
/* When adding return codes, add them to the table below as well! */
-#define MAX_RETURN_CODE 0x5A
+#define MAX_RETURN_CODE 0x5B
\f
#define RETURN_NAME_TABLE \
{ \
/* 0x4D */ "COMPILER_UNASSIGNED_P_RESTART", \
/* 0x4E */ "COMPILER_UNBOUND_P_RESTART", \
/* 0x4F */ "COMPILER_DEFINITION_RESTART", \
-/* 0x50 */ "COMPILER_LEXPR_GC_RESTART", \
+/* 0x50 */ "", \
/* 0x51 */ "COMPILER_SAFE_REFERENCE_RESTART", \
-/* 0x52 */ "COMPILER_CACHE_LOOKUP_RESTART", \
+/* 0x52 */ "", \
/* 0x53 */ "COMPILER_LOOKUP_TRAP_RESTART", \
/* 0x54 */ "COMPILER_ASSIGNMENT_TRAP_RESTART", \
-/* 0x55 */ "COMPILER_CACHE_OPERATOR_RESTART", \
+/* 0X55 */ "", \
/* 0x56 */ "COMPILER_OPERATOR_REFERENCE_TRAP_RESTART", \
/* 0x57 */ "COMPILER_CACHE_REFERENCE_APPLY_RESTART", \
/* 0x58 */ "COMPILER_SAFE_REFERENCE_TRAP_RESTART", \
/* 0x59 */ "COMPILER_UNASSIGNED_P_TRAP_RESTART", \
-/* 0x5A */ "COMPILER_CACHE_ASSIGNMENT_RESTART" \
+/* 0x5A */ "", \
+/* 0x5A */ "COMPILER_LINK_CACHES_RESTART" \
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.27 1988/02/12 16:52:46 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.28 1988/03/12 16:07:56 jinx Rel $
*
* Type code definitions, numerical order
*
#define TC_VECTOR 0x0A
#define TC_RETURN_CODE 0x0B
#define TC_COMBINATION_2 0x0C
-#define TC_COMPILED_PROCEDURE 0x0D
+#define TC_MANIFEST_CLOSURE 0x0D
#define TC_BIG_FIXNUM 0x0E
#define TC_PROCEDURE 0x0F
#define TC_ENTITY 0x10 /* PRIMITIVE_EXTERNAL */
#define TC_IN_PACKAGE 0x25
#define TC_COMBINATION 0x26
#define TC_MANIFEST_NM_VECTOR 0x27
-#define TC_COMPILED_EXPRESSION 0x28
+#define TC_COMPILED_ENTRY 0x28
#define TC_LEXPR 0x29
#define TC_PCOMB3 0x2A
#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B
#define TC_CELL 0x36
#define TC_WEAK_CONS 0x37
#define TC_QUAD 0x38 /* TRAP */
-#define TC_RETURN_ADDRESS 0x39
+#define TC_LINKAGE_SECTION 0x39
#define TC_RATNUM 0x3A /* COMPILER_LINK */
#define TC_STACK_ENVIRONMENT 0x3B
#define TC_COMPLEX 0x3C
/* 0x0A */ "VECTOR", \
/* 0x0B */ "RETURN-CODE", \
/* 0x0C */ "COMBINATION-2", \
- /* 0x0D */ "COMPILED-PROCEDURE", \
+ /* 0x0D */ "MANIFEST-CLOSURE", \
/* 0x0E */ "BIG-FIXNUM", \
/* 0x0F */ "PROCEDURE", \
/* 0x10 */ "ENTITY", \
/* 0x25 */ "IN-PACKAGE", \
/* 0x26 */ "COMBINATION", \
/* 0x27 */ "MANIFEST-NM-VECTOR", \
- /* 0x28 */ "COMPILED-EXPRESSION", \
+ /* 0x28 */ "COMPILED-ENTRY", \
/* 0x29 */ "LEXPR", \
/* 0x2A */ "PCOMB3", \
/* 0x2B */ "MANIFEST-SPECIAL-NM-VECTOR", \
/* 0x36 */ "CELL", \
/* 0x37 */ "WEAK-CONS", \
/* 0x38 */ "QUAD", \
- /* 0x39 */ "RETURN-ADDRESS", \
+ /* 0x39 */ "LINKAGE-SECTION", \
/* 0x3A */ "RATNUM", \
/* 0x3B */ "STACK-ENVIRONMENT", \
/* 0x3C */ "COMPLEX", \
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.42 1988/02/12 16:53:42 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.43 1988/03/12 16:08:08 jinx Exp $
(declare (usual-integrations))
VECTOR ;0A
(RETURN-CODE RETURN-ADDRESS) ;0B
COMBINATION-2 ;0C
- COMPILED-PROCEDURE ;0D
+ MANIFEST-CLOSURE ;0D
(BIGNUM BIG-FIXNUM) ;0E
PROCEDURE ;0F
(ENTITY) ;10
IN-PACKAGE ;25
COMBINATION ;26
MANIFEST-NM-VECTOR ;27
- COMPILED-EXPRESSION ;28
+ COMPILED-ENTRY ;28
LEXPR ;29
PRIMITIVE-COMBINATION-3 ;2A
MANIFEST-SPECIAL-NM-VECTOR ;2B
CELL ;36
WEAK-CONS ;37
QUAD ;38
- COMPILER-RETURN-ADDRESS ;39
+ LINKAGE-SECTION ;39
RATNUM ;3A
STACK-ENVIRONMENT ;3B
(RECNUM COMPLEX) ;3C
COMPILER-UNASSIGNED?-RESTART ;4D
COMPILER-UNBOUND?-RESTART ;4E
COMPILER-DEFINITION-RESTART ;4F
- COMPILER-LEXPR-INTERRUPT-RESTART ;50
+ #F ;50
COMPILER-SAFE-REFERENCE-RESTART ;51
- COMPILER-CACHE-VARIABLE-RESTART ;52
+ #F ;52
COMPILER-REFERENCE-TRAP-RESTART ;53
COMPILER-ASSIGNMENT-TRAP-RESTART ;54
- COMPILER-UUO-LINK-RESTART ;55
- COMPILER-UUO-LINK-TRAP-RESTART ;56
- COMPILER-CACHE-REFERENCE-APPLY-RESTART ;57
+ #F ;55
+ COMPILER-OPERATOR-LOOKUP-TRAP-RESTART ;56
+ COMPILER-LOOKUP-APPLY-TRAP-RESTART ;57
COMPILER-SAFE-REFERENCE-TRAP-RESTART ;58
COMPILER-UNASSIGNED?-TRAP-RESTART ;59
- COMPILER-CACHE-ASSIGNMENT-RESTART ;5A
+ #F ;5A
+ COMPILER-LINK-CACHES-RESTART ;5B
))
\f
;;; [] Errors
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.42 1988/02/12 16:53:42 jinx Exp $"
\ No newline at end of file
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.43 1988/03/12 16:08:08 jinx Exp $"
\ No newline at end of file
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.27 1988/02/29 01:33:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.28 1988/03/12 16:08:44 jinx Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 27
+#define SUBVERSION 28
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff