From: Guillermo J. Rozas Date: Tue, 7 Dec 1993 20:36:05 +0000 (+0000) Subject: Some changes to closures: X-Git-Tag: 20090517-FFI~7385 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e649675bd0d917634c0be242d61e0e270d5b1024;p=mit-scheme.git Some changes to closures: - 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. --- diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c index 3248ba5af..bd49e48f4 100644 --- a/v7/src/microcode/bchdmp.c +++ b/v7/src/microcode/bchdmp.c @@ -1,6 +1,6 @@ /* -*-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 @@ -407,6 +407,7 @@ DEFUN (dumploop, (Scan, To_ptr, To_Address_ptr), /* 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 @@ -514,6 +515,10 @@ DEFUN (dumploop, (Scan, To_ptr, To_Address_ptr), 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.", @@ -627,11 +632,10 @@ DEFUN (dumploop, (Scan, To_ptr, To_Address_ptr), 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: diff --git a/v7/src/microcode/bchgcc.h b/v7/src/microcode/bchgcc.h index 771c042d4..1f048430b 100644 --- a/v7/src/microcode/bchgcc.h +++ b/v7/src/microcode/bchgcc.h @@ -1,6 +1,6 @@ /* -*-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 @@ -416,8 +416,9 @@ do { \ 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; \ @@ -435,8 +436,9 @@ do { \ 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; \ diff --git a/v7/src/microcode/bchgcl.c b/v7/src/microcode/bchgcl.c index c1601b17f..ac8f3f8a9 100644 --- a/v7/src/microcode/bchgcl.c +++ b/v7/src/microcode/bchgcl.c @@ -1,6 +1,6 @@ /* -*-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 @@ -78,6 +78,7 @@ DEFUN (GCLoop, (Scan, To_ptr, To_Address_ptr), /* 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 @@ -178,6 +179,10 @@ DEFUN (GCLoop, (Scan, To_ptr, To_Address_ptr), 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.", @@ -262,7 +267,7 @@ DEFUN (GCLoop, (Scan, To_ptr, To_Address_ptr), case_Quadruple: relocate_normal_pointer (copy_quadruple (), 4); - case TC_BIG_FLONUM: + case_Aligned_Vector: relocate_flonum_setup (); goto Move_Vector; diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c index fdf85aadf..4dabee372 100644 --- a/v7/src/microcode/bchpur.c +++ b/v7/src/microcode/bchpur.c @@ -1,6 +1,6 @@ /* -*-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 @@ -105,6 +105,7 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), /* 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 @@ -212,6 +213,10 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), 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.", @@ -331,13 +336,18 @@ DEFUN (purifyloop, (Scan, To_ptr, To_Address_ptr, purify_mode), break; relocate_normal_pointer (copy_quadruple(), 4); + 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; diff --git a/v7/src/microcode/cmpgc.h b/v7/src/microcode/cmpgc.h index f1e79ae52..a42b777b2 100644 --- a/v7/src/microcode/cmpgc.h +++ b/v7/src/microcode/cmpgc.h @@ -1,6 +1,6 @@ /* -*-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 @@ -43,7 +43,7 @@ See cmpint.txt, cmpint.c, cmpint-md.h, and cmpaux-md.m4 for more details. #ifndef CMPGC_H_INCLUDED #define CMPGC_H_INCLUDED - + #define NOP() do {} while (0) /* A useful macro */ /* These are needed whether or not there is a compiler, @@ -54,6 +54,7 @@ See cmpint.txt, cmpint.c, cmpint-md.h, and cmpaux-md.m4 for more details. #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 diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index ef689a809..69eebb45f 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-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 @@ -239,10 +239,10 @@ typedef utility_result EXFUN /* 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)); /* Exports to the rest of the "microcode" */ @@ -351,10 +351,46 @@ extern C_UTILITY void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT)); #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 /* Utilities for application of compiled procedures. */ @@ -579,7 +615,7 @@ DEFUN_VOID (enter_compiled_expression) 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 ()); @@ -970,7 +1006,43 @@ DEFUN (comutil_lexpr_apply, entry_address); } -/* 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; @@ -981,6 +1053,8 @@ DEFUN (abort_link_cc_block, (ap), PTR ap) return; } +/* Core of comutil_link and comp_link_caches_restart. */ + static long DEFUN (link_cc_block, (block_address, offset, last_header_offset, @@ -997,7 +1071,7 @@ DEFUN (link_cc_block, 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 (); { @@ -1006,7 +1080,7 @@ DEFUN (link_cc_block, transaction_record_action (tat_abort, abort_link_cc_block, ap); } linking_cc_block_p = true; - + result = PRIM_DONE; block = (MAKE_CC_BLOCK (block_address)); @@ -1032,6 +1106,10 @@ DEFUN (link_cc_block, 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: @@ -1040,8 +1118,9 @@ DEFUN (link_cc_block, 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: @@ -1072,14 +1151,14 @@ DEFUN (link_cc_block, (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. @@ -2344,6 +2423,11 @@ DEFUN (compiled_closure_to_entry, #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), @@ -2367,10 +2451,10 @@ DEFUN (compiled_entry_type, 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; else @@ -2382,10 +2466,17 @@ DEFUN (compiled_entry_type, 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: @@ -2853,8 +2944,8 @@ DEFUN (bkpt_proceed, (ep, handle, state), 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]; @@ -2876,11 +2967,16 @@ DEFUN (comutil_compiled_code_bkpt, */ 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; diff --git a/v7/src/microcode/dostrap.c b/v7/src/microcode/dostrap.c index dc2d142ca..ddcc05e69 100644 --- a/v7/src/microcode/dostrap.c +++ b/v7/src/microcode/dostrap.c @@ -1,6 +1,6 @@ /* -*-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 @@ -816,8 +816,8 @@ DEFUN (find_block_address_in_area, (pc_value, area_start), { 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); @@ -835,8 +835,9 @@ DEFUN (find_block_address_in_area, (pc_value, area_start), #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; diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index d4d75bbcf..629287766 100644 --- a/v7/src/microcode/fasdump.c +++ b/v7/src/microcode/fasdump.c @@ -1,6 +1,6 @@ /* -*-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 @@ -97,7 +97,8 @@ static CONST char * dump_file_name = ((char *) 0); */ #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)); \ @@ -114,7 +115,7 @@ static CONST char * dump_file_name = ((char *) 0); #define Fasdump_Transport_Compiled() \ { \ - Transport_Compiled(); \ + Transport_Compiled (); \ if ((mode == 2) && ((OBJECT_TYPE (*(To - 1))) == TC_ENVIRONMENT)) \ *(To - 1) = SHARP_F; \ } @@ -129,14 +130,14 @@ static CONST char * dump_file_name = ((char *) 0); #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))); \ } @@ -174,7 +175,7 @@ DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode) 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", @@ -265,7 +266,7 @@ DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode) 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)); @@ -279,6 +280,10 @@ DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode) break; } + case CLOSURE_PATTERN_LINKAGE_KIND: + Scan += (READ_CACHE_LINKAGE_COUNT (Temp)); + break; + default: { gc_death (TERM_EXIT, @@ -327,13 +332,11 @@ DEFUN (DumpLoop, (Scan, mode), fast SCHEME_OBJECT * Scan AND int mode) 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 ()); diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index 027a082f5..6c653380c 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,6 +1,6 @@ /* -*-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 @@ -439,14 +439,14 @@ DEFUN (Relocate_Block, (Scan, Stop_At), 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: @@ -472,7 +472,7 @@ DEFUN (Relocate_Block, (Scan, Stop_At), case TC_LINKAGE_SECTION: { - switch (READ_LINKAGE_KIND(Temp)) + switch (READ_LINKAGE_KIND (Temp)) { case REFERENCE_LINKAGE_KIND: case ASSIGNMENT_LINKAGE_KIND: @@ -498,8 +498,8 @@ DEFUN (Relocate_Block, (Scan, Stop_At), 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)); @@ -521,6 +521,10 @@ DEFUN (Relocate_Block, (Scan, Stop_At), break; } + case CLOSURE_PATTERN_LINKAGE_KIND: + Scan += (1 + (READ_CACHE_LINKAGE_COUNT (Temp))); + break; + default: { gc_death (TERM_EXIT, @@ -537,8 +541,8 @@ DEFUN (Relocate_Block, (Scan, Stop_At), /* 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; diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h index a3834f439..268ded7dd 100644 --- a/v7/src/microcode/gccode.h +++ b/v7/src/microcode/gccode.h @@ -1,6 +1,6 @@ /* -*-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 @@ -47,24 +47,24 @@ MIT in each case. */ 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): @@ -73,86 +73,91 @@ MIT in each case. */ 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 */ -#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 */ -#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 + */ extern char gc_death_message_buffer []; @@ -245,6 +250,17 @@ do \ 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)); \ @@ -426,7 +442,7 @@ extern void EXFUN (check_transport_vector_lossage, TRANSPORT_ONE_THING ((*To++) = (*Old++)); \ Scan = Saved_Scan; \ } - + #else /* In_Fasdump */ #define Real_Transport_Vector() \ @@ -448,32 +464,14 @@ extern void EXFUN (check_transport_vector_lossage, } #endif - -#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))) \ @@ -537,18 +535,37 @@ extern SCHEME_OBJECT Weak_Chain; 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 (); \ diff --git a/v7/src/microcode/gcloop.c b/v7/src/microcode/gcloop.c index 838c2e666..c1a097527 100644 --- a/v7/src/microcode/gcloop.c +++ b/v7/src/microcode/gcloop.c @@ -1,6 +1,6 @@ /* -*-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 @@ -145,9 +145,9 @@ DEFUN (GCLoop, #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))) @@ -155,10 +155,10 @@ DEFUN (GCLoop, *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: @@ -199,20 +199,20 @@ DEFUN (GCLoop, 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, @@ -225,6 +225,10 @@ DEFUN (GCLoop, break; } + case CLOSURE_PATTERN_LINKAGE_KIND: + Scan += (READ_CACHE_LINKAGE_COUNT (Temp)); + break; + default: { gc_death (TERM_EXIT, @@ -239,8 +243,8 @@ DEFUN (GCLoop, 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; @@ -253,7 +257,7 @@ DEFUN (GCLoop, 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, @@ -268,9 +272,9 @@ DEFUN (GCLoop, } 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; @@ -280,7 +284,7 @@ DEFUN (GCLoop, 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; @@ -288,38 +292,38 @@ DEFUN (GCLoop, /* Fall Through. */ case_Pair: - Setup_Pointer_for_GC(Transport_Pair()); + Setup_Pointer_for_GC (Transport_Pair ()); break; 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: diff --git a/v7/src/microcode/nttrap.c b/v7/src/microcode/nttrap.c index cec5d1264..91f495670 100644 --- a/v7/src/microcode/nttrap.c +++ b/v7/src/microcode/nttrap.c @@ -1,6 +1,6 @@ /* -*-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 @@ -966,8 +966,8 @@ DEFUN (find_block_address_in_area, (pc_value, area_start), { 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); @@ -985,8 +985,9 @@ DEFUN (find_block_address_in_area, (pc_value, area_start), #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; diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c index 44c007469..c639bf0a3 100644 --- a/v7/src/microcode/purify.c +++ b/v7/src/microcode/purify.c @@ -1,6 +1,6 @@ /* -*-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 @@ -58,8 +58,8 @@ extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); #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; \ } @@ -67,15 +67,15 @@ extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **)); #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) \ @@ -136,9 +136,9 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), { 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*/ } @@ -166,13 +166,13 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), Scan -= 1; break; } - + 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)); @@ -184,7 +184,7 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), 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, @@ -197,6 +197,10 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), break; } + case CLOSURE_PATTERN_LINKAGE_KIND: + Scan += (READ_CACHE_LINKAGE_COUNT (Temp)); + break; + default: { gc_death (TERM_EXIT, @@ -211,14 +215,14 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), 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*/ } @@ -233,13 +237,13 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), 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); @@ -249,20 +253,21 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), 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; /* @@ -272,8 +277,8 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), */ 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; @@ -285,9 +290,9 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), 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; } @@ -295,23 +300,28 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), 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; /* No need to handle futures specially here, since purifyloop is always invoked after running GCLoop, which will have @@ -321,7 +331,6 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), 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 @@ -332,11 +341,11 @@ DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode), /* 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: diff --git a/v7/src/microcode/purutl.c b/v7/src/microcode/purutl.c index 044092e1d..73a7f47b7 100644 --- a/v7/src/microcode/purutl.c +++ b/v7/src/microcode/purutl.c @@ -1,6 +1,6 @@ /* -*-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 @@ -56,7 +56,7 @@ DEFUN (update, (From, To, Was, Will_Be), { 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. @@ -65,19 +65,20 @@ DEFUN (update, (From, To, Was, Will_Be), 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; } default: @@ -89,10 +90,11 @@ DEFUN (update, (From, To, Was, Will_Be), /*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: { @@ -101,16 +103,15 @@ DEFUN (update, (From, To, Was, Will_Be), 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; diff --git a/v7/src/microcode/uxtrap.c b/v7/src/microcode/uxtrap.c index 7d3343ece..9e3ff6548 100644 --- a/v7/src/microcode/uxtrap.c +++ b/v7/src/microcode/uxtrap.c @@ -1,6 +1,6 @@ /* -*-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 @@ -698,8 +698,8 @@ DEFUN (find_block_address_in_area, (pc_value, area_start), { 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); @@ -717,8 +717,9 @@ DEFUN (find_block_address_in_area, (pc_value, area_start), #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; diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 1e0c8c68d..1247f7de9 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-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 @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 146 +#define SUBVERSION 147 #endif diff --git a/v8/src/microcode/cmpint.c b/v8/src/microcode/cmpint.c index ef689a809..69eebb45f 100644 --- a/v8/src/microcode/cmpint.c +++ b/v8/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-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 @@ -239,10 +239,10 @@ typedef utility_result EXFUN /* 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)); /* Exports to the rest of the "microcode" */ @@ -351,10 +351,46 @@ extern C_UTILITY void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT)); #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 /* Utilities for application of compiled procedures. */ @@ -579,7 +615,7 @@ DEFUN_VOID (enter_compiled_expression) 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 ()); @@ -970,7 +1006,43 @@ DEFUN (comutil_lexpr_apply, entry_address); } -/* 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; @@ -981,6 +1053,8 @@ DEFUN (abort_link_cc_block, (ap), PTR ap) return; } +/* Core of comutil_link and comp_link_caches_restart. */ + static long DEFUN (link_cc_block, (block_address, offset, last_header_offset, @@ -997,7 +1071,7 @@ DEFUN (link_cc_block, 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 (); { @@ -1006,7 +1080,7 @@ DEFUN (link_cc_block, transaction_record_action (tat_abort, abort_link_cc_block, ap); } linking_cc_block_p = true; - + result = PRIM_DONE; block = (MAKE_CC_BLOCK (block_address)); @@ -1032,6 +1106,10 @@ DEFUN (link_cc_block, 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: @@ -1040,8 +1118,9 @@ DEFUN (link_cc_block, 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: @@ -1072,14 +1151,14 @@ DEFUN (link_cc_block, (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. @@ -2344,6 +2423,11 @@ DEFUN (compiled_closure_to_entry, #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), @@ -2367,10 +2451,10 @@ DEFUN (compiled_entry_type, 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; else @@ -2382,10 +2466,17 @@ DEFUN (compiled_entry_type, 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: @@ -2853,8 +2944,8 @@ DEFUN (bkpt_proceed, (ep, handle, state), 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]; @@ -2876,11 +2967,16 @@ DEFUN (comutil_compiled_code_bkpt, */ 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; diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index 1e0c8c68d..1247f7de9 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-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 @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 146 +#define SUBVERSION 147 #endif