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

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

db4
Joe Groff 2009-09-24 00:11:06 -05:00
parent 4b201f171a 3d0c9c4337
commit 2b1b54d907
212 changed files with 3662 additions and 2274 deletions
basis
alien/c-types
checksums/openssl
classes/struct
combinators/smart
compiler
cpu
db
debugger
definitions/icons
delegate
documents/elements
functors
furnace
grouping
help
html
http/server
inspector
json
literals
math
multiline
opengl
peg/ebnf
prettyprint
Show More

9
basis/alien/c-types/c-types-tests.factor
View File

@ -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> *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

35
basis/alien/c-types/c-types.factor
View File

@ -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

6
basis/checksums/openssl/openssl.factor
View File

@ -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 ;
: <evp-md-context> ( -- ctx )
evp-md-context new-disposable
EVP_MD_CTX <struct> 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 [ <evp-md-context> ] dip with-disposal ; inline

10
basis/classes/struct/struct-tests.factor
View File

@ -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
[ {

35
basis/classes/struct/struct.factor
View File

@ -103,6 +103,8 @@ M: struct-class boa>object
[ <struct> ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
M: struct-class initial-value* <struct> ; 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
<PRIVATE
GENERIC: binary-zero? ( value -- ? )
M: object binary-zero? drop f ;
M: f binary-zero? drop t ;
M: number binary-zero? zero? ;
M: struct binary-zero?
[ byte-length iota ] [ >c-ptr ] bi
[ <displaced-alien> *uchar zero? ] curry all? ;
: struct-needs-prototype? ( class -- ? )
struct-slots [ initial>> binary-zero? ] all? not ;
: make-struct-prototype ( class -- prototype )
[ "struct-size" word-prop <byte-array> ]
[ 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 <byte-array> ]
[ 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) ]

6
basis/combinators/smart/smart-docs.factor
View File

@ -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: input<sequence
@ -26,10 +26,10 @@ HELP: output>array
{ $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 }"
}
} ;

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

@ -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

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

@ -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 -- ) ;

6
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -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 <spill-slot> ] unless ;
?at [ spill-slots get ?at [ <spill-slot> ] [ 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 ;

18
basis/compiler/cfg/linear-scan/numbering/numbering.factor
View File

@ -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?

14
basis/compiler/cfg/linearization/order/order-tests.factor Normal file
View File

@ -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

14
basis/compiler/cfg/linearization/order/order.factor
View File

@ -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>> <reversed> [ 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)

18
basis/compiler/cfg/ssa/cssa/cssa.factor
View File

@ -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 ;

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

@ -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 -- )

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

@ -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

35
basis/compiler/tests/codegen.factor
View File

@ -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

16
basis/compiler/tests/folding.factor
View File

@ -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 <array> ;
"> eval( -- )
M: integer foldable-generic f <array> ;"
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 ] [

4
basis/compiler/tests/low-level-ir.factor
View File

@ -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

11
basis/compiler/tests/optimizer.factor
View File

@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * )
[ t ] [ \ <tuple>-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

17
basis/compiler/tests/redefine10.factor
View File

@ -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 ] [

9
basis/compiler/tests/redefine11.factor
View File

@ -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
[ ] [

16
basis/compiler/tests/redefine5.factor
View File

@ -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 ] [

16
basis/compiler/tests/redefine6.factor
View File

@ -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 ] [

16
basis/compiler/tests/redefine7.factor
View File

@ -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 ] [

16
basis/compiler/tests/redefine8.factor
View File

@ -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 ] [

16
basis/compiler/tests/redefine9.factor
View File

@ -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
[

46
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -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 ;

19
basis/compiler/tree/propagation/constraints/constraints.factor
View File

@ -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 <class-info> 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 <class-info> 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 ;

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

@ -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 ? )

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

@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ;
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method
method-for-class
] if
] if ;

13
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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 <class/interval-info>
'[ 2drop _ ] "outputs" set-word-prop
] each

14
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -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

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

@ -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
<class-info>
] "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] <class/interval-info> 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 -- )

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

@ -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

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

@ -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 -- )

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

@ -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 ;

2
basis/cpu/x86/32/32.factor
View File

@ -322,4 +322,4 @@ os windows? [
4 "double" c-type (>>align)
] unless
"cpu.x86.features" require
check-sse

10
basis/cpu/x86/64/64.factor
View File

@ -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

12
basis/cpu/x86/assembler/assembler.factor
View File

@ -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.
<PRIVATE
GENERIC: (MOV-I) ( src dst -- )
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I)
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
PRIVATE>
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 ;
<PRIVATE
GENERIC# JUMPcc 1 ( addr opcode -- )
M: integer JUMPcc extended-opcode, 4, ;
PRIVATE>
: 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 ;
<PRIVATE
: (SHIFT) ( dst src op -- )
over CL eq? [
nip t HEX: d3 3array 1-operand
@ -303,6 +313,8 @@ M: operand TEST OCT: 204 2-operand ;
swapd t HEX: c0 3array immediate-1
] if ; inline
PRIVATE>
: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
: RCL ( dst n -- ) BIN: 010 (SHIFT) ;

2
basis/cpu/x86/assembler/operands/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Joe Groff

1
basis/cpu/x86/assembler/operands/summary.txt Normal file
View File

@ -0,0 +1 @@
x86 registers and memory operands

51
basis/cpu/x86/features/features.factor
View File

@ -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

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

@ -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
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 ;

26
basis/db/db-docs.factor
View File

@ -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 <sqlite-db> swap with-db ; inline"> }
"book.db" temp-file <sqlite-db> 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 <sqlite-db> swap with-db ; inline"> }
"my-database.db" temp-file <sqlite-db> swap with-db ; inline""" }
"PostgreSQL example combinator:"
{ $code <" USING: db.postgresql db ;
{ $code """USING: db.postgresql db ;
: with-postgresql-db ( quot -- )
<postgresql-db>
"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"

26
basis/db/sqlite/sqlite.factor
View File

@ -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? ( -- ? )

33
basis/db/tuples/tuples-docs.factor
View File

@ -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 <sqlite-db> _ 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"

4
basis/debugger/debugger.factor
View File

@ -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" ;

13
basis/definitions/icons/icons.factor
View File

@ -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 ;

30
basis/delegate/delegate-tests.factor
View File

@ -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 ; "> <string-reader> "delegate-test" parse-stream
M: a-tuple do-me drop ;" <string-reader> "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 ; "> <string-reader> "delegate-test" parse-stream
CONSULT: silly-protocol a-tuple drop f ; " <string-reader> "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 "> <string-reader> "delegate-test" parse-stream
"IN: delegate.tests" <string-reader> "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>> ;"
<string-reader> "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 ;"
<string-reader> "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 ; "
<string-reader> "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>> ;"
<string-reader> "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 ;"
<string-reader> "remove-consult-test" parse-stream
] unit-test

6
basis/documents/elements/elements-tests.factor
View File

@ -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
<document> 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 <page-elt> prev-elt ] unit-test
[ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test

10
basis/functors/functors-tests.factor
View File

@ -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
"> <string-reader> "functors-test" parse-stream
SYMBOL: some-symbol" <string-reader> "functors-test" parse-stream
] unit-test
: test-redefinition ( -- )
@ -145,9 +144,8 @@ SYMBOL: W-symbol
;FUNCTOR
[ [ ] ] [
<" IN: functors.tests
<< "some" redefine-test >>
"> <string-reader> "functors-test" parse-stream
"""IN: functors.tests
<< "some" redefine-test >>""" <string-reader> "functors-test" parse-stream
] unit-test
test-redefinition

6
basis/furnace/actions/actions-docs.factor
View File

@ -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: <action>
@ -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 ;"""
}
} ;

6
basis/furnace/alloy/alloy-docs.factor
View File

@ -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: <alloy>
{ $examples
"The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
{ $code
<" : counter-db ( -- db ) "counter.db" <sqlite-db> ;
""": counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>
counter-db <alloy>
main-responder set-global
8080 httpd ;">
8080 httpd ;"""
}
} ;

14
basis/furnace/auth/auth-docs.factor
View File

@ -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: <protected>
@ -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
<" <protected>
"view your todo list" >>description">
"""<protected>
"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
<" <protected>
"""<protected>
"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
<" : <login-config> ( responder -- responder' )
""": <login-config> ( responder -- responder' )
"Factor website" <login-realm>
"Factor website" >>name
allow-registration
allow-password-recovery
allow-edit-profile
allow-deactivation ;">
allow-deactivation ;"""
} ;
ARTICLE: "furnace.auth" "Furnace authentication"

18
basis/grouping/grouping-docs.factor
View File

@ -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 <groups> }
{ $subsection <sliced-groups> }
{ $subsections groups <groups> <sliced-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 <clumps> }
{ $subsection <sliced-clumps> }
{ $subsections clumps <clumps> <sliced-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"

10
basis/help/cookbook/cookbook.factor
View File

@ -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:"

2
basis/help/crossref/crossref.factor
View File

@ -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 ;

25
basis/help/help-docs.factor
View File

@ -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

2
basis/help/help.factor
View File

@ -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

92
basis/help/markup/markup.factor
View File

@ -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 ;

18
basis/help/vocabs/vocabs.factor
View File

@ -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 ;

3
basis/html/html.factor
View File

@ -22,3 +22,6 @@ IN: html
: simple-link ( xml url -- xml' )
url-encode swap [XML <a href=<->><-></a> XML] ;
: simple-image ( url -- xml )
url-encode [XML <img src=<-> /> XML] ;

10
basis/html/streams/streams-tests.factor
View File

@ -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
[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test
[ "<img src=\"/icons/class-word.tiff\"/>" ] [
[
"text"
{ { image "vocab:definitions/icons/class-word.tiff" } }
format
] make-html-string
] unit-test

23
basis/html/streams/streams.factor
View File

@ -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 ;

8
basis/html/templates/fhtml/fhtml-tests.factor
View File

@ -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

6
basis/http/server/cgi/cgi-docs.factor
View File

@ -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
<" <dispatcher>
"/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder" ">
"""<dispatcher>
"/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder"""
}
}
{ $side-effects "responder" } ;

21
basis/http/server/dispatchers/dispatchers-docs.factor
View File

@ -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
<" <dispatcher>
"""<dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" 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
<" <dispatcher>
"""<dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<view-action> >>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 )
golf-courses new-dispatcher ;
@ -63,15 +62,15 @@ main-responder set-global">
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" 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
<" <vhost-dispatcher>
"""<vhost-dispatcher>
<casino> "concatenative-casino.com" add-responder
<dating> "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 "<casino>" } " responder instead of receiving a 404." ;

2
basis/inspector/inspector-tests.factor
View File

@ -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

20
basis/json/reader/reader-tests.factor
View File

@ -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

8
basis/json/writer/writer-tests.factor
View File

@ -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
[ { 0.5 } ] [ { 1/2 } >json json> ] unit-test

20
basis/literals/literals-docs.factor
View File

@ -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: ${ }

6
basis/math/blas/config/config-docs.factor
View File

@ -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."
;

18
basis/math/blas/matrices/matrices-docs.factor
View File

@ -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: <empty-vector>
{ $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." } ;
{

6
basis/math/combinatorics/combinatorics-docs.factor
View File

@ -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 -- )" } } }

4
basis/math/floats/env/x86/x86.factor vendored
View File

@ -31,9 +31,7 @@ M: x87-env (set-fp-env-register)
set_x87_env ;
M: x86 (fp-env-registers)
sse-version 20 >=
[ <sse-env> <x87-env> 2array ]
[ <x87-env> 1array ] if ;
sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
CONSTANT: sse-exception-flag-bits HEX: 3f
CONSTANT: sse-exception-flag>bit

120
basis/math/functions/functions-docs.factor
View File

@ -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"

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

@ -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

4
basis/math/functions/functions.factor
View File

@ -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 ;

2
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -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 ;

70
basis/math/vectors/simd/alien/alien-tests.factor
View File

@ -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 <byte-array>
[
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 <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 <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 <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

42
basis/math/vectors/simd/alien/alien.factor
View File

@ -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 -- )
<c-type>
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 -- )
<c-type>
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

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

@ -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" } <effect> ;
: 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 -- )
<c-type>
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
<PRIVATE
@ -66,31 +175,62 @@ INSTANCE: A sequence
: A-vv->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 -- )
<c-type>
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

18
basis/math/vectors/simd/intrinsics/intrinsics-tests.factor Normal file
View File

@ -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

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

@ -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 <effect> ;
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 <displaced-alien> 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? ;

200
basis/math/vectors/simd/simd-docs.factor
View File

@ -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 <tuple-boa> } " 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"

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

@ -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 <array> 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 <byte-array>
[
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 <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 <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 <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

200
basis/math/vectors/simd/simd.factor
View File

@ -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 ;
<PRIVATE
! Filter out operations that are not available, eg horizontal adds
! on SSE2. Fallback code in math.vectors is used in that case.
: simd-vocab ( base-type -- vocab )
"math.vectors.simd.instances." prepend ;
: supported-simd-ops ( assoc -- assoc' )
: parse-base-type ( string -- c-type )
{
{ v+ (simd-v+) }
{ v- (simd-v-) }
{ v* (simd-v*) }
{ v/ (simd-v/) }
{ vmin (simd-vmin) }
{ vmax (simd-vmax) }
{ sum (simd-sum) }
} [ nip "intrinsic" word-prop ] assoc-filter
'[ drop _ key? ] assoc-filter ;
! Some SIMD operations are defined in terms of others.
:: high-level-ops ( ctor -- assoc )
{
{ vneg [ [ dup v- ] keep v- ] }
{ v. [ v* sum ] }
{ 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 ] }
{ distance [ v- norm ] }
} ;
:: simd-vector-words ( class ctor elt-type assoc -- )
class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union
specialize-vector-words ;
{ "char" [ c:char ] }
{ "uchar" [ c:uchar ] }
{ "short" [ c:short ] }
{ "ushort" [ c:ushort ] }
{ "int" [ c:int ] }
{ "uint" [ c:uint ] }
{ "longlong" [ c:longlong ] }
{ "ulonglong" [ c:ulonglong ] }
{ "float" [ c:float ] }
{ "double" [ c:double ] }
[ bad-base-type ]
} case ;
PRIVATE>
\ 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 ;

1
basis/math/vectors/simd/summary.txt Normal file
View File

@ -0,0 +1 @@
Single-instruction-multiple-data parallel vector operations

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

@ -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? ;

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

@ -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

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

@ -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
[ 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

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

@ -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 ;
<PRIVATE
: 2saturate-map ( u v quot -- w )
pick element-type '[ @ _ c-type-clamp ] 2map ; inline
PRIVATE>
: 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 ;
<PRIVATE
: fp-bitwise-op ( x y seq quot -- z )
swap element-type {
{ c:double [ [ [ double>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 ;

9
basis/multiline/multiline-docs.factor
View File

@ -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:"

11
basis/multiline/multiline-tests.factor
View File

@ -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:

12
basis/multiline/multiline.factor
View File

@ -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:

6
basis/opengl/capabilities/capabilities-docs.factor
View File

@ -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?

7
basis/opengl/debug/debug-docs.factor
View File

@ -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." } ;

4
basis/peg/ebnf/ebnf-tests.factor
View File

@ -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

1
basis/prettyprint/backend/backend.factor
View File

@ -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* ;

5
basis/prettyprint/stylesheet/stylesheet.factor
View File

@ -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 <rgba> colored-presentation-style
{ { font-style plain } } assoc-union ;

Some files were not shown because too many files have changed in this diff Show More