diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 7e97961eb3..3825ae480e 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 9e82851c12..62d4990c92 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/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-tail < ##fixnum-overflow ; +INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ; +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 diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 6c6c2955c9..aaa45c3937 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/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 ] } diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index b66b6a11c7..f0b8279cb4 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/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-tail generate-insn src1/src2 %fixnum-mul-tail ; +M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ; +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 diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 2fdad0132a..12b6809df9 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/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-tail cpu ( src1 src2 -- ) +HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- ) +HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- ) HOOK: %integer>bignum cpu ( dst src temp -- ) HOOK: %bignum>integer cpu ( dst src temp -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 244be1cfa3..4ccfd2ee7b 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/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 - 0 MTXER + clear-xer 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 - 0 MTXER + clear-xer 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 - 0 MTXER - scratch-reg src1 tag-bits get SRAWI - scratch-reg scratch-reg src2 MULLWO. - scratch-reg ds-reg 0 STW + clear-xer + temp1 src1 tag-bits get SRAWI + temp2 temp1 src2 MULLWO. + temp2 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 - 0 MTXER - scratch-reg src1 tag-bits get SRAWI - scratch-reg scratch-reg src2 MULLWO. + clear-xer + temp1 src1 tag-bits get SRAWI + temp2 temp1 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 ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 104a1f155b..b7dffb849e 100644 --- a/basis/cpu/x86/x86.factor +++ b/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 diff --git a/misc/factor.el b/misc/factor.el index f81b1e8f88..5f56072c1d 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -189,7 +189,7 @@ buffer." "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" "TUPLE:" "T{" "t\\??" "TYPEDEF:" - "UNION:" "USE:" "USING:" "V{" "VAR:" "VARS:" "W{")) + "UNION:" "USE:" "USING:" "V{" "VARS:" "W{")) (defconst factor--regex-parsing-words-ext (regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only") @@ -204,11 +204,14 @@ buffer." (defsubst factor--regex-second-word (prefixes) (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t))) +(defconst factor--regex-method-definition + "^M: +\\([^ ]+\\) +\\([^ ]+\\)") + (defconst factor--regex-word-definition - (factor--regex-second-word '(":" "::" "M:" "GENERIC:"))) + (factor--regex-second-word '(":" "::" "GENERIC:"))) (defconst factor--regex-type-definition - (factor--regex-second-word '("TUPLE:"))) + (factor--regex-second-word '("TUPLE:" "SINGLETON:"))) (defconst factor--regex-parent-type "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)") @@ -217,7 +220,7 @@ buffer." (defconst factor--regex-setter "\\W>>[^ ]+\\b") (defconst factor--regex-symbol-definition - (factor--regex-second-word '("SYMBOL:"))) + (factor--regex-second-word '("SYMBOL:" "VAR:"))) (defconst factor--regex-stack-effect " ( .* )") @@ -235,11 +238,12 @@ buffer." (,factor--regex-declaration-words 1 'factor-font-lock-declaration) (,factor--regex-word-definition 2 'factor-font-lock-word-definition) (,factor--regex-type-definition 2 'factor-font-lock-type-definition) + (,factor--regex-method-definition (1 'factor-font-lock-type-definition) + (2 'factor-font-lock-word-definition)) (,factor--regex-parent-type 1 'factor-font-lock-type-definition) (,factor--regex-constructor . 'factor-font-lock-constructor) (,factor--regex-setter . 'factor-font-lock-setter-word) (,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition) - (,factor--regex-using-lines 1 'factor-font-lock-vocabulary-name) (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name)) "Font lock keywords definition for Factor mode.") @@ -247,7 +251,7 @@ buffer." ;;; Factor mode syntax: (defconst factor--regex-definition-starters - (regexp-opt '("TUPLE" "MACRO" "MACRO:" "M" ":" ""))) + (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" ""))) (defconst factor--regex-definition-start (format "^\\(%s:\\) " factor--regex-definition-starters)) @@ -373,7 +377,8 @@ buffer." (defconst factor--regex-single-liner (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" - "PRIVATE>" "" "