From: Guillermo J. Rozas Date: Tue, 7 Dec 1993 20:31:16 +0000 (+0000) Subject: Some changes to closures: X-Git-Tag: 20090517-FFI~7386 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ef4d37edd99c8e0b6cceccd018ec8288ef47c742;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. --- diff --git a/v7/src/microcode/cmpintmd/hppa.h b/v7/src/microcode/cmpintmd/hppa.h index 61dbd9226..0484d97c0 100644 --- a/v7/src/microcode/cmpintmd/hppa.h +++ b/v7/src/microcode/cmpintmd/hppa.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: hppa.h,v 1.47 1993/11/11 06:01:54 gjr Exp $ +$Id: hppa.h,v 1.48 1993/12/07 20:31:16 gjr Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -45,6 +45,7 @@ MIT in each case. */ #define CMPINTMD_H_INCLUDED #include "cmptype.h" +#include "hppacach.h" /* Machine parameters to be set by the user. */ @@ -113,414 +114,123 @@ extern void ((unsigned long) (nullify_p))); \ } -#ifdef IN_CMPINT_C +/* Interrupt/GC polling. */ -/* Definitions of the utility procedures. - Procedure calls of leaf procedures on the HPPA are pretty fast, - so there is no reason not to do this out of line. - In this way compiled code can use them too. +/* The length of the GC recovery code that precedes an entry. + On the HP-PA a "ble, ldi" instruction sequence. */ -union ldil_inst -{ - unsigned long inst; - struct - { - unsigned opcode : 6; - unsigned base : 5; - unsigned D : 5; - unsigned C : 2; - unsigned E : 2; - unsigned B : 11; - unsigned A : 1; - } fields; -}; - -union branch_inst -{ - unsigned long inst; - struct - { - unsigned opcode : 6; - unsigned t_or_b : 5; - unsigned x_or_w1 : 5; - unsigned s : 3; - unsigned w2b : 10; - unsigned w2a : 1; - unsigned n : 1; - unsigned w0 : 1; - } fields; -}; +#define ENTRY_PREFIX_LENGTH 8 -union short_pointer -{ - unsigned long address; - struct - { - unsigned A : 1; - unsigned B : 11; - unsigned C : 2; - unsigned D : 5; - unsigned w2a : 1; - unsigned w2b : 10; - unsigned pad : 2; - } fields; -}; - /* - Note: The following does not do a full decoding of the BLE instruction. - It assumes that the bits have been set by STORE_ABSOLUTE_ADDRESS below, - which decomposes an absolute address according to the `short_pointer' - structure above, and thus certain fields are 0. + The instructions for a normal entry should be something like - The sequence inserted by STORE_ABSOLUTE_ADDRESS is approximately - (the actual address decomposition is given above). - LDIL L'ep,26 - BLE R'ep(5,26) - */ + COMBT,>=,N Rfree,Rmemtop,interrupt + LDW 0(0,Regs),Rmemtop -unsigned long -DEFUN (hppa_extract_absolute_address, (addr), unsigned long * addr) -{ - union short_pointer result; - union branch_inst ble; - union ldil_inst ldil; + For a closure - ldil.inst = *addr++; - ble.inst = *addr; + DEPI tc_closure>>1,4,5,25 ; set type code + STWM 25,-4(0,Rstack) ; push on stack + COMB,>= Rfree,Rmemtop,interrupt ; GC/interrupt check + LDW 0(0,Regs),Rmemtop ; Recache memtop - /* Fill the padding */ - result.address = 0; + Notes: - result.fields.A = ldil.fields.A; - result.fields.B = ldil.fields.B; - result.fields.C = ldil.fields.C; - result.fields.D = ldil.fields.D; - result.fields.w2a = ble.fields.w2a; - result.fields.w2b = ble.fields.w2b; + The LDW can be eliminated once the C interrupt handler is changed to + update Rmemtop directly. At that point, the instruction following the + COMB instruction will have to be nullified whenever the interrupt + branch is processed. - return (result.address); -} + */ -void -DEFUN (hppa_store_absolute_address, (addr, sourcev, nullify_p), - unsigned long * addr AND unsigned long sourcev - AND unsigned long nullify_p) -{ - union short_pointer source; - union ldil_inst ldil; - union branch_inst ble; +/* Compiled closures */ - source.address = sourcev; +/* Manifest closure entry block size. + Size in bytes of a compiled closure's header excluding the + TC_MANIFEST_CLOSURE header. -#if 0 - ldil.fields.opcode = 0x08; - ldil.fields.base = 26; - ldil.fields.E = 0; -#else - ldil.inst = ((0x08 << 26) | (26 << 21)); -#endif + On the PA this is 2 format_words for the format word and gc + offset words, and 12 more bytes for 3 instructions: - ldil.fields.A = source.fields.A; - ldil.fields.B = source.fields.B; - ldil.fields.C = source.fields.C; - ldil.fields.D = source.fields.D; + LDIL L'target,26 + BLE R'target(5,26) + ADDI -15,31,25 ; handle privilege bits + */ -#if 0 - ble.fields.opcode = 0x39; - ble.fields.t_or_b = 26; - ble.fields.x_or_w1 = 0; - ble.fields.s = 3; - ble.fields.w0 = 0; -#else - ble.inst = ((0x39 << 26) | (26 << 21) | (3 << 13)); -#endif +#define COMPILED_CLOSURE_ENTRY_SIZE 16 - ble.fields.w2a = source.fields.w2a; - ble.fields.w2b = source.fields.w2b; - ble.fields.n = (nullify_p & 1); +/* Manifest closure entry destructuring. - *addr++ = ldil.inst; - *addr = ble.inst; - return; + Given the entry point of a closure, extract the `real entry point' + (the address of the real code of the procedure, ie. one indirection) + from the closure. + On the PA, the real entry point is "smeared out" over the LDIL and + the BLE instructions. +*/ + +#define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \ +{ \ + EXTRACT_ABSOLUTE_ADDRESS (real_entry_point, entry_point); \ } - -/* Cache flushing/pushing code. - Uses routines from cmpaux-hppa.m4. - */ -#include "hppacach.h" -#include "option.h" +/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS. + Given a closure's entry point and a code entry point, store the + code entry point in the closure. + */ -static struct pdc_cache_dump cache_info; +#define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \ +{ \ + STORE_ABSOLUTE_ADDRESS (real_entry_point, entry_point, false); \ +} + +/* Trampolines -extern void - EXFUN (flush_i_cache, (void)), - EXFUN (push_d_cache_region, (PTR, unsigned long)); + Here's a picture of a trampoline on the PA (offset in bytes from + entry point) -void -DEFUN_VOID (flush_i_cache) -{ - extern void - EXFUN (cache_flush_all, (unsigned int, struct pdc_cache_result *)); + -12: MANIFEST vector header + - 8: NON_MARKED header + - 4: Format word + - 2: 0xC (GC Offset to start of block from .+2) + 0: BLE 4(4,3) ; call trampoline_to_interface + 4: LDI index,28 + 8: trampoline dependent storage (0 - 3 longwords) - struct pdc_cache_result * cache_desc; - - cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); + TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine + dependent portion of a trampoline, including the GC and format + headers. The code in the trampoline must store an index (used to + determine which C SCHEME_UTILITY procedure to invoke) in a + register, jump to "scheme_to_interface" and leave the address of + the storage following the code in a standard location. - /* The call can be interrupted in the middle of a set, so do it twice. - Probability of two interrupts in the same cache line is - exceedingly small, so this is likely to win. - On the other hand, if the caches are directly mapped, a single - call can't lose. - In addition, if the cache is shared, there is no need to flush at all. - */ + TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a + trampoline when given the address of the word containing + the manifest vector header. According to the above picture, + it would add 12 bytes to its argument. - if (((cache_desc->I_info.conf.bits.fsel & 1) == 0) - || ((cache_desc->D_info.conf.bits.fsel & 1) == 0)) - { - unsigned int flag = 0; + TRAMPOLINE_STORAGE takes the address of the first instruction in a + trampoline (not the start of the trampoline block) and returns the + address of the first storage word in the trampoline. - if (cache_desc->I_info.loop != 1) - flag |= I_CACHE; - if (cache_desc->D_info.loop != 1) - flag |= D_CACHE; + STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in + the trampoline and stores the instructions. It also receives the + index of the C SCHEME_UTILITY to be invoked. - if (flag != 0) - cache_flush_all (flag, cache_desc); - cache_flush_all ((D_CACHE | I_CACHE), cache_desc); - } -} + Note: this flushes both caches because the words may fall in a cache + line that already has an association in the i-cache because a different + trampoline or a closure are in it. +*/ -void -DEFUN (push_d_cache_region, (start_address, block_size), - PTR start_address AND unsigned long block_size) -{ - extern void - EXFUN (cache_flush_region, (PTR, long, unsigned int)); +#define TRAMPOLINE_ENTRY_SIZE 3 +#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* longwords from MNV to BLE */ - struct pdc_cache_result * cache_desc; - - cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); +#define TRAMPOLINE_ENTRY_POINT(tramp_block) \ + (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY) - /* Note that the first and last words are also flushed from the I-cache - in case this object is adjacent to another that has already caused - the cache line to be copied into the I-cache. - */ - - if (((cache_desc->I_info.conf.bits.fsel & 1) == 0) - || ((cache_desc->D_info.conf.bits.fsel & 1) == 0)) - { - cache_flush_region (start_address, block_size, D_CACHE); - cache_flush_region (start_address, 1, I_CACHE); - cache_flush_region (((PTR) - (((unsigned long *) start_address) - + (block_size - 1))), - 1, - I_CACHE); - } - return; -} - -#ifndef MODELS_FILENAME -#define MODELS_FILENAME "hppacach.mod" -#endif - -static void -DEFUN_VOID (flush_i_cache_initialize) -{ - extern char * EXFUN (getenv, (const char *)); - CONST char * models_filename = - (search_path_for_file (0, MODELS_FILENAME, 1, 1)); - char * model; - - model = (getenv ("MITSCHEME_HPPA_MODEL")); - -#ifdef _HPUX - if (model == ((char *) NULL)) - { - struct utsname sysinfo; - if ((uname (&sysinfo)) < 0) - { - outf_fatal ("\nflush_i_cache: uname failed.\n"); - goto loser; - } - model = &sysinfo.machine[0]; - } -#endif /* _HPUX */ - if (model == ((char *) NULL)) - { - outf_fatal - ("\nflush_i_cache: MITSCHEME_HPPA_MODEL not set in environment.\n"); - goto loser; - } - { - int fd = (open (models_filename, O_RDONLY)); - if (fd < 0) - { - outf_fatal ("\nflush_i_cache: open (%s) failed.\n", - models_filename); - goto loser; - } - while (1) - { - int read_result = - (read (fd, - ((char *) (&cache_info)), - (sizeof (struct pdc_cache_dump)))); - if (read_result == 0) - { - close (fd); - break; - } - if (read_result != (sizeof (struct pdc_cache_dump))) - { - close (fd); - outf_fatal ("\nflush_i_cache: read (%s) failed.\n", - models_filename); - goto loser; - } - if ((strcmp (model, (cache_info . hardware))) == 0) - { - close (fd); - return; - } - } - } - outf_fatal ( - "The cache parameters database has no entry for the %s model.\n", - model); - outf_fatal ("Please make an entry in the database;\n"); - outf_fatal ("the installation notes contain instructions for doing so.\n"); - loser: - outf_fatal ("\nASM_RESET_HOOK: Unable to read cache parameters.\n"); - termination_init_error (); -} - -#endif /* IN_CMPINT_C */ - -/* Interrupt/GC polling. */ - -/* The length of the GC recovery code that precedes an entry. - On the HP-PA a "ble, ldi" instruction sequence. - */ - -#define ENTRY_PREFIX_LENGTH 8 - -/* - The instructions for a normal entry should be something like - - COMBT,>=,N Rfree,Rmemtop,interrupt - LDW 0(0,Regs),Rmemtop - - For a closure - - DEP 0,31,2,31 ; clear privilege bits - DEPI tc_closure>>1,4,5,31 ; set type code - STWM 31,-4(0,Rstack) ; push on stack - COMB,>= Rfree,Rmemtop,interrupt ; GC/interrupt check - LDW 0(0,Regs),Rmemtop ; Recache memtop - - Notes: - - The LDW can be eliminated once the C interrupt handler is changed to - update Rmemtop directly. At that point, the instruction following the - COMB instruction will have to be nullified whenever the interrupt - branch is processed. - - The DEP can be eliminated if we assume that the privilege bits will always - be the same (3). The clearing can be combined with the ADDI instruction in - the closure object itself. - - */ - -/* Compiled closures */ - -/* Manifest closure entry block size. - Size in bytes of a compiled closure's header excluding the - TC_MANIFEST_CLOSURE header. - - On the PA this is 2 format_words for the format word and gc - offset words, and 12 more bytes for 3 instructions: - - LDIL L'target,26 - BLE R'target(5,26) - ADDI -12,31,31 - */ - -#define COMPILED_CLOSURE_ENTRY_SIZE 16 - -/* Manifest closure entry destructuring. - - Given the entry point of a closure, extract the `real entry point' - (the address of the real code of the procedure, ie. one indirection) - from the closure. - On the PA, the real entry point is "smeared out" over the LDIL and - the BLE instructions. -*/ - -#define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \ -{ \ - EXTRACT_ABSOLUTE_ADDRESS(real_entry_point, entry_point); \ -} - -/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS. - Given a closure's entry point and a code entry point, store the - code entry point in the closure. - */ - -#define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \ -{ \ - STORE_ABSOLUTE_ADDRESS(real_entry_point, entry_point, false); \ -} - -/* Trampolines - - Here's a picture of a trampoline on the PA (offset in bytes from - entry point) - - -12: MANIFEST vector header - - 8: NON_MARKED header - - 4: Format word - - 2: 0xC (GC Offset to start of block from .+2) - 0: BLE 4(4,3) ; call trampoline_to_interface - 4: LDI index,28 - 8: trampoline dependent storage (0 - 3 longwords) - - TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine - dependent portion of a trampoline, including the GC and format - headers. The code in the trampoline must store an index (used to - determine which C SCHEME_UTILITY procedure to invoke) in a - register, jump to "scheme_to_interface" and leave the address of - the storage following the code in a standard location. - - TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a - trampoline when given the address of the word containing - the manifest vector header. According to the above picture, - it would add 12 bytes to its argument. - - TRAMPOLINE_STORAGE takes the address of the first instruction in a - trampoline (not the start of the trampoline block) and returns the - address of the first storage word in the trampoline. - - STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in - the trampoline and stores the instructions. It also receives the - index of the C SCHEME_UTILITY to be invoked. - - Note: this flushes both caches because the words may fall in a cache - line that already has an association in the i-cache because a different - trampoline or a closure are in it. -*/ - -#define TRAMPOLINE_ENTRY_SIZE 3 -#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* longwords from MNV to BLE */ - -#define TRAMPOLINE_ENTRY_POINT(tramp_block) \ - (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY) - -#define TRAMPOLINE_STORAGE(tramp_entry) \ - ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ - (2 + TRAMPOLINE_ENTRY_SIZE)) +#define TRAMPOLINE_STORAGE(tramp_entry) \ + ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ + (2 + TRAMPOLINE_ENTRY_SIZE)) #define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \ { \ @@ -709,57 +419,218 @@ extern Boolean EXFUN (hppa_grow_primitive_table, (int)); */ #define SPLIT_CACHES - -#ifdef IN_CMPINT_C -union assemble_17_u -{ - long value; - struct - { - int sign_pad : 13; - unsigned w0 : 1; - unsigned w1 : 5; - unsigned w2a : 1; - unsigned w2b : 10; - unsigned pad : 2; - } fields; -}; +/* Derived parameters and macros. -union assemble_12_u -{ - long value; - struct - { - int sign_pad : 18; - unsigned w0 : 1; - unsigned w2a : 1; - unsigned w2b : 10; - unsigned pad : 2; - } fields; -}; + These macros expect the above definitions to be meaningful. + If they are not, the macros below may have to be changed as well. + */ -long -DEFUN (assemble_17, (inst), union branch_inst inst) -{ - union assemble_17_u off; +#define COMPILED_ENTRY_OFFSET_WORD(entry) \ + (((format_word *) (entry))[-1]) +#define COMPILED_ENTRY_FORMAT_WORD(entry) \ + (((format_word *) (entry))[-2]) - off.fields.pad = 0; - off.fields.w2b = inst.fields.w2b; - off.fields.w2a = inst.fields.w2a; - off.fields.w1 = inst.fields.x_or_w1; - off.fields.w0 = inst.fields.w0; - off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1); - return (off.value); -} +/* The next one assumes 2's complement integers....*/ +#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) +#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) -long -DEFUN (assemble_12, (inst), union branch_inst inst) -{ - union assemble_12_u off; +#if (PC_ZERO_BITS == 0) +/* Instructions aligned on byte boundaries */ +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + ((CLEAR_LOW_BIT(offset_word)) >> 1) +#endif - off.fields.pad = 0; - off.fields.w2b = inst.fields.w2b; +#if (PC_ZERO_BITS == 1) +/* Instructions aligned on word (16 bit) boundaries */ +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + (CLEAR_LOW_BIT(offset_word)) +#endif + +#if (PC_ZERO_BITS >= 2) +/* Should be OK for =2, but bets are off for >2 because of problems + mentioned earlier! +*/ +#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) +#endif + +#define MAKE_OFFSET_WORD(entry, block, continue) \ + ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ + ((char *) (block)))) | \ + ((continue) ? 1 : 0)) + +#if (EXECUTE_CACHE_ENTRY_SIZE == 2) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) >> 1) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) << 1) +#endif + +#if (EXECUTE_CACHE_ENTRY_SIZE == 4) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) >> 2) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) << 2) +#endif + +#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) / EXECUTE_CACHE_ENTRY_SIZE) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) * EXECUTE_CACHE_ENTRY_SIZE) +#endif + +/* The first entry in a cc block is preceeded by 2 headers (block and nmv), + a format word and a gc offset word. See the early part of the + TRAMPOLINE picture, above. + */ + +#define CC_BLOCK_FIRST_ENTRY_OFFSET \ + (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word)))) + +#ifndef FORMAT_BYTE_CLOSURE +#define FORMAT_BYTE_CLOSURE 0xFA +#endif + +#ifndef FORMAT_WORD_CLOSURE +#define FORMAT_WORD_CLOSURE (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CLOSURE)) +#endif + +/* This assumes that a format word is at least 16 bits, + and the low order field is always 8 bits. + */ + +#define MAKE_FORMAT_WORD(field1, field2) \ + (((field1) << 8) | ((field2) & 0xff)) + +#define SIGN_EXTEND_FIELD(field, size) \ + (((field) & ((1 << (size)) - 1)) | \ + ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \ + ((-1) << (size)))) + +#define FORMAT_WORD_LOW_BYTE(word) \ + (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8)) + +#define FORMAT_WORD_HIGH_BYTE(word) \ + (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \ + (((sizeof (format_word)) * CHAR_BIT) - 8))) + +#define COMPILED_ENTRY_FORMAT_HIGH(addr) \ + (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) + +#define COMPILED_ENTRY_FORMAT_LOW(addr) \ + (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) + +#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW +#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH + +#ifdef IN_CMPINT_C + +/* Definitions of the utility procedures. + Procedure calls of leaf procedures on the HPPA are pretty fast, + so there is no reason not to do this out of line. + In this way compiled code can use them too. + */ + +union ldil_inst +{ + unsigned long inst; + struct + { + unsigned opcode : 6; + unsigned base : 5; + unsigned D : 5; + unsigned C : 2; + unsigned E : 2; + unsigned B : 11; + unsigned A : 1; + } fields; +}; + +union branch_inst +{ + unsigned long inst; + struct + { + unsigned opcode : 6; + unsigned t_or_b : 5; + unsigned x_or_w1 : 5; + unsigned s : 3; + unsigned w2b : 10; + unsigned w2a : 1; + unsigned n : 1; + unsigned w0 : 1; + } fields; +}; + +union short_pointer +{ + unsigned long address; + struct + { + unsigned A : 1; + unsigned B : 11; + unsigned C : 2; + unsigned D : 5; + unsigned w2a : 1; + unsigned w2b : 10; + unsigned pad : 2; + } fields; +}; + +union assemble_17_u +{ + long value; + struct + { + int sign_pad : 13; + unsigned w0 : 1; + unsigned w1 : 5; + unsigned w2a : 1; + unsigned w2b : 10; + unsigned pad : 2; + } fields; +}; + +union assemble_12_u +{ + long value; + struct + { + int sign_pad : 18; + unsigned w0 : 1; + unsigned w2a : 1; + unsigned w2b : 10; + unsigned pad : 2; + } fields; +}; + +long +DEFUN (assemble_17, (inst), union branch_inst inst) +{ + union assemble_17_u off; + + off.fields.pad = 0; + off.fields.w2b = inst.fields.w2b; + off.fields.w2a = inst.fields.w2a; + off.fields.w1 = inst.fields.x_or_w1; + off.fields.w0 = inst.fields.w0; + off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1); + return (off.value); +} + +long +DEFUN (assemble_12, (inst), union branch_inst inst) +{ + union assemble_12_u off; + + off.fields.pad = 0; + off.fields.w2b = inst.fields.w2b; off.fields.w2a = inst.fields.w2a; off.fields.w0 = inst.fields.w0; off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1); @@ -803,6 +674,7 @@ static Boolean static unsigned long bkpt_instruction, closure_bkpt_instruction, + closure_entry_bkpt_instruction, * bkpt_normal_proceed_thunk, * bkpt_plus_proceed_thunk, * bkpt_minus_proceed_thunk_start, @@ -813,7 +685,7 @@ static unsigned long #define FAHRENHEIT 451 static void -DEFUN_VOID(bkpt_init) +DEFUN_VOID (bkpt_init) { int i; union branch_inst instr; @@ -845,9 +717,11 @@ DEFUN_VOID(bkpt_init) bkpt_instruction = instr.inst; + instr.fields.w2b = ((FAHRENHEIT + 33) >> 2); + closure_entry_bkpt_instruction = instr.inst; + instr.fields.opcode = 0x38; /* BE opcode */ instr.fields.w2b = ((FAHRENHEIT + 9) >> 2); - closure_bkpt_instruction = instr.inst; bkpt_normal_proceed_thunk @@ -876,6 +750,7 @@ DEFUN_VOID(bkpt_init) #define BKPT_KIND_PC_REL_BRANCH 2 #define BKPT_KIND_BL_INST 3 #define BKPT_KIND_BLE_INST 4 +#define BKPT_KIND_CLOSURE_ENTRY 5 extern void EXFUN (cache_flush_region, (PTR, long, unsigned int)); @@ -904,8 +779,15 @@ DEFUN (bkpt_install, (entry_point), PTR entry_point) SCHEME_OBJECT handle; unsigned long first_instr = (* ((unsigned long *) entry_point)); unsigned short opcode = ((first_instr >> 26) & 0x3f); + unsigned long new_instr = bkpt_instruction; - if ((! (branch_opcode_table[opcode])) || (opcode == 0x38)) + if ((COMPILED_ENTRY_FORMAT_WORD (entry_point)) == FORMAT_WORD_CLOSURE) + { + /* This assumes that the first instruction is normal */ + kind = BKPT_KIND_CLOSURE_ENTRY; + new_instr = closure_entry_bkpt_instruction; + } + else if ((! (branch_opcode_table[opcode])) || (opcode == 0x38)) kind = BKPT_KIND_NORMAL; /* BE instr included */ else if (opcode == 0x39) #if 0 @@ -956,7 +838,7 @@ DEFUN (bkpt_install, (entry_point), PTR entry_point) handle = (alloc_bkpt_handle (kind, first_instr, entry_point)); - (* ((unsigned long *) entry_point)) = bkpt_instruction; + (* ((unsigned long *) entry_point)) = new_instr; cache_flush_region (((PTR) entry_point), 1, (D_CACHE | I_CACHE)); return (handle); @@ -981,7 +863,8 @@ DEFUN (bkpt_remove, (entry_point, handle), int offset; unsigned long * instrs = ((unsigned long *) entry_point); - if (instrs[0] == bkpt_instruction) + if ((instrs[0] == bkpt_instruction) + || (instrs[0] == closure_entry_bkpt_instruction)) offset = 0; else if (instrs[2] == closure_bkpt_instruction) offset = 2; @@ -999,6 +882,7 @@ DEFUN (bkpt_p, (entry_point), PTR entry_point) unsigned long * instrs = ((unsigned long *) entry_point); return ((instrs[0] == bkpt_instruction) + || (instrs[0] == closure_entry_bkpt_instruction) || (instrs[2] == closure_bkpt_instruction)); } @@ -1034,7 +918,7 @@ DEFUN (do_bkpt_proceed, (value), unsigned long * value) * value = ((unsigned long) buffer); return (TRUE); } - + case BKPT_KIND_NORMAL: { int i, len; @@ -1052,6 +936,13 @@ DEFUN (do_bkpt_proceed, (value), unsigned long * value) * value = ((unsigned long) buffer); return (TRUE); } + + case BKPT_KIND_CLOSURE_ENTRY: + { + STACK_PUSH (state); /* closure object */ + * value = ((unsigned long) ((OBJECT_ADDRESS (ep)) + 2)); + return (TRUE); + } case BKPT_KIND_BL_INST: case BKPT_KIND_BLE_INST: @@ -1171,6 +1062,85 @@ DEFUN_VOID (change_vm_protection) return; } +#include "option.h" + +#ifndef MODELS_FILENAME +#define MODELS_FILENAME "hppacach.mod" +#endif + +static struct pdc_cache_dump cache_info; + +static void +DEFUN_VOID (flush_i_cache_initialize) +{ + extern char * EXFUN (getenv, (const char *)); + CONST char * models_filename = + (search_path_for_file (0, MODELS_FILENAME, 1, 1)); + char * model; + + model = (getenv ("MITSCHEME_HPPA_MODEL")); + +#ifdef _HPUX + if (model == ((char *) NULL)) + { + struct utsname sysinfo; + if ((uname (&sysinfo)) < 0) + { + outf_fatal ("\nflush_i_cache: uname failed.\n"); + goto loser; + } + model = &sysinfo.machine[0]; + } +#endif /* _HPUX */ + if (model == ((char *) NULL)) + { + outf_fatal + ("\nflush_i_cache: MITSCHEME_HPPA_MODEL not set in environment.\n"); + goto loser; + } + { + int fd = (open (models_filename, O_RDONLY)); + if (fd < 0) + { + outf_fatal ("\nflush_i_cache: open (%s) failed.\n", + models_filename); + goto loser; + } + while (1) + { + int read_result = + (read (fd, + ((char *) (&cache_info)), + (sizeof (struct pdc_cache_dump)))); + if (read_result == 0) + { + close (fd); + break; + } + if (read_result != (sizeof (struct pdc_cache_dump))) + { + close (fd); + outf_fatal ("\nflush_i_cache: read (%s) failed.\n", + models_filename); + goto loser; + } + if ((strcmp (model, (cache_info . hardware))) == 0) + { + close (fd); + return; + } + } + } + outf_fatal ( + "The cache parameters database has no entry for the %s model.\n", + model); + outf_fatal ("Please make an entry in the database;\n"); + outf_fatal ("the installation notes contain instructions for doing so.\n"); + loser: + outf_fatal ("\nASM_RESET_HOOK: Unable to read cache parameters.\n"); + termination_init_error (); +} + /* This loads the cache information structure for use by flush_i_cache, sets the floating point flags correctly, and accommodates the c function pointer closure format problems for utilities for HP-UX >= 8.0 . @@ -1192,7 +1162,8 @@ DEFUN (hppa_reset_hook, (utility_length, utility_table), flush_i_cache_initialize (); interface_initialize (); change_vm_protection (); - hppa_closure_hook = (C_closure_entry_point ((unsigned long) cross_segment_call)); + hppa_closure_hook + = (C_closure_entry_point ((unsigned long) cross_segment_call)); hppa_utility_table = (transform_procedure_table (utility_length, utility_table)); return; @@ -1225,145 +1196,180 @@ DEFUN (hppa_grow_primitive_table, (new_size), int new_size) hppa_primitive_table = new_table; return (new_table != ((PTR *) NULL)); } - -#define DECLARE_CMPINTMD_UTILITIES() \ - UTLD(hppa_extract_absolute_address), \ - UTLD(hppa_store_absolute_address), \ - UTLD(flush_i_cache), \ - UTLD(push_d_cache_region), \ - UTLD(flush_i_cache_initialize), \ - UTLD(assemble_17), \ - UTLD(assemble_12), \ - UTLD(C_closure_entry_point), \ - UTLD(bkpt_init), \ - UTLD(alloc_bkpt_handle), \ - UTLD(bkpt_install), \ - UTLD(bkpt_closure_install), \ - UTLD(bkpt_remove), \ - UTLD(bkpt_p), \ - UTLD(do_bkpt_proceed), \ - UTLD(transform_procedure_entries), \ - UTLD(transform_procedure_table), \ - UTLD(change_vm_protection), \ - UTLD(hppa_reset_hook), \ - UTLD(hppa_update_primitive_table), \ - UTLD(hppa_grow_primitive_table) - -#endif /* IN_CMPINT_C */ -/* Derived parameters and macros. +/* + Note: The following does not do a full decoding of the BLE instruction. + It assumes that the bits have been set by STORE_ABSOLUTE_ADDRESS below, + which decomposes an absolute address according to the `short_pointer' + structure above, and thus certain fields are 0. - These macros expect the above definitions to be meaningful. - If they are not, the macros below may have to be changed as well. + The sequence inserted by STORE_ABSOLUTE_ADDRESS is approximately + (the actual address decomposition is given above). + LDIL L'ep,26 + BLE R'ep(5,26) */ -#define COMPILED_ENTRY_OFFSET_WORD(entry) \ - (((format_word *) (entry))[-1]) -#define COMPILED_ENTRY_FORMAT_WORD(entry) \ - (((format_word *) (entry))[-2]) +unsigned long +DEFUN (hppa_extract_absolute_address, (addr), unsigned long * addr) +{ + union short_pointer result; + union branch_inst ble; + union ldil_inst ldil; -/* The next one assumes 2's complement integers....*/ -#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) -#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) + ldil.inst = *addr++; + ble.inst = *addr; -#if (PC_ZERO_BITS == 0) -/* Instructions aligned on byte boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) >> 1) -#endif + /* Fill the padding */ + result.address = 0; -#if (PC_ZERO_BITS == 1) -/* Instructions aligned on word (16 bit) boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - (CLEAR_LOW_BIT(offset_word)) -#endif + result.fields.A = ldil.fields.A; + result.fields.B = ldil.fields.B; + result.fields.C = ldil.fields.C; + result.fields.D = ldil.fields.D; + result.fields.w2a = ble.fields.w2a; + result.fields.w2b = ble.fields.w2b; -#if (PC_ZERO_BITS >= 2) -/* Should be OK for =2, but bets are off for >2 because of problems - mentioned earlier! -*/ -#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) -#endif + return (result.address); +} -#define MAKE_OFFSET_WORD(entry, block, continue) \ - ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ - ((char *) (block)))) | \ - ((continue) ? 1 : 0)) +void +DEFUN (hppa_store_absolute_address, (addr, sourcev, nullify_p), + unsigned long * addr AND unsigned long sourcev + AND unsigned long nullify_p) +{ + union short_pointer source; + union ldil_inst ldil; + union branch_inst ble; -#if (EXECUTE_CACHE_ENTRY_SIZE == 2) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 1) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 1) -#endif + source.address = sourcev; -#if (EXECUTE_CACHE_ENTRY_SIZE == 4) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 2) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 2) +#if 0 + ldil.fields.opcode = 0x08; + ldil.fields.base = 26; + ldil.fields.E = 0; +#else + ldil.inst = ((0x08 << 26) | (26 << 21)); #endif -#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) / EXECUTE_CACHE_ENTRY_SIZE) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) * EXECUTE_CACHE_ENTRY_SIZE) + ldil.fields.A = source.fields.A; + ldil.fields.B = source.fields.B; + ldil.fields.C = source.fields.C; + ldil.fields.D = source.fields.D; + +#if 0 + ble.fields.opcode = 0x39; + ble.fields.t_or_b = 26; + ble.fields.x_or_w1 = 0; + ble.fields.s = 3; + ble.fields.w0 = 0; +#else + ble.inst = ((0x39 << 26) | (26 << 21) | (3 << 13)); #endif + + ble.fields.w2a = source.fields.w2a; + ble.fields.w2b = source.fields.w2b; + ble.fields.n = (nullify_p & 1); + + *addr++ = ldil.inst; + *addr = ble.inst; + return; +} -/* The first entry in a cc block is preceeded by 2 headers (block and nmv), - a format word and a gc offset word. See the early part of the - TRAMPOLINE picture, above. +/* Cache flushing/pushing code. + Uses routines from cmpaux-hppa.m4. */ -#define CC_BLOCK_FIRST_ENTRY_OFFSET \ - (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word)))) - -/* Format words */ +extern void + EXFUN (flush_i_cache, (void)), + EXFUN (push_d_cache_region, (PTR, unsigned long)); -#define FORMAT_BYTE_EXPR 0xFF -#define FORMAT_BYTE_COMPLR 0xFE -#define FORMAT_BYTE_CMPINT 0xFD -#define FORMAT_BYTE_DLINK 0xFC -#define FORMAT_BYTE_RETURN 0xFB +void +DEFUN_VOID (flush_i_cache) +{ + extern void + EXFUN (cache_flush_all, (unsigned int, struct pdc_cache_result *)); -#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR)) -#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT)) -#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN)) + struct pdc_cache_result * cache_desc; + + cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); -/* This assumes that a format word is at least 16 bits, - and the low order field is always 8 bits. - */ + /* The call can be interrupted in the middle of a set, so do it twice. + Probability of two interrupts in the same cache line is + exceedingly small, so this is likely to win. + On the other hand, if the caches are directly mapped, a single + call can't lose. + In addition, if the cache is shared, there is no need to flush at all. + */ -#define MAKE_FORMAT_WORD(field1, field2) \ - (((field1) << 8) | ((field2) & 0xff)) + if (((cache_desc->I_info.conf.bits.fsel & 1) == 0) + || ((cache_desc->D_info.conf.bits.fsel & 1) == 0)) + { + unsigned int flag = 0; -#define SIGN_EXTEND_FIELD(field, size) \ - (((field) & ((1 << (size)) - 1)) | \ - ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \ - ((-1) << (size)))) + if (cache_desc->I_info.loop != 1) + flag |= I_CACHE; + if (cache_desc->D_info.loop != 1) + flag |= D_CACHE; -#define FORMAT_WORD_LOW_BYTE(word) \ - (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8)) + if (flag != 0) + cache_flush_all (flag, cache_desc); + cache_flush_all ((D_CACHE | I_CACHE), cache_desc); + } +} -#define FORMAT_WORD_HIGH_BYTE(word) \ - (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \ - (((sizeof (format_word)) * CHAR_BIT) - 8))) +void +DEFUN (push_d_cache_region, (start_address, block_size), + PTR start_address AND unsigned long block_size) +{ + extern void + EXFUN (cache_flush_region, (PTR, long, unsigned int)); -#define COMPILED_ENTRY_FORMAT_HIGH(addr) \ - (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) + struct pdc_cache_result * cache_desc; + + cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); -#define COMPILED_ENTRY_FORMAT_LOW(addr) \ - (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) + /* Note that the first and last words are also flushed from the I-cache + in case this object is adjacent to another that has already caused + the cache line to be copied into the I-cache. + */ -#define FORMAT_BYTE_FRAMEMAX 0x7f + if (((cache_desc->I_info.conf.bits.fsel & 1) == 0) + || ((cache_desc->D_info.conf.bits.fsel & 1) == 0)) + { + cache_flush_region (start_address, block_size, D_CACHE); + cache_flush_region (start_address, 1, I_CACHE); + cache_flush_region (((PTR) + (((unsigned long *) start_address) + + (block_size - 1))), + 1, + I_CACHE); + } + return; +} + +#define DECLARE_CMPINTMD_UTILITIES() \ + UTLD (assemble_17), \ + UTLD (assemble_12), \ + UTLD (C_closure_entry_point), \ + UTLD (bkpt_init), \ + UTLD (alloc_bkpt_handle), \ + UTLD (bkpt_install), \ + UTLD (bkpt_closure_install), \ + UTLD (bkpt_remove), \ + UTLD (bkpt_p), \ + UTLD (do_bkpt_proceed), \ + UTLD (transform_procedure_entries), \ + UTLD (transform_procedure_table), \ + UTLD (change_vm_protection), \ + UTLD (hppa_reset_hook), \ + UTLD (hppa_update_primitive_table), \ + UTLD (hppa_grow_primitive_table), \ + UTLD (hppa_extract_absolute_address), \ + UTLD (hppa_store_absolute_address), \ + UTLD (flush_i_cache), \ + UTLD (push_d_cache_region), \ + UTLD (flush_i_cache_initialize) -#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW -#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH +#endif /* IN_CMPINT_C */ #endif /* CMPINTMD_H_INCLUDED */ diff --git a/v8/src/microcode/cmpintmd/hppa.h b/v8/src/microcode/cmpintmd/hppa.h index 61dbd9226..0484d97c0 100644 --- a/v8/src/microcode/cmpintmd/hppa.h +++ b/v8/src/microcode/cmpintmd/hppa.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: hppa.h,v 1.47 1993/11/11 06:01:54 gjr Exp $ +$Id: hppa.h,v 1.48 1993/12/07 20:31:16 gjr Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -45,6 +45,7 @@ MIT in each case. */ #define CMPINTMD_H_INCLUDED #include "cmptype.h" +#include "hppacach.h" /* Machine parameters to be set by the user. */ @@ -113,414 +114,123 @@ extern void ((unsigned long) (nullify_p))); \ } -#ifdef IN_CMPINT_C +/* Interrupt/GC polling. */ -/* Definitions of the utility procedures. - Procedure calls of leaf procedures on the HPPA are pretty fast, - so there is no reason not to do this out of line. - In this way compiled code can use them too. +/* The length of the GC recovery code that precedes an entry. + On the HP-PA a "ble, ldi" instruction sequence. */ -union ldil_inst -{ - unsigned long inst; - struct - { - unsigned opcode : 6; - unsigned base : 5; - unsigned D : 5; - unsigned C : 2; - unsigned E : 2; - unsigned B : 11; - unsigned A : 1; - } fields; -}; - -union branch_inst -{ - unsigned long inst; - struct - { - unsigned opcode : 6; - unsigned t_or_b : 5; - unsigned x_or_w1 : 5; - unsigned s : 3; - unsigned w2b : 10; - unsigned w2a : 1; - unsigned n : 1; - unsigned w0 : 1; - } fields; -}; +#define ENTRY_PREFIX_LENGTH 8 -union short_pointer -{ - unsigned long address; - struct - { - unsigned A : 1; - unsigned B : 11; - unsigned C : 2; - unsigned D : 5; - unsigned w2a : 1; - unsigned w2b : 10; - unsigned pad : 2; - } fields; -}; - /* - Note: The following does not do a full decoding of the BLE instruction. - It assumes that the bits have been set by STORE_ABSOLUTE_ADDRESS below, - which decomposes an absolute address according to the `short_pointer' - structure above, and thus certain fields are 0. + The instructions for a normal entry should be something like - The sequence inserted by STORE_ABSOLUTE_ADDRESS is approximately - (the actual address decomposition is given above). - LDIL L'ep,26 - BLE R'ep(5,26) - */ + COMBT,>=,N Rfree,Rmemtop,interrupt + LDW 0(0,Regs),Rmemtop -unsigned long -DEFUN (hppa_extract_absolute_address, (addr), unsigned long * addr) -{ - union short_pointer result; - union branch_inst ble; - union ldil_inst ldil; + For a closure - ldil.inst = *addr++; - ble.inst = *addr; + DEPI tc_closure>>1,4,5,25 ; set type code + STWM 25,-4(0,Rstack) ; push on stack + COMB,>= Rfree,Rmemtop,interrupt ; GC/interrupt check + LDW 0(0,Regs),Rmemtop ; Recache memtop - /* Fill the padding */ - result.address = 0; + Notes: - result.fields.A = ldil.fields.A; - result.fields.B = ldil.fields.B; - result.fields.C = ldil.fields.C; - result.fields.D = ldil.fields.D; - result.fields.w2a = ble.fields.w2a; - result.fields.w2b = ble.fields.w2b; + The LDW can be eliminated once the C interrupt handler is changed to + update Rmemtop directly. At that point, the instruction following the + COMB instruction will have to be nullified whenever the interrupt + branch is processed. - return (result.address); -} + */ -void -DEFUN (hppa_store_absolute_address, (addr, sourcev, nullify_p), - unsigned long * addr AND unsigned long sourcev - AND unsigned long nullify_p) -{ - union short_pointer source; - union ldil_inst ldil; - union branch_inst ble; +/* Compiled closures */ - source.address = sourcev; +/* Manifest closure entry block size. + Size in bytes of a compiled closure's header excluding the + TC_MANIFEST_CLOSURE header. -#if 0 - ldil.fields.opcode = 0x08; - ldil.fields.base = 26; - ldil.fields.E = 0; -#else - ldil.inst = ((0x08 << 26) | (26 << 21)); -#endif + On the PA this is 2 format_words for the format word and gc + offset words, and 12 more bytes for 3 instructions: - ldil.fields.A = source.fields.A; - ldil.fields.B = source.fields.B; - ldil.fields.C = source.fields.C; - ldil.fields.D = source.fields.D; + LDIL L'target,26 + BLE R'target(5,26) + ADDI -15,31,25 ; handle privilege bits + */ -#if 0 - ble.fields.opcode = 0x39; - ble.fields.t_or_b = 26; - ble.fields.x_or_w1 = 0; - ble.fields.s = 3; - ble.fields.w0 = 0; -#else - ble.inst = ((0x39 << 26) | (26 << 21) | (3 << 13)); -#endif +#define COMPILED_CLOSURE_ENTRY_SIZE 16 - ble.fields.w2a = source.fields.w2a; - ble.fields.w2b = source.fields.w2b; - ble.fields.n = (nullify_p & 1); +/* Manifest closure entry destructuring. - *addr++ = ldil.inst; - *addr = ble.inst; - return; + Given the entry point of a closure, extract the `real entry point' + (the address of the real code of the procedure, ie. one indirection) + from the closure. + On the PA, the real entry point is "smeared out" over the LDIL and + the BLE instructions. +*/ + +#define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \ +{ \ + EXTRACT_ABSOLUTE_ADDRESS (real_entry_point, entry_point); \ } - -/* Cache flushing/pushing code. - Uses routines from cmpaux-hppa.m4. - */ -#include "hppacach.h" -#include "option.h" +/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS. + Given a closure's entry point and a code entry point, store the + code entry point in the closure. + */ -static struct pdc_cache_dump cache_info; +#define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \ +{ \ + STORE_ABSOLUTE_ADDRESS (real_entry_point, entry_point, false); \ +} + +/* Trampolines -extern void - EXFUN (flush_i_cache, (void)), - EXFUN (push_d_cache_region, (PTR, unsigned long)); + Here's a picture of a trampoline on the PA (offset in bytes from + entry point) -void -DEFUN_VOID (flush_i_cache) -{ - extern void - EXFUN (cache_flush_all, (unsigned int, struct pdc_cache_result *)); + -12: MANIFEST vector header + - 8: NON_MARKED header + - 4: Format word + - 2: 0xC (GC Offset to start of block from .+2) + 0: BLE 4(4,3) ; call trampoline_to_interface + 4: LDI index,28 + 8: trampoline dependent storage (0 - 3 longwords) - struct pdc_cache_result * cache_desc; - - cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); + TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine + dependent portion of a trampoline, including the GC and format + headers. The code in the trampoline must store an index (used to + determine which C SCHEME_UTILITY procedure to invoke) in a + register, jump to "scheme_to_interface" and leave the address of + the storage following the code in a standard location. - /* The call can be interrupted in the middle of a set, so do it twice. - Probability of two interrupts in the same cache line is - exceedingly small, so this is likely to win. - On the other hand, if the caches are directly mapped, a single - call can't lose. - In addition, if the cache is shared, there is no need to flush at all. - */ + TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a + trampoline when given the address of the word containing + the manifest vector header. According to the above picture, + it would add 12 bytes to its argument. - if (((cache_desc->I_info.conf.bits.fsel & 1) == 0) - || ((cache_desc->D_info.conf.bits.fsel & 1) == 0)) - { - unsigned int flag = 0; + TRAMPOLINE_STORAGE takes the address of the first instruction in a + trampoline (not the start of the trampoline block) and returns the + address of the first storage word in the trampoline. - if (cache_desc->I_info.loop != 1) - flag |= I_CACHE; - if (cache_desc->D_info.loop != 1) - flag |= D_CACHE; + STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in + the trampoline and stores the instructions. It also receives the + index of the C SCHEME_UTILITY to be invoked. - if (flag != 0) - cache_flush_all (flag, cache_desc); - cache_flush_all ((D_CACHE | I_CACHE), cache_desc); - } -} + Note: this flushes both caches because the words may fall in a cache + line that already has an association in the i-cache because a different + trampoline or a closure are in it. +*/ -void -DEFUN (push_d_cache_region, (start_address, block_size), - PTR start_address AND unsigned long block_size) -{ - extern void - EXFUN (cache_flush_region, (PTR, long, unsigned int)); +#define TRAMPOLINE_ENTRY_SIZE 3 +#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* longwords from MNV to BLE */ - struct pdc_cache_result * cache_desc; - - cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); +#define TRAMPOLINE_ENTRY_POINT(tramp_block) \ + (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY) - /* Note that the first and last words are also flushed from the I-cache - in case this object is adjacent to another that has already caused - the cache line to be copied into the I-cache. - */ - - if (((cache_desc->I_info.conf.bits.fsel & 1) == 0) - || ((cache_desc->D_info.conf.bits.fsel & 1) == 0)) - { - cache_flush_region (start_address, block_size, D_CACHE); - cache_flush_region (start_address, 1, I_CACHE); - cache_flush_region (((PTR) - (((unsigned long *) start_address) - + (block_size - 1))), - 1, - I_CACHE); - } - return; -} - -#ifndef MODELS_FILENAME -#define MODELS_FILENAME "hppacach.mod" -#endif - -static void -DEFUN_VOID (flush_i_cache_initialize) -{ - extern char * EXFUN (getenv, (const char *)); - CONST char * models_filename = - (search_path_for_file (0, MODELS_FILENAME, 1, 1)); - char * model; - - model = (getenv ("MITSCHEME_HPPA_MODEL")); - -#ifdef _HPUX - if (model == ((char *) NULL)) - { - struct utsname sysinfo; - if ((uname (&sysinfo)) < 0) - { - outf_fatal ("\nflush_i_cache: uname failed.\n"); - goto loser; - } - model = &sysinfo.machine[0]; - } -#endif /* _HPUX */ - if (model == ((char *) NULL)) - { - outf_fatal - ("\nflush_i_cache: MITSCHEME_HPPA_MODEL not set in environment.\n"); - goto loser; - } - { - int fd = (open (models_filename, O_RDONLY)); - if (fd < 0) - { - outf_fatal ("\nflush_i_cache: open (%s) failed.\n", - models_filename); - goto loser; - } - while (1) - { - int read_result = - (read (fd, - ((char *) (&cache_info)), - (sizeof (struct pdc_cache_dump)))); - if (read_result == 0) - { - close (fd); - break; - } - if (read_result != (sizeof (struct pdc_cache_dump))) - { - close (fd); - outf_fatal ("\nflush_i_cache: read (%s) failed.\n", - models_filename); - goto loser; - } - if ((strcmp (model, (cache_info . hardware))) == 0) - { - close (fd); - return; - } - } - } - outf_fatal ( - "The cache parameters database has no entry for the %s model.\n", - model); - outf_fatal ("Please make an entry in the database;\n"); - outf_fatal ("the installation notes contain instructions for doing so.\n"); - loser: - outf_fatal ("\nASM_RESET_HOOK: Unable to read cache parameters.\n"); - termination_init_error (); -} - -#endif /* IN_CMPINT_C */ - -/* Interrupt/GC polling. */ - -/* The length of the GC recovery code that precedes an entry. - On the HP-PA a "ble, ldi" instruction sequence. - */ - -#define ENTRY_PREFIX_LENGTH 8 - -/* - The instructions for a normal entry should be something like - - COMBT,>=,N Rfree,Rmemtop,interrupt - LDW 0(0,Regs),Rmemtop - - For a closure - - DEP 0,31,2,31 ; clear privilege bits - DEPI tc_closure>>1,4,5,31 ; set type code - STWM 31,-4(0,Rstack) ; push on stack - COMB,>= Rfree,Rmemtop,interrupt ; GC/interrupt check - LDW 0(0,Regs),Rmemtop ; Recache memtop - - Notes: - - The LDW can be eliminated once the C interrupt handler is changed to - update Rmemtop directly. At that point, the instruction following the - COMB instruction will have to be nullified whenever the interrupt - branch is processed. - - The DEP can be eliminated if we assume that the privilege bits will always - be the same (3). The clearing can be combined with the ADDI instruction in - the closure object itself. - - */ - -/* Compiled closures */ - -/* Manifest closure entry block size. - Size in bytes of a compiled closure's header excluding the - TC_MANIFEST_CLOSURE header. - - On the PA this is 2 format_words for the format word and gc - offset words, and 12 more bytes for 3 instructions: - - LDIL L'target,26 - BLE R'target(5,26) - ADDI -12,31,31 - */ - -#define COMPILED_CLOSURE_ENTRY_SIZE 16 - -/* Manifest closure entry destructuring. - - Given the entry point of a closure, extract the `real entry point' - (the address of the real code of the procedure, ie. one indirection) - from the closure. - On the PA, the real entry point is "smeared out" over the LDIL and - the BLE instructions. -*/ - -#define EXTRACT_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \ -{ \ - EXTRACT_ABSOLUTE_ADDRESS(real_entry_point, entry_point); \ -} - -/* This is the inverse of EXTRACT_CLOSURE_ENTRY_ADDRESS. - Given a closure's entry point and a code entry point, store the - code entry point in the closure. - */ - -#define STORE_CLOSURE_ENTRY_ADDRESS(real_entry_point, entry_point) \ -{ \ - STORE_ABSOLUTE_ADDRESS(real_entry_point, entry_point, false); \ -} - -/* Trampolines - - Here's a picture of a trampoline on the PA (offset in bytes from - entry point) - - -12: MANIFEST vector header - - 8: NON_MARKED header - - 4: Format word - - 2: 0xC (GC Offset to start of block from .+2) - 0: BLE 4(4,3) ; call trampoline_to_interface - 4: LDI index,28 - 8: trampoline dependent storage (0 - 3 longwords) - - TRAMPOLINE_ENTRY_SIZE is the size in longwords of the machine - dependent portion of a trampoline, including the GC and format - headers. The code in the trampoline must store an index (used to - determine which C SCHEME_UTILITY procedure to invoke) in a - register, jump to "scheme_to_interface" and leave the address of - the storage following the code in a standard location. - - TRAMPOLINE_ENTRY_POINT returns the address of the entry point of a - trampoline when given the address of the word containing - the manifest vector header. According to the above picture, - it would add 12 bytes to its argument. - - TRAMPOLINE_STORAGE takes the address of the first instruction in a - trampoline (not the start of the trampoline block) and returns the - address of the first storage word in the trampoline. - - STORE_TRAMPOLINE_ENTRY gets the address of the first instruction in - the trampoline and stores the instructions. It also receives the - index of the C SCHEME_UTILITY to be invoked. - - Note: this flushes both caches because the words may fall in a cache - line that already has an association in the i-cache because a different - trampoline or a closure are in it. -*/ - -#define TRAMPOLINE_ENTRY_SIZE 3 -#define TRAMPOLINE_BLOCK_TO_ENTRY 3 /* longwords from MNV to BLE */ - -#define TRAMPOLINE_ENTRY_POINT(tramp_block) \ - (((SCHEME_OBJECT *) (tramp_block)) + TRAMPOLINE_BLOCK_TO_ENTRY) - -#define TRAMPOLINE_STORAGE(tramp_entry) \ - ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ - (2 + TRAMPOLINE_ENTRY_SIZE)) +#define TRAMPOLINE_STORAGE(tramp_entry) \ + ((((SCHEME_OBJECT *) (tramp_entry)) - TRAMPOLINE_BLOCK_TO_ENTRY) + \ + (2 + TRAMPOLINE_ENTRY_SIZE)) #define STORE_TRAMPOLINE_ENTRY(entry_address, index) do \ { \ @@ -709,57 +419,218 @@ extern Boolean EXFUN (hppa_grow_primitive_table, (int)); */ #define SPLIT_CACHES - -#ifdef IN_CMPINT_C -union assemble_17_u -{ - long value; - struct - { - int sign_pad : 13; - unsigned w0 : 1; - unsigned w1 : 5; - unsigned w2a : 1; - unsigned w2b : 10; - unsigned pad : 2; - } fields; -}; +/* Derived parameters and macros. -union assemble_12_u -{ - long value; - struct - { - int sign_pad : 18; - unsigned w0 : 1; - unsigned w2a : 1; - unsigned w2b : 10; - unsigned pad : 2; - } fields; -}; + These macros expect the above definitions to be meaningful. + If they are not, the macros below may have to be changed as well. + */ -long -DEFUN (assemble_17, (inst), union branch_inst inst) -{ - union assemble_17_u off; +#define COMPILED_ENTRY_OFFSET_WORD(entry) \ + (((format_word *) (entry))[-1]) +#define COMPILED_ENTRY_FORMAT_WORD(entry) \ + (((format_word *) (entry))[-2]) - off.fields.pad = 0; - off.fields.w2b = inst.fields.w2b; - off.fields.w2a = inst.fields.w2a; - off.fields.w1 = inst.fields.x_or_w1; - off.fields.w0 = inst.fields.w0; - off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1); - return (off.value); -} +/* The next one assumes 2's complement integers....*/ +#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) +#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) -long -DEFUN (assemble_12, (inst), union branch_inst inst) -{ - union assemble_12_u off; +#if (PC_ZERO_BITS == 0) +/* Instructions aligned on byte boundaries */ +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + ((CLEAR_LOW_BIT(offset_word)) >> 1) +#endif - off.fields.pad = 0; - off.fields.w2b = inst.fields.w2b; +#if (PC_ZERO_BITS == 1) +/* Instructions aligned on word (16 bit) boundaries */ +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + (CLEAR_LOW_BIT(offset_word)) +#endif + +#if (PC_ZERO_BITS >= 2) +/* Should be OK for =2, but bets are off for >2 because of problems + mentioned earlier! +*/ +#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) +#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) +#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ + ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) +#endif + +#define MAKE_OFFSET_WORD(entry, block, continue) \ + ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ + ((char *) (block)))) | \ + ((continue) ? 1 : 0)) + +#if (EXECUTE_CACHE_ENTRY_SIZE == 2) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) >> 1) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) << 1) +#endif + +#if (EXECUTE_CACHE_ENTRY_SIZE == 4) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) >> 2) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) << 2) +#endif + +#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) +#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ + ((count) / EXECUTE_CACHE_ENTRY_SIZE) +#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ + ((entries) * EXECUTE_CACHE_ENTRY_SIZE) +#endif + +/* The first entry in a cc block is preceeded by 2 headers (block and nmv), + a format word and a gc offset word. See the early part of the + TRAMPOLINE picture, above. + */ + +#define CC_BLOCK_FIRST_ENTRY_OFFSET \ + (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word)))) + +#ifndef FORMAT_BYTE_CLOSURE +#define FORMAT_BYTE_CLOSURE 0xFA +#endif + +#ifndef FORMAT_WORD_CLOSURE +#define FORMAT_WORD_CLOSURE (MAKE_FORMAT_WORD (0xFF, FORMAT_BYTE_CLOSURE)) +#endif + +/* This assumes that a format word is at least 16 bits, + and the low order field is always 8 bits. + */ + +#define MAKE_FORMAT_WORD(field1, field2) \ + (((field1) << 8) | ((field2) & 0xff)) + +#define SIGN_EXTEND_FIELD(field, size) \ + (((field) & ((1 << (size)) - 1)) | \ + ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \ + ((-1) << (size)))) + +#define FORMAT_WORD_LOW_BYTE(word) \ + (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8)) + +#define FORMAT_WORD_HIGH_BYTE(word) \ + (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \ + (((sizeof (format_word)) * CHAR_BIT) - 8))) + +#define COMPILED_ENTRY_FORMAT_HIGH(addr) \ + (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) + +#define COMPILED_ENTRY_FORMAT_LOW(addr) \ + (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) + +#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW +#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH + +#ifdef IN_CMPINT_C + +/* Definitions of the utility procedures. + Procedure calls of leaf procedures on the HPPA are pretty fast, + so there is no reason not to do this out of line. + In this way compiled code can use them too. + */ + +union ldil_inst +{ + unsigned long inst; + struct + { + unsigned opcode : 6; + unsigned base : 5; + unsigned D : 5; + unsigned C : 2; + unsigned E : 2; + unsigned B : 11; + unsigned A : 1; + } fields; +}; + +union branch_inst +{ + unsigned long inst; + struct + { + unsigned opcode : 6; + unsigned t_or_b : 5; + unsigned x_or_w1 : 5; + unsigned s : 3; + unsigned w2b : 10; + unsigned w2a : 1; + unsigned n : 1; + unsigned w0 : 1; + } fields; +}; + +union short_pointer +{ + unsigned long address; + struct + { + unsigned A : 1; + unsigned B : 11; + unsigned C : 2; + unsigned D : 5; + unsigned w2a : 1; + unsigned w2b : 10; + unsigned pad : 2; + } fields; +}; + +union assemble_17_u +{ + long value; + struct + { + int sign_pad : 13; + unsigned w0 : 1; + unsigned w1 : 5; + unsigned w2a : 1; + unsigned w2b : 10; + unsigned pad : 2; + } fields; +}; + +union assemble_12_u +{ + long value; + struct + { + int sign_pad : 18; + unsigned w0 : 1; + unsigned w2a : 1; + unsigned w2b : 10; + unsigned pad : 2; + } fields; +}; + +long +DEFUN (assemble_17, (inst), union branch_inst inst) +{ + union assemble_17_u off; + + off.fields.pad = 0; + off.fields.w2b = inst.fields.w2b; + off.fields.w2a = inst.fields.w2a; + off.fields.w1 = inst.fields.x_or_w1; + off.fields.w0 = inst.fields.w0; + off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1); + return (off.value); +} + +long +DEFUN (assemble_12, (inst), union branch_inst inst) +{ + union assemble_12_u off; + + off.fields.pad = 0; + off.fields.w2b = inst.fields.w2b; off.fields.w2a = inst.fields.w2a; off.fields.w0 = inst.fields.w0; off.fields.sign_pad = ((inst.fields.w0 == 0) ? 0 : -1); @@ -803,6 +674,7 @@ static Boolean static unsigned long bkpt_instruction, closure_bkpt_instruction, + closure_entry_bkpt_instruction, * bkpt_normal_proceed_thunk, * bkpt_plus_proceed_thunk, * bkpt_minus_proceed_thunk_start, @@ -813,7 +685,7 @@ static unsigned long #define FAHRENHEIT 451 static void -DEFUN_VOID(bkpt_init) +DEFUN_VOID (bkpt_init) { int i; union branch_inst instr; @@ -845,9 +717,11 @@ DEFUN_VOID(bkpt_init) bkpt_instruction = instr.inst; + instr.fields.w2b = ((FAHRENHEIT + 33) >> 2); + closure_entry_bkpt_instruction = instr.inst; + instr.fields.opcode = 0x38; /* BE opcode */ instr.fields.w2b = ((FAHRENHEIT + 9) >> 2); - closure_bkpt_instruction = instr.inst; bkpt_normal_proceed_thunk @@ -876,6 +750,7 @@ DEFUN_VOID(bkpt_init) #define BKPT_KIND_PC_REL_BRANCH 2 #define BKPT_KIND_BL_INST 3 #define BKPT_KIND_BLE_INST 4 +#define BKPT_KIND_CLOSURE_ENTRY 5 extern void EXFUN (cache_flush_region, (PTR, long, unsigned int)); @@ -904,8 +779,15 @@ DEFUN (bkpt_install, (entry_point), PTR entry_point) SCHEME_OBJECT handle; unsigned long first_instr = (* ((unsigned long *) entry_point)); unsigned short opcode = ((first_instr >> 26) & 0x3f); + unsigned long new_instr = bkpt_instruction; - if ((! (branch_opcode_table[opcode])) || (opcode == 0x38)) + if ((COMPILED_ENTRY_FORMAT_WORD (entry_point)) == FORMAT_WORD_CLOSURE) + { + /* This assumes that the first instruction is normal */ + kind = BKPT_KIND_CLOSURE_ENTRY; + new_instr = closure_entry_bkpt_instruction; + } + else if ((! (branch_opcode_table[opcode])) || (opcode == 0x38)) kind = BKPT_KIND_NORMAL; /* BE instr included */ else if (opcode == 0x39) #if 0 @@ -956,7 +838,7 @@ DEFUN (bkpt_install, (entry_point), PTR entry_point) handle = (alloc_bkpt_handle (kind, first_instr, entry_point)); - (* ((unsigned long *) entry_point)) = bkpt_instruction; + (* ((unsigned long *) entry_point)) = new_instr; cache_flush_region (((PTR) entry_point), 1, (D_CACHE | I_CACHE)); return (handle); @@ -981,7 +863,8 @@ DEFUN (bkpt_remove, (entry_point, handle), int offset; unsigned long * instrs = ((unsigned long *) entry_point); - if (instrs[0] == bkpt_instruction) + if ((instrs[0] == bkpt_instruction) + || (instrs[0] == closure_entry_bkpt_instruction)) offset = 0; else if (instrs[2] == closure_bkpt_instruction) offset = 2; @@ -999,6 +882,7 @@ DEFUN (bkpt_p, (entry_point), PTR entry_point) unsigned long * instrs = ((unsigned long *) entry_point); return ((instrs[0] == bkpt_instruction) + || (instrs[0] == closure_entry_bkpt_instruction) || (instrs[2] == closure_bkpt_instruction)); } @@ -1034,7 +918,7 @@ DEFUN (do_bkpt_proceed, (value), unsigned long * value) * value = ((unsigned long) buffer); return (TRUE); } - + case BKPT_KIND_NORMAL: { int i, len; @@ -1052,6 +936,13 @@ DEFUN (do_bkpt_proceed, (value), unsigned long * value) * value = ((unsigned long) buffer); return (TRUE); } + + case BKPT_KIND_CLOSURE_ENTRY: + { + STACK_PUSH (state); /* closure object */ + * value = ((unsigned long) ((OBJECT_ADDRESS (ep)) + 2)); + return (TRUE); + } case BKPT_KIND_BL_INST: case BKPT_KIND_BLE_INST: @@ -1171,6 +1062,85 @@ DEFUN_VOID (change_vm_protection) return; } +#include "option.h" + +#ifndef MODELS_FILENAME +#define MODELS_FILENAME "hppacach.mod" +#endif + +static struct pdc_cache_dump cache_info; + +static void +DEFUN_VOID (flush_i_cache_initialize) +{ + extern char * EXFUN (getenv, (const char *)); + CONST char * models_filename = + (search_path_for_file (0, MODELS_FILENAME, 1, 1)); + char * model; + + model = (getenv ("MITSCHEME_HPPA_MODEL")); + +#ifdef _HPUX + if (model == ((char *) NULL)) + { + struct utsname sysinfo; + if ((uname (&sysinfo)) < 0) + { + outf_fatal ("\nflush_i_cache: uname failed.\n"); + goto loser; + } + model = &sysinfo.machine[0]; + } +#endif /* _HPUX */ + if (model == ((char *) NULL)) + { + outf_fatal + ("\nflush_i_cache: MITSCHEME_HPPA_MODEL not set in environment.\n"); + goto loser; + } + { + int fd = (open (models_filename, O_RDONLY)); + if (fd < 0) + { + outf_fatal ("\nflush_i_cache: open (%s) failed.\n", + models_filename); + goto loser; + } + while (1) + { + int read_result = + (read (fd, + ((char *) (&cache_info)), + (sizeof (struct pdc_cache_dump)))); + if (read_result == 0) + { + close (fd); + break; + } + if (read_result != (sizeof (struct pdc_cache_dump))) + { + close (fd); + outf_fatal ("\nflush_i_cache: read (%s) failed.\n", + models_filename); + goto loser; + } + if ((strcmp (model, (cache_info . hardware))) == 0) + { + close (fd); + return; + } + } + } + outf_fatal ( + "The cache parameters database has no entry for the %s model.\n", + model); + outf_fatal ("Please make an entry in the database;\n"); + outf_fatal ("the installation notes contain instructions for doing so.\n"); + loser: + outf_fatal ("\nASM_RESET_HOOK: Unable to read cache parameters.\n"); + termination_init_error (); +} + /* This loads the cache information structure for use by flush_i_cache, sets the floating point flags correctly, and accommodates the c function pointer closure format problems for utilities for HP-UX >= 8.0 . @@ -1192,7 +1162,8 @@ DEFUN (hppa_reset_hook, (utility_length, utility_table), flush_i_cache_initialize (); interface_initialize (); change_vm_protection (); - hppa_closure_hook = (C_closure_entry_point ((unsigned long) cross_segment_call)); + hppa_closure_hook + = (C_closure_entry_point ((unsigned long) cross_segment_call)); hppa_utility_table = (transform_procedure_table (utility_length, utility_table)); return; @@ -1225,145 +1196,180 @@ DEFUN (hppa_grow_primitive_table, (new_size), int new_size) hppa_primitive_table = new_table; return (new_table != ((PTR *) NULL)); } - -#define DECLARE_CMPINTMD_UTILITIES() \ - UTLD(hppa_extract_absolute_address), \ - UTLD(hppa_store_absolute_address), \ - UTLD(flush_i_cache), \ - UTLD(push_d_cache_region), \ - UTLD(flush_i_cache_initialize), \ - UTLD(assemble_17), \ - UTLD(assemble_12), \ - UTLD(C_closure_entry_point), \ - UTLD(bkpt_init), \ - UTLD(alloc_bkpt_handle), \ - UTLD(bkpt_install), \ - UTLD(bkpt_closure_install), \ - UTLD(bkpt_remove), \ - UTLD(bkpt_p), \ - UTLD(do_bkpt_proceed), \ - UTLD(transform_procedure_entries), \ - UTLD(transform_procedure_table), \ - UTLD(change_vm_protection), \ - UTLD(hppa_reset_hook), \ - UTLD(hppa_update_primitive_table), \ - UTLD(hppa_grow_primitive_table) - -#endif /* IN_CMPINT_C */ -/* Derived parameters and macros. +/* + Note: The following does not do a full decoding of the BLE instruction. + It assumes that the bits have been set by STORE_ABSOLUTE_ADDRESS below, + which decomposes an absolute address according to the `short_pointer' + structure above, and thus certain fields are 0. - These macros expect the above definitions to be meaningful. - If they are not, the macros below may have to be changed as well. + The sequence inserted by STORE_ABSOLUTE_ADDRESS is approximately + (the actual address decomposition is given above). + LDIL L'ep,26 + BLE R'ep(5,26) */ -#define COMPILED_ENTRY_OFFSET_WORD(entry) \ - (((format_word *) (entry))[-1]) -#define COMPILED_ENTRY_FORMAT_WORD(entry) \ - (((format_word *) (entry))[-2]) +unsigned long +DEFUN (hppa_extract_absolute_address, (addr), unsigned long * addr) +{ + union short_pointer result; + union branch_inst ble; + union ldil_inst ldil; -/* The next one assumes 2's complement integers....*/ -#define CLEAR_LOW_BIT(word) ((word) & ((unsigned long) -2)) -#define OFFSET_WORD_CONTINUATION_P(word) (((word) & 1) != 0) + ldil.inst = *addr++; + ble.inst = *addr; -#if (PC_ZERO_BITS == 0) -/* Instructions aligned on byte boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) << 1) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) >> 1) -#endif + /* Fill the padding */ + result.address = 0; -#if (PC_ZERO_BITS == 1) -/* Instructions aligned on word (16 bit) boundaries */ -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) (offset) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - (CLEAR_LOW_BIT(offset_word)) -#endif + result.fields.A = ldil.fields.A; + result.fields.B = ldil.fields.B; + result.fields.C = ldil.fields.C; + result.fields.D = ldil.fields.D; + result.fields.w2a = ble.fields.w2a; + result.fields.w2b = ble.fields.w2b; -#if (PC_ZERO_BITS >= 2) -/* Should be OK for =2, but bets are off for >2 because of problems - mentioned earlier! -*/ -#define SHIFT_AMOUNT (PC_ZERO_BITS - 1) -#define BYTE_OFFSET_TO_OFFSET_WORD(offset) ((offset) >> (SHIFT_AMOUNT)) -#define OFFSET_WORD_TO_BYTE_OFFSET(offset_word) \ - ((CLEAR_LOW_BIT(offset_word)) << (SHIFT_AMOUNT)) -#endif + return (result.address); +} -#define MAKE_OFFSET_WORD(entry, block, continue) \ - ((BYTE_OFFSET_TO_OFFSET_WORD(((char *) (entry)) - \ - ((char *) (block)))) | \ - ((continue) ? 1 : 0)) +void +DEFUN (hppa_store_absolute_address, (addr, sourcev, nullify_p), + unsigned long * addr AND unsigned long sourcev + AND unsigned long nullify_p) +{ + union short_pointer source; + union ldil_inst ldil; + union branch_inst ble; -#if (EXECUTE_CACHE_ENTRY_SIZE == 2) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 1) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 1) -#endif + source.address = sourcev; -#if (EXECUTE_CACHE_ENTRY_SIZE == 4) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) >> 2) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) << 2) +#if 0 + ldil.fields.opcode = 0x08; + ldil.fields.base = 26; + ldil.fields.E = 0; +#else + ldil.inst = ((0x08 << 26) | (26 << 21)); #endif -#if (!defined(EXECUTE_CACHE_COUNT_TO_ENTRIES)) -#define EXECUTE_CACHE_COUNT_TO_ENTRIES(count) \ - ((count) / EXECUTE_CACHE_ENTRY_SIZE) -#define EXECUTE_CACHE_ENTRIES_TO_COUNT(entries) \ - ((entries) * EXECUTE_CACHE_ENTRY_SIZE) + ldil.fields.A = source.fields.A; + ldil.fields.B = source.fields.B; + ldil.fields.C = source.fields.C; + ldil.fields.D = source.fields.D; + +#if 0 + ble.fields.opcode = 0x39; + ble.fields.t_or_b = 26; + ble.fields.x_or_w1 = 0; + ble.fields.s = 3; + ble.fields.w0 = 0; +#else + ble.inst = ((0x39 << 26) | (26 << 21) | (3 << 13)); #endif + + ble.fields.w2a = source.fields.w2a; + ble.fields.w2b = source.fields.w2b; + ble.fields.n = (nullify_p & 1); + + *addr++ = ldil.inst; + *addr = ble.inst; + return; +} -/* The first entry in a cc block is preceeded by 2 headers (block and nmv), - a format word and a gc offset word. See the early part of the - TRAMPOLINE picture, above. +/* Cache flushing/pushing code. + Uses routines from cmpaux-hppa.m4. */ -#define CC_BLOCK_FIRST_ENTRY_OFFSET \ - (2 * ((sizeof(SCHEME_OBJECT)) + (sizeof(format_word)))) - -/* Format words */ +extern void + EXFUN (flush_i_cache, (void)), + EXFUN (push_d_cache_region, (PTR, unsigned long)); -#define FORMAT_BYTE_EXPR 0xFF -#define FORMAT_BYTE_COMPLR 0xFE -#define FORMAT_BYTE_CMPINT 0xFD -#define FORMAT_BYTE_DLINK 0xFC -#define FORMAT_BYTE_RETURN 0xFB +void +DEFUN_VOID (flush_i_cache) +{ + extern void + EXFUN (cache_flush_all, (unsigned int, struct pdc_cache_result *)); -#define FORMAT_WORD_EXPR (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_EXPR)) -#define FORMAT_WORD_CMPINT (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_CMPINT)) -#define FORMAT_WORD_RETURN (MAKE_FORMAT_WORD(0xFF, FORMAT_BYTE_RETURN)) + struct pdc_cache_result * cache_desc; + + cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); -/* This assumes that a format word is at least 16 bits, - and the low order field is always 8 bits. - */ + /* The call can be interrupted in the middle of a set, so do it twice. + Probability of two interrupts in the same cache line is + exceedingly small, so this is likely to win. + On the other hand, if the caches are directly mapped, a single + call can't lose. + In addition, if the cache is shared, there is no need to flush at all. + */ -#define MAKE_FORMAT_WORD(field1, field2) \ - (((field1) << 8) | ((field2) & 0xff)) + if (((cache_desc->I_info.conf.bits.fsel & 1) == 0) + || ((cache_desc->D_info.conf.bits.fsel & 1) == 0)) + { + unsigned int flag = 0; -#define SIGN_EXTEND_FIELD(field, size) \ - (((field) & ((1 << (size)) - 1)) | \ - ((((field) & (1 << ((size) - 1))) == 0) ? 0 : \ - ((-1) << (size)))) + if (cache_desc->I_info.loop != 1) + flag |= I_CACHE; + if (cache_desc->D_info.loop != 1) + flag |= D_CACHE; -#define FORMAT_WORD_LOW_BYTE(word) \ - (SIGN_EXTEND_FIELD((((unsigned long) (word)) & 0xff), 8)) + if (flag != 0) + cache_flush_all (flag, cache_desc); + cache_flush_all ((D_CACHE | I_CACHE), cache_desc); + } +} -#define FORMAT_WORD_HIGH_BYTE(word) \ - (SIGN_EXTEND_FIELD((((unsigned long) (word)) >> 8), \ - (((sizeof (format_word)) * CHAR_BIT) - 8))) +void +DEFUN (push_d_cache_region, (start_address, block_size), + PTR start_address AND unsigned long block_size) +{ + extern void + EXFUN (cache_flush_region, (PTR, long, unsigned int)); -#define COMPILED_ENTRY_FORMAT_HIGH(addr) \ - (FORMAT_WORD_HIGH_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) + struct pdc_cache_result * cache_desc; + + cache_desc = ((struct pdc_cache_result *) &(cache_info.cache_format)); -#define COMPILED_ENTRY_FORMAT_LOW(addr) \ - (FORMAT_WORD_LOW_BYTE(COMPILED_ENTRY_FORMAT_WORD(addr))) + /* Note that the first and last words are also flushed from the I-cache + in case this object is adjacent to another that has already caused + the cache line to be copied into the I-cache. + */ -#define FORMAT_BYTE_FRAMEMAX 0x7f + if (((cache_desc->I_info.conf.bits.fsel & 1) == 0) + || ((cache_desc->D_info.conf.bits.fsel & 1) == 0)) + { + cache_flush_region (start_address, block_size, D_CACHE); + cache_flush_region (start_address, 1, I_CACHE); + cache_flush_region (((PTR) + (((unsigned long *) start_address) + + (block_size - 1))), + 1, + I_CACHE); + } + return; +} + +#define DECLARE_CMPINTMD_UTILITIES() \ + UTLD (assemble_17), \ + UTLD (assemble_12), \ + UTLD (C_closure_entry_point), \ + UTLD (bkpt_init), \ + UTLD (alloc_bkpt_handle), \ + UTLD (bkpt_install), \ + UTLD (bkpt_closure_install), \ + UTLD (bkpt_remove), \ + UTLD (bkpt_p), \ + UTLD (do_bkpt_proceed), \ + UTLD (transform_procedure_entries), \ + UTLD (transform_procedure_table), \ + UTLD (change_vm_protection), \ + UTLD (hppa_reset_hook), \ + UTLD (hppa_update_primitive_table), \ + UTLD (hppa_grow_primitive_table), \ + UTLD (hppa_extract_absolute_address), \ + UTLD (hppa_store_absolute_address), \ + UTLD (flush_i_cache), \ + UTLD (push_d_cache_region), \ + UTLD (flush_i_cache_initialize) -#define COMPILED_ENTRY_MAXIMUM_ARITY COMPILED_ENTRY_FORMAT_LOW -#define COMPILED_ENTRY_MINIMUM_ARITY COMPILED_ENTRY_FORMAT_HIGH +#endif /* IN_CMPINT_C */ #endif /* CMPINTMD_H_INCLUDED */