{ "bits>double" "math" }
{ "<complex>" "math-internals" }
{ "fixnum+" "math-internals" }
+ { "fixnum+fast" "math-internals" }
{ "fixnum-" "math-internals" }
+ { "fixnum-fast" "math-internals" }
{ "fixnum*" "math-internals" }
{ "fixnum/i" "math-internals" }
{ "fixnum/f" "math-internals" }
HELP: collect "( n quot -- array )"
{ $values { "n" "a non-negative integer" } { "quot" "a quotation with stack effect " { $snippet "( n -- value )" } } { "array" "an array with " { $snippet "n" } " elements" } }
-{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. Client code should use " { $snippet map } " instead." } ;
+{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. Client code should use " { $link map } " instead." } ;
HELP: each "( seq quot -- )"
{ $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
\ slot [
H{
- { +input-d { { f "obj" } { f "n" } } }
- { +output-d { "obj" } }
+ { +input { { f "obj" } { f "n" } } }
+ { +output { "obj" } }
} [
"obj" get %untag ,
"n" get "obj" get %slot ,
\ set-slot [
H{
- { +input-d { { f "val" } { f "obj" } { f "slot" } } }
+ { +input { { f "val" } { f "obj" } { f "slot" } } }
{ +clobber { "obj" } }
} [
"obj" get %untag ,
\ char-slot [
H{
- { +input-d { { f "n" } { f "str" } } }
- { +output-d { "str" } }
+ { +input { { f "n" } { f "str" } } }
+ { +output { "str" } }
} [
"n" get "str" get %char-slot ,
] with-template
\ set-char-slot [
H{
- { +input-d { { f "ch" } { f "n" } { f "str" } } }
+ { +input { { f "ch" } { f "n" } { f "str" } } }
} [
"ch" get "str" get "n" get %set-char-slot ,
] with-template
\ type [
H{
- { +input-d { { f "in" } } }
- { +output-d { "in" } }
+ { +input { { f "in" } } }
+ { +output { "in" } }
} [ finalize-contents "in" get %type , ] with-template
] "intrinsic" set-word-prop
\ tag [
H{
- { +input-d { { f "in" } } }
- { +output-d { "in" } }
+ { +input { { f "in" } } }
+ { +output { "in" } }
} [ "in" get %tag , ] with-template
] "intrinsic" set-word-prop
: binary-op ( op -- )
H{
- { +input-d { { 0 "x" } { 1 "y" } } }
- { +output-d { "x" } }
+ { +input { { 0 "x" } { 1 "y" } } }
+ { +output { "x" } }
} [
finalize-contents >r "y" get "x" get dup r> execute ,
] with-template ; inline
{
{ fixnum+ %fixnum+ }
{ fixnum- %fixnum- }
- { fixnum-bitand %fixnum-bitand }
- { fixnum-bitor %fixnum-bitor }
- { fixnum-bitxor %fixnum-bitxor }
{ fixnum/i %fixnum/i }
{ fixnum* %fixnum* }
} [
"intrinsic" set-word-prop
] each
+: binary-op-fast ( op -- )
+ H{
+ { +input { { f "x" } { f "y" } } }
+ { +output { "x" } }
+ } [
+ >r "y" get "x" get dup r> execute ,
+ ] with-template ; inline
+
+{
+ { fixnum-bitand %fixnum-bitand }
+ { fixnum-bitor %fixnum-bitor }
+ { fixnum-bitxor %fixnum-bitxor }
+ { fixnum+fast %fixnum+fast }
+ { fixnum-fast %fixnum-fast }
+} [
+ first2 [ binary-op-fast ] curry
+ "intrinsic" set-word-prop
+] each
+
: binary-jump ( label op -- )
H{
- { +input-d { { f "x" } { f "y" } } }
+ { +input { { f "x" } { f "y" } } }
} [
end-basic-block >r >r "y" get "x" get r> r> execute ,
] with-template ; inline
! hard-coded to put its output in vreg 2, which happends to
! be EDX there.
H{
- { +input-d { { 0 "x" } { 1 "y" } } }
- { +output-d { "out" } }
+ { +input { { 0 "x" } { 1 "y" } } }
+ { +output { "out" } }
} [
finalize-contents
T{ vreg f 2 } "out" set
\ fixnum/mod [
! See the remark on fixnum-mod for vreg usage
H{
- { +input-d { { 0 "x" } { 1 "y" } } }
- { +output-d { "quo" "rem" } }
+ { +input { { 0 "x" } { 1 "y" } } }
+ { +output { "quo" "rem" } }
} [
finalize-contents
T{ vreg f 0 } "quo" set
\ fixnum-bitnot [
H{
- { +input-d { { f "x" } } }
- { +output-d { "x" } }
+ { +input { { f "x" } } }
+ { +output { "x" } }
} [ "x" get dup %fixnum-bitnot , ] with-template
] "intrinsic" set-word-prop
M: #if linearize* ( node -- next )
H{
- { +input-d { { 0 "flag" } } }
+ { +input { { 0 "flag" } } }
} [
end-basic-block
<label> dup "flag" get %jump-t ,
#! Output the jump table insn and return a list of
#! label/branch pairs.
H{
- { +input-d { { 0 "n" } } }
+ { +input { { 0 "n" } } }
} [ end-basic-block "n" get %dispatch , ] with-template
node-children [ <label> dup %target-label , 2array ] map ;
M: %fixnum+ generate-node ( vop -- )
drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
+M: %fixnum+fast generate-node ( vop -- ) drop >3-vop< ADD ;
+
+M: %fixnum-fast generate-node ( vop -- ) drop >3-vop< SUBF ;
+
M: %fixnum- generate-node ( vop -- )
drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
USING: arrays generic inference io kernel math
namespaces prettyprint sequences vectors words ;
+: immediate? ( obj -- ? ) dup fixnum? swap not or ;
+
+: load-literal ( obj dest -- )
+ over immediate? [ %immediate ] [ %indirect ] if , ;
+
: phantom-shuffle-input ( n phantom -- seq )
2dup length <= [
cut-phantom
node-shuffle phantom-shuffle iterate-next ;
: linearize-push ( node -- )
- compute-free-vregs
>#push< dup length dup ensure-vregs
alloc-reg# [ <vreg> ] map
[ [ load-literal ] 2each ] keep
GENERIC: <loc> ( n stack -- loc )
-: (loc) phantom-stack-height - ;
+: (loc)
+ #! Utility for methods on <loc>
+ phantom-stack-height - ;
: (finalize-height) ( stack word -- )
+ #! We consolidate multiple stack height changes until the
+ #! last moment, and we emit the final height changing
+ #! instruction here.
swap [
phantom-stack-height
dup zero? [ 2drop ] [ swap execute , ] if
\ %inc-r (finalize-height) ;
: phantom-locs ( n phantom -- locs )
+ #! A sequence of n ds-locs or cs-locs indexing the stack.
swap reverse-slice [ swap <loc> ] map-with ;
: phantom-locs* ( phantom -- locs )
dup length swap phantom-locs ;
: adjust-phantom ( n phantom -- )
+ #! Change stack heiht.
[ phantom-stack-height + ] keep set-phantom-stack-height ;
GENERIC: cut-phantom ( n phantom -- seq )
<phantom-datastack> phantom-d set
<phantom-callstack> phantom-r set ;
-: immediate? ( obj -- ? )
- #! fixnums and f have a pointerless representation, and
- #! are compiled immediately. Everything else can be moved
- #! by GC, and is indexed through a table.
- dup fixnum? swap f eq? or ;
-
-: load-literal ( obj dest -- )
- over immediate? [ %immediate ] [ %indirect ] if , ;
-
: finalize-heights ( -- )
phantom-d get finalize-height
phantom-r get finalize-height ;
[ reverse-slice ] 2apply
t [ swap first compatible-values? and ] 2reduce ;
-: templates-match? ( template template -- ? )
- phantom-r get template-match?
- >r phantom-d get template-match? r> and ;
-
: split-template ( template phantom -- slow fast )
over length over length <=
[ drop { } swap ] [ length swap cut* ] if ;
-: split-templates ( template template -- slow slow fast fast )
- >r phantom-d get split-template r>
- phantom-r get split-template swapd ;
+: match-template ( template -- slow fast )
+ phantom-d get 2dup template-match?
+ [ split-template ] [ drop { } ] if ;
-: match-templates ( template template -- slow slow fast fast )
- 2dup templates-match? [ split-templates ] [ { } { } ] if ;
-
-: (fast-input) ( template phantom -- )
+: fast-input ( template -- )
+ phantom-d get
over length neg over adjust-phantom
over length swap cut-phantom
swap phantom-vregs ;
-: fast-input ( template template -- )
- phantoms swapd (fast-input) (fast-input) ;
-
-: (slow-input) ( template phantom -- )
- swap [ stack>vregs ] keep phantom-vregs ;
-
: phantom-append ( seq stack -- )
over length over adjust-phantom swap nappend ;
: (template-outputs) ( seq stack -- )
- phantoms swapd phantom-append phantom-append ;
+ phantoms swapd phantom-append phantom-append
+ compute-free-vregs ;
-SYMBOL: +input-d
-SYMBOL: +input-r
-SYMBOL: +output-d
-SYMBOL: +output-r
+SYMBOL: +input
+SYMBOL: +output
SYMBOL: +scratch
SYMBOL: +clobber
: fix-spec ( spec -- spec )
H{
- { +input-d { } }
- { +input-r { } }
- { +output-d { } }
- { +output-r { } }
+ { +input { } }
+ { +output { } }
{ +scratch { } }
{ +clobber { } }
} swap hash-union ;
: adjust-free-vregs ( -- )
used-vregs free-vregs [ diff ] change ;
-: output-vregs ( -- seq )
- { +output-d +output-r +clobber }
- [ get [ get ] map ] map concat ;
+: output-vregs ( -- seq seq )
+ +output get +clobber get [ [ get ] map ] 2apply ;
-: finalize-contents? ( -- ? )
- output-vregs phantoms append
+: outputs-clash? ( -- ? )
+ output-vregs append phantoms append
[ swap member? ] contains-with? ;
-: slow-input ( template template -- )
- 2dup [ empty? not ] 2apply or finalize-contents? or
+: finalize-carefully ( -- )
+ #! If the phantom callstack has datastack locations on it,
+ #! we cannot rearrange the datastack and expect meaningful
+ #! results.
+ phantom-r get [ ds-loc? ] contains? [
+ finalize-contents
+ ] [
+ phantom-d get dup { } flush-locs vregs>stack
+ ] if ;
+
+: slow-input ( template -- )
+ dup empty?
+ [ finalize-carefully ] unless
+ outputs-clash?
[ finalize-contents ] when
- phantoms swapd (slow-input) (slow-input) ;
+ phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
: template-inputs ( -- )
- +input-d get +input-r get
- 2dup additional-vregs# ensure-vregs
- match-templates fast-input
- adjust-free-vregs
- slow-input ;
+ +input get dup { } additional-vregs# ensure-vregs
+ match-template fast-input adjust-free-vregs slow-input ;
: template-outputs ( -- )
- +output-d get +output-r get [ [ get ] map ] 2apply
- (template-outputs) ;
+ +output get [ get ] map { } (template-outputs) ;
: with-template ( spec quot -- )
- swap fix-spec [
- template-inputs call template-outputs
- ] bind ; inline
+ swap fix-spec
+ [ template-inputs call template-outputs ] bind
+ compute-free-vregs ; inline
! fixnum intrinsics
TUPLE: %fixnum+ ;
C: %fixnum+ make-vop ; : %fixnum+ 3-vop <%fixnum+> ;
+TUPLE: %fixnum+fast ;
+C: %fixnum+fast make-vop ; : %fixnum+fast 3-vop <%fixnum+fast> ;
TUPLE: %fixnum- ;
C: %fixnum- make-vop ; : %fixnum- 3-vop <%fixnum-> ;
+TUPLE: %fixnum-fast ;
+C: %fixnum-fast make-vop ; : %fixnum-fast 3-vop <%fixnum-fast> ;
TUPLE: %fixnum* ;
C: %fixnum* make-vop ; : %fixnum* 3-vop <%fixnum*> ;
TUPLE: %fixnum-mod ;
M: %fixnum+ generate-node ( vop -- )
drop dest/src ADD \ SUB \ ADD simple-overflow ;
+M: %fixnum+fast generate-node ( vop -- ) drop dest/src ADD ;
+
M: %fixnum- generate-node ( vop -- )
drop dest/src SUB \ ADD \ SUB simple-overflow ;
+M: %fixnum-fast generate-node ( vop -- ) drop dest/src SUB ;
+
M: %fixnum* generate-node ( vop -- )
drop
! both inputs are tagged, so one of them needs to have its
\ fixnum+ t "flushable" set-word-prop
\ fixnum+ t "foldable" set-word-prop
+\ fixnum+fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum+fast t "flushable" set-word-prop
+\ fixnum+fast t "foldable" set-word-prop
+
\ fixnum- [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum- t "flushable" set-word-prop
\ fixnum- t "foldable" set-word-prop
+\ fixnum-fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-fast t "flushable" set-word-prop
+\ fixnum-fast t "foldable" set-word-prop
+
\ fixnum* [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
\ fixnum* t "flushable" set-word-prop
\ fixnum* t "foldable" set-word-prop
optimizer-changed get
] with-node-iterator [ optimize ] when ;
+: prune-if ( node quot -- successor/t )
+ over >r call [ r> node-successor ] [ r> drop t ] if ;
+ inline
+
! Generic nodes
M: f optimize-node* drop t ;
M: node optimize-node* ( node -- t ) drop t ;
+! #shuffle
+M: #shuffle optimize-node* ( node -- node/t )
+ [ node-values empty? ] prune-if ;
+
! #push
M: #push optimize-node* ( node -- node/t )
- dup node-out-d empty? [ node-successor ] [ drop t ] if ;
+ [ node-out-d empty? ] prune-if ;
! #return
M: #return optimize-node* ( node -- node/t )
! These words are unsafe. Don't use them.
: array-capacity 1 slot ; inline
-: array-nth swap 2 fixnum+ slot ; inline
-: set-array-nth swap 2 fixnum+ set-slot ; inline
+: array-nth swap 2 fixnum+fast slot ; inline
+: set-array-nth swap 2 fixnum+fast set-slot ; inline
: make-tuple <tuple> [ 2 set-slot ] keep ; flushable
IN: temporary
-USING: compiler kernel math sequences test ;
+USING: compiler kernel math math-internals sequences test ;
+
+: empty-loop-0 ( n -- )
+ dup 0 fixnum< [ drop ] [ 1 fixnum-fast empty-loop-0 ] if ;
+ compiled
: empty-loop-1 ( n -- )
[ ] times ; compiled
: empty-loop-3 ( n -- )
[ drop ] each ; compiled
+[ ] [ 5000000 empty-loop-0 ] unit-test
[ ] [ 5000000 empty-loop-1 ] unit-test
[ ] [ 5000000 empty-loop-2 ] unit-test
[ ] [ 5000000 empty-loop-3 ] unit-test
USE: math-internals
USE: namespaces
-! Four fibonacci implementations, each one slower than the
+! Five fibonacci implementations, each one slower than the
! previous.
+: fast-fixnum-fib ( n -- nth fibonacci number )
+ dup 1 fixnum<= [
+ drop 1
+ ] [
+ 1 fixnum-fast dup fast-fixnum-fib
+ swap 1 fixnum-fast fast-fixnum-fib fixnum+fast
+ ] if ;
+ compiled
+
+[ 9227465 ] [ 34 fast-fixnum-fib ] unit-test
+
: fixnum-fib ( n -- nth fibonacci number )
dup 1 fixnum<= [
drop 1
IN: temporary
USING: arrays compiler kernel kernel-internals math
-math-internals namespaces test ;
+math-internals namespaces sequences sequences-internals test ;
! Oops!
[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
[ 1/2 [ dup 0 slot swap 1 slot [ foo ] keep ] compile-1 ]
unit-test
+[ 41 5 4 ] [
+ 5/4 4/5 [
+ dup ratio? [
+ over ratio? [
+ 2dup 2>fraction >r * swap r> * swap
+ + -rot denominator swap denominator
+ ] [
+ 2drop f f f
+ ] if
+ ] [
+ 2drop f f f
+ ] if
+ ] compile-1
+] unit-test
+
: jxyz
over bignum? [
dup ratio? [
global [ 3 \ foo set ] bind
\ foo [ global [ get ] bind ] compile-1
] unit-test
+
+[ 12 13 ] [
+ -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-1
+] unit-test
+
+[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-1 ] unit-test
+
+[ 12 13 ] [
+ -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-1
+] unit-test
+
+[ { t t } ] [
+ { t } { t } [
+ dup array-capacity [
+ 2dup swap swap 2 fixnum+fast slot
+ >r pick swap 2 fixnum+fast slot r> 2array
+ ] collect 2nip
+ ] compile-1 first
+] unit-test
+
+[ { t t } ] [
+ { t } { t } [
+ dup array-capacity [
+ 2dup swap swap 2 fixnum+ slot
+ >r pick swap 2 fixnum+ slot r> 2array
+ ] collect 2nip
+ ] compile-1 first
+] unit-test
[ t ] [ [ [ ] [ ] if ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
-[
- T{ shuffle f { "a" } { } { "a" } { "a" } }
-] [
- T{ shuffle f { "a" } { } { "a" "a" } { } }
- T{ shuffle f { "b" } { } { } { "b" } }
- compose-shuffle
-] unit-test
-
-[
- T{ shuffle f { "b" "a" } { } { "b" "b" } { } }
-] [
- T{ shuffle f { "a" } { } { } { } }
- T{ shuffle f { "b" } { } { "b" "b" } { } }
- compose-shuffle
-] unit-test
-
[ { 0 2 } ] [ [ 2 "Hello" ] infer ] unit-test
[ { 1 2 } ] [ [ dup ] infer ] unit-test
box_signed_cell(x + y);
}
+void primitive_fixnum_add_fast(void)
+{
+ F_FIXNUM y = untag_fixnum_fast(dpop());
+ F_FIXNUM x = untag_fixnum_fast(dpop());
+ dpush(tag_fixnum(x + y));
+}
+
void primitive_fixnum_subtract(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
box_signed_cell(x - y);
}
+void primitive_fixnum_subtract_fast(void)
+{
+ F_FIXNUM y = untag_fixnum_fast(dpop());
+ F_FIXNUM x = untag_fixnum_fast(dpop());
+ dpush(tag_fixnum(x - y));
+}
+
/**
* Multiply two integers, and trap overflow.
* Thanks to David Blaikie (The_Vulture from freenode #java) for the hint.
void primitive_fixnum_add(void);
void primitive_fixnum_subtract(void);
+void primitive_fixnum_add_fast(void);
+void primitive_fixnum_subtract_fast(void);
void primitive_fixnum_multiply(void);
void primitive_fixnum_divint(void);
void primitive_fixnum_divfloat(void);
primitive_bits_double,
primitive_from_rect,
primitive_fixnum_add,
+ primitive_fixnum_add_fast,
primitive_fixnum_subtract,
+ primitive_fixnum_subtract_fast,
primitive_fixnum_multiply,
primitive_fixnum_divint,
primitive_fixnum_divfloat,
CELL primitive_to_xt(CELL primitive)
{
- if(primitive < 0 || primitive >= PRIMITIVE_COUNT)
- return (CELL)undefined;
- else
- return (CELL)primitives[primitive];
+ return (CELL)primitives[primitive];
}
extern void* primitives[];
-#define PRIMITIVE_COUNT 190
CELL primitive_to_xt(CELL primitive);
projects / factor.git / commitdiff