Faster generic arithmetic on fiixnums: both-fixnums? sub-primitive performs a check if the top two stack items are both fixnums with a single conditional branch

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -7,9 +7,18 @@ compiler.cfg.hats
 compiler.cfg.stacks
 compiler.cfg.iterator
 compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities
+compiler.cfg.registers ;
 IN: compiler.cfg.intrinsics.fixnum
 
+: emit-both-fixnums? ( -- )
+    D 0 ^^peek
+    D 1 ^^peek
+    ^^or
+    tag-mask get ^^and-imm
+    0 cc= ^^compare-imm
+    ds-push ;
+
 : (emit-fixnum-imm-op) ( infos insn -- dst )
     ds-drop
     [ ds-pop ]

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -23,6 +23,7 @@ IN: compiler.cfg.intrinsics
 
 {
     kernel.private:tag
+    math.private:both-fixnums?
     math.private:fixnum+
     math.private:fixnum-
     math.private:fixnum+fast
@@ -91,6 +92,7 @@ IN: compiler.cfg.intrinsics
 : 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 ] }

basis/cpu/x86/bootstrap.factor

@@ -379,6 +379,17 @@ big-endian off
     ds-reg bootstrap-cell neg [+] div-arg MOV
 ] f f f \ fixnum/mod-fast define-sub-primitive
 
+[
+    arg0 ds-reg [] MOV
+    arg0 ds-reg bootstrap-cell neg [+] OR
+    ds-reg bootstrap-cell ADD
+    arg0 tag-mask get AND
+    arg0 \ f tag-number MOV
+    arg1 1 tag-fixnum MOV
+    arg0 arg1 CMOVE
+    ds-reg [] arg0 MOV
+] f f f \ both-fixnums? define-sub-primitive
+
 [
     arg0 ds-reg [] MOV                         ! load local number
     fixnum>slot@                               ! turn local number into offset

basis/stack-checker/known-words/known-words.factor

@@ -281,6 +281,8 @@ M: object infer-call*
 \ <complex> { real real } { complex } define-primitive
 \ <complex> make-foldable
 
+\ both-fixnums? { object object } { object object object } define-primitive
+
 \ fixnum+ { fixnum fixnum } { integer } define-primitive
 \ fixnum+ make-foldable
 

core/bootstrap/primitives.factor

@@ -348,6 +348,7 @@ tuple
 {
     { "(execute)" "words.private" }
     { "(call)" "kernel.private" }
+    { "both-fixnums?" "math.private" }
     { "fixnum+fast" "math.private" }
     { "fixnum-fast" "math.private" }
     { "fixnum*fast" "math.private" }

core/generic/math/math.factor

@@ -56,9 +56,11 @@ ERROR: no-math-method left right generic ;
 
 : math-method ( word class1 class2 -- quot )
     2dup and [
-        2dup math-upgrade
-        [ math-class-max over order min-class applicable-method ] dip
-        prepend
+        [
+            2dup 2array , \ declare ,
+            2dup math-upgrade %
+            math-class-max over order min-class applicable-method %
+        ] [ ] make
     ] [
         2drop object-method
     ] if ;
@@ -67,13 +69,9 @@ SYMBOL: picker
 
 : math-vtable ( picker quot -- quot )
     [
-        swap picker set
-        picker get , [ tag 0 eq? ] %
-        num-tags get swap [ bootstrap-type>class ] prepose map
-        unclip ,
-        [
-            picker get , [ tag 1 fixnum-fast ] % , \ dispatch ,
-        ] [ ] make , \ if ,
+        [ , \ tag , ]
+        [ num-tags get swap [ bootstrap-type>class ] prepose map , ] bi*
+        \ dispatch ,
     ] [ ] make ; inline
 
 TUPLE: math-combination ;
@@ -84,13 +82,18 @@ M: math-combination make-default-method
 M: math-combination perform-combination
     drop
     dup
-    \ over [
-        dup math-class? [
-            \ dup [ [ 2dup ] dip math-method ] math-vtable
-        ] [
-            over object-method
-        ] if nip
-    ] math-vtable nip define ;
+    [
+        \ both-fixnums? ,
+        dup fixnum bootstrap-word dup math-method ,
+        \ over [
+            dup math-class? [
+                \ dup [ [ 2dup ] dip math-method ] math-vtable
+            ] [
+                over object-method
+            ] if nip
+        ] math-vtable nip ,
+        \ if ,
+    ] [ ] make define ;
 
 PREDICATE: math-generic < generic ( word -- ? )
     "combination" word-prop math-combination? ;