From e3d37f1d401d094d345b55d478030c5255d40986 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Thu, 19 Nov 2009 14:06:57 -0500 Subject: [PATCH] Add an assembly hook for SET-INTERRUPT-ENABLES! on i386. --- src/compiler/machines/i386/lapgen.scm | 3 +- src/compiler/machines/i386/rules3.scm | 81 +++++++++++++++------------ src/microcode/cmpauxmd/i386.m4 | 59 +++++++++++++++++++ src/microcode/cmpintmd/i386.c | 1 + src/microcode/cmpintmd/i386.h | 1 + 5 files changed, 108 insertions(+), 37 deletions(-) diff --git a/src/compiler/machines/i386/lapgen.scm b/src/compiler/machines/i386/lapgen.scm index 125440a4f..1d4858bb1 100644 --- a/src/compiler/machines/i386/lapgen.scm +++ b/src/compiler/machines/i386/lapgen.scm @@ -673,7 +673,8 @@ USA. shortcircuit-apply-size-8 interrupt-continuation-2 conditionally-serialize - fixnum-shift) + fixnum-shift + set-interrupt-enables!) ;; Operation tables diff --git a/src/compiler/machines/i386/rules3.scm b/src/compiler/machines/i386/rules3.scm index a14f7f281..c2af61988 100644 --- a/src/compiler/machines/i386/rules3.scm +++ b/src/compiler/machines/i386/rules3.scm @@ -172,42 +172,51 @@ USA. (define-rule statement (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) continuation ; ignored - (if (eq? primitive compiled-error-procedure) - (LAP ,@(clear-map!) - (MOV W (R ,ecx) (& ,frame-size)) - ,@(invoke-hook entry:compiler-error)) - (let ((arity (primitive-procedure-arity primitive))) - (cond ((not (negative? arity)) - (with-values (lambda () (get-cached-label)) - (lambda (pc-label pc-reg) - pc-reg ; ignored - (if pc-label - (let ((get-code - (object->machine-register! primitive ecx))) - (LAP ,@get-code - ,@(clear-map!) - ,@(invoke-hook entry:compiler-primitive-apply))) - (let ((prim-label (constant->label primitive)) - (offset-label (generate-label 'PRIMOFF))) - (LAP ,@(clear-map!) - ,@(invoke-hook/call - entry:compiler-short-primitive-apply) - (LABEL ,offset-label) - (LONG S (- ,prim-label ,offset-label)))))))) - ((= arity -1) - (let ((get-code (object->machine-register! primitive ecx))) - (LAP ,@get-code - ,@(clear-map!) - (MOV W ,reg:lexpr-primitive-arity - (& ,(-1+ frame-size))) - ,@(invoke-hook entry:compiler-primitive-lexpr-apply)))) - (else - ;; Unknown primitive arity. Go through apply. - (let ((get-code (object->machine-register! primitive ecx))) - (LAP ,@get-code - ,@(clear-map!) - (MOV W (R ,edx) (& ,frame-size)) - ,@(invoke-interface code:compiler-apply)))))))) + (cond ((eq? primitive compiled-error-procedure) + (LAP ,@(clear-map!) + (MOV W (R ,ecx) (& ,frame-size)) + ,@(invoke-hook entry:compiler-error))) + ((eq? primitive (ucode-primitive SET-INTERRUPT-ENABLES!)) + (LAP ,@(clear-map!) + ,@(invoke-hook entry:compiler-set-interrupt-enables!))) + (else + (let ((arity (primitive-procedure-arity primitive))) + (cond ((not (negative? arity)) + (known-primitive-invocation primitive)) + ((= arity -1) + (lexpr-primitive-invocation primitive frame-size)) + (else + (unknown-primitive-invocation primitive frame-size))))))) + +(define (known-primitive-invocation primitive) + (receive (pc-label pc-reg) (get-cached-label) + pc-reg ; ignored + (if pc-label + (LAP ,@(primitive-invocation-setup! primitive) + ,@(invoke-hook entry:compiler-primitive-apply)) + (let ((prim-label (constant->label primitive)) + (offset-label (generate-label 'PRIMOFF))) + (LAP ,@(clear-map!) + ,@(invoke-hook/call entry:compiler-short-primitive-apply) + (LABEL ,offset-label) + (LONG S (- ,prim-label ,offset-label))))))) + +(define (lexpr-primitive-invocation primitive frame-size) + (LAP ,@(primitive-invocation-setup! primitive) + (MOV W ,reg:lexpr-primitive-arity (& ,(-1+ frame-size))) + ,@(invoke-hook entry:compiler-primitive-lexpr-apply))) + +(define (unknown-primitive-invocation primitive frame-size) + ;; Unknown primitive arity. Go through apply. + (LAP ,@(primitive-invocation-setup! primitive) + (MOV W (R ,edx) (& ,frame-size)) + ,@(invoke-interface code:compiler-apply))) + +(define (primitive-invocation-setup! primitive) + (let* ((get-code (object->machine-register! primitive ecx)) + (clear-map (clear-map!))) + (LAP ,@get-code + ,@clear-map))) (let-syntax ((define-primitive-invocation diff --git a/src/microcode/cmpauxmd/i386.m4 b/src/microcode/cmpauxmd/i386.m4 index 7f2cea671..ed8efedc3 100644 --- a/src/microcode/cmpauxmd/i386.m4 +++ b/src/microcode/cmpauxmd/i386.m4 @@ -292,11 +292,18 @@ define(TC_COMPILED_ENTRY,40) define(IMM_DETAGGED_FIXNUM_MINUS_ONE, IMM(eval((-1) * (1 << TC_LENGTH)))) +define(INT_Stack_Overflow,HEX(1)) +define(INT_GC,HEX(4)) + +define(REGBLOCK_MEMTOP,0) +define(REGBLOCK_INT_MASK,4) define(REGBLOCK_VAL,8) define(REGBLOCK_COMPILER_TEMP,16) define(REGBLOCK_LEXPR_ACTUALS,28) define(REGBLOCK_PRIMITIVE,32) define(REGBLOCK_CLOSURE_FREE,36) +define(REGBLOCK_STACK_GUARD,44) +define(REGBLOCK_INT_CODE,48) define(REGBLOCK_DLINK,REGBLOCK_COMPILER_TEMP) define(REGBLOCK_UTILITY_ARG4,REGBLOCK_CLOSURE_FREE) @@ -769,6 +776,58 @@ define_apply_fixed_size(6) define_apply_fixed_size(7) define_apply_fixed_size(8) +# On entry, the tagged interrupt mask is at the top of the stack, +# below which is a tagged return address. This implementation is not +# very clever about avoiding unnecessary writes. + +define_hook_label(set_interrupt_enables) + + # Store the old interrupt mask in the value register. + OP(mov,l) TW(LOF(REGBLOCK_INT_MASK(),regs),REG(eax)) + OP(or,l) TW(IMM(eval(TAG(TC_FIXNUM,0))),REG(eax)) + OP(mov,l) TW(REG(eax),LOF(REGBLOCK_VAL(),regs)) + + # Store the new one in the interrupt mask register. + OP(pop,l) REG(ecx) + OP(and,l) TW(rmask,REG(ecx)) + OP(mov,l) TW(REG(ecx),LOF(REGBLOCK_INT_MASK(),regs)) + +set_interrupt_enables_determine_memtop: + # If there is an interrupt pending, set memtop to 0. + OP(test,l) TW(LOF(REGBLOCK_INT_CODE(),regs),REG(ecx)) + jz set_interrupt_enables_memtop_1 + OP(xor,l) TW(REG(edx),REG(edx)) + jmp set_interrupt_enables_set_memtop + +set_interrupt_enables_memtop_1: + # If GC is enabled, set memtop to the heap allocation limit. + OP(test,l) TW(IMM(INT_GC),REG(ecx)) + jz set_interrupt_enables_memtop_2 + OP(mov,l) TW(ABS(EVR(heap_alloc_limit)),REG(edx)) + jmp set_interrupt_enables_set_memtop + +set_interrupt_enables_memtop_2: + # Otherwise, there is no interrupt pending, and GC is not + # enabled, so set memtop to the absolute heap end. + OP(mov,l) TW(ABS(EVR(heap_end)),REG(edx)) + +set_interrupt_enables_set_memtop: + OP(mov,l) TW(REG(edx),LOF(REGBLOCK_MEMTOP(),regs)) + +set_interrupt_enables_determine_stack_guard: + OP(test,l) TW(IMM(INT_Stack_Overflow),REG(ecx)) + jz set_interrupt_enables_stack_guard_1 + OP(mov,l) TW(ABS(EVR(stack_guard)),REG(edx)) + jmp set_interrupt_enables_set_stack_guard + +set_interrupt_enables_stack_guard_1: + OP(mov,l) TW(ABS(EVR(stack_start)),REG(edx)) + +set_interrupt_enables_set_stack_guard: + OP(mov,l) TW(REG(edx),LOF(REGBLOCK_STACK_GUARD(),regs)) + OP(and,l) TW(rmask,IND(REG(esp))) + ret + ### The following code is used by generic arithmetic ### whether the fixnum case is open-coded in line or not. ### This takes care of fixnums and flonums so that the common diff --git a/src/microcode/cmpintmd/i386.c b/src/microcode/cmpintmd/i386.c index f6a3725b0..80e7febe8 100644 --- a/src/microcode/cmpintmd/i386.c +++ b/src/microcode/cmpintmd/i386.c @@ -339,6 +339,7 @@ i386_reset_hook (void) else SETUP_REGISTER (asm_dont_serialize_cache); /* -7 */ SETUP_REGISTER (asm_fixnum_shift); /* -6 */ + SETUP_REGISTER (asm_set_interrupt_enables); /* -5 */ #ifdef _MACH_UNIX { diff --git a/src/microcode/cmpintmd/i386.h b/src/microcode/cmpintmd/i386.h index 918bc295c..9c3cd72ec 100644 --- a/src/microcode/cmpintmd/i386.h +++ b/src/microcode/cmpintmd/i386.h @@ -309,6 +309,7 @@ extern void asm_primitive_error (void); extern void asm_primitive_lexpr_apply (void); extern void asm_reference_trap (void); extern void asm_safe_reference_trap (void); +extern void asm_set_interrupt_enables (void); extern void asm_sc_apply (void); extern void asm_sc_apply_size_1 (void); extern void asm_sc_apply_size_2 (void); -- 2.25.1