steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-08-28 10:40:30 -05:00
parent c6c22a4d5d ff4213003b
commit 4197891499
26 changed files with 195 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -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

5
basis/compiler/cfg/hats/hats.factor
View File

@ -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

8
basis/compiler/cfg/instructions/instructions.factor
View File

@ -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

9
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -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 ;

9
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -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 ] }

4
basis/compiler/cfg/two-operand/two-operand.factor
View File

@ -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 -- )

9
basis/compiler/cfg/value-numbering/expressions/expressions.factor
View File

@ -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 ( -- )

12
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -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

13
basis/compiler/cfg/value-numbering/simplify/simplify.factor
View File

@ -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 )

12
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -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

2
basis/compiler/codegen/codegen.factor
View File

@ -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 ;

5
basis/compiler/tests/float.factor
View File

@ -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

13
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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

12
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -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>> {

2
basis/cpu/architecture/architecture.factor
View File

@ -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 -- )

3
basis/cpu/x86/32/32.factor
View File

@ -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

3
basis/cpu/x86/64/64.factor
View File

@ -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

7
basis/cpu/x86/x86.factor
View File

@ -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 ;

33
basis/math/libm/libm.factor
View File

@ -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

4
basis/struct-arrays/struct-arrays.factor
View File

@ -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 )

24
basis/tools/deprecation/deprecation.factor
View File

@ -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
core/math/floats/floats.factor
View File

@ -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

4
core/math/order/order.factor
View File

@ -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 -- ? )

52
extra/benchmark/struct-arrays/struct-arrays.factor Normal file
View File

@ -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
extra/system-info/windows/nt/nt.factor
View File

@ -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>

8
extra/system-info/windows/windows.factor
View File

@ -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 )