shortcircuit-apply-size-7
shortcircuit-apply-size-8
interrupt-continuation-2
- conditionally-serialize)
+ conditionally-serialize
+ fixnum-shift)
\f
;; Operation tables
(SAR W ,target (& ,scheme-type-width))
(IMUL W ,target ,temp))))))))
+;;; This calls an out-of-line assembly hook because it requires a lot
+;;; of hair to deal with shift counts that exceed the datum width, and
+;;; with negative arguments.
+
(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
- (let ((operate
- (lambda (target source2)
- ;; SOURCE2 is guaranteed not to be ECX because of the
- ;; require-register! used below.
- ;; TARGET can be ECX only if the rule has machine register
- ;; ECX as the target, unlikely, but it must be handled!
- (let ((with-target
- (lambda (target)
- (let ((jlabel (generate-label 'SHIFT-JOIN))
- (slabel (generate-label 'SHIFT-NEGATIVE))
- (zlabel (generate-label 'SHIFT-ZERO)))
- (LAP (MOV W (R ,ecx) ,source2)
- (SAR W (R ,ecx) (& ,scheme-type-width))
- (JS B (@PCR ,slabel))
- (CMP W (R ,ecx) (& ,scheme-datum-width))
- (JGE B (@PCR ,zlabel))
- (SHL W ,target (R ,ecx))
- (JMP B (@PCR ,jlabel))
- (LABEL ,zlabel)
- (XOR W ,target ,target)
- (JMP B (@PCR ,jlabel))
- (LABEL ,slabel)
- (NEG W (R ,ecx))
- (CMP W (R ,ecx) (& ,scheme-datum-width))
- (JGE W (@PCR ,zlabel))
- (SHR W ,target (R ,ecx))
- ,@(word->fixnum target)
- (LABEL ,jlabel))))))
-
- (if (not (equal? target (INST-EA (R ,ecx))))
- (with-target target)
- (let ((temp (temporary-register-reference)))
- (LAP (MOV W ,temp ,target)
- ,@(with-target temp)
- (MOV W ,target ,temp))))))))
- (lambda (target source1 source2 overflow?)
- overflow? ; ignored
- (require-register! ecx)
- (two-arg-register-operation operate
- #f
- target
- source1
- source2))))
+ (lambda (target source1 source2 overflow?)
+ (prefix-instructions!
+ (LAP ,@(load-machine-register! source1 eax)
+ ,@(load-machine-register! source2 ecx)))
+ (rtl-target:=machine-register! target eax)
+ (LAP ,@(invoke-hook/call entry:compiler-fixnum-shift))))
\f
(define (do-division target source1 source2 result-reg)
(prefix-instructions! (load-machine-register! source1 eax))
shortcircuit-apply-size-6
shortcircuit-apply-size-7
shortcircuit-apply-size-8
- interrupt-continuation-2)
+ interrupt-continuation-2
+ fixnum-shift)
\f
;; Operation tables
(SAR Q ,target (&U ,scheme-type-width))
(IMUL Q ,target ,temp))))))))
-;++ This is absurd -- it should just be an assembly hook.
+;;; This calls an out-of-line assembly hook because it requires a lot
+;;; of hair to deal with shift counts that exceed the datum width, and
+;;; with negative arguments.
(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
- (let ((operate
- (lambda (target source2)
- ;; SOURCE2 is guaranteed not to be RCX because of the
- ;; require-register! used below.
- ;; TARGET can be RCX only if the rule has machine register
- ;; RCX as the target, unlikely, but it must be handled!
- (let ((with-target
- (lambda (target)
- (let ((jlabel (generate-label 'SHIFT-JOIN))
- (slabel (generate-label 'SHIFT-NEGATIVE))
- (zlabel (generate-label 'SHIFT-ZERO)))
- (LAP (MOV Q (R ,rcx) ,source2)
- (SAR Q (R ,rcx) (&U ,scheme-type-width))
- (JS B (@PCR ,slabel))
- (CMP Q (R ,rcx) (& ,scheme-datum-width))
- (JGE B (@PCR ,zlabel))
- (SHL Q ,target (R ,rcx))
- (JMP B (@PCR ,jlabel))
- (LABEL ,zlabel)
- (XOR Q ,target ,target)
- (JMP B (@PCR ,jlabel))
- (LABEL ,slabel)
- (NEG Q (R ,rcx))
- (CMP Q (R ,rcx) (& ,scheme-datum-width))
- (JGE B (@PCR ,zlabel))
- (SHR Q ,target (R ,rcx))
- ,@(word->fixnum target)
- (LABEL ,jlabel))))))
-
- (if (not (equal? target (INST-EA (R ,rcx))))
- (with-target target)
- (let ((temp (temporary-register-reference)))
- (LAP (MOV Q ,temp ,target)
- ,@(with-target temp)
- (MOV Q ,target ,temp))))))))
- (lambda (target source1 source2 overflow?)
- overflow? ; ignored
- (require-register! rcx)
- (binary-register-operation operate #f 'GENERAL
- (lambda (target source)
- (LAP (MOV Q ,target ,source)))
- target source1 source2))))
+ (lambda (target source1 source2 overflow?)
+ (prefix-instructions!
+ (LAP ,@(load-machine-register! source1 rax)
+ ,@(load-machine-register! source2 rcx)))
+ (rtl-target:=machine-register! target rax)
+ (LAP ,@(invoke-hook/call entry:compiler-fixnum-shift))))
\f
(define (do-division target source1 source2 result-reg)
(prefix-instructions! (load-machine-register! source1 rax))
define(TC_MANIFEST_NM_VECTOR,39)
define(TC_COMPILED_ENTRY,40)
+define(IMM_DETAGGED_FIXNUM_MINUS_ONE, IMM(eval((-1) * (1 << TC_LENGTH))))
+
define(REGBLOCK_VAL,8)
define(REGBLOCK_COMPILER_TEMP,16)
define(REGBLOCK_LEXPR_ACTUALS,28)
define_jump_indirection(nofp_remainder,38)
define_jump_indirection(nofp_modulo,39)
\f
+# Input and output in eax, shift count in ecx, all detagged fixnums.
+# Return address is at the top of the stack.
+
+define_hook_label(fixnum_shift)
+ OP(sar,l) TW(IMM(TC_LENGTH),REG(ecx))
+ js asm_fixnum_shift_negative
+
+asm_fixnum_lsh:
+ OP(cmp,l) TW(IMM(DATUM_LENGTH),REG(ecx))
+ jge asm_fixnum_lsh_overflow
+ OP(shl,l) TW(REG(cl),REG(eax))
+ ret
+
+asm_fixnum_lsh_overflow:
+ OP(xor,l) TW(REG(eax),REG(eax))
+ ret
+
+asm_fixnum_shift_negative:
+ OP(neg,l) REG(ecx)
+
+asm_fixnum_rsh:
+ OP(cmp,l) TW(IMM(DATUM_LENGTH),REG(ecx))
+ jge asm_fixnum_rsh_overflow
+ OP(sar,l) TW(REG(cl),REG(eax))
+
+ # Turn eax back into a detagged fixnum by masking off the low
+ # six bits. -1 has all bits set, but its detagged format has
+ # the low six bits clear.
+ OP(and,l) TW(IMM_DETAGGED_FIXNUM_MINUS_ONE,REG(eax))
+ ret
+
+asm_fixnum_rsh_overflow:
+ OP(cmp,l) TW(IMM(0),REG(eax))
+ js asm_fixnum_rsh_overflow_negative
+
+asm_fixnum_rsh_overflow_nonnegative:
+ OP(xor,l) TW(REG(eax),REG(eax))
+ ret
+
+asm_fixnum_rsh_overflow_negative:
+ OP(mov,l) TW(IMM_DETAGGED_FIXNUM_MINUS_ONE,REG(eax))
+ ret
+\f
IFDASM(`end')
### Edwin Variables:
# constants here. These are computed in terms of the parameters
# above, and ordered lexicographically.
+define(IMM_DETAGGED_FIXNUM_MINUS_ONE, `IMM(HEX(ffffffffffffffc0))')
define(IMM_FALSE, `IMM(HEX(0000000000000000))')
define(IMM_FIXNUM_0, `IMM(HEX(6800000000000000))')
define(IMM_FLONUM_0, `IMM(HEX(1800000000000000))')
define_jump_indirection(generic_remainder,38)
define_jump_indirection(generic_modulo,39)
\f
+# Input and output in rax, shift count in rcx, all detagged fixnums.
+# Return address is at the top of the stack.
+
+define_hook_label(fixnum_shift)
+ OP(sar,q) TW(IMM(TC_LENGTH),REG(rcx))
+ js asm_fixnum_shift_negative
+
+asm_fixnum_lsh:
+ OP(cmp,q) TW(IMM(DATUM_LENGTH),REG(rcx))
+ jge asm_fixnum_lsh_overflow
+ OP(shl,q) TW(REG(cl),REG(rax))
+ ret
+
+asm_fixnum_lsh_overflow:
+ OP(xor,q) TW(REG(rax),REG(rax))
+ ret
+
+asm_fixnum_shift_negative:
+ OP(neg,q) REG(rcx)
+
+asm_fixnum_rsh:
+ OP(cmp,q) TW(IMM(DATUM_LENGTH),REG(rcx))
+ jge asm_fixnum_rsh_overflow
+ OP(sar,q) TW(REG(cl),REG(rax))
+
+ # Turn rax back into a detagged fixnum by masking off the low
+ # six bits. -1 has all bits set, but its detagged format has
+ # the low six bits clear. Use rcx as a temporary register
+ # because AND can't take a 64-bit immediate operand; only MOV
+ # can.
+ OP(mov,q) TW(IMM_DETAGGED_FIXNUM_MINUS_ONE,REG(rcx))
+ OP(and,q) TW(REG(rcx),REG(rax))
+ ret
+
+asm_fixnum_rsh_overflow:
+ OP(cmp,q) TW(IMM(0),REG(rax))
+ js asm_fixnum_rsh_overflow_negative
+
+asm_fixnum_rsh_overflow_nonnegative:
+ OP(xor,q) TW(REG(rax),REG(rax))
+ ret
+
+asm_fixnum_rsh_overflow_negative:
+ OP(mov,q) TW(IMM_DETAGGED_FIXNUM_MINUS_ONE,REG(rax))
+ ret
+\f
IFDASM(`end')
### Edwin Variables:
SETUP_REGISTER (asm_serialize_cache); /* -7 */
else
SETUP_REGISTER (asm_dont_serialize_cache); /* -7 */
+ SETUP_REGISTER (asm_fixnum_shift); /* -6 */
#ifdef _MACH_UNIX
{
extern void asm_assignment_trap (void);
extern void asm_dont_serialize_cache (void);
extern void asm_error (void);
+extern void asm_fixnum_shift (void);
extern void asm_generic_add (void);
extern void asm_generic_decrement (void);
extern void asm_generic_divide (void);
renumber them now. */
SETUP_REGISTER (asm_interrupt_continuation_2); /* 39 */
+ SETUP_REGISTER (asm_fixnum_shift); /* 40 */
+
#ifdef _MACH_UNIX
{
vm_address_t addr;
extern void asm_assignment_trap (void);
extern void asm_dont_serialize_cache (void);
extern void asm_error (void);
+extern void asm_fixnum_shift (void);
extern void asm_generic_add (void);
extern void asm_generic_decrement (void);
extern void asm_generic_divide (void);
projects / mit-scheme.git / commitdiff