From 11d55131de4bd28ff26fe7d1e6ad49b42947b93c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 3 Oct 2009 18:20:35 -0500 Subject: [PATCH 01/13] add ftell primitive --- core/bootstrap/primitives.factor | 1 + vm/io.cpp | 11 +++++++++++ vm/os-unix.hpp | 1 + vm/os-windows.hpp | 3 ++- vm/primitives.cpp | 2 ++ vm/primitives.hpp | 1 + vm/vm.hpp | 1 + 7 files changed, 19 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f7fb28c8f4..f42ab779f4 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 -- )) } { "" "kernel" (( obj -- wrapper )) } diff --git a/vm/io.cpp b/vm/io.cpp index 18a553af89..8e6eff730e 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -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()); diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index dc8acc445e..0afdbb200a 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -23,6 +23,7 @@ typedef char symbol_char; #define STRNCMP strncmp #define STRDUP strdup +#define FTELL ftello #define FSEEK fseeko #define FIXNUM_FORMAT "%ld" diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index d1db3c26ac..319ad6c42a 100644 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -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" diff --git a/vm/primitives.cpp b/vm/primitives.cpp index f8552ab635..e2e663333f 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -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) diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 983d2589b2..dd264869b2 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -136,6 +136,7 @@ PRIMITIVE(fread); PRIMITIVE(fputc); PRIMITIVE(fwrite); PRIMITIVE(fflush); +PRIMITIVE(ftell); PRIMITIVE(fseek); PRIMITIVE(fclose); PRIMITIVE(wrapper); diff --git a/vm/vm.hpp b/vm/vm.hpp index 8f2b96944f..4bd137289d 100644 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -510,6 +510,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(); From 098fd0248ac5dcd94d282339d83734c6034290e8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 3 Oct 2009 18:27:09 -0500 Subject: [PATCH 02/13] support limited-streams correctly for seekable streams --- basis/io/backend/unix/unix.factor | 3 + basis/io/ports/ports.factor | 5 + basis/io/streams/duplex/duplex.factor | 1 - basis/io/streams/limited/limited-tests.factor | 119 +++++++++++++++++- basis/io/streams/limited/limited.factor | 72 +++++++++-- basis/io/streams/string/string.factor | 7 +- core/io/encodings/encodings-tests.factor | 2 +- core/io/encodings/encodings.factor | 4 + core/io/io.factor | 23 +++- .../byte-array/byte-array-tests.factor | 6 +- core/io/streams/byte-array/byte-array.factor | 15 +-- core/io/streams/c/c.factor | 2 + 12 files changed, 227 insertions(+), 32 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 4b7ef4b40f..3245d80d4e 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -49,6 +49,9 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; +M: unix tell-handle ( handle -- n ) + fd>> SEEK_SET 0 lseek [ io-error ] [ ] bi ; + M: unix seek-handle ( n seek-type handle -- ) swap { { io:seek-absolute [ SEEK_SET ] } diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 49f6166e00..e225bed32f 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -124,8 +124,13 @@ 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 ] bi ; + M: input-port stream-seek ( n seek-type stream -- ) [ check-disposed ] [ buffer>> 0 swap buffer-reset ] diff --git a/basis/io/streams/duplex/duplex.factor b/basis/io/streams/duplex/duplex.factor index 4903195abc..0e4d1fd195 100644 --- a/basis/io/streams/duplex/duplex.factor +++ b/basis/io/streams/duplex/duplex.factor @@ -44,4 +44,3 @@ M: duplex-stream underlying-handle >duplex-stream< [ underlying-handle ] bi@ [ = [ invalid-duplex-stream ] when ] keep ; - diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index f052be3b74..bc9125dd62 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -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 ; IN: io.streams.limited.tests [ ] [ @@ -89,3 +90,113 @@ IN: io.streams.limited.tests unlimited-input contents ] with-input-stream ] unit-test + +[ 4 ] [ + "abcdefgh" 4 stream-throws [ + 4 seek-relative seek-input tell-input + ] with-input-stream +] unit-test + +[ + "abcdefgh" 4 stream-throws [ + 4 seek-relative seek-input + 4 read + ] with-input-stream +] [ + limit-exceeded? +] must-fail-with + +[ + "abcdefgh" 4 stream-throws [ + 4 seek-relative seek-input + -2 seek-relative + 2 read + ] with-input-stream +] [ + limit-exceeded? +] must-fail-with + +[ + "abcdefgh" [ + 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" [ + 4 seek-relative seek-input + 2 stream-throws limit-input + 4 seek-absolute seek-input + 2 read + ] with-input-stream +] unit-test + +[ "ef" ] [ + "abcdefgh" [ + 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 [ 2 stream-throws ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ + latin1 [ 2 stream-throws ] 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 [ 2 stream-eofs ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ "as" ] [ + latin1 [ 2 stream-eofs ] change-in + "asdf" over stream-write dup stream-flush + 3 swap stream-read +] unit-test + +! test seeking on limited unseekable streams +[ "as" ] [ + latin1 [ 2 stream-eofs ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ "as" ] [ + latin1 [ 2 stream-eofs ] change-in + "asdf" over stream-write dup stream-flush + 3 swap stream-read +] unit-test + +[ + latin1 [ 2 stream-throws ] change-in + 2 seek-absolute rot in>> stream-seek +] must-fail + +[ + "as" +] [ + latin1 [ 2 stream-throws ] change-in + "asdf" over stream-write dup stream-flush + [ 2 seek-absolute rot in>> stream-seek ] [ drop ] recover + 2 swap stream-read +] unit-test diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index c71e99ab91..403643ed73 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -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 ; > ] [ 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 ; diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index 85cb3022f5..be9016d1f2 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -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 ; [ swap with-output-stream* - ] keep >string ; inline \ No newline at end of file + ] keep >string ; inline diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor index fa8832deab..9b88db5136 100644 --- a/core/io/encodings/encodings-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -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 [ { } ] diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 174816dd34..03e8723d20 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -50,6 +50,10 @@ M: object 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 ; diff --git a/core/io/io.factor b/core/io/io.factor index 669f104a5f..e240467c07 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -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 ; +>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 ; diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor index 3a08dd10d9..96b122549d 100644 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -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 \ No newline at end of file +] unit-test diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index 4cb50dfbc1..6f9b05cf18 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -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-array encoding -- stream ) [ B{ } like 0 byte-reader boa ] dip ; diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index aebc709a9e..6ff1a4b35c 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -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 ] } From 1d41f4c66cf82ea46c09c5453bcaf414a18914ef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 3 Oct 2009 19:07:16 -0500 Subject: [PATCH 03/13] add unit test for c stream-tell --- core/io/streams/c/c-tests.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 6a82d6d545..657c6ccd75 100644 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -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 stream-contents >string ] unit-test + +[ 0 ] +[ "test.txt" temp-file "rb" fopen [ stream-tell ] [ dispose ] bi ] unit-test + +[ 3 ] [ + "test.txt" temp-file "rb" fopen + 3 over stream-read drop + [ stream-tell ] [ dispose ] bi +] unit-test From aa37a57b9a991b42f4bfc922b382a09a649f9405 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 3 Oct 2009 19:15:56 -0500 Subject: [PATCH 04/13] take the buffer position into account on buffered-port stream-tell --- basis/io/ports/ports.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index e225bed32f..7ecb420478 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -129,7 +129,8 @@ HOOK: seek-handle os ( n seek-type handle -- ) M: buffered-port stream-tell ( stream -- n ) [ check-disposed ] - [ handle>> tell-handle ] bi ; + [ handle>> tell-handle ] + [ buffer>> pos>> ] tri + ; M: input-port stream-seek ( n seek-type stream -- ) [ check-disposed ] From ed1636a0c00625369e183128f3d51beb230945e5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 3 Oct 2009 19:26:59 -0500 Subject: [PATCH 05/13] fix stream-tell --- basis/io/backend/unix/unix.factor | 2 +- basis/io/ports/ports.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 3245d80d4e..ebb8f1ec05 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -50,7 +50,7 @@ M: fd cancel-operation ( fd -- ) ] if ; M: unix tell-handle ( handle -- n ) - fd>> SEEK_SET 0 lseek [ io-error ] [ ] bi ; + fd>> 0 SEEK_CUR lseek [ io-error ] [ ] bi ; M: unix seek-handle ( n seek-type handle -- ) swap { diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 7ecb420478..8cdd1d97bd 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -130,7 +130,7 @@ HOOK: seek-handle os ( n seek-type handle -- ) M: buffered-port stream-tell ( stream -- n ) [ check-disposed ] [ handle>> tell-handle ] - [ buffer>> pos>> ] tri + ; + [ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ; M: input-port stream-seek ( n seek-type stream -- ) [ check-disposed ] From 770405359e748b8064f9a8ace44cf7b4dfed8b7f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 3 Oct 2009 19:33:54 -0500 Subject: [PATCH 06/13] better tests for stream-tell --- basis/io/streams/limited/limited-tests.factor | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index bc9125dd62..022d20eb5e 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -2,7 +2,7 @@ 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 ; +kernel namespaces strings tools.test system ; IN: io.streams.limited.tests [ ] [ @@ -200,3 +200,17 @@ IN: io.streams.limited.tests [ 2 seek-absolute rot in>> stream-seek ] [ drop ] recover 2 swap stream-read ] unit-test + +[ 7 ] [ + image binary stream-throws [ + 7 read drop + tell-input + ] with-input-stream +] unit-test + +[ 70000 ] [ + image binary stream-throws [ + 70000 read drop + tell-input + ] with-input-stream +] unit-test From 84fd08d86b53c4421d53c01b7305bd1ac5123008 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 3 Oct 2009 19:39:06 -0500 Subject: [PATCH 07/13] update docs for stream-tell --- basis/io/streams/limited/limited-docs.factor | 17 ++++++++++++++++- core/io/io-docs.factor | 15 +++++++++++++-- 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/basis/io/streams/limited/limited-docs.factor b/basis/io/streams/limited/limited-docs.factor index a7199eaad1..833e53820e 100755 --- a/basis/io/streams/limited/limited-docs.factor +++ b/basis/io/streams/limited/limited-docs.factor @@ -24,7 +24,22 @@ HELP: limit " \"123456\" 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 diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 13048fdb61..e0b74d5ab3 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -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" From d3c51baf912958685799831ec38bd69641a511cc Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 3 Oct 2009 20:22:37 -0500 Subject: [PATCH 08/13] software version of vmerge word (to be backed by UNPCK instructions on x86 and VMRG instructions on ppc) --- basis/math/vectors/vectors-docs.factor | 31 ++++++++++++++++++++++++++ basis/math/vectors/vectors.factor | 7 +++++- 2 files changed, 37 insertions(+), 1 deletion(-) diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index c4b905b633..664ffbeafc 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -355,6 +355,37 @@ 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" }""" +} } ; + 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" } "." } diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index f485e2bbf2..f7191f0013 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -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 @@ -91,6 +91,11 @@ PRIVATE> : hlshift ( u n -- w ) '[ _ prepend 16 head ] change-underlying ; : hrshift ( u n -- w ) '[ _ 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 ; From 05c722ea0c3e4690c6d5c59ed846abd58aaa5dfa Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 3 Oct 2009 21:48:16 -0500 Subject: [PATCH 09/13] link vmerge into math.vectors docs --- basis/math/vectors/vectors-docs.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 664ffbeafc..82bb037186 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -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 @@ -386,6 +387,8 @@ HELP: 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" } "." } From 0c9c3d485951c0413c3977b63d862d9839cd4298 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 3 Oct 2009 21:48:53 -0500 Subject: [PATCH 10/13] add %merge-vector-head and %merge-vector-tail instructions to back vmerge --- .../cfg/instructions/instructions.factor | 10 +++ .../compiler/cfg/intrinsics/intrinsics.factor | 2 + basis/compiler/codegen/codegen.factor | 2 + .../tree/propagation/simd/simd.factor | 2 + basis/cpu/architecture/architecture.factor | 3 + basis/cpu/ppc/ppc.factor | 1 + basis/cpu/x86/x86.factor | 28 +++++++ .../math/vectors/simd/functor/functor.factor | 18 ++++ .../vectors/simd/intrinsics/intrinsics.factor | 84 ++++++++++--------- .../specialization/specialization.factor | 2 + 10 files changed, 112 insertions(+), 40 deletions(-) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index a4ebde304e..b6881b61b6 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index b320489080..124aac5b18 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -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 ] } diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index ff1c8e0b0b..05f50771f6 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 diff --git a/basis/compiler/tree/propagation/simd/simd.factor b/basis/compiler/tree/propagation/simd/simd.factor index 06d96ef28e..462e5d6e0b 100644 --- a/basis/compiler/tree/propagation/simd/simd.factor +++ b/basis/compiler/tree/propagation/simd/simd.factor @@ -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=) diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 1d683ffbe3..0fb69120da 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 2f00ee0591..f604efe64d 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -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 { } ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index f7d1aabfdd..7c025707fc 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -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 ] diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor index 878d4aea70..fb8326fde2 100644 --- a/basis/math/vectors/simd/functor/functor.factor +++ b/basis/math/vectors/simd/functor/functor.factor @@ -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 } diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 0b6b897c4b..dd87d4aaa9 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -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? ; diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index 217849ab3d..8d9d1b49cb 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -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+ } } From 626954a071cdcd0265ec557045329315f356a25e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 3 Oct 2009 22:37:35 -0500 Subject: [PATCH 11/13] fix v? software fallback --- basis/math/vectors/simd/simd-tests.factor | 35 +++++++++++++++++++++++ basis/math/vectors/vectors.factor | 2 +- 2 files changed, 36 insertions(+), 1 deletion(-) diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index c419b47f28..1ebe09f728 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -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 } ] diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index f7191f0013..3f4fe4c7b6 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -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 From cef5a32746577461b02fa8ecdec0e759c804a5ec Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 3 Oct 2009 22:48:41 -0500 Subject: [PATCH 12/13] rice out transpose-matrix4 and diagonal-matrix4 using vmerge --- extra/math/matrices/simd/simd-tests.factor | 20 +++++ extra/math/matrices/simd/simd.factor | 98 ++++++++++------------ 2 files changed, 66 insertions(+), 52 deletions(-) diff --git a/extra/math/matrices/simd/simd-tests.factor b/extra/math/matrices/simd/simd-tests.factor index 6f96a9f94d..3798c3e98e 100644 --- a/extra/math/matrices/simd/simd-tests.factor +++ b/extra/math/matrices/simd/simd-tests.factor @@ -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{ diff --git a/extra/math/matrices/simd/simd.factor b/extra/math/matrices/simd/simd.factor index 16960993b6..0bc2817f53 100644 --- a/extra/math/matrices/simd/simd.factor +++ b/extra/math/matrices/simd/simd.factor @@ -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 From 7ed8f00b0faae675d3bde4b1d403b470b4f49210 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 3 Oct 2009 22:57:04 -0500 Subject: [PATCH 13/13] go back to using random instead of uniform-random-float in math.vectors.simd tests because the software and SIMD implementations of norm and v. can sporadically diverge when their different operation orders lead to cancellation of catastrophically small inputs --- basis/math/vectors/simd/simd-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index 1ebe09f728..88e5d5f1ea 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -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 0/0. suffix random ] map ;