Debugging x86 inline allocators

TODO.FACTOR.txt

@@ -9,7 +9,8 @@
 - 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:
 

library/compiler/amd64/architecture.factor

@@ -13,8 +13,7 @@ math namespaces sequences ;
 
 : 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 ;
@@ -35,10 +34,6 @@ M: float-regs fastcall-regs vregs ;
 : 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

library/compiler/optimizer/call-optimizers.factor

@@ -58,18 +58,6 @@ math math-internals sequences words parser ;
     { [ 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= ;

library/compiler/pentium4/intrinsics.factor

@@ -9,8 +9,7 @@ M: float-regs (%peek)
     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 -- )

library/compiler/x86/allot.factor

@@ -5,54 +5,66 @@ USING: kernel assembler kernel-internals namespaces math ;
 
 : 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 ;
 
@@ -62,10 +74,11 @@ M: float-regs (%replace)
     #! 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 ;

library/compiler/x86/architecture.factor

@@ -16,8 +16,7 @@ IN: compiler
 
 : 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 [+] ;
 
@@ -39,16 +38,6 @@ M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
 : %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 -- )

library/compiler/x86/intrinsics.factor

@@ -50,10 +50,10 @@ IN: compiler
 } 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
@@ -73,7 +73,7 @@ IN: compiler
     "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
@@ -153,18 +153,20 @@ IN: compiler
     { +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 -- )
@@ -178,16 +180,32 @@ IN: compiler
 \ 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
@@ -197,27 +215,20 @@ IN: compiler
     "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