- callback scheduling issue
- sometimes fep when closing window
- %allot-bignum-signed-2: handle carry in negation
+- x86: load-allot-ptr doesn't have a stack effect? why?
+- remove useless-coerce optimization
+ ui:
fp-scratch swap %move-int>int
fp-scratch %move-int>float ;
-: load-zone-ptr ( reg -- )
- #! Load pointer to start of zone array
- dup 0 MOV
- "generations" f rel-absolute-cell rel-dlsym
- dup [] MOV ;
-
-: load-allot-ptr ( vreg -- )
- dup load-zone-ptr dup cell [+] MOV ;
-
-: inc-allot-ptr ( vreg n -- )
- >r dup load-zone-ptr cell [+] r> ADD ;
-
-: with-inline-alloc ( prequot postquot spec -- )
- #! both quotations are called with the vreg
- [
- alloc-tmp-reg PUSH
- alloc-tmp-reg load-allot-ptr
- alloc-tmp-reg [] \ tag-header get call tag-header MOV
- >r call alloc-tmp-reg \ tag get call OR
- r> call alloc-tmp-reg \ size get call inc-allot-ptr
- alloc-tmp-reg POP
- ] bind ; inline
-
M: float-regs (%replace)
- drop
- [ alloc-tmp-reg 8 [+] rot v>operand MOVSD ]
- [ v>operand alloc-tmp-reg MOV ] H{
- { tag-header [ float-tag ] }
- { tag [ float-tag ] }
- { size [ 16 ] }
- } with-inline-alloc ;
+ drop swap %allot-float ;
! Floats
: define-float-op ( word op -- )
--- /dev/null
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler
+USING: kernel assembler kernel-internals namespaces math ;
+
+: load-zone-ptr ( reg -- )
+ #! Load pointer to start of zone array
+ dup 0 MOV
+ "generations" f rel-absolute-cell rel-dlsym
+ dup [] MOV ;
+
+: load-allot-ptr ( reg -- )
+ dup load-zone-ptr dup cell [+] MOV ;
+
+: inc-allot-ptr ( reg n -- )
+ >r dup load-zone-ptr cell [+] r> ADD ;
+
+: %allot ( header size quot -- )
+ swap >r >r
+ alloc-tmp-reg PUSH
+ alloc-tmp-reg load-allot-ptr
+ alloc-tmp-reg [] rot tag-header MOV
+ r> call
+ alloc-tmp-reg r> 8 align inc-allot-ptr
+ alloc-tmp-reg POP ; inline
+
+: %allot-float ( loc vreg -- )
+ #! Only called by pentium4 backend
+ float-tag 16 [
+ alloc-tmp-reg 8 [+] rot v>operand MOVSD
+ alloc-tmp-reg float-tag OR
+ v>operand alloc-tmp-reg MOV
+ ] %allot ;
+
+M: float-regs (%replace)
+ drop swap %allot-float ;
+
+: %allot-bignum ( #digits quot -- )
+ #! 1 cell header, 1 cell length, 1 cell sign, + digits
+ #! length is the # of digits + sign
+ bignum-tag pick 3 + cells [
+ >r alloc-tmp-reg cell [+] swap 1+ tag-bits shift MOV r>
+ call
+ ] %allot ; inline
+
+: %allot-bignum-signed-1 ( reg -- )
+ #! on entry, reg is a signed 32-bit quantity
+ #! exits with tagged ptr to bignum in reg
+ [
+ 1 [
+ ! todo: neg
+ alloc-tmp-reg 2 cells [+] 0 MOV ! positive sign
+ alloc-tmp-reg 3 cells [+] over MOV
+ alloc-tmp-reg bignum-tag OR
+ MOV
+ ] %allot-bignum
+ ] with-scope ;
+
+: %allot-bignum-signed-2 ( reg1 reg2 -- )
+ #! on entry, reg1 and reg2 together form a signed 64-bit
+ #! quantity.
+ #! exits with tagged ptr to bignum in reg1
+ [
+ 2 [
+ alloc-tmp-reg 2 cells [+] 0 MOV ! positive sign
+ alloc-tmp-reg 3 cells [+] swap MOV
+ alloc-tmp-reg 4 cells [+] over MOV
+ alloc-tmp-reg bignum-tag OR
+ MOV
+ ] %allot-bignum
+ ] with-scope ;
{ +output+ { "out" } }
} define-intrinsic
-: ?MOV ( dst src -- ) 2dup = [ 2drop ] [ MOV ] if ;
-
: simple-overflow ( word -- )
- finalize-contents
"z" operand "x" operand MOV
"z" operand "y" operand pick execute
! If the previous arithmetic operation overflowed, then we
! 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
+ "x" operand %allot-bignum-signed-1
+ "z" operand "x" operand MOV
"end" resolve-label ; inline
: simple-overflow-template ( word insn -- )
\ fixnum- \ SUB simple-overflow-template
\ fixnum* [
- finalize-contents
"y" operand tag-bits SAR
"y" operand IMUL
"end" define-label
"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
+ "x" operand remainder-reg %allot-bignum-signed-2
"end" resolve-label
] H{
{ +input+ { { 0 "x" } { 1 "y" } } }
"x" operand 1 tag-bits shift IMUL2
! 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
- ! Align the stack -- only needed on Mac OS X
- stack-reg 16 cell - SUB
- "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
- ! Align the stack -- only needed on Mac OS X
- stack-reg 16 cell - ADD
- ! the remainder is now in EDX
- remainder-reg POP
+ "y" operand %allot-bignum-signed-1
"end" resolve-label ;
\ fixnum/i [ generate-fixnum/mod ] H{
{ +files+ {
"assembler.factor"
"architecture.factor"
+ "allot.factor"
"intrinsics.factor"
} } ;
projects / factor.git / commitdiff