diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index f4a0218565..ab7fc65eb2 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/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 ] diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 50d5525f2d..e2c5ea08a6 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/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 ] } diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 3272015848..42df1c8437 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/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 diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 2b5cf8eb52..12eb637964 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -281,6 +281,8 @@ M: object infer-call* \ { real real } { complex } define-primitive \ make-foldable +\ both-fixnums? { object object } { object object object } define-primitive + \ fixnum+ { fixnum fixnum } { integer } define-primitive \ fixnum+ make-foldable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 84c79a340a..a4cee5c7b9 100644 --- a/core/bootstrap/primitives.factor +++ b/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" } diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 0c7bb2d8e8..0acbdac8f8 100644 --- a/core/generic/math/math.factor +++ b/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? ;