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

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

db4
Sascha Matzke 2009-08-29 12:48:54 +02:00
parent 8b410e373b 908b4742c5
commit d3df9b7718
31 changed files with 305 additions and 93 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 ] [ [ f ] [
[ 1000 [ ] times ] [ 1000 [ ] times ]
[ [ ##peek? ] [ ##replace? ] bi or ] contains-insn? [ [ ##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 ] unit-test

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

@ -35,6 +35,8 @@ IN: compiler.cfg.hats
: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline : ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline : ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; 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 : ^^not ( src -- dst ) ^^r1 ##not ; inline
: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline : ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; 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 : ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline : ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-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 : ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline : ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; 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-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-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-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-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ; : ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline : ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline

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

@ -91,6 +91,8 @@ INSN: ##shr < ##binary ;
INSN: ##shr-imm < ##binary-imm ; INSN: ##shr-imm < ##binary-imm ;
INSN: ##sar < ##binary ; INSN: ##sar < ##binary ;
INSN: ##sar-imm < ##binary-imm ; INSN: ##sar-imm < ##binary-imm ;
INSN: ##min < ##binary ;
INSN: ##max < ##binary ;
INSN: ##not < ##unary ; INSN: ##not < ##unary ;
INSN: ##log2 < ##unary ; INSN: ##log2 < ##unary ;
@ -106,6 +108,8 @@ INSN: ##add-float < ##commutative ;
INSN: ##sub-float < ##binary ; INSN: ##sub-float < ##binary ;
INSN: ##mul-float < ##commutative ; INSN: ##mul-float < ##commutative ;
INSN: ##div-float < ##binary ; INSN: ##div-float < ##binary ;
INSN: ##min-float < ##binary ;
INSN: ##max-float < ##binary ;
INSN: ##sqrt < ##unary ; INSN: ##sqrt < ##unary ;
! Float/integer conversion ! Float/integer conversion
@ -118,7 +122,7 @@ INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ; INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ; INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##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-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@ -263,6 +267,8 @@ UNION: output-float-insn
##sub-float ##sub-float
##mul-float ##mul-float
##div-float ##div-float
##min-float
##max-float
##sqrt ##sqrt
##integer>float ##integer>float
##unbox-float ##unbox-float
@ -275,6 +281,8 @@ UNION: input-float-insn
##sub-float ##sub-float
##mul-float ##mul-float
##div-float ##div-float
##min-float
##max-float
##sqrt ##sqrt
##float>integer ##float>integer
##box-float ##box-float

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

@ -14,10 +14,11 @@ IN: compiler.cfg.intrinsics.alien
} 1&& ; } 1&& ;
: emit-<displaced-alien> ( node -- ) : emit-<displaced-alien> ( node -- )
dup emit-<displaced-alien>? dup emit-<displaced-alien>? [
[ drop 2inputs [ ^^untag-fixnum ] dip ^^box-displaced-alien ds-push ] [ 2inputs [ ^^untag-fixnum ] dip ] dip
[ emit-primitive ] node-input-infos second class>>
if ; ^^box-displaced-alien ds-push
] [ emit-primitive ] if ;
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) : (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ; ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;

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

@ -21,9 +21,13 @@ QUALIFIED: strings.private
QUALIFIED: classes.tuple.private QUALIFIED: classes.tuple.private
QUALIFIED: math.private QUALIFIED: math.private
QUALIFIED: math.integers.private QUALIFIED: math.integers.private
QUALIFIED: math.floats.private
QUALIFIED: math.libm QUALIFIED: math.libm
IN: compiler.cfg.intrinsics IN: compiler.cfg.intrinsics
: enable-intrinsics ( words -- )
[ t "intrinsic" set-word-prop ] each ;
{ {
kernel.private:tag kernel.private:tag
kernel.private:getenv kernel.private:getenv
@ -66,7 +70,7 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-signed-2 alien.accessors:set-alien-signed-2
alien.accessors:alien-cell alien.accessors:alien-cell
alien.accessors:set-alien-cell alien.accessors:set-alien-cell
} [ t "intrinsic" set-word-prop ] each } enable-intrinsics
: enable-alien-4-intrinsics ( -- ) : enable-alien-4-intrinsics ( -- )
{ {
@ -74,7 +78,7 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-unsigned-4 alien.accessors:set-alien-unsigned-4
alien.accessors:alien-signed-4 alien.accessors:alien-signed-4
alien.accessors:set-alien-signed-4 alien.accessors:set-alien-signed-4
} [ t "intrinsic" set-word-prop ] each ; } enable-intrinsics ;
: enable-float-intrinsics ( -- ) : enable-float-intrinsics ( -- )
{ {
@ -93,13 +97,25 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-float alien.accessors:set-alien-float
alien.accessors:alien-double alien.accessors:alien-double
alien.accessors:set-alien-double alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ; } enable-intrinsics ;
: enable-fsqrt ( -- ) : enable-fsqrt ( -- )
\ math.libm:fsqrt t "intrinsic" set-word-prop ; \ 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 ( -- ) : enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; { math.integers.private:fixnum-log2 } enable-intrinsics ;
: emit-intrinsic ( node word -- ) : 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 ] }
{ \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] } { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ 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:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } { \ 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= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] } { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] } { \ 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 ] } { \ math.libm:fsqrt [ drop emit-fsqrt ] }
{ \ slots.private:slot [ emit-slot ] } { \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] } { \ slots.private:set-slot [ emit-set-slot ] }

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

@ -35,11 +35,15 @@ UNION: two-operand-insn
##shr-imm ##shr-imm
##sar ##sar
##sar-imm ##sar-imm
##min
##max
##fixnum-overflow ##fixnum-overflow
##add-float ##add-float
##sub-float ##sub-float
##mul-float ##mul-float
##div-float ; ##div-float
##min-float
##max-float ;
GENERIC: convert-two-operand* ( insn -- ) 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: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ; TUPLE: constant-expr < expr value ;
TUPLE: reference-expr < expr value ; TUPLE: reference-expr < expr value ;
TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
: <constant> ( constant -- expr ) : <constant> ( constant -- expr )
f swap constant-expr boa ; inline f swap constant-expr boa ; inline
@ -85,6 +86,14 @@ M: ##compare-imm >expr compare-imm>expr ;
M: ##compare-float >expr compare>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 ; M: ##flushable >expr drop next-input-expr ;
: init-expressions ( -- ) : 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 -- ? ) : box-displaced-alien? ( expr -- ? )
op>> \ ##box-displaced-alien eq? ; op>> \ ##box-displaced-alien eq? ;
! ##box-displaced-alien f 1 2 3 ! ##box-displaced-alien f 1 2 3 <class>
! ##unbox-any-c-ptr 4 1 ! ##unbox-c-ptr 4 1 <class>
! => ! =>
! ##box-displaced-alien f 1 2 3 ! ##box-displaced-alien f 1 2 3 <class>
! ##unbox-any-c-ptr 5 3 ! ##unbox-c-ptr 5 3 <class>
! ##add 4 5 2 ! ##add 4 5 2
:: rewrite-unbox-displaced-alien ( insn expr -- insns ) :: rewrite-unbox-displaced-alien ( insn expr -- insns )
[ [
next-vreg :> temp next-vreg :> temp
temp expr in2>> vn>vreg insn temp>> ##unbox-any-c-ptr temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
insn dst>> temp expr in1>> vn>vreg ##add insn dst>> temp expr displacement>> vn>vreg ##add
] { } make ; ] { } make ;
M: ##unbox-any-c-ptr rewrite 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 ] [ 2drop f ]
} cond ; inline } cond ; inline
: simplify-box-displaced-alien ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-zero? ] [ nip ] }
[ 2drop f ]
} cond ;
M: binary-expr simplify* M: binary-expr simplify*
dup op>> { dup op>> {
{ \ ##add [ simplify-add ] } { \ ##add [ simplify-add ] }
@ -113,10 +107,15 @@ M: binary-expr simplify*
{ \ ##sar-imm [ simplify-shr ] } { \ ##sar-imm [ simplify-shr ] }
{ \ ##shl [ simplify-shl ] } { \ ##shl [ simplify-shl ] }
{ \ ##shl-imm [ simplify-shl ] } { \ ##shl-imm [ simplify-shl ] }
{ \ ##box-displaced-alien [ simplify-box-displaced-alien ] }
[ 2drop f ] [ 2drop f ]
} case ; } case ;
M: box-displaced-alien-expr simplify*
[ base>> ] [ displacement>> ] bi {
{ [ dup vn>expr expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ;
M: expr simplify* drop f ; M: expr simplify* drop f ;
: simplify ( expr -- vn ) : 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 accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
compiler.cfg.ssa.destruction compiler.cfg.loop-detection compiler.cfg.ssa.destruction compiler.cfg.loop-detection
compiler.cfg.representations compiler.cfg assocs vectors arrays compiler.cfg.representations compiler.cfg assocs vectors arrays
layouts namespaces ; layouts namespaces alien ;
IN: compiler.cfg.value-numbering.tests IN: compiler.cfg.value-numbering.tests
: trim-temps ( insns -- insns ) : trim-temps ( insns -- insns )
@ -877,7 +877,7 @@ cell 8 = [
{ {
T{ ##peek f 0 D 0 } T{ ##peek f 0 D 0 }
T{ ##load-immediate f 2 16 } 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{ ##unbox-any-c-ptr f 4 0 }
T{ ##add-imm f 3 4 16 } T{ ##add-imm f 3 4 16 }
} }
@ -885,7 +885,7 @@ cell 8 = [
{ {
T{ ##peek f 0 D 0 } T{ ##peek f 0 D 0 }
T{ ##load-immediate f 2 16 } 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 } T{ ##unbox-any-c-ptr f 3 1 }
} value-numbering-step } value-numbering-step
] unit-test ] unit-test
@ -896,7 +896,7 @@ cell 8 = [
{ {
T{ ##box-alien f 0 1 } T{ ##box-alien f 0 1 }
T{ ##load-immediate f 2 16 } 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{ ##copy f 5 1 any-rep }
T{ ##add-imm f 4 5 16 } T{ ##add-imm f 4 5 16 }
} }
@ -904,7 +904,7 @@ cell 8 = [
{ {
T{ ##box-alien f 0 1 } T{ ##box-alien f 0 1 }
T{ ##load-immediate f 2 16 } 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 } T{ ##unbox-any-c-ptr f 4 3 }
} value-numbering-step } value-numbering-step
] unit-test ] unit-test
@ -922,7 +922,7 @@ cell 8 = [
{ {
T{ ##peek f 0 D 0 } T{ ##peek f 0 D 0 }
T{ ##load-immediate f 2 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 } T{ ##replace f 3 D 1 }
} value-numbering-step } value-numbering-step
] unit-test ] unit-test

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

@ -149,6 +149,8 @@ M: ##shr generate-insn dst/src1/src2 %shr ;
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ; M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
M: ##sar generate-insn dst/src1/src2 %sar ; M: ##sar generate-insn dst/src1/src2 %sar ;
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ; 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: ##not generate-insn dst/src %not ;
M: ##log2 generate-insn dst/src %log2 ; 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: ##sub-float generate-insn dst/src1/src2 %sub-float ;
M: ##mul-float generate-insn dst/src1/src2 %mul-float ; M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
M: ##div-float generate-insn dst/src1/src2 %div-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 ; 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 [ 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 [ 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

20
basis/compiler/tests/intrinsics.factor
View File

@ -1,11 +1,10 @@
USING: accessors arrays compiler.units kernel kernel.private math USING: accessors arrays compiler.units kernel kernel.private
math.constants math.private sequences strings tools.test words math math.constants math.private math.integers.private sequences
continuations sequences.private hashtables.private byte-arrays strings tools.test words continuations sequences.private
system random layouts vectors hashtables.private byte-arrays system random layouts vectors
sbufs strings.private slots.private alien math.order sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc io.encodings.ascii namespaces libc io.encodings.ascii classes compiler ;
classes compiler ;
IN: compiler.tests.intrinsics IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code. ! Make sure that intrinsic ops compile to correct code.
@ -271,6 +270,15 @@ cell 8 = [
[ 100000 swap array-nth ] compile-call [ 100000 swap array-nth ] compile-call
] unit-test ] 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 ! 64-bit overflow
cell 8 = [ cell 8 = [
[ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test

28
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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel effects accessors math math.private USING: kernel effects accessors math math.private
math.integers.private math.partial-dispatch math.intervals math.integers.private math.floats.private math.partial-dispatch
math.parser math.order math.functions math.libm layouts words math.intervals math.parser math.order math.functions math.libm
sequences sequences.private arrays assocs classes layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private classes.tuple alien.accessors classes.tuple.private
slots.private definitions strings.private vectors hashtables slots.private definitions strings.private vectors hashtables
@ -79,11 +79,16 @@ IN: compiler.tree.propagation.known-words
] unless ; ] unless ;
: ensure-math-class ( class must-be -- class' ) : ensure-math-class ( class must-be -- class' )
[ class<= ] 2keep ? ; [ class<= ] most ;
: number-valued ( class interval -- class' interval' ) : number-valued ( class interval -- class' interval' )
[ number ensure-math-class ] dip ; [ 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-valued ( class interval -- class' interval' )
[ integer ensure-math-class ] dip ; [ integer ensure-math-class ] dip ;
@ -303,3 +308,16 @@ generic-comparison-ops [
flog fpow fsqrt facosh fasinh fatanh } [ flog fpow fsqrt facosh fasinh fatanh } [
{ float } "default-output-classes" set-word-prop { float } "default-output-classes" set-word-prop
] each ] 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

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

@ -1,11 +1,12 @@
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences words fry generic accessors classes.tuple USING: kernel sequences words fry generic accessors
classes classes.algebra definitions stack-checker.state quotations classes.tuple classes classes.algebra definitions
classes.tuple.private math math.partial-dispatch math.private stack-checker.state quotations classes.tuple.private math
math.intervals layouts math.order vectors hashtables math.partial-dispatch math.private math.intervals
combinators effects generalizations assocs sets math.floats.private math.integers.private layouts math.order
combinators.short-circuit sequences.private locals vectors hashtables combinators effects generalizations assocs
sets combinators.short-circuit sequences.private locals
stack-checker namespaces compiler.tree.propagation.info ; stack-checker namespaces compiler.tree.propagation.info ;
IN: compiler.tree.propagation.transforms IN: compiler.tree.propagation.transforms
@ -79,6 +80,26 @@ IN: compiler.tree.propagation.transforms
] [ f ] if ] [ f ] if
] "custom-inlining" set-word-prop ] "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 ! Generate more efficient code for common idiom
\ clone [ \ clone [
in-d>> first value-info literal>> { in-d>> first value-info literal>> {

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

@ -96,6 +96,8 @@ HOOK: %shr cpu ( dst src1 src2 -- )
HOOK: %shr-imm cpu ( dst src1 src2 -- ) HOOK: %shr-imm cpu ( dst src1 src2 -- )
HOOK: %sar cpu ( dst src1 src2 -- ) HOOK: %sar cpu ( dst src1 src2 -- )
HOOK: %sar-imm 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: %not cpu ( dst src -- )
HOOK: %log2 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: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- ) HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %div-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: %sqrt cpu ( dst src -- )
HOOK: %integer>float 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 "Checking if your CPU supports SSE2..." print flush
sse2? [ sse2? [
" - yes" print " - yes" print
enable-float-intrinsics enable-sse2
enable-fsqrt
[ [
sse2? [ sse2? [
"This image was built to use SSE2, which your CPU does not support." print "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 enable-alien-4-intrinsics
! SSE2 is always available on x86-64. ! SSE2 is always available on x86-64.
enable-float-intrinsics enable-sse2
enable-fsqrt
USE: vocabs.loader USE: vocabs.loader

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

@ -123,6 +123,10 @@ M: x86 %xor-imm nip XOR ;
M: x86 %shl-imm nip SHL ; M: x86 %shl-imm nip SHL ;
M: x86 %shr-imm nip SHR ; M: x86 %shr-imm nip SHR ;
M: x86 %sar-imm nip SAR ; 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 %not drop NOT ;
M: x86 %log2 BSR ; M: x86 %log2 BSR ;
@ -203,6 +207,8 @@ M: x86 %add-float nip ADDSD ;
M: x86 %sub-float nip SUBSD ; M: x86 %sub-float nip SUBSD ;
M: x86 %mul-float nip MULSD ; M: x86 %mul-float nip MULSD ;
M: x86 %div-float nip DIVSD ; M: x86 %div-float nip DIVSD ;
M: x86 %min-float nip MINSD ;
M: x86 %max-float nip MAXSD ;
M: x86 %sqrt SQRTSD ; M: x86 %sqrt SQRTSD ;
M: x86 %integer>float CVTSI2SD ; 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 #! stack frame set up, and we want to read the frame
#! set up by the caller. #! set up by the caller.
stack-frame get total-size>> + stack@ ; stack-frame get total-size>> + stack@ ;
: enable-sse2 ( -- )
enable-float-intrinsics
enable-fsqrt
enable-float-min/max ;
enable-min/max

4
basis/math/intervals/intervals-tests.factor
View File

@ -235,6 +235,10 @@ IN: math.intervals.tests
interval-contains? interval-contains?
] unit-test ] 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 [ t ] [ 1 100 [a,b] -1 1 [a,b] interval/i [-inf,inf] = ] unit-test
! Accuracy of interval-mod ! Accuracy of interval-mod

22
basis/math/intervals/intervals.factor
View File

@ -7,7 +7,7 @@ IN: math.intervals
SYMBOL: empty-interval SYMBOL: empty-interval
SYMBOL: full-interval SINGLETON: full-interval
TUPLE: interval { from read-only } { to read-only } ; TUPLE: interval { from read-only } { to read-only } ;
@ -238,12 +238,24 @@ MEMO: array-capacity-interval ( -- interval )
] do-empty-interval ; ] do-empty-interval ;
: interval-max ( i1 i2 -- i3 ) : 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 ) : 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 ) : interval-interior ( i1 -- i2 )
dup special-interval? [ dup special-interval? [

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

@ -4,53 +4,54 @@ USING: alien ;
IN: math.libm IN: math.libm
: facos ( x -- y ) : facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ; "double" "libm" "acos" { "double" } alien-invoke ; inline
: fasin ( x -- y ) : fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ; "double" "libm" "asin" { "double" } alien-invoke ; inline
: fatan ( x -- y ) : fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ; "double" "libm" "atan" { "double" } alien-invoke ; inline
: fatan2 ( x y -- z ) : fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ; "double" "libm" "atan2" { "double" "double" } alien-invoke ; inline
: fcos ( x -- y ) : fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ; "double" "libm" "cos" { "double" } alien-invoke ; inline
: fsin ( x -- y ) : fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ; "double" "libm" "sin" { "double" } alien-invoke ; inline
: ftan ( x -- y ) : ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ; "double" "libm" "tan" { "double" } alien-invoke ; inline
: fcosh ( x -- y ) : fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ; "double" "libm" "cosh" { "double" } alien-invoke ; inline
: fsinh ( x -- y ) : fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ; "double" "libm" "sinh" { "double" } alien-invoke ; inline
: ftanh ( x -- y ) : ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ; "double" "libm" "tanh" { "double" } alien-invoke ; inline
: fexp ( x -- y ) : fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ; "double" "libm" "exp" { "double" } alien-invoke ; inline
: flog ( x -- y ) : flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ; "double" "libm" "log" { "double" } alien-invoke ; inline
: fpow ( x y -- z ) : 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 ) : fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ; "double" "libm" "sqrt" { "double" } alien-invoke ;
! Windows doesn't have these... ! Windows doesn't have these...
: facosh ( x -- y ) : facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ; "double" "libm" "acosh" { "double" } alien-invoke ; inline
: fasinh ( x -- y ) : fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ; "double" "libm" "asinh" { "double" } alien-invoke ; inline
: fatanh ( x -- y ) : 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 M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
: (nth-ptr) ( i struct-array -- alien ) : (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 M: struct-array nth-unsafe
[ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline [ (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 [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
M: struct-array new-sequence M: struct-array new-sequence
[ element-size>> [ * <byte-array> ] 2keep ] [ element-size>> [ * (byte-array) ] 2keep ]
[ class>> ] bi struct-array boa ; inline [ class>> ] bi struct-array boa ; inline
M: struct-array resize ( n seq -- newseq ) 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 ! (c)2009 Joe Groff bsd license
USING: accessors arrays assocs compiler.units USING: accessors arrays assocs compiler.units debugger init io
debugger init io kernel namespaces prettyprint sequences io.streams.null kernel namespaces prettyprint sequences
source-files.errors summary tools.crossref source-files.errors summary tools.crossref
tools.crossref.private tools.errors words ; tools.crossref.private tools.errors words ;
IN: tools.deprecation IN: tools.deprecation
@ -39,12 +39,14 @@ T{ error-type
: clear-deprecation-note ( word -- ) : clear-deprecation-note ( word -- )
deprecation-notes get-global delete-at ; deprecation-notes get-global delete-at ;
: check-deprecations ( word -- ) : check-deprecations ( usage -- )
dup "forgotten" word-prop dup word? [
[ clear-deprecation-note ] [ dup "forgotten" word-prop
dup def>> uses [ deprecated? ] filter [ clear-deprecation-note ] [
[ clear-deprecation-note ] [ >array deprecation-note ] if-empty dup def>> uses [ deprecated? ] filter
] if ; [ clear-deprecation-note ] [ >array deprecation-note ] if-empty
] if
] [ drop ] if ;
M: deprecated-usages summary M: deprecated-usages summary
drop "Deprecated words used" ; drop "Deprecated words used" ;
@ -58,8 +60,10 @@ M: deprecated-usages error.
SINGLETON: deprecation-observer SINGLETON: deprecation-observer
: initialize-deprecation-notes ( -- ) : 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 M: deprecation-observer definitions-changed
drop keys [ word? ] filter drop keys [ word? ] filter

3
core/math/floats/floats.factor
View File

@ -3,6 +3,9 @@
USING: kernel math math.private ; USING: kernel math math.private ;
IN: math.floats.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: fixnum >float fixnum>float ; inline
M: bignum >float bignum>float ; inline M: bignum >float bignum>float ; inline

5
core/math/integers/integers.factor
View File

@ -1,10 +1,13 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! Copyright (C) 2008, Doug Coleman. ! Copyright (C) 2008, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences USING: kernel kernel.private sequences
sequences.private math math.private combinators ; sequences.private math math.private combinators ;
IN: math.integers.private 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 numerator ; inline
M: integer denominator drop 1 ; inline M: integer denominator drop 1 ; 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 before=? ( obj1 obj2 -- ? ) <= ; inline
M: real after=? ( obj1 obj2 -- ? ) >= ; inline M: real after=? ( obj1 obj2 -- ? ) >= ; inline
: min ( x y -- z ) [ before? ] most ; inline : min ( x y -- z ) [ before? ] most ;
: max ( x y -- z ) [ after? ] most ; inline : max ( x y -- z ) [ after? ] most ;
: clamp ( x min max -- y ) [ max ] dip min ; inline : clamp ( x min max -- y ) [ max ] dip min ; inline
: between? ( x y z -- ? ) : 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

10
extra/benchmark/terrain-generation/terrain-generation.factor Normal file
View File

@ -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
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 kernel libc math namespaces system-info.backend
system-info.windows windows windows.advapi32 system-info.windows windows windows.advapi32
windows.kernel32 system byte-arrays windows.errors windows.kernel32 system byte-arrays windows.errors
classes classes.struct ; classes classes.struct accessors ;
IN: system-info.windows.nt IN: system-info.windows.nt
M: winnt cpus ( -- n ) M: winnt cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ; system-info dwNumberOfProcessors>> ;
: memory-status ( -- MEMORYSTATUSEX ) : memory-status ( -- MEMORYSTATUSEX )
"MEMORYSTATUSEX" <struct> "MEMORYSTATUSEX" <struct>

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

@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types kernel libc math namespaces USING: alien alien.c-types classes.struct accessors kernel
windows windows.kernel32 windows.advapi32 math namespaces windows windows.kernel32 windows.advapi32 words
words combinators vocabs.loader system-info.backend combinators vocabs.loader system-info.backend system
system alien.strings windows.errors ; alien.strings windows.errors ;
IN: system-info.windows IN: system-info.windows
: system-info ( -- SYSTEM_INFO ) : system-info ( -- SYSTEM_INFO )