Fix alien accessor intrinsics; a bit more complex now that we don't reserve a tempreg
Slava Pestov
parent
f2c6f8de5b
commit
fe2c20882a
|
|
@ -6,7 +6,8 @@ layouts alien alien.accessors alien.structs slots splitting
|
|||
assocs combinators cpu.x86.assembler
|
||||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||
cpu.x86.allot cpu.architecture compiler.constants
|
||||
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions ;
|
||||
compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
M: x86.64 machine-registers
|
||||
|
|
@ -224,10 +225,64 @@ M: x86.64 %callback-value ( ctype -- )
|
|||
|
||||
USE: cpu.x86.intrinsics
|
||||
|
||||
: (%alien-get-4) ( -- )
|
||||
small-reg-32 "offset" operand [] MOV ; inline
|
||||
|
||||
: %alien-unsigned-4 ( -- )
|
||||
%prepare-alien-accessor
|
||||
"value" operand small-reg = [
|
||||
(%alien-get-4)
|
||||
] [
|
||||
small-reg PUSH
|
||||
(%alien-get-4)
|
||||
"value" operand small-reg MOV
|
||||
small-reg POP
|
||||
] if
|
||||
"value" operand %tag-fixnum ; inline
|
||||
|
||||
: (%alien-signed-4) ( -- )
|
||||
(%alien-get-4)
|
||||
"value" operand small-reg-32 MOVSX ;
|
||||
|
||||
: %alien-signed-4 ( -- )
|
||||
%prepare-alien-accessor
|
||||
"value" operand small-reg = [
|
||||
(%alien-signed-4)
|
||||
] [
|
||||
small-reg PUSH
|
||||
(%alien-signed-4)
|
||||
small-reg POP
|
||||
] if
|
||||
"value" operand %tag-fixnum ; inline
|
||||
|
||||
: define-alien-unsigned-4-getter ( word -- )
|
||||
[ %alien-unsigned-4 ] alien-integer-get-template define-intrinsic ;
|
||||
|
||||
: define-alien-signed-4-getter ( word -- )
|
||||
[ %alien-signed-4 ] alien-integer-get-template define-intrinsic ;
|
||||
|
||||
: %set-alien-4 ( -- )
|
||||
"value" operand "offset" operand = [
|
||||
"value" operand %untag-fixnum
|
||||
] unless
|
||||
%prepare-alien-accessor
|
||||
small-reg "offset" operand = [
|
||||
"value" operand "offset" operand XCHG
|
||||
"value" operand [] small-reg-32 MOV
|
||||
] [
|
||||
small-reg PUSH
|
||||
small-reg "value" operand MOV
|
||||
"offset" operand [] small-reg-32 MOV
|
||||
small-reg POP
|
||||
] if ; inline
|
||||
|
||||
: define-alien-4-setter ( word -- )
|
||||
[ %set-alien-4 ] alien-integer-set-template define-intrinsic ;
|
||||
|
||||
! On 64-bit systems, the result of reading 4 bytes from memory
|
||||
! is a fixnum.
|
||||
\ alien-unsigned-4 small-reg-32 define-unsigned-getter
|
||||
\ set-alien-unsigned-4 small-reg-32 define-setter
|
||||
\ alien-unsigned-4 define-alien-unsigned-4-getter
|
||||
\ set-alien-unsigned-4 define-alien-4-setter
|
||||
|
||||
\ alien-signed-4 small-reg-32 define-signed-getter
|
||||
\ set-alien-signed-4 small-reg-32 define-setter
|
||||
\ alien-signed-4 define-alien-signed-4-getter
|
||||
\ set-alien-signed-4 define-alien-4-setter
|
||||
|
|
|
|||
|
|
@ -378,6 +378,8 @@ GENERIC: CMP ( dst src -- )
|
|||
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand CMP OCT: 070 2-operand ;
|
||||
|
||||
: XCHG ( dst src -- ) OCT: 207 2-operand ;
|
||||
|
||||
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
|
||||
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
|
||||
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
|
||||
|
|
@ -406,6 +408,12 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
|
|||
swapd
|
||||
(2-operand) ;
|
||||
|
||||
: MOVZX ( dst src -- )
|
||||
OCT: 266 extended-opcode
|
||||
over register-16? [ BIN: 1 opcode-or ] when
|
||||
swapd
|
||||
(2-operand) ;
|
||||
|
||||
! Conditional move
|
||||
: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -214,29 +214,26 @@ IN: cpu.x86.intrinsics
|
|||
! allocator about the different sized registers, with all
|
||||
! the complexity this entails, we just push/pop a register
|
||||
! which is guaranteed to be unused (the tempreg)
|
||||
: small-reg cell 8 = RAX EAX ? ; inline
|
||||
: small-reg-8 AL ; inline
|
||||
: small-reg-16 AX ; inline
|
||||
: small-reg-32 EAX ; inline
|
||||
: small-reg cell 8 = RDX EDX ? ; inline
|
||||
: small-reg-8 DL ; inline
|
||||
: small-reg-16 DX ; inline
|
||||
: small-reg-32 EDX ; inline
|
||||
|
||||
: %prepare-alien-accessor ( -- )
|
||||
"offset" operand %untag-fixnum
|
||||
"offset" operand "alien" operand ADD ;
|
||||
|
||||
: (%alien-accessor) ( quot -- )
|
||||
"offset" operand [] swap call ; inline
|
||||
|
||||
: %alien-accessor ( quot -- )
|
||||
%prepare-alien-accessor (%alien-accessor) ; inline
|
||||
:: (%alien-integer-get) ( reg quot -- )
|
||||
reg "offset" operand [] MOV
|
||||
"value" operand reg quot call ; inline
|
||||
|
||||
: %alien-integer-get ( reg quot -- )
|
||||
%prepare-alien-accessor
|
||||
"value" operand small-reg = [
|
||||
(%alien-accessor)
|
||||
(%alien-integer-get)
|
||||
] [
|
||||
small-reg PUSH
|
||||
(%alien-accessor)
|
||||
"value" operand small-reg MOV
|
||||
(%alien-integer-get)
|
||||
small-reg POP
|
||||
] if
|
||||
"value" operand %tag-fixnum ; inline
|
||||
|
|
@ -258,20 +255,23 @@ IN: cpu.x86.intrinsics
|
|||
define-intrinsic ;
|
||||
|
||||
: define-unsigned-getter ( word reg -- )
|
||||
[ small-reg dup XOR MOV ] define-getter ;
|
||||
[ MOVZX ] define-getter ;
|
||||
|
||||
: define-signed-getter ( word reg -- )
|
||||
dup '[ MOV small-reg _ MOVSX ] define-getter ;
|
||||
[ MOVSX ] define-getter ;
|
||||
|
||||
: %alien-integer-set ( reg quot -- )
|
||||
"value" operand %untag-fixnum
|
||||
: %alien-integer-set ( reg -- )
|
||||
"value" operand "offset" operand = [
|
||||
"value" operand %untag-fixnum
|
||||
] unless
|
||||
%prepare-alien-accessor
|
||||
small-reg "value" operand = [
|
||||
(%alien-accessor)
|
||||
small-reg "offset" operand = [
|
||||
"value" operand "offset" operand XCHG
|
||||
"value" operand [] swap MOV
|
||||
] [
|
||||
small-reg PUSH
|
||||
small-reg "value" operand MOV
|
||||
(%alien-accessor)
|
||||
"offset" operand [] swap MOV
|
||||
small-reg POP
|
||||
] if ; inline
|
||||
|
||||
|
|
@ -286,7 +286,7 @@ IN: cpu.x86.intrinsics
|
|||
} ;
|
||||
|
||||
: define-setter ( word reg -- )
|
||||
'[ _ [ swap MOV ] %alien-integer-set ]
|
||||
'[ _ %alien-integer-set ]
|
||||
alien-integer-set-template
|
||||
define-intrinsic ;
|
||||
|
||||
|
|
@ -303,7 +303,8 @@ IN: cpu.x86.intrinsics
|
|||
\ set-alien-signed-2 small-reg-16 define-setter
|
||||
|
||||
\ alien-cell [
|
||||
"value" operand [ MOV ] %alien-accessor
|
||||
%prepare-alien-accessor
|
||||
"value" operand "offset" operand [] MOV
|
||||
] T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "alien" c-ptr }
|
||||
|
|
@ -315,7 +316,8 @@ IN: cpu.x86.intrinsics
|
|||
} define-intrinsic
|
||||
|
||||
\ set-alien-cell [
|
||||
"value" operand [ swap MOV ] %alien-accessor
|
||||
%prepare-alien-accessor
|
||||
"offset" operand [] "value" operand MOV
|
||||
] T{ template
|
||||
{ input {
|
||||
{ unboxed-c-ptr "value" pinned-c-ptr }
|
||||
|
|
|
|||
|
|
@ -86,22 +86,24 @@ M: x86 %unbox-float ( dst src -- )
|
|||
{ clobber { "offset" } }
|
||||
} ;
|
||||
|
||||
: define-alien-float-intrinsics ( word get-quot word set-quot -- )
|
||||
'[ "value" operand _ %alien-accessor ]
|
||||
alien-float-set-template
|
||||
define-intrinsic
|
||||
'[ "value" operand _ %alien-accessor ]
|
||||
: define-float-getter ( word get-quot -- )
|
||||
'[
|
||||
%prepare-alien-accessor
|
||||
"value" operand "offset" operand [] @
|
||||
]
|
||||
alien-float-get-template
|
||||
define-intrinsic ;
|
||||
|
||||
\ alien-double
|
||||
[ MOVSD ]
|
||||
\ set-alien-double
|
||||
[ swap MOVSD ]
|
||||
define-alien-float-intrinsics
|
||||
: define-float-setter ( word set-quot -- )
|
||||
'[
|
||||
%prepare-alien-accessor
|
||||
"offset" operand [] "value" operand @
|
||||
]
|
||||
alien-float-set-template
|
||||
define-intrinsic ;
|
||||
|
||||
\ alien-float
|
||||
[ dupd MOVSS dup CVTSS2SD ]
|
||||
\ set-alien-float
|
||||
[ swap dup dup CVTSD2SS MOVSS ]
|
||||
define-alien-float-intrinsics
|
||||
\ alien-double [ MOVSD ] define-float-getter
|
||||
\ set-alien-double [ MOVSD ] define-float-setter
|
||||
|
||||
\ alien-float [ dupd MOVSS dup CVTSS2SD ] define-float-getter
|
||||
\ set-alien-float [ dup dup CVTSD2SS MOVSS ] define-float-setter
|
||||
|
|
|
|||
Loading…
Reference in New Issue