{
"/library/compiler/x86/assembler.factor"
"/library/compiler/x86/architecture.factor"
- "/library/compiler/x86/generator.factor"
- "/library/compiler/x86/slots.factor"
- "/library/compiler/x86/stack.factor"
- "/library/compiler/x86/fixnum.factor"
"/library/compiler/x86/alien.factor"
+ "/library/compiler/x86/intrinsics.factor"
}
]
} {
G: load-literal ( obj vreg -- ) 1 standard-combination ;
! Set up caller stack frame (PowerPC and AMD64)
-DEFER: %prologue ( n -- )
+: %prologue ( n -- ) drop ;
+
+! Tear down stack frame (PowerPC and AMD64)
+: %epilogue ( n -- ) drop ;
! Tail call another word
DEFER: %jump ( label -- )
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: alien assembler generic kernel kernel-internals math
memory namespaces sequences words ;
0 MFLR
0 1 stack-increment lr@ STW ;
-: compile-epilogue ( -- )
+: %epilogue ( -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
dup primitive? [ word-addr 3 MTCTR BCTR ] [ B ] if ;
: %jump ( label -- )
- compile-epilogue dup postpone-word %jump-label ;
+ %epilogue dup postpone-word %jump-label ;
: %jump-t ( label vreg -- )
0 swap v>operand f address CMPI BNE ;
MTLR
BLR ;
-: %return ( -- ) compile-epilogue BLR ;
+: %return ( -- ) %epilogue BLR ;
: %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ;
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: alien arrays assembler inference kernel
kernel-internals lists math memory namespaces words ;
M: %unbox generate-node
drop 2 input f compile-c-call 1 input push-return-reg ;
-: struct-ptr/size ( func -- )
+: struct-ptr/size ( size func -- )
! Load struct size
- 2 input PUSH
+ swap PUSH
! Load destination address
EAX PUSH
! Copy the struct to the stack
- f compile-c-call
+ f %alien-invoke
! Clean up
EAX POP
ECX POP ;
-M: %unbox-struct generate-node ( vop -- )
- drop
+: %unbox-struct ( n reg-class size -- )
+ 2nip
! Increase stack size
- ESP 2 input SUB
+ ESP over SUB
! Save destination address in EAX
EAX ESP MOV
"unbox_value_struct" struct-ptr/size ;
-M: %box-struct generate-node ( vop -- )
+: %box-struct ( n reg-class size -- )
+ 2nip
! Compute source address in EAX
EAX ESP MOV
EAX 4 ADD
- drop "box_value_struct" struct-ptr/size ;
-
-M: %box generate-node
- drop
- 0 input [ 4 + 1 input load-return-reg ] when*
- 1 input push-return-reg
- 2 input f compile-c-call
- 1 input drop-return-reg ;
-
-M: %alien-callback generate-node ( vop -- )
- drop
- EAX 0 input load-indirect
+ "box_value_struct" struct-ptr/size ;
+
+: %box ( n reg-class func -- )
+ rot [ 4 + pick load-return-reg ] when*
+ over push-return-reg
+ f %alien-invoke
+ drop-return-reg ;
+
+: %alien-callback ( quot -- )
+ EAX swap load-literal
EAX PUSH
- "run_callback" f compile-c-call
+ "run_callback" f %alien-invoke
EAX POP ;
-M: %callback-value generate-node ( vop -- )
- drop
+: %callback-value ( reg-class func -- )
! Call the unboxer
- 1 input f compile-c-call
+ f %alien-invoke
! Save return register
- 0 input push-return-reg
+ dup push-return-reg
! Restore data/callstacks
- "unnest_stacks" f compile-c-call
+ "unnest_stacks" f %alien-invoke
! Restore return register
- 0 input pop-return-reg ;
+ dup pop-return-reg ;
-M: %cleanup generate-node
- drop 0 input dup zero? [ drop ] [ ESP swap ADD ] if ;
+: %cleanup ( n -- ) dup zero? [ drop ] [ ESP swap ADD ] if ;
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
IN: compiler
USING: alien arrays assembler generic kernel kernel-internals
-sequences words ;
+math sequences words ;
! x86 register assignments
! EAX, ECX, EDX vregs
: ds-reg ESI ; inline
: cs-reg EBX ; inline
+: reg-stack ( n reg -- op ) swap cells neg [+] ;
+
+M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
+
+M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
+
: remainder-reg EDX ; inline
: vregs { EAX ECX EDX } ; inline
-: compile-c-call ( symbol dll -- )
+: %alien-invoke ( symbol dll -- )
2dup dlsym CALL rel-relative rel-dlsym ;
: compile-c-call* ( symbol dll args -- operands )
reverse-slice
- [ [ PUSH ] each compile-c-call ] keep
+ [ [ PUSH ] each %alien-invoke ] keep
[ drop EDX POP ] each ;
! On x86, parameters are never passed in registers.
: prepare-division CDQ ; inline
-: compile-prologue ; inline
+M: immediate load-literal ( dest literal -- )
+ address MOV ;
+
+M: object load-literal ( dest literal -- )
+ add-literal [] MOV rel-absolute-cell rel-address ;
+
+: (%call) ( label -- label )
+ dup postpone-word dup primitive? [ address-operand ] when ;
+
+: %call ( label -- ) (%call) CALL ;
+
+: %jump ( label -- ) %epilogue (%call) JMP ;
+
+: %jump-label ( label -- ) JMP ;
+
+: %jump-t ( label vreg -- )
+ v>operand f v>operand CMP JNE ;
+
+: %dispatch ( vreg -- )
+ #! Compile a piece of code that jumps to an offset in a
+ #! jump table indexed by the fixnum at the top of the stack.
+ #! The jump table must immediately follow this macro.
+ drop
+ <label> "end" set
+ ! Untag and multiply to get a jump table offset
+ dup fixnum>slot@
+ ! Add to jump table base. We use a temporary register since
+ ! on AMD4 we have to load a 64-bit immediate. On x86, this
+ ! is redundant.
+ 0 scratch HEX: ffffffff MOV "end" get absolute-cell
+ dup 0 scratch ADD
+ ! Jump to jump table entry
+ dup [] JMP
+ ! Align for better performance
+ compile-aligned
+ ! Fix up jump table pointer
+ "end" get save-xt ;
+
+: %return ( -- ) %epilogue RET ;
+
+: %peek ( vreg loc -- ) [ v>operand ] 2apply MOV ;
+
+: %replace ( vreg loc -- ) swap %peek ;
+
+: (%inc) 0 input cells dup 0 > [ ADD ] [ neg SUB ] if ;
-: compile-epilogue ; inline
+: %inc-d ( n -- ) ds-reg (%inc) ;
-: load-indirect ( dest literal -- )
- add-literal [] MOV rel-absolute-cell rel-address ; inline
+: %inc-r ( n -- ) cs-reg (%inc) ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: arrays assembler errors kernel kernel-internals
-math math-internals memory namespaces words ;
-
-: 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 ;
-
-: 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.
- prepare-division
- ! give it a fixnum tag.
- 0 output-operand tag-bits SHL ;
-
-: fixnum-jump ( -- label )
- 1 input-operand 0 input-operand CMP label ;
-
-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 ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: alien arrays assembler inference kernel
-kernel-internals lists math memory namespaces sequences words ;
-
-! Not used on x86
-M: %prologue generate-node ( vop -- ) drop ;
-
-: (%call)
- label dup postpone-word
- dup primitive? [ address-operand ] when ;
-
-M: %call generate-node ( vop -- )
- drop (%call) CALL ;
-
-M: %jump generate-node ( vop -- )
- drop compile-epilogue (%call) JMP ;
-
-M: %jump-label generate-node ( vop -- )
- drop label JMP ;
-
-M: %jump-t generate-node ( vop -- )
- drop
- ! Compare input with f
- 0 input-operand f address CMP
- ! If not equal, jump
- label JNE ;
-
-M: %return generate-node ( vop -- )
- drop compile-epilogue RET ;
-
-M: %dispatch generate-node ( vop -- )
- #! Compile a piece of code that jumps to an offset in a
- #! jump table indexed by the fixnum at the top of the stack.
- #! The jump table must immediately follow this macro.
- drop
- <label> "end" set
- ! Untag and multiply to get a jump table offset
- 0 input-operand fixnum>slot@
- ! Add to jump table base. We use a temporary register since
- ! on AMD4 we have to load a 64-bit immediate. On x86, this
- ! is redundant.
- 0 scratch HEX: ffffffff MOV "end" get absolute-cell
- 0 input-operand 0 scratch ADD
- ! Jump to jump table entry
- 0 input-operand [] JMP
- ! Align for better performance
- compile-aligned
- ! Fix up jump table pointer
- "end" get save-xt ;
-
-M: %type generate-node ( vop -- )
- #! Intrinstic version of type primitive.
- drop
- <label> "header" set
- <label> "f" set
- <label> "end" set
- ! Make a copy
- 0 scratch 0 output-operand MOV
- ! Get the tag
- 0 output-operand tag-mask AND
- ! Compare with object tag number (3).
- 0 output-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
- "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
- "f" get JE
- ! The pointer is not equal to 3. Load the object header.
- 0 output-operand 0 scratch object-tag neg [+] MOV
- ! Mask off header tag, making a fixnum.
- 0 output-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 ;
-
-M: %untag generate-node ( vop -- )
- drop
- 0 output-operand tag-mask bitnot AND ;
--- /dev/null
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: compiler
+
+M: %type generate-node ( vop -- )
+ #! Intrinstic version of type primitive.
+ drop
+ <label> "header" set
+ <label> "f" set
+ <label> "end" set
+ ! Make a copy
+ 0 scratch 0 output-operand MOV
+ ! Get the tag
+ 0 output-operand tag-mask AND
+ ! Compare with object tag number (3).
+ 0 output-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
+ "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
+ "f" get JE
+ ! The pointer is not equal to 3. Load the object header.
+ 0 output-operand 0 scratch object-tag neg [+] MOV
+ ! Mask off header tag, making a fixnum.
+ 0 output-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 ;
+
+M: %untag generate-node ( vop -- )
+ drop
+ 0 output-operand tag-mask bitnot AND ;
+
+M: %slot generate-node ( vop -- )
+ drop
+ ! turn tagged fixnum slot # into an offset, multiple of 4
+ 0 input-operand fixnum>slot@
+ ! compute slot address
+ dest/src ADD
+ ! load slot value
+ 0 output-operand dup [] MOV ;
+
+: card-offset 1 getenv ; inline
+
+M: %write-barrier generate-node ( vop -- )
+ #! 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 ;
+
+M: %set-slot generate-node ( vop -- )
+ drop
+ ! turn tagged fixnum slot # into an offset
+ 2 input-operand fixnum>slot@
+ ! compute slot address
+ 2 input-operand 1 input-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 ;
+
+: 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.
+ prepare-division
+ ! give it a fixnum tag.
+ 0 output-operand tag-bits SHL ;
+
+: fixnum-jump ( -- label )
+ 1 input-operand 0 input-operand CMP label ;
+
+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 ;
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
-USING: alien arrays assembler inference kernel
-kernel-internals lists math memory namespaces sequences words ;
-
-M: %slot generate-node ( vop -- )
- drop
- ! turn tagged fixnum slot # into an offset, multiple of 4
- 0 input-operand fixnum>slot@
- ! compute slot address
- dest/src ADD
- ! load slot value
- 0 output-operand dup [] MOV ;
-
-M: %fast-slot generate-node ( vop -- )
- drop 0 output-operand 1 input-operand 0 input [+] MOV ;
-
-: card-offset 1 getenv ; inline
-
-M: %write-barrier generate-node ( vop -- )
- #! 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 ;
-
-M: %set-slot generate-node ( vop -- )
- drop
- ! turn tagged fixnum slot # into an offset
- 2 input-operand fixnum>slot@
- ! compute slot address
- 2 input-operand 1 input-operand ADD
- ! store new slot value
- 2 input-operand [] 0 input-operand MOV ;
-
-M: %fast-set-slot generate-node ( vop -- )
- drop 1 input-operand 2 input [+] 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 ;
-
-: userenv@ ( n -- addr ) cells "userenv" f dlsym + ;
-
-M: %getenv generate-node ( vop -- )
- drop
- 0 output-operand 0 input userenv@ MOV
- 0 input rel-absolute-cell rel-userenv
- 0 output-operand dup [] MOV ;
-
-M: %setenv generate-node ( vop -- )
- drop
- 0 scratch 1 input userenv@ MOV
- 1 input rel-absolute-cell rel-userenv
- 0 scratch [] 0 input-operand MOV ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: compiler
-USING: alien arrays assembler inference kernel
-kernel-internals lists math memory sequences words ;
-
-: reg-stack ( n reg -- op ) swap cells neg [+] ;
-
-M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
-
-M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
-
-M: %peek generate-node ( vop -- )
- drop 0 output-operand 0 input-operand MOV ;
-
-M: %replace generate-node ( vop -- )
- drop 0 output-operand 0 input-operand MOV ;
-
-: (%inc) 0 input cells dup 0 > [ ADD ] [ neg SUB ] if ;
-
-M: %inc-d generate-node ( vop -- ) drop ds-reg (%inc) ;
-
-M: %inc-r generate-node ( vop -- ) drop cs-reg (%inc) ;
-
-M: %immediate generate-node ( vop -- )
- drop 0 output-operand 0 input address MOV ;
-
-M: %indirect generate-node ( vop -- )
- #! indirect load of a literal through a table
- drop 0 output-operand 0 input load-indirect ;
projects / factor.git / commitdiff