diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 9d91215f3d..d4e8c5401a 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -44,6 +44,9 @@ M: word test-cfg nl ] each ; +: test-mr. ( quot -- ) + test-mr mr. ; inline + ! Prettyprinting : pprint-loc ( loc word -- ) > pprint* block> ; @@ -79,4 +82,4 @@ M: rs-loc pprint* \ R pprint-loc ; [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ] bi [ suffix ] when* ] map concat - ] map concat >hashtable representations set ; \ No newline at end of file + ] map concat >hashtable representations set ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index cf0f668db3..aefa155ec5 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -404,12 +404,12 @@ literal: rep ; PURE-INSN: ##shl-vector def: dst -use: src1 src2/scalar-rep +use: src1 src2/int-scalar-rep literal: rep ; PURE-INSN: ##shr-vector def: dst -use: src1 src2/scalar-rep +use: src1 src2/int-scalar-rep literal: rep ; ! Scalar/vector conversion diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index 51eced4e35..62ee1cf019 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -74,7 +74,9 @@ MACRO: if-literals-match ( quots -- ) : shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ; : emit-shuffle-vector ( node -- ) - [ ^^shuffle-vector ] [unary/param] + ! Pad the permutation with zeroes if its too short, since we + ! can't throw an error at this point. + [ [ rep-components 0 pad-tail ] keep ^^shuffle-vector ] [unary/param] { [ shuffle? ] [ representation? ] } if-literals-match ; : ^^broadcast-vector ( src n rep -- dst ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 006d38f384..de37cd6ee3 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -386,24 +386,24 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl "end" resolve-label ] with-scope ; -M: ppc %alien-unsigned-1 0 LBZ ; -M: ppc %alien-unsigned-2 0 LHZ ; +M: ppc %alien-unsigned-1 LBZ ; +M: ppc %alien-unsigned-2 LHZ ; -M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ; -M: ppc %alien-signed-2 0 LHA ; +M: ppc %alien-signed-1 [ dup ] 2dip LBZ dup EXTSB ; +M: ppc %alien-signed-2 LHA ; -M: ppc %alien-cell 0 LWZ ; +M: ppc %alien-cell LWZ ; -M: ppc %alien-float 0 LFS ; -M: ppc %alien-double 0 LFD ; +M: ppc %alien-float LFS ; +M: ppc %alien-double LFD ; -M: ppc %set-alien-integer-1 swap 0 STB ; -M: ppc %set-alien-integer-2 swap 0 STH ; +M: ppc %set-alien-integer-1 swapd STB ; +M: ppc %set-alien-integer-2 swapd STH ; -M: ppc %set-alien-cell swap 0 STW ; +M: ppc %set-alien-cell swapd STW ; -M: ppc %set-alien-float swap 0 STFS ; -M: ppc %set-alien-double swap 0 STFD ; +M: ppc %set-alien-float swapd STFS ; +M: ppc %set-alien-double swapd STFD ; : load-zone-ptr ( reg -- ) "nursery" %load-vm-field-addr ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index eaaab19662..3c20064313 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -317,13 +317,19 @@ M:: x86 %set-string-nth-fast ( ch str index temp -- ) : %alien-unsigned-getter ( dst src offset size -- ) [ MOVZX ] %alien-integer-getter ; inline +: %alien-signed-getter ( dst src offset size -- ) + [ MOVSX ] %alien-integer-getter ; inline + +:: %alien-integer-setter ( ptr offset value size -- ) + value { ptr } size [| new-value | + new-value value int-rep %copy + ptr offset [+] new-value size n-bit-version-of MOV + ] with-small-register ; inline + M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ; M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ; M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ; -: %alien-signed-getter ( dst src offset size -- ) - [ MOVSX ] %alien-integer-getter ; inline - M: x86 %alien-signed-1 8 %alien-signed-getter ; M: x86 %alien-signed-2 16 %alien-signed-getter ; M: x86 %alien-signed-4 32 %alien-signed-getter ; @@ -333,12 +339,6 @@ M: x86 %alien-float [+] MOVSS ; M: x86 %alien-double [+] MOVSD ; M: x86 %alien-vector [ [+] ] dip %copy ; -:: %alien-integer-setter ( ptr offset value size -- ) - value { ptr } size [| new-value | - new-value value int-rep %copy - ptr offset [+] new-value size n-bit-version-of MOV - ] with-small-register ; inline - M: x86 %set-alien-integer-1 8 %alien-integer-setter ; M: x86 %set-alien-integer-2 16 %alien-integer-setter ; M: x86 %set-alien-integer-4 32 %alien-integer-setter ; @@ -1045,8 +1045,20 @@ M: x86 %shr-vector-reps : scalar-sized-reg ( reg rep -- reg' ) rep-size 8 * n-bit-version-of ; -M: x86 %integer>scalar scalar-sized-reg MOVD ; -M: x86 %scalar>integer swap [ scalar-sized-reg ] dip MOVD ; +M: x86 %integer>scalar drop MOVD ; + +M:: x86 %scalar>integer ( dst src rep -- ) + rep { + { int-scalar-rep [ + dst 32-bit-version-of src MOVD + dst dst 32-bit-version-of + 2dup eq? [ 2drop ] [ MOVSX ] if + ] } + { uint-scalar-rep [ + dst 32-bit-version-of src MOVD + ] } + } case ; + M: x86 %vector>scalar %copy ; M: x86 %scalar>vector %copy ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 2377a6753a..678d55df61 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -181,20 +181,22 @@ M: word link-long-text : >topic ( obj -- topic ) dup topic? [ >link ] unless ; +: topic-span ( topic quot -- ) [ >topic ] dip ($span) ; inline + PRIVATE> -: ($link) ( topic -- ) >topic link-text ; +: ($link) ( topic -- ) [ link-text ] topic-span ; : $link ( element -- ) first ($link) ; -: ($long-link) ( topic -- ) >topic link-long-text ; +: ($long-link) ( topic -- ) [ link-long-text ] topic-span ; : $long-link ( element -- ) first ($long-link) ; : ($pretty-link) ( topic -- ) - >topic [ link-icon ] [ drop bl ] [ link-text ] tri ; + [ [ link-icon ] [ drop bl ] [ link-text ] tri ] topic-span ; : $pretty-link ( element -- ) first ($pretty-link) ; : ($long-pretty-link) ( topic -- ) - >topic [ link-icon ] [ drop bl ] [ link-long-text ] tri ; + [ [ link-icon ] [ drop bl ] [ link-long-text ] tri ] topic-span ; : <$pretty-link> ( definition -- element ) 1array \ $pretty-link prefix ; diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index ce17736d75..c676b9fe98 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -6,7 +6,7 @@ tools.test vocabs assocs compiler.cfg.debugger words locals math.vectors.specialization combinators cpu.architecture math.vectors.simd.intrinsics namespaces byte-arrays alien specialized-arrays classes.struct eval classes.algebra sets -quotations math.constants ; +quotations math.constants compiler.units ; QUALIFIED-WITH: alien.c-types c SPECIALIZED-ARRAY: c:float SIMD: c:char @@ -216,12 +216,27 @@ simd-classes&reps [ [ int-4{ 256 512 1024 2048 } ] [ int-4{ 1 2 4 8 } [ { int-4 } declare 1 hlshift ] compile-call ] unit-test +[ int-4{ 256 512 1024 2048 } ] +[ int-4{ 1 2 4 8 } 1 [ { int-4 fixnum } declare hlshift ] compile-call ] unit-test + [ int-4{ 1 2 4 8 } ] [ int-4{ 256 512 1024 2048 } 1 hrshift ] unit-test [ int-4{ 1 2 4 8 } ] [ int-4{ 256 512 1024 2048 } [ { int-4 } declare 1 hrshift ] compile-call ] unit-test +[ int-4{ 1 2 4 8 } ] +[ int-4{ 256 512 1024 2048 } 1 [ { int-4 fixnum } declare hrshift ] compile-call ] unit-test + +! Invalid inputs should not cause the compiler to throw errors +[ ] [ + [ [ { int-4 } declare t hrshift ] (( a -- b )) define-temp drop ] with-compilation-unit +] unit-test + +[ ] [ + [ [ { int-4 } declare { 3 2 1 } vshuffle ] (( a -- b )) define-temp drop ] with-compilation-unit +] unit-test + ! Shuffles : shuffles-for ( n -- shuffles ) { @@ -278,6 +293,7 @@ simd-classes [ [ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test [ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test +[ -8 ] [ int-4{ HEX: 7fffffff 3 4 -8 } last ] unit-test [ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test [ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test @@ -313,6 +329,9 @@ simd-classes [ [ { } ] [ longlong-4{ 1 2 3 4 } test-broadcast ] unit-test [ { } ] [ ulonglong-4{ 1 2 3 4 } test-broadcast ] unit-test +! Make sure we use the fallback in the correct situations +[ int-4{ 3 3 3 3 } ] [ int-4{ 12 34 3 17 } 2 [ { int-4 fixnum } declare vbroadcast ] compile-call ] unit-test + "== Checking alien operations" print [ float-4{ 1 2 3 4 } ] [ diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index ea9947a0c5..b07615bfc9 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -14,7 +14,7 @@ SYMBOLS: -> +vector+ +scalar+ +nonnegative+ +literal+ ; { +vector+ [ drop ] } { +scalar+ [ nip ] } { +nonnegative+ [ nip ] } - { +literal+ [ 2drop object ] } + { +literal+ [ 2drop f ] } } case ] with with map ; @@ -136,7 +136,7 @@ ERROR: bad-vector-word word ; [ { } ] } cond ! Don't specialize horizontal shifts or shuffles at all, they're only for SIMD - { hlshift hrshift vshuffle } diff + { hlshift hrshift vshuffle vbroadcast } diff nip ; :: specialize-vector-words ( array-type elt-type simd -- ) @@ -147,13 +147,16 @@ ERROR: bad-vector-word word ; tri add-specialization ] each ; +: specialization-matches? ( value-infos signature -- ? ) + [ [ [ class>> ] dip class<= ] [ literal?>> ] if* ] 2all? ; + : find-specialization ( classes word -- word/f ) specializations - [ first [ class<= ] 2all? ] with find + [ first specialization-matches? ] with find swap [ second ] when ; : vector-word-custom-inlining ( #call -- word/f ) - [ in-d>> [ value-info class>> ] map ] [ word>> ] bi + [ in-d>> [ value-info ] map ] [ word>> ] bi find-specialization ; vector-words keys [ diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index cd539a14e4..1d323822bd 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -1,10 +1,21 @@ USING: help.markup help.syntax math math.functions sequences ; IN: math.vectors -ARTICLE: "math-vectors" "Vector arithmetic" -"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used." -$nl -"Acting on vectors by a scalar:" +ARTICLE: "math-vectors-arithmetic" "Vector arithmetic" +"Vector/vector binary operations:" +{ $subsection v+ } +{ $subsection v- } +{ $subsection v+- } +{ $subsection v* } +{ $subsection v/ } +"Vector unary operations:" +{ $subsection vneg } +{ $subsection vabs } +{ $subsection vsqrt } +{ $subsection vfloor } +{ $subsection vceiling } +{ $subsection vtruncate } +"Vector/scalar and scalar/vector binary operations:" { $subsection vneg } { $subsection v*n } { $subsection n*v } @@ -14,24 +25,21 @@ $nl { $subsection n+v } { $subsection v-n } { $subsection n-v } -"Vector unary operations:" -{ $subsection vneg } -{ $subsection vabs } -{ $subsection vsqrt } -{ $subsection vfloor } -{ $subsection vceiling } -{ $subsection vtruncate } -"Vector/vector binary operations:" -{ $subsection v+ } -{ $subsection v- } -{ $subsection v+- } -{ $subsection v* } -{ $subsection v/ } "Saturated arithmetic (only on " { $link "specialized-arrays" } "):" { $subsection vs+ } { $subsection vs- } { $subsection vs* } -"Componentwise vector operations:" +"Inner product and norm:" +{ $subsection v. } +{ $subsection norm } +{ $subsection norm-sq } +{ $subsection normalize } +"Comparing entire vectors:" +{ $subsection distance } +{ $subsection v~ } ; + +ARTICLE: "math-vectors-logic" "Vector componentwise logic" +"Element comparisons:" { $subsection v< } { $subsection v<= } { $subsection v= } @@ -40,6 +48,8 @@ $nl { $subsection vunordered? } { $subsection vmax } { $subsection vmin } +{ $subsection vsupremum } +{ $subsection vinfimum } "Bitwise operations:" { $subsection vbitand } { $subsection vbitandn } @@ -47,31 +57,29 @@ $nl { $subsection vbitxor } { $subsection vlshift } { $subsection vrshift } -"Componentwise logical operations:" +"Element logical operations:" { $subsection vand } { $subsection vor } { $subsection vxor } { $subsection vmask } { $subsection v? } -"Shuffling:" -{ $subsection vshuffle } -"Inner product and norm:" -{ $subsection v. } -{ $subsection norm } -{ $subsection norm-sq } -{ $subsection normalize } -"Comparing entire vectors:" -{ $subsection distance } -{ $subsection v~ } -"Other functions:" -{ $subsection vsupremum } -{ $subsection vinfimum } +"Element shuffling:" +{ $subsection vshuffle } ; + +ARTICLE: "math-vectors-misc" "Miscellaneous vector functions" { $subsection trilerp } { $subsection bilerp } { $subsection vlerp } { $subsection vnlerp } { $subsection vbilerp } ; + +ARTICLE: "math-vectors" "Vector operations" +"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used." +{ $subsection "math-vectors-arithmetic" } +{ $subsection "math-vectors-logic" } +{ $subsection "math-vectors-misc" } ; + ABOUT: "math-vectors" HELP: vneg diff --git a/basis/random/dummy/dummy-tests.factor b/basis/random/dummy/dummy-tests.factor new file mode 100644 index 0000000000..5d4b4b5473 --- /dev/null +++ b/basis/random/dummy/dummy-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: random random.dummy tools.test ; +IN: random.dummy.tests + +[ 10 ] [ 10 random-32* ] unit-test +[ 100 ] [ 10 100 seed-random random-32* ] unit-test diff --git a/basis/random/dummy/dummy.factor b/basis/random/dummy/dummy.factor index e6661dc078..988bd015d0 100644 --- a/basis/random/dummy/dummy.factor +++ b/basis/random/dummy/dummy.factor @@ -4,8 +4,8 @@ IN: random.dummy TUPLE: random-dummy i ; C: random-dummy -M: random-dummy seed-random ( seed obj -- ) - (>>i) ; +M: random-dummy seed-random ( obj seed -- obj ) + >>i ; M: random-dummy random-32* ( obj -- r ) [ dup 1 + ] change-i drop ; diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index 651e43ef5b..b877af6f79 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -27,3 +27,9 @@ IN: random.mersenne-twister.tests [ 3 ] [ 101 [ 3 random-bytes length ] test-rng ] unit-test [ 33 ] [ 101 [ 33 random-bytes length ] test-rng ] unit-test [ t ] [ 101 [ 100 random-bits log2 90 > ] test-rng ] unit-test + +[ t ] +[ + 1234 + [ random-32* ] [ 1234 seed-random random-32* ] bi = +] unit-test diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index e29f97ef2e..51112ae980 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -62,15 +62,21 @@ PRIVATE> init-mt-seq 0 mersenne-twister boa dup mt-generate ; -M: mersenne-twister seed-random ( mt seed -- ) - init-mt-seq >>seq drop ; +M: mersenne-twister seed-random ( mt seed -- mt' ) + init-mt-seq >>seq + [ mt-generate ] + [ 0 >>i drop ] + [ ] tri ; M: mersenne-twister random-32* ( mt -- r ) [ next-index ] [ seq>> nth-unsafe mt-temper ] [ [ 1 + ] change-i drop ] tri ; -[ +: default-mersenne-twister ( -- mersenne-twister ) [ 32 random-bits ] with-system-random - random-generator set-global + ; + +[ + default-mersenne-twister random-generator set-global ] "bootstrap.random" add-init-hook diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index bb0fc57312..cd645750db 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -2,8 +2,12 @@ USING: help.markup help.syntax math kernel sequences ; IN: random HELP: seed-random -{ $values { "tuple" "a random number generator" } { "seed" "an integer between 0 and 2^32-1" } } -{ $description "Seed the random number generator." } +{ $values + { "tuple" "a random number generator" } + { "seed" "a seed specific to the random number generator" } + { "tuple'" "a random number generator" } +} +{ $description "Seed the random number generator. Repeatedly seeding the random number generator should provide the same sequence of random numbers." } { $notes "Not supported on all random number generators." } ; HELP: random-32* @@ -29,6 +33,10 @@ HELP: random "heads" } } ; +HELP: random-32 +{ $values { "n" "a 32-bit random integer" } } +{ $description "Outputs 32 random bits. This word is more efficient than calling " { $link random } " because no scaling is done on the output." } ; + HELP: random-bytes { $values { "n" "an integer" } { "byte-array" "a random integer" } } { $description "Outputs an integer with n bytes worth of bits." } @@ -104,6 +112,8 @@ $nl $nl "Generate a random object:" { $subsection random } +"Efficient 32-bit random numbers:" +{ $subsection random-32 } "Combinators to change the random number generator:" { $subsection with-random } { $subsection with-system-random } diff --git a/basis/random/random.factor b/basis/random/random.factor index afdf0b43ba..1f2408556f 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -10,7 +10,7 @@ SYMBOL: system-random-generator SYMBOL: secure-random-generator SYMBOL: random-generator -GENERIC: seed-random ( tuple seed -- ) +GENERIC# seed-random 1 ( tuple seed -- tuple' ) GENERIC: random-32* ( tuple -- r ) GENERIC: random-bytes* ( n tuple -- byte-array ) @@ -55,6 +55,8 @@ PRIVATE> [ length random-integer ] keep nth ] if-empty ; +: random-32 ( -- n ) random-generator get random-32* ; + : randomize ( seq -- seq ) dup length [ dup 1 > ] [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ] diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor index cd720d74d4..4e65e74c2c 100644 --- a/basis/unix/statfs/openbsd/openbsd.factor +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax unix.types unix.stat classes.struct ; +USING: alien.c-types alien.syntax unix.types classes.struct +unix.stat ; IN: unix.statfs.openbsd CONSTANT: MFSNAMELEN 16 @@ -30,4 +31,4 @@ STRUCT: statfs { f_mntfromname { char MNAMELEN } } { mount_info char[160] } ; -FUNCTION: int statfs ( char* path, statvfs* buf ) ; +FUNCTION: int statfs ( char* path, statfs* buf ) ; diff --git a/basis/windows/com/com-tests.factor b/basis/windows/com/com-tests.factor index 289581a929..ae8ef62c16 100644 --- a/basis/windows/com/com-tests.factor +++ b/basis/windows/com/com-tests.factor @@ -37,13 +37,13 @@ TUPLE: test-implementation x ; C: test-implementation { - { "IInherited" { + { IInherited { [ drop S_OK ] ! ISimple::returnOK [ drop E_FAIL ] ! ISimple::returnError [ x>> ] ! IInherited::getX [ >>x drop ] ! IInherited::setX } } - { "IUnrelated" { + { IUnrelated { [ swap x>> + ] ! IUnrelated::xPlus [ spin x>> * + ] ! IUnrelated::xMulAdd } } @@ -85,7 +85,7 @@ dup +test-wrapper+ set [ +guinea-pig-implementation+ get ISimple-iid com-query-interface dup com-release ] unit-test - "void*" heap-size +guinea-pig-implementation+ get + void* heap-size +guinea-pig-implementation+ get +guinea-pig-implementation+ get 2array [ +guinea-pig-implementation+ get IUnrelated-iid com-query-interface diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index e4f0ef0654..27672df833 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -52,13 +52,13 @@ unless swap GUID memory>struct _ case [ - "void*" heap-size * rot com-add-ref + void* heap-size * rot com-add-ref swap 0 set-alien-cell S_OK ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if* ] ; : (make-add-ref) ( interfaces -- quot ) - length "void*" heap-size * '[ + length void* heap-size * '[ _ [ alien-unsigned-4 1 + dup ] [ set-alien-unsigned-4 ] @@ -66,7 +66,7 @@ unless ] ; : (make-release) ( interfaces -- quot ) - length "void*" heap-size * '[ + length void* heap-size * '[ _ [ drop ] [ alien-unsigned-4 1 - dup ] @@ -84,7 +84,7 @@ unless : (thunk) ( n -- quot ) dup 0 = [ drop [ ] ] - [ "void*" heap-size neg * '[ _ swap ] ] + [ void* heap-size neg * '[ _ swap ] ] if ; : (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s ) @@ -97,15 +97,15 @@ unless [ [ (( -- alien )) define-declared ] pick [ call ] dip ] with-compilation-unit ; -: (callback-word) ( function-name interface-name counter -- word ) - [ "::" rot 3append "-callback-" ] dip number>string 3append +: (callback-word) ( function-name interface counter -- word ) + [ name>> "::" rot 3append "-callback-" ] dip number>string 3append "windows.com.wrapper.callbacks" create ; : (finish-thunk) ( param-count thunk quot -- thunked-quot ) [ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ] dip compose ; -: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words ) +: (make-interface-callbacks) ( interface quots iunknown-methods n -- words ) (thunk) (thunked-quots) swap [ find-com-interface-definition family-tree-functions ] keep (next-vtbl-counter) '[ @@ -128,8 +128,8 @@ unless curry map-index ; : (malloc-wrapped-object) ( wrapper -- wrapped-object ) - vtbls>> length "void*" heap-size * - [ "ulong" heap-size + malloc ] keep + vtbls>> length void* heap-size * + [ ulong heap-size + malloc ] keep [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor index a05bf3a685..4ffd6f4427 100644 --- a/core/checksums/checksums-docs.factor +++ b/core/checksums/checksums-docs.factor @@ -20,15 +20,39 @@ HELP: checksum-stream HELP: checksum-bytes { $values { "bytes" "a sequence of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } } -{ $contract "Computes the checksum of all data in a sequence." } ; +{ $contract "Computes the checksum of all data in a sequence." } +{ $examples + { $example + "USING: checksums checksums.crc32 prettyprint ;" + "B{ 1 10 100 } crc32 checksum-bytes ." + "B{ 78 179 254 238 }" + } +} ; HELP: checksum-lines { $values { "lines" "a sequence of sequences of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } } -{ $contract "Computes the checksum of all data in a sequence." } ; +{ $contract "Computes the checksum of all data in a sequence." } +{ $examples + { $example + "USING: checksums checksums.crc32 prettyprint ;" +"""{ + "Take me out to the ball game" + "Take me out with the crowd" +} crc32 checksum-lines .""" + "B{ 111 205 9 27 }" + } +} ; HELP: checksum-file { $values { "path" "a pathname specifier" } { "checksum" "a checksum specifier" } { "value" byte-array } } -{ $contract "Computes the checksum of all data in a file." } ; +{ $contract "Computes the checksum of all data in a file." } +{ $examples + { $example + "USING: checksums checksums.crc32 prettyprint ;" + """"resource:license.txt" crc32 checksum-file .""" + "B{ 100 139 199 92 }" + } +} ; ARTICLE: "checksums" "Checksums" "A " { $emphasis "checksum" } " is a function mapping sequences of bytes to fixed-length strings. While checksums are not one-to-one, a good checksum should have a low probability of collision. Additionally, some checksum algorithms are designed to be hard to reverse, in the sense that finding an input string which hashes to a given checksum string requires a brute-force search." diff --git a/extra/benchmark/3d-matrix-scalar/3d-matrix-scalar.factor b/extra/benchmark/3d-matrix-scalar/3d-matrix-scalar.factor new file mode 100644 index 0000000000..d629eda6bd --- /dev/null +++ b/extra/benchmark/3d-matrix-scalar/3d-matrix-scalar.factor @@ -0,0 +1,23 @@ +USING: kernel locals math math.matrices math.order math.vectors +prettyprint sequences ; +IN: benchmark.3d-matrix-scalar + +:: p-matrix ( dim fov near far -- matrix ) + dim dup first2 min v/n fov v*n near v*n + near far frustum-matrix4 ; + +:: mv-matrix ( pitch yaw location -- matrix ) + { 1.0 0.0 0.0 } pitch rotation-matrix4 + { 0.0 1.0 0.0 } yaw rotation-matrix4 + location vneg translation-matrix4 m. m. ; + +:: 3d-matrix ( -- ) + f :> result! + 100000 [ + { 1024.0 768.0 } 0.7 0.25 1024.0 p-matrix :> p + 3.0 1.0 { 10.0 -0.0 2.0 } mv-matrix :> mv + mv p m. result! + ] times + result . ; + +MAIN: 3d-matrix diff --git a/extra/benchmark/3d-matrix-vector/3d-matrix-vector.factor b/extra/benchmark/3d-matrix-vector/3d-matrix-vector.factor new file mode 100644 index 0000000000..1b57bb902f --- /dev/null +++ b/extra/benchmark/3d-matrix-vector/3d-matrix-vector.factor @@ -0,0 +1,28 @@ +USING: kernel locals math math.matrices.simd math.order math.vectors +math.vectors.simd prettyprint sequences typed ; +QUALIFIED-WITH: alien.c-types c +SIMD: c:float +IN: benchmark.3d-matrix-vector + +: v2min ( xy -- xx ) + dup { 1 0 2 3 } vshuffle vmin ; inline + +TYPED:: p-matrix ( dim: float-4 fov: float near: float far: float -- matrix: matrix4 ) + dim dup v2min v/ fov v*n near v*n + near far frustum-matrix4 ; + +TYPED:: mv-matrix ( pitch: float yaw: float location: float-4 -- matrix: matrix4 ) + float-4{ 1.0 0.0 0.0 0.0 } pitch rotation-matrix4 + float-4{ 0.0 1.0 0.0 0.0 } yaw rotation-matrix4 + location vneg translation-matrix4 m4. m4. ; + +:: 3d-matrix ( -- ) + f :> result! + 100000 [ + float-4{ 1024.0 768.0 0.0 0.0 } 0.7 0.25 1024.0 p-matrix :> p + 3.0 1.0 float-4{ 10.0 -0.0 2.0 0.0 } mv-matrix :> mv + mv p m4. result! + ] times + result . ; + +MAIN: 3d-matrix diff --git a/extra/benchmark/matrix-exponential-scalar/matrix-exponential-scalar.factor b/extra/benchmark/matrix-exponential-scalar/matrix-exponential-scalar.factor new file mode 100644 index 0000000000..de4bf1ffe7 --- /dev/null +++ b/extra/benchmark/matrix-exponential-scalar/matrix-exponential-scalar.factor @@ -0,0 +1,24 @@ +USING: locals math math.combinatorics math.matrices +prettyprint sequences typed ; +IN: benchmark.matrix-exponential-scalar + +:: e^m ( m iterations -- e^m ) + { + { 0.0 0.0 0.0 0.0 } + { 0.0 0.0 0.0 0.0 } + { 0.0 0.0 0.0 0.0 } + { 0.0 0.0 0.0 0.0 } + } + iterations iota [| i | + m i m^n i factorial >float m/n m+ + ] each ; + +:: matrix-e ( -- ) + f :> result! + 4 identity-matrix :> i4 + 10000 [ + i4 20 e^m result! + ] times + result . ; + +MAIN: matrix-e diff --git a/extra/benchmark/matrix-exponential-simd/matrix-exponential-simd.factor b/extra/benchmark/matrix-exponential-simd/matrix-exponential-simd.factor new file mode 100644 index 0000000000..a23b3f2843 --- /dev/null +++ b/extra/benchmark/matrix-exponential-simd/matrix-exponential-simd.factor @@ -0,0 +1,18 @@ +USING: locals math math.combinatorics math.matrices.simd +prettyprint sequences typed ; +IN: benchmark.matrix-exponential-simd + +TYPED:: e^m4 ( m: matrix4 iterations: fixnum -- e^m: matrix4 ) + zero-matrix4 + iterations iota [| i | + m i m4^n i factorial >float m4/n m4+ + ] each ; + +:: matrix-e ( -- ) + f :> result! + 10000 [ + identity-matrix4 20 e^m4 result! + ] times + result . ; + +MAIN: matrix-e diff --git a/extra/math/matrices/simd/simd.factor b/extra/math/matrices/simd/simd.factor index 014cd86265..0c4c3e1866 100644 --- a/extra/math/matrices/simd/simd.factor +++ b/extra/math/matrices/simd/simd.factor @@ -1,6 +1,6 @@ ! (c)Joe Groff bsd license USING: accessors classes.struct generalizations kernel locals -math math.functions math.matrices.simd math.vectors +math math.combinatorics math.functions math.matrices.simd math.vectors math.vectors.simd sequences sequences.private specialized-arrays typed ; QUALIFIED-WITH: alien.c-types c @@ -105,6 +105,19 @@ CONSTANT: identity-matrix4 } } +CONSTANT: zero-matrix4 + S{ matrix4 f + float-4-array{ + float-4{ 0.0 0.0 0.0 0.0 } + float-4{ 0.0 0.0 0.0 0.0 } + float-4{ 0.0 0.0 0.0 0.0 } + float-4{ 0.0 0.0 0.0 0.0 } + } + } + +TYPED:: m4^n ( m: matrix4 n: fixnum -- m^n: matrix4 ) + identity-matrix4 n [ m m4. ] times ; + TYPED:: scale-matrix4 ( factors: float-4 -- matrix: matrix4 ) matrix4 (struct) :> c diff --git a/extra/project-euler/051/051.factor b/extra/project-euler/051/051.factor new file mode 100644 index 0000000000..b42a491e3c --- /dev/null +++ b/extra/project-euler/051/051.factor @@ -0,0 +1,58 @@ +! Copyright (C) 2009 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel math math.combinatorics math.functions +math.parser math.primes namespaces project-euler.common +sequences sets strings grouping math.ranges arrays ; +IN: project-euler.051 + +SYMBOL: family-count +SYMBOL: large-families +: reset-globals ( -- ) + H{ } clone family-count set + H{ } clone large-families set ; + +: append-or-create ( value seq/f -- seq ) + dup [ swap suffix ] [ drop 1array ] if ; +: append-at ( value key assoc -- ) + [ at append-or-create ] 2keep set-at ; +: digits-positions ( str -- positions ) + H{ } clone swap over [ swapd append-at ] curry each-index ; + +: *-if-index ( char combination index -- char ) + member? [ drop CHAR: * ] when ; +: replace-positions-with-* ( str positions -- str ) + [ *-if-index ] curry map-index ; +: all-size-combinations ( seq -- combinations ) + dup length [1,b] [ all-combinations ] with map concat ; + +: families ( stra -- seq ) + dup digits-positions values + [ all-size-combinations [ replace-positions-with-* ] with map ] with map concat ; + +: save-family ( family -- ) + family-count get dupd at 8 = [ large-families get conjoin ] [ drop ] if ; +: increment-family ( family -- ) + family-count get dupd at* [ 1 + ] [ drop 1 ] if swap family-count get set-at ; +: handle-family ( family -- ) + [ increment-family ] [ save-family ] bi ; + +! Test all primes that have length n +: n-digits-primes ( n -- primes ) + [ 1 - 10^ ] [ 10^ ] bi primes-between ; +: test-n-digits-primes ( n -- seq ) + reset-globals + n-digits-primes + [ number>string families [ handle-family ] each ] each + large-families get ; + +: fill-*-with-ones ( str -- str ) + [ dup CHAR: * = [ drop CHAR: 1 ] when ] map ; + +! recursively test all primes by length until we find an answer +: (euler051) ( i -- answer ) + dup test-n-digits-primes + dup assoc-size 0 > + [ nip values [ fill-*-with-ones string>number ] map infimum ] + [ drop 1 + (euler051) ] if ; +: euler051 ( -- answer ) + 2 (euler051) ; diff --git a/extra/typed/debugger/debugger.factor b/extra/typed/debugger/debugger.factor index 452af16a2e..c5f83c0378 100644 --- a/extra/typed/debugger/debugger.factor +++ b/extra/typed/debugger/debugger.factor @@ -4,5 +4,7 @@ IN: typed.debugger : typed-test-mr ( word -- mrs ) "typed-word" word-prop test-mr ; inline +: typed-test-mr. ( word -- ) + "typed-word" word-prop test-mr mr. ; inline : typed-optimized. ( word -- ) "typed-word" word-prop optimized. ; inline