Merge branch 'master' of git://factorcode.org/git/factor
commit
2b1b54d907
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
[ {
|
||||
|
|
|
@ -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) ]
|
||||
|
|
|
@ -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 }"
|
||||
}
|
||||
} ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- ) ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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?
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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)
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 -- )
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ] [
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ] [
|
||||
|
|
|
@ -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
|
||||
|
||||
[ ] [
|
||||
|
|
|
@ -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 ] [
|
||||
|
|
|
@ -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 ] [
|
||||
|
|
|
@ -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 ] [
|
||||
|
|
|
@ -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 ] [
|
||||
|
|
|
@ -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
|
||||
|
||||
[
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ? )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -322,4 +322,4 @@ os windows? [
|
|||
4 "double" c-type (>>align)
|
||||
] unless
|
||||
|
||||
"cpu.x86.features" require
|
||||
check-sse
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Joe Groff
|
|
@ -0,0 +1 @@
|
|||
x86 registers and memory operands
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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? ( -- ? )
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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" ;
|
||||
|
||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;"""
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
@ -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 ;"""
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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:"
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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] ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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" } ;
|
||||
|
|
|
@ -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." ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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: ${ }
|
||||
|
|
|
@ -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."
|
||||
;
|
||||
|
||||
|
|
|
@ -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." } ;
|
||||
|
||||
{
|
||||
|
|
|
@ -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 -- )" } } }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
@ -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? ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Single-instruction-multiple-data parallel vector operations
|
|
@ -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? ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
|
@ -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:"
|
||||
|
|
|
@ -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:
|
||||
|
|
|
@ -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:
|
||||
|
|
|
@ -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?
|
||||
|
|
|
@ -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." } ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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
Loading…
Reference in New Issue