Merge branch 'master' of git://factorcode.org/git/factor
Sascha Matzke
commit
d3df9b7718
|
|
@ -184,4 +184,10 @@ IN: compiler.cfg.builder.tests
|
|||
[ f ] [
|
||||
[ 1000 [ ] times ]
|
||||
[ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
|
||||
] unit-test
|
||||
|
||||
[ f t ] [
|
||||
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
|
||||
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
|
||||
[ [ ##slot-imm? ] contains-insn? ] bi
|
||||
] unit-test
|
||||
|
|
@ -35,6 +35,8 @@ IN: compiler.cfg.hats
|
|||
: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
|
||||
: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
|
||||
: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
|
||||
: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline
|
||||
: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline
|
||||
: ^^not ( src -- dst ) ^^r1 ##not ; inline
|
||||
: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
|
||||
: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
|
||||
|
|
@ -43,6 +45,8 @@ IN: compiler.cfg.hats
|
|||
: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
|
||||
: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
|
||||
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
|
||||
: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
|
||||
: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
|
||||
: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
|
||||
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
|
||||
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
|
||||
|
|
@ -51,7 +55,8 @@ IN: compiler.cfg.hats
|
|||
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
|
||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
|
||||
: ^^box-displaced-alien ( base displacement -- dst ) ^^r2 next-vreg ##box-displaced-alien ; inline
|
||||
: ^^box-displaced-alien ( base displacement base-class -- dst )
|
||||
^^r3 [ next-vreg ] dip ##box-displaced-alien ; inline
|
||||
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
|
||||
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
|
||||
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
|
||||
|
|
|
|||
|
|
@ -91,6 +91,8 @@ INSN: ##shr < ##binary ;
|
|||
INSN: ##shr-imm < ##binary-imm ;
|
||||
INSN: ##sar < ##binary ;
|
||||
INSN: ##sar-imm < ##binary-imm ;
|
||||
INSN: ##min < ##binary ;
|
||||
INSN: ##max < ##binary ;
|
||||
INSN: ##not < ##unary ;
|
||||
INSN: ##log2 < ##unary ;
|
||||
|
||||
|
|
@ -106,6 +108,8 @@ INSN: ##add-float < ##commutative ;
|
|||
INSN: ##sub-float < ##binary ;
|
||||
INSN: ##mul-float < ##commutative ;
|
||||
INSN: ##div-float < ##binary ;
|
||||
INSN: ##min-float < ##binary ;
|
||||
INSN: ##max-float < ##binary ;
|
||||
INSN: ##sqrt < ##unary ;
|
||||
|
||||
! Float/integer conversion
|
||||
|
|
@ -118,7 +122,7 @@ INSN: ##unbox-float < ##unary ;
|
|||
INSN: ##unbox-any-c-ptr < ##unary/temp ;
|
||||
INSN: ##box-float < ##unary/temp ;
|
||||
INSN: ##box-alien < ##unary/temp ;
|
||||
INSN: ##box-displaced-alien < ##binary temp ;
|
||||
INSN: ##box-displaced-alien < ##binary temp base-class ;
|
||||
|
||||
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
|
||||
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
|
||||
|
|
@ -263,6 +267,8 @@ UNION: output-float-insn
|
|||
##sub-float
|
||||
##mul-float
|
||||
##div-float
|
||||
##min-float
|
||||
##max-float
|
||||
##sqrt
|
||||
##integer>float
|
||||
##unbox-float
|
||||
|
|
@ -275,6 +281,8 @@ UNION: input-float-insn
|
|||
##sub-float
|
||||
##mul-float
|
||||
##div-float
|
||||
##min-float
|
||||
##max-float
|
||||
##sqrt
|
||||
##float>integer
|
||||
##box-float
|
||||
|
|
|
|||
|
|
@ -14,10 +14,11 @@ IN: compiler.cfg.intrinsics.alien
|
|||
} 1&& ;
|
||||
|
||||
: emit-<displaced-alien> ( node -- )
|
||||
dup emit-<displaced-alien>?
|
||||
[ drop 2inputs [ ^^untag-fixnum ] dip ^^box-displaced-alien ds-push ]
|
||||
[ emit-primitive ]
|
||||
if ;
|
||||
dup emit-<displaced-alien>? [
|
||||
[ 2inputs [ ^^untag-fixnum ] dip ] dip
|
||||
node-input-infos second class>>
|
||||
^^box-displaced-alien ds-push
|
||||
] [ emit-primitive ] if ;
|
||||
|
||||
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
|
||||
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
|
||||
|
|
|
|||
|
|
@ -21,9 +21,13 @@ QUALIFIED: strings.private
|
|||
QUALIFIED: classes.tuple.private
|
||||
QUALIFIED: math.private
|
||||
QUALIFIED: math.integers.private
|
||||
QUALIFIED: math.floats.private
|
||||
QUALIFIED: math.libm
|
||||
IN: compiler.cfg.intrinsics
|
||||
|
||||
: enable-intrinsics ( words -- )
|
||||
[ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
{
|
||||
kernel.private:tag
|
||||
kernel.private:getenv
|
||||
|
|
@ -66,7 +70,7 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-signed-2
|
||||
alien.accessors:alien-cell
|
||||
alien.accessors:set-alien-cell
|
||||
} [ t "intrinsic" set-word-prop ] each
|
||||
} enable-intrinsics
|
||||
|
||||
: enable-alien-4-intrinsics ( -- )
|
||||
{
|
||||
|
|
@ -74,7 +78,7 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-unsigned-4
|
||||
alien.accessors:alien-signed-4
|
||||
alien.accessors:set-alien-signed-4
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-float-intrinsics ( -- )
|
||||
{
|
||||
|
|
@ -93,13 +97,25 @@ IN: compiler.cfg.intrinsics
|
|||
alien.accessors:set-alien-float
|
||||
alien.accessors:alien-double
|
||||
alien.accessors:set-alien-double
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-fsqrt ( -- )
|
||||
\ math.libm:fsqrt t "intrinsic" set-word-prop ;
|
||||
|
||||
: enable-float-min/max ( -- )
|
||||
{
|
||||
math.floats.private:float-min
|
||||
math.floats.private:float-max
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-min/max ( -- )
|
||||
{
|
||||
math.integers.private:fixnum-min
|
||||
math.integers.private:fixnum-max
|
||||
} enable-intrinsics ;
|
||||
|
||||
: enable-fixnum-log2 ( -- )
|
||||
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
|
||||
{ math.integers.private:fixnum-log2 } enable-intrinsics ;
|
||||
|
||||
: emit-intrinsic ( node word -- )
|
||||
{
|
||||
|
|
@ -123,6 +139,8 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
|
||||
{ \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
|
||||
{ \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
|
||||
{ \ math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
|
||||
{ \ math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
|
||||
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
|
||||
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
|
||||
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
|
||||
|
|
@ -136,6 +154,8 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
|
||||
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
|
||||
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
|
||||
{ \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
|
||||
{ \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
|
||||
{ \ math.libm:fsqrt [ drop emit-fsqrt ] }
|
||||
{ \ slots.private:slot [ emit-slot ] }
|
||||
{ \ slots.private:set-slot [ emit-set-slot ] }
|
||||
|
|
|
|||
|
|
@ -35,11 +35,15 @@ UNION: two-operand-insn
|
|||
##shr-imm
|
||||
##sar
|
||||
##sar-imm
|
||||
##min
|
||||
##max
|
||||
##fixnum-overflow
|
||||
##add-float
|
||||
##sub-float
|
||||
##mul-float
|
||||
##div-float ;
|
||||
##div-float
|
||||
##min-float
|
||||
##max-float ;
|
||||
|
||||
GENERIC: convert-two-operand* ( insn -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ TUPLE: commutative-expr < binary-expr ;
|
|||
TUPLE: compare-expr < binary-expr cc ;
|
||||
TUPLE: constant-expr < expr value ;
|
||||
TUPLE: reference-expr < expr value ;
|
||||
TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
|
||||
|
||||
: <constant> ( constant -- expr )
|
||||
f swap constant-expr boa ; inline
|
||||
|
|
@ -85,6 +86,14 @@ M: ##compare-imm >expr compare-imm>expr ;
|
|||
|
||||
M: ##compare-float >expr compare>expr ;
|
||||
|
||||
M: ##box-displaced-alien >expr
|
||||
{
|
||||
[ class ]
|
||||
[ src1>> vreg>vn ]
|
||||
[ src2>> vreg>vn ]
|
||||
[ base-class>> ]
|
||||
} cleave box-displaced-alien-expr boa ;
|
||||
|
||||
M: ##flushable >expr drop next-input-expr ;
|
||||
|
||||
: init-expressions ( -- )
|
||||
|
|
|
|||
|
|
@ -354,18 +354,18 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
|
|||
: box-displaced-alien? ( expr -- ? )
|
||||
op>> \ ##box-displaced-alien eq? ;
|
||||
|
||||
! ##box-displaced-alien f 1 2 3
|
||||
! ##unbox-any-c-ptr 4 1
|
||||
! ##box-displaced-alien f 1 2 3 <class>
|
||||
! ##unbox-c-ptr 4 1 <class>
|
||||
! =>
|
||||
! ##box-displaced-alien f 1 2 3
|
||||
! ##unbox-any-c-ptr 5 3
|
||||
! ##box-displaced-alien f 1 2 3 <class>
|
||||
! ##unbox-c-ptr 5 3 <class>
|
||||
! ##add 4 5 2
|
||||
|
||||
:: rewrite-unbox-displaced-alien ( insn expr -- insns )
|
||||
[
|
||||
next-vreg :> temp
|
||||
temp expr in2>> vn>vreg insn temp>> ##unbox-any-c-ptr
|
||||
insn dst>> temp expr in1>> vn>vreg ##add
|
||||
temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
|
||||
insn dst>> temp expr displacement>> vn>vreg ##add
|
||||
] { } make ;
|
||||
|
||||
M: ##unbox-any-c-ptr rewrite
|
||||
|
|
|
|||
|
|
@ -87,12 +87,6 @@ M: unary-expr simplify*
|
|||
[ 2drop f ]
|
||||
} cond ; inline
|
||||
|
||||
: simplify-box-displaced-alien ( expr -- vn/expr/f )
|
||||
>binary-expr< {
|
||||
{ [ over expr-zero? ] [ nip ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
M: binary-expr simplify*
|
||||
dup op>> {
|
||||
{ \ ##add [ simplify-add ] }
|
||||
|
|
@ -113,10 +107,15 @@ M: binary-expr simplify*
|
|||
{ \ ##sar-imm [ simplify-shr ] }
|
||||
{ \ ##shl [ simplify-shl ] }
|
||||
{ \ ##shl-imm [ simplify-shl ] }
|
||||
{ \ ##box-displaced-alien [ simplify-box-displaced-alien ] }
|
||||
[ 2drop f ]
|
||||
} case ;
|
||||
|
||||
M: box-displaced-alien-expr simplify*
|
||||
[ base>> ] [ displacement>> ] bi {
|
||||
{ [ dup vn>expr expr-zero? ] [ drop ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
M: expr simplify* drop f ;
|
||||
|
||||
: simplify ( expr -- vn )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ cpu.architecture tools.test kernel math combinators.short-circuit
|
|||
accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
|
||||
compiler.cfg.ssa.destruction compiler.cfg.loop-detection
|
||||
compiler.cfg.representations compiler.cfg assocs vectors arrays
|
||||
layouts namespaces ;
|
||||
layouts namespaces alien ;
|
||||
IN: compiler.cfg.value-numbering.tests
|
||||
|
||||
: trim-temps ( insns -- insns )
|
||||
|
|
@ -877,7 +877,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 1 2 0 }
|
||||
T{ ##box-displaced-alien f 1 2 0 c-ptr }
|
||||
T{ ##unbox-any-c-ptr f 4 0 }
|
||||
T{ ##add-imm f 3 4 16 }
|
||||
}
|
||||
|
|
@ -885,7 +885,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 1 2 0 }
|
||||
T{ ##box-displaced-alien f 1 2 0 c-ptr }
|
||||
T{ ##unbox-any-c-ptr f 3 1 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
@ -896,7 +896,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##box-alien f 0 1 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 c-ptr }
|
||||
T{ ##copy f 5 1 any-rep }
|
||||
T{ ##add-imm f 4 5 16 }
|
||||
}
|
||||
|
|
@ -904,7 +904,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##box-alien f 0 1 }
|
||||
T{ ##load-immediate f 2 16 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 c-ptr }
|
||||
T{ ##unbox-any-c-ptr f 4 3 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
@ -922,7 +922,7 @@ cell 8 = [
|
|||
{
|
||||
T{ ##peek f 0 D 0 }
|
||||
T{ ##load-immediate f 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 }
|
||||
T{ ##box-displaced-alien f 3 2 0 c-ptr }
|
||||
T{ ##replace f 3 D 1 }
|
||||
} value-numbering-step
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -149,6 +149,8 @@ M: ##shr generate-insn dst/src1/src2 %shr ;
|
|||
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
|
||||
M: ##sar generate-insn dst/src1/src2 %sar ;
|
||||
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
|
||||
M: ##min generate-insn dst/src1/src2 %min ;
|
||||
M: ##max generate-insn dst/src1/src2 %max ;
|
||||
M: ##not generate-insn dst/src %not ;
|
||||
M: ##log2 generate-insn dst/src %log2 ;
|
||||
|
||||
|
|
@ -169,6 +171,8 @@ M: ##add-float generate-insn dst/src1/src2 %add-float ;
|
|||
M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
|
||||
M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
|
||||
M: ##div-float generate-insn dst/src1/src2 %div-float ;
|
||||
M: ##min-float generate-insn dst/src1/src2 %min-float ;
|
||||
M: ##max-float generate-insn dst/src1/src2 %max-float ;
|
||||
|
||||
M: ##sqrt generate-insn dst/src %sqrt ;
|
||||
|
||||
|
|
|
|||
|
|
@ -83,3 +83,8 @@ IN: compiler.tests.float
|
|||
[ f ] [ 3.0 [ dup 0.0 float= swap -0.0 float= or ] compile-call ] unit-test
|
||||
|
||||
[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test
|
||||
|
||||
[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test
|
||||
[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
|
||||
[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
|
||||
[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
USING: accessors arrays compiler.units kernel kernel.private math
|
||||
math.constants math.private sequences strings tools.test words
|
||||
continuations sequences.private hashtables.private byte-arrays
|
||||
system random layouts vectors
|
||||
USING: accessors arrays compiler.units kernel kernel.private
|
||||
math math.constants math.private math.integers.private sequences
|
||||
strings tools.test words continuations sequences.private
|
||||
hashtables.private byte-arrays system random layouts vectors
|
||||
sbufs strings.private slots.private alien math.order
|
||||
alien.accessors alien.c-types alien.syntax alien.strings
|
||||
namespaces libc io.encodings.ascii
|
||||
classes compiler ;
|
||||
namespaces libc io.encodings.ascii classes compiler ;
|
||||
IN: compiler.tests.intrinsics
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
|
|
@ -271,6 +270,15 @@ cell 8 = [
|
|||
[ 100000 swap array-nth ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [ 2 4 [ fixnum-min ] compile-call ] unit-test
|
||||
[ 2 ] [ 4 2 [ fixnum-min ] compile-call ] unit-test
|
||||
[ 4 ] [ 2 4 [ fixnum-max ] compile-call ] unit-test
|
||||
[ 4 ] [ 4 2 [ fixnum-max ] compile-call ] unit-test
|
||||
[ -2 ] [ -2 -4 [ fixnum-max ] compile-call ] unit-test
|
||||
[ -2 ] [ -4 -2 [ fixnum-max ] compile-call ] unit-test
|
||||
[ -4 ] [ -2 -4 [ fixnum-min ] compile-call ] unit-test
|
||||
[ -4 ] [ -4 -2 [ fixnum-min ] compile-call ] unit-test
|
||||
|
||||
! 64-bit overflow
|
||||
cell 8 = [
|
||||
[ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel effects accessors math math.private
|
||||
math.integers.private math.partial-dispatch math.intervals
|
||||
math.parser math.order math.functions math.libm layouts words
|
||||
sequences sequences.private arrays assocs classes
|
||||
math.integers.private math.floats.private math.partial-dispatch
|
||||
math.intervals math.parser math.order math.functions math.libm
|
||||
layouts words sequences sequences.private arrays assocs classes
|
||||
classes.algebra combinators generic.math splitting fry locals
|
||||
classes.tuple alien.accessors classes.tuple.private
|
||||
slots.private definitions strings.private vectors hashtables
|
||||
|
|
@ -79,11 +79,16 @@ IN: compiler.tree.propagation.known-words
|
|||
] unless ;
|
||||
|
||||
: ensure-math-class ( class must-be -- class' )
|
||||
[ class<= ] 2keep ? ;
|
||||
[ class<= ] most ;
|
||||
|
||||
: number-valued ( class interval -- class' interval' )
|
||||
[ number ensure-math-class ] dip ;
|
||||
|
||||
: fixnum-valued ( class interval -- class' interval' )
|
||||
over null-class? [
|
||||
[ drop fixnum ] dip
|
||||
] unless ;
|
||||
|
||||
: integer-valued ( class interval -- class' interval' )
|
||||
[ integer ensure-math-class ] dip ;
|
||||
|
||||
|
|
@ -303,3 +308,16 @@ generic-comparison-ops [
|
|||
flog fpow fsqrt facosh fasinh fatanh } [
|
||||
{ float } "default-output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
! Find a less repetitive way of doing this
|
||||
\ float-min { float float } "input-classes" set-word-prop
|
||||
\ float-min [ interval-min ] [ float-valued ] binary-op
|
||||
|
||||
\ float-max { float float } "input-classes" set-word-prop
|
||||
\ float-max [ interval-max ] [ float-valued ] binary-op
|
||||
|
||||
\ fixnum-min { fixnum fixnum } "input-classes" set-word-prop
|
||||
\ fixnum-min [ interval-min ] [ fixnum-valued ] binary-op
|
||||
|
||||
\ fixnum-max { fixnum fixnum } "input-classes" set-word-prop
|
||||
\ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences words fry generic accessors classes.tuple
|
||||
classes classes.algebra definitions stack-checker.state quotations
|
||||
classes.tuple.private math math.partial-dispatch math.private
|
||||
math.intervals layouts math.order vectors hashtables
|
||||
combinators effects generalizations assocs sets
|
||||
combinators.short-circuit sequences.private locals
|
||||
USING: kernel sequences words fry generic accessors
|
||||
classes.tuple classes classes.algebra definitions
|
||||
stack-checker.state quotations classes.tuple.private math
|
||||
math.partial-dispatch math.private math.intervals
|
||||
math.floats.private math.integers.private layouts math.order
|
||||
vectors hashtables combinators effects generalizations assocs
|
||||
sets combinators.short-circuit sequences.private locals
|
||||
stack-checker namespaces compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.transforms
|
||||
|
||||
|
|
@ -79,6 +80,26 @@ IN: compiler.tree.propagation.transforms
|
|||
] [ f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
! Integrate this with generic arithmetic optimization instead?
|
||||
: both-inputs? ( #call class -- ? )
|
||||
[ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ;
|
||||
|
||||
\ min [
|
||||
{
|
||||
{ [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] }
|
||||
{ [ dup float both-inputs? ] [ [ float-min ] ] }
|
||||
[ f ]
|
||||
} cond nip
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
\ max [
|
||||
{
|
||||
{ [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] }
|
||||
{ [ dup float both-inputs? ] [ [ float-max ] ] }
|
||||
[ f ]
|
||||
} cond nip
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
|
|
|
|||
|
|
@ -96,6 +96,8 @@ HOOK: %shr cpu ( dst src1 src2 -- )
|
|||
HOOK: %shr-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar cpu ( dst src1 src2 -- )
|
||||
HOOK: %sar-imm cpu ( dst src1 src2 -- )
|
||||
HOOK: %min cpu ( dst src1 src2 -- )
|
||||
HOOK: %max cpu ( dst src1 src2 -- )
|
||||
HOOK: %not cpu ( dst src -- )
|
||||
HOOK: %log2 cpu ( dst src -- )
|
||||
|
||||
|
|
@ -110,6 +112,8 @@ HOOK: %add-float cpu ( dst src1 src2 -- )
|
|||
HOOK: %sub-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %mul-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %div-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %min-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %max-float cpu ( dst src1 src2 -- )
|
||||
HOOK: %sqrt cpu ( dst src -- )
|
||||
|
||||
HOOK: %integer>float cpu ( dst src -- )
|
||||
|
|
|
|||
|
|
@ -303,8 +303,7 @@ USING: cpu.x86.features cpu.x86.features.private ;
|
|||
"Checking if your CPU supports SSE2..." print flush
|
||||
sse2? [
|
||||
" - yes" print
|
||||
enable-float-intrinsics
|
||||
enable-fsqrt
|
||||
enable-sse2
|
||||
[
|
||||
sse2? [
|
||||
"This image was built to use SSE2, which your CPU does not support." print
|
||||
|
|
|
|||
|
|
@ -202,8 +202,7 @@ M: x86.64 %callback-value ( ctype -- )
|
|||
enable-alien-4-intrinsics
|
||||
|
||||
! SSE2 is always available on x86-64.
|
||||
enable-float-intrinsics
|
||||
enable-fsqrt
|
||||
enable-sse2
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
|
|
|
|||
|
|
@ -123,6 +123,10 @@ M: x86 %xor-imm nip XOR ;
|
|||
M: x86 %shl-imm nip SHL ;
|
||||
M: x86 %shr-imm nip SHR ;
|
||||
M: x86 %sar-imm nip SAR ;
|
||||
|
||||
M: x86 %min nip [ CMP ] [ CMOVG ] 2bi ;
|
||||
M: x86 %max nip [ CMP ] [ CMOVL ] 2bi ;
|
||||
|
||||
M: x86 %not drop NOT ;
|
||||
M: x86 %log2 BSR ;
|
||||
|
||||
|
|
@ -203,6 +207,8 @@ M: x86 %add-float nip ADDSD ;
|
|||
M: x86 %sub-float nip SUBSD ;
|
||||
M: x86 %mul-float nip MULSD ;
|
||||
M: x86 %div-float nip DIVSD ;
|
||||
M: x86 %min-float nip MINSD ;
|
||||
M: x86 %max-float nip MAXSD ;
|
||||
M: x86 %sqrt SQRTSD ;
|
||||
|
||||
M: x86 %integer>float CVTSI2SD ;
|
||||
|
|
@ -572,3 +578,10 @@ M: x86 small-enough? ( n -- ? )
|
|||
#! stack frame set up, and we want to read the frame
|
||||
#! set up by the caller.
|
||||
stack-frame get total-size>> + stack@ ;
|
||||
|
||||
: enable-sse2 ( -- )
|
||||
enable-float-intrinsics
|
||||
enable-fsqrt
|
||||
enable-float-min/max ;
|
||||
|
||||
enable-min/max
|
||||
|
|
|
|||
|
|
@ -235,6 +235,10 @@ IN: math.intervals.tests
|
|||
interval-contains?
|
||||
] unit-test
|
||||
|
||||
[ t ] [ full-interval 10 10 [a,b] interval-max 10 1/0. [a,b] = ] unit-test
|
||||
|
||||
[ t ] [ full-interval 10 10 [a,b] interval-min -1/0. 10 [a,b] = ] unit-test
|
||||
|
||||
[ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
|
||||
|
||||
! Accuracy of interval-mod
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: math.intervals
|
|||
|
||||
SYMBOL: empty-interval
|
||||
|
||||
SYMBOL: full-interval
|
||||
SINGLETON: full-interval
|
||||
|
||||
TUPLE: interval { from read-only } { to read-only } ;
|
||||
|
||||
|
|
@ -238,12 +238,24 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
] do-empty-interval ;
|
||||
|
||||
: interval-max ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] do-empty-interval ;
|
||||
{
|
||||
{ [ over empty-interval eq? ] [ drop ] }
|
||||
{ [ dup empty-interval eq? ] [ nip ] }
|
||||
{ [ 2dup [ full-interval eq? ] both? ] [ drop ] }
|
||||
{ [ over full-interval eq? ] [ nip from>> first [a,inf] ] }
|
||||
{ [ dup full-interval eq? ] [ drop from>> first [a,inf] ] }
|
||||
[ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ]
|
||||
} cond ;
|
||||
|
||||
: interval-min ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] do-empty-interval ;
|
||||
{
|
||||
{ [ over empty-interval eq? ] [ drop ] }
|
||||
{ [ dup empty-interval eq? ] [ nip ] }
|
||||
{ [ 2dup [ full-interval eq? ] both? ] [ drop ] }
|
||||
{ [ over full-interval eq? ] [ nip to>> first [-inf,a] ] }
|
||||
{ [ dup full-interval eq? ] [ drop to>> first [-inf,a] ] }
|
||||
[ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ]
|
||||
} cond ;
|
||||
|
||||
: interval-interior ( i1 -- i2 )
|
||||
dup special-interval? [
|
||||
|
|
|
|||
|
|
@ -4,53 +4,54 @@ USING: alien ;
|
|||
IN: math.libm
|
||||
|
||||
: facos ( x -- y )
|
||||
"double" "libm" "acos" { "double" } alien-invoke ;
|
||||
"double" "libm" "acos" { "double" } alien-invoke ; inline
|
||||
|
||||
: fasin ( x -- y )
|
||||
"double" "libm" "asin" { "double" } alien-invoke ;
|
||||
"double" "libm" "asin" { "double" } alien-invoke ; inline
|
||||
|
||||
: fatan ( x -- y )
|
||||
"double" "libm" "atan" { "double" } alien-invoke ;
|
||||
"double" "libm" "atan" { "double" } alien-invoke ; inline
|
||||
|
||||
: fatan2 ( x y -- z )
|
||||
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
|
||||
"double" "libm" "atan2" { "double" "double" } alien-invoke ; inline
|
||||
|
||||
: fcos ( x -- y )
|
||||
"double" "libm" "cos" { "double" } alien-invoke ;
|
||||
"double" "libm" "cos" { "double" } alien-invoke ; inline
|
||||
|
||||
: fsin ( x -- y )
|
||||
"double" "libm" "sin" { "double" } alien-invoke ;
|
||||
"double" "libm" "sin" { "double" } alien-invoke ; inline
|
||||
|
||||
: ftan ( x -- y )
|
||||
"double" "libm" "tan" { "double" } alien-invoke ;
|
||||
"double" "libm" "tan" { "double" } alien-invoke ; inline
|
||||
|
||||
: fcosh ( x -- y )
|
||||
"double" "libm" "cosh" { "double" } alien-invoke ;
|
||||
"double" "libm" "cosh" { "double" } alien-invoke ; inline
|
||||
|
||||
: fsinh ( x -- y )
|
||||
"double" "libm" "sinh" { "double" } alien-invoke ;
|
||||
"double" "libm" "sinh" { "double" } alien-invoke ; inline
|
||||
|
||||
: ftanh ( x -- y )
|
||||
"double" "libm" "tanh" { "double" } alien-invoke ;
|
||||
"double" "libm" "tanh" { "double" } alien-invoke ; inline
|
||||
|
||||
: fexp ( x -- y )
|
||||
"double" "libm" "exp" { "double" } alien-invoke ;
|
||||
"double" "libm" "exp" { "double" } alien-invoke ; inline
|
||||
|
||||
: flog ( x -- y )
|
||||
"double" "libm" "log" { "double" } alien-invoke ;
|
||||
"double" "libm" "log" { "double" } alien-invoke ; inline
|
||||
|
||||
: fpow ( x y -- z )
|
||||
"double" "libm" "pow" { "double" "double" } alien-invoke ;
|
||||
"double" "libm" "pow" { "double" "double" } alien-invoke ; inline
|
||||
|
||||
! Don't inline fsqrt -- its an intrinsic!
|
||||
: fsqrt ( x -- y )
|
||||
"double" "libm" "sqrt" { "double" } alien-invoke ;
|
||||
|
||||
! Windows doesn't have these...
|
||||
: facosh ( x -- y )
|
||||
"double" "libm" "acosh" { "double" } alien-invoke ;
|
||||
"double" "libm" "acosh" { "double" } alien-invoke ; inline
|
||||
|
||||
: fasinh ( x -- y )
|
||||
"double" "libm" "asinh" { "double" } alien-invoke ;
|
||||
"double" "libm" "asinh" { "double" } alien-invoke ; inline
|
||||
|
||||
: fatanh ( x -- y )
|
||||
"double" "libm" "atanh" { "double" } alien-invoke ;
|
||||
"double" "libm" "atanh" { "double" } alien-invoke ; inline
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ M: struct-array length length>> ; inline
|
|||
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
|
||||
|
||||
: (nth-ptr) ( i struct-array -- alien )
|
||||
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ; inline
|
||||
[ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
|
||||
|
||||
M: struct-array nth-unsafe
|
||||
[ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
|
||||
|
|
@ -26,7 +26,7 @@ M: struct-array set-nth-unsafe
|
|||
[ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
|
||||
|
||||
M: struct-array new-sequence
|
||||
[ element-size>> [ * <byte-array> ] 2keep ]
|
||||
[ element-size>> [ * (byte-array) ] 2keep ]
|
||||
[ class>> ] bi struct-array boa ; inline
|
||||
|
||||
M: struct-array resize ( n seq -- newseq )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays assocs compiler.units
|
||||
debugger init io kernel namespaces prettyprint sequences
|
||||
USING: accessors arrays assocs compiler.units debugger init io
|
||||
io.streams.null kernel namespaces prettyprint sequences
|
||||
source-files.errors summary tools.crossref
|
||||
tools.crossref.private tools.errors words ;
|
||||
IN: tools.deprecation
|
||||
|
|
@ -39,12 +39,14 @@ T{ error-type
|
|||
: clear-deprecation-note ( word -- )
|
||||
deprecation-notes get-global delete-at ;
|
||||
|
||||
: check-deprecations ( word -- )
|
||||
dup "forgotten" word-prop
|
||||
[ clear-deprecation-note ] [
|
||||
dup def>> uses [ deprecated? ] filter
|
||||
[ clear-deprecation-note ] [ >array deprecation-note ] if-empty
|
||||
] if ;
|
||||
: check-deprecations ( usage -- )
|
||||
dup word? [
|
||||
dup "forgotten" word-prop
|
||||
[ clear-deprecation-note ] [
|
||||
dup def>> uses [ deprecated? ] filter
|
||||
[ clear-deprecation-note ] [ >array deprecation-note ] if-empty
|
||||
] if
|
||||
] [ drop ] if ;
|
||||
|
||||
M: deprecated-usages summary
|
||||
drop "Deprecated words used" ;
|
||||
|
|
@ -58,8 +60,10 @@ M: deprecated-usages error.
|
|||
SINGLETON: deprecation-observer
|
||||
|
||||
: initialize-deprecation-notes ( -- )
|
||||
get-crossref [ drop deprecated? ] assoc-filter
|
||||
values [ keys [ check-deprecations ] each ] each ;
|
||||
[
|
||||
get-crossref [ drop deprecated? ] assoc-filter
|
||||
values [ keys [ check-deprecations ] each ] each
|
||||
] with-null-writer ;
|
||||
|
||||
M: deprecation-observer definitions-changed
|
||||
drop keys [ word? ] filter
|
||||
|
|
|
|||
|
|
@ -3,6 +3,9 @@
|
|||
USING: kernel math math.private ;
|
||||
IN: math.floats.private
|
||||
|
||||
: float-min ( x y -- z ) [ float< ] most ; foldable
|
||||
: float-max ( x y -- z ) [ float> ] most ; foldable
|
||||
|
||||
M: fixnum >float fixnum>float ; inline
|
||||
M: bignum >float bignum>float ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private sequences
|
||||
sequences.private math math.private combinators ;
|
||||
IN: math.integers.private
|
||||
|
||||
: fixnum-min ( x y -- z ) [ fixnum< ] most ; foldable
|
||||
: fixnum-max ( x y -- z ) [ fixnum> ] most ; foldable
|
||||
|
||||
M: integer numerator ; inline
|
||||
M: integer denominator drop 1 ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@ M: real after? ( obj1 obj2 -- ? ) > ; inline
|
|||
M: real before=? ( obj1 obj2 -- ? ) <= ; inline
|
||||
M: real after=? ( obj1 obj2 -- ? ) >= ; inline
|
||||
|
||||
: min ( x y -- z ) [ before? ] most ; inline
|
||||
: max ( x y -- z ) [ after? ] most ; inline
|
||||
: min ( x y -- z ) [ before? ] most ;
|
||||
: max ( x y -- z ) [ after? ] most ;
|
||||
: clamp ( x min max -- y ) [ max ] dip min ; inline
|
||||
|
||||
: between? ( x y z -- ? )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,52 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors classes.struct combinators.smart fry kernel
|
||||
math math.functions math.order math.parser sequences
|
||||
struct-arrays hints io ;
|
||||
IN: benchmark.struct-arrays
|
||||
|
||||
STRUCT: point { x float } { y float } { z float } ;
|
||||
|
||||
: xyz ( point -- x y z )
|
||||
[ x>> ] [ y>> ] [ z>> ] tri ; inline
|
||||
|
||||
: change-xyz ( point obj x: ( x obj -- x' ) y: ( y obj -- y' ) z: ( z obj -- z' ) -- point )
|
||||
tri-curry [ change-x ] [ change-y ] [ change-z ] tri* ; inline
|
||||
|
||||
: init-point ( n point -- n )
|
||||
over >fixnum >float
|
||||
[ sin >>x ] [ cos 3 * >>y ] [ sin sq 2 / >>z ] tri drop
|
||||
1 + ; inline
|
||||
|
||||
: make-points ( len -- points )
|
||||
point <struct-array> dup 0 [ init-point ] reduce drop ; inline
|
||||
|
||||
: point-norm ( point -- norm )
|
||||
[ xyz [ absq ] tri@ ] sum-outputs sqrt ; inline
|
||||
|
||||
: normalize-point ( point -- )
|
||||
dup point-norm [ / ] [ / ] [ / ] change-xyz drop ; inline
|
||||
|
||||
: normalize-points ( points -- )
|
||||
[ normalize-point ] each ; inline
|
||||
|
||||
: max-point ( point1 point2 -- point1 )
|
||||
[ x>> max ] [ y>> max ] [ z>> max ] change-xyz ; inline
|
||||
|
||||
: <zero-point> ( -- point )
|
||||
0 0 0 point <struct-boa> ; inline
|
||||
|
||||
: max-points ( points -- point )
|
||||
<zero-point> [ max-point ] reduce ; inline
|
||||
|
||||
: print-point ( point -- )
|
||||
[ xyz [ number>string ] tri@ ] output>array ", " join print ; inline
|
||||
|
||||
: struct-array-benchmark ( len -- )
|
||||
make-points [ normalize-points ] [ max-points ] bi print-point ;
|
||||
|
||||
HINTS: struct-array-benchmark fixnum ;
|
||||
|
||||
: main ( -- ) 5000000 struct-array-benchmark ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: io kernel terrain.generation threads ;
|
||||
IN: benchmark.terrain-generation
|
||||
|
||||
: terrain-generation-benchmark ( -- )
|
||||
"Generating terrain segment..." write flush yield
|
||||
<terrain> { 0.0 0.0 } terrain-segment drop
|
||||
"done" print ;
|
||||
|
||||
MAIN: terrain-generation-benchmark
|
||||
|
|
@ -4,11 +4,11 @@ USING: alien alien.c-types alien.strings
|
|||
kernel libc math namespaces system-info.backend
|
||||
system-info.windows windows windows.advapi32
|
||||
windows.kernel32 system byte-arrays windows.errors
|
||||
classes classes.struct ;
|
||||
classes classes.struct accessors ;
|
||||
IN: system-info.windows.nt
|
||||
|
||||
M: winnt cpus ( -- n )
|
||||
system-info SYSTEM_INFO-dwNumberOfProcessors ;
|
||||
system-info dwNumberOfProcessors>> ;
|
||||
|
||||
: memory-status ( -- MEMORYSTATUSEX )
|
||||
"MEMORYSTATUSEX" <struct>
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types kernel libc math namespaces
|
||||
windows windows.kernel32 windows.advapi32
|
||||
words combinators vocabs.loader system-info.backend
|
||||
system alien.strings windows.errors ;
|
||||
USING: alien alien.c-types classes.struct accessors kernel
|
||||
math namespaces windows windows.kernel32 windows.advapi32 words
|
||||
combinators vocabs.loader system-info.backend system
|
||||
alien.strings windows.errors ;
|
||||
IN: system-info.windows
|
||||
|
||||
: system-info ( -- SYSTEM_INFO )
|
||||
|
|
|
|||
Loading…
Reference in New Issue