! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
IN: compiler
+USING: alien assembler kernel kernel-internals math
+math-internals namespaces sequences ;
-M: %type generate-node ( vop -- )
+\ tag [
+ "in" operand tag-mask AND
+ "in" operand tag-bits SHL
+] H{
+ { +input { { f "in" } } }
+ { +output { "in" } }
+} define-intrinsic
+
+\ type [
#! Intrinstic version of type primitive.
- drop
<label> "header" set
<label> "f" set
<label> "end" set
! Make a copy
- 0 scratch 0 output-operand MOV
+ "x" operand "obj" operand MOV
! Get the tag
- 0 output-operand tag-mask AND
+ "obj" operand tag-mask AND
! Compare with object tag number (3).
- 0 output-operand object-tag CMP
+ "obj" operand object-tag CMP
! Jump if the object doesn't store type info in its header
"header" get JE
! It doesn't store type info in its header
- 0 output-operand tag-bits SHL
+ "obj" operand tag-bits SHL
"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).
- 0 scratch object-tag CMP
+ "x" operand object-tag CMP
"f" get JE
! The pointer is not equal to 3. Load the object header.
- 0 output-operand 0 scratch object-tag neg [+] MOV
+ "obj" operand "x" operand object-tag neg [+] MOV
! Mask off header tag, making a fixnum.
- 0 output-operand object-tag XOR
+ "obj" operand object-tag XOR
"end" get JMP
"f" get save-xt
! The pointer is equal to 3. Load F_TYPE (9).
- 0 output-operand f type tag-bits shift MOV
- "end" get save-xt ;
-
-M: %tag generate-node ( vop -- )
- drop
- 0 input-operand tag-mask AND
- 0 input-operand tag-bits SHL ;
+ "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
-M: %untag generate-node ( vop -- )
- drop
- 0 output-operand tag-mask bitnot AND ;
+: untag ( reg -- ) tag-mask bitnot AND ;
-M: %slot generate-node ( vop -- )
- drop
+\ slot [
+ "obj" operand untag
! turn tagged fixnum slot # into an offset, multiple of 4
- 0 input-operand fixnum>slot@
+ "n" operand fixnum>slot@
! compute slot address
- dest/src ADD
+ "obj" operand "n" operand ADD
! load slot value
- 0 output-operand dup [] MOV ;
+ "obj" operand dup [] MOV
+] H{
+ { +input { { f "obj" } { f "n" } } }
+ { +output { "obj" } }
+ { +clobber { "n" } }
+} define-intrinsic
: card-offset 1 getenv ; inline
-M: %write-barrier generate-node ( vop -- )
+: generate-write-barrier ( -- )
#! Mark the card pointed to by vreg.
- drop
- 0 input-operand card-bits SHR
- 0 input-operand card-offset ADD rel-absolute-cell rel-cards
- 0 input-operand [] card-mark OR ;
+ "obj" operand card-bits SHR
+ "obj" operand card-offset ADD rel-absolute-cell rel-cards
+ "obj" operand [] card-mark OR ;
-M: %set-slot generate-node ( vop -- )
- drop
+\ set-slot [
+ "obj" operand untag
! turn tagged fixnum slot # into an offset
- 2 input-operand fixnum>slot@
+ "slot" operand fixnum>slot@
! compute slot address
- 2 input-operand 1 input-operand ADD
+ "obj" operand "slot" operand ADD
! store new slot value
- 2 input-operand [] 0 input-operand MOV ;
-
-: >register-16 ( reg -- reg )
- "register" word-prop { AX CX DX } nth ;
-
-: scratch-16 ( n -- reg ) scratch >register-16 ;
-
-M: %char-slot generate-node ( vop -- )
- drop
- 0 input-operand 2 SHR
- 0 scratch dup XOR
- dest/src ADD
- 0 scratch-16 0 output-operand string-offset [+] MOV
- 0 scratch tag-bits SHL
- 0 output-operand 0 scratch MOV ;
-
-M: %set-char-slot generate-node ( vop -- )
- drop
- 0 input-operand tag-bits SHR
- 2 input-operand 2 SHR
- 2 input-operand 1 input-operand ADD
- 2 input-operand string-offset [+]
- 0 input-operand >register-16 MOV ;
-
-: literal-overflow ( -- dest src )
- #! Called if the src operand is a literal.
- #! Untag the dest operand.
- dest/src over tag-bits SAR tag-bits neg shift ;
-
-: computed-overflow ( -- dest src )
- #! Called if the src operand is a register.
- #! Untag both operands.
- dest/src 2dup tag-bits SAR tag-bits SAR ;
-
-: simple-overflow ( inverse word -- )
- #! 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.
- >r >r dest/src r> execute
- 0 input integer? [ literal-overflow ] [ computed-overflow ] if
- ! Compute a result, this time it will fit.
- r> execute
- ! Create a bignum.
- "s48_long_to_bignum" f 0 output-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
- "end" get save-xt ; inline
-
-M: %fixnum+ generate-node ( vop -- )
- drop dest/src ADD \ SUB \ ADD simple-overflow ;
-
-M: %fixnum+fast generate-node ( vop -- ) drop dest/src ADD ;
-
-M: %fixnum- generate-node ( vop -- )
- drop dest/src SUB \ ADD \ SUB simple-overflow ;
-
-M: %fixnum-fast generate-node ( vop -- ) drop dest/src SUB ;
-
-M: %fixnum* generate-node ( vop -- )
- drop
- ! both inputs are tagged, so one of them needs to have its
- ! tag removed.
- 1 input-operand tag-bits SAR
- 0 input-operand IMUL
- <label> "end" set
- "end" get JNO
- "s48_fixnum_pair_to_bignum" f
- 1 input-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
- 1 input-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 ;
-
-M: %fixnum-mod generate-node ( vop -- )
- #! This has specific register requirements. Inputs are in
- #! ECX and EAX, and the result is in EDX.
- drop
- prepare-division
- 0 input-operand IDIV ;
+ "obj" operand [] "val" operand MOV
+ generate-write-barrier
+] H{
+ { +input { { f "val" } { f "obj" } { f "slot" } } }
+ { +scratch { { f "x" } } }
+ { +clobber { "obj" } }
+} define-intrinsic
-: generate-fixnum/mod
- #! The same code is used for %fixnum/i and %fixnum/mod.
- #! This has specific register requirements. Inputs are in
- #! ECX and EAX, and the result is in EDX.
- <label> "end" set
- prepare-division
- 0 input-operand IDIV
- ! Make a copy since following shift is destructive
- 0 input-operand 1 input-operand MOV
- ! Tag the value, since division cancelled tags from both
- ! inputs
- 1 input-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
- 0 input-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 ;
-
-M: %fixnum/i generate-node drop generate-fixnum/mod ;
-
-M: %fixnum/mod generate-node drop generate-fixnum/mod ;
-
-M: %fixnum-bitand generate-node ( vop -- ) drop dest/src AND ;
-
-M: %fixnum-bitor generate-node ( vop -- ) drop dest/src OR ;
-
-M: %fixnum-bitxor generate-node ( vop -- ) drop dest/src XOR ;
-
-M: %fixnum-bitnot generate-node ( vop -- )
- drop
- ! Negate the bits of the operand
- 0 output-operand NOT
- ! Mask off the low 3 bits to give a fixnum tag
- 0 output-operand tag-mask XOR ;
-
-M: %fixnum>> generate-node
- drop
- ! shift register
- 0 output-operand 0 input SAR
- ! give it a fixnum tag
- 0 output-operand tag-mask bitnot AND ;
-
-M: %fixnum-sgn generate-node
- #! This has specific register requirements.
- drop
- ! store 0 in EDX if EAX is >=0, otherwise store -1.
+\ char-slot [
+ EBX PUSH
+ "n" operand 2 SHR
+ EBX dup XOR
+ EBX "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 [
+ "obj" operand untag
+ 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" } } }
+ { +clobber { "obj" } }
+} define-intrinsic
+
+: define-binary-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 }
+} [
+ first2 define-binary-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 [
prepare-division
- ! give it a fixnum tag.
- 0 output-operand tag-bits SHL ;
+ "x" operand IDIV
+] H{
+ { +input { { 0 "x" } { 2 "y" } } }
+ { +output { "x" } }
+} define-intrinsic
+
+! : literal-overflow ( -- dest src )
+! #! Called if the src operand is a literal.
+! #! Untag the dest operand.
+! dest/src over tag-bits SAR tag-bits neg shift ;
+!
+! : computed-overflow ( -- dest src )
+! #! Called if the src operand is a register.
+! #! Untag both operands.
+! dest/src 2dup tag-bits SAR tag-bits SAR ;
+!
+! : simple-overflow ( inverse word -- )
+! #! 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.
+! >r >r dest/src r> execute
+! 0 input integer? [ literal-overflow ] [ computed-overflow ] if
+! ! Compute a result, this time it will fit.
+! r> execute
+! ! Create a bignum.
+! "s48_long_to_bignum" f 0 output-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
+! "end" get save-xt ; inline
+!
+! M: %fixnum+ generate-node ( vop -- )
+! drop dest/src ADD \ SUB \ ADD simple-overflow ;
+!
+! M: %fixnum- generate-node ( vop -- )
+! drop dest/src SUB \ ADD \ SUB simple-overflow ;
+!
+! M: %fixnum* generate-node ( vop -- )
+! drop
+! ! both inputs are tagged, so one of them needs to have its
+! ! tag removed.
+! 1 input-operand tag-bits SAR
+! 0 input-operand IMUL
+! <label> "end" set
+! "end" get JNO
+! "s48_fixnum_pair_to_bignum" f
+! 1 input-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
+! 1 input-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 ;
+!
+! : generate-fixnum/mod
+! #! The same code is used for %fixnum/i and %fixnum/mod.
+! #! This has specific register requirements. Inputs are in
+! #! ECX and EAX, and the result is in EDX.
+! <label> "end" set
+! prepare-division
+! 0 input-operand IDIV
+! ! Make a copy since following shift is destructive
+! 0 input-operand 1 input-operand MOV
+! ! Tag the value, since division cancelled tags from both
+! ! inputs
+! 1 input-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
+! 0 input-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 ;
+!
+! M: %fixnum/i generate-node drop generate-fixnum/mod ;
+!
+! M: %fixnum/mod generate-node drop generate-fixnum/mod ;
+
+: define-binary-jump ( word op -- )
+ [
+ [ end-basic-block "x" operand "y" operand CMP ] % ,
+ ] [ ] make H{
+ { +input { { f "x" } { f "y" } } }
+ } define-if-intrinsic ;
+
+{
+ { fixnum< JL }
+ { fixnum<= JLE }
+ { fixnum> JG }
+ { fixnum>= JGE }
+ { eq? JE }
+} [
+ first2 define-binary-jump
+] each
+
+: %userenv ( -- )
+ "x" operand "userenv" f dlsym MOV
+ rel-absolute-cell rel-userenv
+ "n" operand 1 SHR
+ "n" operand "x" operand ADD ;
-: fixnum-jump ( -- label )
- 1 input-operand 0 input-operand CMP label ;
+\ getenv [
+ %userenv "n" operand dup [] MOV
+] H{
+ { +input { { f "n" } } }
+ { +scratch { { f "x" } } }
+ { +output { "n" } }
+} define-intrinsic
-M: %jump-fixnum< generate-node ( vop -- ) drop fixnum-jump JL ;
-M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump JLE ;
-M: %jump-fixnum> generate-node ( vop -- ) drop fixnum-jump JG ;
-M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump JGE ;
-M: %jump-eq? generate-node ( vop -- ) drop fixnum-jump JE ;
+\ setenv [
+ %userenv "n" operand [] "val" operand MOV
+] H{
+ { +input { { f "val" } { f "n" } } }
+ { +scratch { { f "x" } } }
+ { +clobber { "n" } }
+} define-intrinsic
projects / factor.git / commitdiff