! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays checksums checksums.md5 io.encodings.binary
-io.streams.byte-array kernel math namespaces tools.test ;
+io.streams.byte-array kernel math namespaces tools.test
+sequences ;
IN: checksums.md5.tests
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
<md5-state> "asdf" binary <byte-reader> add-checksum-stream
[ get-checksum ] [ get-checksum ] bi =
] unit-test
+
+[
+ t
+] [
+ { "abcd" "efg" } md5 checksum-lines length 16 =
+] unit-test
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
] each
-: contains-insn? ( quot insn-check -- ? )
+: count-insns ( quot insn-check -- ? )
[ test-mr [ instructions>> ] map ] dip
- '[ _ any? ] any? ; inline
+ '[ _ count ] sigma ; inline
+
+: contains-insn? ( quot insn-check -- ? )
+ count-insns 0 > ; inline
[ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
- [ [ ##box-float? ] contains-insn? ] bi
+ [ [ ##allot? ] contains-insn? ] bi
] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
- [ [ ##box-float? ] contains-insn? ] bi
+ [ [ ##allot? ] contains-insn? ] bi
] unit-test
+
+ [ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
] when
! Regression. Make sure everything is inlined correctly
} 0 test-bb
V{
- T{ ##box-float f 0 1 }
+ T{ ##box-alien f 0 1 }
} 1 test-bb
0 1 edge
[ ##load-reference ]
} cond ;
-: ^^unbox-c-ptr ( src class -- dst )
- [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
-
-: ^^allot-tuple ( n -- dst )
- 2 + cells tuple ^^allot ;
-
-: ^^allot-array ( n -- dst )
- 2 + cells array ^^allot ;
-
-: ^^allot-byte-array ( n -- dst )
- 2 cells + byte-array ^^allot ;
-
: ^^offset>slot ( slot -- vreg' )
cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
-: ^^tag-offset>slot ( slot tag -- vreg' )
- [ ^^offset>slot ] dip ^^sub-imm ;
-
: ^^tag-fixnum ( src -- dst )
tag-bits get ^^shl-imm ;
use: src/int-rep ;
! Float arithmetic
-PURE-INSN: ##unbox-float
-def: dst/double-rep
-use: src/int-rep ;
-
-PURE-INSN: ##box-float
-def: dst/int-rep
-use: src/double-rep
-temp: temp/int-rep ;
-
PURE-INSN: ##add-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
use: src/int-rep ;
! SIMD operations
-
-PURE-INSN: ##box-vector
-def: dst/int-rep
-use: src
-literal: rep
-temp: temp/int-rep ;
-
-PURE-INSN: ##unbox-vector
-def: dst
-use: src/int-rep
-literal: rep ;
-
PURE-INSN: ##zero-vector
def: dst
literal: rep ;
UNION: ##allocation
##allot
-##box-float
-##box-vector
##box-alien
##box-displaced-alien ;
USING: accessors kernel sequences alien math classes.algebra fry
locals combinators combinators.short-circuit cpu.architecture
compiler.tree.propagation.info compiler.cfg.hats
-compiler.cfg.stacks compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.builder.blocks ;
+compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.instructions compiler.cfg.utilities
+compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.alien
: emit-<displaced-alien>? ( node -- ? )
[ second class>> fixnum class<= ]
bi and ;
+: ^^unbox-c-ptr ( src class -- dst )
+ [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
+
: prepare-alien-accessor ( info -- ptr-vreg offset )
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
: tuple-slot-regs ( layout -- vregs )
[ second ds-load ] [ ^^load-literal ] bi prefix ;
+: ^^allot-tuple ( n -- dst )
+ 2 + cells tuple ^^allot ;
+
: emit-<tuple-boa> ( node -- )
dup node-input-infos last literal>>
dup array? [
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
+: ^^allot-array ( n -- dst )
+ 2 + cells array ^^allot ;
+
:: emit-<array> ( node -- )
[let | len [ node node-input-infos first literal>> ] |
len expand-<array>? [
: bytes>cells ( m -- n ) cell align cell /i ;
+: ^^allot-byte-array ( n -- dst )
+ 2 cells + byte-array ^^allot ;
+
: emit-allot-byte-array ( len -- dst )
ds-drop
dup ^^allot-byte-array
: value-tag ( info -- n ) class>> class-tag ; inline
+: ^^tag-offset>slot ( slot tag -- vreg' )
+ [ ^^offset>slot ] dip ^^sub-imm ;
+
: (emit-slot) ( infos -- dst )
[ 2inputs ] [ first value-tag ] bi*
^^tag-offset>slot ^^slot ;
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry accessors sequences assocs sets namespaces
-arrays combinators combinators.short-circuit make locals deques
-dlists layouts cpu.architecture compiler.utilities
+arrays combinators combinators.short-circuit math make locals
+deques dlists layouts byte-arrays cpu.architecture
+compiler.utilities
+compiler.constants
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
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 ;
+ dst temp double-rep emit-box ;
M:: float-rep emit-unbox ( dst src rep -- )
double-rep next-vreg-rep :> temp
- temp src ##unbox-float
+ temp src double-rep emit-unbox
dst temp ##double>single-float ;
M: double-rep emit-box
- drop int-rep next-vreg-rep ##box-float ;
+ drop
+ [ drop 16 float int-rep next-vreg-rep ##allot ]
+ [ float-offset swap ##set-alien-double ]
+ 2bi ;
M: double-rep emit-unbox
- drop ##unbox-float ;
+ drop float-offset ##alien-double ;
-M: vector-rep emit-box
- int-rep next-vreg-rep ##box-vector ;
+M:: vector-rep emit-box ( dst src rep -- )
+ int-rep next-vreg-rep :> temp
+ dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
+ temp 16 tag-fixnum ##load-immediate
+ temp dst 1 byte-array tag-number ##set-slot-imm
+ dst byte-array-offset src rep ##set-alien-vector ;
M: vector-rep emit-unbox
- ##unbox-vector ;
+ [ byte-array-offset ] dip ##alien-vector ;
M:: scalar-rep emit-box ( dst src rep -- )
int-rep next-vreg-rep :> temp
! Insert conversions. This introduces new temporaries, so we need
! to rename opearands too.
+! Mapping from vreg,rep pairs to vregs
+SYMBOL: alternatives
+
:: emit-def-conversion ( dst preferred required -- new-dst' )
! If an instruction defines a register with representation 'required',
! but the register has preferred representation 'preferred', then
! but the register has preferred representation 'preferred', then
! we rename the instruction's input to a new register, which
! becomes the output of a conversion instruction.
- required next-vreg-rep [ src required preferred emit-conversion ] keep ;
+ preferred required eq? [ src ] [
+ src required alternatives get [
+ required next-vreg-rep :> new-src
+ [ new-src ] 2dip preferred emit-conversion
+ new-src
+ ] 2cache
+ ] if ;
SYMBOLS: renaming-set needs-renaming? ;
dup kill-block? [ drop ] [
[
[
+ H{ } clone alternatives set
[ conversions-for-insn ] each
] V{ } make
] change-instructions drop
{
T{ ##peek f 8 D 0 }
T{ ##peek f 9 D -1 }
- T{ ##unbox-float f 10 8 }
- T{ ##unbox-float f 11 9 }
- T{ ##compare-float-unordered f 12 10 11 cc< }
- T{ ##compare-float-unordered f 14 10 11 cc/< }
+ T{ ##compare-float-unordered f 12 8 9 cc< }
+ T{ ##compare-float-unordered f 14 8 9 cc/< }
T{ ##replace f 14 D 0 }
}
] [
{
T{ ##peek f 8 D 0 }
T{ ##peek f 9 D -1 }
- T{ ##unbox-float f 10 8 }
- T{ ##unbox-float f 11 9 }
- T{ ##compare-float-unordered f 12 10 11 cc< }
+ T{ ##compare-float-unordered f 12 8 9 cc< }
T{ ##compare-imm f 14 12 5 cc= }
T{ ##replace f 14 D 0 }
} value-numbering-step trim-temps
CODEGEN: ##neg %neg
CODEGEN: ##log2 %log2
CODEGEN: ##copy %copy
-CODEGEN: ##unbox-float %unbox-float
-CODEGEN: ##box-float %box-float
CODEGEN: ##add-float %add-float
CODEGEN: ##sub-float %sub-float
CODEGEN: ##mul-float %mul-float
CODEGEN: ##double>single-float %double>single-float
CODEGEN: ##integer>float %integer>float
CODEGEN: ##float>integer %float>integer
-CODEGEN: ##unbox-vector %unbox-vector
CODEGEN: ##zero-vector %zero-vector
CODEGEN: ##gather-vector-2 %gather-vector-2
CODEGEN: ##gather-vector-4 %gather-vector-4
CODEGEN: ##shuffle-vector %shuffle-vector
CODEGEN: ##compare-vector %compare-vector
CODEGEN: ##test-vector %test-vector
-CODEGEN: ##box-vector %box-vector
CODEGEN: ##add-vector %add-vector
CODEGEN: ##saturated-add-vector %saturated-add-vector
CODEGEN: ##add-sub-vector %add-sub-vector
} compile-test-bb
] unit-test
-! ##copy on floats. We can only run this test if float intrinsics
-! are enabled.
-\ float+ "intrinsic" word-prop [
- [ 1.5 ] [
- V{
- T{ ##load-reference f 4 1.5 }
- T{ ##unbox-float f 1 4 }
- T{ ##copy f 2 1 double-rep }
- T{ ##box-float f 3 2 }
- T{ ##copy f 0 3 int-rep }
- } compile-test-bb
- ] unit-test
-] when
-
! make sure slot access works when the destination is
! one of the sources
[ t ] [
HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
-HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float cpu ( dst src temp -- )
-
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
-HOOK: %box-vector cpu ( dst src temp rep -- )
-HOOK: %unbox-vector cpu ( dst src rep -- )
-
HOOK: %zero-vector cpu ( dst rep -- )
HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
} case
] if ;
-M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
-
-M:: ppc %box-float ( dst src temp -- )
- dst 16 float temp %allot
- src dst float-offset STFD ;
-
GENERIC: float-function-param* ( dst src -- )
M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
M: ppc %alien-float LFS ;
M: ppc %alien-double LFD ;
-M: ppc %set-alien-integer-1 swapd STB ;
-M: ppc %set-alien-integer-2 swapd STH ;
+M: ppc %set-alien-integer-1 -rot STB ;
+M: ppc %set-alien-integer-2 -rot STH ;
-M: ppc %set-alien-cell swapd STW ;
+M: ppc %set-alien-cell -rot STW ;
-M: ppc %set-alien-float swapd STFS ;
-M: ppc %set-alien-double swapd STFD ;
+M: ppc %set-alien-float -rot STFS ;
+M: ppc %set-alien-double -rot STFD ;
: load-zone-ptr ( reg -- )
"nursery" %load-vm-field-addr ;
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
-M: x86 %unbox-float ( dst src -- )
- float-offset [+] MOVSD ;
-
-M:: x86 %box-float ( dst src temp -- )
- dst 16 float temp %allot
- dst float-offset [+] src MOVSD ;
-
: %cmov-float= ( dst src -- )
[
"no-move" define-label
M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
\ UCOMISD (%compare-float-branch) ;
-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 ;
-
-M:: x86 %unbox-vector ( dst src rep -- )
- dst src byte-array-offset [+]
- rep %copy ;
-
MACRO: available-reps ( alist -- )
! Each SSE version adds new representations and supports
! all old ones
namespaces arrays quotations combinators combinators.short-circuit sets
layouts ;
QUALIFIED-WITH: alien.c-types c
+QUALIFIED: math.private
IN: math.vectors.simd.functor
ERROR: bad-length got expected ;
: can-be-unboxed? ( type -- ? )
{
- { c:float [ t ] }
- { c:double [ t ] }
+ { c:float [ \ math.private:float+ "intrinsic" word-prop ] }
+ { c:double [ \ math.private:float+ "intrinsic" word-prop ] }
[ c:heap-size cell < ]
} case ;
: simd-with ( rep class x -- simd-array )
[ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
-: simd-with-fast? ( rep -- ? )
+: simd-with/nth-fast? ( rep -- ? )
[ \ (simd-vshuffle) supported-simd-op? ]
[ rep-component-type can-be-unboxed? ]
bi and ;
:: define-with-custom-inlining ( word rep class -- )
word [
drop
- rep simd-with-fast? [
+ rep simd-with/nth-fast? [
[ rep rep-coerce rep (simd-with) class boa ]
] [ word def>> ] if
] "custom-inlining" set-word-prop ;
-: simd-nth-fast? ( rep -- ? )
- [ \ (simd-vshuffle) supported-simd-op? ]
- [ rep-component-type can-be-unboxed? ]
- bi and ;
-
: simd-nth-fast ( rep -- quot )
[ rep-components ] keep
'[ swap _ '[ _ _ (simd-select) ] 2array ] map-index
rep-component-type dup c:c-type-getter-boxer c:array-accessor ;
MACRO: simd-nth ( rep -- x )
- dup simd-nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ;
+ dup simd-with/nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ;
: boa-effect ( rep n -- effect )
[ rep-components ] dip *
[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
[ 99 ] [ 100 99 sample prune length ] unit-test
+
+[ ]
+[ [ 100 random-bytes ] with-system-random drop ] unit-test
[ 2drop ] [ random-32* 4 >le swap head over push-all ] if
] bi-curry bi* ;
-M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;
+M: object random-32* ( tuple -- r ) 4 swap random-bytes* le> ;
ERROR: no-random-number-generator ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax unix.types unix.stat classes.struct ;
+USING: alien.c-types alien.syntax unix.types classes.struct
+unix.stat ;
IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16
{ f_mntfromname { char MNAMELEN } }
{ mount_info char[160] } ;
-FUNCTION: int statfs ( char* path, statvfs* buf ) ;
+FUNCTION: int statfs ( char* path, statfs* buf ) ;
projects / factor.git / commitdiff