Merge branch 'master' of git://factorcode.org/git/factor
commit
4197891499
|
@ -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
|
|
@ -43,6 +43,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 +53,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
|
||||
|
|
|
@ -106,6 +106,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 +120,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 +265,8 @@ UNION: output-float-insn
|
|||
##sub-float
|
||||
##mul-float
|
||||
##div-float
|
||||
##min-float
|
||||
##max-float
|
||||
##sqrt
|
||||
##integer>float
|
||||
##unbox-float
|
||||
|
@ -275,6 +279,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,6 +21,7 @@ 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
|
||||
|
||||
|
@ -98,6 +99,12 @@ IN: compiler.cfg.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
|
||||
} [ t "intrinsic" set-word-prop ] each ;
|
||||
|
||||
: enable-fixnum-log2 ( -- )
|
||||
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
|
||||
|
||||
|
@ -136,6 +143,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 ] }
|
||||
|
|
|
@ -39,7 +39,9 @@ UNION: two-operand-insn
|
|||
##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 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
|
||||
|
|
|
@ -169,6 +169,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,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
|
||||
|
@ -303,3 +303,8 @@ generic-comparison-ops [
|
|||
flog fpow fsqrt facosh fasinh fatanh } [
|
||||
{ float } "default-output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
{ float-min float-max } [
|
||||
[ { float float } "input-classes" set-word-prop ]
|
||||
[ { float } "default-output-classes" set-word-prop ] bi
|
||||
] each
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
math.intervals math.floats.private layouts math.order vectors hashtables
|
||||
combinators effects generalizations assocs sets
|
||||
combinators.short-circuit sequences.private locals
|
||||
stack-checker namespaces compiler.tree.propagation.info ;
|
||||
|
@ -79,6 +79,16 @@ IN: compiler.tree.propagation.transforms
|
|||
] [ f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
{ min [ float-min ] }
|
||||
{ max [ float-max ] }
|
||||
} [
|
||||
'[
|
||||
in-d>> first2 [ value-info class>> float class<= ] both?
|
||||
[ _ ] [ f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
! Generate more efficient code for common idiom
|
||||
\ clone [
|
||||
in-d>> first value-info literal>> {
|
||||
|
|
|
@ -110,6 +110,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
|
||||
|
||||
|
|
|
@ -203,6 +203,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 +574,8 @@ 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 ;
|
||||
|
|
|
@ -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< ] 2keep ? ;
|
||||
: float-max ( x y -- z ) [ float> ] 2keep ? ;
|
||||
|
||||
M: fixnum >float fixnum>float ; inline
|
||||
M: bignum >float bignum>float ; 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
|
|
@ -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