diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 390477dcac..8b5a526e82 100755 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -13,8 +13,7 @@ HELP: heap-size { $values { "type" string } { "size" math:integer } } { $description "Outputs the number of bytes needed for a heap-allocated value of this C type." } { $examples - "On a 32-bit system, you will get the following output:" - { $unchecked-example "USE: alien\n\"void*\" heap-size ." "4" } + { $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" } } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 1ad4f75a3c..9aea6fe252 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -53,7 +53,7 @@ ERROR: no-c-type name ; PREDICATE: c-type-word < word "c-type" word-prop ; -UNION: c-type-name string c-type-word ; +UNION: c-type-name string word ; ! C type protocol GENERIC: c-type ( name -- type ) foldable @@ -479,6 +479,8 @@ 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 ; diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 1faa64be61..cb46f2d67a 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -25,7 +25,7 @@ STRUCT: T-class { real N } { imaginary N } ; T-class c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot -number >>boxed-class +complex >>boxed-class drop ;FUNCTOR diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index cb8b2de543..680ce42259 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -190,7 +190,7 @@ M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; -M: ##vm-field-ptr insn-slot# fieldname>> 1array ; ! is this right? +M: ##vm-field-ptr insn-slot# field-name>> ; ! is this right? M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 874093ed40..8f0a5d5402 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -380,6 +380,27 @@ def: dst use: src1 src2 literal: rep ; +PURE-INSN: ##shl-vector +def: dst +use: src1 src2/scalar-rep +literal: rep ; + +PURE-INSN: ##shr-vector +def: dst +use: src1 src2/scalar-rep +literal: rep ; + +! Scalar/integer conversion +PURE-INSN: ##scalar>integer +def: dst/int-rep +use: src +literal: rep ; + +PURE-INSN: ##integer>scalar +def: dst +use: src/int-rep +literal: rep ; + ! Boxing and unboxing aliens PURE-INSN: ##box-alien def: dst/int-rep @@ -492,7 +513,7 @@ literal: symbol library ; INSN: ##vm-field-ptr def: dst/int-rep -literal: fieldname ; +literal: field-name ; ! FFI INSN: ##alien-invoke diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index d2f158f06d..056e2471ef 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -169,6 +169,8 @@ IN: compiler.cfg.intrinsics { 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-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] } + { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-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 ] } diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor index 389b78c333..4444290f05 100644 --- a/basis/compiler/cfg/representations/preferred/preferred.factor +++ b/basis/compiler/cfg/representations/preferred/preferred.factor @@ -3,8 +3,8 @@ USING: kernel accessors sequences arrays fry namespaces generic words sets combinators generalizations cpu.architecture compiler.units compiler.cfg.utilities compiler.cfg compiler.cfg.rpo -compiler.cfg.instructions compiler.cfg.instructions.syntax -compiler.cfg.def-use ; +compiler.cfg.instructions compiler.cfg.def-use ; +FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ; IN: compiler.cfg.representations.preferred GENERIC: defs-vreg-rep ( insn -- rep/f ) diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor index ec2856f647..d9c2eab6c3 100644 --- a/basis/compiler/cfg/representations/representations.factor +++ b/basis/compiler/cfg/representations/representations.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry accessors sequences assocs sets namespaces -arrays combinators make locals deques dlists +arrays combinators make locals deques dlists layouts cpu.architecture compiler.utilities compiler.cfg compiler.cfg.rpo @@ -22,19 +22,18 @@ ERROR: bad-conversion dst src dst-rep src-rep ; GENERIC: emit-box ( dst src rep -- ) GENERIC: emit-unbox ( dst src rep -- ) -M: float-rep emit-box - drop - [ double-rep next-vreg-rep dup ] dip ##single>double-float - int-rep next-vreg-rep ##box-float ; +M:: float-rep emit-box ( dst src rep -- ) + double-rep next-vreg-rep :> temp + temp src ##single>double-float + dst temp int-rep next-vreg-rep ##box-float ; -M: float-rep emit-unbox - drop - [ double-rep next-vreg-rep dup ] dip ##unbox-float - ##double>single-float ; +M:: float-rep emit-unbox ( dst src rep -- ) + double-rep next-vreg-rep :> temp + temp src ##unbox-float + dst temp ##double>single-float ; M: double-rep emit-box - drop - int-rep next-vreg-rep ##box-float ; + drop int-rep next-vreg-rep ##box-float ; M: double-rep emit-unbox drop ##unbox-float ; @@ -45,6 +44,16 @@ M: vector-rep emit-box M: vector-rep emit-unbox ##unbox-vector ; +M:: scalar-rep emit-box ( dst src rep -- ) + int-rep next-vreg-rep :> temp + temp src rep ##scalar>integer + dst temp tag-bits get ##shl-imm ; + +M:: scalar-rep emit-unbox ( dst src rep -- ) + int-rep next-vreg-rep :> temp + temp src tag-bits get ##sar-imm + dst temp rep ##integer>scalar ; + : emit-conversion ( dst src dst-rep src-rep -- ) { { [ 2dup eq? ] [ drop ##copy ] } diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index 45d248f8f4..4434e0b7b8 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -58,7 +58,9 @@ UNION: two-operand-insn ##max-vector ##and-vector ##or-vector - ##xor-vector ; + ##xor-vector + ##shl-vector + ##shr-vector ; GENERIC: convert-two-operand* ( insn -- ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 43d11b5d4f..150e65db3f 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -184,6 +184,10 @@ CODEGEN: ##abs-vector %abs-vector CODEGEN: ##and-vector %and-vector CODEGEN: ##or-vector %or-vector CODEGEN: ##xor-vector %xor-vector +CODEGEN: ##shl-vector %shl-vector +CODEGEN: ##shr-vector %shr-vector +CODEGEN: ##integer>scalar %integer>scalar +CODEGEN: ##scalar>integer %scalar>integer CODEGEN: ##box-alien %box-alien CODEGEN: ##box-displaced-alien %box-displaced-alien CODEGEN: ##unbox-alien %unbox-alien @@ -212,6 +216,7 @@ CODEGEN: ##compare-imm %compare-imm CODEGEN: ##compare-float-ordered %compare-float-ordered CODEGEN: ##compare-float-unordered %compare-float-unordered CODEGEN: ##save-context %save-context +CODEGEN: ##vm-field-ptr %vm-field-ptr CODEGEN: _fixnum-add %fixnum-add CODEGEN: _fixnum-sub %fixnum-sub @@ -278,9 +283,6 @@ M: ##alien-global generate-insn [ dst>> ] [ symbol>> ] [ library>> ] tri %alien-global ; -M: ##vm-field-ptr generate-insn - [ dst>> ] [ fieldname>> ] bi %vm-field-ptr ; - ! ##alien-invoke GENERIC: next-fastcall-param ( rep -- ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index b436b21329..79016585f6 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays system sorting math.libm -math.intervals quotations effects alien ; +math.intervals quotations effects alien alien.data ; FROM: math => float ; SPECIALIZED-ARRAY: double IN: compiler.tree.propagation.tests @@ -894,3 +894,6 @@ M: tuple-with-read-only-slot clone [ t ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test [ f ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test [ f ] [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test + +! We want this to inline +[ t ] [ [ void* ] { } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/simd/simd.factor b/basis/compiler/tree/propagation/simd/simd.factor index fadb382398..6a619b298e 100644 --- a/basis/compiler/tree/propagation/simd/simd.factor +++ b/basis/compiler/tree/propagation/simd/simd.factor @@ -19,6 +19,8 @@ IN: compiler.tree.propagation.simd (simd-vbitand) (simd-vbitor) (simd-vbitxor) + (simd-vlshift) + (simd-vrshift) (simd-broadcast) (simd-gather-2) (simd-gather-4) @@ -30,7 +32,7 @@ IN: compiler.tree.propagation.simd literal>> scalar-rep-of { { float-rep [ float ] } { double-rep [ float ] } - { int-rep [ integer ] } + [ integer ] } case ] [ drop real ] if diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 2dbe724f0a..3c5abf668a 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -27,7 +27,20 @@ uchar-16-rep short-8-rep ushort-8-rep int-4-rep -uint-4-rep ; +uint-4-rep +longlong-2-rep +ulonglong-2-rep ; + +! Scalar values in the high component of a vector register +SINGLETONS: +char-scalar-rep +uchar-scalar-rep +short-scalar-rep +ushort-scalar-rep +int-scalar-rep +uint-scalar-rep +longlong-scalar-rep +ulonglong-scalar-rep ; SINGLETONS: float-4-rep @@ -39,7 +52,19 @@ uchar-16-rep short-8-rep ushort-8-rep int-4-rep -uint-4-rep ; +uint-4-rep +longlong-2-rep +ulonglong-2-rep ; + +UNION: scalar-rep +char-scalar-rep +uchar-scalar-rep +short-scalar-rep +ushort-scalar-rep +int-scalar-rep +uint-scalar-rep +longlong-scalar-rep +ulonglong-scalar-rep ; UNION: float-vector-rep float-4-rep @@ -55,7 +80,8 @@ tagged-rep int-rep float-rep double-rep -vector-rep ; +vector-rep +scalar-rep ; ! Register classes SINGLETONS: int-regs float-regs ; @@ -66,13 +92,18 @@ CONSTANT: reg-classes { int-regs float-regs } ! A pseudo-register class for parameters spilled on the stack SINGLETON: stack-params +! On x86, vectors and floats are stored in the same register bank +! On PowerPC they are distinct +HOOK: vector-regs cpu ( -- reg-class ) + GENERIC: reg-class-of ( rep -- reg-class ) M: tagged-rep reg-class-of drop int-regs ; M: int-rep reg-class-of drop int-regs ; M: float-rep reg-class-of drop float-regs ; M: double-rep reg-class-of drop float-regs ; -M: vector-rep reg-class-of drop float-regs ; +M: vector-rep reg-class-of drop vector-regs ; +M: scalar-rep reg-class-of drop vector-regs ; M: stack-params reg-class-of drop stack-params ; GENERIC: rep-size ( rep -- n ) foldable @@ -92,7 +123,14 @@ 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 ; +M: char-16-rep scalar-rep-of drop char-scalar-rep ; +M: uchar-16-rep scalar-rep-of drop uchar-scalar-rep ; +M: short-8-rep scalar-rep-of drop short-scalar-rep ; +M: ushort-8-rep scalar-rep-of drop ushort-scalar-rep ; +M: int-4-rep scalar-rep-of drop int-scalar-rep ; +M: uint-4-rep scalar-rep-of drop uint-scalar-rep ; +M: longlong-2-rep scalar-rep-of drop longlong-scalar-rep ; +M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ; ! Mapping from register class to machine registers HOOK: machine-registers cpu ( -- assoc ) @@ -196,6 +234,11 @@ 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: %shl-vector cpu ( dst src1 src2 rep -- ) +HOOK: %shr-vector cpu ( dst src1 src2 rep -- ) + +HOOK: %integer>scalar cpu ( dst src rep -- ) +HOOK: %scalar>integer cpu ( dst src rep -- ) HOOK: %broadcast-vector-reps cpu ( -- reps ) HOOK: %gather-vector-2-reps cpu ( -- reps ) @@ -216,6 +259,8 @@ 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: %shl-vector-reps cpu ( -- reps ) +HOOK: %shr-vector-reps cpu ( -- reps ) HOOK: %unbox-alien cpu ( dst src -- ) HOOK: %unbox-any-c-ptr cpu ( dst src temp -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index eb9709a350..f67c73e2e9 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -284,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 ; @@ -299,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 @@ -313,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: ppc %broadcast-vector-reps { } ; +M: ppc %gather-vector-2-reps { } ; +M: ppc %gather-vector-4-reps { } ; +M: ppc %add-vector-reps { } ; +M: ppc %saturated-add-vector-reps { } ; +M: ppc %add-sub-vector-reps { } ; +M: ppc %sub-vector-reps { } ; +M: ppc %saturated-sub-vector-reps { } ; +M: ppc %mul-vector-reps { } ; +M: ppc %saturated-mul-vector-reps { } ; +M: ppc %div-vector-reps { } ; +M: ppc %min-vector-reps { } ; +M: ppc %max-vector-reps { } ; +M: ppc %sqrt-vector-reps { } ; +M: ppc %horizontal-add-vector-reps { } ; +M: ppc %abs-vector-reps { } ; +M: ppc %and-vector-reps { } ; +M: ppc %or-vector-reps { } ; +M: ppc %xor-vector-reps { } ; M: ppc %unbox-alien ( dst src -- ) alien-offset LWZ ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index e2096987da..0540ccd6d6 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -11,7 +11,7 @@ IN: bootstrap.x86 : shift-arg ( -- reg ) ECX ; : div-arg ( -- reg ) EAX ; : mod-arg ( -- reg ) EDX ; -: arg ( -- reg ) EAX ; +: arg1 ( -- reg ) EAX ; : arg2 ( -- reg ) EDX ; : temp0 ( -- reg ) EAX ; : temp1 ( -- reg ) EDX ; @@ -29,7 +29,7 @@ IN: bootstrap.x86 ! save stack pointer temp0 [] stack-reg MOV ! pass vm ptr to primitive - arg 0 MOV rc-absolute-cell rt-vm jit-rel + arg1 0 MOV rc-absolute-cell rt-vm jit-rel ! call the primitive 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index af13546657..c33368fc91 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -58,9 +58,9 @@ M: stack-params copy-register* { [ over integer? ] [ R11 swap MOV param@ R11 MOV ] } } cond ; -M: x86 %save-param-reg [ param@ ] 2dip copy-register ; +M: x86 %save-param-reg [ param@ ] 2dip %copy ; -M: x86 %load-param-reg [ swap param@ ] dip copy-register ; +M: x86 %load-param-reg [ swap param@ ] dip %copy ; : with-return-regs ( quot -- ) [ @@ -133,9 +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 ; M:: x86.64 %box ( n rep func -- ) n [ @@ -222,7 +220,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 diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index aa7a5dcd67..bffe056656 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -21,7 +21,6 @@ IN: bootstrap.x86 : rex-length ( -- n ) 1 ; [ - ! load stack_chain temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel temp0 temp0 [] MOV @@ -30,7 +29,7 @@ IN: bootstrap.x86 ! load XT temp1 0 MOV rc-absolute-cell rt-primitive jit-rel ! load vm ptr - arg 0 MOV rc-absolute-cell rt-vm jit-rel + arg1 0 MOV rc-absolute-cell rt-vm jit-rel ! go temp1 JMP ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index 199fe8daf4..2ad3a721af 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -5,7 +5,7 @@ cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 4 bootstrap-cells ; -: arg ( -- reg ) RDI ; +: arg1 ( -- reg ) RDI ; : arg2 ( -- reg ) RSI ; << "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 72b9d27ca4..2dd3e889a5 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -6,7 +6,7 @@ cpu.x86.assembler.operands ; IN: bootstrap.x86 : stack-frame-size ( -- n ) 8 bootstrap-cells ; -: arg ( -- reg ) RCX ; +: arg1 ( -- reg ) RCX ; : arg2 ( -- reg ) RDX ; << "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index ead1c8a695..ceb9c54e6e 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -198,12 +198,16 @@ M: register POP f HEX: 58 short-operand ; M: operand POP { BIN: 000 f HEX: 8f } 1-operand ; ! MOV where the src is immediate. + + GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; M: operand MOV HEX: 88 2-operand ; @@ -219,9 +223,13 @@ GENERIC: CALL ( op -- ) M: integer CALL HEX: e8 , 4, ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; + + : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; : JB ( dst -- ) HEX: 82 JUMPcc ; @@ -296,6 +304,8 @@ M: operand TEST OCT: 204 2-operand ; : CDQ ( -- ) HEX: 99 , ; : CQO ( -- ) HEX: 48 , CDQ ; + + : ROL ( dst n -- ) BIN: 000 (SHIFT) ; : ROR ( dst n -- ) BIN: 001 (SHIFT) ; : RCL ( dst n -- ) BIN: 010 (SHIFT) ; diff --git a/basis/cpu/x86/assembler/operands/authors.txt b/basis/cpu/x86/assembler/operands/authors.txt new file mode 100644 index 0000000000..580f882c8d --- /dev/null +++ b/basis/cpu/x86/assembler/operands/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Joe Groff diff --git a/basis/cpu/x86/assembler/operands/summary.txt b/basis/cpu/x86/assembler/operands/summary.txt new file mode 100644 index 0000000000..474b715848 --- /dev/null +++ b/basis/cpu/x86/assembler/operands/summary.txt @@ -0,0 +1 @@ +x86 registers and memory operands diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 5bc5272ab4..3cc71d22f7 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -248,13 +248,13 @@ big-endian off ! Quotations and words [ ! load from stack - arg ds-reg [] MOV + arg1 ds-reg [] MOV ! pop stack ds-reg bootstrap-cell SUB ! pass vm pointer arg2 0 MOV rc-absolute-cell rt-vm jit-rel ! call quotation - arg quot-xt-offset [+] JMP + arg1 quot-xt-offset [+] JMP ] \ (call) define-sub-primitive ! Objects diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 1a96e93c63..8585dfa697 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -2,10 +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 byte-arrays io macros quotations cpu.x86.features -cpu.x86.features.private compiler compiler.units init vm +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 @@ -22,6 +22,8 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; M: x86 two-operand? t ; +M: x86 vector-regs float-regs ; + HOOK: stack-reg cpu ( -- reg ) HOOK: reserved-area-size cpu ( -- n ) @@ -140,11 +142,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 @@ -243,11 +243,11 @@ 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 @@ -259,14 +259,15 @@ MACRO: available-reps ( alist -- ) 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 } } + ! Can't do this with sse1 since it will want to unbox + ! a double-precision float and convert to single precision + { sse2? { float-4-rep double-2-rep } } } available-reps ; M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- ) @@ -274,7 +275,7 @@ M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- ) { float-4-rep [ - dst src1 MOVSS + dst src1 float-4-rep %copy dst src2 UNPCKLPS src3 src4 UNPCKLPS dst src3 MOVLHPS @@ -284,7 +285,9 @@ M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- ) M: x86 %gather-vector-4-reps { - { sse? { float-4-rep } } + ! Can't do this with sse1 since it will want to unbox + ! double-precision floats and convert to single precision + { sse2? { float-4-rep } } } available-reps ; M:: x86 %gather-vector-2 ( dst src1 src2 rep -- ) @@ -292,7 +295,7 @@ M:: x86 %gather-vector-2 ( dst src1 src2 rep -- ) { double-2-rep [ - dst src1 MOVSD + dst src1 double-2-rep %copy dst src2 UNPCKLPD ] } @@ -313,12 +316,14 @@ 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 } } + { 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 -- ) @@ -355,12 +360,14 @@ 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 } } + { 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 -- ) @@ -389,7 +396,8 @@ M: x86 %mul-vector ( dst src1 src2 rep -- ) M: x86 %mul-vector-reps { { sse? { float-4-rep } } - { sse2? { double-2-rep short-8-rep ushort-8-rep int-4-rep uint-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 @@ -448,8 +456,8 @@ M: x86 %max-vector-reps M: x86 %horizontal-add-vector ( dst src rep -- ) { - { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] } - { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] } + { 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 @@ -485,56 +493,74 @@ M: x86 %and-vector ( dst src1 src2 rep -- ) { { float-4-rep [ ANDPS ] } { double-2-rep [ ANDPD ] } - { char-16-rep [ PAND ] } - { uchar-16-rep [ PAND ] } - { short-8-rep [ PAND ] } - { ushort-8-rep [ PAND ] } - { int-4-rep [ PAND ] } - { uint-4-rep [ PAND ] } + [ 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 } } + { 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 ] } - { char-16-rep [ POR ] } - { uchar-16-rep [ POR ] } - { short-8-rep [ POR ] } - { ushort-8-rep [ POR ] } - { int-4-rep [ POR ] } - { uint-4-rep [ POR ] } + [ 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 } } + { 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 ] } - { char-16-rep [ PXOR ] } - { uchar-16-rep [ PXOR ] } - { short-8-rep [ PXOR ] } - { ushort-8-rep [ PXOR ] } - { int-4-rep [ PXOR ] } - { uint-4-rep [ PXOR ] } + [ 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 } } + { 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 %shl-vector ( dst src1 src2 rep -- ) + { + { short-8-rep [ PSLLW ] } + { ushort-8-rep [ PSLLW ] } + { int-4-rep [ PSLLD ] } + { uint-4-rep [ PSLLD ] } + { longlong-2-rep [ PSLLQ ] } + { ulonglong-2-rep [ PSLLQ ] } + } case drop ; + +M: x86 %shl-vector-reps + { + { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %shr-vector ( dst src1 src2 rep -- ) + { + { short-8-rep [ PSRAW ] } + { ushort-8-rep [ PSRLW ] } + { int-4-rep [ PSRAD ] } + { uint-4-rep [ PSRLD ] } + { ulonglong-2-rep [ PSRLQ ] } + } case drop ; + +M: x86 %shr-vector-reps + { + { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } } + } available-reps ; + +M: x86 %integer>scalar drop MOVD ; + +M: x86 %scalar>integer drop MOVD ; + M: x86 %unbox-alien ( dst src -- ) alien-offset [+] MOV ; @@ -648,9 +674,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. @@ -678,12 +701,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 ; @@ -692,7 +715,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 -- ) @@ -712,11 +735,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 @@ -726,7 +749,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? ; @@ -931,10 +954,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 ; diff --git a/basis/definitions/icons/icons.factor b/basis/definitions/icons/icons.factor index 3c4dad5be7..63ea2d6093 100644 --- a/basis/definitions/icons/icons.factor +++ b/basis/definitions/icons/icons.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs classes.predicate fry generic io.pathnames kernel -macros sequences vocabs words words.symbol words.constant -lexer parser help.topics help.markup namespaces sorting ; +USING: assocs classes.predicate fry generic help.topics +io.pathnames kernel lexer macros namespaces parser sequences +vocabs words words.constant words.symbol ; IN: definitions.icons GENERIC: definition-icon ( definition -- path ) @@ -41,10 +41,3 @@ ICON: topic help-article ICON: runnable-vocab runnable-vocab ICON: vocab open-vocab ICON: vocab-link unopen-vocab - -: $definition-icons ( element -- ) - drop - icons get >alist sort-keys - [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map - { "" "Definition class" } prefix - $table ; \ No newline at end of file diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index 07250058ae..d64745b834 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -3,17 +3,13 @@ IN: grouping ARTICLE: "grouping" "Groups and clumps" "Splitting a sequence into disjoint, fixed-length subsequences:" -{ $subsection group } +{ $subsections group } "A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:" -{ $subsection groups } -{ $subsection } -{ $subsection } +{ $subsections groups } "Splitting a sequence into overlapping, fixed-length subsequences:" -{ $subsection clump } +{ $subsections clump } "A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:" -{ $subsection clumps } -{ $subsection } -{ $subsection } +{ $subsections clumps } "The difference can be summarized as the following:" { $list { "With groups, the subsequences form the original sequence when concatenated:" @@ -29,11 +25,11 @@ ARTICLE: "grouping" "Groups and clumps" } } } +$nl "A combinator built using clumps:" -{ $subsection monotonic? } +{ $subsections monotonic? } "Testing how elements are related:" -{ $subsection all-eq? } -{ $subsection all-equal? } ; +{ $subsections all-eq? all-equal? } ; ABOUT: "grouping" diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor index 46f9561605..5e4922c7ad 100644 --- a/basis/help/crossref/crossref.factor +++ b/basis/help/crossref/crossref.factor @@ -10,7 +10,7 @@ IN: help.crossref collect-elements [ >link ] map ; : article-children ( topic -- seq ) - { $subsection } article-links ; + { $subsection $subsections } article-links ; : help-path ( topic -- seq ) [ article-parent ] follow rest ; diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index be521eb93a..32d60851bd 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -148,9 +148,30 @@ HELP: :help HELP: $subsection { $values { "element" "a markup element of the form " { $snippet "{ topic }" } } } -{ $description "Prints a large clickable link to the help topic named by the first string element of " { $snippet "element" } "." } +{ $description "Prints a large clickable link to the help topic named by the first item in " { $snippet "element" } ". The link is printed along with its associated definition icon." } { $examples - { $code "{ $subsection \"sequences\" }" } + { $markup-example { $subsection "sequences" } } + { $markup-example { $subsection nth } } + { $markup-example { $subsection each } } +} ; + +HELP: $subsections +{ $values { "children" "a " { $link sequence } " of one or more " { $link topic } "s or, in the case of a help article, the article's string name." } } +{ $description "Prints a large clickable link for each of the listed help topics in " { $snippet "children" } ". The link is printed along with its associated definition icon." } +{ $examples + { $markup-example { $subsections "sequences" nth each } } +} ; + +{ $subsection $subsections $link } related-words + +HELP: $vocab-subsection +{ $values { "element" "a markup element of the form " { $snippet "{ title vocab }" } } } +{ $description "Prints a large clickable link for " { $snippet "vocab" } ". If " { $snippet "vocab" } " has a main help article, the link will point at that article and the " { $snippet "title" } " input will be ignored. Otherwise, the link text will be taken from " { $snippet "title" } " and point to " { $snippet "vocab" } "'s automatically generated documentation." +$nl +"The link will be printed along with its associated definition icon." } +{ $examples + { $markup-example { $vocab-subsection "SQLite" "db.sqlite" } } + { $markup-example { $vocab-subsection "Alien" "alien" } } } ; HELP: $index diff --git a/basis/help/help.factor b/basis/help/help.factor index e31c705e26..8f8ad35bf4 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -125,7 +125,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; : print-topic ( topic -- ) >link last-element off - [ $title ] [ article-content print-content nl ] bi ; + [ $title ] [ nl article-content print-content nl ] bi ; SYMBOL: help-hook diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index c64f315d6d..0201e86b3f 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays definitions generic io kernel assocs -hashtables namespaces make parser prettyprint sequences strings -io.styles vectors words math sorting splitting classes slots fry -sets vocabs help.stylesheet help.topics vocabs.loader quotations -combinators see present ; +USING: accessors arrays assocs classes colors.constants +combinators definitions definitions.icons effects fry generic +hashtables help.stylesheet help.topics io io.styles kernel make +math namespaces parser present prettyprint +prettyprint.stylesheet quotations see sequences sets slots +sorting splitting strings vectors vocabs vocabs.loader words ; FROM: prettyprint.sections => with-pprint ; IN: help.markup @@ -70,7 +71,7 @@ ALIAS: $slot $snippet ] ($span) ; : $nl ( children -- ) - nl nl drop ; + nl last-block? [ nl ] unless drop ; ! Some blocks : ($heading) ( children quot -- ) @@ -156,45 +157,73 @@ ALIAS: $slot $snippet : write-link ( string object -- ) link-style get [ write-object ] with-style ; -: ($link) ( article -- ) - [ [ article-name ] [ >link ] bi write-link ] ($span) ; +: link-icon ( topic -- ) + definition-icon 1array $image ; -: $link ( element -- ) - first ($link) ; - -: ($definition-link) ( word -- ) +: link-text ( topic -- ) [ article-name ] keep write-link ; -: $definition-link ( element -- ) - first ($definition-link) ; +: link-effect ( topic -- ) + dup word? [ + stack-effect [ effect>string ] [ effect-style ] bi + [ write ] with-style + ] [ drop ] if ; -: ($long-link) ( object -- ) - [ article-title ] [ >link ] bi write-link ; +: inter-cleave ( x seq between -- ) + [ [ call( x -- ) ] with ] dip swap interleave ; inline -: $long-link ( object -- ) - first ($long-link) ; +: (($link)) ( topic words -- ) + [ dup topic? [ >link ] unless ] dip + [ [ bl ] inter-cleave ] ($span) ; inline + +: ($link) ( topic -- ) + { [ link-text ] } (($link)) ; + +: $link ( element -- ) first ($link) ; + +: ($long-link) ( topic -- ) + { [ link-text ] [ link-effect ] } (($link)) ; + +: $long-link ( element -- ) first ($long-link) ; + +: ($pretty-link) ( topic -- ) + { [ link-icon ] [ link-text ] } (($link)) ; + +: $pretty-link ( element -- ) first ($pretty-link) ; + +: ($long-pretty-link) ( topic -- ) + { [ link-icon ] [ link-text ] [ link-effect ] } (($link)) ; + +: $long-pretty-link ( element -- ) first ($long-pretty-link) ; + +: <$pretty-link> ( definition -- element ) + 1array \ $pretty-link prefix ; : ($subsection) ( element quot -- ) [ - subsection-style get [ - bullet get write bl - call - ] with-style + subsection-style get [ call ] with-style ] ($block) ; inline +: $subsection* ( topic -- ) + [ + [ ($long-pretty-link) ] with-scope + ] ($subsection) ; + +: $subsections ( children -- ) + [ $subsection* ] each nl ; + : $subsection ( element -- ) - [ first ($long-link) ] ($subsection) ; + first $subsection* ; : ($vocab-link) ( text vocab -- ) >vocab-link write-link ; : $vocab-subsection ( element -- ) [ - first2 dup vocab-help dup [ - 2nip ($long-link) - ] [ - drop ($vocab-link) - ] if + first2 dup vocab-help + [ 2nip ($long-pretty-link) ] + [ [ >vocab-link link-icon bl ] [ ($vocab-link) ] bi ] + if* ] ($subsection) ; : $vocab-link ( element -- ) @@ -390,3 +419,10 @@ M: array elements* : <$snippet> ( str -- element ) 1array \ $snippet prefix ; + +: $definition-icons ( element -- ) + drop + icons get >alist sort-keys + [ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map + { "" "Definition class" } prefix + $table ; \ No newline at end of file diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index d8f351f57d..0aa17ef676 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -3,25 +3,17 @@ USING: accessors arrays assocs classes classes.builtin classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple classes.union combinators -definitions effects fry generic help help.markup help.stylesheet -help.topics io io.files io.pathnames io.styles kernel macros -make namespaces prettyprint sequences sets sorting summary -vocabs vocabs.files vocabs.hierarchy vocabs.loader -vocabs.metadata words words.symbol definitions.icons ; +effects fry generic help help.markup help.stylesheet +help.topics io io.pathnames io.styles kernel macros make +namespaces sequences sorting summary vocabs vocabs.files +vocabs.hierarchy vocabs.loader vocabs.metadata words +words.symbol ; FROM: vocabs.hierarchy => child-vocabs ; IN: help.vocabs : about ( vocab -- ) [ require ] [ vocab help ] bi ; -: $pretty-link ( element -- ) - [ first definition-icon 1array $image " " print-element ] - [ $definition-link ] - bi ; - -: <$pretty-link> ( definition -- element ) - 1array \ $pretty-link prefix ; - : vocab-row ( vocab -- row ) [ <$pretty-link> ] [ vocab-summary ] bi 2array ; diff --git a/basis/html/html.factor b/basis/html/html.factor index e446c66d8c..12cf3549f4 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -22,3 +22,6 @@ IN: html : simple-link ( xml url -- xml' ) url-encode swap [XML ><-> XML] ; + +: simple-image ( url -- xml ) + url-encode [XML /> XML] ; \ No newline at end of file diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor index 79e8027489..eeac9210c1 100644 --- a/basis/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -61,4 +61,12 @@ M: funky url-of "http://www.funky-town.com/" swap town>> append ; [ H{ } [ ] with-nesting nl ] make-html-string ] unit-test -[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test \ No newline at end of file +[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test + +[ "" ] [ + [ + "text" + { { image "vocab:definitions/icons/class-word.tiff" } } + format + ] make-html-string +] unit-test diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 26a3d5f391..1b3086f665 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel assocs io io.styles math math.order math.parser -sequences strings make words combinators macros xml.syntax html fry -destructors ; +USING: accessors assocs combinators destructors fry html io +io.backend io.pathnames io.styles kernel macros make math +math.order math.parser namespaces sequences strings words +splitting xml xml.syntax ; IN: html.streams GENERIC: url-of ( object -- url ) @@ -87,9 +88,21 @@ MACRO: make-css ( pairs -- str ) : emit-html ( quot stream -- ) dip data>> push ; inline +: image-path ( path -- images-path ) + "vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ; + +: img-tag ( xml style -- xml ) + image swap at [ nip image-path simple-image ] when* ; + : format-html-span ( string style stream -- ) - [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ] - emit-html ; + [ + { + [ span-tag ] + [ href-link-tag ] + [ object-link-tag ] + [ img-tag ] + } cleave + ] emit-html ; TUPLE: html-span-stream < html-sub-stream ; diff --git a/basis/inspector/inspector-tests.factor b/basis/inspector/inspector-tests.factor index 3f3e7f13df..9be32a2240 100644 --- a/basis/inspector/inspector-tests.factor +++ b/basis/inspector/inspector-tests.factor @@ -8,7 +8,7 @@ f describe H{ } describe H{ } describe -[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test +[ "fixnum\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test [ ] [ H{ } clone inspect ] unit-test diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index fb392191d4..11f209fb9c 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -3,103 +3,91 @@ sequences quotations math.functions.private ; IN: math.functions ARTICLE: "integer-functions" "Integer functions" -{ $subsection align } -{ $subsection gcd } -{ $subsection log2 } -{ $subsection next-power-of-2 } +{ $subsections + align + gcd + log2 + next-power-of-2 +} "Modular exponentiation:" -{ $subsection ^mod } -{ $subsection mod-inv } +{ $subsections ^mod mod-inv } "Tests:" -{ $subsection power-of-2? } -{ $subsection even? } -{ $subsection odd? } -{ $subsection divisor? } ; +{ $subsections + power-of-2? + even? + odd? + divisor? +} ; ARTICLE: "arithmetic-functions" "Arithmetic functions" "Computing additive and multiplicative inverses:" -{ $subsection neg } -{ $subsection recip } +{ $subsections neg recip } "Complex conjugation:" -{ $subsection conjugate } +{ $subsections conjugate } "Tests:" -{ $subsection zero? } -{ $subsection between? } +{ $subsections zero? between? } "Control flow:" -{ $subsection if-zero } -{ $subsection when-zero } -{ $subsection unless-zero } +{ $subsections + if-zero + when-zero + unless-zero +} "Sign:" -{ $subsection sgn } +{ $subsections sgn } "Rounding:" -{ $subsection ceiling } -{ $subsection floor } -{ $subsection truncate } -{ $subsection round } +{ $subsections + ceiling + floor + truncate + round +} "Inexact comparison:" -{ $subsection ~ } +{ $subsections ~ } "Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ; ARTICLE: "power-functions" "Powers and logarithms" "Squares:" -{ $subsection sq } -{ $subsection sqrt } +{ $subsections sq sqrt } "Exponential and natural logarithm:" -{ $subsection exp } -{ $subsection cis } -{ $subsection log } +{ $subsections exp cis log } "Other logarithms:" -{ $subsection log1+ } -{ $subsection log10 } +{ $subsection log1+ log10 } "Raising a number to a power:" -{ $subsection ^ } -{ $subsection 10^ } +{ $subsections ^ 10^ } "Converting between rectangular and polar form:" -{ $subsection abs } -{ $subsection absq } -{ $subsection arg } -{ $subsection >polar } -{ $subsection polar> } ; +{ $subsections + abs + absq + arg + >polar + polar> +} ; ARTICLE: "trig-hyp-functions" "Trigonometric and hyperbolic functions" "Trigonometric functions:" -{ $subsection cos } -{ $subsection sin } -{ $subsection tan } +{ $subsections cos sin tan } "Reciprocals:" -{ $subsection sec } -{ $subsection cosec } -{ $subsection cot } +{ $subsections sec cosec cot } "Inverses:" -{ $subsection acos } -{ $subsection asin } -{ $subsection atan } +{ $subsections acos asin atan } "Inverse reciprocals:" -{ $subsection asec } -{ $subsection acosec } -{ $subsection acot } +{ $subsections asec acosec acot } "Hyperbolic functions:" -{ $subsection cosh } -{ $subsection sinh } -{ $subsection tanh } +{ $subsections cosh sinh tanh } "Reciprocals:" -{ $subsection sech } -{ $subsection cosech } -{ $subsection coth } +{ $subsections sech cosech coth } "Inverses:" -{ $subsection acosh } -{ $subsection asinh } -{ $subsection atanh } +{ $subsections acosh asinh atanh } "Inverse reciprocals:" -{ $subsection asech } -{ $subsection acosech } -{ $subsection acoth } ; +{ $subsections asech acosech acoth } ; ARTICLE: "math-functions" "Mathematical functions" -{ $subsection "integer-functions" } -{ $subsection "arithmetic-functions" } -{ $subsection "power-functions" } -{ $subsection "trig-hyp-functions" } ; +{ $subsections + "integer-functions" + "arithmetic-functions" + "power-functions" + "trig-hyp-functions" +} ; ABOUT: "math-functions" diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor index e934a641c4..c76ed573d5 100644 --- a/basis/math/vectors/simd/functor/functor.factor +++ b/basis/math/vectors/simd/functor/functor.factor @@ -78,12 +78,13 @@ ERROR: bad-schema schema ; } append ] when ; -:: simd-vector-words ( class ctor rep vv->v v->v v->n -- ) +:: simd-vector-words ( class ctor rep vv->v vn->v v->v v->n -- ) rep rep-component-type c-type-boxed-class :> elt-class class elt-class { { { +vector+ +vector+ -> +vector+ } vv->v } + { { +vector+ +scalar+ -> +vector+ } vn->v } { { +vector+ -> +vector+ } v->v } { { +vector+ -> +scalar+ } v->n } { { +vector+ -> +nonnegative+ } v->n } @@ -118,6 +119,7 @@ SET-NTH [ T dup c-setter array-accessor ] A-rep [ A name>> "-rep" append "cpu.architecture" lookup ] A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op +A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op A-v->v-op DEFINES-PRIVATE ${A}-v->v-op A-v->n-op DEFINES-PRIVATE ${A}-v->n-op @@ -175,13 +177,16 @@ INSTANCE: A sequence : A-vv->v-op ( v1 v2 quot -- v3 ) [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline +: A-vn->v-op ( v1 v2 quot -- v3 ) + [ [ underlying>> ] dip 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-with \ A-rep \ A-vv->v-op \ A-vn->v-op \ A-v->v-op \ A-v->n-op simd-vector-words \ A \ A-rep define-simd-128-type PRIVATE> @@ -230,6 +235,7 @@ A-deref DEFINES-PRIVATE ${A}-deref A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ] A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op +A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op A-v->v-op DEFINES-PRIVATE ${A}-v->v-op A-v->n-op DEFINES-PRIVATE ${A}-v->n-op @@ -296,6 +302,11 @@ INSTANCE: A sequence [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi \ A boa ; inline +: A-vn->v-op ( v1 v2 quot -- v3 ) + [ [ [ underlying1>> ] dip A-rep ] dip call ] + [ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi + \ A boa ; inline + : A-v->v-op ( v1 combine-quot -- v2 ) [ [ underlying1>> A-rep ] dip call ] [ [ underlying2>> A-rep ] dip call ] 2bi @@ -304,7 +315,7 @@ INSTANCE: A sequence : 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-with \ A-rep \ A-vv->v-op \ A-vn->v-op \ A-v->v-op \ A-v->n-op simd-vector-words \ A \ A-rep define-simd-256-type ;FUNCTOR diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 2c1f76cfe1..6989ac2bc2 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -42,6 +42,8 @@ SIMD-OP: vabs SIMD-OP: vbitand SIMD-OP: vbitor SIMD-OP: vbitxor +SIMD-OP: vlshift +SIMD-OP: vrshift : (simd-broadcast) ( x rep -- v ) bad-simd-call ; : (simd-gather-2) ( a b rep -- v ) bad-simd-call ; @@ -110,6 +112,8 @@ M: vector-rep supported-simd-op? { \ (simd-vbitand) [ %and-vector-reps ] } { \ (simd-vbitor) [ %or-vector-reps ] } { \ (simd-vbitxor) [ %xor-vector-reps ] } + { \ (simd-vlshift) [ %shl-vector-reps ] } + { \ (simd-vrshift) [ %shr-vector-reps ] } { \ (simd-broadcast) [ %broadcast-vector-reps ] } { \ (simd-gather-2) [ %gather-vector-2-reps ] } { \ (simd-gather-4) [ %gather-vector-4-reps ] } diff --git a/basis/math/vectors/simd/simd-docs.factor b/basis/math/vectors/simd/simd-docs.factor index 9b832526d8..2fdb9ff88c 100644 --- a/basis/math/vectors/simd/simd-docs.factor +++ b/basis/math/vectors/simd/simd-docs.factor @@ -52,6 +52,10 @@ $nl "uint-4" "int-8" "uint-8" + "longlong-2" + "ulonglong-2" + "longlong-4" + "ulonglong-4" "float-4" "float-8" "double-2" @@ -92,7 +96,7 @@ SYMBOLS: x y ; { $code """USING: compiler.tree.debugger kernel.private math.vectors math.vectors.simd ; -SIMD: float-4 +SIMD: float IN: simd-demo : interpolate ( v a b -- w ) @@ -106,7 +110,7 @@ $nl { $code """USING: compiler.tree.debugger hints math.vectors math.vectors.simd ; -SIMD: float-4 +SIMD: float IN: simd-demo : interpolate ( v a b -- w ) @@ -122,7 +126,7 @@ $nl "In the " { $snippet "interpolate" } " word, there is still a call to the " { $link } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:" { $code """USING: compiler.tree.debugger math.vectors math.vectors.simd ; -SIMD: float-4 +SIMD: float IN: simd-demo STRUCT: actor @@ -192,8 +196,8 @@ ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)" { $subsection "math.vectors.simd.intrinsics" } ; HELP: SIMD: -{ $syntax "SIMD: type-length" } -{ $values { "type" "a scalar C type" } { "length" "a vector dimension" } } -{ $description "Brings a SIMD array for holding " { $snippet "length" } " values 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" } "." } ; +{ $syntax "SIMD: type" } +{ $values { "type" "a scalar C type" } } +{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ; ABOUT: "math.vectors.simd" diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor index db8597fc9d..535a671359 100644 --- a/basis/math/vectors/simd/simd-tests.factor +++ b/basis/math/vectors/simd/simd-tests.factor @@ -5,35 +5,35 @@ 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 ; +specialized-arrays classes.struct eval ; FROM: alien.c-types => c-type-boxed-class ; SPECIALIZED-ARRAY: float -SIMD: char-16 -SIMD: uchar-16 -SIMD: char-32 -SIMD: uchar-32 -SIMD: short-8 -SIMD: ushort-8 -SIMD: short-16 -SIMD: ushort-16 -SIMD: int-4 -SIMD: uint-4 -SIMD: int-8 -SIMD: uint-8 -SIMD: float-4 -SIMD: float-8 -SIMD: double-2 -SIMD: double-4 +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 -[ 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 +[ V{ float-4 } ] [ [ { float-4 } declare normalize ] final-classes ] unit-test + +[ V{ float-4 } ] [ [ { float-4 float-4 } declare v+ ] final-classes ] unit-test + ! Test puns; only on x86 cpu x86? [ [ double-2{ 4 1024 } ] [ @@ -62,6 +62,10 @@ CONSTANT: simd-classes uint-4 int-8 uint-8 + longlong-2 + ulonglong-2 + longlong-4 + ulonglong-4 float-4 float-8 double-2 @@ -137,9 +141,12 @@ CONSTANT: simd-classes : remove-float-words ( alist -- alist' ) [ drop { vsqrt n/v v/n v/ normalize } member? not ] assoc-filter ; +: remove-integer-words ( alist -- alist' ) + [ drop { vlshift vrshift } member? not ] assoc-filter ; + : ops-to-check ( elt-class -- alist ) [ vector-words >alist ] dip - float = [ remove-float-words ] unless ; + float = [ remove-integer-words ] [ remove-float-words ] if ; : check-vector-ops ( class elt-class compare-quot -- ) [ @@ -164,7 +171,7 @@ CONSTANT: simd-classes simd-classes [ { { [ dup name>> "float" head? ] [ float [ approx= ] ] } - { [ dup name>> "double" tail? ] [ float [ = ] ] } + { [ dup name>> "double" head? ] [ float [ = ] ] } [ fixnum [ = ] ] } cond 3array ] map ; diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index fe043032b8..71936b2657 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -3,30 +3,39 @@ 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 -ERROR: bad-vector-size bits ; +ERROR: bad-base-type type ; number ] bi* - * 8 * { - { 128 [ [ define-simd-128 ] ] } - { 256 [ [ define-simd-256 ] ] } - [ bad-vector-size ] +: parse-base-type ( string -- c-type ) + { + { "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> : define-simd-vocab ( type -- vocab ) - [ simd-vocab ] - [ '[ _ parse-simd-name call( type -- ) ] ] bi - generate-vocab ; + [ simd-vocab ] keep '[ + _ parse-base-type + [ define-simd-128 ] + [ define-simd-256 ] bi + ] generate-vocab ; SYNTAX: SIMD: scan define-simd-vocab use-vocab ; diff --git a/basis/math/vectors/specialization/specialization-tests.factor b/basis/math/vectors/specialization/specialization-tests.factor index f9f241bb6f..649685b898 100644 --- a/basis/math/vectors/specialization/specialization-tests.factor +++ b/basis/math/vectors/specialization/specialization-tests.factor @@ -13,10 +13,14 @@ SPECIALIZED-ARRAY: float [ { float-array float } declare v*n norm ] final-classes ] unit-test -[ V{ number } ] [ +[ V{ complex } ] [ [ { complex-float-array complex-float-array } declare v. ] final-classes ] unit-test -[ V{ real } ] [ +[ V{ float } ] [ + [ { float-array float } declare v*n norm ] final-classes +] unit-test + +[ V{ float } ] [ [ { complex-float-array complex } declare v*n norm ] final-classes ] unit-test \ No newline at end of file diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor index bf2dac29d6..6c8ffd6f61 100644 --- a/basis/math/vectors/specialization/specialization.factor +++ b/basis/math/vectors/specialization/specialization.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types words kernel make sequences effects -kernel.private accessors combinators math math.intervals -math.vectors namespaces assocs fry splitting classes.algebra -generalizations locals compiler.tree.propagation.info ; +USING: words kernel make sequences effects sets kernel.private +accessors combinators math math.intervals math.vectors +namespaces assocs fry splitting classes.algebra generalizations +locals compiler.tree.propagation.info ; IN: math.vectors.specialization SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ; @@ -30,7 +30,14 @@ SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ; { { +vector+ [ drop ] } { +scalar+ [ nip ] } - { +nonnegative+ [ nip real class-and [0,inf] ] } + { + +nonnegative+ + [ + nip + dup complex class<= [ drop float ] when + [0,inf] + ] + } } case ] with with map ; @@ -77,6 +84,8 @@ H{ { vbitand { +vector+ +vector+ -> +vector+ } } { vbitor { +vector+ +vector+ -> +vector+ } } { vbitxor { +vector+ +vector+ -> +vector+ } } + { vlshift { +vector+ +scalar+ -> +vector+ } } + { vrshift { +vector+ +scalar+ -> +vector+ } } } PREDICATE: vector-word < word vector-words key? ; @@ -107,15 +116,24 @@ M: vector-word subwords specializations values [ word? ] filter ; :: input-signature ( word array-type elt-type -- signature ) array-type elt-type word word-schema inputs signature-for-schema ; +: vector-words-for-type ( elt-type -- alist ) + { + ! Can't do shifts on floats + { [ dup float class<= ] [ vector-words keys { vlshift vrshift } diff ] } + ! Can't divide integers + { [ dup integer class<= ] [ vector-words keys { vsqrt n/v v/n v/ normalize } diff ] } + ! Can't compute square root of complex numbers (vsqrt uses fsqrt not sqrt) + { [ dup complex class<= ] [ vector-words keys { vsqrt } diff ] } + [ { } ] + } cond nip ; + :: specialize-vector-words ( array-type elt-type simd -- ) - elt-type number class<= [ - vector-words keys [ - [ array-type elt-type simd specialize-vector-word ] - [ array-type elt-type input-signature ] - [ ] - tri add-specialization - ] each - ] when ; + elt-type vector-words-for-type [ + [ array-type elt-type simd specialize-vector-word ] + [ array-type elt-type input-signature ] + [ ] + tri add-specialization + ] each ; : find-specialization ( classes word -- word/f ) specializations diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 3790e38d55..252cc4216e 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -38,6 +38,8 @@ $nl { $subsection vbitand } { $subsection vbitor } { $subsection vbitxor } +{ $subsection vlshift } +{ $subsection vrshift } "Inner product and norm:" { $subsection v. } { $subsection norm } @@ -160,11 +162,7 @@ HELP: vmin HELP: v. { $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "x" "a real number" } } -{ $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:" - { $code "0 [ conjugate * + ] 2reduce" } -} ; +{ $description "Computes the dot product of two vectors." } ; HELP: vs+ { $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } @@ -209,6 +207,14 @@ HELP: vbitxor { $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: vlshift +{ $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } } +{ $description "Shifts each element of " { $snippet "u" } " to the left by " { $snippet "n" } " bits." } ; + +HELP: vrshift +{ $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } } +{ $description "Shifts each element of " { $snippet "u" } " to the right by " { $snippet "n" } " bits." } ; + HELP: norm-sq { $values { "v" "a sequence of numbers" } { "x" "a non-negative real number" } } { $description "Computes the squared length of a mathematical vector." } ; diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index fc482815a9..5296831889 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -1,5 +1,5 @@ IN: math.vectors.tests -USING: math.vectors tools.test ; +USING: math.vectors tools.test kernel ; [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test [ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test @@ -19,4 +19,6 @@ USING: math.vectors tools.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 \ No newline at end of file +[ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test + +[ 1 ] [ { C{ 0 1 } } dup v. ] unit-test \ No newline at end of file diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 4b6f67544a..a40506f980 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -61,6 +61,9 @@ PRIVATE> : vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ; : vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ; +: vlshift ( u n -- w ) '[ _ shift ] map ; +: vrshift ( u n -- w ) neg '[ _ shift ] map ; + : vfloor ( u -- v ) [ floor ] map ; : vceiling ( u -- v ) [ ceiling ] map ; : vtruncate ( u -- v ) [ truncate ] map ; @@ -68,7 +71,7 @@ PRIVATE> : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; -: v. ( u v -- x ) [ * ] [ + ] 2map-reduce ; +: v. ( u v -- x ) [ conjugate * ] [ + ] 2map-reduce ; : norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ; : norm ( v -- x ) norm-sq sqrt ; : normalize ( u -- v ) dup norm v/n ; diff --git a/basis/prettyprint/stylesheet/stylesheet.factor b/basis/prettyprint/stylesheet/stylesheet.factor index a593f23d99..580049160d 100644 --- a/basis/prettyprint/stylesheet/stylesheet.factor +++ b/basis/prettyprint/stylesheet/stylesheet.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Keith Lazuka. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs colors.constants combinators +USING: assocs colors colors.constants combinators combinators.short-circuit hashtables io.styles kernel literals namespaces sequences words words.symbol ; IN: prettyprint.stylesheet @@ -43,4 +43,5 @@ PRIVATE> dim-color colored-presentation-style ; : effect-style ( effect -- style ) - COLOR: DarkGreen colored-presentation-style ; + 0 0.2 0 1 colored-presentation-style + { { font-style plain } } assoc-union ; diff --git a/basis/regexp/combinators/combinators-docs.factor b/basis/regexp/combinators/combinators-docs.factor index a49b16b585..20d5624025 100644 --- a/basis/regexp/combinators/combinators-docs.factor +++ b/basis/regexp/combinators/combinators-docs.factor @@ -18,20 +18,21 @@ ARTICLE: "regexp.combinators.intro" "Regular expression combinator rationale" ARTICLE: "regexp.combinators" "Regular expression combinators" "The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This complements the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary." -{ $subsection "regexp.combinators.intro" } +{ $subsections "regexp.combinators.intro" } "Basic combinators:" -{ $subsection } -{ $subsection } +{ $subsections } "Higher-order combinators for building new regular expressions from existing ones:" -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } +{ $subsections + + + + + +} "Derived combinators implemented in terms of the above:" -{ $subsection } +{ $subsections } "Setting options:" -{ $subsection