(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)))
\f
(let-syntax
((define-primitive-invocation
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)
define_apply_fixed_size(7)
define_apply_fixed_size(8)
\f
+# 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
+\f
### 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
projects / mit-scheme.git / commitdiff