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

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

db4
Jon Harper 2009-10-04 15:23:56 +09:00
parent d75be8defe 7ed8f00b0f
commit 0dbbc6bbe5
37 changed files with 556 additions and 133 deletions

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

@ -280,6 +280,16 @@ def: dst
use: src
literal: shuffle rep ;
PURE-INSN: ##merge-vector-head
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##merge-vector-tail
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##compare-vector
def: dst
use: src1 src2

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

@ -194,6 +194,8 @@ IN: compiler.cfg.intrinsics
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
{ math.vectors.simd.intrinsics:(simd-vshuffle) [ emit-shuffle-vector ] }
{ math.vectors.simd.intrinsics:(simd-vmerge-head) [ [ ^^merge-vector-head ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmerge-tail) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] }
{ math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }

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

@ -163,6 +163,8 @@ CODEGEN: ##zero-vector %zero-vector
CODEGEN: ##gather-vector-2 %gather-vector-2
CODEGEN: ##gather-vector-4 %gather-vector-4
CODEGEN: ##shuffle-vector %shuffle-vector
CODEGEN: ##merge-vector-head %merge-vector-head
CODEGEN: ##merge-vector-tail %merge-vector-tail
CODEGEN: ##compare-vector %compare-vector
CODEGEN: ##test-vector %test-vector
CODEGEN: ##add-vector %add-vector

2
basis/compiler/tree/propagation/simd/simd.factor
View File

@ -31,6 +31,8 @@ IN: compiler.tree.propagation.simd
(simd-hlshift)
(simd-hrshift)
(simd-vshuffle)
(simd-vmerge-head)
(simd-vmerge-tail)
(simd-v<=)
(simd-v<)
(simd-v=)

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

@ -218,6 +218,8 @@ HOOK: %fill-vector cpu ( dst rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
HOOK: %shuffle-vector cpu ( dst src shuffle rep -- )
HOOK: %merge-vector-head cpu ( dst src1 src2 rep -- )
HOOK: %merge-vector-tail cpu ( dst src1 src2 rep -- )
HOOK: %compare-vector cpu ( dst src1 src2 temp rep cc -- )
HOOK: %test-vector cpu ( dst src1 temp rep vcc -- )
HOOK: %test-vector-branch cpu ( label src1 temp rep vcc -- )
@ -256,6 +258,7 @@ HOOK: %fill-vector-reps cpu ( -- reps )
HOOK: %gather-vector-2-reps cpu ( -- reps )
HOOK: %gather-vector-4-reps cpu ( -- reps )
HOOK: %shuffle-vector-reps cpu ( -- reps )
HOOK: %merge-vector-reps cpu ( -- reps )
HOOK: %compare-vector-reps cpu ( cc -- reps )
HOOK: %test-vector-reps cpu ( -- reps )
HOOK: %add-vector-reps cpu ( -- reps )

1
basis/cpu/ppc/ppc.factor
View File

@ -262,6 +262,7 @@ M: ppc %fill-vector-reps { } ;
M: ppc %gather-vector-2-reps { } ;
M: ppc %gather-vector-4-reps { } ;
M: ppc %shuffle-vector-reps { } ;
M: ppc %merge-vector-reps { } ;
M: ppc %compare-vector-reps drop { } ;
M: ppc %test-vector-reps { } ;
M: ppc %add-vector-reps { } ;

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

@ -721,6 +721,34 @@ M: x86 %shuffle-vector-reps
{ sse2? { double-2-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %merge-vector-head
[ two-operand ] keep
unsign-rep {
{ double-2-rep [ UNPCKLPD ] }
{ float-4-rep [ UNPCKLPS ] }
{ longlong-2-rep [ PUNPCKLQDQ ] }
{ int-4-rep [ PUNPCKLDQ ] }
{ short-8-rep [ PUNPCKLWD ] }
{ char-16-rep [ PUNPCKLBW ] }
} case ;
M: x86 %merge-vector-tail
[ two-operand ] keep
unsign-rep {
{ double-2-rep [ UNPCKHPD ] }
{ float-4-rep [ UNPCKHPS ] }
{ longlong-2-rep [ PUNPCKHQDQ ] }
{ int-4-rep [ PUNPCKHDQ ] }
{ short-8-rep [ PUNPCKHWD ] }
{ char-16-rep [ PUNPCKHBW ] }
} case ;
M: x86 %merge-vector-reps
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
:: compare-float-v-operands ( dst src1 src2 temp rep cc -- dst' src' rep cc' )
cc { cc> cc>= cc/> cc/>= } member?
[ dst src2 src1 rep two-operand rep cc swap-cc ]

3
basis/io/backend/unix/unix.factor
View File

@ -49,6 +49,9 @@ M: fd cancel-operation ( fd -- )
2bi
] if ;
M: unix tell-handle ( handle -- n )
fd>> 0 SEEK_CUR lseek [ io-error ] [ ] bi ;
M: unix seek-handle ( n seek-type handle -- )
swap {
{ io:seek-absolute [ SEEK_SET ] }

6
basis/io/ports/ports.factor
View File

@ -124,8 +124,14 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- )
HOOK: tell-handle os ( handle -- n )
HOOK: seek-handle os ( n seek-type handle -- )
M: buffered-port stream-tell ( stream -- n )
[ check-disposed ]
[ handle>> tell-handle ]
[ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ;
M: input-port stream-seek ( n seek-type stream -- )
[ check-disposed ]
[ buffer>> 0 swap buffer-reset ]

1
basis/io/streams/duplex/duplex.factor
View File

@ -44,4 +44,3 @@ M: duplex-stream underlying-handle
>duplex-stream<
[ underlying-handle ] bi@
[ = [ invalid-duplex-stream ] when ] keep ;

17
basis/io/streams/limited/limited-docs.factor
View File

@ -24,7 +24,22 @@ HELP: limit
" \"123456\" <string-reader> 3 stream-throws limit"
" 100 swap stream-read ."
"] [ ] recover ."
"T{ limit-exceeded }"
"""T{ limit-exceeded
{ n 1 }
{ stream
T{ limited-stream
{ stream
T{ string-reader
{ underlying "123456" }
{ i 3 }
}
}
{ mode stream-throws }
{ count 4 }
{ limit 3 }
}
}
}"""
}
"Returning " { $link f } " on exhaustion:"
{ $example

133
basis/io/streams/limited/limited-tests.factor
View File

@ -1,7 +1,8 @@
USING: io io.streams.limited io.encodings io.encodings.string
io.encodings.ascii io.encodings.binary io.streams.byte-array
namespaces tools.test strings kernel io.streams.string accessors
io.encodings.utf8 io.files destructors ;
USING: accessors continuations destructors io io.encodings
io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files io.pipes
io.streams.byte-array io.streams.limited io.streams.string
kernel namespaces strings tools.test system ;
IN: io.streams.limited.tests
[ ] [
@ -89,3 +90,127 @@ IN: io.streams.limited.tests
unlimited-input contents
] with-input-stream
] unit-test
[ 4 ] [
"abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
4 seek-relative seek-input tell-input
] with-input-stream
] unit-test
[
"abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
4 seek-relative seek-input
4 read
] with-input-stream
] [
limit-exceeded?
] must-fail-with
[
"abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
4 seek-relative seek-input
-2 seek-relative
2 read
] with-input-stream
] [
limit-exceeded?
] must-fail-with
[
"abcdefgh" <string-reader> [
4 seek-relative seek-input
2 stream-throws limit-input
-2 seek-relative seek-input
2 read
] with-input-stream
] [
limit-exceeded?
] must-fail-with
[ "ef" ] [
"abcdefgh" <string-reader> [
4 seek-relative seek-input
2 stream-throws limit-input
4 seek-absolute seek-input
2 read
] with-input-stream
] unit-test
[ "ef" ] [
"abcdefgh" <string-reader> [
4 seek-absolute seek-input
2 stream-throws limit-input
2 seek-absolute seek-input
4 seek-absolute seek-input
2 read
] with-input-stream
] unit-test
! stream-throws, pipes are duplex and not seekable
[ "as" ] [
latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[
latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] [
limit-exceeded?
] must-fail-with
! stream-eofs, pipes are duplex and not seekable
[ "as" ] [
latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[ "as" ] [
latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
! test seeking on limited unseekable streams
[ "as" ] [
latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[ "as" ] [
latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
[
latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
2 seek-absolute rot in>> stream-seek
] must-fail
[
"as"
] [
latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
[ 2 seek-absolute rot in>> stream-seek ] [ drop ] recover
2 swap stream-read
] unit-test
[ 7 ] [
image binary stream-throws <limited-file-reader> [
7 read drop
tell-input
] with-input-stream
] unit-test
[ 70000 ] [
image binary stream-throws <limited-file-reader> [
70000 read drop
tell-input
] with-input-stream
] unit-test

72
basis/io/streams/limited/limited.factor
View File

@ -2,11 +2,14 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-vectors combinators destructors fry io
io.encodings io.files io.files.info kernel math namespaces
sequences ;
io.encodings io.files io.files.info kernel locals math
namespaces sequences ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit mode stack ;
TUPLE: limited-stream
stream mode
count limit
current start stop ;
SINGLETONS: stream-throws stream-eofs ;
@ -51,13 +54,27 @@ M: object unlimited ( stream -- stream' )
: with-limited-stream ( stream limit mode quot -- )
[ limit ] dip call ; inline
ERROR: limit-exceeded ;
ERROR: limit-exceeded n stream ;
ERROR: bad-stream-mode mode ;
<PRIVATE
: adjust-limit ( n stream -- n' stream )
: adjust-current-limit ( n stream -- n' stream )
2dup [ + ] change-current
[ current>> ] [ stop>> ] bi >
[
dup mode>> {
{ stream-throws [ limit-exceeded ] }
{ stream-eofs [
dup [ current>> ] [ stop>> ] bi -
'[ _ - ] dip
] }
[ bad-stream-mode ]
} case
] when ; inline
: adjust-count-limit ( n stream -- n' stream )
2dup [ + ] change-count
[ count>> ] [ limit>> ] bi >
[
@ -66,13 +83,29 @@ ERROR: bad-stream-mode mode ;
{ stream-eofs [
dup [ count>> ] [ limit>> ] bi -
'[ _ - ] dip
dup limit>> >>count
] }
[ bad-stream-mode ]
} case
] when ; inline
: check-count-bounds ( n stream -- n stream )
dup [ count>> ] [ limit>> ] bi >
[ limit-exceeded ] when ;
: check-current-bounds ( n stream -- n stream )
dup [ current>> ] [ start>> ] bi <
[ limit-exceeded ] when ;
: adjust-limited-read ( n stream -- n stream )
dup start>> [
check-current-bounds adjust-current-limit
] [
check-count-bounds adjust-count-limit
] if ;
: maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f )
[ adjust-limit ] dip
[ adjust-limited-read ] dip
pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline
PRIVATE>
@ -93,16 +126,35 @@ M: limited-stream stream-read-partial
3dup [ [ stream-read1 dup ] dip memq? ] dip
swap [ drop ] [ push (read-until) ] if ;
:: limited-stream-seek ( n seek-type stream -- )
seek-type {
{ seek-absolute [ n stream (>>current) ] }
{ seek-relative [ stream [ n + ] change-current drop ] }
{ seek-end [ stream stop>> n - stream (>>current) ] }
[ bad-seek-type ]
} case ;
: >limited-seek ( stream -- stream' )
dup start>> [
dup stream-tell >>current
dup [ current>> ] [ count>> ] bi - >>start
dup [ start>> ] [ limit>> ] bi + >>stop
] unless ;
PRIVATE>
M: limited-stream stream-read-until
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
M: limited-stream stream-seek
stream>> stream-seek ;
M: limited-stream stream-tell
stream>> stream-tell ;
M: limited-stream dispose
stream>> dispose ;
M: limited-stream stream-seek
>limited-seek
[ stream>> stream-seek ]
[ limited-stream-seek ] 3bi ;
M: limited-stream dispose stream>> dispose ;
M: limited-stream stream-element-type
stream>> stream-element-type ;

7
basis/io/streams/string/string.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces sequences sbufs
strings generic splitting continuations destructors sequences.private
io.streams.plain io.encodings math.order growable io.streams.sequence ;
io.streams.plain io.encodings math.order growable io.streams.sequence
io.private ;
IN: io.streams.string
! Readers
@ -13,6 +14,8 @@ M: string-reader stream-read-partial stream-read ;
M: string-reader stream-read sequence-read ;
M: string-reader stream-read1 sequence-read1 ;
M: string-reader stream-read-until sequence-read-until ;
M: string-reader stream-tell i>> ;
M: string-reader stream-seek (stream-seek) ;
M: string-reader dispose drop ;
<PRIVATE
@ -35,4 +38,4 @@ M: sbuf stream-element-type drop +character+ ;
: with-string-writer ( quot -- str )
<string-writer> [
swap with-output-stream*
] keep >string ; inline
] keep >string ; inline

18
basis/math/vectors/simd/functor/functor.factor
View File

@ -325,6 +325,8 @@ A-v.-op DEFINES-PRIVATE ${A}-v.-op
A-sum-op DEFINES-PRIVATE ${A}-sum-op
A-vany-op DEFINES-PRIVATE ${A}-vany-op
A-vall-op DEFINES-PRIVATE ${A}-vall-op
A-vmerge-head-op DEFINES-PRIVATE ${A}-vmerge-head-op
A-vmerge-tail-op DEFINES-PRIVATE ${A}-vmerge-tail-op
WHERE
@ -419,6 +421,20 @@ INSTANCE: A sequence
: A-vall-op ( v1 quot -- n )
[ (simd-vbitand) ] (A-v->n-op) ; inline
: A-vmerge-head-op ( v1 v2 quot -- v )
drop
[ underlying1>> ] bi@
[ A-rep (simd-vmerge-head) ]
[ A-rep (simd-vmerge-tail) ] 2bi
\ A boa ;
: A-vmerge-tail-op ( v1 v2 quot -- v )
drop
[ underlying2>> ] bi@
[ A-rep (simd-vmerge-head) ]
[ A-rep (simd-vmerge-tail) ] 2bi
\ A boa ;
simd new
\ A >>class
\ A-with >>ctor
@ -429,6 +445,8 @@ simd new
{ vnone? A-vany-op }
{ vany? A-vany-op }
{ vall? A-vall-op }
{ vmerge-head A-vmerge-head-op }
{ vmerge-tail A-vmerge-tail-op }
} >>special-wrappers
{
{ { +vector+ +vector+ -> +vector+ } A-vv->v-op }

84
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -55,6 +55,8 @@ SIMD-OP: vrshift
SIMD-OP: hlshift
SIMD-OP: hrshift
SIMD-OP: vshuffle
SIMD-OP: vmerge-head
SIMD-OP: vmerge-tail
SIMD-OP: v<=
SIMD-OP: v<
SIMD-OP: v=
@ -118,44 +120,46 @@ GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? )
M: vector-rep supported-simd-op?
{
{ \ (simd-v+) [ %add-vector-reps ] }
{ \ (simd-vs+) [ %saturated-add-vector-reps ] }
{ \ (simd-v+-) [ %add-sub-vector-reps ] }
{ \ (simd-v-) [ %sub-vector-reps ] }
{ \ (simd-vs-) [ %saturated-sub-vector-reps ] }
{ \ (simd-v*) [ %mul-vector-reps ] }
{ \ (simd-vs*) [ %saturated-mul-vector-reps ] }
{ \ (simd-v/) [ %div-vector-reps ] }
{ \ (simd-vmin) [ %min-vector-reps ] }
{ \ (simd-vmax) [ %max-vector-reps ] }
{ \ (simd-v.) [ %dot-vector-reps ] }
{ \ (simd-vsqrt) [ %sqrt-vector-reps ] }
{ \ (simd-sum) [ %horizontal-add-vector-reps ] }
{ \ (simd-vabs) [ %abs-vector-reps ] }
{ \ (simd-vbitand) [ %and-vector-reps ] }
{ \ (simd-vbitandn) [ %andn-vector-reps ] }
{ \ (simd-vbitor) [ %or-vector-reps ] }
{ \ (simd-vbitxor) [ %xor-vector-reps ] }
{ \ (simd-vbitnot) [ %not-vector-reps ] }
{ \ (simd-vand) [ %and-vector-reps ] }
{ \ (simd-vandn) [ %andn-vector-reps ] }
{ \ (simd-vor) [ %or-vector-reps ] }
{ \ (simd-vxor) [ %xor-vector-reps ] }
{ \ (simd-vnot) [ %not-vector-reps ] }
{ \ (simd-vlshift) [ %shl-vector-reps ] }
{ \ (simd-vrshift) [ %shr-vector-reps ] }
{ \ (simd-hlshift) [ %horizontal-shl-vector-reps ] }
{ \ (simd-hrshift) [ %horizontal-shr-vector-reps ] }
{ \ (simd-vshuffle) [ %shuffle-vector-reps ] }
{ \ (simd-v<=) [ cc<= %compare-vector-reps ] }
{ \ (simd-v<) [ cc< %compare-vector-reps ] }
{ \ (simd-v=) [ cc= %compare-vector-reps ] }
{ \ (simd-v>) [ cc> %compare-vector-reps ] }
{ \ (simd-v>=) [ cc>= %compare-vector-reps ] }
{ \ (simd-vunordered?) [ cc/<>= %compare-vector-reps ] }
{ \ (simd-gather-2) [ %gather-vector-2-reps ] }
{ \ (simd-gather-4) [ %gather-vector-4-reps ] }
{ \ (simd-vany?) [ %test-vector-reps ] }
{ \ (simd-vall?) [ %test-vector-reps ] }
{ \ (simd-vnone?) [ %test-vector-reps ] }
{ \ (simd-v+) [ %add-vector-reps ] }
{ \ (simd-vs+) [ %saturated-add-vector-reps ] }
{ \ (simd-v+-) [ %add-sub-vector-reps ] }
{ \ (simd-v-) [ %sub-vector-reps ] }
{ \ (simd-vs-) [ %saturated-sub-vector-reps ] }
{ \ (simd-v*) [ %mul-vector-reps ] }
{ \ (simd-vs*) [ %saturated-mul-vector-reps ] }
{ \ (simd-v/) [ %div-vector-reps ] }
{ \ (simd-vmin) [ %min-vector-reps ] }
{ \ (simd-vmax) [ %max-vector-reps ] }
{ \ (simd-v.) [ %dot-vector-reps ] }
{ \ (simd-vsqrt) [ %sqrt-vector-reps ] }
{ \ (simd-sum) [ %horizontal-add-vector-reps ] }
{ \ (simd-vabs) [ %abs-vector-reps ] }
{ \ (simd-vbitand) [ %and-vector-reps ] }
{ \ (simd-vbitandn) [ %andn-vector-reps ] }
{ \ (simd-vbitor) [ %or-vector-reps ] }
{ \ (simd-vbitxor) [ %xor-vector-reps ] }
{ \ (simd-vbitnot) [ %not-vector-reps ] }
{ \ (simd-vand) [ %and-vector-reps ] }
{ \ (simd-vandn) [ %andn-vector-reps ] }
{ \ (simd-vor) [ %or-vector-reps ] }
{ \ (simd-vxor) [ %xor-vector-reps ] }
{ \ (simd-vnot) [ %not-vector-reps ] }
{ \ (simd-vlshift) [ %shl-vector-reps ] }
{ \ (simd-vrshift) [ %shr-vector-reps ] }
{ \ (simd-hlshift) [ %horizontal-shl-vector-reps ] }
{ \ (simd-hrshift) [ %horizontal-shr-vector-reps ] }
{ \ (simd-vshuffle) [ %shuffle-vector-reps ] }
{ \ (simd-vmerge-head) [ %merge-vector-reps ] }
{ \ (simd-vmerge-tail) [ %merge-vector-reps ] }
{ \ (simd-v<=) [ cc<= %compare-vector-reps ] }
{ \ (simd-v<) [ cc< %compare-vector-reps ] }
{ \ (simd-v=) [ cc= %compare-vector-reps ] }
{ \ (simd-v>) [ cc> %compare-vector-reps ] }
{ \ (simd-v>=) [ cc>= %compare-vector-reps ] }
{ \ (simd-vunordered?) [ cc/<>= %compare-vector-reps ] }
{ \ (simd-gather-2) [ %gather-vector-2-reps ] }
{ \ (simd-gather-4) [ %gather-vector-4-reps ] }
{ \ (simd-vany?) [ %test-vector-reps ] }
{ \ (simd-vall?) [ %test-vector-reps ] }
{ \ (simd-vnone?) [ %test-vector-reps ] }
} case member? ;

37
basis/math/vectors/simd/simd-tests.factor
View File

@ -146,7 +146,7 @@ CONSTANT: simd-classes
: random-float-vector ( class -- vec )
new [
drop
-1,000.0 1,000.0 uniform-random-float
1000 random
10 swap <array> 0/0. suffix random
] map ;
@ -254,6 +254,41 @@ simd-classes&reps [
[ [ { } ] ] dip first3 '[ _ _ _ check-boolean-ops ] unit-test
] each
"== Checking vector blend" print
[ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
[
char-16{ t t f f t t t f t f f f t f t t }
char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 }
char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 } v?
] unit-test
[ char-16{ 0 1 22 33 4 5 6 77 8 99 110 121 12 143 14 15 } ]
[
char-16{ t t f f t t t f t f f f t f t t }
char-16{ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 }
char-16{ 0 11 22 33 44 55 66 77 88 99 110 121 132 143 154 165 }
[ { char-16 char-16 char-16 } declare v? ] compile-call
] unit-test
[ int-4{ 1 22 33 4 } ]
[ int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 } v? ] unit-test
[ int-4{ 1 22 33 4 } ]
[
int-4{ t f f t } int-4{ 1 2 3 4 } int-4{ 11 22 33 44 }
[ { int-4 int-4 int-4 } declare v? ] compile-call
] unit-test
[ float-4{ 1.0 22.0 33.0 4.0 } ]
[ float-4{ t f f t } float-4{ 1.0 2.0 3.0 4.0 } float-4{ 11.0 22.0 33.0 44.0 } v? ] unit-test
[ float-4{ 1.0 22.0 33.0 4.0 } ]
[
float-4{ t f f t } float-4{ 1.0 2.0 3.0 4.0 } float-4{ 11.0 22.0 33.0 44.0 }
[ { float-4 float-4 float-4 } declare v? ] compile-call
] unit-test
"== Checking shifts and permutations" print
[ int-4{ 256 512 1024 2048 } ]

2
basis/math/vectors/specialization/specialization.factor
View File

@ -98,6 +98,8 @@ H{
{ hrshift { +vector+ +literal+ -> +vector+ } }
{ vshuffle { +vector+ +literal+ -> +vector+ } }
{ vbroadcast { +vector+ +literal+ -> +vector+ } }
{ vmerge-head { +vector+ +vector+ -> +vector+ } }
{ vmerge-tail { +vector+ +vector+ -> +vector+ } }
{ v<= { +vector+ +vector+ -> +vector+ } }
{ v< { +vector+ +vector+ -> +vector+ } }
{ v= { +vector+ +vector+ -> +vector+ } }

36
basis/math/vectors/vectors-docs.factor
View File

@ -58,7 +58,8 @@ $nl
{ $subsection vshuffle }
{ $subsection vbroadcast }
{ $subsection hlshift }
{ $subsection hrshift } ;
{ $subsection hrshift }
{ $subsection vmerge } ;
ARTICLE: "math-vectors-logic" "Vector component- and bit-wise logic"
{ $notes
@ -355,6 +356,39 @@ HELP: hrshift
{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } }
{ $description "Shifts the entire SIMD array to the right by " { $snippet "n" } " bytes, filling the vacated left-hand bits with zeroes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ;
HELP: vmerge
{ $values { "u" "a sequence" } { "v" "a sequence" } { "h" "a sequence" } { "t" "a sequence" } }
{ $description "Creates two new sequences of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements of " { $snippet "u" } " and " { $snippet "v" } "." }
{ $examples
{ $example """USING: kernel math.vectors prettyprint ;
{ "A" "B" "C" "D" } { "1" "2" "3" "4" } vmerge [ . ] bi@"""
"""{ "A" "1" "B" "2" }
{ "C" "3" "D" "4" }"""
} } ;
HELP: vmerge-head
{ $values { "u" "a sequence" } { "v" "a sequence" } { "h" "a sequence" } }
{ $description "Creates two new sequences of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements from the first half of " { $snippet "u" } " and " { $snippet "v" } "." }
{ $examples
{ $example """USING: kernel math.vectors prettyprint ;
{ "A" "B" "C" "D" } { "1" "2" "3" "4" } vmerge-head ."""
"""{ "A" "1" "B" "2" }"""
} } ;
HELP: vmerge-tail
{ $values { "u" "a sequence" } { "v" "a sequence" } { "t" "a sequence" } }
{ $description "Creates two new sequences of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements from the tail half of " { $snippet "u" } " and " { $snippet "v" } "." }
{ $examples
{ $example """USING: kernel math.vectors prettyprint ;
{ "A" "B" "C" "D" } { "1" "2" "3" "4" } vmerge-tail ."""
"""{ "C" "3" "D" "4" }"""
} } ;
{ vmerge vmerge-head vmerge-tail } related-words
HELP: vbroadcast
{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "v" "a SIMD array" } }
{ $description "Outputs a new SIMD array of the same type as " { $snippet "u" } " where every element is equal to the " { $snippet "n" } "th element of " { $snippet "u" } "." }

9
basis/math/vectors/vectors.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien.c-types kernel sequences math math.functions
USING: arrays alien.c-types assocs kernel sequences math math.functions
hints math.order math.libm fry combinators byte-arrays accessors
locals ;
QUALIFIED-WITH: alien.c-types c
@ -65,7 +65,7 @@ PRIVATE>
} case ; inline
: element>bool ( x seq -- ? )
element-type [ zero? not ] when ; inline
element-type [ [ f ] when-zero ] when ; inline
: bitandn ( x y -- z ) [ bitnot ] dip bitand ; inline
@ -91,6 +91,11 @@ PRIVATE>
: hlshift ( u n -- w ) '[ _ <byte-array> prepend 16 head ] change-underlying ;
: hrshift ( u n -- w ) '[ _ <byte-array> append 16 tail* ] change-underlying ;
: vmerge-head ( u v -- h ) over length 2 / '[ _ head-slice ] bi@ [ zip ] keep concat-as ;
: vmerge-tail ( u v -- t ) over length 2 / '[ _ tail-slice ] bi@ [ zip ] keep concat-as ;
: vmerge ( u v -- h t ) [ vmerge-head ] [ vmerge-tail ] 2bi ; inline
: vand ( u v -- w ) over '[ [ _ element>bool ] bi@ and ] 2map ;
: vandn ( u v -- w ) over '[ [ _ element>bool ] bi@ [ not ] dip and ] 2map ;
: vor ( u v -- w ) over '[ [ _ element>bool ] bi@ or ] 2map ;

1
core/bootstrap/primitives.factor
View File

@ -486,6 +486,7 @@ tuple
{ "fputc" "io.streams.c" (( ch alien -- )) }
{ "fwrite" "io.streams.c" (( string alien -- )) }
{ "fflush" "io.streams.c" (( alien -- )) }
{ "ftell" "io.streams.c" (( alien -- n )) }
{ "fseek" "io.streams.c" (( alien offset whence -- )) }
{ "fclose" "io.streams.c" (( alien -- )) }
{ "<wrapper>" "kernel" (( obj -- wrapper )) }

2
core/io/encodings/encodings-tests.factor
View File

@ -1,6 +1,6 @@
USING: io.files io.streams.string io io.streams.byte-array
tools.test kernel io.encodings.ascii io.encodings.utf8
namespaces accessors io.encodings ;
namespaces accessors io.encodings io.streams.limited ;
IN: io.streams.encodings.tests
[ { } ]

4
core/io/encodings/encodings.factor
View File

@ -50,6 +50,10 @@ M: object <decoder> f decoder boa ;
M: decoder stream-element-type
drop +character+ ;
M: decoder stream-tell stream>> stream-tell ;
M: decoder stream-seek stream>> stream-seek ;
M: decoder stream-read1
dup >decoder< decode-char fix-read1 ;

15
core/io/io-docs.factor
View File

@ -86,6 +86,14 @@ HELP: stream-copy
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
HELP: stream-tell
{ $values
{ "stream" "a stream" } { "n" integer }
}
{ $description "Returns the index of the stream pointer if the stream is seekable." }
{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
HELP: stream-seek
{ $values
{ "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
@ -274,8 +282,11 @@ $nl
}
"This word is only required for string output streams:"
{ $subsections stream-nl }
"This word is for streams that allow seeking:"
{ $subsections stream-seek }
"These words are for seekable streams:"
{ $subsections
stream-tell
stream-seek
}
{ $see-also "io.timeouts" } ;
ARTICLE: "stdio-motivation" "Motivation for default streams"

23
core/io/io.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces make sequences
continuations destructors assocs combinators ;
USING: accessors combinators continuations destructors kernel
math namespaces sequences ;
IN: io
SYMBOLS: +byte+ +character+ ;
@ -23,9 +23,24 @@ ERROR: bad-seek-type type ;
SINGLETONS: seek-absolute seek-relative seek-end ;
GENERIC: stream-tell ( stream -- n )
GENERIC: stream-seek ( n seek-type stream -- )
: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
<PRIVATE
SLOT: i
: (stream-seek) ( n seek-type stream -- )
swap {
{ seek-absolute [ (>>i) ] }
{ seek-relative [ [ + ] change-i drop ] }
{ seek-end [ [ underlying>> length + ] [ (>>i) ] bi ] }
[ bad-seek-type ]
} case ;
PRIVATE>
: stream-print ( str stream -- ) [ stream-write ] [ stream-nl ] bi ;
! Default streams
SYMBOL: input-stream
@ -37,6 +52,8 @@ SYMBOL: error-stream
: read ( n -- seq ) input-stream get stream-read ;
: read-until ( seps -- seq sep/f ) input-stream get stream-read-until ;
: read-partial ( n -- seq ) input-stream get stream-read-partial ;
: tell-input ( -- n ) input-stream get stream-tell ;
: tell-output ( -- n ) output-stream get stream-tell ;
: seek-input ( n seek-type -- ) input-stream get stream-seek ;
: seek-output ( n seek-type -- ) output-stream get stream-seek ;

6
core/io/streams/byte-array/byte-array-tests.factor
View File

@ -29,7 +29,11 @@ io.encodings.utf8 io kernel arrays strings namespaces math ;
] with-byte-reader
] unit-test
[ 0 ] [
B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary [ tell-input ] with-byte-reader
] unit-test
! Overly aggressive compiler optimizations
[ B{ 123 } ] [
binary [ 123 >bignum write1 ] with-byte-writer
] unit-test
] unit-test

15
core/io/streams/byte-array/byte-array.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays byte-vectors kernel io.encodings sequences io
namespaces io.encodings.private accessors sequences.private
io.streams.sequence destructors math combinators ;
USING: accessors byte-arrays byte-vectors destructors io
io.encodings io.private io.streams.sequence kernel namespaces
sequences sequences.private ;
IN: io.streams.byte-array
M: byte-vector stream-element-type drop +byte+ ;
@ -24,13 +24,8 @@ M: byte-reader stream-read1 sequence-read1 ;
M: byte-reader stream-read-until sequence-read-until ;
M: byte-reader dispose drop ;
M: byte-reader stream-seek ( n seek-type stream -- )
swap {
{ seek-absolute [ (>>i) ] }
{ seek-relative [ [ + ] change-i drop ] }
{ seek-end [ [ underlying>> length + ] keep (>>i) ] }
[ bad-seek-type ]
} case ;
M: byte-reader stream-tell i>> ;
M: byte-reader stream-seek (stream-seek) ;
: <byte-reader> ( byte-array encoding -- stream )
[ B{ } like 0 byte-reader boa ] dip <decoder> ;

11
core/io/streams/c/c-tests.factor
View File

@ -1,5 +1,5 @@
USING: tools.test io.files io.files.temp io io.streams.c
io.encodings.ascii strings ;
io.encodings.ascii strings destructors kernel ;
IN: io.streams.c.tests
[ "hello world" ] [
@ -8,3 +8,12 @@ IN: io.streams.c.tests
"test.txt" temp-file "rb" fopen <c-reader> stream-contents
>string
] unit-test
[ 0 ]
[ "test.txt" temp-file "rb" fopen <c-reader> [ stream-tell ] [ dispose ] bi ] unit-test
[ 3 ] [
"test.txt" temp-file "rb" fopen <c-reader>
3 over stream-read drop
[ stream-tell ] [ dispose ] bi
] unit-test

2
core/io/streams/c/c.factor
View File

@ -13,6 +13,8 @@ TUPLE: c-stream < disposable handle ;
M: c-stream dispose* handle>> fclose ;
M: c-stream stream-tell handle>> ftell ;
M: c-stream stream-seek
handle>> swap {
{ seek-absolute [ 0 ] }

20
extra/math/matrices/simd/simd-tests.factor
View File

@ -29,6 +29,26 @@ IN: math.matrices.simd.tests
}
] [ float-4{ 8.0 4.0 2.0 0.0 } ortho-matrix4 ] unit-test
[
S{ matrix4 f
float-4-array{
float-4{ 0.0 0.0 -1.0 0.0 }
float-4{ 1.0 0.0 0.0 0.0 }
float-4{ 0.0 1.0 0.0 0.0 }
float-4{ 3.0 4.0 2.0 1.0 }
}
}
] [
S{ matrix4 f
float-4-array{
float-4{ 0.0 1.0 0.0 3.0 }
float-4{ 0.0 0.0 1.0 4.0 }
float-4{ -1.0 0.0 0.0 2.0 }
float-4{ 0.0 0.0 0.0 1.0 }
}
} transpose-matrix4
] unit-test
[
S{ matrix4 f
float-4-array{

98
extra/math/matrices/simd/simd.factor
View File

@ -1,5 +1,5 @@
! (c)Joe Groff bsd license
USING: accessors classes.struct generalizations kernel locals
USING: accessors classes.struct fry generalizations kernel locals
math math.combinatorics math.functions math.matrices.simd math.vectors
math.vectors.simd sequences sequences.private specialized-arrays
typed ;
@ -30,30 +30,22 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
c4 rows set-fourth
c ; inline
: make-matrix4 ( quot: ( -- c1 c2 c3 c4 ) -- c )
matrix4 (struct) swap dip set-rows ; inline
:: 2map-rows ( a b quot -- c )
matrix4 (struct) :> c
[
a rows :> a4 :> a3 :> a2 :> a1
b rows :> b4 :> b3 :> b2 :> b1
a rows :> a4 :> a3 :> a2 :> a1
b rows :> b4 :> b3 :> b2 :> b1
a1 b1 quot call
a2 b2 quot call
a3 b3 quot call
a4 b4 quot call
] make-matrix4 ; inline
a1 b1 quot call
a2 b2 quot call
a3 b3 quot call
a4 b4 quot call
c set-rows ; inline
:: map-rows ( a quot -- c )
matrix4 (struct) :> c
a rows :> a4 :> a3 :> a2 :> a1
a1 quot call
a2 quot call
a3 quot call
a4 quot call
c set-rows ; inline
: map-rows ( a quot -- c )
'[ rows _ 4 napply ] make-matrix4 ; inline
PRIVATE>
@ -68,32 +60,30 @@ TYPED: n*m4 ( a: float b: matrix4 -- c: matrix4 ) [ n*v ] with map-rows ;
TYPED: n/m4 ( a: float b: matrix4 -- c: matrix4 ) [ n/v ] with map-rows ;
TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
matrix4 (struct) :> c
[
a rows :> a4 :> a3 :> a2 :> a1
b rows :> b4 :> b3 :> b2 :> b1
a rows :> a4 :> a3 :> a2 :> a1
b rows :> b4 :> b3 :> b2 :> b1
a1 first b1 n*v :> c1a
a2 first b1 n*v :> c2a
a3 first b1 n*v :> c3a
a4 first b1 n*v :> c4a
a1 first b1 n*v :> c1a
a2 first b1 n*v :> c2a
a3 first b1 n*v :> c3a
a4 first b1 n*v :> c4a
a1 second b2 n*v c1a v+ :> c1b
a2 second b2 n*v c2a v+ :> c2b
a3 second b2 n*v c3a v+ :> c3b
a4 second b2 n*v c4a v+ :> c4b
a1 second b2 n*v c1a v+ :> c1b
a2 second b2 n*v c2a v+ :> c2b
a3 second b2 n*v c3a v+ :> c3b
a4 second b2 n*v c4a v+ :> c4b
a1 third b3 n*v c1b v+ :> c1c
a2 third b3 n*v c2b v+ :> c2c
a3 third b3 n*v c3b v+ :> c3c
a4 third b3 n*v c4b v+ :> c4c
a1 third b3 n*v c1b v+ :> c1c
a2 third b3 n*v c2b v+ :> c2c
a3 third b3 n*v c3b v+ :> c3c
a4 third b3 n*v c4b v+ :> c4c
a1 fourth b4 n*v c1c v+
a2 fourth b4 n*v c2c v+
a3 fourth b4 n*v c3c v+
a4 fourth b4 n*v c4c v+
c set-rows ;
a1 fourth b4 n*v c1c v+
a2 fourth b4 n*v c2c v+
a3 fourth b4 n*v c3c v+
a4 fourth b4 n*v c4c v+
] make-matrix4 ;
TYPED:: v.m4 ( a: float-4 b: matrix4 -- c: float-4 )
b rows :> b4 :> b3 :> b2 :> b1
@ -129,17 +119,21 @@ CONSTANT: zero-matrix4
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
: vmerge-diagonal ( x -- h t )
0.0 float-4-with [ vmerge-head ] [ swap vmerge-tail ] 2bi ; inline
factors float-4{ t t t f } vbitand :> factors'
TYPED: diagonal-matrix4 ( diagonal: float-4 -- matrix: matrix4 )
[ vmerge-diagonal [ vmerge-diagonal ] bi@ ] make-matrix4 ;
factors' { 0 3 3 3 } vshuffle
factors' { 3 1 3 3 } vshuffle
factors' { 3 3 2 3 } vshuffle
float-4{ 0.0 0.0 0.0 1.0 }
: vmerge-transpose ( a b c d -- a' b' c' d' )
[ vmerge ] bi-curry@ bi* ; inline
c set-rows ;
TYPED: transpose-matrix4 ( matrix: matrix4 -- matrix: matrix4 )
[ rows vmerge-transpose vmerge-transpose ] make-matrix4 ;
: scale-matrix4 ( factors -- matrix )
[ float-4{ t t t f } ] dip float-4{ 0.0 0.0 0.0 1.0 } v?
diagonal-matrix4 ;
: ortho-matrix4 ( factors -- matrix )
float-4{ 1.0 1.0 1.0 1.0 } swap v/ scale-matrix4 ; inline

11
vm/io.cpp
View File

@ -164,6 +164,17 @@ void factor_vm::primitive_fwrite()
}
}
void factor_vm::primitive_ftell()
{
FILE *file = (FILE *)unbox_alien();
off_t offset;
if((offset = FTELL(file)) == -1)
io_error();
box_signed_8(offset);
}
void factor_vm::primitive_fseek()
{
int whence = to_fixnum(dpop());

1
vm/os-unix.hpp
View File

@ -23,6 +23,7 @@ typedef char symbol_char;
#define STRNCMP strncmp
#define STRDUP strdup
#define FTELL ftello
#define FSEEK fseeko
#define FIXNUM_FORMAT "%ld"

3
vm/os-windows.hpp
View File

@ -19,7 +19,8 @@ typedef wchar_t vm_char;
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
#define MIN(a,b) ((a)>(b)?(b):(a))
#define FSEEK fseek
#define FTELL _ftelli64
#define FSEEK _fseeki64
#ifdef WIN64
#define CELL_FORMAT "%Iu"

2
vm/primitives.cpp
View File

@ -128,6 +128,7 @@ const primitive_type primitives[] = {
primitive_fputc,
primitive_fwrite,
primitive_fflush,
primitive_ftell,
primitive_fseek,
primitive_fclose,
primitive_wrapper,
@ -254,6 +255,7 @@ PRIMITIVE_FORWARD(fread)
PRIMITIVE_FORWARD(fputc)
PRIMITIVE_FORWARD(fwrite)
PRIMITIVE_FORWARD(fflush)
PRIMITIVE_FORWARD(ftell)
PRIMITIVE_FORWARD(fseek)
PRIMITIVE_FORWARD(fclose)
PRIMITIVE_FORWARD(wrapper)

1
vm/primitives.hpp
View File

@ -136,6 +136,7 @@ PRIMITIVE(fread);
PRIMITIVE(fputc);
PRIMITIVE(fwrite);
PRIMITIVE(fflush);
PRIMITIVE(ftell);
PRIMITIVE(fseek);
PRIMITIVE(fclose);
PRIMITIVE(wrapper);

1
vm/vm.hpp
View File

@ -493,6 +493,7 @@ struct factor_vm
void primitive_fread();
void primitive_fputc();
void primitive_fwrite();
void primitive_ftell();
void primitive_fseek();
void primitive_fflush();
void primitive_fclose();