(LAP (JMP ,entry)))
;; Invoke a hook that will pop an untagged return address off the stack
-;; and jump to it with RET, just like a C subroutine.
+;; and jump to it with RET, just like a C subroutine. To be used for
+;; super-cheap assembly hooks that never fail but are a little too
+;; large to copy in every caller.
(define-integrable (invoke-hook/subroutine entry)
(LAP (CALL ,entry)))
-;; Invoke a hook that expects a compiled entry address in rbx and will
-;; jump to it with JMP.
-
-(define (invoke-hook/reentry entry)
- (let ((label (generate-label 'HOOK-REENTRY)))
- (LAP (LEA Q (R ,rbx) (@PCRO ,label 12)) ;Skip format word and PC offset.
- ,@(invoke-hook entry)
- (LABEL ,label))))
+;; Invoke a hook that expects a compiled return address on the stack,
+;; may examine it, and will eventually pop it and return to it with
+;; RET. It is worthwhile to use paired CALL/RET here because in the
+;; fast path, non-error case, the hook will just return to Scheme; only
+;; in error or complicated cases will it return to C. To be used for
+;; compiler utilities that are usually cheap but may have error cases
+;; and may call back into C.
+
+(define-integrable (invoke-hook/call entry label)
+ (LAP (CALL ,entry)
+ (JMP (@PCR ,label))))
+
+;; Invoke a hook that expects a compiled entry address in rbx (first
+;; utility argument) and will later jump to it with JMP. It is not
+;; worthwhile to use paired CALL/RET here because the microcode will
+;; RET back into C code on the C stack to handle it, which wrecks the
+;; return address branch target predictor anyway. To be used for,
+;; e.g., interrupts, which are assumed to be always expensive.
+
+(define-integrable (invoke-hook/reentry entry label)
+ (LAP (LEA Q (R ,rbx) (@PCR ,label))
+ ,@(invoke-hook entry)))
(define-integrable (invoke-interface code)
(LAP (MOV B (R ,r9) (& ,code))
,@(invoke-hook entry:compiler-scheme-to-interface)))
-(define-integrable (invoke-interface/call code)
+(define-integrable (invoke-interface/call code label)
+ (LAP (MOV B (R ,r9) (& ,code))
+ ,@(invoke-hook/call entry:compiler-scheme-to-interface/call label)))
+
+(define-integrable (invoke-interface/reentry code label)
(LAP (MOV B (R ,r9) (& ,code))
- ,@(invoke-hook/reentry entry:compiler-scheme-to-interface/call)))
+ ,@(invoke-hook/reentry entry:compiler-scheme-to-interface label)))
\f
(define-syntax define-entries
(sc-macro-transformer
;;; interrupt handler that saves and restores the dynamic link
;;; register.
-(define (interrupt-check interrupt-label checks)
+(define (interrupt-check checks invoke)
;; This always does interrupt checks in line.
(let ((branch-target (generate-label 'INTERRUPT)))
;; Put the interrupt check branch target after the branch so that
;; it is a forward branch, which Intel and AMD CPUs will predict
;; not taken by default, in the absence of dynamic branch
- ;; prediction profile data.
+ ;; prediction profile data. Also probably worthwhile to keep it
+ ;; far away so that it doesn't occupy space in the instruction
+ ;; cache.
(add-end-of-block-code!
(lambda ()
(LAP (LABEL ,branch-target)
- (JMP (@PCR ,interrupt-label)))))
+ ,@invoke)))
(LAP ,@(if (or (memq 'INTERRUPT checks) (memq 'HEAP checks))
(LAP (CMP Q (R ,regnum:free-pointer) ,reg:compiled-memtop)
(JGE (@PCR ,branch-target)))
(define (simple-procedure-header code-word label entry)
(let ((checks (get-entry-interrupt-checks)))
- (if (null? checks)
- (LAP ,@(make-external-label code-word label))
- (let ((gc-label (generate-label)))
- (LAP (LABEL ,gc-label)
- ,@(invoke-hook/reentry entry)
- ,@(make-external-label code-word label)
- ,@(interrupt-check gc-label checks))))))
+ (LAP ,@(make-external-label code-word label)
+ ,@(interrupt-check checks (invoke-hook/reentry entry label)))))
(define-rule statement
(CONTINUATION-ENTRY (? internal-label))
(define-rule statement
(CONTINUATION-HEADER (? internal-label))
#|
- ;; Note: This is wrong -- compiler-interrupt-continuation expects a
- ;; compiled return address on the stack, but this will yield compiled
- ;; entry addresses. If you uncomment this, prepare to deal with the
- ;; consequences.
(simple-procedure-header (continuation-code-word internal-label)
internal-label
entry:compiler-interrupt-continuation)
(make-external-label (continuation-code-word internal-label)
internal-label))
+;;; XXX This rule has obviously never been exercised, since it was
+;;; broken for a decade and nobody noticed. Maybe we should delete it.
+
(define-rule statement
(IC-PROCEDURE-HEADER (? internal-label))
- (get-entry-interrupt-checks) ; force search
(let ((procedure (label->object internal-label)))
(let ((external-label (rtl-procedure/external-label procedure))
- (gc-label (generate-label)))
+ (checks (get-entry-interrupt-checks)))
(LAP (ENTRY-POINT ,external-label)
(EQUATE ,external-label ,internal-label)
- (LABEL ,gc-label)
- ,@(invoke-interface/call code:compiler-interrupt-ic-procedure)
,@(make-external-label expression-code-word internal-label)
- ,@(interrupt-check gc-label)))))
+ ,@(interrupt-check
+ checks
+ (invoke-interface/reentry code:compiler-interrupt-ic-procedure
+ internal-label))))))
(define-rule statement
(OPEN-PROCEDURE-HEADER (? internal-label))
internal-label
entry:compiler-interrupt-procedure)))
((pair? checks)
- (let ((gc-label (generate-label 'GC-LABEL)))
- (LAP (LABEL ,gc-label)
- ,@(invoke-hook entry:compiler-interrupt-closure)
- ,@(label+adjustment)
- ,@(interrupt-check gc-label checks))))
+ (LAP ,@(label+adjustment)
+ ,@(interrupt-check
+ checks
+ (invoke-hook entry:compiler-interrupt-closure))))
(else
(label+adjustment)))))
;;; This is invoked by the top level of the LAP generator.
(define (generate/quotation-header environment-label free-ref-label n-sections)
- (LAP (MOV Q (R ,rax) ,reg:environment)
- (MOV Q (@PCR ,environment-label) (R ,rax))
- (LEA Q (R ,rdx) (@PCR ,*block-label*))
- (LEA Q (R ,rcx) (@PCR ,free-ref-label))
- (MOV Q (R ,r8) (&U ,n-sections))
- #|
- ,@(invoke-interface/call code:compiler-link)
- |#
- ,@(invoke-hook/reentry entry:compiler-link)
- ,@(make-external-label (continuation-code-word #f)
- (generate-label))))
+ (let ((continuation-label (generate-label 'LINKED)))
+ (LAP (MOV Q (R ,rax) ,reg:environment)
+ (MOV Q (@PCR ,environment-label) (R ,rax))
+ (LEA Q (R ,rdx) (@PCR ,*block-label*))
+ (LEA Q (R ,rcx) (@PCR ,free-ref-label))
+ (MOV Q (R ,r8) (&U ,n-sections))
+ #|
+ ,@(invoke-interface/call code:compiler-link continuation-label)
+ |#
+ ,@(invoke-hook/call entry:compiler-link continuation-label)
+ ,@(make-external-label (continuation-code-word #f)
+ continuation-label))))
(define (generate/remote-link code-block-label
environment-offset
free-ref-offset
n-sections)
- (LAP (MOV Q (R ,rdx) (@PCR ,code-block-label))
- (AND Q (R ,rdx) (R ,regnum:datum-mask))
- (LEA Q (R ,rcx) (@RO ,rdx ,free-ref-offset))
- (MOV Q (R ,rax) ,reg:environment)
- (MOV Q (@RO ,rdx ,environment-offset) (R ,rax))
- (MOV Q (R ,r8) (&U ,n-sections))
- #|
- ,@(invoke-interface/call code:compiler-link)
- |#
- ,@(invoke-hook/reentry entry:compiler-link)
- ,@(make-external-label (continuation-code-word #f)
- (generate-label))))
+ (let ((continuation-label (generate-label 'LINKED)))
+ (LAP (MOV Q (R ,rdx) (@PCR ,code-block-label))
+ (AND Q (R ,rdx) (R ,regnum:datum-mask))
+ (LEA Q (R ,rcx) (@RO ,rdx ,free-ref-offset))
+ (MOV Q (R ,rax) ,reg:environment)
+ (MOV Q (@RO ,rdx ,environment-offset) (R ,rax))
+ (MOV Q (R ,r8) (&U ,n-sections))
+ #|
+ ,@(invoke-interface/call code:compiler-link continuation-label)
+ |#
+ ,@(invoke-hook/call entry:compiler-link continuation-label)
+ ,@(make-external-label (continuation-code-word #f)
+ continuation-label))))
\f
(define (generate/remote-links n-blocks vector-label nsects)
(if (zero? n-blocks)
(LAP)
(let ((loop (generate-label))
(bytes (generate-label))
- (end (generate-label)))
+ (end (generate-label))
+ (continuation (generate-label 'LINKED)))
(LAP
;; Push counter
(PUSH Q (& 0))
(@ROI ,rdx ,(* 2 address-units-per-object)
,rax ,address-units-per-object))
;; Invoke linker
- ,@(invoke-hook/reentry entry:compiler-link)
+ ,@(invoke-hook/call entry:compiler-link continuation)
,@(make-external-label (continuation-code-word false)
- (generate-label))
+ continuation)
;; Increment counter and loop
(ADD Q (@R ,rsp) (&U 1))
,@(receive (temp prefix comparand)
(define-rule statement
(INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?))
(QUALIFIER (interpreter-call-argument? extension))
- cont ; ignored
(let ((set-extension
(interpreter-call-argument->machine-register! extension rdx)))
(LAP ,@set-extension
,@(invoke-interface/call
(if safe?
code:compiler-safe-reference-trap
- code:compiler-reference-trap))
+ code:compiler-reference-trap)
+ cont)
|#
- ,@(invoke-hook/reentry
+ ,@(invoke-hook/call
(if safe?
entry:compiler-safe-reference-trap
- entry:compiler-reference-trap)))))
+ entry:compiler-reference-trap)
+ cont))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value))
(QUALIFIER (and (interpreter-call-argument? extension)
(interpreter-call-argument? value)))
- cont ; ignored
(let* ((set-extension
(interpreter-call-argument->machine-register! extension rdx))
(set-value (interpreter-call-argument->machine-register! value rcx)))
,@set-value
,@(clear-map!)
#|
- ,@(invoke-interface/call code:compiler-assignment-trap)
+ ,@(invoke-interface/call code:compiler-assignment-trap cont)
|#
- ,@(invoke-hook/reentry entry:compiler-assignment-trap))))
+ ,@(invoke-hook/call entry:compiler-assignment-trap cont))))
(define-rule statement
(INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension))
(QUALIFIER (interpreter-call-argument? extension))
- cont ; ignored
(let ((set-extension
(interpreter-call-argument->machine-register! extension rdx)))
(LAP ,@set-extension
,@(clear-map!)
- ,@(invoke-interface/call code:compiler-unassigned?-trap))))
+ ,@(invoke-interface/call code:compiler-unassigned?-trap cont))))
\f
;;;; Interpreter Calls
(define-rule statement
(INTERPRETER-CALL:ACCESS (? cont) (? environment) (? name))
(QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-access environment name))
+ (lookup-call code:compiler-access environment name cont))
(define-rule statement
(INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?))
(QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
(lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
- environment name))
+ environment name cont))
(define-rule statement
(INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name))
(QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-unassigned? environment name))
+ (lookup-call code:compiler-unassigned? environment name cont))
(define-rule statement
(INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name))
(QUALIFIER (interpreter-call-argument? environment))
- cont ; ignored
- (lookup-call code:compiler-unbound? environment name))
+ (lookup-call code:compiler-unbound? environment name cont))
-(define (lookup-call code environment name)
+(define (lookup-call code environment name cont)
(let ((set-environment
(interpreter-call-argument->machine-register! environment rdx)))
(LAP ,@set-environment
,@(clear-map (clear-map!))
,@(load-constant (INST-EA (R ,rcx)) name)
- ,@(invoke-interface/call code))))
+ ,@(invoke-interface/call code cont))))
\f
(define-rule statement
(INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value))
(QUALIFIER (and (interpreter-call-argument? environment)
(interpreter-call-argument? value)))
- cont ; ignored
- (assignment-call code:compiler-define environment name value))
+ (assignment-call code:compiler-define environment name value cont))
(define-rule statement
(INTERPRETER-CALL:SET! (? cont) (? environment) (? name) (? value))
(QUALIFIER (and (interpreter-call-argument? environment)
(interpreter-call-argument? value)))
- cont ; ignored
- (assignment-call code:compiler-set! environment name value))
+ (assignment-call code:compiler-set! environment name value cont))
-(define (assignment-call code environment name value)
+(define (assignment-call code environment name value cont)
(let* ((set-environment
(interpreter-call-argument->machine-register! environment rdx))
(set-value (interpreter-call-argument->machine-register! value r8)))
,@set-value
,@(clear-map!)
,@(load-constant (INST-EA (R ,rcx)) name)
- ,@(invoke-interface/call code))))
\ No newline at end of file
+ ,@(invoke-interface/call code cont))))
\ No newline at end of file
OP(mov,q) TW(REG(rcx),REG(rbx)) # argument in rbx
jmp scheme_to_interface
-# We used to CALL this to get the return address on the stack, but now
-# we use RIP-relative addressing to load directly into %rbx -- which
-# doesn't ruin the return address branch target prediction stack -- so
-# that this is no longer needed.
define_hook_label(scheme_to_interface_call)
define_debugging_label(scheme_to_interface_call)
- nop
+ OP(pop,q) REG(rbx) # pop untagged ret addr
+define_debugging_label(scheme_to_interface_reentry)
# jmp scheme_to_interface
\f
# scheme_to_interface passes control from compiled Scheme code to a
OP(mov,b) TW(IMM(HEX($2)),REG(r9b))
jmp scheme_to_interface_call')
-define_call_indirection(interrupt_procedure,1a)
-define_call_indirection(interrupt_continuation,1b)
+# Expects compiled entry address (with zero offset) in rbx.
+define(define_reentry_indirection,
+`define_hook_label($1)
+ OP(mov,b) TW(IMM(HEX($2)),REG(r9b))
+ jmp scheme_to_interface')
+
+define_reentry_indirection(interrupt_procedure,1a)
+define_reentry_indirection(interrupt_continuation,1b)
define_jump_indirection(interrupt_closure,18)
define_jump_indirection(interrupt_continuation_2,3b)
+# Expects compiled entry address (with zero offset) in rbx.
define_hook_label(interrupt_dlink)
OP(mov,q) TW(QOF(REGBLOCK_DLINK(),regs),REG(rdx))
OP(mov,b) TW(IMM(HEX(19)),REG(r9b))
- jmp scheme_to_interface_call
+ jmp scheme_to_interface_reentry
declare_alignment(2)
define_jump_indirection(primitive_apply,12)
-
define_jump_indirection(primitive_lexpr_apply,13)
define_jump_indirection(error,15)
define_call_indirection(link,17)
if (result != PRIM_DONE)
RETURN_TO_C (result);
}
- RETURN_TO_SCHEME_ENTRY (s.return_address);
+ RETURN_TO_SCHEME_CONTINUATION (s.return_address);
}
/* comp_link_caches_restart is used to continue the linking process
if (result != PRIM_DONE)
return (result);
- ENTER_SCHEME_ENTRY (s.return_address);
+ ENTER_SCHEME_CONTINUATION (s.return_address);
}
static long
{
#if defined(FLUSH_I_CACHE_REGION) || defined(PUSH_D_CACHE_REGION)
SCHEME_OBJECT * addr = (s->block_address);
- if ((cc_entry_address_to_block_address (s->return_address)) == addr)
+ if ((cc_return_address_to_block_address (s->return_address)) == addr)
#ifdef FLUSH_I_CACHE_REGION
FLUSH_I_CACHE_REGION (addr, (CC_BLOCK_ADDR_LENGTH (addr)));
#else
back_out_of_link_section (link_cc_state_t * s)
{
/* Save enough state to restart. */
- STACK_PUSH (MAKE_CC_ENTRY (s->return_address));
+ STACK_PUSH (MAKE_CC_RETURN (s->return_address));
STACK_PUSH (ULONG_TO_FIXNUM ((s->n_sections) - (s->n_linked_sections)));
STACK_PUSH (ULONG_TO_FIXNUM ((s->scan0) - (s->block_address)));
STACK_PUSH (ULONG_TO_FIXNUM ((s->scan) - (s->block_address)));
(s->scan) = ((s->block_address) + (OBJECT_DATUM (STACK_POP ())));
(s->scan0) = ((s->block_address) + (OBJECT_DATUM (STACK_POP ())));
(s->n_sections) = (OBJECT_DATUM (STACK_POP ()));
- (s->return_address) = (CC_ENTRY_ADDRESS (STACK_POP ()));
+ (s->return_address) = (CC_RETURN_ADDRESS (STACK_POP ()));
(s->n_linked_sections) = 0;
(s->type) = (linkage_section_type (* (s->scan0)));
continuation is a piece of state that will be returned to
GET_VAL and GET_ENV (both) upon return. */
+/* Stack has invocation frame with tagged closure on top. */
+
DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_closure)
{
compiler_interrupt_common (DSU_result, 0, SHARP_F);
/* GET_VAL has live data, and there is no entry address on the stack */
-DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_continuation, return_addr)
+DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_continuation, entry_point)
{
- DECLARE_UTILITY_ARG (insn_t *, return_addr);
- compiler_interrupt_common (DSU_result, return_addr, GET_VAL);
+ DECLARE_UTILITY_ARG (insn_t *, entry_point);
+ compiler_interrupt_common (DSU_result, entry_point, GET_VAL);
}
/* GET_ENV has live data; no entry point on the stack */
compiler_interrupt_common (DSU_result, entry_point, GET_ENV);
}
+/* GET_VAL has live data, and the tagged continuation is on top of stack. */
+
DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_continuation_2)
{
compiler_interrupt_return_to_entry ();
/* Convert the compiled return address on the stack to a compiled
entry. This is easier than adding a different interpreter return
- code, &c. */
+ code, or creating a stub compiled entry that just does pop-return.
+ It's OK if we ruin return address branch target prediction:
+ servicing interrupts is expensive anyway. */
static void
compiler_interrupt_return_to_entry (void)
void
compiler_interrupt_common (utility_result_t * DSU_result,
- insn_t * address,
+ insn_t * entry_address,
SCHEME_OBJECT state)
{
if (!FREE_OK_P (Free))
REQUEST_GC (Free - heap_alloc_limit);
STACK_CHECK (0);
- if (address != 0)
- STACK_PUSH (MAKE_CC_ENTRY (address));
+ if (entry_address != 0)
+ STACK_PUSH (MAKE_CC_ENTRY (entry_address));
assert (CC_ENTRY_P (STACK_REF (0)));
STACK_PUSH (state);
SAVE_LAST_RETURN_CODE (RC_COMP_INTERRUPT_RESTART);
long code = (compiler_assignment_trap (cache, new_val, (&old_val)));
if (code != PRIM_DONE)
{
- SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
- SCHEME_OBJECT block = (cc_entry_to_block (sra));
+ SCHEME_OBJECT sra = (MAKE_CC_RETURN (ret_addr));
+ SCHEME_OBJECT block = (cc_return_to_block (sra));
STACK_PUSH (sra);
STACK_PUSH (new_val);
STACK_PUSH (cc_block_environment (block));
RETURN_TO_C (code);
}
SET_VAL (old_val);
- RETURN_TO_SCHEME_ENTRY (ret_addr);
+ RETURN_TO_SCHEME_CONTINUATION (ret_addr);
}
DEFINE_SCHEME_ENTRY (comp_assignment_trap_restart)
return (code);
}
SET_VAL (old_val);
- JUMP_TO_CC_ENTRY (STACK_POP ());
+ JUMP_TO_CC_RETURN (STACK_POP ());
}
}
\f
long code = (compiler_lookup_trap (cache, (&val)));
if (code != PRIM_DONE)
{
- SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
- SCHEME_OBJECT block = (cc_entry_to_block (sra));
+ SCHEME_OBJECT sra = (MAKE_CC_RETURN (ret_addr));
+ SCHEME_OBJECT block = (cc_return_to_block (sra));
STACK_PUSH (sra);
STACK_PUSH (cc_block_environment (block));
STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
RETURN_TO_C (code);
}
SET_VAL (val);
- RETURN_TO_SCHEME_ENTRY (ret_addr);
+ RETURN_TO_SCHEME_CONTINUATION (ret_addr);
}
DEFINE_SCHEME_ENTRY (comp_lookup_trap_restart)
return (code);
}
SET_VAL (val);
- JUMP_TO_CC_ENTRY (STACK_POP ());
+ JUMP_TO_CC_RETURN (STACK_POP ());
}
}
long code = (compiler_safe_lookup_trap (cache, (&val)));
if (code != PRIM_DONE)
{
- SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
- SCHEME_OBJECT block = (cc_entry_to_block (sra));
+ SCHEME_OBJECT sra = (MAKE_CC_RETURN (ret_addr));
+ SCHEME_OBJECT block = (cc_return_to_block (sra));
STACK_PUSH (sra);
STACK_PUSH (cc_block_environment (block));
STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
RETURN_TO_C (code);
}
SET_VAL (val);
- RETURN_TO_SCHEME_ENTRY (ret_addr);
+ RETURN_TO_SCHEME_CONTINUATION (ret_addr);
}
DEFINE_SCHEME_ENTRY (comp_safe_lookup_trap_restart)
return (code);
}
SET_VAL (val);
- JUMP_TO_CC_ENTRY (STACK_POP ());
+ JUMP_TO_CC_RETURN (STACK_POP ());
}
}
long code = (compiler_unassigned_p_trap (cache, (&val)));
if (code != PRIM_DONE)
{
- SCHEME_OBJECT sra = (MAKE_CC_ENTRY (ret_addr));
- SCHEME_OBJECT block = (cc_entry_to_block (sra));
+ SCHEME_OBJECT sra = (MAKE_CC_RETURN (ret_addr));
+ SCHEME_OBJECT block = (cc_return_to_block (sra));
STACK_PUSH (sra);
STACK_PUSH (cc_block_environment (block));
STACK_PUSH (compiler_var_error (cache, block, CACHE_REFERENCES_LOOKUP));
RETURN_TO_C (code);
}
SET_VAL (val);
- RETURN_TO_SCHEME_ENTRY (ret_addr);
+ RETURN_TO_SCHEME_CONTINUATION (ret_addr);
}
DEFINE_SCHEME_ENTRY (comp_unassigned_p_trap_restart)
return (code);
}
SET_VAL (val);
- JUMP_TO_CC_ENTRY (STACK_POP ());
+ JUMP_TO_CC_RETURN (STACK_POP ());
}
}
\f
projects / mit-scheme.git / commitdiff