fixnum* intrinsic for x86

basis/compiler/cfg/def-use/def-use.factor

@@ -18,6 +18,8 @@ M: ##string-nth defs-vregs dst/tmp-vregs ;
 M: ##compare defs-vregs dst/tmp-vregs ;
 M: ##compare-imm defs-vregs dst/tmp-vregs ;
 M: ##compare-float defs-vregs dst/tmp-vregs ;
+M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 M: insn defs-vregs drop f ;
 
 M: ##unary uses-vregs src>> 1array ;

basis/compiler/cfg/instructions/instructions.factor

@@ -98,8 +98,8 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
 INSN: ##fixnum-add-tail < ##fixnum-overflow ;
 INSN: ##fixnum-sub < ##fixnum-overflow ;
 INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
-INSN: ##fixnum-mul < ##fixnum-overflow ;
+INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
-INSN: ##fixnum-mul-tail < ##fixnum-overflow ;
+INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
 
 : ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
 : ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -26,6 +26,7 @@ IN: compiler.cfg.intrinsics
     math.private:both-fixnums?
     math.private:fixnum+
     math.private:fixnum-
+    math.private:fixnum*
     math.private:fixnum+fast
     math.private:fixnum-fast
     math.private:fixnum-bitand
@@ -89,16 +90,13 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-double
     } [ t "intrinsic" set-word-prop ] each ;
 
-: enable-fixnum*-intrinsic ( -- )
-    \ math.private:fixnum* t "intrinsic" set-word-prop ;
-
 : emit-intrinsic ( node word -- node/f )
     {
         { \ kernel.private:tag [ drop emit-tag iterate-next ] }
         { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
         { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum* [ drop [ ##fixnum-mul ] [ ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
+        { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
         { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
         { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }

basis/compiler/codegen/codegen.factor

@@ -159,12 +159,15 @@ M: ##not     generate-insn dst/src       %not     ;
 : src1/src2 ( insn -- src1 src2 )
     [ src1>> register ] [ src2>> register ] bi ; inline
 
+: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
+    [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
+
 M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
 M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
 M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
 M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
-M: ##fixnum-mul generate-insn src1/src2 %fixnum-mul ;
+M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
-M: ##fixnum-mul-tail generate-insn src1/src2 %fixnum-mul-tail ;
+M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
 
 : dst/src/temp ( insn -- dst src temp )
     [ dst/src ] [ temp>> register ] bi ; inline

basis/cpu/architecture/architecture.factor

@@ -81,8 +81,8 @@ HOOK: %fixnum-add cpu ( src1 src2 -- )
 HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
 HOOK: %fixnum-sub cpu ( src1 src2 -- )
 HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
-HOOK: %fixnum-mul cpu ( src1 src2 -- )
+HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- )
-HOOK: %fixnum-mul-tail cpu ( src1 src2 -- )
+HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
 
 HOOK: %integer>bignum cpu ( dst src temp -- )
 HOOK: %bignum>integer cpu ( dst src temp -- )

basis/cpu/ppc/ppc.factor

@@ -187,10 +187,13 @@ M: ppc %not     NOT ;
         [ 3 src1 MR 4 src2 MR ]
     } cond ;
 
+: clear-xer ( -- )
+    0 0 LI
+    0 MTXER ; inline
+
 :: overflow-template ( src1 src2 insn func -- )
     "no-overflow" define-label
-    0 0 LI
+    clear-xer
-    0 MTXER
     scratch-reg src2 src1 insn call
     scratch-reg ds-reg 0 STW
     "no-overflow" get BNO
@@ -201,8 +204,7 @@ M: ppc %not     NOT ;
 
 :: overflow-template-tail ( src1 src2 insn func -- )
     "overflow" define-label
-    0 0 LI
+    clear-xer
-    0 MTXER
     scratch-reg src2 src1 insn call
     "overflow" get BO
     scratch-reg ds-reg 0 STW
@@ -224,32 +226,30 @@ M: ppc %fixnum-sub ( src1 src2 -- )
 M: ppc %fixnum-sub-tail ( src1 src2 -- )
     [ SUBFO. ] "overflow_fixnum_subtract" overflow-template-tail ;
 
-M:: ppc %fixnum-mul ( src1 src2 -- )
+M:: ppc %fixnum-mul ( src1 src2 temp1 temp2 -- )
     "no-overflow" define-label
-    0 0 LI
+    clear-xer
-    0 MTXER
+    temp1 src1 tag-bits get SRAWI
-    scratch-reg src1 tag-bits get SRAWI
+    temp2 temp1 src2 MULLWO.
-    scratch-reg scratch-reg src2 MULLWO.
+    temp2 ds-reg 0 STW
-    scratch-reg ds-reg 0 STW
     "no-overflow" get BNO
     src2 src2 tag-bits get SRAWI
-    scratch-reg src2 move>args
+    temp1 src2 move>args
     %prepare-alien-invoke
     "overflow_fixnum_multiply" f %alien-invoke
     "no-overflow" resolve-label ;
 
-M:: ppc %fixnum-mul-tail ( src1 src2 -- )
+M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
     "overflow" define-label
-    0 0 LI
+    clear-xer
-    0 MTXER
+    temp1 src1 tag-bits get SRAWI
-    scratch-reg src1 tag-bits get SRAWI
+    temp2 temp1 src2 MULLWO.
-    scratch-reg scratch-reg src2 MULLWO.
     "overflow" get BO
-    scratch-reg ds-reg 0 STW
+    temp2 ds-reg 0 STW
     BLR
     "overflow" resolve-label
     src2 src2 tag-bits get SRAWI
-    scratch-reg src2 move>args
+    temp1 src2 move>args
     %prepare-alien-invoke
     "overflow_fixnum_multiply" f %alien-invoke-tail ;
 

basis/cpu/x86/x86.factor

@@ -145,6 +145,35 @@ M: x86 %fixnum-sub ( src1 src2 -- )
 M: x86 %fixnum-sub-tail ( src1 src2 -- )
     [ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
 
+M:: x86 %fixnum-mul ( src1 src2 temp1 temp2 -- )
+    "no-overflow" define-label
+    temp1 src1 MOV
+    temp1 tag-bits get SAR
+    src2 temp1 IMUL2
+    ds-reg [] temp1 MOV
+    "no-overflow" get JNO
+    src1 src2 move>args
+    param-reg-1 tag-bits get SAR
+    param-reg-2 tag-bits get SAR
+    %prepare-alien-invoke
+    "overflow_fixnum_multiply" f %alien-invoke
+    "no-overflow" resolve-label ;
+
+M:: x86 %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
+    "overflow" define-label
+    temp1 src1 MOV
+    temp1 tag-bits get SAR
+    src2 temp1 IMUL2
+    "overflow" get JO
+    ds-reg [] temp1 MOV
+    0 RET
+    "overflow" resolve-label
+    src1 src2 move>args
+    param-reg-1 tag-bits get SAR
+    param-reg-2 tag-bits get SAR
+    %prepare-alien-invoke
+    "overflow_fixnum_multiply" f %alien-invoke-tail ;
+
 : bignum@ ( reg n -- op )
     cells bignum tag-number - [+] ; inline