Merge branch 'master' of git://factorcode.org/git/factor
commit
ff000f3e82
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ] }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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>" "<PRIVATE" "SYMBOL:" "USE:"))))
|
||||
"PRIVATE>" "<PRIVATE"
|
||||
"SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
|
||||
|
||||
(defconst factor--regex-begin-of-def
|
||||
(format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
|
||||
|
@ -485,7 +490,7 @@ buffer."
|
|||
(defvar factor-mode-map (make-sparse-keymap)
|
||||
"Key map used by Factor mode.")
|
||||
|
||||
(defsubst factor--beginning-of-defun (times)
|
||||
(defsubst factor--beginning-of-defun (&optional times)
|
||||
(re-search-backward factor--regex-begin-of-def nil t times))
|
||||
|
||||
(defsubst factor--end-of-defun ()
|
||||
|
|
Loading…
Reference in New Issue