- Tightening of the entry sequence.
- Closure generation by copying a pattern made by the compiler.
- Add ability to set breakpoints in closures' internal entry points.
- Add CLOSURE_PATTERN_LINKAGE_KIND used by the new patterns.
Align compiled code blocks on floating-point boundaries so that the
compiler can pad to guarantee that embedded floating-point numbers
(and closure patterns, copied using floating-point instructions on the
hppa) are aligned correctly.
/* -*-C-*-
-$Id: bchdmp.c,v 9.75 1993/11/09 08:33:14 gjr Exp $
+$Id: bchdmp.c,v 9.76 1993/12/07 20:35:50 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
Scan += (OBJECT_DATUM (Temp));
+area_skipped:
if (Scan < scan_buffer_top)
break;
else
break;
}
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
+ goto area_skipped;
+
default:
gc_death (TERM_EXIT,
"fasdump: Unknown compiler linkage kind.",
case_Quadruple:
fasdump_normal_pointer (copy_quadruple (), 4);
- case TC_BIG_FLONUM:
+ case_Aligned_Vector:
fasdump_flonum_setup ();
goto Move_Vector;
- case TC_COMPILED_CODE_BLOCK:
case_Purify_Vector:
fasdump_normal_setup ();
Move_Vector:
/* -*-C-*-
-$Id: bchgcc.h,v 9.56 1993/11/09 08:30:39 gjr Exp $
+$Id: bchgcc.h,v 9.57 1993/12/07 20:35:51 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
continue; \
Compiled_BH (in_gc_p, continue); \
{ \
- SCHEME_OBJECT *Saved_Old = Old; \
+ SCHEME_OBJECT * Saved_Old = Old; \
\
+ FLOAT_ALIGN_FREE (To_Address, To); \
New_Address = (MAKE_BROKEN_HEART (To_Address)); \
copy_vector (NULL); \
* Saved_Old = New_Address; \
continue; \
Compiled_BH (in_gc_p, continue); \
{ \
- SCHEME_OBJECT *Saved_Old = Old; \
+ SCHEME_OBJECT * Saved_Old = Old; \
\
+ FLOAT_ALIGN_FREE (To_Address, To); \
New_Address = (MAKE_BROKEN_HEART (To_Address)); \
copy_vector (NULL); \
* Saved_Old = New_Address; \
/* -*-C-*-
-$Id: bchgcl.c,v 9.48 1993/10/14 21:42:54 gjr Exp $
+$Id: bchgcl.c,v 9.49 1993/12/07 20:35:52 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
Scan += (OBJECT_DATUM (Temp));
+area_skipped:
if (Scan < scan_buffer_top)
break;
else
break;
}
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
+ goto area_skipped;
+
default:
gc_death (TERM_EXIT,
"GC: Unknown compiler linkage kind.",
case_Quadruple:
relocate_normal_pointer (copy_quadruple (), 4);
- case TC_BIG_FLONUM:
+ case_Aligned_Vector:
relocate_flonum_setup ();
goto Move_Vector;
/* -*-C-*-
-$Id: bchpur.c,v 9.63 1993/10/14 21:41:29 gjr Exp $
+$Id: bchpur.c,v 9.64 1993/12/07 20:35:53 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
Scan += (OBJECT_DATUM (Temp));
+area_skipped:
if (Scan < scan_buffer_top)
break;
else
break;
}
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
+ goto area_skipped;
+
default:
gc_death (TERM_EXIT,
"purify: Unknown compiler linkage kind.",
break;
relocate_normal_pointer (copy_quadruple(), 4);
\f
+ case TC_COMPILED_CODE_BLOCK:
+ if (purify_mode == PURE_COPY)
+ break;
+ goto aligned_vector_relocation;
+
case TC_BIG_FLONUM:
if (purify_mode == CONSTANT_COPY)
break;
+ aligned_vector_relocation:
relocate_flonum_setup ();
goto Move_Vector;
- case TC_COMPILED_CODE_BLOCK:
case TC_ENVIRONMENT:
if (purify_mode == PURE_COPY)
break;
/* -*-C-*-
-$Id: cmpgc.h,v 1.26 1993/11/22 00:33:04 gjr Exp $
+$Id: cmpgc.h,v 1.27 1993/12/07 20:35:54 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
#ifndef CMPGC_H_INCLUDED
#define CMPGC_H_INCLUDED
-
+\f
#define NOP() do {} while (0) /* A useful macro */
/* These are needed whether or not there is a compiler,
#define REFERENCE_LINKAGE_KIND 0x010000
#define ASSIGNMENT_LINKAGE_KIND 0x020000
#define GLOBAL_OPERATOR_LINKAGE_KIND 0x030000
+#define CLOSURE_PATTERN_LINKAGE_KIND 0x040000
#ifdef HAS_COMPILER_SUPPORT
/* -*-C-*-
-$Id: cmpint.c,v 1.80 1993/11/16 03:56:41 gjr Exp $
+$Id: cmpint.c,v 1.81 1993/12/07 20:35:55 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
/* Imports from the rest of the "microcode" */
extern long
- EXFUN (compiler_cache_operator, (void)),
- EXFUN (compiler_cache_global_operator, (void)),
- EXFUN (compiler_cache_lookup, (void)),
- EXFUN (compiler_cache_assignment, (void));
+ EXFUN (compiler_cache_assignment, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
+ EXFUN (compiler_cache_lookup, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
+ EXFUN (compiler_cache_global_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
+ EXFUN (compiler_cache_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long));
\f
/* Exports to the rest of the "microcode" */
#define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED
+/* Ways to bypass the interpreter */
+
#define REFLECT_CODE_INTERNAL_APPLY 0
#define REFLECT_CODE_RESTORE_INTERRUPT_MASK 1
#define REFLECT_CODE_STACK_MARKER 2
#define REFLECT_CODE_CC_BKPT 3
+
+/* Markers for special entry points */
+
+#ifndef FORMAT_BYTE_EXPR
+#define FORMAT_BYTE_EXPR 0xFF
+#endif
+#ifndef FORMAT_BYTE_COMPLR
+#define FORMAT_BYTE_COMPLR 0xFE
+#endif
+#ifndef FORMAT_BYTE_CMPINT
+#define FORMAT_BYTE_CMPINT 0xFD
+#endif
+#ifndef FORMAT_BYTE_DLINK
+#define FORMAT_BYTE_DLINK 0xFC
+#endif
+#ifndef FORMAT_BYTE_RETURN
+#define FORMAT_BYTE_RETURN 0xFB
+#endif
+#ifndef FORMAT_BYTE_CLOSURE
+#define FORMAT_BYTE_CLOSURE 0xFA
+#endif
+#ifndef FORMAT_BYTE_FRAMEMAX
+#define FORMAT_BYTE_FRAMEMAX 0x7F
+#endif
+
+#ifndef FORMAT_WORD_EXPR
+#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_EXPR))
+#endif
+#ifndef FORMAT_WORD_CMPINT
+#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CMPINT))
+#endif
+#ifndef FORMAT_WORD_RETURN
+#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_RETURN))
+#endif
\f
/* Utilities for application of compiled procedures. */
compiled_entry_address =
((instruction *) (OBJECT_ADDRESS (Fetch_Expression ())));
if ((COMPILED_ENTRY_FORMAT_WORD (compiled_entry_address)) !=
- (FORMAT_WORD_EXPR))
+ FORMAT_WORD_EXPR)
{
/* It self evaluates. */
Val = (Fetch_Expression ());
entry_address);
}
\f
-/* Core of comutil_link and comp_link_caches_restart. */
+static long
+DEFUN (compiler_link_closure_pattern, (distance, block, offset),
+ SCHEME_OBJECT distance AND SCHEME_OBJECT block AND long offset)
+{
+ long objdist = (FIXNUM_TO_LONG (distance));
+ long nmv_length = (OBJECT_DATUM (MEMORY_REF (block, 1)));
+ SCHEME_OBJECT * location = (MEMORY_LOC (block, offset));
+ SCHEME_OBJECT * closptr = (location - objdist);
+ SCHEME_OBJECT * end_closptr = (MEMORY_LOC (block, (2 + nmv_length)));
+ SCHEME_OBJECT entry_offset, * area_end;
+ char * word_ptr;
+ long count;
+
+ nmv_length -= (end_closptr - closptr);
+ while (closptr < end_closptr)
+ {
+ while ((* closptr) == ((SCHEME_OBJECT) 0))
+ closptr ++;
+ closptr ++;
+ count = (MANIFEST_CLOSURE_COUNT (closptr));
+ word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (closptr));
+ area_end = (MANIFEST_CLOSURE_END (closptr, count));
+ while ((--count) >= 0)
+ {
+ closptr = ((SCHEME_OBJECT *) word_ptr);
+ word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr);
+ entry_offset = ((SCHEME_OBJECT)
+ (((long) closptr) - ((long) entry_offset)));
+ STORE_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr);
+ }
+ closptr = &area_end[1];
+ }
+
+ MEMORY_SET (block, 1, (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length)));
+ return (PRIM_DONE);
+}
static Boolean linking_cc_block_p = false;
return;
}
+/* Core of comutil_link and comp_link_caches_restart. */
+
static long
DEFUN (link_cc_block,
(block_address, offset, last_header_offset,
SCHEME_OBJECT block;
SCHEME_OBJECT header;
long result, kind, total_count;
- long (*cache_handler)();
+ long EXFUN ((* cache_handler), (SCHEME_OBJECT, SCHEME_OBJECT, long));
transaction_begin ();
{
transaction_record_action (tat_abort, abort_link_cc_block, ap);
}
linking_cc_block_p = true;
-
+\f
result = PRIM_DONE;
block = (MAKE_CC_BLOCK (block_address));
cache_handler = compiler_cache_global_operator;
goto handle_operator;
+ case ASSIGNMENT_LINKAGE_KIND:
+ cache_handler = compiler_cache_assignment;
+ goto handle_reference;
+
case REFERENCE_LINKAGE_KIND:
cache_handler = compiler_cache_lookup;
handle_reference:
count = (READ_CACHE_LINKAGE_COUNT (header));
break;
- case ASSIGNMENT_LINKAGE_KIND:
- cache_handler = compiler_cache_assignment;
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ cache_handler = compiler_link_closure_pattern;
+ /* Not really a reference, but the same format. */
goto handle_reference;
default:
(MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
for (offset += 1; ((--count) >= 0); offset += entry_size)
{
- SCHEME_OBJECT name;
+ SCHEME_OBJECT info; /* A symbol or a fixnum */
- if (!execute_p)
- name = (block_address[offset]);
+ if (! execute_p)
+ info = (block_address[offset]);
else
- EXTRACT_EXECUTE_CACHE_SYMBOL(name, &(block_address[offset]));
+ EXTRACT_EXECUTE_CACHE_SYMBOL (info, &(block_address[offset]));
- result = ((*cache_handler)(name, block, offset));
+ result = ((* cache_handler) (info, block, offset));
if (result != PRIM_DONE)
{
/* Save enough state to continue.
#define CONTINUATION_DYNAMIC_LINK 1
#define CONTINUATION_RETURN_TO_INTERPRETER 2
+/* Other subtypes */
+
+#define OTHER_CLOSURE 0
+#define OTHER_RANDOM 1
+
C_UTILITY void
DEFUN (compiled_entry_type,
(entry, buffer),
kind = KIND_CONTINUATION;
field1 = CONTINUATION_NORMAL;
- field2 = (((((unsigned long) max_arity) & 0x3f) << 7) |
- (((unsigned long) min_arity) & 0x7f));
+ field2 = (((((unsigned long) max_arity) & 0x3f) << 7)
+ | (((unsigned long) min_arity) & 0x7f));
}
- else if (min_arity != (-1))
+ else if (min_arity != -1)
kind = KIND_ILLEGAL;
\f
else
kind = KIND_EXPRESSION;
break;
}
+ case FORMAT_BYTE_CLOSURE:
+ {
+ kind = KIND_OTHER;
+ field1 = OTHER_CLOSURE;
+ break;
+ }
case FORMAT_BYTE_COMPLR:
case FORMAT_BYTE_CMPINT:
{
kind = KIND_OTHER;
+ field1 = OTHER_RANDOM;
break;
}
case FORMAT_BYTE_DLINK:
\f
SCHEME_UTILITY utility_result
DEFUN (comutil_compiled_code_bkpt,
- (entry_point_raw, dlink_raw, ignore_3, ignore_4),
- SCHEME_ADDR entry_point_raw AND SCHEME_ADDR dlink_raw
+ (entry_point_raw, state_raw, ignore_3, ignore_4),
+ SCHEME_ADDR entry_point_raw AND SCHEME_ADDR state_raw
AND long ignore_3 AND long ignore_4)
{
long type_info[3];
*/
compiled_entry_type (entry_point, &type_info[0]);
- if (type_info[0] != KIND_CONTINUATION)
+ if ((type_info[0] == KIND_OTHER) && (type_info[1] == OTHER_CLOSURE))
+ {
+ entry_point_a = ((instruction *) (SCHEME_ADDR_TO_ADDR (state_raw)));
+ state = (ENTRY_TO_OBJECT (entry_point_a));
+ }
+ else if (type_info[0] != KIND_CONTINUATION)
state = SHARP_F;
else if (type_info[1] == CONTINUATION_DYNAMIC_LINK)
state = (MAKE_POINTER_OBJECT
- (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (dlink_raw))));
+ (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (state_raw))));
else
state = Val;
/* -*-C-*-
-$Id: dostrap.c,v 1.5 1993/10/14 19:21:13 gjr Exp $
+$Id: dostrap.c,v 1.6 1993/12/07 20:35:57 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
{
switch (READ_LINKAGE_KIND (object))
{
- case OPERATOR_LINKAGE_KIND:
case GLOBAL_OPERATOR_LINKAGE_KIND:
+ case OPERATOR_LINKAGE_KIND:
{
long count = (READ_OPERATOR_LINKAGE_COUNT (object));
area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
#else
/* Fall through, no reason to crash here. */
#endif
- case REFERENCE_LINKAGE_KIND:
case ASSIGNMENT_LINKAGE_KIND:
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ case REFERENCE_LINKAGE_KIND:
area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
break;
/* -*-C-*-
-$Id: fasdump.c,v 9.59 1993/11/09 08:32:41 gjr Exp $
+$Id: fasdump.c,v 9.60 1993/12/07 20:35:58 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
*/
#define Setup_Pointer_for_Dump(Extra_Code) \
- Dump_Pointer (Fasdump_Setup_Pointer (Extra_Code, Normal_BH (false, continue)))
+ Dump_Pointer (Fasdump_Setup_Pointer (Extra_Code, \
+ Normal_BH (false, continue)))
#define Dump_Pointer(Code) \
Old = (OBJECT_ADDRESS (Temp)); \
#define Fasdump_Transport_Compiled() \
{ \
- Transport_Compiled(); \
+ Transport_Compiled (); \
if ((mode == 2) && ((OBJECT_TYPE (*(To - 1))) == TC_ENVIRONMENT)) \
*(To - 1) = SHARP_F; \
}
#define Dump_Compiled_Entry(label) \
{ \
Dump_Pointer \
- (Fasdump_Setup_Pointer (Fasdump_Transport_Compiled (), \
+ (Fasdump_Setup_Aligned (Fasdump_Transport_Compiled (), \
Compiled_BH (false, goto label))); \
}
#define DUMP_RAW_COMPILED_ENTRY(label) \
{ \
DUMP_RAW_POINTER \
- (Fasdump_Setup_Pointer (FASDUMP_TRANSPORT_RAW_COMPILED (), \
+ (Fasdump_Setup_Aligned (FASDUMP_TRANSPORT_RAW_COMPILED (), \
RAW_COMPILED_BH (false, \
goto label))); \
}
break;
case TC_BROKEN_HEART:
- if (OBJECT_DATUM (Temp) != 0)
+ if ((OBJECT_DATUM (Temp)) != 0)
{
sprintf (gc_death_message_buffer,
"dumploop: broken heart (0x%lx) in scan",
word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
- while(--count >= 0)
+ while (--count >= 0)
{
Scan = ((SCHEME_OBJECT *) (word_ptr));
word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
break;
}
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
+ break;
+
default:
{
gc_death (TERM_EXIT,
Setup_Pointer_for_Dump (Transport_Quadruple ());
break;
- case TC_BIG_FLONUM:
- Setup_Pointer_for_Dump({
- Transport_Flonum ();
- break;
- });
+ case_Aligned_Vector:
+ Dump_Pointer (Fasdump_Setup_Aligned (goto Move_Vector,
+ Normal_BH (false, continue)));
+ break;
- case TC_COMPILED_CODE_BLOCK:
case_Purify_Vector:
process_vector:
Setup_Pointer_for_Dump (Transport_Vector ());
/* -*-C-*-
-$Id: fasload.c,v 9.78 1993/11/09 08:34:16 gjr Exp $
+$Id: fasload.c,v 9.79 1993/12/07 20:35:59 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
if (Reloc_Debug)
{
- outf_error (
- "\nRelocate_Block: block = 0x%lx, length = 0x%lx, end = 0x%lx.\n",
- ((long) Scan), ((long) ((Stop_At - Scan) - 1)), ((long) Stop_At));
+ outf_error
+ ("\nRelocate_Block: block = 0x%lx, length = 0x%lx, end = 0x%lx.\n",
+ ((long) Scan), ((long) ((Stop_At - Scan) - 1)), ((long) Stop_At));
}
while (Scan < Stop_At)
{
- Temp = *Scan;
+ Temp = * Scan;
Switch_by_GC_Type (Temp)
{
case TC_BROKEN_HEART:
\f
case TC_LINKAGE_SECTION:
{
- switch (READ_LINKAGE_KIND(Temp))
+ switch (READ_LINKAGE_KIND (Temp))
{
case REFERENCE_LINKAGE_KIND:
case ASSIGNMENT_LINKAGE_KIND:
case GLOBAL_OPERATOR_LINKAGE_KIND:
{
fast long count;
- fast char *word_ptr;
- SCHEME_OBJECT *end_scan;
+ fast char * word_ptr;
+ SCHEME_OBJECT * end_scan;
START_OPERATOR_RELOCATION (Scan);
count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
break;
}
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ Scan += (1 + (READ_CACHE_LINKAGE_COUNT (Temp)));
+ break;
+
default:
{
gc_death (TERM_EXIT,
/* See comment about relocation in TC_LINKAGE_SECTION above. */
fast long count;
- fast char *word_ptr;
- SCHEME_OBJECT *area_end;
+ fast char * word_ptr;
+ SCHEME_OBJECT * area_end;
START_CLOSURE_RELOCATION (Scan);
Scan += 1;
/* -*-C-*-
-$Id: gccode.h,v 9.52 1993/10/14 19:21:29 gjr Exp $
+$Id: gccode.h,v 9.53 1993/12/07 20:36:00 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
first Switch_by_GC_Type, then each of the case_ macros (in any
order). The default: case MUST be included in the switch. */
-#define Switch_by_GC_Type(P) \
+#define Switch_by_GC_Type(P) \
switch (OBJECT_TYPE (P))
-#define case_simple_Non_Pointer \
- case TC_NULL: \
- case TC_TRUE: \
- case TC_RETURN_CODE: \
+#define case_simple_Non_Pointer \
+ case TC_NULL: \
+ case TC_TRUE: \
+ case TC_RETURN_CODE: \
case TC_THE_ENVIRONMENT
-#define case_Fasload_Non_Pointer \
- case TC_FIXNUM: \
- case TC_CHARACTER: \
+#define case_Fasload_Non_Pointer \
+ case TC_FIXNUM: \
+ case TC_CHARACTER: \
case_simple_Non_Pointer
-#define case_Non_Pointer \
- case TC_PRIMITIVE: \
- case TC_PCOMB0: \
- case TC_STACK_ENVIRONMENT: \
+#define case_Non_Pointer \
+ case TC_PRIMITIVE: \
+ case TC_PCOMB0: \
+ case TC_STACK_ENVIRONMENT: \
case_Fasload_Non_Pointer
/* Missing Non Pointer types (must always be treated specially):
TC_MANIFEST_SPECIAL_NM_VECTOR
TC_REFERENCE_TRAP
TC_MANIFEST_CLOSURE
- TC_LINKAGE_SECTION */
+ TC_LINKAGE_SECTION
+ */
-#define case_compiled_entry_point \
+#define case_compiled_entry_point \
case TC_COMPILED_ENTRY
-#define case_Cell \
+#define case_Cell \
case TC_CELL
/* No missing Cell types */
\f
-#define case_Fasdump_Pair \
- case TC_LIST: \
- case TC_SCODE_QUOTE: \
- case TC_COMBINATION_1: \
- case TC_EXTENDED_PROCEDURE: \
- case TC_PROCEDURE: \
- case TC_DELAY: \
- case TC_DELAYED: \
- case TC_COMMENT: \
- case TC_LAMBDA: \
- case TC_SEQUENCE_2: \
- case TC_PCOMB1: \
- case TC_ACCESS: \
- case TC_DEFINITION: \
- case TC_ASSIGNMENT: \
- case TC_IN_PACKAGE: \
- case TC_LEXPR: \
- case TC_DISJUNCTION: \
- case TC_COMPLEX: \
- case TC_ENTITY: \
+#define case_Fasdump_Pair \
+ case TC_LIST: \
+ case TC_SCODE_QUOTE: \
+ case TC_COMBINATION_1: \
+ case TC_EXTENDED_PROCEDURE: \
+ case TC_PROCEDURE: \
+ case TC_DELAY: \
+ case TC_DELAYED: \
+ case TC_COMMENT: \
+ case TC_LAMBDA: \
+ case TC_SEQUENCE_2: \
+ case TC_PCOMB1: \
+ case TC_ACCESS: \
+ case TC_DEFINITION: \
+ case TC_ASSIGNMENT: \
+ case TC_IN_PACKAGE: \
+ case TC_LEXPR: \
+ case TC_DISJUNCTION: \
+ case TC_COMPLEX: \
+ case TC_ENTITY: \
case TC_RATNUM
-#define case_Pair \
- case TC_INTERNED_SYMBOL: \
- case TC_UNINTERNED_SYMBOL: \
+#define case_Pair \
+ case TC_INTERNED_SYMBOL: \
+ case TC_UNINTERNED_SYMBOL: \
case_Fasdump_Pair
/* Missing pair types (must be treated specially):
- TC_WEAK_CONS */
-
-#define case_Triple \
- case TC_COMBINATION_2: \
- case TC_EXTENDED_LAMBDA: \
- case TC_HUNK3_A: \
- case TC_HUNK3_B: \
- case TC_CONDITIONAL: \
- case TC_SEQUENCE_3: \
+ TC_WEAK_CONS
+ */
+
+#define case_Triple \
+ case TC_COMBINATION_2: \
+ case TC_EXTENDED_LAMBDA: \
+ case TC_HUNK3_A: \
+ case TC_HUNK3_B: \
+ case TC_CONDITIONAL: \
+ case TC_SEQUENCE_3: \
case TC_PCOMB2
/* Missing triple types (must be treated specially):
TC_VARIABLE */
\f
-#define case_Quadruple \
+#define case_Quadruple \
case TC_QUAD
/* No missing quad types. */
-#define case_simple_Vector \
- case TC_NON_MARKED_VECTOR: \
- case TC_VECTOR: \
- case TC_RECORD: \
- case TC_CONTROL_POINT: \
- case TC_COMBINATION: \
- case TC_PCOMB3: \
- case TC_VECTOR_1B: \
+#define case_simple_Vector \
+ case TC_NON_MARKED_VECTOR: \
+ case TC_VECTOR: \
+ case TC_RECORD: \
+ case TC_CONTROL_POINT: \
+ case TC_COMBINATION: \
+ case TC_PCOMB3: \
+ case TC_VECTOR_1B: \
case TC_VECTOR_16B
-#define case_Purify_Vector \
- case TC_BIG_FIXNUM: \
- case TC_CHARACTER_STRING: \
+#define case_Purify_Vector \
+ case TC_BIG_FIXNUM: \
+ case TC_CHARACTER_STRING: \
case_simple_Vector
-#define case_Vector \
- case TC_ENVIRONMENT: \
- case TC_COMPILED_CODE_BLOCK: \
+#define case_Vector \
+ case TC_ENVIRONMENT: \
case_Purify_Vector
+#define case_Aligned_Vector \
+ case TC_COMPILED_CODE_BLOCK: \
+ case TC_BIG_FLONUM
+
/* Missing vector types (must be treated specially):
- TC_FUTURE
- TC_BIG_FLONUM */
+ TC_FUTURE
+ */
\f
extern char gc_death_message_buffer [];
Transport_Code; \
}
+#define Setup_Aligned(In_GC, Transport_Code, Already_Relocated_Code) \
+{ \
+ GC_Consistency_Check (In_GC); \
+ if (Old < low_heap) \
+ continue; \
+ Already_Relocated_Code; \
+ ALIGN_FLOAT (To); \
+ New_Address = (MAKE_BROKEN_HEART (To)); \
+ Transport_Code; \
+}
+
#define Setup_Pointer(In_GC, Transport_Code) \
{ \
Setup_Internal (In_GC, Transport_Code, Normal_BH (In_GC, continue)); \
TRANSPORT_ONE_THING ((*To++) = (*Old++)); \
Scan = Saved_Scan; \
}
-
+\f
#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() \
+#define Transport_Vector() \
{ \
- ALIGN_FLOAT (To); \
- New_Address = (MAKE_BROKEN_HEART (To)); \
+Move_Vector: \
Real_Transport_Vector (); \
Pointer_End (); \
}
-#else
-
-#define Transport_Flonum() \
-{ \
- goto Move_Vector; \
-}
-
-#endif
-
#define Transport_Future() \
{ \
if (! (Future_Spliceable (Temp))) \
Extra_Code; \
}
+#define Fasdump_Setup_Aligned(Extra_Code, BH_Code) \
+{ \
+ BH_Code; \
+ \
+ /* It must be transported to New Space */ \
+ \
+ ALIGN_FLOAT (To); \
+ New_Address = (MAKE_BROKEN_HEART (To)); \
+ if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
+ { \
+ NewFree = To; \
+ Fixup = Fixes; \
+ return (PRIM_INTERRUPT); \
+ } \
+ (*--Fixes) = (* Old); \
+ (*--Fixes) = (ADDRESS_TO_DATUM (Old)); \
+ Extra_Code; \
+}
+
/* Undefine Symbols */
#define Fasdump_Symbol(global_value) \
{ \
- (*To++) = (*Old); \
+ (*To++) = (* Old); \
(*To++) = global_value; \
Pointer_End (); \
}
#define Fasdump_Variable() \
{ \
- (*To++) = (*Old); \
+ (*To++) = (* Old); \
(*To++) = UNCOMPILED_VARIABLE; \
(*To++) = SHARP_F; \
Pointer_End (); \
/* -*-C-*-
-$Id: gcloop.c,v 9.44 1993/11/09 08:31:48 gjr Exp $
+$Id: gcloop.c,v 9.45 1993/12/07 20:36:01 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
#ifdef ENABLE_GC_DEBUGGING_TOOLS
object_referencing = Temp;
#endif
- HANDLE_GC_TRAP();
+ HANDLE_GC_TRAP ();
- Switch_by_GC_Type(Temp)
+ Switch_by_GC_Type (Temp)
{
case TC_BROKEN_HEART:
if (Scan == (OBJECT_ADDRESS (Temp)))
*To_Pointer = To;
return (Scan);
}
- sprintf(gc_death_message_buffer,
- "gcloop: broken heart (0x%lx) in scan",
- Temp);
- gc_death(TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
+ sprintf (gc_death_message_buffer,
+ "gcloop: broken heart (0x%lx) in scan",
+ Temp);
+ gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
/*NOTREACHED*/
case TC_MANIFEST_NM_VECTOR:
case GLOBAL_OPERATOR_LINKAGE_KIND:
{
fast long count;
- fast char *word_ptr;
- SCHEME_OBJECT *end_scan;
+ fast char * word_ptr;
+ SCHEME_OBJECT * end_scan;
START_OPERATOR_RELOCATION (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)
+ while (--count >= 0)
{
Scan = ((SCHEME_OBJECT *) word_ptr);
word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
- GC_RAW_POINTER (Setup_Internal
+ GC_RAW_POINTER (Setup_Aligned
(true,
TRANSPORT_RAW_COMPILED (),
RAW_COMPILED_BH (true,
break;
}
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
+ break;
+
default:
{
gc_death (TERM_EXIT,
case TC_MANIFEST_CLOSURE:
{
fast long count;
- fast char *word_ptr;
- SCHEME_OBJECT *area_end;
+ fast char * word_ptr;
+ SCHEME_OBJECT * area_end;
START_CLOSURE_RELOCATION (Scan);
Scan += 1;
Scan = ((SCHEME_OBJECT *) (word_ptr));
word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
- GC_RAW_POINTER (Setup_Internal
+ GC_RAW_POINTER (Setup_Aligned
(true,
TRANSPORT_RAW_COMPILED (),
RAW_COMPILED_BH (true,
}
case_compiled_entry_point:
- GC_Pointer(Setup_Internal(true,
- Transport_Compiled(),
- Compiled_BH(true, goto after_entry)));
+ GC_Pointer (Setup_Aligned (true,
+ Transport_Compiled (),
+ Compiled_BH (true, goto after_entry)));
after_entry:
*Scan = Temp;
break;
break;
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
+ if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
{
/* It is a non pointer. */
break;
/* Fall Through. */
case_Pair:
- Setup_Pointer_for_GC(Transport_Pair());
+ Setup_Pointer_for_GC (Transport_Pair ());
break;
\f
case TC_VARIABLE:
case_Triple:
- Setup_Pointer_for_GC(Transport_Triple());
+ Setup_Pointer_for_GC (Transport_Triple ());
break;
case_Quadruple:
- Setup_Pointer_for_GC(Transport_Quadruple());
+ Setup_Pointer_for_GC (Transport_Quadruple ());
break;
- case TC_BIG_FLONUM:
- Setup_Pointer_for_GC({
- Transport_Flonum();
- break;
- });
+ case_Aligned_Vector:
+ GC_Pointer (Setup_Aligned (true,
+ goto Move_Vector,
+ Normal_BH (true, continue)));
+ break;
case_Vector:
- Setup_Pointer_for_GC(Transport_Vector());
+ Setup_Pointer_for_GC (Transport_Vector ());
break;
case TC_FUTURE:
- Setup_Pointer_for_GC(Transport_Future());
+ Setup_Pointer_for_GC (Transport_Future ());
break;
case TC_WEAK_CONS:
- Setup_Pointer_for_GC(Transport_Weak_Cons());
+ Setup_Pointer_for_GC (Transport_Weak_Cons ());
break;
default:
- GC_BAD_TYPE("gcloop");
+ GC_BAD_TYPE ("gcloop");
/* Fall Through */
case_Non_Pointer:
/* -*-C-*-
-$Id: nttrap.c,v 1.9 1993/10/14 19:11:56 gjr Exp $
+$Id: nttrap.c,v 1.10 1993/12/07 20:36:02 gjr Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
{
switch (READ_LINKAGE_KIND (object))
{
- case OPERATOR_LINKAGE_KIND:
case GLOBAL_OPERATOR_LINKAGE_KIND:
+ case OPERATOR_LINKAGE_KIND:
{
long count = (READ_OPERATOR_LINKAGE_COUNT (object));
area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
#else
/* Fall through, no reason to crash here. */
#endif
- case REFERENCE_LINKAGE_KIND:
case ASSIGNMENT_LINKAGE_KIND:
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ case REFERENCE_LINKAGE_KIND:
area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
break;
/* -*-C-*-
-$Id: purify.c,v 9.53 1993/11/09 08:32:15 gjr Exp $
+$Id: purify.c,v 9.54 1993/12/07 20:36:03 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
#define Purify_Pointer(Code) \
{ \
Old = (OBJECT_ADDRESS (Temp)); \
- if ((GC_Mode == CONSTANT_COPY) && \
- (Old < low_heap)) \
+ if ((GC_Mode == CONSTANT_COPY) \
+ && (Old < low_heap)) \
continue; \
Code; \
}
#define PURIFY_RAW_POINTER(Code) \
{ \
Old = (SCHEME_ADDR_TO_ADDR (Temp)); \
- if ((GC_Mode == CONSTANT_COPY) && \
- (Old < low_heap)) \
+ if ((GC_Mode == CONSTANT_COPY) \
+ && (Old < low_heap)) \
continue; \
Code; \
}
#define Setup_Pointer_for_Purify(Extra_Code) \
{ \
- Purify_Pointer(Setup_Pointer(false, Extra_Code)); \
+ Purify_Pointer (Setup_Pointer (false, Extra_Code)); \
}
#define Indirect_BH(In_GC) \
{
if (GC_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*/
}
Scan -= 1;
break;
}
-
+\f
case OPERATOR_LINKAGE_KIND:
case GLOBAL_OPERATOR_LINKAGE_KIND:
{
fast long count;
- fast char *word_ptr;
- SCHEME_OBJECT *end_scan;
+ fast char * word_ptr;
+ SCHEME_OBJECT * end_scan;
START_OPERATOR_RELOCATION (Scan);
count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
Scan = ((SCHEME_OBJECT *) word_ptr);
word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
- PURIFY_RAW_POINTER (Setup_Internal
+ PURIFY_RAW_POINTER (Setup_Aligned
(false,
TRANSPORT_RAW_COMPILED (),
RAW_COMPILED_BH (false,
break;
}
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
+ break;
+
default:
{
gc_death (TERM_EXIT,
case TC_MANIFEST_CLOSURE:
{
fast long count;
- fast char *word_ptr;
- SCHEME_OBJECT *area_end;
+ fast char * word_ptr;
+ SCHEME_OBJECT * area_end;
if (GC_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*/
}
Scan = ((SCHEME_OBJECT *) (word_ptr));
word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
- PURIFY_RAW_POINTER (Setup_Internal
+ PURIFY_RAW_POINTER (Setup_Aligned
(false,
TRANSPORT_RAW_COMPILED (),
RAW_COMPILED_BH (false,
goto next_closure)));
next_closure:
- STORE_CLOSURE_ENTRY_ADDRESS(Temp, Scan);
+ STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
}
Scan = area_end;
END_CLOSURE_RELOCATION (Scan);
case_compiled_entry_point:
if (GC_Mode != PURE_COPY)
{
- Purify_Pointer(Setup_Internal(false,
- Transport_Compiled(),
- Compiled_BH(false, goto after_entry)));
+ Purify_Pointer (Setup_Aligned (false,
+ Transport_Compiled (),
+ Compiled_BH (false,
+ goto after_entry)));
after_entry:
*Scan = Temp;
}
break;
case_Cell:
- Setup_Pointer_for_Purify(Transport_Cell());
+ Setup_Pointer_for_Purify (Transport_Cell ());
break;
case TC_WEAK_CONS:
- Setup_Pointer_for_Purify(Transport_Weak_Cons());
+ Setup_Pointer_for_Purify (Transport_Weak_Cons ());
break;
\f
/*
*/
case TC_REFERENCE_TRAP:
- if ((OBJECT_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;
if (GC_Mode == PURE_COPY)
{
Temp = MEMORY_REF (Temp, SYMBOL_NAME);
- Purify_Pointer(Setup_Internal(false,
- Transport_Vector_Indirect(),
- Indirect_BH(false)));
+ Purify_Pointer (Setup_Internal (false,
+ Transport_Vector_Indirect (),
+ Indirect_BH (false)));
break;
}
case_Fasdump_Pair:
purify_pair:
- Setup_Pointer_for_Purify(Transport_Pair());
+ Setup_Pointer_for_Purify (Transport_Pair ());
break;
case TC_VARIABLE:
case_Triple:
- Setup_Pointer_for_Purify(Transport_Triple());
+ Setup_Pointer_for_Purify (Transport_Triple ());
break;
case_Quadruple:
- Setup_Pointer_for_Purify(Transport_Quadruple());
+ Setup_Pointer_for_Purify (Transport_Quadruple ());
break;
- case TC_BIG_FLONUM:
- Setup_Pointer_for_Purify({
- Transport_Flonum();
+ case TC_COMPILED_CODE_BLOCK:
+ if (GC_Mode == PURE_COPY)
break;
- });
+ /* fall through */
+
+ case TC_BIG_FLONUM:
+ Purify_Pointer (Setup_Aligned (false,
+ goto Move_Vector,
+ Normal_BH (false, continue)));
+ break;
\f
/* No need to handle futures specially here, since purifyloop
is always invoked after running GCLoop, which will have
case TC_FUTURE:
case TC_ENVIRONMENT:
- case TC_COMPILED_CODE_BLOCK:
if (GC_Mode == PURE_COPY)
{
/* For environments, this should actually do an indirect pair
/* Fall through */
case_Purify_Vector:
- Setup_Pointer_for_Purify(Transport_Vector());
+ Setup_Pointer_for_Purify (Transport_Vector ());
break;
default:
- GC_BAD_TYPE("purifyloop");
+ GC_BAD_TYPE ("purifyloop");
/* Fall Through */
case_Non_Pointer:
/* -*-C-*-
-$Id: purutl.c,v 9.46 1993/10/14 19:16:10 gjr Exp $
+$Id: purutl.c,v 9.47 1993/12/07 20:36:04 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
{
case TC_MANIFEST_NM_VECTOR:
From += (OBJECT_DATUM (* From));
- continue;
+ break;
/* The following two type codes assume that none of the protected
objects can be updated.
case TC_LINKAGE_SECTION:
switch (READ_LINKAGE_KIND (* From))
{
- case REFERENCE_LINKAGE_KIND:
case ASSIGNMENT_LINKAGE_KIND:
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ case REFERENCE_LINKAGE_KIND:
{
From += (READ_CACHE_LINKAGE_COUNT (* From));
- continue;
+ break;
}
- case OPERATOR_LINKAGE_KIND:
case GLOBAL_OPERATOR_LINKAGE_KIND:
+ case OPERATOR_LINKAGE_KIND:
{
count = (READ_OPERATOR_LINKAGE_COUNT (* From));
From = (END_OPERATOR_LINKAGE_AREA (From, count));
- continue;
+ break;
}
\f
default:
/*NOTREACHED*/
}
#else /* not BAD_TYPES_LETHAL */
- outf_error ("\nupdate (impurify): Bad type code = 0x %02x.\n",
- (OBJECT_TYPE (* From)));
+ outf_error ("\nImpurify: Bad linkage section (0x%lx).\n",
+ (* From));
#endif /* BAD_TYPES_LETHAL */
}
+ break;
case TC_MANIFEST_CLOSURE:
{
From += 1;
count = (MANIFEST_CLOSURE_COUNT (From));
From = (MANIFEST_CLOSURE_END (From, count));
- continue;
+ break;
}
default:
- continue;
+ break;
}
}
- if (GC_Type_Non_Pointer(* From))
- continue;
- if ((OBJECT_ADDRESS (* From)) == Was)
+ else if ((! (GC_Type_Non_Pointer (* From)))
+ && ((OBJECT_ADDRESS (* From)) == Was))
* From = (MAKE_POINTER_OBJECT (OBJECT_TYPE (* From), Will_Be));
}
return;
/* -*-C-*-
-$Id: uxtrap.c,v 1.24 1993/10/14 19:20:41 gjr Exp $
+$Id: uxtrap.c,v 1.25 1993/12/07 20:36:05 gjr Exp $
Copyright (c) 1990-1993 Massachusetts Institute of Technology
{
switch (READ_LINKAGE_KIND (object))
{
- case OPERATOR_LINKAGE_KIND:
case GLOBAL_OPERATOR_LINKAGE_KIND:
+ case OPERATOR_LINKAGE_KIND:
{
long count = (READ_OPERATOR_LINKAGE_COUNT (object));
area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
#else
/* Fall through, no reason to crash here. */
#endif
- case REFERENCE_LINKAGE_KIND:
case ASSIGNMENT_LINKAGE_KIND:
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ case REFERENCE_LINKAGE_KIND:
area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
break;
/* -*-C-*-
-$Id: version.h,v 11.146 1993/11/16 04:53:48 gjr Exp $
+$Id: version.h,v 11.147 1993/12/07 20:35:21 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 146
+#define SUBVERSION 147
#endif
/* -*-C-*-
-$Id: cmpint.c,v 1.80 1993/11/16 03:56:41 gjr Exp $
+$Id: cmpint.c,v 1.81 1993/12/07 20:35:55 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
/* Imports from the rest of the "microcode" */
extern long
- EXFUN (compiler_cache_operator, (void)),
- EXFUN (compiler_cache_global_operator, (void)),
- EXFUN (compiler_cache_lookup, (void)),
- EXFUN (compiler_cache_assignment, (void));
+ EXFUN (compiler_cache_assignment, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
+ EXFUN (compiler_cache_lookup, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
+ EXFUN (compiler_cache_global_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long)),
+ EXFUN (compiler_cache_operator, (SCHEME_OBJECT, SCHEME_OBJECT, long));
\f
/* Exports to the rest of the "microcode" */
#define TRAMPOLINE_K_OTHER TRAMPOLINE_K_INTERPRETED
+/* Ways to bypass the interpreter */
+
#define REFLECT_CODE_INTERNAL_APPLY 0
#define REFLECT_CODE_RESTORE_INTERRUPT_MASK 1
#define REFLECT_CODE_STACK_MARKER 2
#define REFLECT_CODE_CC_BKPT 3
+
+/* Markers for special entry points */
+
+#ifndef FORMAT_BYTE_EXPR
+#define FORMAT_BYTE_EXPR 0xFF
+#endif
+#ifndef FORMAT_BYTE_COMPLR
+#define FORMAT_BYTE_COMPLR 0xFE
+#endif
+#ifndef FORMAT_BYTE_CMPINT
+#define FORMAT_BYTE_CMPINT 0xFD
+#endif
+#ifndef FORMAT_BYTE_DLINK
+#define FORMAT_BYTE_DLINK 0xFC
+#endif
+#ifndef FORMAT_BYTE_RETURN
+#define FORMAT_BYTE_RETURN 0xFB
+#endif
+#ifndef FORMAT_BYTE_CLOSURE
+#define FORMAT_BYTE_CLOSURE 0xFA
+#endif
+#ifndef FORMAT_BYTE_FRAMEMAX
+#define FORMAT_BYTE_FRAMEMAX 0x7F
+#endif
+
+#ifndef FORMAT_WORD_EXPR
+#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_EXPR))
+#endif
+#ifndef FORMAT_WORD_CMPINT
+#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CMPINT))
+#endif
+#ifndef FORMAT_WORD_RETURN
+#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_RETURN))
+#endif
\f
/* Utilities for application of compiled procedures. */
compiled_entry_address =
((instruction *) (OBJECT_ADDRESS (Fetch_Expression ())));
if ((COMPILED_ENTRY_FORMAT_WORD (compiled_entry_address)) !=
- (FORMAT_WORD_EXPR))
+ FORMAT_WORD_EXPR)
{
/* It self evaluates. */
Val = (Fetch_Expression ());
entry_address);
}
\f
-/* Core of comutil_link and comp_link_caches_restart. */
+static long
+DEFUN (compiler_link_closure_pattern, (distance, block, offset),
+ SCHEME_OBJECT distance AND SCHEME_OBJECT block AND long offset)
+{
+ long objdist = (FIXNUM_TO_LONG (distance));
+ long nmv_length = (OBJECT_DATUM (MEMORY_REF (block, 1)));
+ SCHEME_OBJECT * location = (MEMORY_LOC (block, offset));
+ SCHEME_OBJECT * closptr = (location - objdist);
+ SCHEME_OBJECT * end_closptr = (MEMORY_LOC (block, (2 + nmv_length)));
+ SCHEME_OBJECT entry_offset, * area_end;
+ char * word_ptr;
+ long count;
+
+ nmv_length -= (end_closptr - closptr);
+ while (closptr < end_closptr)
+ {
+ while ((* closptr) == ((SCHEME_OBJECT) 0))
+ closptr ++;
+ closptr ++;
+ count = (MANIFEST_CLOSURE_COUNT (closptr));
+ word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (closptr));
+ area_end = (MANIFEST_CLOSURE_END (closptr, count));
+ while ((--count) >= 0)
+ {
+ closptr = ((SCHEME_OBJECT *) word_ptr);
+ word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
+ EXTRACT_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr);
+ entry_offset = ((SCHEME_OBJECT)
+ (((long) closptr) - ((long) entry_offset)));
+ STORE_CLOSURE_ENTRY_ADDRESS (entry_offset, closptr);
+ }
+ closptr = &area_end[1];
+ }
+
+ MEMORY_SET (block, 1, (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, nmv_length)));
+ return (PRIM_DONE);
+}
static Boolean linking_cc_block_p = false;
return;
}
+/* Core of comutil_link and comp_link_caches_restart. */
+
static long
DEFUN (link_cc_block,
(block_address, offset, last_header_offset,
SCHEME_OBJECT block;
SCHEME_OBJECT header;
long result, kind, total_count;
- long (*cache_handler)();
+ long EXFUN ((* cache_handler), (SCHEME_OBJECT, SCHEME_OBJECT, long));
transaction_begin ();
{
transaction_record_action (tat_abort, abort_link_cc_block, ap);
}
linking_cc_block_p = true;
-
+\f
result = PRIM_DONE;
block = (MAKE_CC_BLOCK (block_address));
cache_handler = compiler_cache_global_operator;
goto handle_operator;
+ case ASSIGNMENT_LINKAGE_KIND:
+ cache_handler = compiler_cache_assignment;
+ goto handle_reference;
+
case REFERENCE_LINKAGE_KIND:
cache_handler = compiler_cache_lookup;
handle_reference:
count = (READ_CACHE_LINKAGE_COUNT (header));
break;
- case ASSIGNMENT_LINKAGE_KIND:
- cache_handler = compiler_cache_assignment;
+ case CLOSURE_PATTERN_LINKAGE_KIND:
+ cache_handler = compiler_link_closure_pattern;
+ /* Not really a reference, but the same format. */
goto handle_reference;
default:
(MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
for (offset += 1; ((--count) >= 0); offset += entry_size)
{
- SCHEME_OBJECT name;
+ SCHEME_OBJECT info; /* A symbol or a fixnum */
- if (!execute_p)
- name = (block_address[offset]);
+ if (! execute_p)
+ info = (block_address[offset]);
else
- EXTRACT_EXECUTE_CACHE_SYMBOL(name, &(block_address[offset]));
+ EXTRACT_EXECUTE_CACHE_SYMBOL (info, &(block_address[offset]));
- result = ((*cache_handler)(name, block, offset));
+ result = ((* cache_handler) (info, block, offset));
if (result != PRIM_DONE)
{
/* Save enough state to continue.
#define CONTINUATION_DYNAMIC_LINK 1
#define CONTINUATION_RETURN_TO_INTERPRETER 2
+/* Other subtypes */
+
+#define OTHER_CLOSURE 0
+#define OTHER_RANDOM 1
+
C_UTILITY void
DEFUN (compiled_entry_type,
(entry, buffer),
kind = KIND_CONTINUATION;
field1 = CONTINUATION_NORMAL;
- field2 = (((((unsigned long) max_arity) & 0x3f) << 7) |
- (((unsigned long) min_arity) & 0x7f));
+ field2 = (((((unsigned long) max_arity) & 0x3f) << 7)
+ | (((unsigned long) min_arity) & 0x7f));
}
- else if (min_arity != (-1))
+ else if (min_arity != -1)
kind = KIND_ILLEGAL;
\f
else
kind = KIND_EXPRESSION;
break;
}
+ case FORMAT_BYTE_CLOSURE:
+ {
+ kind = KIND_OTHER;
+ field1 = OTHER_CLOSURE;
+ break;
+ }
case FORMAT_BYTE_COMPLR:
case FORMAT_BYTE_CMPINT:
{
kind = KIND_OTHER;
+ field1 = OTHER_RANDOM;
break;
}
case FORMAT_BYTE_DLINK:
\f
SCHEME_UTILITY utility_result
DEFUN (comutil_compiled_code_bkpt,
- (entry_point_raw, dlink_raw, ignore_3, ignore_4),
- SCHEME_ADDR entry_point_raw AND SCHEME_ADDR dlink_raw
+ (entry_point_raw, state_raw, ignore_3, ignore_4),
+ SCHEME_ADDR entry_point_raw AND SCHEME_ADDR state_raw
AND long ignore_3 AND long ignore_4)
{
long type_info[3];
*/
compiled_entry_type (entry_point, &type_info[0]);
- if (type_info[0] != KIND_CONTINUATION)
+ if ((type_info[0] == KIND_OTHER) && (type_info[1] == OTHER_CLOSURE))
+ {
+ entry_point_a = ((instruction *) (SCHEME_ADDR_TO_ADDR (state_raw)));
+ state = (ENTRY_TO_OBJECT (entry_point_a));
+ }
+ else if (type_info[0] != KIND_CONTINUATION)
state = SHARP_F;
else if (type_info[1] == CONTINUATION_DYNAMIC_LINK)
state = (MAKE_POINTER_OBJECT
- (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (dlink_raw))));
+ (TC_STACK_ENVIRONMENT, (SCHEME_ADDR_TO_ADDR (state_raw))));
else
state = Val;
/* -*-C-*-
-$Id: version.h,v 11.146 1993/11/16 04:53:48 gjr Exp $
+$Id: version.h,v 11.147 1993/12/07 20:35:21 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 146
+#define SUBVERSION 147
#endif
projects / mit-scheme.git / commitdiff