From e3d37f1d401d094d345b55d478030c5255d40986 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
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