- 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
+- mov 0x0(%esi),%ecx why?
+- mac intel: perhaps its not a good idea using ebx as allot-tmp-reg
+ ui:
: ds-reg R14 ; inline
: cs-reg R15 ; inline
-: remainder-reg RDX ; inline
-: alloc-tmp-reg RBX ; inline
+: allot-tmp-reg RBX ; inline
: stack-reg RSP ; inline
M: int-regs return-reg drop RAX ;
: compile-c-call ( symbol dll -- )
0 address-operand >r rel-absolute-cell rel-dlsym r> CALL ;
-: compile-c-call* ( symbol dll args -- )
- T{ int-regs } fastcall-regs
- swap [ MOV ] 2each compile-c-call ;
-
: fixnum>slot@ drop ; inline
: prepare-division CQO ; inline
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
} define-optimizers
-: useless-coerce? ( node -- ? )
- dup 0 node-class#
- swap node-param "infer-effect" word-prop effect-out first
- eq? ;
-
-! >fixnum on a fixnum, etc is a no-op
-{ >fixnum >bignum >float } [
- {
- { [ dup useless-coerce? ] [ call>no-op ] }
- } define-optimizers
-] each
-
! type applied to an object of a known type can be folded
: known-type? ( node -- ? )
0 node-class# types length 1 number= ;
fp-scratch swap %move-int>int
fp-scratch %move-int>float ;
-M: float-regs (%replace)
- drop swap %allot-float ;
+M: float-regs (%replace) drop swap %allot-float ;
! Floats
: define-float-op ( word op -- )
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
- dup 0 MOV
+ allot-tmp-reg 0 MOV
"generations" f rel-absolute-cell rel-dlsym
- dup [] MOV ;
+ allot-tmp-reg allot-tmp-reg [] MOV ;
-: load-allot-ptr ( reg -- )
- dup load-zone-ptr dup cell [+] MOV ;
+: load-allot-ptr ( -- )
+ load-zone-ptr
+ allot-tmp-reg allot-tmp-reg cell [+] MOV ;
-: inc-allot-ptr ( reg n -- )
- >r dup load-zone-ptr cell [+] r> ADD ;
+: inc-allot-ptr ( n -- )
+ load-zone-ptr
+ allot-tmp-reg cell [+] swap 8 align ADD ;
+
+: store-header ( header -- )
+ allot-tmp-reg [] swap tag-header MOV ;
: %allot ( header size quot -- )
swap >r >r
- alloc-tmp-reg PUSH
- alloc-tmp-reg load-allot-ptr
- alloc-tmp-reg [] rot tag-header MOV
+ allot-tmp-reg PUSH
+ load-allot-ptr
+ store-header
r> call
- alloc-tmp-reg r> 8 align inc-allot-ptr
- alloc-tmp-reg POP ; inline
+ r> inc-allot-ptr
+ allot-tmp-reg POP ; inline
: %allot-float ( loc vreg -- )
- #! Only called by pentium4 backend
+ #! Only called by pentium4 backend, uses SSE2 instruction
float-tag 16 [
- alloc-tmp-reg 8 [+] rot v>operand MOVSD
- alloc-tmp-reg float-tag OR
- v>operand alloc-tmp-reg MOV
+ allot-tmp-reg 8 [+] rot v>operand MOVSD
+ allot-tmp-reg float-tag OR
+ v>operand allot-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>
+ ! Write length
+ >r allot-tmp-reg cell [+] swap 1+ tag-bits shift MOV r>
+ ! Call quot
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
+: %allot-bignum-signed-1 ( outreg inreg -- )
+ #! on entry, inreg is a signed 32-bit quantity
+ #! exits with tagged ptr to bignum in outreg
[
+ "positive" define-label
+ "end" define-label
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
+ dup 0 CMP
+ "positive" get JGE
+ allot-tmp-reg 2 cells [+] 1 MOV ! negative sign
+ dup NEG
+ "end" get JMP
+ "positive" resolve-label
+ allot-tmp-reg 2 cells [+] 0 MOV ! positive sign
+ "end" resolve-label
+ allot-tmp-reg 3 cells [+] swap MOV
+ allot-tmp-reg bignum-tag OR
+ allot-tmp-reg MOV
] %allot-bignum
] with-scope ;
#! 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
+ ! todo: neg
+ allot-tmp-reg 2 cells [+] 0 MOV ! positive sign
+ allot-tmp-reg 3 cells [+] swap MOV
+ allot-tmp-reg 4 cells [+] over MOV
+ allot-tmp-reg bignum-tag OR
+ allot-tmp-reg MOV
] %allot-bignum
] with-scope ;
: ds-reg ESI ; inline
: cs-reg EDI ; inline
-: remainder-reg EDX ; inline
-: alloc-tmp-reg EBX ; inline
+: allot-tmp-reg EBX ; inline
: stack-reg ESP ; inline
: stack@ stack-reg swap [+] ;
: %alien-indirect ( -- )
[ CALL ] alien-temp ;
-: with-aligned-stack ( n quot -- )
- #! On Linux, there is no requirement to align stack frames,
- #! so this is mostly a no-op.
- swap slip stack-reg swap ADD ; inline
-
-: compile-c-call* ( symbol dll args -- )
- dup length cells [
- <reversed> [ PUSH ] each %alien-invoke
- ] with-aligned-stack ;
-
GENERIC: push-return-reg ( reg-class -- )
GENERIC: pop-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
} define-intrinsic
! Slots
-: untag ( reg -- ) tag-mask bitnot AND ;
+: %untag ( reg -- ) tag-mask bitnot AND ;
\ slot [
- "obj" operand untag
+ "obj" operand %untag
! turn tagged fixnum slot # into an offset, multiple of 4
"n" operand fixnum>slot@
! compute slot address
"obj" operand [] card-mark OR ;
\ set-slot [
- "obj" operand untag
+ "obj" operand %untag
! turn tagged fixnum slot # into an offset
"slot" operand fixnum>slot@
! compute slot address
{ +output+ { "out" } }
} define-intrinsic
+: %untag-fixnums ( seq -- )
+ [ tag-bits SAR ] unique-operands ;
+
: simple-overflow ( word -- )
+ "end" define-label
"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.
- "end" define-label
"end" get JNO
! There was an overflow. Recompute the original operand.
- { "y" "x" } [ tag-bits SAR ] unique-operands
+ { "y" "x" } %untag-fixnums
"x" operand "y" operand rot execute
- "x" operand %allot-bignum-signed-1
- "z" operand "x" operand MOV
+ "z" operand "x" operand %allot-bignum-signed-1
"end" resolve-label ; inline
: simple-overflow-template ( word insn -- )
\ fixnum+ \ ADD simple-overflow-template
\ fixnum- \ SUB simple-overflow-template
+: %tag-overflow ( -- )
+ #! Tag a cell-size value, where the tagging might posibly
+ #! overflow.
+ "y" operand "x" operand MOV ! Make a copy
+ "x" operand 1 tag-bits shift IMUL2 ! Tag it
+ "end" get JNO ! Overflow?
+ "x" operand "y" operand %allot-bignum-signed-1 ! Yes, box bignum
+ ;
+
\ fixnum* [
- "y" operand tag-bits SAR
- "y" operand IMUL
+ "overflow-1" define-label
+ "overflow-2" define-label
"end" define-label
- "end" get JNO
- "x" operand remainder-reg %allot-bignum-signed-2
+ { "y" "x" } %untag-fixnums
+ "y" operand IMUL
+ "overflow-1" get JNO
+ "x" operand "r" operand %allot-bignum-signed-2
+ "end" get JMP
+ "overflow-1" resolve-label
+ %tag-overflow
"end" resolve-label
] H{
{ +input+ { { 0 "x" } { 1 "y" } } }
{ +output+ { "x" } }
+ { +scratch+ { { 2 "r" } } }
+ { +clobber+ { "y" } }
} define-intrinsic
: generate-fixnum/mod
"end" define-label
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 1 tag-bits shift IMUL2
- ! Did it overflow?
- "end" get JNO
- "y" operand %allot-bignum-signed-1
+ %tag-overflow
"end" resolve-label ;
\ fixnum/i [ generate-fixnum/mod ] H{
{ +input+ { { 0 "x" } { 1 "y" } } }
- { +scratch+ { { 2 "out" } } }
+ { +scratch+ { { 2 "r" } } }
{ +output+ { "x" } }
{ +clobber+ { "x" "y" } }
} define-intrinsic
\ fixnum/mod [ generate-fixnum/mod ] H{
{ +input+ { { 0 "x" } { 1 "y" } } }
- { +scratch+ { { 2 "out" } } }
- { +output+ { "x" "out" } }
+ { +scratch+ { { 2 "r" } } }
+ { +output+ { "x" "r" } }
{ +clobber+ { "x" "y" } }
} define-intrinsic