From 876b77d1f9c4e71256cf9dba8f2b70423a2052c5 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Fri, 28 Dec 2018 20:51:02 +0000 Subject: [PATCH] Split compiled entries and compiled return addresses. Reallocate tag 4 for return addresses. This way, a compiled entry can be a pointer to a PC offsets so that we can construct closures without dynamically generating code and wrecking the instruction cache, while a compiled return addresses can be a pointer to a PC, since we never dynamically create indirections for returns. For now, the runtime can handle both tags for return addresses. XXX Only done and tested on x86-64 for now. Other architectures need to be tested. Might be worthwhile to do this on i386 too, if anyone still cares about i386. WARNING: This changes the compiled code interface on all architectures, so you'll have to build a new compiler running on an old microcode and use that to compile a new system afresh. --- src/compiler/base/asstop.scm | 2 +- src/compiler/base/utils.scm | 1 + src/compiler/machines/x86-64/lapgen.scm | 8 +- src/compiler/machines/x86-64/rules1.scm | 22 ++-- src/compiler/machines/x86-64/rules3.scm | 15 +-- src/compiler/rtlbase/rtlcon.scm | 2 +- src/microcode/cmpauxmd/i386.m4 | 6 +- src/microcode/cmpauxmd/x86-64.m4 | 52 +++++--- src/microcode/cmpint.c | 166 ++++++++++++++++++------ src/microcode/cmpint.h | 88 +++++++++++-- src/microcode/cmpintmd/c.c | 6 + src/microcode/cmpintmd/c.h | 11 ++ src/microcode/cmpintmd/i386.c | 6 + src/microcode/cmpintmd/i386.h | 13 ++ src/microcode/cmpintmd/svm1.c | 6 + src/microcode/cmpintmd/svm1.h | 17 ++- src/microcode/cmpintmd/x86-64.c | 6 + src/microcode/cmpintmd/x86-64.h | 8 ++ src/microcode/comutl.c | 29 ++++- src/microcode/debug.c | 15 ++- src/microcode/gc.h | 12 +- src/microcode/gccode.h | 7 + src/microcode/gcloop.c | 63 +++++++-- src/microcode/hooks.c | 10 +- src/microcode/svm1-interp.c | 5 +- src/microcode/typename.txt | 80 ++++++------ src/microcode/types.h | 4 +- src/microcode/utils.c | 4 +- src/runtime/global.scm | 7 +- src/runtime/microcode-data.scm | 6 +- src/runtime/predicate-tagging.scm | 2 + src/runtime/printer.scm | 10 +- 32 files changed, 512 insertions(+), 177 deletions(-) diff --git a/src/compiler/base/asstop.scm b/src/compiler/base/asstop.scm index ddc69a1fc..c8ae22a76 100644 --- a/src/compiler/base/asstop.scm +++ b/src/compiler/base/asstop.scm @@ -335,7 +335,7 @@ USA. (block-offset start) (label start) (pea (@pcr proc)) - (or b (& ,(* (microcode-type 'compiled-entry) 4)) (@a 7)) + (or b (& ,(* (microcode-type 'compiled-return) 4)) (@a 7)) (mov l (@a+ 7) (@ao 6 8)) (and b (& #x3) (@a 7)) (rts) diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm index d580de2d8..cce2df0a3 100644 --- a/src/compiler/base/utils.scm +++ b/src/compiler/base/utils.scm @@ -156,6 +156,7 @@ USA. (define-type-code unassigned) (define-type-code stack-environment) (define-type-code compiled-entry) +(define-integrable type-code:compiled-return 4) (define (scode/procedure-type-code *lambda) (cond ((object-type? type-code:lambda *lambda) diff --git a/src/compiler/machines/x86-64/lapgen.scm b/src/compiler/machines/x86-64/lapgen.scm index 8595951e2..6a1a63ff5 100644 --- a/src/compiler/machines/x86-64/lapgen.scm +++ b/src/compiler/machines/x86-64/lapgen.scm @@ -218,11 +218,11 @@ USA. (move-to-alias-register! source (register-type target) target) (LAP)) -(define (load-pc-relative target label-expr) - (LAP (MOV Q ,target (@PCR ,label-expr)))) +(define (load-pc-relative target label-expr offset) + (LAP (MOV Q ,target (@PCRO ,label-expr ,offset)))) -(define (load-pc-relative-address target label-expr) - (LAP (LEA Q ,target (@PCR ,label-expr)))) +(define (load-pc-relative-address target label-expr offset) + (LAP (LEA Q ,target (@PCRO ,label-expr ,offset)))) (define (compare/register*register reg1 reg2) (cond ((register-alias reg1 'GENERAL) diff --git a/src/compiler/machines/x86-64/rules1.scm b/src/compiler/machines/x86-64/rules1.scm index 96309d1ae..a327bcb15 100644 --- a/src/compiler/machines/x86-64/rules1.scm +++ b/src/compiler/machines/x86-64/rules1.scm @@ -170,39 +170,45 @@ USA. (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) (load-pc-relative-address (target-register-reference target) - (rtl-procedure/external-label (label->object label)))) + (rtl-procedure/external-label (label->object label)) + 0)) (define-rule statement (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) - (load-pc-relative-address (target-register-reference target) label)) + (load-pc-relative-address (target-register-reference target) label 8)) (define-rule statement ;; This is an intermediate rule -- not intended to produce code. (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) + (assert (= type type-code:compiled-entry)) (load-pc-relative-address/typed (target-register-reference target) type (rtl-procedure/external-label - (label->object label)))) + (label->object label)) + 0)) (define-rule statement ;; This is an intermediate rule -- not intended to produce code. (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (ENTRY:CONTINUATION (? label)))) + (assert (= type type-code:compiled-return)) (load-pc-relative-address/typed (target-register-reference target) - type label)) + type label 8)) (define-rule statement (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) (load-pc-relative (target-register-reference target) - (free-reference-label name))) + (free-reference-label name) + 0)) (define-rule statement (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) (load-pc-relative (target-register-reference target) - (free-assignment-label name))) + (free-assignment-label name) + 0)) (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) @@ -398,13 +404,13 @@ USA. (target (target-register-reference target))) (LAP (LEA Q ,target ,source)))) -(define (load-pc-relative-address/typed target type label) +(define (load-pc-relative-address/typed target type label offset) ;++ This is pretty horrid, especially since it happens for every ;++ continuation pushed! None of the alternatives is much good. ;; Twenty bytes, but only three instructions and no extra memory. (let ((temp (temporary-register-reference))) (LAP (MOV Q ,temp (&U ,(make-non-pointer-literal type 0))) - (LEA Q ,target (@PCR ,label)) + (LEA Q ,target (@PCRO ,label ,offset)) (OR Q ,target ,temp))) #| ;; Nineteen bytes, but rather complicated (and needs syntax for an diff --git a/src/compiler/machines/x86-64/rules3.scm b/src/compiler/machines/x86-64/rules3.scm index 4c97dd085..8f49c4707 100644 --- a/src/compiler/machines/x86-64/rules3.scm +++ b/src/compiler/machines/x86-64/rules3.scm @@ -39,10 +39,8 @@ USA. (cond ((null? checks) (current-bblock-continue! (make-new-sblock - (LAP (POP Q (R ,rcx)) ; continuation - (AND Q (R ,rcx) (R ,regnum:datum-mask)) ; clear type - (MOV Q (R ,rax) (@R ,rcx)) ;rax := PC offset - (ADD Q (R ,rax) (R ,rcx)) ;rax := PC + (LAP (POP Q (R ,rax)) ; continuation + (AND Q (R ,rax) (R ,regnum:datum-mask)) ; clear type (JMP (R ,rax)))))) ((block-association 'POP-RETURN) => current-bblock-continue!) @@ -52,10 +50,8 @@ USA. (let ((interrupt-label (generate-label 'INTERRUPT))) (LAP (CMP Q (R ,regnum:free-pointer) ,reg:compiled-memtop) (JGE (@PCR ,interrupt-label)) - (POP Q (R ,rcx)) ; continuation - (AND Q (R ,rcx) (R ,regnum:datum-mask)) ; clear type - (MOV Q (R ,rax) (@R ,rcx)) ;rax := PC offset - (ADD Q (R ,rax) (R ,rcx)) ;rax := PC + (POP Q (R ,rax)) ; continuation + (AND Q (R ,rax) (R ,regnum:datum-mask)) ; clear type (JMP (R ,rax)) (LABEL ,interrupt-label) ,@(invoke-hook @@ -155,7 +151,8 @@ USA. (set-address (begin (require-register! rdx) (load-pc-relative-address (INST-EA (R ,rdx)) - *block-label*)))) + *block-label* + 0)))) (delete-dead-registers!) (LAP ,@set-extension ,@set-address diff --git a/src/compiler/rtlbase/rtlcon.scm b/src/compiler/rtlbase/rtlcon.scm index 6e3656223..61f11c38c 100644 --- a/src/compiler/rtlbase/rtlcon.scm +++ b/src/compiler/rtlbase/rtlcon.scm @@ -125,7 +125,7 @@ USA. (define (rtl:make-push-return continuation) (rtl:make-push - (rtl:make-cons-pointer (rtl:make-machine-constant type-code:compiled-entry) + (rtl:make-cons-pointer (rtl:make-machine-constant type-code:compiled-return) (rtl:make-entry:continuation continuation)))) (define (rtl:make-push-link) diff --git a/src/microcode/cmpauxmd/i386.m4 b/src/microcode/cmpauxmd/i386.m4 index bfa0d32b6..94d2ae8a5 100644 --- a/src/microcode/cmpauxmd/i386.m4 +++ b/src/microcode/cmpauxmd/i386.m4 @@ -638,7 +638,7 @@ scheme_to_interface_proceed: # Signal to within_c_stack that we are now in C land. OP(mov,l) TW(IMM(0),EVR(C_Stack_Pointer)) - OP(sub,l) TW(IMM(8),REG(esp)) # alloc struct return + OP(sub,l) TW(IMM(12),REG(esp)) # alloc struct return OP(push,l) LOF(REGBLOCK_UTILITY_ARG4(),regs) # push utility args OP(push,l) REG(ebx) @@ -657,7 +657,9 @@ scheme_to_interface_proceed: define_debugging_label(scheme_to_interface_return) OP(add,l) TW(IMM(20),REG(esp)) # pop utility args OP(pop,l) REG(eax) # pop struct return - OP(pop,l) REG(edx) + OP(pop,l) REG(edx) # interp code / compiled ptr + OP(pop,l) REG(ecx) # interp garbage / compiled pc + # (currently unused on i386) jmp IJMP(REG(eax)) # Invoke handler define_c_label(interface_to_scheme) diff --git a/src/microcode/cmpauxmd/x86-64.m4 b/src/microcode/cmpauxmd/x86-64.m4 index fd8859cb3..d10c67d72 100644 --- a/src/microcode/cmpauxmd/x86-64.m4 +++ b/src/microcode/cmpauxmd/x86-64.m4 @@ -283,6 +283,7 @@ define(ADDRESS_MASK, HEX(3ffffffffffffff)) #define(TAG, ($2 + ($1 * DATUM_SHIFT))) define(TC_FALSE,0) +define(TC_COMPILED_RETURN,4) define(TC_FLONUM,6) define(TC_TRUE,8) define(TC_FIXNUM,26) @@ -385,11 +386,13 @@ define_debugging_label(within_c_stack_from_c) OP(mov,q) TW(REG(rsi),REG(rdi)) # arg2 (arg) -> arg1 jmp IJMP(REG(rax)) # tail-call fn(arg) -# C_to_interface passes control from C into Scheme. To C it is a -# unary procedure; its one argument is passed in rdi. It saves the -# state of the C world (the C frame pointer and stack pointer) and -# then passes control to interface_to_scheme to set up the state of -# the Scheme world. +# C_to_interface passes control from C into Scheme. +# +# long C_to_interface (insn_t *ptr=rdi, insn_t *pc=rsi) +# +# It saves the state of the C world (the C frame pointer and stack +# pointer) and then passes control to interface_to_scheme to set up the +# state of the Scheme world. # # Note: The AMD64 ABI mandates that on entry to a function, RSP - 8 # must be a multiple of 0x10; that is, the stack must be 128-bit @@ -399,6 +402,8 @@ define_debugging_label(within_c_stack_from_c) # which we must pop off in interface_to_C. define_c_label(C_to_interface) + # rdi = compiled entry address + # rsi = compiled PC OP(push,q) REG(rbp) # Link according OP(mov,q) TW(REG(rsp),REG(rbp)) # to C's conventions OP(push,q) REG(rbx) # Save callee-saves @@ -407,7 +412,8 @@ define_c_label(C_to_interface) OP(push,q) REG(r14) OP(push,q) REG(r15) OP(push,q) IMM(0) # Align stack - OP(mov,q) TW(REG(rdi),REG(rdx)) # Entry point + OP(mov,q) TW(REG(rdi),REG(rcx)) # rcx := entry ptr + OP(mov,q) TW(REG(rsi),REG(rdx)) # rcx := entry pc # Preserve frame ptr OP(mov,q) TW(REG(rbp),ABS(EVR(C_Frame_Pointer))) # Preserve stack ptr @@ -448,7 +454,8 @@ define_debugging_label(scheme_to_interface) # Signal to within_c_stack that we are now in C land. OP(mov,q) TW(IMM(0),ABS(EVR(C_Stack_Pointer))) - OP(sub,q) TW(IMM(16),REG(rsp)) # alloc struct return + OP(sub,q) TW(IMM(32),REG(rsp)) # alloc struct return; + # preserve 16-byte alignment OP(mov,q) TW(REG(rsp),REG(rdi)) # Structure is first argument. OP(mov,q) TW(REG(rbx),REG(rsi)) # rbx -> second argument. @@ -464,11 +471,17 @@ define_debugging_label(scheme_to_interface) call IJMP(REG(rax)) define_debugging_label(scheme_to_interface_return) - OP(pop,q) REG(rax) # pop struct return - OP(pop,q) REG(rdx) + # pop utility_result_t contents + OP(pop,q) REG(rax) # interface_dispatch + OP(pop,q) REG(rcx) # interp code / compiled ptr + OP(pop,q) REG(rdx) # interp garbage / compiled pc + OP(add,q) TW(IMM(8),REG(rsp)) # pop alignment padding jmp IJMP(REG(rax)) # Invoke handler define_c_label(interface_to_scheme) + # rax = interface_to_scheme + # rcx = compiled entry address, needed by compiled code; 0 if return + # rdx = compiled PC ifdef(`WIN32', # Register block = %rsi ` OP(mov,q) TW(ABS(EVR(RegistersPtr)),regs)', ` OP(lea,q) TW(ABS(EVR(Registers)),regs)') @@ -482,11 +495,9 @@ ifdef(`WIN32', # Register block = %rsi OP(mov,q) TW(ABS(EVR(stack_pointer)),REG(rsp)) OP(mov,q) TW(REG(rbp),ABS(EVR(C_Frame_Pointer))) OP(mov,q) TW(IMM(ADDRESS_MASK),rmask) # = %rbp - OP(mov,q) TW(REG(rax),REG(rcx)) # Preserve if used - OP(and,q) TW(rmask,REG(rcx)) # Restore potential dynamic link - OP(mov,q) TW(REG(rcx),QOF(REGBLOCK_DLINK(),regs)) - OP(mov,q) TW(REG(rdx),REG(rcx)) # rcx := entry addr - OP(add,q) TW(IND(REG(rcx)),REG(rdx)) # rcx := PC + OP(mov,q) TW(REG(rax),REG(r8)) # Preserve if used + OP(and,q) TW(rmask,REG(r8)) # Restore potential dynamic link + OP(mov,q) TW(REG(r8),QOF(REGBLOCK_DLINK(),regs)) jmp IJMP(REG(rdx)) # Invoke IF_WIN32(` @@ -497,7 +508,10 @@ define_code_label(EFR(callWinntExceptionTransferHook)) ') define_c_label(interface_to_C) - OP(mov,q) TW(REG(rdx),REG(rax)) # Set up result + # rax = interface_to_scheme + # rcx = interpreter code + # rdx = garbage + OP(mov,q) TW(REG(rcx),REG(rax)) # Set up result # We need a dummy register for the POP (which is three bytes # shorter than ADD $8,RSP); since we're about to pop into r15 # anyway, we may as well use that. @@ -569,7 +583,7 @@ define_hook_label(sc_apply) jne asm_sc_apply_generic OP(mov,q) TW(IND(REG(rcx)),REG(rax)) # rax := PC offset OP(add,q) TW(REG(rcx),REG(rax)) # rax := PC - jmp IJMP(REG(rax)) # Invoke + jmp IJMP(REG(rax)) # Invoke entry define_debugging_label(asm_sc_apply_generic) OP(mov,q) TW(IMM(HEX(14)),REG(rax)) @@ -588,7 +602,7 @@ define_hook_label(sc_apply_size_$1) jne asm_sc_apply_generic_$1 # to nargs+1 OP(mov,q) TW(IND(REG(rcx)),REG(rax)) # rax := PC offset OP(add,q) TW(REG(rcx),REG(rax)) # rax := PC - jmp IJMP(REG(rax)) # Invoke + jmp IJMP(REG(rax)) # Invoke entry asm_sc_apply_generic_$1: OP(mov,q) TW(IMM($1),REG(rdx)) @@ -615,9 +629,7 @@ asm_generic_return_rax: OP(mov,q) TW(REG(rax),QOF(REGBLOCK_VAL(),regs)) OP(pop,q) REG(rcx) OP(and,q) TW(rmask,REG(rcx)) - OP(mov,q) TW(IND(REG(rcx)),REG(rax)) - OP(add,q) TW(REG(rcx),REG(rax)) - jmp IJMP(REG(rax)) + jmp IJMP(REG(rcx)) # Invoke return declare_alignment(2) asm_generic_fixnum_result: diff --git a/src/microcode/cmpint.c b/src/microcode/cmpint.c index e3a77c6e7..03fa95cae 100644 --- a/src/microcode/cmpint.c +++ b/src/microcode/cmpint.c @@ -40,15 +40,16 @@ USA. /* Two special classes of procedures are used in this file: Scheme interface entries. These procedures are called from C and - ultimately invoke 'ENTER_SCHEME' to enter compiled code, or return - a status code. + ultimately invoke 'ENTER_SCHEME_ENTRY'/'ENTER_SCHEME_CONTINUATION' + to enter compiled code, or return a status code. Scheme interface utilities. These procedures are called from the Scheme interface and perform tasks that the compiler does not code inline. They are referenced from compiled Scheme code by index, and the assembly language interface fetches them from an array. They are defined with 'SCHEME_UTILITY_n' for some 'n', and - ultimately invoke either 'RETURN_TO_SCHEME' (in the normal case) or + ultimately invoke either 'RETURN_TO_SCHEME_ENTRY' / + 'RETURN_TO_SCHEME_CONTINUATION' (in the normal case) or 'RETURN_TO_C' (in the error case). */ typedef long cache_handler_t (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long); @@ -139,6 +140,7 @@ static void count_linkage_sections static SCHEME_OBJECT read_linkage_sections (SCHEME_OBJECT *, SCHEME_OBJECT *, unsigned long, unsigned long); static bool section_execute_p (SCHEME_OBJECT); +static void compiler_interrupt_return_to_entry (void); static void setup_compiled_invocation_from_primitive (SCHEME_OBJECT, unsigned long); static long setup_compiled_invocation (SCHEME_OBJECT, unsigned long); @@ -187,18 +189,44 @@ static long make_apply_trampoline return; \ } while (false) -#define RETURN_TO_SCHEME(ep) do \ +#define RETURN_TO_SCHEME_ENTRY(ep) do \ { \ + insn_t * ep_ = (ep); \ (DSU_result->interface_dispatch) = interface_to_scheme; \ - ((DSU_result->extra) . entry_point) = (ep); \ + ((DSU_result->extra) . compiled_code . ptr) = (CC_ENTRY_ADDRESS_PTR (ep_)); \ + ((DSU_result->extra) . compiled_code . pc) = (CC_ENTRY_ADDRESS_PC (ep_)); \ + return; \ +} while (false) + +#define RETURN_TO_SCHEME_CONTINUATION(c) do \ +{ \ + insn_t * c_ = (c); \ + (DSU_result->interface_dispatch) = interface_to_scheme; \ + ((DSU_result->extra) . compiled_code . ptr) = (CC_RETURN_ADDRESS_PTR (c_)); \ + ((DSU_result->extra) . compiled_code . pc) = (CC_RETURN_ADDRESS_PC (c_)); \ return; \ } while (false) extern c_func_t ASM_ENTRY_POINT (interface_to_C); extern c_func_t ASM_ENTRY_POINT (interface_to_scheme); -#define ENTER_SCHEME(ep) return (C_to_interface (ep)) -extern long ASM_ENTRY_POINT (C_to_interface) (insn_t *); +#define ENTER_SCHEME_ENTRY(ep) do \ +{ \ + insn_t * ep_ = (ep); \ + return \ + (C_to_interface \ + ((CC_ENTRY_ADDRESS_PTR (ep_)), (CC_ENTRY_ADDRESS_PC (ep_)))); \ +} while (false) + +#define ENTER_SCHEME_CONTINUATION(c) do \ +{ \ + insn_t * c_ = (c); \ + return \ + (C_to_interface \ + ((CC_RETURN_ADDRESS_PTR (c_)), (CC_RETURN_ADDRESS_PC (c_)))); \ +} while (false) + +extern long ASM_ENTRY_POINT (C_to_interface) (insn_t *, insn_t *); #else /* !CMPINT_USE_STRUCS */ @@ -209,17 +237,21 @@ extern long ASM_ENTRY_POINT (C_to_interface) (insn_t *); return; \ } while (false) -#define RETURN_TO_SCHEME(ep) do \ +/* Assume entries and returns have the same address representation. */ + +#define RETURN_TO_SCHEME_ENTRY(ep) do \ { \ (*DSU_result) = (ep); \ return; \ } while (false) +#define RETURN_TO_SCHEME_CONTINUATION RETURN_TO_SCHEME_ENTRY -#define ENTER_SCHEME(ep) do \ +#define ENTER_SCHEME_ENTRY(ep) do \ { \ C_to_interface (ep); \ return (C_return_value); \ } while (false) +#define ENTER_SCHEME_CONTINUATION ENTER_SCHEME_ENTRY extern utility_result_t interface_to_C_hook; extern void ASM_ENTRY_POINT (C_to_interface) (insn_t *); @@ -228,7 +260,9 @@ long C_return_value; #endif /* !CMPINT_USE_STRUCS */ #endif /* !UTILITY_RESULT_DEFINED */ -#define JUMP_TO_CC_ENTRY(entry) ENTER_SCHEME (CC_ENTRY_ADDRESS (entry)) +#define JUMP_TO_CC_ENTRY(entry) ENTER_SCHEME_ENTRY (CC_ENTRY_ADDRESS (entry)) +#define JUMP_TO_CC_RETURN(ret) \ + ENTER_SCHEME_CONTINUATION (CC_RETURN_ADDRESS (ret)) #ifndef COMPILER_REGBLOCK_N_FIXED # define COMPILER_REGBLOCK_N_FIXED REGBLOCK_MINIMUM_LENGTH @@ -384,8 +418,8 @@ compiler_reset (SCHEME_OBJECT new_block) nbp = (OBJECT_ADDRESS (new_block)); compiler_utilities = new_block; - return_to_interpreter = (MAKE_CC_ENTRY (trampoline_entry_addr (nbp, 0))); - reflect_to_interface = (MAKE_CC_ENTRY (trampoline_entry_addr (nbp, 1))); + return_to_interpreter = (MAKE_CC_RETURN (trampoline_return_addr (nbp, 0))); + reflect_to_interface = (MAKE_CC_RETURN (trampoline_return_addr (nbp, 1))); SET_CLOSURE_FREE (0); SET_CLOSURE_SPACE (0); SET_REFLECTOR (reflect_to_interface); @@ -432,24 +466,28 @@ DEFINE_SCHEME_ENTRY (return_to_compiled_code) SCHEME_OBJECT cont = (STACK_POP ()); { cc_entry_type_t cet; - if ((read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (cont)))) + if (! (CC_RETURN_P (cont))) + goto bad; + insn_t * ret_addr = (CC_RETURN_ADDRESS (cont)); + insn_t * entry_addr = (CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS (ret_addr)); + if ((read_cc_entry_type ((&cet), entry_addr)) || (! ((cet.marker == CET_CONTINUATION) || (cet.marker == CET_INTERNAL_CONTINUATION) || (cet.marker == CET_RETURN_TO_INTERPRETER)))) { - STACK_PUSH (cont); +bad: STACK_PUSH (cont); SAVE_CONT (); return (ERR_INAPPLICABLE_OBJECT); } } - JUMP_TO_CC_ENTRY (cont); + JUMP_TO_CC_RETURN (cont); } } void guarantee_cc_return (unsigned long offset) { - if (CC_ENTRY_P (STACK_REF (offset))) + if (CC_RETURN_P (STACK_REF (offset))) return; assert (RETURN_CODE_P (CONT_RET (offset))); if (CHECK_RETURN_CODE (RC_REENTER_COMPILED_CODE, offset)) @@ -475,7 +513,7 @@ guarantee_interp_return (void) unsigned long offset = (1 + (APPLY_FRAME_SIZE ())); if (RETURN_CODE_P (CONT_RET (offset))) return; - assert (CC_ENTRY_P (STACK_REF (offset))); + assert (CC_RETURN_P (STACK_REF (offset))); if ((STACK_REF (offset)) == return_to_interpreter) { assert (RETURN_CODE_P (CONT_RET (offset + 1))); @@ -581,10 +619,12 @@ ASM_ENTRY_POINT (pname) \ { \ if (Free >= GET_MEMTOP) \ { \ + compiler_interrupt_return_to_entry (); \ compiler_interrupt_common (DSU_result, 0, GET_VAL); \ return; \ } \ - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (STACK_POP ())); \ + assert (CC_RETURN_P (STACK_REF (0))); \ + RETURN_TO_SCHEME_CONTINUATION (CC_RETURN_ADDRESS (STACK_POP ())); \ } while (false) #define TAIL_CALL_1(pname, a1) do \ @@ -653,7 +693,7 @@ DEFINE_SCHEME_UTILITY_2 (comutil_apply, procedure, frame_size) if (code != PRIM_DONE) RETURN_TO_C (code); } - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); case TC_PRIMITIVE: if (IMPLEMENTED_PRIMITIVE_P (procedure)) @@ -711,7 +751,7 @@ DEFINE_SCHEME_UTILITY_2 (comutil_lexpr_apply, address, n_args) if (code != PRIM_DONE) RETURN_TO_C (code); } - RETURN_TO_SCHEME (address); + RETURN_TO_SCHEME_ENTRY (address); } /* comutil_primitive_apply is used to invoked a C primitive. Note @@ -788,7 +828,7 @@ DEFINE_SCHEME_UTILITY_4 (comutil_link, if (result != PRIM_DONE) RETURN_TO_C (result); } - RETURN_TO_SCHEME (s.return_address); + RETURN_TO_SCHEME_ENTRY (s.return_address); } /* comp_link_caches_restart is used to continue the linking process @@ -812,7 +852,7 @@ DEFINE_SCHEME_ENTRY (comp_link_caches_restart) if (result != PRIM_DONE) return (result); - ENTER_SCHEME (s.return_address); + ENTER_SCHEME_ENTRY (s.return_address); } static long @@ -1147,9 +1187,25 @@ DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_ic_procedure, entry_point) DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_continuation_2) { + compiler_interrupt_return_to_entry (); compiler_interrupt_common (DSU_result, 0, GET_VAL); } +/* Convert the compiled return address on the stack to a compiled + entry. This is easier than adding a different interpreter return + code, &c. */ + +static void +compiler_interrupt_return_to_entry (void) +{ + SCHEME_OBJECT ret = (STACK_POP ()); + assert (CC_RETURN_P (ret)); + insn_t * ret_addr = (CC_RETURN_ADDRESS (ret)); + insn_t * entry_addr = (CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS (ret_addr)); + SCHEME_OBJECT entry = (MAKE_CC_ENTRY (entry_addr)); + STACK_PUSH (entry); +} + void compiler_interrupt_common (utility_result_t * DSU_result, insn_t * address, @@ -1160,6 +1216,7 @@ compiler_interrupt_common (utility_result_t * DSU_result, STACK_CHECK (0); if (address != 0) STACK_PUSH (MAKE_CC_ENTRY (address)); + assert (CC_ENTRY_P (STACK_REF (0))); STACK_PUSH (state); SAVE_LAST_RETURN_CODE (RC_COMP_INTERRUPT_RESTART); RETURN_TO_C (PRIM_INTERRUPT); @@ -1202,7 +1259,7 @@ DEFINE_SCHEME_UTILITY_3 (comutil_assignment_trap, RETURN_TO_C (code); } SET_VAL (old_val); - RETURN_TO_SCHEME (ret_addr); + RETURN_TO_SCHEME_ENTRY (ret_addr); } DEFINE_SCHEME_ENTRY (comp_assignment_trap_restart) @@ -1301,7 +1358,7 @@ DEFINE_SCHEME_UTILITY_2 (comutil_lookup_trap, ret_addr, cache_addr) RETURN_TO_C (code); } SET_VAL (val); - RETURN_TO_SCHEME (ret_addr); + RETURN_TO_SCHEME_ENTRY (ret_addr); } DEFINE_SCHEME_ENTRY (comp_lookup_trap_restart) @@ -1342,7 +1399,7 @@ DEFINE_SCHEME_UTILITY_2 (comutil_safe_lookup_trap, ret_addr, cache_addr) RETURN_TO_C (code); } SET_VAL (val); - RETURN_TO_SCHEME (ret_addr); + RETURN_TO_SCHEME_ENTRY (ret_addr); } DEFINE_SCHEME_ENTRY (comp_safe_lookup_trap_restart) @@ -1383,7 +1440,7 @@ DEFINE_SCHEME_UTILITY_2 (comutil_unassigned_p_trap, ret_addr, cache_addr) RETURN_TO_C (code); } SET_VAL (val); - RETURN_TO_SCHEME (ret_addr); + RETURN_TO_SCHEME_ENTRY (ret_addr); } DEFINE_SCHEME_ENTRY (comp_unassigned_p_trap_restart) @@ -1707,6 +1764,26 @@ cc_entry_address_to_block_address (insn_t * entry) } } } + +SCHEME_OBJECT +cc_return_to_block (SCHEME_OBJECT ret) +{ + return (MAKE_CC_BLOCK (cc_return_to_block_address (ret))); +} + +SCHEME_OBJECT * +cc_return_to_block_address (SCHEME_OBJECT ret) +{ + return (cc_return_address_to_block_address (CC_RETURN_ADDRESS (ret))); +} + +SCHEME_OBJECT * +cc_return_address_to_block_address (insn_t * addr) +{ + return + (cc_entry_address_to_block_address + (CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS (addr))); +} static bool plausible_first_cc_entry_p (insn_t * entry, insn_t * zero) @@ -1826,6 +1903,13 @@ cc_entry_to_block_offset (SCHEME_OBJECT entry) - ((insn_t *) (cc_entry_to_block_address (entry)))); } +unsigned long +cc_return_to_block_offset (SCHEME_OBJECT ret) +{ + return ((CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS (CC_RETURN_ADDRESS (ret))) + - ((insn_t *) (cc_return_to_block_address (ret)))); +} + bool cc_block_closure_p (SCHEME_OBJECT block) { @@ -2088,7 +2172,7 @@ DEFINE_TRAMPOLINE (comutil_reflect_to_interface) case REFLECT_CODE_APPLY_COMPILED: { SCHEME_OBJECT procedure = (STACK_POP ()); - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } case REFLECT_CODE_INTERNAL_APPLY: @@ -2123,7 +2207,7 @@ DEFINE_TRAMPOLINE (comutil_reflect_to_interface) STACK_PUSH (code); RETURN_TO_C (code); } - RETURN_TO_SCHEME (addr); + RETURN_TO_SCHEME_ENTRY (addr); } default: @@ -2162,7 +2246,7 @@ DEFINE_TRAMPOLINE (comutil_operator_1_0_trap) { INIT_TRAMPOLINE_1 (procedure); STACK_PUSH (DEFAULT_OBJECT); - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_2_0_trap) @@ -2170,7 +2254,7 @@ DEFINE_TRAMPOLINE (comutil_operator_2_0_trap) INIT_TRAMPOLINE_1 (procedure); STACK_PUSH (DEFAULT_OBJECT); STACK_PUSH (DEFAULT_OBJECT); - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_2_1_trap) @@ -2181,7 +2265,7 @@ DEFINE_TRAMPOLINE (comutil_operator_2_1_trap) STACK_PUSH (DEFAULT_OBJECT); STACK_PUSH (a1); } - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_3_0_trap) @@ -2190,7 +2274,7 @@ DEFINE_TRAMPOLINE (comutil_operator_3_0_trap) STACK_PUSH (DEFAULT_OBJECT); STACK_PUSH (DEFAULT_OBJECT); STACK_PUSH (DEFAULT_OBJECT); - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_3_1_trap) @@ -2202,7 +2286,7 @@ DEFINE_TRAMPOLINE (comutil_operator_3_1_trap) STACK_PUSH (DEFAULT_OBJECT); STACK_PUSH (a1); } - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_3_2_trap) @@ -2215,7 +2299,7 @@ DEFINE_TRAMPOLINE (comutil_operator_3_2_trap) STACK_PUSH (a2); STACK_PUSH (a1); } - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_4_0_trap) @@ -2225,7 +2309,7 @@ DEFINE_TRAMPOLINE (comutil_operator_4_0_trap) STACK_PUSH (DEFAULT_OBJECT); STACK_PUSH (DEFAULT_OBJECT); STACK_PUSH (DEFAULT_OBJECT); - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_4_1_trap) @@ -2238,7 +2322,7 @@ DEFINE_TRAMPOLINE (comutil_operator_4_1_trap) STACK_PUSH (DEFAULT_OBJECT); STACK_PUSH (a1); } - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_4_2_trap) @@ -2252,7 +2336,7 @@ DEFINE_TRAMPOLINE (comutil_operator_4_2_trap) STACK_PUSH (a2); STACK_PUSH (a1); } - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } DEFINE_TRAMPOLINE (comutil_operator_4_3_trap) @@ -2267,7 +2351,7 @@ DEFINE_TRAMPOLINE (comutil_operator_4_3_trap) STACK_PUSH (a2); STACK_PUSH (a1); } - RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure)); + RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure)); } /* The linker either couldn't find a binding or the binding was @@ -2314,7 +2398,7 @@ DEFINE_SCHEME_ENTRY (comp_op_lookup_trap_restart) = (trampoline_storage (cc_entry_to_block_address (STACK_POP ()))); SCHEME_OBJECT block = (store[1]); unsigned long offset = (OBJECT_DATUM (store[2])); - ENTER_SCHEME (read_uuo_target_no_reloc (MEMORY_LOC (block, offset))); + ENTER_SCHEME_ENTRY (read_uuo_target_no_reloc (MEMORY_LOC (block, offset))); } } @@ -2587,8 +2671,8 @@ make_apply_trampoline (SCHEME_OBJECT * slot, SCHEME_OBJECT bkpt_proceed (insn_t * ep, SCHEME_OBJECT handle, SCHEME_OBJECT state) { - if (! ((CC_ENTRY_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) - && ((CC_ENTRY_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) == ep))) + if (! ((CC_RETURN_P (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) + && ((CC_RETURN_ADDRESS (STACK_REF (BKPT_PROCEED_FRAME_SIZE))) == ep))) error_external_return (); PUSH_REFLECTION (REFLECT_CODE_CC_BKPT); stack_pointer = (STACK_LOC (-BKPT_PROCEED_FRAME_SIZE)); diff --git a/src/microcode/cmpint.h b/src/microcode/cmpint.h index c812a8833..c74805e67 100644 --- a/src/microcode/cmpint.h +++ b/src/microcode/cmpint.h @@ -137,19 +137,6 @@ struct cc_entry_offset_s extern bool read_cc_entry_offset (cc_entry_offset_t *, insn_t *); extern bool write_cc_entry_offset (cc_entry_offset_t *, insn_t *); -#define CC_ENTRY_ADDRESS(obj) ((insn_t *) (OBJECT_ADDRESS (obj))) -#define MAKE_CC_ENTRY(addr) \ - (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (addr)))) - -#define CC_ENTRY_NEW_ADDRESS(entry, address) \ - (OBJECT_NEW_ADDRESS ((entry), ((insn_t *) (address)))) - -#define CC_ENTRY_NEW_BLOCK(entry, new_block, old_block) \ - (CC_ENTRY_NEW_ADDRESS ((entry), \ - (((insn_t *) (new_block)) \ - + ((CC_ENTRY_ADDRESS (entry)) \ - - ((insn_t *) (old_block)))))) - #define MAKE_CC_BLOCK(address) \ (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (address))) @@ -162,13 +149,78 @@ extern bool write_cc_entry_offset (cc_entry_offset_t *, insn_t *); #define CC_BLOCK_ADDR_END(addr) ((addr) + (CC_BLOCK_ADDR_LENGTH (addr))) #define CC_ENTRY_P(object) ((OBJECT_TYPE (object)) == TC_COMPILED_ENTRY) +#define CC_RETURN_P(object) ((OBJECT_TYPE (object)) == TC_COMPILED_RETURN) #define CC_BLOCK_P(object) ((OBJECT_TYPE (object)) == TC_COMPILED_CODE_BLOCK) #define CC_STACK_ENV_P(object) ((OBJECT_TYPE (object)) == TC_STACK_ENVIRONMENT) +static inline insn_t * +CC_ENTRY_ADDRESS (SCHEME_OBJECT obj) +{ + assert (CC_ENTRY_P (obj)); + return ((insn_t *) (OBJECT_ADDRESS (obj))); +} + +static inline SCHEME_OBJECT +MAKE_CC_ENTRY (insn_t * addr) +{ + return (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) addr))); +} + +static inline SCHEME_OBJECT +CC_ENTRY_NEW_ADDRESS (SCHEME_OBJECT entry, insn_t * addr) +{ + assert (CC_ENTRY_P (entry)); + return (OBJECT_NEW_ADDRESS (entry, addr)); +} + +static inline SCHEME_OBJECT +CC_ENTRY_NEW_BLOCK (SCHEME_OBJECT entry, + SCHEME_OBJECT * new_block, + SCHEME_OBJECT * old_block) +{ + size_t offset; + assert (CC_ENTRY_P (entry)); + offset = ((CC_ENTRY_ADDRESS (entry)) - ((insn_t *) old_block)); + return (CC_ENTRY_NEW_ADDRESS (entry, (((insn_t *) new_block) + offset))); +} + +static inline insn_t * +CC_RETURN_ADDRESS (SCHEME_OBJECT obj) +{ + assert (CC_RETURN_P (obj)); + return ((insn_t *) (OBJECT_ADDRESS (obj))); +} + +static inline SCHEME_OBJECT +MAKE_CC_RETURN (insn_t * addr) +{ + return (MAKE_POINTER_OBJECT (TC_COMPILED_RETURN, ((SCHEME_OBJECT *) addr))); +} + +static inline SCHEME_OBJECT +CC_RETURN_NEW_ADDRESS (SCHEME_OBJECT entry, insn_t * addr) +{ + assert (CC_RETURN_P (entry)); + return (OBJECT_NEW_ADDRESS (entry, addr)); +} + +static inline SCHEME_OBJECT +CC_RETURN_NEW_BLOCK (SCHEME_OBJECT entry, + SCHEME_OBJECT * new_block, + SCHEME_OBJECT * old_block) +{ + size_t offset = ((CC_RETURN_ADDRESS (entry)) - ((insn_t *) old_block)); + return (CC_RETURN_NEW_ADDRESS (entry, (((insn_t *) new_block) + offset))); +} + extern unsigned long cc_entry_to_block_offset (SCHEME_OBJECT); extern SCHEME_OBJECT cc_entry_to_block (SCHEME_OBJECT); extern SCHEME_OBJECT * cc_entry_to_block_address (SCHEME_OBJECT); extern SCHEME_OBJECT * cc_entry_address_to_block_address (insn_t *); +extern unsigned long cc_return_to_block_offset (SCHEME_OBJECT); +extern SCHEME_OBJECT cc_return_to_block (SCHEME_OBJECT); +extern SCHEME_OBJECT * cc_return_to_block_address (SCHEME_OBJECT); +extern SCHEME_OBJECT * cc_return_address_to_block_address (insn_t *); extern int plausible_cc_block_p (SCHEME_OBJECT *); /* Linkage sections @@ -327,6 +379,10 @@ extern unsigned long trampoline_entry_size (unsigned long); the address of the specified entry point. */ extern insn_t * trampoline_entry_addr (SCHEME_OBJECT *, unsigned long); +/* Given the address of a trampoline block and an entry index, returns + the address of the specified entry point as a return address. */ +extern insn_t * trampoline_return_addr (SCHEME_OBJECT *, unsigned long); + /* Given the address of a trampoline entry and the code for the trampoline to be invoked, stores the appropriate instruction sequence in the trampoline. */ @@ -368,7 +424,11 @@ typedef struct union { long code_to_interpreter; - insn_t * entry_point; + struct + { + insn_t * ptr; + insn_t * pc; + } compiled_code; } extra; } utility_result_t; diff --git a/src/microcode/cmpintmd/c.c b/src/microcode/cmpintmd/c.c index c798cba8a..69e83d1d1 100644 --- a/src/microcode/cmpintmd/c.c +++ b/src/microcode/cmpintmd/c.c @@ -164,3 +164,9 @@ trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index) { return (((insn_t *) (block + 2 + (index * 2))) + CC_ENTRY_HEADER_SIZE); } + +insn_t * +trampoline_return_addr (SCHEME_OBJECT * block, unsigned long index) +{ + return (trampoline_entry_addr (block, index)); +} diff --git a/src/microcode/cmpintmd/c.h b/src/microcode/cmpintmd/c.h index f5a831d5e..66cdd2932 100644 --- a/src/microcode/cmpintmd/c.h +++ b/src/microcode/cmpintmd/c.h @@ -130,6 +130,17 @@ typedef SCHEME_OBJECT insn_t; instructions are stored. */ #define CC_ENTRY_GC_TRAP_SIZE 0 +/* We don't distinguish the self pointer from an `instruction' pointer. */ +#define CC_ENTRY_ADDRESS_PTR(e) (e) +#define CC_ENTRY_ADDRESS_PC(e) (0) + +/* Same for return addresses. */ +#define CC_RETURN_ADDRESS_PTR(r) (r) +#define CC_RETURN_ADDRESS_PC(r) (0) + +/* Return addresses and entry addresses aren't distinguished here. */ +#define CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS(r) (r) + /* Size of execution cache in SCHEME_OBJECTS. */ #define UUO_LINK_SIZE 2 #define READ_UUO_TARGET(a, r) read_uuo_target (a) diff --git a/src/microcode/cmpintmd/i386.c b/src/microcode/cmpintmd/i386.c index b7722dbb8..08daa938b 100644 --- a/src/microcode/cmpintmd/i386.c +++ b/src/microcode/cmpintmd/i386.c @@ -221,6 +221,12 @@ trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index) + CC_ENTRY_HEADER_SIZE); } +insn_t * +trampoline_return_addr (SCHEME_OBJECT * block, unsigned long index) +{ + return (trampoline_entry_addr (block, index)); +} + bool store_trampoline_insns (insn_t * entry, uint8_t code) { diff --git a/src/microcode/cmpintmd/i386.h b/src/microcode/cmpintmd/i386.h index 19db8c088..4cf391b6e 100644 --- a/src/microcode/cmpintmd/i386.h +++ b/src/microcode/cmpintmd/i386.h @@ -211,6 +211,19 @@ typedef uint8_t insn_t; /* Number of insn_t units preceding entry header in which GC trap instructions are stored. */ #define CC_ENTRY_GC_TRAP_SIZE 3 + +/* Entry address is the self pointer for closures _and_ the instruction + pointer to jump to, since closures have embedded instructions. We + use only the self pointer so the `PC' is a dummy. */ +#define CC_ENTRY_ADDRESS_PTR(e) (e) +#define CC_ENTRY_ADDRESS_PC(e) (0) /* unused */ + +/* Same for return addresses. */ +#define CC_RETURN_ADDRESS_PTR(r) (r) +#define CC_RETURN_ADDRESS_PC(r) (0) /* unused */ + +/* Return addresses and entry addresses aren't distinguished here. */ +#define CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS(r) (r) #define EMBEDDED_CLOSURE_ADDRS_P 1 diff --git a/src/microcode/cmpintmd/svm1.c b/src/microcode/cmpintmd/svm1.c index d6c46a38e..4976b9e06 100644 --- a/src/microcode/cmpintmd/svm1.c +++ b/src/microcode/cmpintmd/svm1.c @@ -347,6 +347,12 @@ trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index) + CC_ENTRY_HEADER_SIZE); } +insn_t * +trampoline_return_addr (SCHEME_OBJECT * block, unsigned long index) +{ + return (trampoline_entry_addr (block, index)); +} + bool store_trampoline_insns (insn_t * entry, uint8_t code) { diff --git a/src/microcode/cmpintmd/svm1.h b/src/microcode/cmpintmd/svm1.h index 67c1746c6..4f64240f2 100644 --- a/src/microcode/cmpintmd/svm1.h +++ b/src/microcode/cmpintmd/svm1.h @@ -61,6 +61,17 @@ typedef uint8_t insn_t; /* Size of closure entry in insn_t units. */ #define CLOSURE_ENTRY_SIZE 5 +/* We don't distinguish the self pointer from an `instruction' pointer. */ +#define CC_ENTRY_ADDRESS_PTR(e) (e) +#define CC_ENTRY_ADDRESS_PC(e) (0) + +/* Same for return addresses. */ +#define CC_RETURN_ADDRESS_PTR(r) (r) +#define CC_RETURN_ADDRESS_PC(r) (0) + +/* Return addresses and entry addresses aren't distinguished here. */ +#define CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS(r) (r) + /* Size of execution cache in SCHEME_OBJECTS. */ #define UUO_LINK_SIZE 2 #define READ_UUO_TARGET(a, r) read_uuo_target (a) @@ -80,14 +91,16 @@ typedef struct return; \ } while (false) -#define RETURN_TO_SCHEME(ep) do \ +#define RETURN_TO_SCHEME_ENTRY(ep) do \ { \ (DSU_result->scheme_p) = true; \ ((DSU_result->arg) . new_pc) = (ep); \ return; \ } while (false) +#define RETURN_TO_SCHEME_CONTINUATION RETURN_TO_SCHEME_ENTRY -#define ENTER_SCHEME(ep) return (C_to_interface (ep)) +#define ENTER_SCHEME_ENTRY(ep) return (C_to_interface (ep)) +#define ENTER_SCHEME_CONTINUATION ENTER_SCHEME_ENTRY extern long C_to_interface (void *); extern void initialize_svm1 (void); diff --git a/src/microcode/cmpintmd/x86-64.c b/src/microcode/cmpintmd/x86-64.c index 3cf4f9aa9..be21835ae 100644 --- a/src/microcode/cmpintmd/x86-64.c +++ b/src/microcode/cmpintmd/x86-64.c @@ -243,6 +243,12 @@ trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index) + BYTES_PER_TRAMPOLINE_ENTRY_PADDING + CC_ENTRY_HEADER_SIZE); } +insn_t * +trampoline_return_addr (SCHEME_OBJECT * block, unsigned long index) +{ + return ((trampoline_entry_addr (block, index)) + 8); +} + bool store_trampoline_insns (insn_t * entry, uint8_t code) { diff --git a/src/microcode/cmpintmd/x86-64.h b/src/microcode/cmpintmd/x86-64.h index 6307bfb6c..d48aee366 100644 --- a/src/microcode/cmpintmd/x86-64.h +++ b/src/microcode/cmpintmd/x86-64.h @@ -154,6 +154,14 @@ typedef uint8_t insn_t; XXX Stop using CALL for this. */ #define CC_ENTRY_GC_TRAP_SIZE 6 + +#define CC_ENTRY_ADDRESS_PTR(e) (e) +#define CC_ENTRY_ADDRESS_PC(e) ((e) + (* ((const int64_t *) (e)))) + +#define CC_RETURN_ADDRESS_PTR(r) 0 +#define CC_RETURN_ADDRESS_PC(r) (r) + +#define CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS(r) (((insn_t *) (r)) - 8) #define EMBEDDED_CLOSURE_ADDRS_P 1 diff --git a/src/microcode/comutl.c b/src/microcode/comutl.c index 9c0206f5f..794cb9778 100644 --- a/src/microcode/comutl.c +++ b/src/microcode/comutl.c @@ -36,13 +36,18 @@ extern void get_liarc_compiled_block_data (unsigned long, const char **, void **, void **, void **); #endif +#define CC_ENTRY_OR_RETURN_P(x) ((CC_ENTRY_P (x)) || (CC_RETURN_P (x))) + DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block, 1, 1, "(ADDRESS)\n\ Given a compiled-code entry ADDRESS, return its block.") { PRIMITIVE_HEADER (1); - CHECK_ARG (1, CC_ENTRY_P); - PRIMITIVE_RETURN (cc_entry_to_block (ARG_REF (1))); + CHECK_ARG (1, CC_ENTRY_OR_RETURN_P); + if (CC_ENTRY_P (ARG_REF (1))) + PRIMITIVE_RETURN (cc_entry_to_block (ARG_REF (1))); + else + PRIMITIVE_RETURN (cc_return_to_block (ARG_REF (1))); } DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET", @@ -50,8 +55,13 @@ DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET", Given a compiled-code entry ADDRESS, return its offset into its block.") { PRIMITIVE_HEADER (1); - CHECK_ARG (1, CC_ENTRY_P); - PRIMITIVE_RETURN (ULONG_TO_FIXNUM (cc_entry_to_block_offset (ARG_REF (1)))); + CHECK_ARG (1, CC_ENTRY_OR_RETURN_P); + if (CC_ENTRY_P (ARG_REF (1))) + PRIMITIVE_RETURN + (ULONG_TO_FIXNUM (cc_entry_to_block_offset (ARG_REF (1)))); + else + PRIMITIVE_RETURN + (ULONG_TO_FIXNUM (cc_return_to_block_offset (ARG_REF (1)))); } DEFINE_PRIMITIVE ("STACK-TOP-ADDRESS", Prim_stack_top_address, 0, 0, 0) @@ -77,14 +87,21 @@ DEFINE_PRIMITIVE ("STACK-ADDRESS-OFFSET", Prim_stack_address_offset, 1, 1, 0) DEFINE_PRIMITIVE ("COMPILED-ENTRY-KIND", Prim_compiled_entry_kind, 1, 1, 0) { PRIMITIVE_HEADER (1); - CHECK_ARG (1, CC_ENTRY_P); + CHECK_ARG (1, CC_ENTRY_OR_RETURN_P); { + insn_t * addr; cc_entry_type_t cet; unsigned long kind = 4; unsigned long field1 = 0; long field2 = 0; - if (!read_cc_entry_type ((&cet), (CC_ENTRY_ADDRESS (ARG_REF (1))))) + if (CC_ENTRY_P (ARG_REF (1))) + addr = (CC_ENTRY_ADDRESS (ARG_REF (1))); + else + addr = + (CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS (CC_RETURN_ADDRESS (ARG_REF (1)))); + + if (!read_cc_entry_type ((&cet), addr)) switch (cet.marker) { case CET_PROCEDURE: diff --git a/src/microcode/debug.c b/src/microcode/debug.c index bf54b0361..13e5e44c1 100644 --- a/src/microcode/debug.c +++ b/src/microcode/debug.c @@ -625,6 +625,15 @@ print_object (outf_channel stream, SCHEME_OBJECT obj) case TC_COMPILED_ENTRY: print_compiled_entry (stream, obj); return; + + case TC_COMPILED_RETURN: + { + insn_t * ret_addr = (CC_RETURN_ADDRESS (obj)); + insn_t * entry_addr = (CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS (ret_addr)); + SCHEME_OBJECT entry = + (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, entry_addr)); + print_compiled_entry (stream, entry); + } #endif default: @@ -1223,11 +1232,15 @@ verify_heap_area (const char * name, SCHEME_OBJECT * area, SCHEME_OBJECT * end) break; #ifdef CC_SUPPORT_P - case GC_COMPILED: + case GC_COMPILED_ENTRY: if (! verify_compiled (object, (unsigned long)area)) complaints += 1; area += 1; break; + case GC_COMPILED_RETURN: + outf_error ("%#lx: XXX not implemented", (unsigned long)area); + complaints += 1; + break; #endif default: diff --git a/src/microcode/gc.h b/src/microcode/gc.h index b75ff7140..05879e951 100644 --- a/src/microcode/gc.h +++ b/src/microcode/gc.h @@ -31,9 +31,10 @@ USA. #include "object.h" +/* Must match %ENCODE-GC-TYPE in runtime/global.scm. */ typedef enum { - GC_COMPILED = -4, + GC_COMPILED_ENTRY = -4, GC_VECTOR, GC_SPECIAL, /* Internal GC types */ GC_UNDEFINED, @@ -41,7 +42,8 @@ typedef enum GC_CELL, GC_PAIR, GC_TRIPLE, - GC_QUADRUPLE + GC_QUADRUPLE, + GC_COMPILED_RETURN, } gc_type_t; #define GC_TYPE_TO_INT(type) ((int) (type)) @@ -56,12 +58,14 @@ typedef enum #define GC_TYPE_UNDEFINED(object) ((GC_TYPE (object)) == GC_UNDEFINED) #define GC_TYPE_SPECIAL(object) ((GC_TYPE (object)) == GC_SPECIAL) #define GC_TYPE_VECTOR(object) ((GC_TYPE (object)) == GC_VECTOR) -#define GC_TYPE_COMPILED(object) ((GC_TYPE (object)) == GC_COMPILED) +#define GC_TYPE_COMPILED_ENTRY(object) ((GC_TYPE (object)) == GC_COMPILED_ENTRY) +#define GC_TYPE_COMPILED_RETURN(object) ((GC_TYPE (object)) == GC_COMPILED_RETURN) typedef enum { GC_POINTER_NORMAL, - GC_POINTER_COMPILED, + GC_POINTER_COMPILED_ENTRY, + GC_POINTER_COMPILED_RETURN, GC_POINTER_NOT } gc_ptr_type_t; diff --git a/src/microcode/gccode.h b/src/microcode/gccode.h index 0bc4857b0..fdbc4e0d4 100644 --- a/src/microcode/gccode.h +++ b/src/microcode/gccode.h @@ -100,6 +100,7 @@ typedef struct gc_tuple_handler_t * tuple_handler; gc_vector_handler_t * vector_handler; gc_object_handler_t * cc_entry_handler; + gc_object_handler_t * cc_return_handler; gc_precheck_from_t * precheck_from; gc_transport_words_t * transport_words; gc_ignore_object_p_t * ignore_object_p; @@ -113,6 +114,7 @@ typedef struct #define GCT_TUPLE(table) ((table)->tuple_handler) #define GCT_VECTOR(table) ((table)->vector_handler) #define GCT_CC_ENTRY(table) ((table)->cc_entry_handler) +#define GCT_CC_RETURN(table) ((table)->cc_return_handler) #define GCT_PRECHECK_FROM(table) ((table)->precheck_from) #define GCT_TRANSPORT_WORDS(table) ((table)->transport_words) #define GCT_IGNORE_OBJECT_P(table) ((table)->ignore_object_p) @@ -130,6 +132,9 @@ typedef struct #define GC_HANDLE_CC_ENTRY(object) \ ((* (GCT_CC_ENTRY (current_gc_table))) (object)) +#define GC_HANDLE_CC_RETURN(object) \ + ((* (GCT_CC_RETURN (current_gc_table))) (object)) + #define GC_PRECHECK_FROM(from) \ ((* (GCT_PRECHECK_FROM (current_gc_table))) (from)) @@ -158,6 +163,7 @@ extern gc_handler_t gc_handle_quadruple; extern gc_handler_t gc_handle_weak_pair; extern gc_handler_t gc_handle_ephemeron; extern gc_handler_t gc_handle_cc_entry; +extern gc_handler_t gc_handle_cc_return; extern gc_handler_t gc_handle_aligned_vector; extern gc_handler_t gc_handle_unaligned_vector; extern gc_handler_t gc_handle_broken_heart; @@ -170,6 +176,7 @@ extern gc_handler_t gc_handle_undefined; extern gc_tuple_handler_t gc_tuple; extern gc_vector_handler_t gc_vector; extern gc_object_handler_t gc_cc_entry; +extern gc_object_handler_t gc_cc_return; extern gc_precheck_from_t gc_precheck_from; extern gc_precheck_from_t gc_precheck_from_no_transport; extern gc_transport_words_t gc_transport_words; diff --git a/src/microcode/gcloop.c b/src/microcode/gcloop.c index f5aa71dfb..527257fda 100644 --- a/src/microcode/gcloop.c +++ b/src/microcode/gcloop.c @@ -326,7 +326,8 @@ initialize_gc_table (gc_table_t * table, bool transport_p) case GC_TRIPLE: SIMPLE_HANDLER (gc_handle_triple); case GC_QUADRUPLE: SIMPLE_HANDLER (gc_handle_quadruple); case GC_VECTOR: SIMPLE_HANDLER (gc_handle_unaligned_vector); - case GC_COMPILED: SIMPLE_HANDLER (gc_handle_cc_entry); + case GC_COMPILED_ENTRY: SIMPLE_HANDLER (gc_handle_cc_entry); + case GC_COMPILED_RETURN: SIMPLE_HANDLER (gc_handle_cc_return); case GC_UNDEFINED: SIMPLE_HANDLER (gc_handle_undefined); case GC_SPECIAL: @@ -360,6 +361,7 @@ initialize_gc_table (gc_table_t * table, bool transport_p) (GCT_TUPLE (table)) = gc_tuple; (GCT_VECTOR (table)) = gc_vector; (GCT_CC_ENTRY (table)) = gc_cc_entry; + (GCT_CC_RETURN (table)) = gc_cc_return; if (transport_p) { (GCT_PRECHECK_FROM (table)) = gc_precheck_from; @@ -486,6 +488,20 @@ DEFINE_GC_OBJECT_HANDLER (gc_cc_entry) #endif } +DEFINE_GC_OBJECT_HANDLER (gc_cc_return) +{ +#ifdef CC_SUPPORT_P + SCHEME_OBJECT old_block = (cc_return_to_block (object)); + SCHEME_OBJECT new_block = (GC_HANDLE_VECTOR (old_block, true)); + return (CC_RETURN_NEW_BLOCK (object, + (OBJECT_ADDRESS (new_block)), + (OBJECT_ADDRESS (old_block)))); +#else + gc_no_cc_support (); + return (object); +#endif +} + DEFINE_GC_PRECHECK_FROM (gc_precheck_from) { #if 0 @@ -619,6 +635,12 @@ DEFINE_GC_HANDLER (gc_handle_cc_entry) return (scan + 1); } +DEFINE_GC_HANDLER (gc_handle_cc_return) +{ + (*scan) = (GC_HANDLE_CC_RETURN (object)); + return (scan + 1); +} + DEFINE_GC_HANDLER (gc_handle_aligned_vector) { (*scan) = (GC_HANDLE_VECTOR (object, true)); @@ -805,13 +827,20 @@ weak_referent_address (SCHEME_OBJECT object) case GC_POINTER_NORMAL: return (OBJECT_ADDRESS (object)); - case GC_POINTER_COMPILED: + case GC_POINTER_COMPILED_ENTRY: #ifdef CC_SUPPORT_P return (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (object))); #else gc_no_cc_support (); #endif + case GC_POINTER_COMPILED_RETURN: +#ifdef CC_SUPPORT_P + return (cc_return_address_to_block_address (CC_RETURN_ADDRESS (object))); +#else + gc_no_cc_support (); +#endif + default: return (0); } @@ -830,7 +859,7 @@ weak_referent_forward (SCHEME_OBJECT object) return (MAKE_OBJECT_FROM_OBJECTS (object, (*addr))); return (SHARP_F); - case GC_POINTER_COMPILED: + case GC_POINTER_COMPILED_ENTRY: #ifdef CC_SUPPORT_P addr = (cc_entry_address_to_block_address (CC_ENTRY_ADDRESS (object))); if (BROKEN_HEART_P (*addr)) @@ -840,6 +869,16 @@ weak_referent_forward (SCHEME_OBJECT object) #endif return (SHARP_F); + case GC_POINTER_COMPILED_RETURN: +#ifdef CC_SUPPORT_P + addr = (cc_return_address_to_block_address (CC_RETURN_ADDRESS (object))); + if (BROKEN_HEART_P (*addr)) + return (CC_RETURN_NEW_BLOCK (object, (OBJECT_ADDRESS (*addr)), addr)); +#else + gc_no_cc_support (); +#endif + return (SHARP_F); + case GC_POINTER_NOT: default: /* suppress bogus GCC warning */ std_gc_death ("Non-pointer cannot be a weak reference."); @@ -1253,7 +1292,7 @@ gc_type_t gc_type_map [N_TYPE_CODES] = GC_PAIR, /* TC_LIST */ GC_NON_POINTER, /* TC_CHARACTER */ GC_PAIR, /* TC_SCODE_QUOTE */ - GC_UNDEFINED, /* was TC_PCOMB2 */ + GC_COMPILED_RETURN, /* TC_COMPILED_RETURN */ GC_PAIR, /* TC_UNINTERNED_SYMBOL */ GC_VECTOR, /* TC_BIG_FLONUM */ GC_UNDEFINED, /* was TC_COMBINATION_1 */ @@ -1289,7 +1328,7 @@ gc_type_t gc_type_map [N_TYPE_CODES] = GC_PAIR, /* TC_TAGGED_OBJECT */ GC_VECTOR, /* TC_COMBINATION */ GC_SPECIAL, /* TC_MANIFEST_NM_VECTOR */ - GC_COMPILED, /* TC_COMPILED_ENTRY */ + GC_COMPILED_ENTRY, /* TC_COMPILED_ENTRY */ GC_PAIR, /* TC_LEXPR */ GC_UNDEFINED, /* was TC_PCOMB3 */ GC_VECTOR, /* TC_EPHEMERON */ @@ -1344,9 +1383,10 @@ gc_ptr_type (SCHEME_OBJECT object) case GC_VECTOR: return (GC_POINTER_NORMAL); - case GC_COMPILED: - return (GC_POINTER_COMPILED); - break; + case GC_COMPILED_ENTRY: + return (GC_POINTER_COMPILED_ENTRY); + case GC_COMPILED_RETURN: + return (GC_POINTER_COMPILED_RETURN); default: return (GC_POINTER_NOT); @@ -1361,11 +1401,16 @@ get_object_address (SCHEME_OBJECT object) case GC_POINTER_NORMAL: return (OBJECT_ADDRESS (object)); - case GC_POINTER_COMPILED: + case GC_POINTER_COMPILED_ENTRY: #ifdef CC_SUPPORT_P return (cc_entry_to_block_address (object)); #endif + case GC_POINTER_COMPILED_RETURN: +#ifdef CC_SUPPORT_P + return (cc_return_to_block_address (object)); +#endif + default: return (0); } diff --git a/src/microcode/hooks.c b/src/microcode/hooks.c index 0aa5bb01f..577decc36 100644 --- a/src/microcode/hooks.c +++ b/src/microcode/hooks.c @@ -97,12 +97,16 @@ Invokes PROCEDURE on the arguments in ARG-LIST.") } #ifdef CC_SUPPORT_P - if (CC_ENTRY_P (STACK_REF (n_args))) + if (CC_RETURN_P (STACK_REF (n_args))) { apply_compiled_from_primitive (n_args, procedure); UN_POP_PRIMITIVE_FRAME (2); PRIMITIVE_RETURN (UNSPECIFIC); } + else + { + assert (RETURN_CODE_P (STACK_REF (n_args))); + } #endif STACK_PUSH (procedure); @@ -491,7 +495,7 @@ and MARKER2 is data identifying the marker instance.") { SCHEME_OBJECT thunk = (ARG_REF (1)); #ifdef CC_SUPPORT_P - if ((CC_ENTRY_P (STACK_REF (3))) && (CC_ENTRY_P (thunk))) + if ((CC_RETURN_P (STACK_REF (3))) && (CC_ENTRY_P (thunk))) { (void) STACK_POP (); compiled_with_stack_marker (thunk); @@ -544,7 +548,7 @@ with_new_interrupt_mask (unsigned long new_mask) SCHEME_OBJECT receiver = (ARG_REF (2)); #ifdef CC_SUPPORT_P - if ((CC_ENTRY_P (STACK_REF (2))) && (CC_ENTRY_P (receiver))) + if ((CC_RETURN_P (STACK_REF (2))) && (CC_ENTRY_P (receiver))) { unsigned long current_mask = GET_INT_MASK; POP_PRIMITIVE_FRAME (2); diff --git a/src/microcode/svm1-interp.c b/src/microcode/svm1-interp.c index 872184afc..41248b44d 100644 --- a/src/microcode/svm1-interp.c +++ b/src/microcode/svm1-interp.c @@ -1132,8 +1132,9 @@ DEFINE_INST (enter_closure) SCHEME_OBJECT * targets = (skip_compiled_closure_padding (block + (CLOSURE_ENTRY_START + (count * CLOSURE_ENTRY_SIZE)))); - push_object (MAKE_CC_ENTRY (((SCHEME_OBJECT *) - (block + CLOSURE_ENTRY_OFFSET)))); + push_object + (MAKE_CC_ENTRY + ((insn_t *) ((SCHEME_OBJECT *) (block + CLOSURE_ENTRY_OFFSET)))); NEW_PC (BYTE_ADDR (OBJECT_ADDRESS (targets[index]))); } } diff --git a/src/microcode/typename.txt b/src/microcode/typename.txt index ea904c5b2..7476a05fb 100644 --- a/src/microcode/typename.txt +++ b/src/microcode/typename.txt @@ -6,7 +6,7 @@ 01 04 LIST 23 8C ASSIGNMENT 02 08 CHARACTER 0E 38 BIG-FIXNUM 03 0C SCODE-QUOTE 06 18 BIG-FLONUM -04 10 UNUSED-04 22 88 BROKEN-HEART +04 10 COMPILED-RETURN 22 88 BROKEN-HEART 05 14 UNINTERNED-SYMBOL 36 D8 CELL 06 18 BIG-FLONUM 02 08 CHARACTER 07 1C UNUSED-07 1E 78 CHARACTER-STRING @@ -14,45 +14,45 @@ 09 24 EXTENDED-PROCEDURE 15 54 COMMENT 0A 28 VECTOR 3D F4 COMPILED-CODE-BLOCK 0B 2C RETURN-CODE 28 A0 COMPILED-ENTRY -0C 30 UNUSED-0C 3C F0 COMPLEX -0D 34 MANIFEST-CLOSURE 34 D0 CONDITIONAL -0E 38 BIG-FIXNUM 08 20 CONSTANT -0F 3C PROCEDURE 1C 70 CONTROL-POINT -10 40 ENTITY 21 84 DEFINITION -11 44 DELAY 11 44 DELAY -12 48 ENVIRONMENT 13 4C DELAYED -13 4C DELAYED 35 D4 DISJUNCTION -14 50 EXTENDED-LAMBDA 10 40 ENTITY -15 54 COMMENT 12 48 ENVIRONMENT -16 58 NON-MARKED-VECTOR 2B AC EPHEMERON -17 5C LAMBDA 14 50 EXTENDED-LAMBDA -18 60 PRIMITIVE 09 24 EXTENDED-PROCEDURE -19 64 SEQUENCE 1A 68 FIXNUM -1A 68 FIXNUM 20 80 HUNK3-A -1B 6C UNUSED-1B 24 90 HUNK3-B -1C 70 CONTROL-POINT 1D 74 INTERNED-SYMBOL -1D 74 INTERNED-SYMBOL 17 5C LAMBDA -1E 78 CHARACTER-STRING 29 A4 LEXPR -1F 7C ACCESS 39 E4 LINKAGE-SECTION -20 80 HUNK3-A 01 04 LIST -21 84 DEFINITION 0D 34 MANIFEST-CLOSURE -22 88 BROKEN-HEART 27 9C MANIFEST-NM-VECTOR -23 8C ASSIGNMENT 16 58 NON-MARKED-VECTOR -24 90 HUNK3-B 00 00 NULL -25 94 UNUSED-25 18 60 PRIMITIVE -26 98 COMBINATION 0F 3C PROCEDURE -27 9C MANIFEST-NM-VECTOR 38 E0 QUAD -28 A0 COMPILED-ENTRY 3A E8 RATNUM -29 A4 LEXPR 3E F8 RECORD -2A A8 UNUSED-2A 32 C8 REFERENCE-TRAP -2B AC EPHEMERON 0B 2C RETURN-CODE -2C B0 VARIABLE 03 0C SCODE-QUOTE -2D B4 THE-ENVIRONMENT 19 64 SEQUENCE -2E B8 SYNTAX-ERROR 3B EC STACK-ENVIRONMENT -2F BC VECTOR-1B 2E B8 SYNTAX-ERROR -30 C0 UNUSED-30 2D B4 THE-ENVIRONMENT -31 C4 VECTOR-16B 05 14 UNINTERNED-SYMBOL -32 C8 REFERENCE-TRAP 04 10 UNUSED-04 +0C 30 UNUSED-0C 04 10 COMPILED-RETURN +0D 34 MANIFEST-CLOSURE 3C F0 COMPLEX +0E 38 BIG-FIXNUM 34 D0 CONDITIONAL +0F 3C PROCEDURE 08 20 CONSTANT +10 40 ENTITY 1C 70 CONTROL-POINT +11 44 DELAY 21 84 DEFINITION +12 48 ENVIRONMENT 11 44 DELAY +13 4C DELAYED 13 4C DELAYED +14 50 EXTENDED-LAMBDA 35 D4 DISJUNCTION +15 54 COMMENT 10 40 ENTITY +16 58 NON-MARKED-VECTOR 12 48 ENVIRONMENT +17 5C LAMBDA 2B AC EPHEMERON +18 60 PRIMITIVE 14 50 EXTENDED-LAMBDA +19 64 SEQUENCE 09 24 EXTENDED-PROCEDURE +1A 68 FIXNUM 1A 68 FIXNUM +1B 6C UNUSED-1B 20 80 HUNK3-A +1C 70 CONTROL-POINT 24 90 HUNK3-B +1D 74 INTERNED-SYMBOL 1D 74 INTERNED-SYMBOL +1E 78 CHARACTER-STRING 17 5C LAMBDA +1F 7C ACCESS 29 A4 LEXPR +20 80 HUNK3-A 39 E4 LINKAGE-SECTION +21 84 DEFINITION 01 04 LIST +22 88 BROKEN-HEART 0D 34 MANIFEST-CLOSURE +23 8C ASSIGNMENT 27 9C MANIFEST-NM-VECTOR +24 90 HUNK3-B 16 58 NON-MARKED-VECTOR +25 94 UNUSED-25 00 00 NULL +26 98 COMBINATION 18 60 PRIMITIVE +27 9C MANIFEST-NM-VECTOR 0F 3C PROCEDURE +28 A0 COMPILED-ENTRY 38 E0 QUAD +29 A4 LEXPR 3A E8 RATNUM +2A A8 UNUSED-2A 3E F8 RECORD +2B AC EPHEMERON 32 C8 REFERENCE-TRAP +2C B0 VARIABLE 0B 2C RETURN-CODE +2D B4 THE-ENVIRONMENT 03 0C SCODE-QUOTE +2E B8 SYNTAX-ERROR 19 64 SEQUENCE +2F BC VECTOR-1B 3B EC STACK-ENVIRONMENT +30 C0 UNUSED-30 2E B8 SYNTAX-ERROR +31 C4 VECTOR-16B 2D B4 THE-ENVIRONMENT +32 C8 REFERENCE-TRAP 05 14 UNINTERNED-SYMBOL 33 CC UNUSED-33 07 1C UNUSED-07 34 D0 CONDITIONAL 0C 30 UNUSED-0C 35 D4 DISJUNCTION 1B 6C UNUSED-1B diff --git a/src/microcode/types.h b/src/microcode/types.h index fc9aa4686..e8412d724 100644 --- a/src/microcode/types.h +++ b/src/microcode/types.h @@ -30,7 +30,7 @@ USA. #define TC_LIST 0x01 #define TC_CHARACTER 0x02 #define TC_SCODE_QUOTE 0x03 -/* #define TC_PCOMB2 0x04 */ +#define TC_COMPILED_RETURN 0x04 #define TC_UNINTERNED_SYMBOL 0x05 #define TC_BIG_FLONUM 0x06 /* #define TC_COMBINATION_1 0x07 */ @@ -108,7 +108,7 @@ USA. /* 0x01 */ "pair", \ /* 0x02 */ "character", \ /* 0x03 */ "quotation", \ - /* 0x04 */ 0, \ + /* 0x04 */ "compiled-return", \ /* 0x05 */ "uninterned-symbol", \ /* 0x06 */ "flonum", \ /* 0x07 */ 0, \ diff --git a/src/microcode/utils.c b/src/microcode/utils.c index a4dda6c9f..6d0f1bf83 100644 --- a/src/microcode/utils.c +++ b/src/microcode/utils.c @@ -217,7 +217,7 @@ canonicalize_primitive_context (void) n_args = (PRIMITIVE_N_ARGUMENTS (primitive)); #ifdef CC_SUPPORT_P - if (CC_ENTRY_P (STACK_REF (n_args))) + if (CC_RETURN_P (STACK_REF (n_args))) { /* The primitive has been invoked from compiled code. */ STACK_PUSH (primitive); @@ -228,6 +228,8 @@ canonicalize_primitive_context (void) /*NOTREACHED*/ } #endif + + assert (RETURN_CODE_P (STACK_REF (n_args))); } /* back_out_of_primitive sets the registers up so that the backout diff --git a/src/runtime/global.scm b/src/runtime/global.scm index e9a6675d4..b824568f3 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -305,10 +305,11 @@ USA. (define (%encode-gc-type t) (if (not (and (fix:fixnum? t) (fix:>= t -4) - (fix:<= t 4))) + (fix:<= t 5))) (error "Illegal GC-type value:" t)) + ;; Must match enum gc_type_t in microcode/gc.h. (vector-ref '#(compiled-entry vector gc-internal undefined non-pointer - cell pair triple quadruple) + cell pair triple quadruple compiled-return) (fix:+ t 4))) (define (object-non-pointer? object) @@ -337,7 +338,7 @@ USA. (define (pointer-type-code? code) (case (type-code->gc-type code) - ((cell pair triple quadruple vector compiled-entry) #t) + ((cell pair triple quadruple vector compiled-entry compiled-return) #t) ((gc-internal) (fix:= (ucode-type broken-heart) code)) (else #f))) diff --git a/src/runtime/microcode-data.scm b/src/runtime/microcode-data.scm index a31e23f68..70555c286 100644 --- a/src/runtime/microcode-data.scm +++ b/src/runtime/microcode-data.scm @@ -65,8 +65,10 @@ USA. ;;;; Compiled Code Entries -(define-integrable (compiled-code-address? object) - (object-type? (ucode-type compiled-entry) object)) +(define (compiled-code-address? object) + (or (let ((type (microcode-type/name->code 'compiled-return))) + (and type (object-type? type object))) + (object-type? (ucode-type compiled-entry) object))) (define-integrable (stack-address? object) (object-type? (ucode-type stack-environment) object)) diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm index addc95bfe..573469988 100644 --- a/src/runtime/predicate-tagging.scm +++ b/src/runtime/predicate-tagging.scm @@ -81,6 +81,8 @@ USA. (define-primitive-predicate 'cell cell?) (define-primitive-predicate 'character char?) (define-primitive-predicate 'compiled-code-block compiled-code-block?) + (if (microcode-type/name->code 'compiled-return) + (define-primitive-predicate 'compiled-return compiled-return-address?)) (define-primitive-predicate 'conditional scode-conditional?) (define-primitive-predicate 'control-point control-point?) (define-primitive-predicate 'definition scode-definition?) diff --git a/src/runtime/printer.scm b/src/runtime/printer.scm index 454d16a1d..9f87c1e84 100644 --- a/src/runtime/printer.scm +++ b/src/runtime/printer.scm @@ -420,7 +420,13 @@ USA. (uninterned-symbol ,print-uninterned-symbol) (variable ,print-variable) (vector ,print-vector) - (vector-1b ,print-bit-string))))) + (vector-1b ,print-bit-string))) + ;; XXX Provisional until next release with the entry/return split. + (cond ((microcode-type/name->code 'compiled-return) + => (lambda (type-code:compiled-return) + (vector-set! dispatch-table + type-code:compiled-return + print-compiled-entry)))))) ;;;; Low Level Operations @@ -557,7 +563,7 @@ USA. (define (print-default object context) (let ((type (user-object-type object))) (case (object-gc-type object) - ((cell pair triple quadruple vector compiled-entry) + ((cell pair triple quadruple vector compiled-entry compiled-return) (*print-with-brackets type object context '())) (else ;non-pointer, undefined, gc-internal (*print-with-brackets type object context (maybe-print-datum object)))))) -- 2.25.1