M: array c-type-class drop object ;
+M: array c-type-boxed-class drop object ;
+
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
M: string-type c-type ;
-M: string-type c-type-class
- drop object ;
+M: string-type c-type-class drop object ;
+
+M: string-type c-type-boxed-class drop object ;
M: string-type heap-size
drop "void*" heap-size ;
TUPLE: abstract-c-type
{ class class initial: object }
+{ boxed-class class initial: object }
{ boxer-quot callable }
{ unboxer-quot callable }
{ getter callable }
M: string c-type-class c-type c-type-class ;
+GENERIC: c-type-boxed-class ( name -- class )
+
+M: abstract-c-type c-type-boxed-class boxed-class>> ;
+
+M: string c-type-boxed-class c-type c-type-boxed-class ;
+
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
[
<c-type>
c-ptr >>class
+ c-ptr >>boxed-class
[ alien-cell ] >>getter
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
<long-long-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
<long-long-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
<c-type>
integer >>class
+ integer >>boxed-class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
<c-type>
fixnum >>class
+ fixnum >>boxed-class
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
<c-type>
float >>class
+ float >>boxed-class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
<c-type>
float >>class
+ float >>boxed-class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex kernel alien.c-types alien.syntax
-namespaces ;
+namespaces math ;
IN: alien.complex.tests
C-STRUCT: complex-holder
] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
+
+[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
+
+[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
\ No newline at end of file
T c-type
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
-number >>class
+number >>boxed-class
drop
;FUNCTOR
[ [ align ] keep ] dip
struct-type new
byte-array >>class
+ byte-array >>boxed-class
swap >>fields
swap >>align
swap >>size
compiler.tree.optimizer
compiler.tree.combinators
compiler.tree.checker
+compiler.tree.identities
compiler.tree.dead-code
compiler.tree.modular-arithmetic ;
FROM: fry => _ ;
normalize
propagate
cleanup
+ apply-identities
compute-def-use
remove-dead-code
compute-def-use
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch
-math.private accessors slots.private sequences strings sbufs
+math.private accessors slots.private sequences sequences.private strings sbufs
compiler.tree.builder
compiler.tree.normalization
compiler.tree.debugger
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test
[ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test
+
+[ t ] [
+ [ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
+ { >fixnum } inlined?
+] unit-test
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals namespaces
-sequences words combinators combinators.short-circuit byte-arrays
-strings arrays layouts cpu.architecture compiler.tree.propagation.copy
- ;
+sequences sequences.private words combinators
+combinators.short-circuit byte-arrays strings arrays layouts
+cpu.architecture compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
CONSTANT: object-info T{ value-info f object full-interval }
-: class-interval ( class -- interval )
- dup real class<=
- [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ;
-
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
[ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ]
} 1|| ;
+: min-value ( class -- n ) fixnum eq? [ most-negative-fixnum ] [ -1/0. ] if ;
+
+: max-value ( class -- n ) fixnum eq? [ most-positive-fixnum ] [ 1/0. ] if ;
+
+: class-interval ( class -- i ) fixnum eq? [ fixnum-interval ] [ full-interval ] if ;
+
+: wrap-interval ( interval class -- interval' )
+ {
+ { fixnum [ interval->fixnum ] }
+ { array-capacity [ max-array-capacity [a,a] interval-rem ] }
+ [ drop ]
+ } case ;
+
+: init-interval ( info -- info )
+ dup [ interval>> full-interval or ] [ class>> ] bi wrap-interval >>interval
+ dup class>> integer class<= [ [ integral-closure ] change-interval ] when ; inline
+
: init-value-info ( info -- info )
dup literal?>> [
init-literal-info
null >>class
empty-interval >>interval
] [
- [ [-inf,inf] or ] change-interval
- dup class>> integer class<= [ [ integral-closure ] change-interval ] when
+ init-interval
dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
] if
init-value-info ; foldable
: <class-info> ( class -- info )
- dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or
- <class/interval-info> ; foldable
+ f <class/interval-info> ; foldable
: <interval-info> ( interval -- info )
<value-info>
compiler.tree.propagation.transforms ;
IN: compiler.tree.propagation.known-words
-\ fixnum
-most-negative-fixnum most-positive-fixnum [a,b]
-"interval" set-word-prop
-
-\ array-capacity
-0 max-array-capacity [a,b]
-"interval" set-word-prop
-
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
{ fixnum bignum integer rational float real number object }
[ class<= ] with find nip ;
-: fits? ( interval class -- ? )
- "interval" word-prop interval-subset? ;
+: fits-in-fixnum? ( interval -- ? )
+ fixnum-interval interval-subset? ;
: binary-op-class ( info1 info2 -- newclass )
[ class>> ] bi@
[ [ interval>> ] bi@ ] dip call ; inline
: won't-overflow? ( class interval -- ? )
- [ fixnum class<= ] [ fixnum fits? ] bi* and ;
+ [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
: may-overflow ( class interval -- class' interval' )
over null-class? [
{ >integer integer }
} [
- '[
- _
- [ nip ] [
- [ interval>> ] [ class-interval ] bi*
- interval-intersect
- ] 2bi
- <class/interval-info>
- ] "outputs" set-word-prop
+ '[ _ swap interval>> <class/interval-info> ] "outputs" set-word-prop
] assoc-each
{ numerator denominator }
[ string>number 8 * 2^ 1- 0 swap [a,b] ]
}
} cond
- [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
+ [ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
'[ 2drop _ ] "outputs" set-word-prop
] each
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+! generalize-counter is not tight enough
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test
+
+! Coercions need to update intervals
+[ V{ f } ] [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test
+
+[ V{ f } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test
+
! Mutable tuples with circularity should not cause problems
TUPLE: circle me ;
IN: compiler.tree.propagation.recursive.tests
USING: tools.test compiler.tree.propagation.recursive
-math.intervals kernel ;
+math.intervals kernel math literals layouts ;
[ T{ interval f { 0 t } { 1/0. t } } ] [
T{ interval f { 1 t } { 1 t } }
- T{ interval f { 0 t } { 0 t } } generalize-counter-interval
+ T{ interval f { 0 t } { 0 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [
+ T{ interval f { 1 t } { 1 t } }
+ T{ interval f { 0 t } { 0 t } }
+ fixnum generalize-counter-interval
] unit-test
[ T{ interval f { -1/0. t } { 10 t } } ] [
T{ interval f { -1 t } { -1 t } }
- T{ interval f { 10 t } { 10 t } } generalize-counter-interval
+ T{ interval f { 10 t } { 10 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ T{ interval f { $[ most-negative-fixnum ] t } { 10 t } } ] [
+ T{ interval f { -1 t } { -1 t } }
+ T{ interval f { 10 t } { 10 t } }
+ fixnum generalize-counter-interval
] unit-test
[ t ] [
T{ interval f { 1 t } { 268435455 t } }
T{ interval f { -268435456 t } { 268435455 t } } tuck
- generalize-counter-interval =
+ integer generalize-counter-interval =
+] unit-test
+
+[ t ] [
+ T{ interval f { 1 t } { 268435455 t } }
+ T{ interval f { -268435456 t } { 268435455 t } } tuck
+ fixnum generalize-counter-interval =
+] unit-test
+
+[ full-interval ] [
+ T{ interval f { -5 t } { 3 t } }
+ T{ interval f { 2 t } { 11 t } }
+ integer generalize-counter-interval
+] unit-test
+
+[ $[ fixnum-interval ] ] [
+ T{ interval f { -5 t } { 3 t } }
+ T{ interval f { 2 t } { 11 t } }
+ fixnum generalize-counter-interval
] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors arrays fry math.intervals
-combinators namespaces
+USING: kernel sequences accessors arrays fry math math.intervals
+layouts combinators namespaces locals
stack-checker.inlining
compiler.tree
compiler.tree.combinators
[ label>> calls>> [ node>> node-input-infos ] map flip ]
[ latest-input-infos ] bi ;
-: generalize-counter-interval ( interval initial-interval -- interval' )
+:: generalize-counter-interval ( interval initial-interval class -- interval' )
{
- { [ 2dup interval-subset? ] [ empty-interval ] }
- { [ over empty-interval eq? ] [ empty-interval ] }
- { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] }
- { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] }
- [ [-inf,inf] ]
- } cond interval-union nip ;
+ { [ interval initial-interval interval-subset? ] [ initial-interval ] }
+ { [ interval empty-interval eq? ] [ initial-interval ] }
+ {
+ [ interval initial-interval interval>= t eq? ]
+ [ class max-value [a,a] initial-interval interval-union ]
+ }
+ {
+ [ interval initial-interval interval<= t eq? ]
+ [ class min-value [a,a] initial-interval interval-union ]
+ }
+ [ class class-interval ]
+ } cond ;
: generalize-counter ( info' initial -- info )
2dup [ not ] either? [ drop ] [
2dup [ class>> null-class? ] either? [ drop ] [
[ clone ] dip
- [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ]
+ [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ]
[ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
[ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
tri
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
-combinators generic layouts ;
+combinators generic layouts memoize ;
IN: math.intervals
SYMBOL: empty-interval
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
-: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+MEMO: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+
+MEMO: fixnum-interval ( -- interval )
+ most-negative-fixnum most-positive-fixnum [a,b] ; inline
: [-inf,inf] ( -- interval ) full-interval ; inline
} cond
swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ;
+: (rem-range) ( i -- i' ) interval-abs to>> first 0 swap [a,b) ;
+
: interval-rem ( i1 i2 -- i3 )
{
{ [ over empty-interval eq? ] [ drop ] }
{ [ dup empty-interval eq? ] [ nip ] }
{ [ dup full-interval eq? ] [ nip ] }
- [ nip interval-abs to>> first 0 swap [a,b) ]
+ [ (rem-range) 2dup interval-subset? [ drop ] [ nip ] if ]
+ } cond ;
+
+: interval->fixnum ( i1 -- i2 )
+ {
+ { [ dup empty-interval eq? ] [ ] }
+ { [ dup full-interval eq? ] [ drop fixnum-interval ] }
+ { [ dup fixnum-interval interval-subset? not ] [ drop fixnum-interval ] }
+ [ ]
} cond ;
: interval-bitand-pos ( i1 i2 -- ? )
INSTANCE: A sequence
-A T c-type class>> specialize-vector-words
+A T c-type-boxed-class specialize-vector-words
;FUNCTOR
--- /dev/null
+! Copyright (C) Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.accessors alien.c-types alien.syntax byte-arrays
+destructors generalizations hints kernel libc locals math math.order
+sequences sequences.private ;
+IN: benchmark.yuv-to-rgb
+
+C-STRUCT: yuv_buffer
+ { "int" "y_width" }
+ { "int" "y_height" }
+ { "int" "y_stride" }
+ { "int" "uv_width" }
+ { "int" "uv_height" }
+ { "int" "uv_stride" }
+ { "void*" "y" }
+ { "void*" "u" }
+ { "void*" "v" } ;
+
+:: fake-data ( -- rgb yuv )
+ [let* | w [ 1600 ]
+ h [ 1200 ]
+ buffer [ "yuv_buffer" <c-object> ]
+ rgb [ w h * 3 * <byte-array> ] |
+ w buffer set-yuv_buffer-y_width
+ h buffer set-yuv_buffer-y_height
+ h buffer set-yuv_buffer-uv_height
+ w buffer set-yuv_buffer-y_stride
+ w buffer set-yuv_buffer-uv_stride
+ w h * [ dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-y
+ w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-u
+ w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-v
+ rgb buffer
+ ] ;
+
+: clamp ( n -- n )
+ 255 min 0 max ; inline
+
+: stride ( line yuv -- uvy yy )
+ [ yuv_buffer-uv_stride swap 2/ * >fixnum ]
+ [ yuv_buffer-y_stride * >fixnum ] 2bi ; inline
+
+: compute-y ( yuv uvy yy x -- y )
+ + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
+
+: compute-v ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-u swap alien-unsigned-1 128 - ; inline
+
+: compute-u ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-v swap alien-unsigned-1 128 - ; inline
+
+:: compute-yuv ( yuv uvy yy x -- y u v )
+ yuv uvy yy x compute-y
+ yuv uvy yy x compute-u
+ yuv uvy yy x compute-v ; inline
+
+: compute-blue ( y u v -- b )
+ drop 516 * 128 + swap 298 * + -8 shift clamp ; inline
+
+: compute-green ( y u v -- g )
+ [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift clamp ;
+ inline
+
+: compute-red ( y u v -- g )
+ nip 409 * swap 298 * + 128 + -8 shift clamp ; inline
+
+: compute-rgb ( y u v -- b g r )
+ [ compute-blue ] [ compute-green ] [ compute-red ] 3tri ;
+ inline
+
+: store-rgb ( index rgb b g r -- index )
+ [ pick 0 + pick set-nth-unsafe ]
+ [ pick 1 + pick set-nth-unsafe ]
+ [ pick 2 + pick set-nth-unsafe ] tri*
+ drop ; inline
+
+: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
+ compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
+
+: yuv>rgb-row ( index rgb yuv y -- index )
+ over stride
+ pick yuv_buffer-y_width >fixnum
+ [ yuv>rgb-pixel ] with with with with each ; inline
+
+: yuv>rgb ( rgb yuv -- )
+ [ 0 ] 2dip
+ dup yuv_buffer-y_height >fixnum
+ [ yuv>rgb-row ] with with each
+ drop ;
+
+HINTS: yuv>rgb byte-array byte-array ;
+
+: yuv>rgb-benchmark ( -- )
+ [ fake-data yuv>rgb ] with-destructors ;
+
+MAIN: yuv>rgb-benchmark
projects / factor.git / commitdiff