factor/library/compiler/x86/intrinsics.factor

283 lines
7.5 KiB
Factor
Raw Normal View History

2006-04-28 19:23:50 -04:00
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
2006-05-15 01:01:47 -04:00
USING: alien arrays assembler kernel kernel-internals math
2006-05-01 20:45:40 -04:00
math-internals namespaces sequences words ;
IN: compiler
2006-04-28 19:23:50 -04:00
2006-05-04 18:08:52 -04:00
! Type checks
\ tag [
"in" operand tag-mask AND
"in" operand tag-bits SHL
] H{
{ +input { { f "in" } } }
{ +output { "in" } }
} define-intrinsic
\ type [
2006-04-28 19:23:50 -04:00
#! Intrinstic version of type primitive.
<label> "header" set
<label> "f" set
<label> "end" set
! Make a copy
"x" operand "obj" operand MOV
2006-04-28 19:23:50 -04:00
! Get the tag
"obj" operand tag-mask AND
2006-04-28 19:23:50 -04:00
! Compare with object tag number (3).
"obj" operand object-tag CMP
2006-04-28 19:23:50 -04:00
! Jump if the object doesn't store type info in its header
"header" get JE
! It doesn't store type info in its header
"obj" operand tag-bits SHL
2006-04-28 19:23:50 -04:00
"end" get JMP
"header" get save-xt
! It does store type info in its header
! Is the pointer itself equal to 3? Then its F_TYPE (9).
"x" operand object-tag CMP
2006-04-28 19:23:50 -04:00
"f" get JE
! The pointer is not equal to 3. Load the object header.
"obj" operand "x" operand object-tag neg [+] MOV
2006-04-28 19:23:50 -04:00
! Mask off header tag, making a fixnum.
"obj" operand object-tag XOR
2006-04-28 19:23:50 -04:00
"end" get JMP
"f" get save-xt
! The pointer is equal to 3. Load F_TYPE (9).
"obj" operand f type tag-bits shift MOV
"end" get save-xt
] H{
{ +input { { f "obj" } } }
{ +scratch { { f "x" } { f "y" } } }
{ +output { "obj" } }
} define-intrinsic
2006-04-28 19:23:50 -04:00
2006-05-04 18:08:52 -04:00
! Slots
: untag ( reg -- ) tag-mask bitnot AND ;
2006-04-28 19:23:50 -04:00
\ slot [
"obj" operand untag
2006-04-28 19:23:50 -04:00
! turn tagged fixnum slot # into an offset, multiple of 4
"n" operand fixnum>slot@
2006-04-28 19:23:50 -04:00
! compute slot address
"obj" operand "n" operand ADD
2006-04-28 19:23:50 -04:00
! load slot value
"obj" operand dup [] MOV
] H{
{ +input { { f "obj" } { f "n" } } }
{ +output { "obj" } }
{ +clobber { "n" } }
} define-intrinsic
2006-04-28 19:23:50 -04:00
: card-offset 1 getenv ; inline
: generate-write-barrier ( -- )
2006-04-28 19:23:50 -04:00
#! Mark the card pointed to by vreg.
"obj" operand card-bits SHR
"obj" operand card-offset ADD rel-absolute-cell rel-cards
"obj" operand [] card-mark OR ;
2006-04-28 19:23:50 -04:00
2006-05-11 19:46:19 -04:00
\ set-slot [
"obj" operand untag
! turn tagged fixnum slot # into an offset
"slot" operand fixnum>slot@
! compute slot address
"slot" operand "obj" operand ADD
! store new slot value
"slot" operand [] "val" operand MOV
generate-write-barrier
] H{
{ +input { { f "val" } { f "obj" } { f "slot" } } }
{ +clobber { "obj" "slot" } }
} define-intrinsic
\ char-slot [
EBX PUSH
"n" operand 2 SHR
EBX dup XOR
2006-05-01 20:45:40 -04:00
"obj" operand "n" operand ADD
BX "obj" operand string-offset [+] MOV
EBX tag-bits SHL
"obj" operand EBX MOV
EBX POP
] H{
{ +input { { f "n" } { f "obj" } } }
{ +output { "obj" } }
{ +clobber { "n" } }
} define-intrinsic
\ set-char-slot [
EBX PUSH
"val" operand tag-bits SHR
"slot" operand 2 SHR
"obj" operand "slot" operand ADD
EBX "val" operand MOV
"obj" operand string-offset [+] BX MOV
EBX POP
] H{
{ +input { { f "val" } { f "slot" } { f "obj" } } }
2006-05-01 20:45:40 -04:00
{ +clobber { "val" "slot" "obj" } }
} define-intrinsic
2006-05-04 18:08:52 -04:00
! Fixnums
: define-fixnum-op ( word op -- )
[ [ "x" operand "y" operand ] % , ] [ ] make H{
{ +input { { f "x" } { f "y" } } }
{ +output { "x" } }
} define-intrinsic ;
{
{ fixnum+fast ADD }
{ fixnum-fast SUB }
{ fixnum-bitand AND }
{ fixnum-bitor OR }
{ fixnum-bitxor XOR }
} [
2006-05-04 18:08:52 -04:00
first2 define-fixnum-op
] each
\ fixnum-bitnot [
"x" operand NOT
"x" operand tag-mask XOR
] H{
{ +input { { f "x" } } }
{ +output { "x" } }
} define-intrinsic
! This has specific register requirements. Inputs are in
! ECX and EAX, and the result is in EDX.
\ fixnum-mod [
2005-12-07 03:37:05 -05:00
prepare-division
2006-05-01 20:45:40 -04:00
"y" operand IDIV
] H{
{ +input { { 0 "x" } { 1 "y" } } }
{ +scratch { { 2 "out" } } }
{ +output { "out" } }
} define-intrinsic
: ?MOV ( dst src -- ) 2dup = [ 2drop ] [ MOV ] if ;
: unique-operands ( operands quot -- )
>r [ operand ] map prune r> each ; inline
: simple-overflow ( word -- )
finalize-contents
"z" operand "x" operand MOV
"z" operand "y" operand pick execute
! If the previous arithmetic operation overflowed, then we
! turn the result into a bignum and leave it in EAX.
<label> "end" set
"end" get JNO
! There was an overflow. Recompute the original operand.
{ "y" "x" } [ tag-bits SAR ] unique-operands
"x" operand "y" operand rot execute
"s48_long_to_bignum" f "x" operand 1array compile-c-call*
! An untagged pointer to the bignum is now in EAX; tag it
T{ int-regs } return-reg bignum-tag OR
"z" operand T{ int-regs } return-reg ?MOV
"end" get save-xt ; inline
: simple-overflow-template ( word insn -- )
[ simple-overflow ] curry H{
{ +input { { f "x" } { f "y" } } }
{ +scratch { { f "z" } } }
{ +output { "z" } }
{ +clobber { "x" "y" } }
} define-intrinsic ;
\ fixnum+ \ ADD simple-overflow-template
\ fixnum- \ SUB simple-overflow-template
\ fixnum* [
finalize-contents
"y" operand tag-bits SAR
"y" operand IMUL
<label> "end" set
"end" get JNO
"s48_fixnum_pair_to_bignum" f
"x" operand remainder-reg 2array compile-c-call*
! now we have to shift it by three bits to remove the second
! tag
"s48_bignum_arithmetic_shift" f
"x" operand tag-bits neg 2array compile-c-call*
! an untagged pointer to the bignum is now in EAX; tag it
T{ int-regs } return-reg bignum-tag OR
"end" get save-xt
] H{
2006-05-01 20:45:40 -04:00
{ +input { { 0 "x" } { 1 "y" } } }
{ +output { "x" } }
} define-intrinsic
2006-05-01 20:45:40 -04:00
: generate-fixnum/mod
#! The same code is used for fixnum/i and fixnum/mod.
#! This has specific register
#! ECX and EAX, and the result is in EDX.
<label> "end" set
prepare-division
"y" operand IDIV
! Make a copy since following shift is destructive
"y" operand "x" operand MOV
! Tag the value, since division cancelled tags from both
! inputs
"x" operand tag-bits SHL
! Did it overflow?
"end" get JNO
! There was an overflow, so make ECX into a bignum. we must
! save EDX since its volatile.
remainder-reg PUSH
"s48_long_to_bignum" f
"y" operand 1array compile-c-call*
! An untagged pointer to the bignum is now in EAX; tag it
T{ int-regs } return-reg bignum-tag OR
! the remainder is now in EDX
remainder-reg POP
"end" get save-xt ;
\ fixnum/i [ generate-fixnum/mod ] H{
{ +input { { 0 "x" } { 1 "y" } } }
{ +scratch { { 2 "out" } } }
{ +output { "x" } }
{ +clobber { "x" "y" } }
} define-intrinsic
2006-05-01 20:45:40 -04:00
\ fixnum/mod [ generate-fixnum/mod ] H{
{ +input { { 0 "x" } { 1 "y" } } }
{ +scratch { { 2 "out" } } }
{ +output { "x" "out" } }
{ +clobber { "x" "y" } }
} define-intrinsic
2006-05-04 18:08:52 -04:00
: define-fixnum-jump ( word op -- )
2006-05-14 20:05:57 -04:00
[ end-basic-block "x" operand "y" operand CMP ] swap add
H{ { +input { { f "x" } { f "y" } } } } define-if-intrinsic ;
{
{ fixnum< JL }
{ fixnum<= JLE }
{ fixnum> JG }
{ fixnum>= JGE }
{ eq? JE }
} [
2006-05-04 18:08:52 -04:00
first2 define-fixnum-jump
] each
2006-05-04 18:08:52 -04:00
! User environment
: %userenv ( -- )
2006-05-24 18:42:21 -04:00
"x" operand "userenv" f [ dlsym MOV ] 2keep
2006-05-20 18:15:46 -04:00
rel-absolute-cell rel-dlsym
2006-05-14 20:05:57 -04:00
"n" operand fixnum>slot@
"n" operand "x" operand ADD ;
2005-05-09 22:34:47 -04:00
\ getenv [
%userenv "n" operand dup [] MOV
] H{
{ +input { { f "n" } } }
{ +scratch { { f "x" } } }
{ +output { "n" } }
} define-intrinsic
2005-05-09 02:34:15 -04:00
\ setenv [
%userenv "n" operand [] "val" operand MOV
] H{
{ +input { { f "val" } { f "n" } } }
{ +scratch { { f "x" } } }
{ +clobber { "n" } }
} define-intrinsic