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.
(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)
(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)
(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)
(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))))
(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
(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!)
(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
(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
(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)
# 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)
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)
#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)
OP(mov,q) TW(REG(rsi),REG(rdi)) # arg2 (arg) -> arg1
jmp IJMP(REG(rax)) # tail-call fn(arg)
\f
-# 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
# 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
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
# 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.
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)')
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(`
')
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.
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))
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))
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:
/* 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). */
\f
typedef long cache_handler_t (SCHEME_OBJECT, SCHEME_OBJECT, unsigned long);
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);
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 */
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 *);
#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))
\f
#ifndef COMPILER_REGBLOCK_N_FIXED
# define COMPILER_REGBLOCK_N_FIXED REGBLOCK_MINIMUM_LENGTH
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);
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);
}
}
\f
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))
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)));
{ \
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 \
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))
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
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
if (result != PRIM_DONE)
return (result);
- ENTER_SCHEME (s.return_address);
+ ENTER_SCHEME_ENTRY (s.return_address);
}
static long
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,
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);
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)
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)
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)
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)
}
}
}
+
+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)));
+}
\f
static bool
plausible_first_cc_entry_p (insn_t * entry, insn_t * zero)
- ((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)
{
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:
STACK_PUSH (code);
RETURN_TO_C (code);
}
- RETURN_TO_SCHEME (addr);
+ RETURN_TO_SCHEME_ENTRY (addr);
}
default:
{
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)
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)
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)
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)
STACK_PUSH (DEFAULT_OBJECT);
STACK_PUSH (a1);
}
- RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
+ RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure));
}
\f
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)
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)
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)
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)
STACK_PUSH (a2);
STACK_PUSH (a1);
}
- RETURN_TO_SCHEME (CC_ENTRY_ADDRESS (procedure));
+ RETURN_TO_SCHEME_ENTRY (CC_ENTRY_ADDRESS (procedure));
}
\f
/* The linker either couldn't find a binding or the binding was
= (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)));
}
}
\f
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));
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)))
#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 *);
\f
/* Linkage sections
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. */
union
{
long code_to_interpreter;
- insn_t * entry_point;
+ struct
+ {
+ insn_t * ptr;
+ insn_t * pc;
+ } compiled_code;
} extra;
} utility_result_t;
{
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));
+}
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)
+ 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)
{
/* 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)
\f
#define EMBEDDED_CLOSURE_ADDRS_P 1
+ 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)
{
/* 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)
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);
+ 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)
{
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)
\f
#define EMBEDDED_CLOSURE_ADDRS_P 1
(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",
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)
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:
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:
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:
#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,
GC_CELL,
GC_PAIR,
GC_TRIPLE,
- GC_QUADRUPLE
+ GC_QUADRUPLE,
+ GC_COMPILED_RETURN,
} gc_type_t;
#define GC_TYPE_TO_INT(type) ((int) (type))
#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;
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;
#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)
#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))
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;
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;
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:
(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;
#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
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));
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);
}
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))
#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.");
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 */
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 */
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);
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);
}
}
#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);
{
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);
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);
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])));
}
}
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
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
#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 */
/* 0x01 */ "pair", \
/* 0x02 */ "character", \
/* 0x03 */ "quotation", \
- /* 0x04 */ 0, \
+ /* 0x04 */ "compiled-return", \
/* 0x05 */ "uninterned-symbol", \
/* 0x06 */ "flonum", \
/* 0x07 */ 0, \
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);
/*NOTREACHED*/
}
#endif
+
+ assert (RETURN_CODE_P (STACK_REF (n_args)));
}
/* back_out_of_primitive sets the registers up so that the backout
(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)
(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)))
\f
;;;; 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))
(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?)
(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))))))
\f
;;;; Low Level Operations
(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))))))
projects / mit-scheme.git / commitdiff