diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 792e7d416a..a893ffebe8 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -1,5 +1,6 @@ USING: alien alien.syntax alien.c-types kernel tools.test -sequences system libc alien.strings io.encodings.utf8 ; +sequences system libc alien.strings io.encodings.utf8 +math.constants ; IN: alien.c-types.tests CONSTANT: xyz 123 @@ -52,3 +53,9 @@ TYPEDEF: uchar* MyLPBYTE os windows? cpu x86.64? and [ [ -2147467259 ] [ 2147500037 *long ] unit-test ] when + +[ 0 ] [ -10 uchar c-type-clamp ] unit-test +[ 12 ] [ 12 uchar c-type-clamp ] unit-test +[ -10 ] [ -10 char c-type-clamp ] unit-test +[ 127 ] [ 230 char c-type-clamp ] unit-test +[ t ] [ pi dup float c-type-clamp = ] unit-test diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index fa27e29c04..0ed111c077 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays arrays assocs kernel kernel.private math -namespaces make parser sequences strings words splitting math.parser -cpu.architecture alien alien.accessors alien.strings quotations -layouts system compiler.units io io.files io.encodings.binary -io.streams.memory accessors combinators effects continuations fry -classes vocabs vocabs.loader words.symbol ; +math.order math.parser namespaces make parser sequences strings +words splitting cpu.architecture alien alien.accessors +alien.strings quotations layouts system compiler.units io +io.files io.encodings.binary io.streams.memory accessors +combinators effects continuations fry classes vocabs +vocabs.loader words.symbol ; QUALIFIED: math IN: alien.c-types @@ -472,3 +473,27 @@ SYMBOLS: \ ulong \ size_t typedef ] with-compilation-unit +M: char-16-rep rep-component-type drop char ; +M: uchar-16-rep rep-component-type drop uchar ; +M: short-8-rep rep-component-type drop short ; +M: ushort-8-rep rep-component-type drop ushort ; +M: int-4-rep rep-component-type drop int ; +M: uint-4-rep rep-component-type drop uint ; +M: longlong-2-rep rep-component-type drop longlong ; +M: ulonglong-2-rep rep-component-type drop ulonglong ; +M: float-4-rep rep-component-type drop float ; +M: double-2-rep rep-component-type drop double ; + +: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable +: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable +: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable +: signed-interval ( c-type -- from to ) heap-size (signed-interval) ; foldable + +: c-type-interval ( c-type -- from to ) + { + { [ dup { float double } memq? ] [ drop -1/0. 1/0. ] } + { [ dup { char short int long longlong } memq? ] [ signed-interval ] } + { [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] } + } cond ; foldable + +: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index bc70230fd0..095ab38ace 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov +! copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-arrays alien.c-types alien.data kernel continuations destructors sequences io openssl openssl.libcrypto @@ -23,10 +23,10 @@ TUPLE: evp-md-context < disposable handle ; : ( -- ctx ) evp-md-context new-disposable - EVP_MD_CTX dup EVP_MD_CTX_init >>handle ; + EVP_MD_CTX_create >>handle ; M: evp-md-context dispose* - handle>> EVP_MD_CTX_cleanup drop ; + handle>> EVP_MD_CTX_destroy ; : with-evp-md-context ( quot -- ) maybe-init-ssl [ ] dip with-disposal ; inline diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index b60bfa375b..a026417171 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -3,7 +3,7 @@ USING: accessors alien alien.c-types alien.data ascii assocs byte-arrays classes.struct classes.tuple.private combinators compiler.tree.debugger compiler.units destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc -literals math mirrors multiline namespaces prettyprint +literals math mirrors namespaces prettyprint prettyprint.config see sequences specialized-arrays system tools.test parser lexer eval layouts ; FROM: math => float ; @@ -183,18 +183,18 @@ STRUCT: struct-test-string-ptr ] with-scope ] unit-test -[ <" USING: alien.c-types classes.struct ; +[ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-foo { x char initial: 0 } { y int initial: 123 } { z bool } ; -"> ] +" ] [ [ struct-test-foo see ] with-string-writer ] unit-test -[ <" USING: alien.c-types classes.struct ; +[ "USING: alien.c-types classes.struct ; IN: classes.struct.tests UNION-STRUCT: struct-test-float-and-bits { f float initial: 0.0 } { bits uint initial: 0 } ; -"> ] +" ] [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test [ { diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 7e99328652..63f2ad282e 100755 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -103,6 +103,8 @@ M: struct-class boa>object [ ] [ struct-slots ] bi [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ; +M: struct-class initial-value* ; inline + ! Struct slot accessors GENERIC: struct-slot-values ( struct -- sequence ) @@ -113,6 +115,9 @@ M: struct-class reader-quot M: struct-class writer-quot nip (writer-quot) ; +: offset-of ( field struct -- offset ) + struct-slots slot-named offset>> ; inline + ! c-types TUPLE: struct-c-type < abstract-c-type @@ -202,15 +207,29 @@ M: struct byte-length class "struct-size" word-prop ; foldable ! class definition c-ptr ] bi + [ *uchar zero? ] curry all? ; + +: struct-needs-prototype? ( class -- ? ) + struct-slots [ initial>> binary-zero? ] all? not ; + : make-struct-prototype ( class -- prototype ) - [ "struct-size" word-prop ] - [ memory>struct ] - [ struct-slots ] tri - [ - [ initial>> ] - [ (writer-quot) ] bi - over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if - ] each ; + dup struct-needs-prototype? [ + [ "struct-size" word-prop ] + [ memory>struct ] + [ struct-slots ] tri + [ + [ initial>> ] + [ (writer-quot) ] bi + over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if + ] each + ] [ drop f ] if ; : (struct-methods) ( class -- ) [ (define-struct-slot-values-method) ] diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 85545a730c..2b98f5c061 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations math sequences -multiline stack-checker ; +stack-checker ; IN: combinators.smart HELP: inputarray { $description "Infers the number or outputs from the quotation and constructs an array from those outputs." } { $examples { $example - <" USING: combinators combinators.smart math prettyprint ; + "USING: combinators combinators.smart math prettyprint ; 9 [ { [ 1 - ] [ 1 + ] [ sq ] } cleave -] output>array ."> +] output>array ." "{ 8 10 81 }" } } ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 7c28198f67..874093ed40 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -305,16 +305,36 @@ def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##saturated-add-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##add-sub-vector +def: dst +use: src1 src2 +literal: rep ; + PURE-INSN: ##sub-vector def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##saturated-sub-vector +def: dst +use: src1 src2 +literal: rep ; + PURE-INSN: ##mul-vector def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##saturated-mul-vector +def: dst +use: src1 src2 +literal: rep ; + PURE-INSN: ##div-vector def: dst use: src1 src2 @@ -330,14 +350,34 @@ def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##horizontal-add-vector +def: dst/scalar-rep +use: src +literal: rep ; + +PURE-INSN: ##abs-vector +def: dst +use: src +literal: rep ; + PURE-INSN: ##sqrt-vector def: dst use: src literal: rep ; -PURE-INSN: ##horizontal-add-vector -def: dst/scalar-rep -use: src +PURE-INSN: ##and-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##or-vector +def: dst +use: src1 src2 +literal: rep ; + +PURE-INSN: ##xor-vector +def: dst +use: src1 src2 literal: rep ; ! Boxing and unboxing aliens diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 0daab82395..d2f158f06d 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -151,27 +151,31 @@ IN: compiler.cfg.intrinsics { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } } enable-intrinsics ; -: enable-sse2-simd ( -- ) +: enable-simd ( -- ) { { math.vectors.simd.intrinsics:assert-positive [ drop ] } { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] } - { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vabs) [ [ ^^abs-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] } { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] } { 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-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] } { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] } { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] } } enable-intrinsics ; -: enable-sse3-simd ( -- ) - { - { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] } - } enable-intrinsics ; - : emit-intrinsic ( node word -- ) "intrinsic" word-prop call( node -- ) ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 8754b65475..572107be6c 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -28,10 +28,12 @@ SYMBOL: pending-interval-assoc : remove-pending ( live-interval -- ) vreg>> pending-interval-assoc get delete-at ; +ERROR: bad-vreg vreg ; + : (vreg>reg) ( vreg pending -- reg ) ! If a live vreg is not in the pending set, then it must ! have been spilled. - ?at [ spill-slots get at ] unless ; + ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ; : vreg>reg ( vreg -- reg ) pending-interval-assoc get (vreg>reg) ; @@ -157,8 +159,6 @@ M: insn assign-registers-in-insn drop ; : end-block ( bb -- ) [ live-out vregs>regs ] keep register-live-outs get set-at ; -ERROR: bad-vreg vreg ; - : vreg-at-start ( vreg bb -- state ) register-live-ins get at ?at [ bad-vreg ] unless ; diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 6fd97c64da..44b2ff907a 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -4,12 +4,18 @@ USING: kernel accessors math sequences grouping namespaces compiler.cfg.linearization.order ; IN: compiler.cfg.linear-scan.numbering -: number-instructions ( rpo -- ) - linearization-order 0 [ - instructions>> [ - [ (>>insn#) ] [ drop 2 + ] 2bi - ] each - ] reduce drop ; +ERROR: already-numbered insn ; + +: number-instruction ( n insn -- n' ) + [ nip dup insn#>> [ already-numbered ] [ drop ] if ] + [ (>>insn#) ] + [ drop 2 + ] + 2tri ; + +: number-instructions ( cfg -- ) + linearization-order + 0 [ instructions>> [ number-instruction ] each ] reduce + drop ; SYMBOL: check-numbering? diff --git a/basis/compiler/cfg/linearization/order/order-tests.factor b/basis/compiler/cfg/linearization/order/order-tests.factor new file mode 100644 index 0000000000..67fb55f507 --- /dev/null +++ b/basis/compiler/cfg/linearization/order/order-tests.factor @@ -0,0 +1,14 @@ +USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order +kernel accessors sequences sets tools.test namespaces ; +IN: compiler.cfg.linearization.order.tests + +V{ } 0 test-bb + +V{ } 1 test-bb + +V{ } 2 test-bb + +0 { 1 1 } edges +1 2 edge + +[ t ] [ cfg new 0 get >>entry linearization-order [ id>> ] map all-unique? ] unit-test diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor index 703db8e516..1fcc137c60 100644 --- a/basis/compiler/cfg/linearization/order/order.factor +++ b/basis/compiler/cfg/linearization/order/order.factor @@ -3,7 +3,7 @@ USING: accessors assocs deques dlists kernel make sorting namespaces sequences combinators combinators.short-circuit fry math sets compiler.cfg.rpo compiler.cfg.utilities -compiler.cfg.loop-detection ; +compiler.cfg.loop-detection compiler.cfg.predecessors ; IN: compiler.cfg.linearization.order ! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp @@ -56,10 +56,12 @@ SYMBOLS: work-list loop-heads visited ; successors>> [ loop-nesting-at ] sort-with ; : process-block ( bb -- ) - [ , ] - [ visited get conjoin ] - [ sorted-successors [ process-successor ] each ] - tri ; + dup visited? [ drop ] [ + [ , ] + [ visited get conjoin ] + [ sorted-successors [ process-successor ] each ] + tri + ] if ; : (linearization-order) ( cfg -- bbs ) init-linearization-order @@ -69,7 +71,7 @@ SYMBOLS: work-list loop-heads visited ; PRIVATE> : linearization-order ( cfg -- bbs ) - needs-post-order needs-loops + needs-post-order needs-loops needs-predecessors dup linear-order>> [ ] [ dup (linearization-order) diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor index 14287e900f..d58cebac65 100644 --- a/basis/compiler/cfg/ssa/cssa/cssa.factor +++ b/basis/compiler/cfg/ssa/cssa/cssa.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel locals fry +USING: accessors assocs kernel locals fry sequences cpu.architecture compiler.cfg.rpo +compiler.cfg.def-use compiler.cfg.utilities compiler.cfg.registers compiler.cfg.instructions @@ -13,10 +14,19 @@ IN: compiler.cfg.ssa.cssa ! selection, so it must keep track of representations when introducing ! new values. +: insert-copy? ( bb vreg -- ? ) + ! If the last instruction defines a value (which means it is + ! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't + ! need to insert a copy since in fact doing so will result + ! in incorrect code. + [ instructions>> last defs-vreg ] dip eq? not ; + :: insert-copy ( bb src rep -- bb dst ) - rep next-vreg-rep :> dst - bb [ dst src rep src rep-of emit-conversion ] add-instructions - bb dst ; + bb src insert-copy? [ + rep next-vreg-rep :> dst + bb [ dst src rep src rep-of emit-conversion ] add-instructions + bb dst + ] [ bb src ] if ; : convert-phi ( ##phi -- ) dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ; diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index 20fa1d0b18..45d248f8f4 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -47,11 +47,18 @@ UNION: two-operand-insn ##min-float ##max-float ##add-vector + ##saturated-add-vector + ##add-sub-vector ##sub-vector + ##saturated-sub-vector ##mul-vector + ##saturated-mul-vector ##div-vector ##min-vector - ##max-vector ; + ##max-vector + ##and-vector + ##or-vector + ##xor-vector ; GENERIC: convert-two-operand* ( insn -- ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index e1551f54c0..43d11b5d4f 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -169,13 +169,21 @@ CODEGEN: ##gather-vector-2 %gather-vector-2 CODEGEN: ##gather-vector-4 %gather-vector-4 CODEGEN: ##box-vector %box-vector CODEGEN: ##add-vector %add-vector +CODEGEN: ##saturated-add-vector %saturated-add-vector +CODEGEN: ##add-sub-vector %add-sub-vector CODEGEN: ##sub-vector %sub-vector +CODEGEN: ##saturated-sub-vector %saturated-sub-vector CODEGEN: ##mul-vector %mul-vector +CODEGEN: ##saturated-mul-vector %saturated-mul-vector CODEGEN: ##div-vector %div-vector CODEGEN: ##min-vector %min-vector CODEGEN: ##max-vector %max-vector CODEGEN: ##sqrt-vector %sqrt-vector CODEGEN: ##horizontal-add-vector %horizontal-add-vector +CODEGEN: ##abs-vector %abs-vector +CODEGEN: ##and-vector %and-vector +CODEGEN: ##or-vector %or-vector +CODEGEN: ##xor-vector %xor-vector CODEGEN: ##box-alien %box-alien CODEGEN: ##box-displaced-alien %box-displaced-alien CODEGEN: ##unbox-alien %unbox-alien diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 56e368e320..3dbde076a6 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -3,7 +3,7 @@ math hashtables.private math.private namespaces sequences tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make alien.c-types combinators.short-circuit -math.order math.libm math.parser ; +math.order math.libm math.parser alien.c-types ; FROM: math => float ; QUALIFIED: namespaces.private IN: compiler.tests.codegen @@ -416,3 +416,36 @@ cell 4 = [ [ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test [ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test + +! Bug in linearization +[ 283686952174081 ] [ + B{ 1 1 1 1 } [ + { byte-array } declare + [ 0 2 ] dip + [ + [ drop ] 2dip + [ + swap 1 < [ [ ] dip ] [ [ ] dip ] if + 0 alien-signed-4 + ] curry dup bi * + ] curry each-integer + ] compile-call +] unit-test + +TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ; + +[ 2 ] [ + little-endian? + T{ myseq f B{ 1 0 0 0 } B{ 1 0 0 0 } } + T{ myseq f B{ 0 0 0 1 } B{ 0 0 0 1 } } ? + [ + { myseq } declare + [ 0 2 ] dip dup + [ + [ + over 1 < [ underlying1>> ] [ [ 1 - ] dip underlying2>> ] if + swap 4 * >fixnum alien-signed-4 + ] bi-curry@ bi * + + ] 2curry each-integer + ] compile-call +] unit-test diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor index 5050ce1950..ebdee36b70 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel classes.mixin arrays ; IN: compiler.tests.folding @@ -7,20 +7,18 @@ IN: compiler.tests.folding [ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: math arrays ; + "USING: math arrays ; IN: compiler.tests.folding GENERIC: foldable-generic ( a -- b ) foldable - M: integer foldable-generic f ; - "> eval( -- ) + M: integer foldable-generic f ;" + eval( -- ) ] unit-test [ ] [ - <" - USING: math arrays ; + "USING: math arrays ; IN: compiler.tests.folding - : fold-test ( -- x ) 10 foldable-generic ; - "> eval( -- ) + : fold-test ( -- x ) 10 foldable-generic ;" + eval( -- ) ] unit-test [ t ] [ diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index e2fc26e94b..76d7e6de42 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -18,7 +18,7 @@ IN: compiler.tests.low-level-ir compile-cfg ; : compile-test-bb ( insns -- result ) - V{ T{ ##prologue } T{ ##branch } } 0 test-bb + V{ T{ ##prologue } T{ ##branch } } [ clone ] map 0 test-bb V{ T{ ##inc-d f 1 } T{ ##replace f 0 D 0 } @@ -73,7 +73,7 @@ IN: compiler.tests.low-level-ir [ t ] [ V{ T{ ##load-reference f 0 { t f t } } - T{ ##slot-imm f 0 0 2 $[ array tag-number ] 2 } + T{ ##slot-imm f 0 0 2 $[ array tag-number ] } } compile-test-bb ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 45ea841a73..18679ce77b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * ) [ t ] [ \ -regression optimized? ] unit-test -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ t ] [ - reversed \ foozul specific-method - reversed \ foozul method - eq? -] unit-test - ! regression : constant-fold-2 ( -- value ) f ; foldable : constant-fold-3 ( -- value ) 4 ; foldable diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index 66edd75097..768b926389 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -1,5 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words -kernel ; +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine10 ! Mixin redefinition did not recompile all necessary words. @@ -7,21 +6,19 @@ IN: compiler.tests.redefine10 [ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math classes ; + "USING: kernel math classes ; IN: compiler.tests.redefine10 MIXIN: my-mixin INSTANCE: fixnum my-mixin - : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; - "> eval( -- ) + : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: math + "USE: math IN: compiler.tests.redefine10 - INSTANCE: float my-mixin - "> eval( -- ) + INSTANCE: float my-mixin" + eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index dbec57e3d5..0f16a42cc3 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel classes.mixin arrays ; IN: compiler.tests.redefine11 @@ -7,8 +7,7 @@ IN: compiler.tests.redefine11 [ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math classes arrays ; + "USING: kernel math classes arrays ; IN: compiler.tests.redefine11 MIXIN: my-mixin INSTANCE: array my-mixin @@ -16,8 +15,8 @@ IN: compiler.tests.redefine11 GENERIC: my-generic ( a -- b ) M: my-mixin my-generic drop 0 ; M: object my-generic drop 1 ; - : my-inline ( -- b ) { } my-generic ; - "> eval( -- ) + : my-inline ( -- b ) { } my-generic ;" + eval( -- ) ] unit-test [ ] [ diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index 7613987852..38623393e7 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -1,5 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words -kernel ; +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine5 ! Regression: if dispatch was eliminated but method was not inlined, @@ -8,22 +7,19 @@ IN: compiler.tests.redefine5 [ "compiler.tests.redefine5" forget-vocab ] with-compilation-unit [ ] [ - <" - USING: sorting kernel math.order ; + "USING: sorting kernel math.order ; IN: compiler.tests.redefine5 GENERIC: my-generic ( a -- b ) M: object my-generic [ <=> ] sort ; - : my-inline ( a -- b ) my-generic ; - "> eval( -- ) + : my-inline ( a -- b ) my-generic ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: kernel + "USE: kernel IN: compiler.tests.redefine5 TUPLE: my-tuple ; - M: my-tuple my-generic drop 0 ; - "> eval( -- ) + M: my-tuple my-generic drop 0 ;" eval( -- ) ] unit-test [ 0 ] [ diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index fdf3e7edbb..892c768bc5 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine6 @@ -7,24 +7,22 @@ IN: compiler.tests.redefine6 [ ] [ [ "compiler.tests.redefine6" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel kernel.private ; + "USING: kernel kernel.private ; IN: compiler.tests.redefine6 GENERIC: my-generic ( a -- b ) MIXIN: my-mixin M: my-mixin my-generic drop 0 ; - : my-inline ( a -- b ) { my-mixin } declare my-generic ; - "> eval( -- ) + : my-inline ( a -- b ) { my-mixin } declare my-generic ;" + eval( -- ) ] unit-test [ ] [ - <" - USING: kernel ; + "USING: kernel ; IN: compiler.tests.redefine6 TUPLE: my-tuple ; M: my-tuple my-generic drop 1 ; - INSTANCE: my-tuple my-mixin - "> eval( -- ) + INSTANCE: my-tuple my-mixin" + eval( -- ) ] unit-test [ 1 ] [ diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index cfe29603f9..8e7abcb372 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine7 @@ -7,21 +7,19 @@ IN: compiler.tests.redefine7 [ ] [ [ "compiler.tests.redefine7" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math ; + "USING: kernel math ; IN: compiler.tests.redefine7 MIXIN: my-mixin INSTANCE: fixnum my-mixin - : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; - "> eval( -- ) + : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: math + "USE: math IN: compiler.tests.redefine7 - INSTANCE: float my-mixin - "> eval( -- ) + INSTANCE: float my-mixin" + eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index a79bfb5af5..b4deeb3cc1 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel ; IN: compiler.tests.redefine8 @@ -7,24 +7,22 @@ IN: compiler.tests.redefine8 [ ] [ [ "compiler.tests.redefine8" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math math.order sorting ; + "USING: kernel math math.order sorting ; IN: compiler.tests.redefine8 MIXIN: my-mixin INSTANCE: fixnum my-mixin GENERIC: my-generic ( a -- b ) ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. - M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> eval( -- ) + M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: math + "USE: math IN: compiler.tests.redefine8 - INSTANCE: float my-mixin - "> eval( -- ) + INSTANCE: float my-mixin" + eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 2598246472..abc677dd77 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -1,4 +1,4 @@ -USING: eval tools.test compiler.units vocabs multiline words +USING: eval tools.test compiler.units vocabs words kernel generic.math ; IN: compiler.tests.redefine9 @@ -7,25 +7,23 @@ IN: compiler.tests.redefine9 [ ] [ [ "compiler.tests.redefine9" forget-vocab ] with-compilation-unit ] unit-test [ ] [ - <" - USING: kernel math math.order sorting ; + "USING: kernel math math.order sorting ; IN: compiler.tests.redefine9 MIXIN: my-mixin INSTANCE: fixnum my-mixin GENERIC: my-generic ( a -- b ) ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. - M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> eval( -- ) + M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;" + eval( -- ) ] unit-test [ ] [ - <" - USE: math + "USE: math IN: compiler.tests.redefine9 TUPLE: my-tuple ; - INSTANCE: my-tuple my-mixin - "> eval( -- ) + INSTANCE: my-tuple my-mixin" + eval( -- ) ] unit-test [ diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index f2613022fc..b8861a6292 100755 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry kernel sequences assocs accessors namespaces math.intervals arrays classes.algebra combinators columns -stack-checker.branches +stack-checker.branches locals compiler.utilities compiler.tree compiler.tree.combinators @@ -82,6 +82,13 @@ M: #phi propagate-before ( #phi -- ) [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] bi ; +:: update-constraints ( new old -- ) + new [| key value | key old [ value append ] change-at ] assoc-each ; + +: include-child-constraints ( i -- ) + infer-children-data get nth constraints swap at last + constraints get last update-constraints ; + : branch-phi-constraints ( output values booleans -- ) { { @@ -116,22 +123,24 @@ M: #phi propagate-before ( #phi -- ) swap t--> ] } - ! { - ! { { t f } { } } - ! [ B - ! first - ! [ [ =t ] bi@ <--> ] - ! [ [ =f ] bi@ <--> ] 2bi /\ - ! ] - ! } - ! { - ! { { } { t f } } - ! [ - ! second - ! [ [ =t ] bi@ <--> ] - ! [ [ =f ] bi@ <--> ] 2bi /\ - ! ] - ! } + { + { { t f } { } } + [ + first + [ [ =t ] bi@ <--> ] + [ [ =f ] bi@ <--> ] 2bi /\ + 0 include-child-constraints + ] + } + { + { { } { t f } } + [ + second + [ [ =t ] bi@ <--> ] + [ [ =f ] bi@ <--> ] 2bi /\ + 1 include-child-constraints + ] + } [ 3drop f ] } case assume ; @@ -146,9 +155,6 @@ M: #phi propagate-after ( #phi -- ) ] 3each ] [ drop ] if ; -M: #phi propagate-around ( #phi -- ) - [ propagate-before ] [ propagate-after ] bi ; - M: #branch propagate-around dup live-branches >>live-branches [ infer-children ] [ annotate-node ] bi ; diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index 31f6cea148..59c9912e47 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs math math.intervals kernel accessors sequences namespaces classes classes.algebra -combinators words +combinators words combinators.short-circuit compiler.tree compiler.tree.propagation.info compiler.tree.propagation.copy ; @@ -28,15 +28,19 @@ M: object satisfied? drop f ; ! Boolean constraints TUPLE: true-constraint value ; -: =t ( value -- constriant ) resolve-copy true-constraint boa ; +: =t ( value -- constraint ) resolve-copy true-constraint boa ; + +: follow-implications ( constraint -- ) + constraints get assoc-stack [ assume ] when* ; M: true-constraint assume* [ \ f class-not swap value>> refine-value-info ] - [ constraints get assoc-stack [ assume ] when* ] + [ follow-implications ] bi ; M: true-constraint satisfied? - value>> value-info class>> true-class? ; + value>> value-info class>> + { [ true-class? ] [ null-class? not ] } 1&& ; TUPLE: false-constraint value ; @@ -44,11 +48,12 @@ TUPLE: false-constraint value ; M: false-constraint assume* [ \ f swap value>> refine-value-info ] - [ constraints get assoc-stack [ assume ] when* ] + [ follow-implications ] bi ; M: false-constraint satisfied? - value>> value-info class>> false-class? ; + value>> value-info class>> + { [ false-class? ] [ null-class? not ] } 1&& ; ! Class constraints TUPLE: class-constraint value class ; @@ -82,7 +87,7 @@ TUPLE: implication p q ; C: --> implication -: assume-implication ( p q -- ) +: assume-implication ( q p -- ) [ constraints get [ assoc-stack swap suffix ] 2keep last set-at ] [ satisfied? [ assume ] [ drop ] if ] 2bi ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 0a04b48160..53b2109bbb 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -302,7 +302,7 @@ SYMBOL: value-infos : refine-value-info ( info value -- ) resolve-copy value-infos get - [ assoc-stack value-info-intersect ] 2keep + [ assoc-stack [ value-info-intersect ] when* ] 2keep last set-at ; : value-literal ( value -- obj ? ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0b50632e4e..367427c716 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ; 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ [ in-d>> ] [ [ dispatch# ] keep ] bi* [ swap nth value-info class>> dup ] dip - specific-method + method-for-class ] if ] if ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 621b8d082b..d4780b335b 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -18,6 +18,7 @@ compiler.tree.propagation.constraints compiler.tree.propagation.call-effect compiler.tree.propagation.transforms compiler.tree.propagation.simd ; +FROM: alien.c-types => (signed-interval) (unsigned-interval) ; IN: compiler.tree.propagation.known-words { + - * / } @@ -260,15 +261,9 @@ generic-comparison-ops [ alien-unsigned-8 } [ dup name>> { - { - [ "alien-signed-" ?head ] - [ string>number 8 * 1 - 2^ dup neg swap 1 - [a,b] ] - } - { - [ "alien-unsigned-" ?head ] - [ string>number 8 * 2^ 1 - 0 swap [a,b] ] - } - } cond + { [ "alien-signed-" ?head ] [ string>number (signed-interval) ] } + { [ "alien-unsigned-" ?head ] [ string>number (unsigned-interval) ] } + } cond [a,b] [ fits-in-fixnum? fixnum integer ? ] keep '[ 2drop _ ] "outputs" set-word-prop ] each diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 0da234791b..b436b21329 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -764,17 +764,17 @@ MIXIN: empty-mixin [ { word object } declare equal? ] final-classes ] unit-test -! [ V{ string } ] [ -! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes -! ] unit-test +[ V{ string } ] [ + [ dup string? t xor [ "A" throw ] [ ] if ] final-classes +] unit-test -! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test +[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test -! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test +[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test -! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test +[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test -! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test +[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test ! generalize-counter-interval wasn't being called in all the right places. ! bug found by littledan diff --git a/basis/compiler/tree/propagation/simd/simd.factor b/basis/compiler/tree/propagation/simd/simd.factor index 3baa7cdcbf..fadb382398 100644 --- a/basis/compiler/tree/propagation/simd/simd.factor +++ b/basis/compiler/tree/propagation/simd/simd.factor @@ -1,46 +1,45 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays combinators fry +USING: accessors byte-arrays combinators fry sequences compiler.tree.propagation.info cpu.architecture kernel words math math.intervals math.vectors.simd.intrinsics ; IN: compiler.tree.propagation.simd -\ (simd-v+) { byte-array } "default-output-classes" set-word-prop - -\ (simd-v-) { byte-array } "default-output-classes" set-word-prop - -\ (simd-v*) { byte-array } "default-output-classes" set-word-prop - -\ (simd-v/) { byte-array } "default-output-classes" set-word-prop - -\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop - -\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop - -\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop +{ + (simd-v+) + (simd-v-) + (simd-v+-) + (simd-v*) + (simd-v/) + (simd-vmin) + (simd-vmax) + (simd-sum) + (simd-vabs) + (simd-vsqrt) + (simd-vbitand) + (simd-vbitor) + (simd-vbitxor) + (simd-broadcast) + (simd-gather-2) + (simd-gather-4) + alien-vector +} [ { byte-array } "default-output-classes" set-word-prop ] each \ (simd-sum) [ nip dup literal?>> [ literal>> scalar-rep-of { { float-rep [ float ] } { double-rep [ float ] } + { int-rep [ integer ] } } case ] [ drop real ] if ] "outputs" set-word-prop -\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop - -\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop - -\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop - \ assert-positive [ real [0,inf] value-info-intersect ] "outputs" set-word-prop -\ alien-vector { byte-array } "default-output-classes" set-word-prop - ! If SIMD is not available, inline alien-vector and set-alien-vector ! to get a speedup : inline-unless-intrinsic ( word -- ) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index e08a21d4b9..8aa6a821d8 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -14,7 +14,7 @@ IN: compiler.tree.propagation.transforms ! If first input has a known type and second input is an ! object, we convert this to [ swap equal? ]. in-d>> first2 value-info class>> object class= [ - value-info class>> \ equal? specific-method + value-info class>> \ equal? method-for-class [ swap equal? ] f ? ] [ drop f ] if ] "custom-inlining" set-word-prop diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index fbec9f697a..dd817117b6 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -22,24 +22,36 @@ SINGLETONS: float-rep double-rep ; ! On x86, floating point registers are really vector registers SINGLETONS: -float-4-rep -double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep -uint-4-rep ; +uint-4-rep +longlong-2-rep +ulonglong-2-rep ; + +SINGLETONS: +float-4-rep +double-2-rep ; + +UNION: int-vector-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 ; + +UNION: float-vector-rep +float-4-rep +double-2-rep ; UNION: vector-rep -float-4-rep -double-2-rep -char-16-rep -uchar-16-rep -short-8-rep -ushort-8-rep -int-4-rep -uint-4-rep ; +int-vector-rep +float-vector-rep ; UNION: representation any-rep @@ -76,10 +88,15 @@ M: double-rep rep-size drop 8 ; M: stack-params rep-size drop cell ; M: vector-rep rep-size drop 16 ; +GENERIC: rep-component-type ( rep -- n ) + +! Methods defined in alien.c-types + GENERIC: scalar-rep-of ( rep -- rep' ) M: float-4-rep scalar-rep-of drop float-rep ; M: double-2-rep scalar-rep-of drop double-rep ; +M: int-vector-rep scalar-rep-of drop int-rep ; ! Mapping from register class to machine registers HOOK: machine-registers cpu ( -- assoc ) @@ -167,15 +184,42 @@ HOOK: %unbox-vector cpu ( dst src rep -- ) HOOK: %broadcast-vector cpu ( dst src rep -- ) HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- ) HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- ) - HOOK: %add-vector cpu ( dst src1 src2 rep -- ) +HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- ) +HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- ) HOOK: %sub-vector cpu ( dst src1 src2 rep -- ) +HOOK: %saturated-sub-vector cpu ( dst src1 src2 rep -- ) HOOK: %mul-vector cpu ( dst src1 src2 rep -- ) +HOOK: %saturated-mul-vector cpu ( dst src1 src2 rep -- ) HOOK: %div-vector cpu ( dst src1 src2 rep -- ) HOOK: %min-vector cpu ( dst src1 src2 rep -- ) HOOK: %max-vector cpu ( dst src1 src2 rep -- ) HOOK: %sqrt-vector cpu ( dst src rep -- ) HOOK: %horizontal-add-vector cpu ( dst src rep -- ) +HOOK: %abs-vector cpu ( dst src rep -- ) +HOOK: %and-vector cpu ( dst src1 src2 rep -- ) +HOOK: %or-vector cpu ( dst src1 src2 rep -- ) +HOOK: %xor-vector cpu ( dst src1 src2 rep -- ) + +HOOK: %broadcast-vector-reps cpu ( -- reps ) +HOOK: %gather-vector-2-reps cpu ( -- reps ) +HOOK: %gather-vector-4-reps cpu ( -- reps ) +HOOK: %add-vector-reps cpu ( -- reps ) +HOOK: %saturated-add-vector-reps cpu ( -- reps ) +HOOK: %add-sub-vector-reps cpu ( -- reps ) +HOOK: %sub-vector-reps cpu ( -- reps ) +HOOK: %saturated-sub-vector-reps cpu ( -- reps ) +HOOK: %mul-vector-reps cpu ( -- reps ) +HOOK: %saturated-mul-vector-reps cpu ( -- reps ) +HOOK: %div-vector-reps cpu ( -- reps ) +HOOK: %min-vector-reps cpu ( -- reps ) +HOOK: %max-vector-reps cpu ( -- reps ) +HOOK: %sqrt-vector-reps cpu ( -- reps ) +HOOK: %horizontal-add-vector-reps cpu ( -- reps ) +HOOK: %abs-vector-reps cpu ( -- reps ) +HOOK: %and-vector-reps cpu ( -- reps ) +HOOK: %or-vector-reps cpu ( -- reps ) +HOOK: %xor-vector-reps cpu ( -- reps ) HOOK: %unbox-alien cpu ( dst src -- ) HOOK: %unbox-any-c-ptr cpu ( dst src temp -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 2a16a8b6df..87bea69d9e 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -9,6 +9,7 @@ compiler.codegen.fixup compiler.cfg.intrinsics compiler.cfg.stack-frame compiler.cfg.build-stack-frame compiler.units compiler.constants compiler.codegen vm ; FROM: cpu.ppc.assembler => B ; +FROM: layouts => cell ; FROM: math => float ; IN: cpu.ppc @@ -283,10 +284,12 @@ M:: ppc %float>integer ( dst src -- ) dst 1 4 scratch@ LWZ ; M: ppc %copy ( dst src rep -- ) - { - { int-rep [ MR ] } - { double-rep [ FMR ] } - } case ; + 2over eq? [ 3drop ] [ + { + { int-rep [ MR ] } + { double-rep [ FMR ] } + } case + ] if ; M: ppc %unbox-float ( dst src -- ) float-offset LFD ; @@ -298,7 +301,7 @@ M:: ppc %box-float ( dst src temp -- ) [ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ; : float-function-return ( reg -- ) - float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ; + float-regs return-reg double-rep %copy ; M:: ppc %unary-float-function ( dst src func -- ) 0 src float-function-param @@ -312,9 +315,29 @@ M:: ppc %binary-float-function ( dst src1 src2 func -- ) dst float-function-return ; ! Internal format is always double-precision on PowerPC -M: ppc %single>double-float FMR ; +M: ppc %single>double-float double-rep %copy ; +M: ppc %double>single-float double-rep %copy ; -M: ppc %double>single-float FMR ; +! VMX/AltiVec not supported yet +M: %broadcast-vector-reps drop { } ; +M: %gather-vector-2-reps drop { } ; +M: %gather-vector-4-reps drop { } ; +M: %add-vector-reps drop { } ; +M: %saturated-add-vector-reps drop { } ; +M: %add-sub-vector-reps drop { } ; +M: %sub-vector-reps drop { } ; +M: %saturated-sub-vector-reps drop { } ; +M: %mul-vector-reps drop { } ; +M: %saturated-mul-vector-reps drop { } ; +M: %div-vector-reps drop { } ; +M: %min-vector-reps drop { } ; +M: %max-vector-reps drop { } ; +M: %sqrt-vector-reps drop { } ; +M: %horizontal-add-vector-reps drop { } ; +M: %abs-vector-reps drop { } ; +M: %and-vector-reps drop { } ; +M: %or-vector-reps drop { } ; +M: %xor-vector-reps drop { } ; M: ppc %unbox-alien ( dst src -- ) alien-offset LWZ ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 85db5fb09c..7a7d1befd9 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -322,4 +322,4 @@ os windows? [ 4 "double" c-type (>>align) ] unless -"cpu.x86.features" require +check-sse diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 0528733af1..ef24006e2a 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -58,9 +58,9 @@ M: stack-params copy-register* { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] } } cond ; -M: x86 %save-param-reg [ param@ ] 2dip copy-register ; +M: x86 %save-param-reg [ param@ ] 2dip %copy ; -M: x86 %load-param-reg [ swap param@ ] dip copy-register ; +M: x86 %load-param-reg [ swap param@ ] dip %copy ; : with-return-regs ( quot -- ) [ @@ -133,7 +133,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- ) [ [ 0 ] dip reg-class-of param-reg ] [ reg-class-of return-reg ] [ ] - tri copy-register ; + tri %copy ; @@ -222,7 +222,7 @@ M: x86.64 %callback-value ( ctype -- ) [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ; : float-function-return ( reg -- ) - float-regs return-reg double-rep copy-register ; + float-regs return-reg double-rep %copy ; M:: x86.64 %unary-float-function ( dst src func -- ) 0 src float-function-param @@ -249,4 +249,4 @@ USE: vocabs.loader { [ os winnt? ] [ "cpu.x86.64.winnt" require ] } } cond -"cpu.x86.features" require +check-sse diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index ead1c8a695..ceb9c54e6e 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -198,12 +198,16 @@ M: register POP f HEX: 58 short-operand ; M: operand POP { BIN: 000 f HEX: 8f } 1-operand ; ! MOV where the src is immediate. + + GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; M: operand MOV HEX: 88 2-operand ; @@ -219,9 +223,13 @@ GENERIC: CALL ( op -- ) M: integer CALL HEX: e8 , 4, ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; + + : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; : JB ( dst -- ) HEX: 82 JUMPcc ; @@ -296,6 +304,8 @@ M: operand TEST OCT: 204 2-operand ; : CDQ ( -- ) HEX: 99 , ; : CQO ( -- ) HEX: 48 , CDQ ; + + : ROL ( dst n -- ) BIN: 000 (SHIFT) ; : ROR ( dst n -- ) BIN: 001 (SHIFT) ; : RCL ( dst n -- ) BIN: 010 (SHIFT) ; diff --git a/basis/cpu/x86/assembler/operands/authors.txt b/basis/cpu/x86/assembler/operands/authors.txt new file mode 100644 index 0000000000..580f882c8d --- /dev/null +++ b/basis/cpu/x86/assembler/operands/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Joe Groff diff --git a/basis/cpu/x86/assembler/operands/summary.txt b/basis/cpu/x86/assembler/operands/summary.txt new file mode 100644 index 0000000000..474b715848 --- /dev/null +++ b/basis/cpu/x86/assembler/operands/summary.txt @@ -0,0 +1 @@ +x86 registers and memory operands diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor index c5cf2d470a..b21aa762d8 100644 --- a/basis/cpu/x86/features/features.factor +++ b/basis/cpu/x86/features/features.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system kernel math math.order math.parser namespaces -alien.c-types alien.syntax combinators locals init io cpu.x86 +USING: system kernel memoize math math.order math.parser +namespaces alien.c-types alien.syntax combinators locals init io compiler compiler.units accessors ; IN: cpu.x86.features @@ -13,7 +13,18 @@ FUNCTION: longlong read_timestamp_counter ( ) ; PRIVATE> -ALIAS: sse-version sse_version +MEMO: sse-version ( -- n ) + sse_version + "sse-version" get string>number [ min ] when* ; + +[ \ sse-version reset-memoized ] "cpu.x86.features" add-init-hook + +: sse? ( -- ? ) sse-version 10 >= ; +: sse2? ( -- ? ) sse-version 20 >= ; +: sse3? ( -- ? ) sse-version 30 >= ; +: ssse3? ( -- ? ) sse-version 33 >= ; +: sse4.1? ( -- ? ) sse-version 41 >= ; +: sse4.2? ( -- ? ) sse-version 42 >= ; : sse-string ( version -- string ) { @@ -32,37 +43,3 @@ M: x86 instruction-count read_timestamp_counter ; : count-instructions ( quot -- n ) instruction-count [ call ] dip instruction-count swap - ; inline - -USING: cpu.x86.features cpu.x86.features.private ; - -:: install-sse-check ( version -- ) - [ - sse-version version < [ - "This image was built to use " write - version sse-string write - " but your CPU only supports " write - sse-version sse-string write "." print - "You will need to bootstrap Factor again." print - flush - 1 exit - ] when - ] "cpu.x86" add-init-hook ; - -: enable-sse ( version -- ) - { - { 00 [ ] } - { 10 [ ] } - { 20 [ enable-sse2 ] } - { 30 [ enable-sse3 ] } - { 33 [ enable-sse3 ] } - { 41 [ enable-sse3 ] } - { 42 [ enable-sse3 ] } - } case ; - -[ { sse_version } compile ] with-optimizer - -"Checking for multimedia extensions: " write sse-version -"sse-version" get [ string>number min ] when* -[ sse-string write " detected" print ] -[ install-sse-check ] -[ enable-sse ] tri diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d8e02fe516..5bed068a7a 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -2,9 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs alien alien.c-types arrays strings cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands -cpu.architecture kernel kernel.private math memory namespaces make -sequences words system layouts combinators math.order fry locals -compiler.constants vm byte-arrays +cpu.x86.features cpu.x86.features.private cpu.architecture kernel +kernel.private math memory namespaces make sequences words system +layouts combinators math.order fry locals compiler.constants +byte-arrays io macros quotations compiler compiler.units init vm compiler.cfg.registers compiler.cfg.instructions compiler.cfg.intrinsics @@ -139,11 +140,9 @@ M: float-4-rep copy-register* drop MOVUPS ; M: double-2-rep copy-register* drop MOVUPD ; M: vector-rep copy-register* drop MOVDQU ; -: copy-register ( dst src rep -- ) +M: x86 %copy ( dst src rep -- ) 2over eq? [ 3drop ] [ copy-register* ] if ; -M: x86 %copy ( dst src rep -- ) copy-register ; - :: overflow-template ( label dst src1 src2 insn -- ) src1 src2 insn call label JO ; inline @@ -242,24 +241,38 @@ M:: x86 %box-vector ( dst src rep temp -- ) dst rep rep-size 2 cells + byte-array temp %allot 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm dst byte-array-offset [+] - src rep copy-register ; + src rep %copy ; M:: x86 %unbox-vector ( dst src rep -- ) dst src byte-array-offset [+] - rep copy-register ; + rep %copy ; + +MACRO: available-reps ( alist -- ) + ! Each SSE version adds new representations and supports + ! all old ones + unzip { } [ append ] accumulate rest swap suffix + [ [ 1quotation ] map ] bi@ zip + reverse [ { } ] suffix + '[ _ cond ] ; M: x86 %broadcast-vector ( dst src rep -- ) { - { float-4-rep [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] } - { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 2bi ] } + { float-4-rep [ [ float-4-rep %copy ] [ drop dup 0 SHUFPS ] 2bi ] } + { double-2-rep [ [ double-2-rep %copy ] [ drop dup UNPCKLPD ] 2bi ] } } case ; +M: x86 %broadcast-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep } } + } available-reps ; + M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- ) rep { { float-4-rep [ - dst src1 MOVSS + dst src1 float-4-rep %copy dst src2 UNPCKLPS src3 src4 UNPCKLPS dst src3 MOVLHPS @@ -267,17 +280,27 @@ M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- ) } } case ; +M: x86 %gather-vector-4-reps + { + { sse? { float-4-rep } } + } available-reps ; + M:: x86 %gather-vector-2 ( dst src1 src2 rep -- ) rep { { double-2-rep [ - dst src1 MOVSD + dst src1 double-2-rep %copy dst src2 UNPCKLPD ] } } case ; +M: x86 %gather-vector-2-reps + { + { sse2? { double-2-rep } } + } available-reps ; + M: x86 %add-vector ( dst src1 src2 rep -- ) { { float-4-rep [ ADDPS ] } @@ -288,8 +311,40 @@ M: x86 %add-vector ( dst src1 src2 rep -- ) { ushort-8-rep [ PADDW ] } { int-4-rep [ PADDD ] } { uint-4-rep [ PADDD ] } + { longlong-2-rep [ PADDQ ] } + { ulonglong-2-rep [ PADDQ ] } } case drop ; +M: x86 %add-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 ; + +M: x86 %saturated-add-vector ( dst src1 src2 rep -- ) + { + { char-16-rep [ PADDSB ] } + { uchar-16-rep [ PADDUSB ] } + { short-8-rep [ PADDSW ] } + { ushort-8-rep [ PADDUSW ] } + } case drop ; + +M: x86 %saturated-add-vector-reps + { + { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } } + } available-reps ; + +M: x86 %add-sub-vector ( dst src1 src2 rep -- ) + { + { float-4-rep [ ADDSUBPS ] } + { double-2-rep [ ADDSUBPD ] } + } case drop ; + +M: x86 %add-sub-vector-reps + { + { sse3? { float-4-rep double-2-rep } } + } available-reps ; + M: x86 %sub-vector ( dst src1 src2 rep -- ) { { float-4-rep [ SUBPS ] } @@ -300,44 +355,173 @@ M: x86 %sub-vector ( dst src1 src2 rep -- ) { ushort-8-rep [ PSUBW ] } { int-4-rep [ PSUBD ] } { uint-4-rep [ PSUBD ] } + { longlong-2-rep [ PSUBQ ] } + { ulonglong-2-rep [ PSUBQ ] } } case drop ; +M: x86 %sub-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 ; + +M: x86 %saturated-sub-vector ( dst src1 src2 rep -- ) + { + { char-16-rep [ PSUBSB ] } + { uchar-16-rep [ PSUBUSB ] } + { short-8-rep [ PSUBSW ] } + { ushort-8-rep [ PSUBUSW ] } + } case drop ; + +M: x86 %saturated-sub-vector-reps + { + { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } } + } available-reps ; + M: x86 %mul-vector ( dst src1 src2 rep -- ) { { float-4-rep [ MULPS ] } { double-2-rep [ MULPD ] } - { int-4-rep [ PMULLW ] } + { short-8-rep [ PMULLW ] } + { ushort-8-rep [ PMULLW ] } + { int-4-rep [ PMULLD ] } + { uint-4-rep [ PMULLD ] } } case drop ; +M: x86 %mul-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep short-8-rep ushort-8-rep } } + { sse4.1? { int-4-rep uint-4-rep } } + } available-reps ; + +M: x86 %saturated-mul-vector-reps + ! No multiplication with saturation on x86 + { } ; + M: x86 %div-vector ( dst src1 src2 rep -- ) { { float-4-rep [ DIVPS ] } { double-2-rep [ DIVPD ] } } case drop ; +M: x86 %div-vector-reps + { + { sse? { float-4-rep } } + { sse2? { double-2-rep } } + } available-reps ; + M: x86 %min-vector ( dst src1 src2 rep -- ) { + { char-16-rep [ PMINSB ] } + { uchar-16-rep [ PMINUB ] } + { short-8-rep [ PMINSW ] } + { ushort-8-rep [ PMINUW ] } + { int-4-rep [ PMINSD ] } + { uint-4-rep [ PMINUD ] } { float-4-rep [ MINPS ] } { double-2-rep [ MINPD ] } } case drop ; +M: x86 %min-vector-reps + { + { sse? { float-4-rep } } + { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } } + { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } + } available-reps ; + M: x86 %max-vector ( dst src1 src2 rep -- ) { + { char-16-rep [ PMAXSB ] } + { uchar-16-rep [ PMAXUB ] } + { short-8-rep [ PMAXSW ] } + { ushort-8-rep [ PMAXUW ] } + { int-4-rep [ PMAXSD ] } + { uint-4-rep [ PMAXUD ] } { float-4-rep [ MAXPS ] } { double-2-rep [ MAXPD ] } } case drop ; +M: x86 %max-vector-reps + { + { sse? { float-4-rep } } + { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } } + { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } + } available-reps ; + +M: x86 %horizontal-add-vector ( dst src rep -- ) + { + { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] } + { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] } + } case ; + +M: x86 %horizontal-add-vector-reps + { + { sse3? { float-4-rep double-2-rep } } + } available-reps ; + +M: x86 %abs-vector ( dst src rep -- ) + { + { char-16-rep [ PABSB ] } + { short-8-rep [ PABSW ] } + { int-4-rep [ PABSD ] } + } case ; + +M: x86 %abs-vector-reps + { + { ssse3? { char-16-rep short-8-rep int-4-rep } } + } available-reps ; + M: x86 %sqrt-vector ( dst src rep -- ) { { float-4-rep [ SQRTPS ] } { double-2-rep [ SQRTPD ] } } case ; -M: x86 %horizontal-add-vector ( dst src rep -- ) +M: x86 %sqrt-vector-reps { - { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] } - { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] } - } case ; + { sse? { float-4-rep } } + { sse2? { double-2-rep } } + } available-reps ; + +M: x86 %and-vector ( dst src1 src2 rep -- ) + { + { float-4-rep [ ANDPS ] } + { double-2-rep [ ANDPD ] } + [ drop PAND ] + } case drop ; + +M: x86 %and-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 ; + +M: x86 %or-vector ( dst src1 src2 rep -- ) + { + { float-4-rep [ ORPS ] } + { double-2-rep [ ORPD ] } + [ drop POR ] + } case drop ; + +M: x86 %or-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 ; + +M: x86 %xor-vector ( dst src1 src2 rep -- ) + { + { float-4-rep [ XORPS ] } + { double-2-rep [ XORPD ] } + [ drop PXOR ] + } case drop ; + +M: x86 %xor-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 ; M: x86 %unbox-alien ( dst src -- ) alien-offset [+] MOV ; @@ -452,9 +636,6 @@ M: x86.64 has-small-reg? 2drop t ; [ quot call ] with-save/restore ] if ; inline -: ?MOV ( dst src -- ) - 2dup = [ 2drop ] [ MOV ] if ; inline - M:: x86 %string-nth ( dst src index temp -- ) ! We request a small-reg of size 8 since those of size 16 are ! a superset. @@ -482,12 +663,12 @@ M:: x86 %string-nth ( dst src index temp -- ) ! Compute code point new-dst temp XOR "end" resolve-label - dst new-dst ?MOV + dst new-dst int-rep %copy ] with-small-register ; M:: x86 %set-string-nth-fast ( ch str index temp -- ) ch { index str temp } 8 [| new-ch | - new-ch ch ?MOV + new-ch ch int-rep %copy temp str index [+] LEA temp string-offset [+] new-ch 8-bit-version-of MOV ] with-small-register ; @@ -496,7 +677,7 @@ M:: x86 %set-string-nth-fast ( ch str index temp -- ) dst { src } size [| new-dst | new-dst dup size n-bit-version-of dup src [] MOV quot call - dst new-dst ?MOV + dst new-dst int-rep %copy ] with-small-register ; inline : %alien-unsigned-getter ( dst src size -- ) @@ -516,11 +697,11 @@ M: x86 %alien-signed-4 32 %alien-signed-getter ; M: x86 %alien-cell [] MOV ; M: x86 %alien-float [] MOVSS ; M: x86 %alien-double [] MOVSD ; -M: x86 %alien-vector [ [] ] dip copy-register ; +M: x86 %alien-vector [ [] ] dip %copy ; :: %alien-integer-setter ( ptr value size -- ) value { ptr } size [| new-value | - new-value value ?MOV + new-value value int-rep %copy ptr [] new-value size n-bit-version-of MOV ] with-small-register ; inline @@ -530,7 +711,7 @@ M: x86 %set-alien-integer-4 32 %alien-integer-setter ; M: x86 %set-alien-cell [ [] ] dip MOV ; M: x86 %set-alien-float [ [] ] dip MOVSS ; M: x86 %set-alien-double [ [] ] dip MOVSD ; -M: x86 %set-alien-vector [ [] ] 2dip copy-register ; +M: x86 %set-alien-vector [ [] ] 2dip %copy ; : shift-count? ( reg -- ? ) { ECX RCX } memq? ; @@ -735,10 +916,10 @@ M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- ) \ UCOMISD (%compare-float-branch) ; M:: x86 %spill ( src rep n -- ) - n spill@ src rep copy-register ; + n spill@ src rep %copy ; M:: x86 %reload ( dst rep n -- ) - dst n spill@ rep copy-register ; + dst n spill@ rep %copy ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ; @@ -767,15 +948,29 @@ M: x86 small-enough? ( n -- ? ) #! set up by the caller. stack-frame get total-size>> + stack@ ; -: enable-sse2 ( -- ) - enable-float-intrinsics - enable-fsqrt - enable-float-min/max - enable-sse2-simd ; - -: enable-sse3 ( -- ) - enable-sse2 - enable-sse3-simd ; - +enable-simd enable-min/max -enable-fixnum-log2 \ No newline at end of file +enable-fixnum-log2 + +:: install-sse2-check ( -- ) + [ + sse-version 20 < [ + "This image was built to use SSE2 but your CPU does not support it." print + "You will need to bootstrap Factor again." print + flush + 1 exit + ] when + ] "cpu.x86" add-init-hook ; + +: enable-sse2 ( version -- ) + 20 >= [ + enable-float-intrinsics + enable-fsqrt + enable-float-min/max + install-sse2-check + ] when ; + +: check-sse ( -- ) + [ { sse_version } compile ] with-optimizer + "Checking for multimedia extensions: " write sse-version + [ sse-string write " detected" print ] [ enable-sse2 ] bi ; diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index e73783fdfc..77474fffbd 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes kernel help.markup help.syntax sequences -alien assocs strings math multiline quotations db.private ; +alien assocs strings math quotations db.private ; IN: db HELP: db-connection @@ -251,24 +251,24 @@ ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial" { $subsection sql-query } "Here's an example usage where we'll make a book table, insert some objects, and query them." $nl "First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." -{ $code <" +{ $code """ USING: db.sqlite db io.files io.files.temp ; : with-book-db ( quot -- ) - "book.db" temp-file swap with-db ; inline"> } + "book.db" temp-file swap with-db ; inline" } "Now let's create the table manually:" -{ $code <" "create table books +{ $code " "create table books (id integer primary key, title text, author text, date_published timestamp, edition integer, cover_price double, condition text)" - [ sql-command ] with-book-db"> } + [ sql-command ] with-book-db""" } "Time to insert some books:" -{ $code <" +{ $code """ "insert into books (title, author, date_published, edition, cover_price, condition) values('Factor for Sheeple', 'Mister Stacky Pants', date('now'), 1, 13.37, 'mint')" -[ sql-command ] with-book-db"> } +[ sql-command ] with-book-db""" } "Now let's select the book:" -{ $code <" -"select id, title, cover_price from books;" [ sql-query ] with-book-db "> } +{ $code """ +"select id, title, cover_price from books;" [ sql-query ] with-book-db""" } "Notice that the result of this query is a Factor array containing the database rows as arrays of strings. We would have to convert the " { $snippet "cover_price" } " from a string to a number in order to use it in a calculation." $nl "In conclusion, this method of accessing a database is supported, but it is fairly low-level and generally specific to a single database. The " { $vocab-link "db.tuples" } " vocabulary is a good alternative to writing SQL by hand." ; @@ -278,13 +278,13 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators" "Make a " { $snippet "with-" } " combinator to open and close a database so that resources are not leaked." $nl "SQLite example combinator:" -{ $code <" +{ $code """ USING: db.sqlite db io.files io.files.temp ; : with-sqlite-db ( quot -- ) - "my-database.db" temp-file swap with-db ; inline"> } + "my-database.db" temp-file swap with-db ; inline""" } "PostgreSQL example combinator:" -{ $code <" USING: db.postgresql db ; +{ $code """USING: db.postgresql db ; : with-postgresql-db ( quot -- ) "localhost" >>host @@ -292,7 +292,7 @@ USING: db.sqlite db io.files io.files.temp ; "erg" >>username "secrets?" >>password "factor-test" >>database - swap with-db ; inline"> + swap with-db ; inline""" } ; ABOUT: "db" diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 5b658f36c9..ffcbec70d0 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -6,7 +6,7 @@ sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators math.intervals io nmake accessors vectors math.ranges random math.bitwise db.queries destructors db.tuples.private interpolate -io.streams.string multiline make db.private sequences.deep +io.streams.string make db.private sequences.deep db.errors.sqlite ; IN: db.sqlite @@ -201,19 +201,19 @@ M: sqlite-db-connection persistent-table ( -- assoc ) : insert-trigger ( -- string ) [ - <" + """ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : insert-trigger-not-null ( -- string ) [ - <" + """ CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE INSERT ON ${table-name} FOR EACH ROW BEGIN @@ -221,24 +221,24 @@ M: sqlite-db-connection persistent-table ( -- assoc ) WHERE NEW.${table-id} IS NOT NULL AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : update-trigger ( -- string ) [ - <" + """ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : update-trigger-not-null ( -- string ) [ - <" + """ CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE UPDATE ON ${table-name} FOR EACH ROW BEGIN @@ -246,30 +246,30 @@ M: sqlite-db-connection persistent-table ( -- assoc ) WHERE NEW.${table-id} IS NOT NULL AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : delete-trigger-restrict ( -- string ) [ - <" + """ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"') WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; END; - "> interpolate + """ interpolate ] with-string-writer ; : delete-trigger-cascade ( -- string ) [ - <" + """ CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id BEFORE DELETE ON ${foreign-table-name} FOR EACH ROW BEGIN DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id}; END; - "> interpolate + """ interpolate ] with-string-writer ; : can-be-null? ( -- ? ) diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index bd88c56431..4d435e6a89 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes help.markup help.syntax io.streams.string kernel -quotations sequences strings multiline math db.types -db.tuples.private db ; +quotations sequences strings math db.types db.tuples.private db ; IN: db.tuples HELP: random-id-generator @@ -209,7 +208,7 @@ ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" "The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl "To actually bind the tuple slots to the database types, we'll use " { $link define-persistent } "." { $code -<" USING: db.tuples db.types ; +"""USING: db.tuples db.types ; book "BOOK" { { "id" "ID" +db-assigned-id+ } @@ -219,9 +218,9 @@ book "BOOK" { "edition" "EDITION" INTEGER } { "cover-price" "COVER_PRICE" DOUBLE } { "condition" "CONDITION" VARCHAR } -} define-persistent "> } +} define-persistent""" } "That's all we'll have to do with the database for this tutorial. Now let's make a book." -{ $code <" USING: calendar namespaces ; +{ $code """USING: calendar namespaces ; T{ book { title "Factor for Sheeple" } { author "Mister Stacky Pants" } @@ -229,9 +228,9 @@ T{ book { edition 1 } { cover-price 13.37 } } book set -"> } +""" } "Now we've created a book. Let's save it to the database." -{ $code <" USING: db db.sqlite fry io.files ; +{ $code """USING: db db.sqlite fry io.files ; : with-book-tutorial ( quot -- ) '[ "book-tutorial.db" temp-file _ with-db ] call ; @@ -239,25 +238,25 @@ T{ book book recreate-table book get insert-tuple ] with-book-tutorial -"> } +""" } "Is it really there?" -{ $code <" [ +{ $code """[ T{ book { title "Factor for Sheeple" } } select-tuples . -] with-book-tutorial "> } +] with-book-tutorial""" } "Oops, we spilled some orange juice on the book cover." -{ $code <" book get "Small orange juice stain on cover" >>condition "> } +{ $code """book get "Small orange juice stain on cover" >>condition""" } "Now let's save the modified book." -{ $code <" [ +{ $code """[ book get update-tuple -] with-book-tutorial "> } +] with-book-tutorial""" } "And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "." -{ $code <" [ +{ $code """[ T{ book { title "Factor for Sheeple" } } select-tuples -] with-book-tutorial "> } +] with-book-tutorial""" } "Let's drop the table because we're done." -{ $code <" [ +{ $code """[ book drop-table -] with-book-tutorial "> } +] with-book-tutorial""" } "To summarize, the steps for using Factor's tuple database are:" { $list "Make a new tuple to represent your data" diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 1e08896e8d..4888896866 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -319,7 +319,9 @@ M: lexer-error error-help M: bad-effect summary drop "Bad stack effect declaration" ; -M: bad-escape summary drop "Bad escape code" ; +M: bad-escape error. + "Bad escape code: \\" write + char>> 1string print ; M: bad-literal-tuple summary drop "Bad literal tuple" ; diff --git a/basis/definitions/icons/icons.factor b/basis/definitions/icons/icons.factor index 3c4dad5be7..63ea2d6093 100644 --- a/basis/definitions/icons/icons.factor +++ b/basis/definitions/icons/icons.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs classes.predicate fry generic io.pathnames kernel -macros sequences vocabs words words.symbol words.constant -lexer parser help.topics help.markup namespaces sorting ; +USING: assocs classes.predicate fry generic help.topics +io.pathnames kernel lexer macros namespaces parser sequences +vocabs words words.constant words.symbol ; IN: definitions.icons GENERIC: definition-icon ( definition -- path ) @@ -41,10 +41,3 @@ ICON: topic help-article ICON: runnable-vocab runnable-vocab ICON: vocab open-vocab ICON: vocab-link unopen-vocab - -: $definition-icons ( element -- ) - drop - icons get >alist sort-keys - [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map - { "" "Definition class" } prefix - $table ; \ No newline at end of file diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index d9581152e1..17f81708c5 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -105,20 +105,20 @@ PROTOCOL: silly-protocol do-me ; ! Replacing a method definition with a consultation would cause problems [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USE: kernel - M: a-tuple do-me drop ; "> "delegate-test" parse-stream + M: a-tuple do-me drop ;" "delegate-test" parse-stream ] unit-test [ ] [ T{ a-tuple } do-me ] unit-test ! Change method definition to consultation [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USE: kernel USE: delegate - CONSULT: silly-protocol a-tuple drop f ; "> "delegate-test" parse-stream + CONSULT: silly-protocol a-tuple drop f ; " "delegate-test" parse-stream ] unit-test ! Method should be there @@ -126,7 +126,7 @@ PROTOCOL: silly-protocol do-me ; ! Now try removing the consulation [ [ ] ] [ - <" IN: delegate.tests "> "delegate-test" parse-stream + "IN: delegate.tests" "delegate-test" parse-stream ] unit-test ! Method should be gone @@ -139,18 +139,18 @@ SLOT: y [ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USING: accessors delegate ; TUPLE: slot-protocol-test-3 x ; -CONSULT: y>> slot-protocol-test-3 x>> ;"> +CONSULT: y>> slot-protocol-test-3 x>> ;" "delegate-test-1" parse-stream ] unit-test [ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test [ [ ] ] [ - <" IN: delegate.tests -TUPLE: slot-protocol-test-3 x y ;"> + "IN: delegate.tests +TUPLE: slot-protocol-test-3 x y ;" "delegate-test-1" parse-stream ] unit-test @@ -160,11 +160,11 @@ TUPLE: slot-protocol-test-3 x y ;"> ! We want to be able to override methods after consultation [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USING: delegate kernel sequences delegate.protocols accessors ; TUPLE: override-method-test seq ; CONSULT: sequence-protocol override-method-test seq>> ; - M: override-method-test like drop ; "> + M: override-method-test like drop ; " "delegate-test-2" parse-stream ] unit-test @@ -172,10 +172,10 @@ DEFER: seq-delegate ! See if removing a consultation updates protocol-consult word prop [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USING: accessors delegate delegate.protocols ; TUPLE: seq-delegate seq ; - CONSULT: sequence-protocol seq-delegate seq>> ;"> + CONSULT: sequence-protocol seq-delegate seq>> ;" "remove-consult-test" parse-stream ] unit-test @@ -186,9 +186,9 @@ DEFER: seq-delegate ] unit-test [ [ ] ] [ - <" IN: delegate.tests + "IN: delegate.tests USING: delegate delegate.protocols ; - TUPLE: seq-delegate seq ;"> + TUPLE: seq-delegate seq ;" "remove-consult-test" parse-stream ] unit-test diff --git a/basis/documents/elements/elements-tests.factor b/basis/documents/elements/elements-tests.factor index 9b323ae8e9..70476e16a9 100644 --- a/basis/documents/elements/elements-tests.factor +++ b/basis/documents/elements/elements-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test namespaces documents documents.elements multiline ; +USING: tools.test namespaces documents documents.elements ; IN: document.elements.tests SYMBOL: doc @@ -56,12 +56,12 @@ SYMBOL: doc ! page-elt doc set -<" First line +"First line Second line Third line Fourth line Fifth line -Sixth line"> doc get set-doc-string +Sixth line" doc get set-doc-string [ { 0 0 } ] [ { 3 3 } doc get 4 prev-elt ] unit-test [ { 1 2 } ] [ { 5 2 } doc get 4 prev-elt ] unit-test diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 58da96aa17..544c2ed1e4 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -105,14 +105,13 @@ M: integer W 1 + ; ! Does replacing an ordinary word with a functor-generated one work? [ [ ] ] [ - <" IN: functors.tests + "IN: functors.tests TUPLE: some-tuple ; : some-word ( -- ) ; GENERIC: some-generic ( a -- b ) M: some-tuple some-generic ; - SYMBOL: some-symbol - "> "functors-test" parse-stream + SYMBOL: some-symbol" "functors-test" parse-stream ] unit-test : test-redefinition ( -- ) @@ -145,9 +144,8 @@ SYMBOL: W-symbol ;FUNCTOR [ [ ] ] [ - <" IN: functors.tests - << "some" redefine-test >> - "> "functors-test" parse-stream + """IN: functors.tests + << "some" redefine-test >>""" "functors-test" parse-stream ] unit-test test-redefinition diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor index 6468b8deb7..f28be1015a 100644 --- a/basis/furnace/actions/actions-docs.factor +++ b/basis/furnace/actions/actions-docs.factor @@ -1,6 +1,6 @@ USING: assocs classes help.markup help.syntax io.streams.string http http.server.dispatchers http.server.responses -furnace.redirection strings multiline html.forms ; +furnace.redirection strings html.forms ; IN: furnace.actions HELP: @@ -53,12 +53,12 @@ HELP: validate-params { $examples "A simple validator from " { $vocab-link "webapps.todo" } "; this word is invoked from the " { $slot "validate" } " quotation of action for editing a todo list item:" { $code - <" : validate-todo ( -- ) + """: validate-todo ( -- ) { { "summary" [ v-one-line ] } { "priority" [ v-integer 0 v-min-value 10 v-max-value ] } { "description" [ v-required ] } - } validate-params ;"> + } validate-params ;""" } } ; diff --git a/basis/furnace/alloy/alloy-docs.factor b/basis/furnace/alloy/alloy-docs.factor index f21fc237a8..7c5a231be8 100644 --- a/basis/furnace/alloy/alloy-docs.factor +++ b/basis/furnace/alloy/alloy-docs.factor @@ -1,5 +1,5 @@ +USING: help.markup help.syntax db ; IN: furnace.alloy -USING: help.markup help.syntax db multiline ; HELP: init-furnace-tables { $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ; @@ -10,13 +10,13 @@ HELP: { $examples "The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:" { $code - <" : counter-db ( -- db ) "counter.db" ; + """: counter-db ( -- db ) "counter.db" ; : run-counter ( -- ) counter-db main-responder set-global - 8080 httpd ;"> + 8080 httpd ;""" } } ; diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index efd6a52ef0..21041c416c 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -1,7 +1,7 @@ USING: assocs classes help.markup help.syntax kernel quotations strings words words.symbol furnace.auth.providers.db checksums.sha furnace.auth.providers math byte-arrays -http multiline ; +http ; IN: furnace.auth HELP: @@ -149,24 +149,24 @@ ARTICLE: "furnace.auth.users" "User profiles" ARTICLE: "furnace.auth.example" "Furnace authentication example" "The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo list”:" { $code - <" - "view your todo list" >>description"> + """ + "view your todo list" >>description""" } "The " { $vocab-link "webapps.wiki" } " vocabulary defines a mix of protected and unprotected actions. One example of a protected action is that for deleting wiki pages, an action normally reserved for administrators. This action is protected with the following code:" { $code - <" + """ "delete wiki articles" >>description - { can-delete-wiki-articles? } >>capabilities"> + { can-delete-wiki-articles? } >>capabilities""" } "The " { $vocab-link "websites.concatenative" } " vocabulary wraps all of its responders, including the wiki, in a login authentication realm:" { $code -<" : ( responder -- responder' ) +""": ( responder -- responder' ) "Factor website" "Factor website" >>name allow-registration allow-password-recovery allow-edit-profile - allow-deactivation ;"> + allow-deactivation ;""" } ; ARTICLE: "furnace.auth" "Furnace authentication" diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index 07250058ae..d64745b834 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -3,17 +3,13 @@ IN: grouping ARTICLE: "grouping" "Groups and clumps" "Splitting a sequence into disjoint, fixed-length subsequences:" -{ $subsection group } +{ $subsections group } "A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:" -{ $subsection groups } -{ $subsection } -{ $subsection } +{ $subsections groups } "Splitting a sequence into overlapping, fixed-length subsequences:" -{ $subsection clump } +{ $subsections clump } "A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" -{ $subsection clumps } -{ $subsection } -{ $subsection } +{ $subsections clumps } "The difference can be summarized as the following:" { $list { "With groups, the subsequences form the original sequence when concatenated:" @@ -29,11 +25,11 @@ ARTICLE: "grouping" "Groups and clumps" } } } +$nl "A combinator built using clumps:" -{ $subsection monotonic? } +{ $subsections monotonic? } "Testing how elements are related:" -{ $subsection all-eq? } -{ $subsection all-equal? } ; +{ $subsections all-eq? all-equal? } ; ABOUT: "grouping" diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 6bf88f8f03..96193c1ab8 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax io kernel math parser prettyprint sequences vocabs.loader namespaces stack-checker -help command-line multiline see ; +help command-line see ; IN: help.cookbook ARTICLE: "cookbook-syntax" "Basic syntax cookbook" @@ -195,7 +195,7 @@ $nl { $heading "Example: ls" } "Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:" { $code - <" USING: command-line namespaces io io.files + """USING: command-line namespaces io io.files io.pathnames tools.files sequences kernel ; command-line get [ @@ -204,13 +204,13 @@ command-line get [ dup length 1 = [ first directory. ] [ [ [ nl write ":" print ] [ directory. ] bi ] each ] if -] if-empty"> +] if-empty""" } "You can put it in a file named " { $snippet "ls.factor" } ", and then run it, to list the " { $snippet "/usr/bin" } " directory for example:" { $code "./factor ls.factor /usr/bin" } { $heading "Example: grep" } "The following is a more complicated example, implementing something like the Unix " { $snippet "grep" } " command:" -{ $code <" USING: kernel fry io io.files io.encodings.ascii sequences +{ $code """USING: kernel fry io io.files io.encodings.ascii sequences regexp command-line namespaces ; IN: grep @@ -231,7 +231,7 @@ command-line get [ ] [ [ grep-file ] with each ] if-empty -] if-empty"> } +] if-empty""" } "You can run it like so," { $code "./factor grep.factor '.*hello.*' myfile.txt" } "You'll notice this script takes a while to start. This is because it is loading and compiling the " { $vocab-link "regexp" } " vocabulary every time. To speed up startup, load the vocabulary into your image, and save the image:" diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor index 46f9561605..5e4922c7ad 100644 --- a/basis/help/crossref/crossref.factor +++ b/basis/help/crossref/crossref.factor @@ -10,7 +10,7 @@ IN: help.crossref collect-elements [ >link ] map ; : article-children ( topic -- seq ) - { $subsection } article-links ; + { $subsection $subsections } article-links ; : help-path ( topic -- seq ) [ article-parent ] follow rest ; diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index be521eb93a..32d60851bd 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -148,9 +148,30 @@ HELP: :help HELP: $subsection { $values { "element" "a markup element of the form " { $snippet "{ topic }" } } } -{ $description "Prints a large clickable link to the help topic named by the first string element of " { $snippet "element" } "." } +{ $description "Prints a large clickable link to the help topic named by the first item in " { $snippet "element" } ". The link is printed along with its associated definition icon." } { $examples - { $code "{ $subsection \"sequences\" }" } + { $markup-example { $subsection "sequences" } } + { $markup-example { $subsection nth } } + { $markup-example { $subsection each } } +} ; + +HELP: $subsections +{ $values { "children" "a " { $link sequence } " of one or more " { $link topic } "s or, in the case of a help article, the article's string name." } } +{ $description "Prints a large clickable link for each of the listed help topics in " { $snippet "children" } ". The link is printed along with its associated definition icon." } +{ $examples + { $markup-example { $subsections "sequences" nth each } } +} ; + +{ $subsection $subsections $link } related-words + +HELP: $vocab-subsection +{ $values { "element" "a markup element of the form " { $snippet "{ title vocab }" } } } +{ $description "Prints a large clickable link for " { $snippet "vocab" } ". If " { $snippet "vocab" } " has a main help article, the link will point at that article and the " { $snippet "title" } " input will be ignored. Otherwise, the link text will be taken from " { $snippet "title" } " and point to " { $snippet "vocab" } "'s automatically generated documentation." +$nl +"The link will be printed along with its associated definition icon." } +{ $examples + { $markup-example { $vocab-subsection "SQLite" "db.sqlite" } } + { $markup-example { $vocab-subsection "Alien" "alien" } } } ; HELP: $index diff --git a/basis/help/help.factor b/basis/help/help.factor index e31c705e26..8f8ad35bf4 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -125,7 +125,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : print-topic ( topic -- ) >link last-element off - [ $title ] [ article-content print-content nl ] bi ; + [ $title ] [ nl article-content print-content nl ] bi ; SYMBOL: help-hook diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index c64f315d6d..0201e86b3f 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays definitions generic io kernel assocs -hashtables namespaces make parser prettyprint sequences strings -io.styles vectors words math sorting splitting classes slots fry -sets vocabs help.stylesheet help.topics vocabs.loader quotations -combinators see present ; +USING: accessors arrays assocs classes colors.constants +combinators definitions definitions.icons effects fry generic +hashtables help.stylesheet help.topics io io.styles kernel make +math namespaces parser present prettyprint +prettyprint.stylesheet quotations see sequences sets slots +sorting splitting strings vectors vocabs vocabs.loader words ; FROM: prettyprint.sections => with-pprint ; IN: help.markup @@ -70,7 +71,7 @@ ALIAS: $slot $snippet ] ($span) ; : $nl ( children -- ) - nl nl drop ; + nl last-block? [ nl ] unless drop ; ! Some blocks : ($heading) ( children quot -- ) @@ -156,45 +157,73 @@ ALIAS: $slot $snippet : write-link ( string object -- ) link-style get [ write-object ] with-style ; -: ($link) ( article -- ) - [ [ article-name ] [ >link ] bi write-link ] ($span) ; +: link-icon ( topic -- ) + definition-icon 1array $image ; -: $link ( element -- ) - first ($link) ; - -: ($definition-link) ( word -- ) +: link-text ( topic -- ) [ article-name ] keep write-link ; -: $definition-link ( element -- ) - first ($definition-link) ; +: link-effect ( topic -- ) + dup word? [ + stack-effect [ effect>string ] [ effect-style ] bi + [ write ] with-style + ] [ drop ] if ; -: ($long-link) ( object -- ) - [ article-title ] [ >link ] bi write-link ; +: inter-cleave ( x seq between -- ) + [ [ call( x -- ) ] with ] dip swap interleave ; inline -: $long-link ( object -- ) - first ($long-link) ; +: (($link)) ( topic words -- ) + [ dup topic? [ >link ] unless ] dip + [ [ bl ] inter-cleave ] ($span) ; inline + +: ($link) ( topic -- ) + { [ link-text ] } (($link)) ; + +: $link ( element -- ) first ($link) ; + +: ($long-link) ( topic -- ) + { [ link-text ] [ link-effect ] } (($link)) ; + +: $long-link ( element -- ) first ($long-link) ; + +: ($pretty-link) ( topic -- ) + { [ link-icon ] [ link-text ] } (($link)) ; + +: $pretty-link ( element -- ) first ($pretty-link) ; + +: ($long-pretty-link) ( topic -- ) + { [ link-icon ] [ link-text ] [ link-effect ] } (($link)) ; + +: $long-pretty-link ( element -- ) first ($long-pretty-link) ; + +: <$pretty-link> ( definition -- element ) + 1array \ $pretty-link prefix ; : ($subsection) ( element quot -- ) [ - subsection-style get [ - bullet get write bl - call - ] with-style + subsection-style get [ call ] with-style ] ($block) ; inline +: $subsection* ( topic -- ) + [ + [ ($long-pretty-link) ] with-scope + ] ($subsection) ; + +: $subsections ( children -- ) + [ $subsection* ] each nl ; + : $subsection ( element -- ) - [ first ($long-link) ] ($subsection) ; + first $subsection* ; : ($vocab-link) ( text vocab -- ) >vocab-link write-link ; : $vocab-subsection ( element -- ) [ - first2 dup vocab-help dup [ - 2nip ($long-link) - ] [ - drop ($vocab-link) - ] if + first2 dup vocab-help + [ 2nip ($long-pretty-link) ] + [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ] + if* ] ($subsection) ; : $vocab-link ( element -- ) @@ -390,3 +419,10 @@ M: array elements* : <$snippet> ( str -- element ) 1array \ $snippet prefix ; + +: $definition-icons ( element -- ) + drop + icons get >alist sort-keys + [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map + { "" "Definition class" } prefix + $table ; \ No newline at end of file diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index d8f351f57d..0aa17ef676 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -3,25 +3,17 @@ USING: accessors arrays assocs classes classes.builtin classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple classes.union combinators -definitions effects fry generic help help.markup help.stylesheet -help.topics io io.files io.pathnames io.styles kernel macros -make namespaces prettyprint sequences sets sorting summary -vocabs vocabs.files vocabs.hierarchy vocabs.loader -vocabs.metadata words words.symbol definitions.icons ; +effects fry generic help help.markup help.stylesheet +help.topics io io.pathnames io.styles kernel macros make +namespaces sequences sorting summary vocabs vocabs.files +vocabs.hierarchy vocabs.loader vocabs.metadata words +words.symbol ; FROM: vocabs.hierarchy => child-vocabs ; IN: help.vocabs : about ( vocab -- ) [ require ] [ vocab help ] bi ; -: $pretty-link ( element -- ) - [ first definition-icon 1array $image " " print-element ] - [ $definition-link ] - bi ; - -: <$pretty-link> ( definition -- element ) - 1array \ $pretty-link prefix ; - : vocab-row ( vocab -- row ) [ <$pretty-link> ] [ vocab-summary ] bi 2array ; diff --git a/basis/html/html.factor b/basis/html/html.factor index e446c66d8c..12cf3549f4 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -22,3 +22,6 @@ IN: html : simple-link ( xml url -- xml' ) url-encode swap [XML ><-> XML] ; + +: simple-image ( url -- xml ) + url-encode [XML /> XML] ; \ No newline at end of file diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor index 79e8027489..eeac9210c1 100644 --- a/basis/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -61,4 +61,12 @@ M: funky url-of "http://www.funky-town.com/" swap town>> append ; [ H{ } [ ] with-nesting nl ] make-html-string ] unit-test -[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test \ No newline at end of file +[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test + +[ "" ] [ + [ + "text" + { { image "vocab:definitions/icons/class-word.tiff" } } + format + ] make-html-string +] unit-test diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 26a3d5f391..1b3086f665 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel assocs io io.styles math math.order math.parser -sequences strings make words combinators macros xml.syntax html fry -destructors ; +USING: accessors assocs combinators destructors fry html io +io.backend io.pathnames io.styles kernel macros make math +math.order math.parser namespaces sequences strings words +splitting xml xml.syntax ; IN: html.streams GENERIC: url-of ( object -- url ) @@ -87,9 +88,21 @@ MACRO: make-css ( pairs -- str ) : emit-html ( quot stream -- ) dip data>> push ; inline +: image-path ( path -- images-path ) + "vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ; + +: img-tag ( xml style -- xml ) + image swap at [ nip image-path simple-image ] when* ; + : format-html-span ( string style stream -- ) - [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ] - emit-html ; + [ + { + [ span-tag ] + [ href-link-tag ] + [ object-link-tag ] + [ img-tag ] + } cleave + ] emit-html ; TUPLE: html-span-stream < html-sub-stream ; diff --git a/basis/html/templates/fhtml/fhtml-tests.factor b/basis/html/templates/fhtml/fhtml-tests.factor index 427b3215c1..6179e07859 100644 --- a/basis/html/templates/fhtml/fhtml-tests.factor +++ b/basis/html/templates/fhtml/fhtml-tests.factor @@ -1,5 +1,5 @@ USING: io io.files io.streams.string io.encodings.utf8 -html.templates html.templates.fhtml kernel multiline +html.templates html.templates.fhtml kernel tools.test sequences parser splitting prettyprint ; IN: html.templates.fhtml.tests @@ -20,11 +20,9 @@ IN: html.templates.fhtml.tests [ [ ] [ - <" - <% + """<% IN: html.templates.fhtml.tests : test-word ( -- ) ; - %> - "> parse-template drop + %>""" parse-template drop ] unit-test ] with-file-vocabs diff --git a/basis/http/server/cgi/cgi-docs.factor b/basis/http/server/cgi/cgi-docs.factor index e4ce71f626..edc4103f8c 100644 --- a/basis/http/server/cgi/cgi-docs.factor +++ b/basis/http/server/cgi/cgi-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax http.server.static multiline ; +USING: help.markup help.syntax http.server.static ; IN: http.server.cgi HELP: enable-cgi @@ -6,8 +6,8 @@ HELP: enable-cgi { $description "Enables the responder to serve " { $snippet ".cgi" } " scripts by executing them as per the CGI specification." } { $examples { $code - <" - "/var/www/cgi/" enable-cgi "cgi-bin" add-responder" "> + """ + "/var/www/cgi/" enable-cgi "cgi-bin" add-responder""" } } { $side-effects "responder" } ; diff --git a/basis/http/server/dispatchers/dispatchers-docs.factor b/basis/http/server/dispatchers/dispatchers-docs.factor index e0f7f20e69..75c87582f7 100644 --- a/basis/http/server/dispatchers/dispatchers-docs.factor +++ b/basis/http/server/dispatchers/dispatchers-docs.factor @@ -1,7 +1,6 @@ -! Copyright (C) 2008 Your name. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes help.markup help.syntax io.streams.string -multiline ; +USING: classes help.markup help.syntax io.streams.string ; IN: http.server.dispatchers HELP: new-dispatcher @@ -32,28 +31,28 @@ HELP: add-responder ARTICLE: "http.server.dispatchers.example" "HTTP dispatcher examples" { $heading "Simple pathname dispatcher" } { $code - <" + """ "new" add-responder "edit" add-responder "delete" add-responder "" add-responder -main-responder set-global"> +main-responder set-global""" } "In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error." { $heading "Another pathname dispatcher" } "On the other hand, suppose we wanted to route all unrecognized paths to a “view” action:" { $code - <" + """ "new" add-responder "edit" add-responder "delete" add-responder >>default -main-responder set-global"> +main-responder set-global""" } "The " { $slot "default" } " slot holds a responder to which all unrecognized paths are sent to." { $heading "Dispatcher subclassing example" } { $code - <" TUPLE: golf-courses < dispatcher ; + """TUPLE: golf-courses < dispatcher ; : ( -- golf-courses ) golf-courses new-dispatcher ; @@ -63,15 +62,15 @@ main-responder set-global"> "edit" add-responder "delete" add-responder "" add-responder -main-responder set-global"> +main-responder set-global""" } "The action templates can now emit links to responder-relative URLs prefixed by " { $snippet "$golf-courses/" } "." { $heading "Virtual hosting example" } { $code - <" + """ "concatenative-casino.com" add-responder "raptor-dating.com" add-responder -main-responder set-global"> +main-responder set-global""" } "Note that the virtual host dispatcher strips off a " { $snippet "www." } " prefix, so " { $snippet "www.concatenative-casino.com" } " would be routed to the " { $snippet "" } " responder instead of receiving a 404." ; diff --git a/basis/inspector/inspector-tests.factor b/basis/inspector/inspector-tests.factor index 3f3e7f13df..9be32a2240 100644 --- a/basis/inspector/inspector-tests.factor +++ b/basis/inspector/inspector-tests.factor @@ -8,7 +8,7 @@ f describe H{ } describe H{ } describe -[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test +[ "fixnum\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test [ ] [ H{ } clone inspect ] unit-test diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor index 14a54b89c0..79a0e4b5af 100644 --- a/basis/json/reader/reader-tests.factor +++ b/basis/json/reader/reader-tests.factor @@ -1,4 +1,4 @@ -USING: arrays json.reader kernel multiline strings tools.test +USING: arrays json.reader kernel strings tools.test hashtables json ; IN: json.reader.tests @@ -26,26 +26,26 @@ IN: json.reader.tests ! feature to get { -0.0 } [ "-0.0" json> ] unit-test -{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test -{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test +{ " fuzzy pickles " } [ """ " fuzzy pickles " """ json> ] unit-test +{ "while 1:\n\tpass" } [ """ "while 1:\n\tpass" """ json> ] unit-test ! unicode is allowed in json -{ "ß∂¬ƒ˚∆" } [ <" "ß∂¬ƒ˚∆""> json> ] unit-test -{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test -{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test +{ "ß∂¬ƒ˚∆" } [ """ "ß∂¬ƒ˚∆"""" json> ] unit-test +{ 8 9 10 12 13 34 47 92 } >string 1array [ """ "\\b\\t\\n\\f\\r\\"\\/\\\\" """ json> ] unit-test +{ HEX: abcd } >string 1array [ """ "\\uaBCd" """ json> ] unit-test { H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test { { } } [ "[]" json> ] unit-test -{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test +{ { 1 "two" 3.0 } } [ """ [1, "two", 3.0] """ json> ] unit-test { H{ } } [ "{}" json> ] unit-test ! the returned hashtable should be different every time { H{ } } [ "key" "value" "{}" json> ?set-at "{}" json> nip ] unit-test -{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test +{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ """ { "US$":1.00, "EU\\u20AC":1.50 } """ json> ] unit-test { H{ { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } } { "prime" { 2 3 5 7 11 13 } } -} } [ <" { +} } [ """ { "fib": [1, 1, 2, 3, 5, 8, { "etc":"etc" } ], "prime": @@ -53,7 +53,7 @@ IN: json.reader.tests 11, 13 ] } -"> json> ] unit-test +""" json> ] unit-test { 0 } [ " 0" json> ] unit-test { 0 } [ "0 " json> ] unit-test diff --git a/basis/json/writer/writer-tests.factor b/basis/json/writer/writer-tests.factor index 6b6118c443..692a264d0a 100644 --- a/basis/json/writer/writer-tests.factor +++ b/basis/json/writer/writer-tests.factor @@ -1,4 +1,4 @@ -USING: json.writer tools.test multiline json.reader json ; +USING: json.writer tools.test json.reader json ; IN: json.writer.tests { "false" } [ f >json ] unit-test @@ -11,10 +11,10 @@ IN: json.writer.tests { "102.5" } [ 102.5 >json ] unit-test { "[1,\"two\",3.0]" } [ { 1 "two" 3.0 } >json ] unit-test -{ <" {"US$":1.0,"EU€":1.5}"> } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test +{ """{"US$":1.0,"EU€":1.5}""" } [ H{ { "US$" 1.0 } { "EU€" 1.5 } } >json ] unit-test ! Random symbols are written simply as strings SYMBOL: testSymbol -{ <" "testSymbol""> } [ testSymbol >json ] unit-test +{ """"testSymbol"""" } [ testSymbol >json ] unit-test -[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test \ No newline at end of file +[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 1caa4b746f..3b47d9351f 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -9,21 +9,21 @@ HELP: $ { $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples - { $example <" + { $example """ USING: kernel literals prettyprint ; IN: scratchpad CONSTANT: five 5 { $ five } . - "> "{ 5 }" } + """ "{ 5 }" } - { $example <" + { $example """ USING: kernel literals prettyprint ; IN: scratchpad : seven-eleven ( -- a b ) 7 11 ; { $ seven-eleven } . - "> "{ 7 11 }" } + """ "{ 7 11 }" } } ; @@ -33,13 +33,13 @@ HELP: $[ { $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." } { $examples - { $example <" + { $example """ USING: kernel literals math prettyprint ; IN: scratchpad << CONSTANT: five 5 >> { $[ five dup 1 + dup 2 + ] } . - "> "{ 5 6 8 }" } + """ "{ 5 6 8 }" } } ; @@ -49,14 +49,14 @@ HELP: ${ { $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } { $examples - { $example <" + { $example """ USING: kernel literals math prettyprint ; IN: scratchpad CONSTANT: five 5 CONSTANT: six 6 ${ five six 7 } . - "> "{ 5 6 7 }" + """ "{ 5 6 7 }" } } ; @@ -64,13 +64,13 @@ ${ five six 7 } . ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." -{ $example <" +{ $example """ USE: literals IN: scratchpad CONSTANT: five 5 { $ five $[ five dup 1 + dup 2 + ] } . - "> "{ 5 5 6 8 }" } + """ "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } { $subsection POSTPONE: $[ } { $subsection POSTPONE: ${ } diff --git a/basis/math/blas/config/config-docs.factor b/basis/math/blas/config/config-docs.factor index 60eaff25c2..eadfc3fed0 100644 --- a/basis/math/blas/config/config-docs.factor +++ b/basis/math/blas/config/config-docs.factor @@ -1,4 +1,4 @@ -USING: alien.fortran help.markup help.syntax math.blas.config multiline ; +USING: alien.fortran help.markup help.syntax math.blas.config ; IN: math.blas.config ARTICLE: "math.blas.config" "Configuring the BLAS interface" @@ -6,11 +6,11 @@ ARTICLE: "math.blas.config" "Configuring the BLAS interface" { $subsection blas-library } { $subsection blas-fortran-abi } "The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:" -{ $code <" +{ $code """ USING: math.blas.config namespaces ; "X:\\path\\to\\acml.dll" blas-library set-global intel-windows-abi blas-fortran-abi set-global -"> } +""" } "To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded." ; diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index 5662cd9905..a42fea3bf6 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -1,4 +1,4 @@ -USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ; +USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ; IN: math.blas.matrices ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" @@ -249,39 +249,39 @@ HELP: { $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ; HELP: smatrix{ -{ $syntax <" smatrix{ +{ $syntax """smatrix{ { 1.0 0.0 0.0 1.0 } { 0.0 1.0 0.0 2.0 } { 0.0 0.0 1.0 3.0 } { 0.0 0.0 0.0 1.0 } -} "> } +}""" } { $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: dmatrix{ -{ $syntax <" dmatrix{ +{ $syntax """dmatrix{ { 1.0 0.0 0.0 1.0 } { 0.0 1.0 0.0 2.0 } { 0.0 0.0 1.0 3.0 } { 0.0 0.0 0.0 1.0 } -} "> } +}""" } { $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: cmatrix{ -{ $syntax <" cmatrix{ +{ $syntax """cmatrix{ { 1.0 0.0 0.0 1.0 } { 0.0 C{ 0.0 1.0 } 0.0 2.0 } { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } -} "> } +}""" } { $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; HELP: zmatrix{ -{ $syntax <" zmatrix{ +{ $syntax """zmatrix{ { 1.0 0.0 0.0 1.0 } { 0.0 C{ 0.0 1.0 } 0.0 2.0 } { 0.0 0.0 -1.0 3.0 } { 0.0 0.0 0.0 C{ 0.0 -1.0 } } -} "> } +}""" } { $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; { diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 0e0b7ae167..10584f2004 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel math math.order multiline sequences ; +USING: help.markup help.syntax kernel math math.order sequences ; IN: math.combinatorics HELP: factorial @@ -76,14 +76,14 @@ HELP: all-combinations { $examples { $example "USING: math.combinatorics prettyprint ;" "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ." -<" { +"""{ { "a" "b" } { "a" "c" } { "a" "d" } { "b" "c" } { "b" "d" } { "c" "d" } -}"> } } ; +}""" } } ; HELP: each-combination { $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } } diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index e91fc4eda9..e9120567aa 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -31,9 +31,7 @@ M: x87-env (set-fp-env-register) set_x87_env ; M: x86 (fp-env-registers) - sse-version 20 >= - [ 2array ] - [ 1array ] if ; + sse2? [ 2array ] [ 1array ] if ; CONSTANT: sse-exception-flag-bits HEX: 3f CONSTANT: sse-exception-flag>bit diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index fb392191d4..11f209fb9c 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -3,103 +3,91 @@ sequences quotations math.functions.private ; IN: math.functions ARTICLE: "integer-functions" "Integer functions" -{ $subsection align } -{ $subsection gcd } -{ $subsection log2 } -{ $subsection next-power-of-2 } +{ $subsections + align + gcd + log2 + next-power-of-2 +} "Modular exponentiation:" -{ $subsection ^mod } -{ $subsection mod-inv } +{ $subsections ^mod mod-inv } "Tests:" -{ $subsection power-of-2? } -{ $subsection even? } -{ $subsection odd? } -{ $subsection divisor? } ; +{ $subsections + power-of-2? + even? + odd? + divisor? +} ; ARTICLE: "arithmetic-functions" "Arithmetic functions" "Computing additive and multiplicative inverses:" -{ $subsection neg } -{ $subsection recip } +{ $subsections neg recip } "Complex conjugation:" -{ $subsection conjugate } +{ $subsections conjugate } "Tests:" -{ $subsection zero? } -{ $subsection between? } +{ $subsections zero? between? } "Control flow:" -{ $subsection if-zero } -{ $subsection when-zero } -{ $subsection unless-zero } +{ $subsections + if-zero + when-zero + unless-zero +} "Sign:" -{ $subsection sgn } +{ $subsections sgn } "Rounding:" -{ $subsection ceiling } -{ $subsection floor } -{ $subsection truncate } -{ $subsection round } +{ $subsections + ceiling + floor + truncate + round +} "Inexact comparison:" -{ $subsection ~ } +{ $subsections ~ } "Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ; ARTICLE: "power-functions" "Powers and logarithms" "Squares:" -{ $subsection sq } -{ $subsection sqrt } +{ $subsections sq sqrt } "Exponential and natural logarithm:" -{ $subsection exp } -{ $subsection cis } -{ $subsection log } +{ $subsections exp cis log } "Other logarithms:" -{ $subsection log1+ } -{ $subsection log10 } +{ $subsection log1+ log10 } "Raising a number to a power:" -{ $subsection ^ } -{ $subsection 10^ } +{ $subsections ^ 10^ } "Converting between rectangular and polar form:" -{ $subsection abs } -{ $subsection absq } -{ $subsection arg } -{ $subsection >polar } -{ $subsection polar> } ; +{ $subsections + abs + absq + arg + >polar + polar> +} ; ARTICLE: "trig-hyp-functions" "Trigonometric and hyperbolic functions" "Trigonometric functions:" -{ $subsection cos } -{ $subsection sin } -{ $subsection tan } +{ $subsections cos sin tan } "Reciprocals:" -{ $subsection sec } -{ $subsection cosec } -{ $subsection cot } +{ $subsections sec cosec cot } "Inverses:" -{ $subsection acos } -{ $subsection asin } -{ $subsection atan } +{ $subsections acos asin atan } "Inverse reciprocals:" -{ $subsection asec } -{ $subsection acosec } -{ $subsection acot } +{ $subsections asec acosec acot } "Hyperbolic functions:" -{ $subsection cosh } -{ $subsection sinh } -{ $subsection tanh } +{ $subsections cosh sinh tanh } "Reciprocals:" -{ $subsection sech } -{ $subsection cosech } -{ $subsection coth } +{ $subsections sech cosech coth } "Inverses:" -{ $subsection acosh } -{ $subsection asinh } -{ $subsection atanh } +{ $subsections acosh asinh atanh } "Inverse reciprocals:" -{ $subsection asech } -{ $subsection acosech } -{ $subsection acoth } ; +{ $subsections asech acosech acoth } ; ARTICLE: "math-functions" "Mathematical functions" -{ $subsection "integer-functions" } -{ $subsection "arithmetic-functions" } -{ $subsection "power-functions" } -{ $subsection "trig-hyp-functions" } ; +{ $subsections + "integer-functions" + "arithmetic-functions" + "power-functions" + "trig-hyp-functions" +} ; ABOUT: "math-functions" diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index fa880f77af..4502e993a3 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -6,6 +6,10 @@ IN: math.functions.tests [ t ] [ 4.0000001 4.0000001 .000001 ~ ] unit-test [ f ] [ -4.0000001 4.0000001 .00001 ~ ] unit-test [ t ] [ -.0000000000001 0 .0000000001 ~ ] unit-test +[ t ] [ 100 101 -.9 ~ ] unit-test +[ f ] [ 100 120 -.09 ~ ] unit-test +[ t ] [ 0 0 -.9 ~ ] unit-test +[ f ] [ 0 10 -.9 ~ ] unit-test ! Lets get the argument order correct, eh? [ 0.0 ] [ 0.0 1.0 fatan2 ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index f124c202b8..a31b6ee7cc 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -137,13 +137,13 @@ M: real absq sq ; inline [ - abs ] dip < ; : ~rel ( x y epsilon -- ? ) - [ [ - abs ] 2keep [ abs ] bi@ + ] dip * < ; + [ [ - abs ] 2keep [ abs ] bi@ + ] dip * <= ; : ~ ( x y epsilon -- ? ) { { [ 2over [ fp-nan? ] either? ] [ 3drop f ] } { [ dup zero? ] [ drop number= ] } - { [ dup 0 < ] [ ~rel ] } + { [ dup 0 < ] [ neg ~rel ] } [ ~abs ] } cond ; diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 7c66c911de..e72d77ee1f 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -147,7 +147,7 @@ SYMBOL: fast-math-ops : math-both-known? ( word left right -- ? ) 3dup math-op [ 2drop 2drop t ] - [ drop math-class-max swap specific-method >boolean ] if ; + [ drop math-class-max swap method-for-class >boolean ] if ; : (derived-ops) ( word assoc -- words ) swap '[ swap first _ eq? nip ] assoc-filter ; diff --git a/basis/math/vectors/simd/alien/alien-tests.factor b/basis/math/vectors/simd/alien/alien-tests.factor deleted file mode 100644 index 87540dd9a5..0000000000 --- a/basis/math/vectors/simd/alien/alien-tests.factor +++ /dev/null @@ -1,70 +0,0 @@ -USING: cpu.architecture math.vectors.simd -math.vectors.simd.intrinsics accessors math.vectors.simd.alien -kernel classes.struct tools.test compiler sequences byte-arrays -alien math kernel.private specialized-arrays combinators ; -SPECIALIZED-ARRAY: float -IN: math.vectors.simd.alien.tests - -! Vector alien intrinsics -[ float-4{ 1 2 3 4 } ] [ - [ - float-4{ 1 2 3 4 } - underlying>> 0 float-4-rep alien-vector - ] compile-call float-4 boa -] unit-test - -[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [ - 16 [ 1 ] B{ } replicate-as 16 - [ - 0 [ - { byte-array c-ptr fixnum } declare - float-4-rep set-alien-vector - ] compile-call - ] keep -] unit-test - -[ float-array{ 1 2 3 4 } ] [ - [ - float-array{ 1 2 3 4 } underlying>> - float-array{ 4 3 2 1 } clone - [ underlying>> 0 float-4-rep set-alien-vector ] keep - ] compile-call -] unit-test - -STRUCT: simd-struct -{ x float-4 } -{ y double-2 } -{ z double-4 } -{ w float-8 } ; - -[ t ] [ [ simd-struct ] compile-call >c-ptr [ 0 = ] all? ] unit-test - -[ - float-4{ 1 2 3 4 } - double-2{ 2 1 } - double-4{ 4 3 2 1 } - float-8{ 1 2 3 4 5 6 7 8 } -] [ - simd-struct - float-4{ 1 2 3 4 } >>x - double-2{ 2 1 } >>y - double-4{ 4 3 2 1 } >>z - float-8{ 1 2 3 4 5 6 7 8 } >>w - { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave -] unit-test - -[ - float-4{ 1 2 3 4 } - double-2{ 2 1 } - double-4{ 4 3 2 1 } - float-8{ 1 2 3 4 5 6 7 8 } -] [ - [ - simd-struct - float-4{ 1 2 3 4 } >>x - double-2{ 2 1 } >>y - double-4{ 4 3 2 1 } >>z - float-8{ 1 2 3 4 5 6 7 8 } >>w - { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave - ] compile-call -] unit-test diff --git a/basis/math/vectors/simd/alien/alien.factor b/basis/math/vectors/simd/alien/alien.factor deleted file mode 100644 index 1486f6d0af..0000000000 --- a/basis/math/vectors/simd/alien/alien.factor +++ /dev/null @@ -1,42 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien accessors alien.c-types byte-arrays compiler.units -cpu.architecture locals kernel math math.vectors.simd -math.vectors.simd.intrinsics ; -IN: math.vectors.simd.alien - -:: define-simd-128-type ( class rep -- ) - - byte-array >>class - class >>boxed-class - [ rep alien-vector class boa ] >>getter - [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter - 16 >>size - 8 >>align - rep >>rep - class name>> typedef ; - -:: define-simd-256-type ( class rep -- ) - - class >>class - class >>boxed-class - [ - [ rep alien-vector ] - [ 16 + >fixnum rep alien-vector ] 2bi - class boa - ] >>getter - [ - [ [ underlying1>> ] 2dip rep set-alien-vector ] - [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ] - 3bi - ] >>setter - 32 >>size - 8 >>align - rep >>rep - class name>> typedef ; -[ - float-4 float-4-rep define-simd-128-type - double-2 double-2-rep define-simd-128-type - float-8 float-4-rep define-simd-256-type - double-4 double-2-rep define-simd-256-type -] with-compilation-unit diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor index 641585a5d7..e934a641c4 100644 --- a/basis/math/vectors/simd/functor/functor.factor +++ b/basis/math/vectors/simd/functor/functor.factor @@ -1,27 +1,124 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types byte-arrays classes functors -kernel math parser prettyprint.custom sequences -sequences.private literals ; +USING: accessors alien.c-types assocs byte-arrays classes +effects fry functors generalizations kernel literals locals +math math.functions math.vectors math.vectors.simd.intrinsics +math.vectors.specialization parser prettyprint.custom sequences +sequences.private strings words definitions macros cpu.architecture +namespaces arrays quotations ; +QUALIFIED-WITH: math m IN: math.vectors.simd.functor ERROR: bad-length got expected ; +MACRO: simd-boa ( rep class -- simd-array ) + [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ; + +:: define-boa-custom-inlining ( word rep class -- ) + word [ + drop + rep rep rep-gather-word supported-simd-op? [ + [ rep (simd-boa) class boa ] + ] [ word def>> ] if + ] "custom-inlining" set-word-prop ; + +: simd-with ( rep class x -- simd-array ) + [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline + +:: define-with-custom-inlining ( word rep class -- ) + word [ + drop + rep \ (simd-broadcast) supported-simd-op? [ + [ rep rep-coerce rep (simd-broadcast) class boa ] + ] [ word def>> ] if + ] "custom-inlining" set-word-prop ; + +: boa-effect ( rep n -- effect ) + [ rep-components ] dip * + [ CHAR: a + 1string ] map + { "simd-vector" } ; + +: supported-simd-ops ( assoc rep -- assoc' ) + [ simd-ops get ] dip + '[ nip _ swap supported-simd-op? ] assoc-filter + '[ drop _ key? ] assoc-filter ; + +ERROR: bad-schema schema ; + +: low-level-ops ( box-quot: ( inputs... simd-op -- outputs... ) -- alist ) + [ simd-ops get ] dip '[ + 1quotation + over word-schema _ ?at [ bad-schema ] unless + [ ] 2sequence + ] assoc-map ; + +:: high-level-ops ( ctor elt-class -- assoc ) + ! Some SIMD operations are defined in terms of others. + { + { vneg [ [ dup v- ] keep v- ] } + { n+v [ [ ctor execute ] dip v+ ] } + { v+n [ ctor execute v+ ] } + { n-v [ [ ctor execute ] dip v- ] } + { v-n [ ctor execute v- ] } + { n*v [ [ ctor execute ] dip v* ] } + { v*n [ ctor execute v* ] } + { n/v [ [ ctor execute ] dip v/ ] } + { v/n [ ctor execute v/ ] } + { norm-sq [ dup v. assert-positive ] } + { norm [ norm-sq sqrt ] } + { normalize [ dup norm v/n ] } + } + ! To compute dot product and distance with integer vectors, we + ! have to do things less efficiently, with integer overflow checks, + ! in the general case. + elt-class m:float = [ + { + { distance [ v- norm ] } + { v. [ v* sum ] } + } append + ] when ; + +:: simd-vector-words ( class ctor rep vv->v v->v v->n -- ) + rep rep-component-type c-type-boxed-class :> elt-class + class + elt-class + { + { { +vector+ +vector+ -> +vector+ } vv->v } + { { +vector+ -> +vector+ } v->v } + { { +vector+ -> +scalar+ } v->n } + { { +vector+ -> +nonnegative+ } v->n } + } low-level-ops + rep supported-simd-ops + ctor elt-class high-level-ops assoc-union + specialize-vector-words ; + +:: define-simd-128-type ( class rep -- ) + + byte-array >>class + class >>boxed-class + [ rep alien-vector class boa ] >>getter + [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter + 16 >>size + 8 >>align + rep >>rep + class typedef ; + FUNCTOR: define-simd-128 ( T -- ) -T-TYPE IS ${T} - -N [ 16 T-TYPE heap-size /i ] +N [ 16 T heap-size /i ] A DEFINES-CLASS ${T}-${N} +A-boa DEFINES ${A}-boa +A-with DEFINES ${A}-with >A DEFINES >${A} A{ DEFINES ${A}{ -NTH [ T-TYPE dup c-type-getter-boxer array-accessor ] -SET-NTH [ T-TYPE dup c-setter array-accessor ] +NTH [ T dup c-type-getter-boxer array-accessor ] +SET-NTH [ T dup c-setter array-accessor ] -A-rep IS ${A}-rep +A-rep [ A name>> "-rep" append "cpu.architecture" lookup ] A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op +A-v->v-op DEFINES-PRIVATE ${A}-v->v-op A-v->n-op DEFINES-PRIVATE ${A}-v->n-op WHERE @@ -51,6 +148,8 @@ M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ; M: A byte-length underlying>> length ; inline +M: A element-type drop A-rep rep-component-type ; + M: A pprint-delims drop \ A{ \ } ; M: A >pprint-sequence ; @@ -59,6 +158,16 @@ M: A pprint* pprint-object ; SYNTAX: A{ \ } [ >A ] parse-literal ; +: A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ; + +\ A-with \ A-rep \ A define-with-custom-inlining + +\ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared + +\ A-rep rep-gather-word [ + \ A-boa \ A-rep \ A define-boa-custom-inlining +] when + INSTANCE: A sequence v-op ( v1 v2 quot -- v3 ) [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline +: A-v->v-op ( v1 quot -- v2 ) + [ underlying>> A-rep ] dip call \ A boa ; inline + : A-v->n-op ( v quot -- n ) [ underlying>> A-rep ] dip call ; inline +\ A \ A-with \ A-rep \ A-vv->v-op \ A-v->v-op \ A-v->n-op simd-vector-words +\ A \ A-rep define-simd-128-type + PRIVATE> ;FUNCTOR ! Synthesize 256-bit vectors from a pair of 128-bit vectors +SLOT: underlying1 +SLOT: underlying2 + +:: define-simd-256-type ( class rep -- ) + + class >>class + class >>boxed-class + [ + [ rep alien-vector ] + [ 16 + >fixnum rep alien-vector ] 2bi + class boa + ] >>getter + [ + [ [ underlying1>> ] 2dip rep set-alien-vector ] + [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ] + 3bi + ] >>setter + 32 >>size + 8 >>align + rep >>rep + class typedef ; + FUNCTOR: define-simd-256 ( T -- ) -T-TYPE IS ${T} - -N [ 32 T-TYPE heap-size /i ] +N [ 32 T heap-size /i ] N/2 [ N 2 / ] A/2 IS ${T}-${N/2} +A/2-boa IS ${A/2}-boa +A/2-with IS ${A/2}-with A DEFINES-CLASS ${T}-${N} +A-boa DEFINES ${A}-boa +A-with DEFINES ${A}-with >A DEFINES >${A} A{ DEFINES ${A}{ A-deref DEFINES-PRIVATE ${A}-deref -A-rep IS ${A/2}-rep +A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ] A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op +A-v->v-op DEFINES-PRIVATE ${A}-v->v-op A-v->n-op DEFINES-PRIVATE ${A}-v->n-op WHERE @@ -129,6 +269,8 @@ M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ; M: A byte-length drop 32 ; inline +M: A element-type drop A-rep rep-component-type ; + SYNTAX: A{ \ } [ >A ] parse-literal ; M: A pprint-delims drop \ A{ \ } ; @@ -137,6 +279,16 @@ M: A >pprint-sequence ; M: A pprint* pprint-object ; +: A-with ( x -- simd-array ) + [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@ + \ A boa ; inline + +: A-boa ( ... -- simd-array ) + [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@ + \ A boa ; inline + +\ A-rep 2 boa-effect \ A-boa set-stack-effect + INSTANCE: A sequence : A-vv->v-op ( v1 v2 quot -- v3 ) @@ -144,8 +296,15 @@ INSTANCE: A sequence [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi \ A boa ; inline -: A-v->n-op ( v1 combine-quot reduce-quot -- v2 ) - [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ] - dip call ; inline +: A-v->v-op ( v1 combine-quot -- v2 ) + [ [ underlying1>> A-rep ] dip call ] + [ [ underlying2>> A-rep ] dip call ] 2bi + \ A boa ; inline + +: A-v->n-op ( v1 combine-quot -- v2 ) + [ [ underlying1>> ] [ underlying2>> ] bi A-rep (simd-v+) A-rep ] dip call ; inline + +\ A \ A-with \ A-rep \ A-vv->v-op \ A-v->v-op \ A-v->n-op simd-vector-words +\ A \ A-rep define-simd-256-type ;FUNCTOR diff --git a/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor b/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor new file mode 100644 index 0000000000..84eee935a0 --- /dev/null +++ b/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor @@ -0,0 +1,18 @@ +IN: math.vectors.simd.intrinsics.tests +USING: math.vectors.simd.intrinsics cpu.architecture tools.test ; + +[ 16 ] [ uchar-16-rep rep-components ] unit-test +[ 16 ] [ char-16-rep rep-components ] unit-test +[ 8 ] [ ushort-8-rep rep-components ] unit-test +[ 8 ] [ short-8-rep rep-components ] unit-test +[ 4 ] [ uint-4-rep rep-components ] unit-test +[ 4 ] [ int-4-rep rep-components ] unit-test +[ 4 ] [ float-4-rep rep-components ] unit-test +[ 2 ] [ double-2-rep rep-components ] unit-test + +{ 4 1 } [ uint-4-rep (simd-boa) ] must-infer-as +{ 4 1 } [ int-4-rep (simd-boa) ] must-infer-as +{ 4 1 } [ float-4-rep (simd-boa) ] must-infer-as +{ 2 1 } [ double-2-rep (simd-boa) ] must-infer-as + + diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 914d1ef169..2c1f76cfe1 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -1,18 +1,48 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel alien alien.data cpu.architecture libc ; +USING: alien alien.c-types alien.data assocs combinators +cpu.architecture fry generalizations kernel libc macros math +sequences effects accessors namespaces lexer parser vocabs.parser +words arrays math.vectors ; IN: math.vectors.simd.intrinsics ERROR: bad-simd-call ; -: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ; -: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ; +<< + +: simd-effect ( word -- effect ) + stack-effect [ in>> "rep" suffix ] [ out>> ] bi ; + +SYMBOL: simd-ops + +V{ } clone simd-ops set-global + +SYNTAX: SIMD-OP: + scan-word dup name>> "(simd-" ")" surround create-in + [ nip [ bad-simd-call ] define ] + [ [ simd-effect ] dip set-stack-effect ] + [ 2array simd-ops get push ] + 2tri ; + +>> + +SIMD-OP: v+ +SIMD-OP: v- +SIMD-OP: v+- +SIMD-OP: vs+ +SIMD-OP: vs- +SIMD-OP: vs* +SIMD-OP: v* +SIMD-OP: v/ +SIMD-OP: vmin +SIMD-OP: vmax +SIMD-OP: vsqrt +SIMD-OP: sum +SIMD-OP: vabs +SIMD-OP: vbitand +SIMD-OP: vbitor +SIMD-OP: vbitxor + : (simd-broadcast) ( x rep -- v ) bad-simd-call ; : (simd-gather-2) ( a b rep -- v ) bad-simd-call ; : (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ; @@ -26,3 +56,61 @@ ERROR: bad-simd-call ; ! Inefficient version for when intrinsics are missing [ swap swap ] dip rep-size memcpy ; +<< + +: rep-components ( rep -- n ) + 16 swap rep-component-type heap-size /i ; foldable + +: rep-coercer ( rep -- quot ) + { + { [ dup int-vector-rep? ] [ [ >fixnum ] ] } + { [ dup float-vector-rep? ] [ [ >float ] ] } + } cond nip ; foldable + +: rep-coerce ( value rep -- value' ) + rep-coercer call( value -- value' ) ; inline + +CONSTANT: rep-gather-words + { + { 2 (simd-gather-2) } + { 4 (simd-gather-4) } + } + +: rep-gather-word ( rep -- word ) + rep-components rep-gather-words at ; + +>> + +MACRO: (simd-boa) ( rep -- quot ) + { + [ rep-coercer ] + [ rep-components ] + [ ] + [ rep-gather-word ] + } cleave + '[ _ _ napply _ _ execute ] ; + +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-vsqrt) [ %sqrt-vector-reps ] } + { \ (simd-sum) [ %horizontal-add-vector-reps ] } + { \ (simd-vabs) [ %abs-vector-reps ] } + { \ (simd-vbitand) [ %and-vector-reps ] } + { \ (simd-vbitor) [ %or-vector-reps ] } + { \ (simd-vbitxor) [ %xor-vector-reps ] } + { \ (simd-broadcast) [ %broadcast-vector-reps ] } + { \ (simd-gather-2) [ %gather-vector-2-reps ] } + { \ (simd-gather-4) [ %gather-vector-4-reps ] } + } case member? ; diff --git a/basis/math/vectors/simd/simd-docs.factor b/basis/math/vectors/simd/simd-docs.factor index b110de1de8..2fdb9ff88c 100644 --- a/basis/math/vectors/simd/simd-docs.factor +++ b/basis/math/vectors/simd/simd-docs.factor @@ -1,6 +1,6 @@ -USING: help.markup help.syntax sequences math math.vectors -multiline kernel.private classes.tuple.private -math.vectors.simd.intrinsics cpu.architecture ; +USING: classes.tuple.private cpu.architecture help.markup +help.syntax kernel.private math math.vectors +math.vectors.simd.intrinsics sequences ; IN: math.vectors.simd ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support" @@ -17,23 +17,53 @@ $nl "There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ; ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations" -"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs." +"At present, the SIMD support makes use of a subset of SSE up to SSE4.1. The subset used depends on the current CPU type." $nl -"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance." +"SSE1 only supports single-precision SIMD (" { $snippet "float-4" } " and " { $snippet "float-8" } ")." $nl -"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance." +"SSE2 introduces double-precision SIMD (" { $snippet "double-2" } " and " { $snippet "double-4" } ") and integer SIMD (all types). Integer SIMD in missing a few features, in particular the " { $link vmin } " and " { $link vmax } " operations only work on " { $snippet "uchar-16" } " and " { $snippet "short-8" } "." +$nl +"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } "." +$nl +"SSSE3 introduces " { $link vabs } " for " { $snippet "char-16" } ", " { $snippet "short-8" } " and " { $snippet "int-4" } "." +$nl +"SSE4.1 introduces " { $link vmin } " and " { $link vmax } " for all remaining integer types." +$nl +"On PowerPC, or older x86 chips without SSE, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance." $nl "The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ; ARTICLE: "math.vectors.simd.types" "SIMD vector types" -"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8." +"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension." $nl -"The following vector types are defined:" -{ $subsection float-4 } -{ $subsection double-2 } -{ $subsection float-8 } -{ $subsection double-4 } -"For each vector type, several words are defined:" +"To use a SIMD vector type, a parsing word is used to generate the relevant code and bring it into the vocabulary search path; this is the same idea as with " { $link "specialized-arrays" } ":" +{ $subsection POSTPONE: SIMD: } +"The following vector types are supported:" +{ $code + "char-16" + "uchar-16" + "char-32" + "uchar-32" + "short-8" + "ushort-8" + "short-16" + "ushort-16" + "int-4" + "uint-4" + "int-8" + "uint-8" + "longlong-2" + "ulonglong-2" + "longlong-4" + "ulonglong-4" + "float-4" + "float-8" + "double-2" + "double-4" +} ; + +ARTICLE: "math.vectors.simd.words" "SIMD vector words" +"For each SIMD vector type, several words are defined:" { $table { "Word" "Stack effect" "Description" } { { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" } @@ -41,24 +71,6 @@ $nl { { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" } { { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" } } -"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers." -$nl -"Operations on " { $link float-4 } " instances:" -{ $subsection float-4-with } -{ $subsection float-4-boa } -{ $subsection POSTPONE: float-4{ } -"Operations on " { $link double-2 } " instances:" -{ $subsection double-2-with } -{ $subsection double-2-boa } -{ $subsection POSTPONE: double-2{ } -"Operations on " { $link float-8 } " instances:" -{ $subsection float-8-with } -{ $subsection float-8-boa } -{ $subsection POSTPONE: float-8{ } -"Operations on " { $link double-4 } " instances:" -{ $subsection double-4-with } -{ $subsection double-4-boa } -{ $subsection POSTPONE: double-4{ } "To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words." { $see-also "c-types-specs" } ; @@ -71,7 +83,7 @@ $nl $nl "For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:" { $code -<" USING: compiler.tree.debugger math.vectors +"""USING: compiler.tree.debugger math.vectors math.vectors.simd ; SYMBOLS: x y ; @@ -79,37 +91,42 @@ SYMBOLS: x y ; double-4{ 1.5 2.0 3.7 0.4 } x set double-4{ 1.5 2.0 3.7 0.4 } y set x get y get v+ -] optimizer-report."> } +] optimizer-report.""" } "The following word benefits from SIMD optimization, because it begins with an unsafe declaration:" { $code -<" USING: compiler.tree.debugger kernel.private +"""USING: compiler.tree.debugger kernel.private math.vectors math.vectors.simd ; +SIMD: float +IN: simd-demo : interpolate ( v a b -- w ) { float-4 float-4 float-4 } declare [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ; -\ interpolate optimizer-report. "> } +\ interpolate optimizer-report.""" } "Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations." $nl "Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:" { $code -<" USING: compiler.tree.debugger hints +"""USING: compiler.tree.debugger hints math.vectors math.vectors.simd ; +SIMD: float +IN: simd-demo : interpolate ( v a b -- w ) [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ; HINTS: interpolate float-4 float-4 float-4 ; -\ interpolate optimizer-report. "> } +\ interpolate optimizer-report. """ } "This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives." $nl "If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "." $nl "In the " { $snippet "interpolate" } " word, there is still a call to the " { $link } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:" { $code -<" USING: compiler.tree.debugger math.vectors math.vectors.simd ; +"""USING: compiler.tree.debugger math.vectors math.vectors.simd ; +SIMD: float IN: simd-demo STRUCT: actor @@ -132,13 +149,13 @@ M: actor advance ( dt actor -- ) [ >float ] dip [ update-velocity ] [ update-position ] 2bi ; -M\ actor advance optimized."> +M\ actor advance optimized.""" } "The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:" { $code -<" USE: compiler.tree.debugger +"""USE: compiler.tree.debugger -M\ actor advance test-mr mr."> } +M\ actor advance test-mr mr.""" } "An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ; ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives" @@ -150,106 +167,37 @@ ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives" } "The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD." $nl -"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "." -{ $subsection (simd-v+) } -{ $subsection (simd-v-) } -{ $subsection (simd-v/) } -{ $subsection (simd-vmin) } -{ $subsection (simd-vmax) } -{ $subsection (simd-vsqrt) } -{ $subsection (simd-sum) } -{ $subsection (simd-broadcast) } -{ $subsection (simd-gather-2) } -{ $subsection (simd-gather-4) } +"It is best to avoid calling SIMD primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "." +$nl "There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":" { $subsection alien-vector } { $subsection set-alien-vector } "For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ; ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes" -"Struct classes may contain fields which store SIMD data; use one of the following C type names:" -{ $code -<" float-4 -double-2 -float-8 -double-4"> } -"Passing SIMD data as function parameters is not yet supported." ; +"Struct classes may contain fields which store SIMD data; for each SIMD vector type listed in " { $snippet "math.vectors.simd.types" } " there is a C type with the same name." +$nl +"Only SIMD struct fields are allowed at the moment; passing SIMD data as function parameters is not yet supported." ; + +ARTICLE: "math.vectors.simd.accuracy" "Numerical accuracy of SIMD primitives" +"No guarantees are made that " { $vocab-link "math.vectors.simd" } " words will give identical results on different SSE versions, or between the hardware intrinsics and the software fallbacks." +$nl +"In particular, horizontal operations on " { $snippet "float-4" } " and " { $snippet "float-8" } " are affected by this. They are computed with lower precision in intrinsics than the software fallback. Horizontal opeartions include anything involving adding together the components of a vector, such as " { $link sum } " or " { $link normalize } "." ; ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)" "The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors." { $subsection "math.vectors.simd.intro" } { $subsection "math.vectors.simd.types" } +{ $subsection "math.vectors.simd.words" } { $subsection "math.vectors.simd.support" } +{ $subsection "math.vectors.simd.accuracy" } { $subsection "math.vectors.simd.efficiency" } { $subsection "math.vectors.simd.alien" } { $subsection "math.vectors.simd.intrinsics" } ; -! ! ! float-4 - -HELP: float-4 -{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ; - -HELP: float-4-with -{ $values { "x" float } { "simd-array" float-4 } } -{ $description "Creates a new vector with all four components equal to a scalar." } ; - -HELP: float-4-boa -{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } } -{ $description "Creates a new vector from four scalar components." } ; - -HELP: float-4{ -{ $syntax "float-4{ a b c d }" } -{ $description "Literal syntax for a " { $link float-4 } "." } ; - -! ! ! double-2 - -HELP: double-2 -{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ; - -HELP: double-2-with -{ $values { "x" float } { "simd-array" double-2 } } -{ $description "Creates a new vector with both components equal to a scalar." } ; - -HELP: double-2-boa -{ $values { "a" float } { "b" float } { "simd-array" double-2 } } -{ $description "Creates a new vector from two scalar components." } ; - -HELP: double-2{ -{ $syntax "double-2{ a b }" } -{ $description "Literal syntax for a " { $link double-2 } "." } ; - -! ! ! float-8 - -HELP: float-8 -{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ; - -HELP: float-8-with -{ $values { "x" float } { "simd-array" float-8 } } -{ $description "Creates a new vector with all eight components equal to a scalar." } ; - -HELP: float-8-boa -{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } } -{ $description "Creates a new vector from eight scalar components." } ; - -HELP: float-8{ -{ $syntax "float-8{ a b c d e f g h }" } -{ $description "Literal syntax for a " { $link float-8 } "." } ; - -! ! ! double-4 - -HELP: double-4 -{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ; - -HELP: double-4-with -{ $values { "x" float } { "simd-array" double-4 } } -{ $description "Creates a new vector with all four components equal to a scalar." } ; - -HELP: double-4-boa -{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } } -{ $description "Creates a new vector from four scalar components." } ; - -HELP: double-4{ -{ $syntax "double-4{ a b c d }" } -{ $description "Literal syntax for a " { $link double-4 } "." } ; +HELP: SIMD: +{ $syntax "SIMD: type" } +{ $values { "type" "a scalar C type" } } +{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ; ABOUT: "math.vectors.simd" diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index f5318c341f..312dfc2cbd 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -1,354 +1,38 @@ +USING: accessors arrays classes compiler compiler.tree.debugger +effects fry io kernel kernel.private math math.functions +math.private math.vectors math.vectors.simd +math.vectors.simd.private prettyprint random sequences system +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 ; +FROM: alien.c-types => c-type-boxed-class ; +SPECIALIZED-ARRAY: float +SIMD: char +SIMD: uchar +SIMD: short +SIMD: ushort +SIMD: int +SIMD: uint +SIMD: longlong +SIMD: ulonglong +SIMD: float +SIMD: double IN: math.vectors.simd.tests -USING: math math.vectors.simd math.vectors.simd.private -math.vectors math.functions math.private kernel.private compiler -sequences tools.test compiler.tree.debugger accessors kernel -system ; -[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test +! Make sure the functor doesn't generate bogus vocabularies +2 [ [ "USE: math.vectors.simd SIMD: rubinius" eval( -- ) ] must-fail ] times -[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test +[ f ] [ "math.vectors.simd.instances.rubinius" vocab ] unit-test +! Test type propagation [ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test [ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test -[ float-4{ 12 12 12 12 } ] [ - 12 [ float-4-with ] compile-call -] unit-test +[ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test -[ float-4{ 1 2 3 4 } ] [ - 1 2 3 4 [ float-4-boa ] compile-call -] unit-test - -[ float-4{ 11 22 33 44 } ] [ - float-4{ 1 2 3 4 } float-4{ 10 20 30 40 } - [ { float-4 float-4 } declare v+ ] compile-call -] unit-test - -[ float-4{ -9 -18 -27 -36 } ] [ - float-4{ 1 2 3 4 } float-4{ 10 20 30 40 } - [ { float-4 float-4 } declare v- ] compile-call -] unit-test - -[ float-4{ 10 40 90 160 } ] [ - float-4{ 1 2 3 4 } float-4{ 10 20 30 40 } - [ { float-4 float-4 } declare v* ] compile-call -] unit-test - -[ float-4{ 10 100 1000 10000 } ] [ - float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 } - [ { float-4 float-4 } declare v/ ] compile-call -] unit-test - -[ float-4{ -10 -20 -30 -40 } ] [ - float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 } - [ { float-4 float-4 } declare vmin ] compile-call -] unit-test - -[ float-4{ 10 20 30 40 } ] [ - float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 } - [ { float-4 float-4 } declare vmax ] compile-call -] unit-test - -[ 10.0 ] [ - float-4{ 1 2 3 4 } - [ { float-4 } declare sum ] compile-call -] unit-test - -[ 13.0 ] [ - float-4{ 1 2 3 4 } - [ { float-4 } declare sum 3.0 + ] compile-call -] unit-test - -[ 8.0 ] [ - float-4{ 1 2 3 4 } float-4{ 2 0 2 0 } - [ { float-4 float-4 } declare v. ] compile-call -] unit-test - -[ float-4{ 5 10 15 20 } ] [ - 5.0 float-4{ 1 2 3 4 } - [ { float float-4 } declare n*v ] compile-call -] unit-test - -[ float-4{ 5 10 15 20 } ] [ - float-4{ 1 2 3 4 } 5.0 - [ { float float-4 } declare v*n ] compile-call -] unit-test - -[ float-4{ 10 5 2 5 } ] [ - 10.0 float-4{ 1 2 5 2 } - [ { float float-4 } declare n/v ] compile-call -] unit-test - -[ float-4{ 0.5 1 1.5 2 } ] [ - float-4{ 1 2 3 4 } 2 - [ { float float-4 } declare v/n ] compile-call -] unit-test - -[ float-4{ 1 0 0 0 } ] [ - float-4{ 10 0 0 0 } - [ { float-4 } declare normalize ] compile-call -] unit-test - -[ 30.0 ] [ - float-4{ 1 2 3 4 } - [ { float-4 } declare norm-sq ] compile-call -] unit-test - -[ t ] [ - float-4{ 1 0 0 0 } - float-4{ 0 1 0 0 } - [ { float-4 float-4 } declare distance ] compile-call - 2 sqrt 1.0e-6 ~ -] unit-test - -[ double-2{ 12 12 } ] [ - 12 [ double-2-with ] compile-call -] unit-test - -[ double-2{ 1 2 } ] [ - 1 2 [ double-2-boa ] compile-call -] unit-test - -[ double-2{ 11 22 } ] [ - double-2{ 1 2 } double-2{ 10 20 } - [ { double-2 double-2 } declare v+ ] compile-call -] unit-test - -[ double-2{ -9 -18 } ] [ - double-2{ 1 2 } double-2{ 10 20 } - [ { double-2 double-2 } declare v- ] compile-call -] unit-test - -[ double-2{ 10 40 } ] [ - double-2{ 1 2 } double-2{ 10 20 } - [ { double-2 double-2 } declare v* ] compile-call -] unit-test - -[ double-2{ 10 100 } ] [ - double-2{ 100 2000 } double-2{ 10 20 } - [ { double-2 double-2 } declare v/ ] compile-call -] unit-test - -[ double-2{ -10 -20 } ] [ - double-2{ -10 20 } double-2{ 10 -20 } - [ { double-2 double-2 } declare vmin ] compile-call -] unit-test - -[ double-2{ 10 20 } ] [ - double-2{ -10 20 } double-2{ 10 -20 } - [ { double-2 double-2 } declare vmax ] compile-call -] unit-test - -[ 3.0 ] [ - double-2{ 1 2 } - [ { double-2 } declare sum ] compile-call -] unit-test - -[ 7.0 ] [ - double-2{ 1 2 } - [ { double-2 } declare sum 4.0 + ] compile-call -] unit-test - -[ 16.0 ] [ - double-2{ 1 2 } double-2{ 2 7 } - [ { double-2 double-2 } declare v. ] compile-call -] unit-test - -[ double-2{ 5 10 } ] [ - 5.0 double-2{ 1 2 } - [ { float double-2 } declare n*v ] compile-call -] unit-test - -[ double-2{ 5 10 } ] [ - double-2{ 1 2 } 5.0 - [ { float double-2 } declare v*n ] compile-call -] unit-test - -[ double-2{ 10 5 } ] [ - 10.0 double-2{ 1 2 } - [ { float double-2 } declare n/v ] compile-call -] unit-test - -[ double-2{ 0.5 1 } ] [ - double-2{ 1 2 } 2 - [ { float double-2 } declare v/n ] compile-call -] unit-test - -[ double-2{ 0 0 } ] [ double-2 new ] unit-test - -[ double-2{ 1 0 } ] [ - double-2{ 10 0 } - [ { double-2 } declare normalize ] compile-call -] unit-test - -[ 5.0 ] [ - double-2{ 1 2 } - [ { double-2 } declare norm-sq ] compile-call -] unit-test - -[ t ] [ - double-2{ 1 0 } - double-2{ 0 1 } - [ { double-2 double-2 } declare distance ] compile-call - 2 sqrt 1.0e-6 ~ -] unit-test - -[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test - -[ double-4{ 1 2 3 4 } ] [ - 1 2 3 4 double-4-boa -] unit-test - -[ double-4{ 1 1 1 1 } ] [ - 1 double-4-with -] unit-test - -[ double-4{ 0 1 2 3 } ] [ - 1 double-4-with [ * ] map-index -] unit-test - -[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test - -[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test - -[ double-4{ 12 12 12 12 } ] [ - 12 [ double-4-with ] compile-call -] unit-test - -[ double-4{ 1 2 3 4 } ] [ - 1 2 3 4 [ double-4-boa ] compile-call -] unit-test - -[ double-4{ 11 22 33 44 } ] [ - double-4{ 1 2 3 4 } double-4{ 10 20 30 40 } - [ { double-4 double-4 } declare v+ ] compile-call -] unit-test - -[ double-4{ -9 -18 -27 -36 } ] [ - double-4{ 1 2 3 4 } double-4{ 10 20 30 40 } - [ { double-4 double-4 } declare v- ] compile-call -] unit-test - -[ double-4{ 10 40 90 160 } ] [ - double-4{ 1 2 3 4 } double-4{ 10 20 30 40 } - [ { double-4 double-4 } declare v* ] compile-call -] unit-test - -[ double-4{ 10 100 1000 10000 } ] [ - double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 } - [ { double-4 double-4 } declare v/ ] compile-call -] unit-test - -[ double-4{ -10 -20 -30 -40 } ] [ - double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 } - [ { double-4 double-4 } declare vmin ] compile-call -] unit-test - -[ double-4{ 10 20 30 40 } ] [ - double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 } - [ { double-4 double-4 } declare vmax ] compile-call -] unit-test - -[ 10.0 ] [ - double-4{ 1 2 3 4 } - [ { double-4 } declare sum ] compile-call -] unit-test - -[ 13.0 ] [ - double-4{ 1 2 3 4 } - [ { double-4 } declare sum 3.0 + ] compile-call -] unit-test - -[ 8.0 ] [ - double-4{ 1 2 3 4 } double-4{ 2 0 2 0 } - [ { double-4 double-4 } declare v. ] compile-call -] unit-test - -[ double-4{ 5 10 15 20 } ] [ - 5.0 double-4{ 1 2 3 4 } - [ { float double-4 } declare n*v ] compile-call -] unit-test - -[ double-4{ 5 10 15 20 } ] [ - double-4{ 1 2 3 4 } 5.0 - [ { float double-4 } declare v*n ] compile-call -] unit-test - -[ double-4{ 10 5 2 5 } ] [ - 10.0 double-4{ 1 2 5 2 } - [ { float double-4 } declare n/v ] compile-call -] unit-test - -[ double-4{ 0.5 1 1.5 2 } ] [ - double-4{ 1 2 3 4 } 2 - [ { float double-4 } declare v/n ] compile-call -] unit-test - -[ double-4{ 1 0 0 0 } ] [ - double-4{ 10 0 0 0 } - [ { double-4 } declare normalize ] compile-call -] unit-test - -[ 30.0 ] [ - double-4{ 1 2 3 4 } - [ { double-4 } declare norm-sq ] compile-call -] unit-test - -[ t ] [ - double-4{ 1 0 0 0 } - double-4{ 0 1 0 0 } - [ { double-4 double-4 } declare distance ] compile-call - 2 sqrt 1.0e-6 ~ -] unit-test - -[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test - -[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test - -[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test - -[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test - -[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test - -[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test - -[ float-8{ 3 6 9 12 15 18 21 24 } ] [ - float-8{ 1 2 3 4 5 6 7 8 } - float-8{ 2 4 6 8 10 12 14 16 } - [ { float-8 float-8 } declare v+ ] compile-call -] unit-test - -[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [ - float-8{ 1 2 3 4 5 6 7 8 } - float-8{ 2 4 6 8 10 12 14 16 } - [ { float-8 float-8 } declare v- ] compile-call -] unit-test - -[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [ - -0.5 - float-8{ 2 4 6 8 10 12 14 16 } - [ { float float-8 } declare n*v ] compile-call -] unit-test - -[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [ - float-8{ 2 4 6 8 10 12 14 16 } - -0.5 - [ { float-8 float } declare v*n ] compile-call -] unit-test - -[ float-8{ 256 128 64 32 16 8 4 2 } ] [ - 256.0 - float-8{ 1 2 4 8 16 32 64 128 } - [ { float float-8 } declare n/v ] compile-call -] unit-test - -[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [ - float-8{ 2 4 6 8 10 12 14 16 } - -2.0 - [ { float-8 float } declare v/n ] compile-call -] unit-test +[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test ! Test puns; only on x86 cpu x86? [ @@ -362,3 +46,205 @@ cpu x86? [ [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call ] unit-test ] when + +! Fuzz testing +CONSTANT: simd-classes + { + char-16 + uchar-16 + char-32 + uchar-32 + short-8 + ushort-8 + short-16 + ushort-16 + int-4 + uint-4 + int-8 + uint-8 + longlong-2 + ulonglong-2 + longlong-4 + ulonglong-4 + float-4 + float-8 + double-2 + double-4 + } + +: with-ctors ( -- seq ) + simd-classes [ [ name>> "-with" append ] [ vocabulary>> ] bi lookup ] map ; + +: boa-ctors ( -- seq ) + simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ; + +: check-optimizer ( seq inputs quot eq-quot -- ) + '[ + @ + [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ] + [ [ call ] dip call ] + [ [ call ] dip compile-call ] 2tri @ not + ] filter ; inline + +"== Checking -new constructors" print + +[ { } ] [ + simd-classes [ [ [ ] ] dip '[ _ new ] ] [ = ] check-optimizer +] unit-test + +[ { } ] [ + simd-classes [ '[ _ new ] compile-call [ zero? ] all? not ] filter +] unit-test + +"== Checking -with constructors" print + +[ { } ] [ + with-ctors [ + [ 1000 random '[ _ ] ] dip '[ { fixnum } declare _ execute ] + ] [ = ] check-optimizer +] unit-test + +"== Checking -boa constructors" print + +[ { } ] [ + boa-ctors [ + dup stack-effect in>> length + [ nip [ 1000 random ] [ ] replicate-as ] + [ fixnum swap '[ _ declare _ execute ] ] + 2bi + ] [ = ] check-optimizer +] unit-test + +"== Checking vector operations" print + +: random-vector ( class -- vec ) + new [ drop 1000 random ] map ; + +:: check-vector-op ( word inputs class elt-class -- inputs quot ) + inputs [ + [ + { + { +vector+ [ class random-vector ] } + { +scalar+ [ 1000 random elt-class float = [ >float ] when ] } + } case + ] [ ] map-as + ] [ + [ + { + { +vector+ [ class ] } + { +scalar+ [ elt-class ] } + } case + ] map + ] bi + word '[ _ declare _ execute ] ; + +: remove-float-words ( alist -- alist' ) + [ drop { vsqrt n/v v/n v/ normalize } member? not ] assoc-filter ; + +: ops-to-check ( elt-class -- alist ) + [ vector-words >alist ] dip + float = [ remove-float-words ] unless ; + +: check-vector-ops ( class elt-class compare-quot -- ) + [ + [ nip ops-to-check ] 2keep + '[ first2 inputs _ _ check-vector-op ] + ] dip check-optimizer ; inline + +: approx= ( x y -- ? ) + { + { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] } + { [ 2dup [ sequence? ] both? ] [ + [ + { + { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] } + { [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] } + } cond + ] 2all? + ] } + } cond ; + +: simd-classes&reps ( -- alist ) + simd-classes [ + { + { [ dup name>> "float" head? ] [ float [ approx= ] ] } + { [ dup name>> "double" tail? ] [ float [ = ] ] } + [ fixnum [ = ] ] + } cond 3array + ] map ; + +simd-classes&reps [ + [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test +] each + +! Other regressions +[ 8000000 ] [ + int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 } + [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call +] unit-test + +! Vector alien intrinsics +[ float-4{ 1 2 3 4 } ] [ + [ + float-4{ 1 2 3 4 } + underlying>> 0 float-4-rep alien-vector + ] compile-call float-4 boa +] unit-test + +[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [ + 16 [ 1 ] B{ } replicate-as 16 + [ + 0 [ + { byte-array c-ptr fixnum } declare + float-4-rep set-alien-vector + ] compile-call + ] keep +] unit-test + +[ float-array{ 1 2 3 4 } ] [ + [ + float-array{ 1 2 3 4 } underlying>> + float-array{ 4 3 2 1 } clone + [ underlying>> 0 float-4-rep set-alien-vector ] keep + ] compile-call +] unit-test + +STRUCT: simd-struct +{ x float-4 } +{ y double-2 } +{ z double-4 } +{ w float-8 } ; + +[ t ] [ [ simd-struct ] compile-call >c-ptr [ 0 = ] all? ] unit-test + +[ + float-4{ 1 2 3 4 } + double-2{ 2 1 } + double-4{ 4 3 2 1 } + float-8{ 1 2 3 4 5 6 7 8 } +] [ + simd-struct + float-4{ 1 2 3 4 } >>x + double-2{ 2 1 } >>y + double-4{ 4 3 2 1 } >>z + float-8{ 1 2 3 4 5 6 7 8 } >>w + { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave +] unit-test + +[ + float-4{ 1 2 3 4 } + double-2{ 2 1 } + double-4{ 4 3 2 1 } + float-8{ 1 2 3 4 5 6 7 8 } +] [ + [ + simd-struct + float-4{ 1 2 3 4 } >>x + double-2{ 2 1 } >>y + double-4{ 4 3 2 1 } >>z + float-8{ 1 2 3 4 5 6 7 8 } >>w + { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave + ] compile-call +] unit-test + +[ ] [ char-16 new 1array stack. ] unit-test diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index a3c99ae217..71936b2657 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -1,185 +1,41 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types byte-arrays cpu.architecture -kernel math math.functions math.vectors -math.vectors.simd.functor math.vectors.simd.intrinsics -math.vectors.specialization parser prettyprint.custom sequences -sequences.private locals assocs words fry ; -FROM: alien.c-types => float ; -QUALIFIED-WITH: math m +USING: alien.c-types combinators fry kernel lexer math math.parser +math.vectors.simd.functor sequences splitting vocabs.generated +vocabs.loader vocabs.parser words ; +QUALIFIED-WITH: alien.c-types c IN: math.vectors.simd -<< - -DEFER: float-4 -DEFER: double-2 -DEFER: float-8 -DEFER: double-4 - -"double" define-simd-128 -"float" define-simd-128 -"double" define-simd-256 -"float" define-simd-256 - ->> - -: float-4-with ( x -- simd-array ) - [ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ; - -: float-4-boa ( a b c d -- simd-array ) - \ float-4 new 4sequence ; - -: double-2-with ( x -- simd-array ) - [ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ; - -: double-2-boa ( a b -- simd-array ) - \ double-2 new 2sequence ; - -! More efficient expansions for the above, used when SIMD is -! actually available. - -<< - -\ float-4-with [ - drop - \ (simd-broadcast) "intrinsic" word-prop [ - [ >float float-4-rep (simd-broadcast) \ float-4 boa ] - ] [ \ float-4-with def>> ] if -] "custom-inlining" set-word-prop - -\ float-4-boa [ - drop - \ (simd-gather-4) "intrinsic" word-prop [ - [| a b c d | - a >float b >float c >float d >float - float-4-rep (simd-gather-4) \ float-4 boa - ] - ] [ \ float-4-boa def>> ] if -] "custom-inlining" set-word-prop - -\ double-2-with [ - drop - \ (simd-broadcast) "intrinsic" word-prop [ - [ >float double-2-rep (simd-broadcast) \ double-2 boa ] - ] [ \ double-2-with def>> ] if -] "custom-inlining" set-word-prop - -\ double-2-boa [ - drop - \ (simd-gather-4) "intrinsic" word-prop [ - [ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ] - ] [ \ double-2-boa def>> ] if -] "custom-inlining" set-word-prop - ->> - -: float-8-with ( x -- simd-array ) - [ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@ - \ float-8 boa ; inline - -:: float-8-boa ( a b c d e f g h -- simd-array ) - a b c d float-4-boa - e f g h float-4-boa - [ underlying>> ] bi@ - \ float-8 boa ; inline - -: double-4-with ( x -- simd-array ) - [ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@ - \ double-4 boa ; inline - -:: double-4-boa ( a b c d -- simd-array ) - a b double-2-boa - c d double-2-boa - [ underlying>> ] bi@ - \ double-4 boa ; inline - -<< +ERROR: bad-base-type type ; -\ float-4 \ float-4-with m:float H{ - { v+ [ [ (simd-v+) ] float-4-vv->v-op ] } - { v- [ [ (simd-v-) ] float-4-vv->v-op ] } - { v* [ [ (simd-v*) ] float-4-vv->v-op ] } - { v/ [ [ (simd-v/) ] float-4-vv->v-op ] } - { vmin [ [ (simd-vmin) ] float-4-vv->v-op ] } - { vmax [ [ (simd-vmax) ] float-4-vv->v-op ] } - { sum [ [ (simd-sum) ] float-4-v->n-op ] } -} simd-vector-words +: define-simd-vocab ( type -- vocab ) + [ simd-vocab ] keep '[ + _ parse-base-type + [ define-simd-128 ] + [ define-simd-256 ] bi + ] generate-vocab ; -\ double-2 \ double-2-with m:float H{ - { v+ [ [ (simd-v+) ] double-2-vv->v-op ] } - { v- [ [ (simd-v-) ] double-2-vv->v-op ] } - { v* [ [ (simd-v*) ] double-2-vv->v-op ] } - { v/ [ [ (simd-v/) ] double-2-vv->v-op ] } - { vmin [ [ (simd-vmin) ] double-2-vv->v-op ] } - { vmax [ [ (simd-vmax) ] double-2-vv->v-op ] } - { sum [ [ (simd-sum) ] double-2-v->n-op ] } -} simd-vector-words - -\ float-8 \ float-8-with m:float H{ - { v+ [ [ (simd-v+) ] float-8-vv->v-op ] } - { v- [ [ (simd-v-) ] float-8-vv->v-op ] } - { v* [ [ (simd-v*) ] float-8-vv->v-op ] } - { v/ [ [ (simd-v/) ] float-8-vv->v-op ] } - { vmin [ [ (simd-vmin) ] float-8-vv->v-op ] } - { vmax [ [ (simd-vmax) ] float-8-vv->v-op ] } - { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] } -} simd-vector-words - -\ double-4 \ double-4-with m:float H{ - { v+ [ [ (simd-v+) ] double-4-vv->v-op ] } - { v- [ [ (simd-v-) ] double-4-vv->v-op ] } - { v* [ [ (simd-v*) ] double-4-vv->v-op ] } - { v/ [ [ (simd-v/) ] double-4-vv->v-op ] } - { vmin [ [ (simd-vmin) ] double-4-vv->v-op ] } - { vmax [ [ (simd-vmax) ] double-4-vv->v-op ] } - { sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] } -} simd-vector-words - ->> - -USE: vocabs.loader - -"math.vectors.simd.alien" require +SYNTAX: SIMD: + scan define-simd-vocab use-vocab ; diff --git a/basis/math/vectors/simd/summary.txt b/basis/math/vectors/simd/summary.txt new file mode 100644 index 0000000000..22593f1286 --- /dev/null +++ b/basis/math/vectors/simd/summary.txt @@ -0,0 +1 @@ +Single-instruction-multiple-data parallel vector operations diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index 21ec9f64f3..bf2dac29d6 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -53,10 +53,14 @@ H{ { norm-sq { +vector+ -> +nonnegative+ } } { normalize { +vector+ -> +vector+ } } { v* { +vector+ +vector+ -> +vector+ } } + { vs* { +vector+ +vector+ -> +vector+ } } { v*n { +vector+ +scalar+ -> +vector+ } } { v+ { +vector+ +vector+ -> +vector+ } } + { vs+ { +vector+ +vector+ -> +vector+ } } + { v+- { +vector+ +vector+ -> +vector+ } } { v+n { +vector+ +scalar+ -> +vector+ } } { v- { +vector+ +vector+ -> +vector+ } } + { vs- { +vector+ +vector+ -> +vector+ } } { v-n { +vector+ +scalar+ -> +vector+ } } { v. { +vector+ +vector+ -> +scalar+ } } { v/ { +vector+ +vector+ -> +vector+ } } @@ -68,6 +72,11 @@ H{ { vneg { +vector+ -> +vector+ } } { vtruncate { +vector+ -> +vector+ } } { sum { +vector+ -> +scalar+ } } + { vabs { +vector+ -> +vector+ } } + { vsqrt { +vector+ -> +vector+ } } + { vbitand { +vector+ +vector+ -> +vector+ } } + { vbitor { +vector+ +vector+ -> +vector+ } } + { vbitxor { +vector+ +vector+ -> +vector+ } } } PREDICATE: vector-word < word vector-words key? ; diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 7456597278..3790e38d55 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math sequences ; +USING: help.markup help.syntax math math.functions sequences ; IN: math.vectors ARTICLE: "math-vectors" "Vector arithmetic" @@ -14,18 +14,46 @@ $nl { $subsection n+v } { $subsection v-n } { $subsection n-v } -"Combining two vectors to form another vector with " { $link 2map } ":" +"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* } +"Comparisons:" { $subsection vmax } { $subsection vmin } +"Bitwise operations:" +{ $subsection vbitand } +{ $subsection vbitor } +{ $subsection vbitxor } "Inner product and norm:" { $subsection v. } { $subsection norm } { $subsection norm-sq } -{ $subsection normalize } ; +{ $subsection normalize } +"Comparing vectors:" +{ $subsection distance } +{ $subsection v~ } +"Other functions:" +{ $subsection vsupremum } +{ $subsection vinfimum } +{ $subsection trilerp } +{ $subsection bilerp } +{ $subsection vlerp } +{ $subsection vnlerp } +{ $subsection vbilerp } ; ABOUT: "math-vectors" @@ -33,6 +61,43 @@ HELP: vneg { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } { $description "Negates each element of " { $snippet "u" } "." } ; +HELP: vabs +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of non-negative real numbers" } } +{ $description "Takes the absolute value of each element of " { $snippet "u" } "." } ; + +HELP: vsqrt +{ $values { "u" "a sequence of non-negative real numbers" } { "v" "a sequence of non-negative real numbers" } } +{ $description "Takes the square root of each element of " { $snippet "u" } "." } +{ $warning "For performance reasons, this does not work with negative inputs, unlike " { $link sqrt } "." } ; + +HELP: vfloor +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } } +{ $description "Takes the " { $link floor } " of each element of " { $snippet "u" } "." } ; + +HELP: vceiling +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } } +{ $description "Takes the " { $link ceiling } " of each element of " { $snippet "u" } "." } ; + +HELP: vtruncate +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } } +{ $description "Truncates each element of " { $snippet "u" } "." } ; + +HELP: n+v +{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ; + +HELP: v+n +{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } } +{ $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ; + +HELP: n-v +{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Subtracts each element of " { $snippet "u" } " from " { $snippet "n" } "." } ; + +HELP: v-n +{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } } +{ $description "Subtracts " { $snippet "n" } " from each element of " { $snippet "u" } "." } ; + HELP: n*v { $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } { $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; @@ -43,11 +108,13 @@ HELP: v*n HELP: n/v { $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } -{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." } ; +{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." } +{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ; HELP: v/n { $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } } -{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; +{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } +{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ; HELP: v+ { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } @@ -57,6 +124,17 @@ HELP: v- { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise." } ; +HELP: v+- +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Adds and subtracts alternate elements of " { $snippet "v" } " and " { $snippet "u" } " component-wise." } +{ $examples + { $example + "USING: math.vectors prettyprint ;" + "{ 1 2 3 } { 2 3 2 } v+- ." + "{ -1 5 1 }" + } +} ; + HELP: [v-] { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } { $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise; any components which become negative are set to zero." } ; @@ -68,7 +146,7 @@ HELP: v* HELP: v/ { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Divides " { $snippet "u" } " by " { $snippet "v" } " component-wise." } -{ $errors "Throws an error if an integer division by zero occurs." } ; +{ $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ; HELP: vmax { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } @@ -85,9 +163,52 @@ HELP: v. { $description "Computes the real-valued dot product." } { $notes "This word can also take complex number sequences as input, however mathematically it will compute the wrong result. The complex-valued dot product is defined differently:" - { $snippet "0 [ conjugate * + ] 2reduce" } + { $code "0 [ conjugate * + ] 2reduce" } } ; +HELP: vs+ +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Adds " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." } +{ $examples + "With saturation:" + { $example + "USING: math.vectors prettyprint specialized-arrays ;" + "SPECIALIZED-ARRAY: uchar" + "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } vs+ ." + "uchar-array{ 170 255 220 }" + } + "Without saturation:" + { $example + "USING: math.vectors prettyprint specialized-arrays ;" + "SPECIALIZED-ARRAY: uchar" + "uchar-array{ 100 200 150 } uchar-array{ 70 70 70 } v+ ." + "uchar-array{ 170 14 220 }" + } +} ; + +HELP: vs- +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise with saturation." } ; + +HELP: vs* +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Multiplies " { $snippet "u" } " and " { $snippet "v" } " component-wise with saturation." } ; + +HELP: vbitand +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Takes the bitwise and of " { $snippet "u" } " and " { $snippet "v" } " component-wise." } +{ $notes "Unlike " { $link bitand } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ; + +HELP: vbitor +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Takes the bitwise or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." } +{ $notes "Unlike " { $link bitor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ; + +HELP: vbitxor +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Takes the bitwise exclusive or of " { $snippet "u" } " and " { $snippet "v" } " component-wise." } +{ $notes "Unlike " { $link bitxor } ", this word may be used on a specialized array of floats or doubles, in which case the bitwise representation of the floating point numbers is operated upon." } ; + HELP: norm-sq { $values { "v" "a sequence of numbers" } { "x" "a non-negative real number" } } { $description "Computes the squared length of a mathematical vector." } ; @@ -100,6 +221,10 @@ HELP: normalize { $values { "u" "a sequence of numbers, not all zero" } { "v" "a sequence of numbers" } } { $description "Outputs a vector with the same direction as " { $snippet "u" } " but length 1." } ; +HELP: distance +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "x" "a non-negative real number" } } +{ $description "Outputs the Euclidean distance between two vectors." } ; + HELP: set-axis { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "axis" "a sequence of 0/1" } { "w" "a sequence of numbers" } } { $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "u" } " in place of 0, and corresponding elements from " { $snippet "v" } " in place of 1." } @@ -108,3 +233,5 @@ HELP: set-axis { 2map v+ v- v* v/ } related-words { 2reduce v. } related-words + +{ vs+ vs- vs* } related-words diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index 3e56644d3e..fc482815a9 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -17,4 +17,6 @@ USING: math.vectors tools.test ; [ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test -[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test \ No newline at end of file +[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test + +[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test \ No newline at end of file diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index dd48525b53..4b6f67544a 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -1,9 +1,12 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences math math.functions hints -math.order ; +USING: arrays alien.c-types kernel sequences math math.functions +hints math.order math.libm fry combinators ; +QUALIFIED-WITH: alien.c-types c IN: math.vectors +GENERIC: element-type ( obj -- c-type ) + : vneg ( u -- v ) [ neg ] map ; : v+n ( u n -- v ) [ + ] curry map ; @@ -24,9 +27,43 @@ IN: math.vectors : vmax ( u v -- w ) [ max ] 2map ; : vmin ( u v -- w ) [ min ] 2map ; -: vfloor ( v -- _v_ ) [ floor ] map ; -: vceiling ( v -- ^v^ ) [ ceiling ] map ; -: vtruncate ( v -- -v- ) [ truncate ] map ; +: v+- ( u v -- w ) + [ t ] 2dip + [ [ not ] 2dip pick [ + ] [ - ] if ] 2map + nip ; + + + +: vs+ ( u v -- w ) [ + ] 2saturate-map ; +: vs- ( u v -- w ) [ - ] 2saturate-map ; +: vs* ( u v -- w ) [ * ] 2saturate-map ; + +: vabs ( u -- v ) [ abs ] map ; +: vsqrt ( u -- v ) [ >float fsqrt ] map ; + +bits ] bi@ ] dip call bits>double ] } + { c:float [ [ [ float>bits ] bi@ ] dip call bits>float ] } + [ drop call ] + } case ; inline + +PRIVATE> + +: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ; +: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ; +: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ; + +: vfloor ( u -- v ) [ floor ] map ; +: vceiling ( u -- v ) [ ceiling ] map ; +: vtruncate ( u -- v ) [ truncate ] map ; : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 3616c0976c..ef42b80fa4 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -5,10 +5,6 @@ HELP: STRING: { $syntax "STRING: name\nfoo\n;" } { $description "Forms a multiline string literal, or 'here document' stored in the word called name. A semicolon is used to signify the end, and that semicolon must be on a line by itself, not preceeded or followed by any whitespace. The string will have newlines in between lines but not at the end, unless there is a blank line before the semicolon." } ; -HELP: <" -{ $syntax "<\" text \">" } -{ $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ; - HELP: /* { $syntax "/* comment */" } { $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." } @@ -47,17 +43,14 @@ HELP: DELIMITED: } } ; -{ POSTPONE: <" POSTPONE: STRING: } related-words - HELP: parse-multiline-string { $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } } { $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." } -{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ; +{ $notes "Used to implement " { $link POSTPONE: /* } "." } ; ARTICLE: "multiline" "Multiline" "Multiline strings:" { $subsection POSTPONE: STRING: } -{ $subsection POSTPONE: <" } { $subsection POSTPONE: HEREDOC: } { $subsection POSTPONE: DELIMITED: } "Multiline comments:" diff --git a/basis/multiline/multiline-tests.factor b/basis/multiline/multiline-tests.factor index 25610ed660..ad624dd917 100644 --- a/basis/multiline/multiline-tests.factor +++ b/basis/multiline/multiline-tests.factor @@ -8,17 +8,6 @@ bar ; [ "foo\nbar\n" ] [ test-it ] unit-test -[ "foo\nbar\n" ] [ <" foo -bar -"> ] unit-test - -[ "hello\nworld" ] [ <" hello -world"> ] unit-test - -[ "hello" "world" ] [ <" hello"> <" world"> ] unit-test - -[ "\nhi" ] [ <" -hi"> ] unit-test ! HEREDOC: diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 4eaafe1f18..e28537066b 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -75,18 +75,6 @@ PRIVATE> : parse-multiline-string ( end-text -- str ) 1 (parse-multiline-string) ; -SYNTAX: <" - "\">" parse-multiline-string parsed ; - -SYNTAX: <' - "'>" parse-multiline-string parsed ; - -SYNTAX: {' - "'}" parse-multiline-string parsed ; - -SYNTAX: {" - "\"}" parse-multiline-string parsed ; - SYNTAX: /* "*/" parse-multiline-string drop ; SYNTAX: HEREDOC: diff --git a/basis/opengl/capabilities/capabilities-docs.factor b/basis/opengl/capabilities/capabilities-docs.factor index 959b222671..8b43c56f6d 100644 --- a/basis/opengl/capabilities/capabilities-docs.factor +++ b/basis/opengl/capabilities/capabilities-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; +opengl.gl assocs ; IN: opengl.capabilities HELP: gl-version @@ -42,10 +42,10 @@ HELP: has-gl-extensions? { $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } { $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." } { $examples "Testing for framebuffer object and pixel buffer support:" - { $code <" { + { $code """{ { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" } "GL_ARB_pixel_buffer_object" -} has-gl-extensions? "> } +} has-gl-extensions?""" } } ; HELP: has-gl-version-or-extensions? diff --git a/basis/opengl/debug/debug-docs.factor b/basis/opengl/debug/debug-docs.factor index 7cb8f9b246..ac666a21c3 100644 --- a/basis/opengl/debug/debug-docs.factor +++ b/basis/opengl/debug/debug-docs.factor @@ -1,15 +1,14 @@ ! (c)2009 Joe Groff bsd license -USING: help.markup help.syntax multiline tools.continuations ; +USING: help.markup help.syntax tools.continuations ; IN: opengl.debug HELP: G { $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." } -{ $examples { $code <" USING: opengl.debug ui ; +{ $examples { $code """USING: opengl.debug ui ; [ drop t ] find-window G-world set G 0.0 0.0 1.0 1.0 glClearColor -G GL_COLOR_BUFFER_BIT glClear -"> } } ; +G GL_COLOR_BUFFER_BIT glClear""" } } ; HELP: F { $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ; diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index 329156d733..bcd881c03d 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -521,10 +521,10 @@ Tok = Spaces (Number | Special ) [ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail -[ <" USE: peg.ebnf [EBNF +[ """USE: peg.ebnf [EBNF lol = a lol = b - EBNF] "> eval( -- ) + EBNF]""" eval( -- ) ] [ error>> [ redefined-rule? ] [ name>> "lol" = ] bi and ] must-fail-with diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index cba40bbff1..fb47c50fbe 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -173,6 +173,7 @@ M: tuple pprint* ] when ; : pprint-elements ( seq -- ) + >array do-length-limit [ [ pprint* ] each ] dip [ "~" swap number>string " more~" 3append text ] when* ; diff --git a/basis/prettyprint/stylesheet/stylesheet.factor b/basis/prettyprint/stylesheet/stylesheet.factor index a593f23d99..580049160d 100644 --- a/basis/prettyprint/stylesheet/stylesheet.factor +++ b/basis/prettyprint/stylesheet/stylesheet.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Keith Lazuka. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs colors.constants combinators +USING: assocs colors colors.constants combinators combinators.short-circuit hashtables io.styles kernel literals namespaces sequences words words.symbol ; IN: prettyprint.stylesheet @@ -43,4 +43,5 @@ PRIVATE> dim-color colored-presentation-style ; : effect-style ( effect -- style ) - COLOR: DarkGreen colored-presentation-style ; + 0 0.2 0 1 colored-presentation-style + { { font-style plain } } assoc-union ; diff --git a/basis/quoted-printable/quoted-printable-tests.factor b/basis/quoted-printable/quoted-printable-tests.factor index abaff9e222..e258cb9a96 100644 --- a/basis/quoted-printable/quoted-printable-tests.factor +++ b/basis/quoted-printable/quoted-printable-tests.factor @@ -1,24 +1,24 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test quoted-printable multiline io.encodings.string +USING: tools.test quoted-printable io.encodings.string sequences io.encodings.8-bit splitting kernel ; IN: quoted-printable.tests -[ <" José was the +[ """José was the person who knew how to write the letters: ő and ü -and we didn't know hów tö do thât"> ] -[ <" Jos=E9 was the +and we didn't know hów tö do thât""" ] +[ """Jos=E9 was the person who knew how to write the letters: =F5 and =FC=20 and w= -e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test +e didn't know h=F3w t=F6 do th=E2t""" quoted> latin2 decode ] unit-test -[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ] -[ <" José was the +[ """Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t""" ] +[ """José was the person who knew how to write the letters: ő and ü -and we didn't know hów tö do thât"> latin2 encode >quoted ] unit-test +and we didn't know hów tö do thât""" latin2 encode >quoted ] unit-test : message ( -- str ) 55 [ "hello" ] replicate concat ; diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index 222ecaf935..bb0fc57312 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -72,6 +72,18 @@ HELP: randomize } { $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ; +HELP: sample +{ $values + { "seq" sequence } { "n" integer } + { "seq'" sequence } +} +{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." } +{ $examples + { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ." + "{ 3 2 }" + } +} ; + HELP: delete-random { $values { "seq" sequence } @@ -100,6 +112,8 @@ $nl { $subsection "random-protocol" } "Randomizing a sequence:" { $subsection randomize } +"Sampling a sequences:" +{ $subsection sample } "Deleting a random element from a sequence:" { $subsection delete-random } "Random numbers with " { $snippet "n" } " bits:" diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 2b6ac9b1b8..da8d4a1844 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -25,3 +25,8 @@ IN: random.tests [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test [ 49 ] [ 50 random-bits* log2 ] unit-test + +[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with + +[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test +[ 99 ] [ 100 99 sample prune length ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index 4c94e87928..afdf0b43ba 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel math namespaces sequences -io.backend io.binary combinators system vocabs.loader -summary math.bitwise byte-vectors fry byte-arrays -math.ranges math.constants math.functions accessors ; +USING: accessors alien.c-types assocs byte-arrays byte-vectors +combinators fry io.backend io.binary kernel locals math +math.bitwise math.constants math.functions math.ranges +namespaces sequences sets summary system vocabs.loader ; IN: random SYMBOL: system-random-generator @@ -60,6 +60,25 @@ PRIVATE> [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ] while drop ; +ERROR: too-many-samples seq n ; + + + +: sample ( seq n -- seq' ) + 2dup [ length ] dip < [ too-many-samples ] when + swap [ length ] [ ] bi H{ } clone + '[ _ dup random _ _ next-sample ] replicate ; + : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; diff --git a/basis/regexp/combinators/combinators-docs.factor b/basis/regexp/combinators/combinators-docs.factor index a49b16b585..20d5624025 100644 --- a/basis/regexp/combinators/combinators-docs.factor +++ b/basis/regexp/combinators/combinators-docs.factor @@ -18,20 +18,21 @@ ARTICLE: "regexp.combinators.intro" "Regular expression combinator rationale" ARTICLE: "regexp.combinators" "Regular expression combinators" "The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary." -{ $subsection "regexp.combinators.intro" } +{ $subsections "regexp.combinators.intro" } "Basic combinators:" -{ $subsection } -{ $subsection } +{ $subsections } "Higher-order combinators for building new regular expressions from existing ones:" -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } +{ $subsections + + + + + +} "Derived combinators implemented in terms of the above:" -{ $subsection } +{ $subsections } "Setting options:" -{ $subsection