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

Merge branch 'bitfields' of git://factorcode.org/git/factor into bitfields

db4
Slava Pestov 2009-10-09 04:12:34 -05:00
parent 4d897aace3 bb93543054
commit 4262781be2
9 changed files with 239 additions and 14 deletions

7
basis/classes/struct/bit-accessors/bit-accessors-tests.factor Normal file
View File

@ -0,0 +1,7 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
IN: classes.struct.bit-accessors.test
[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test
[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test

46
basis/classes/struct/bit-accessors/bit-accessors.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math fry locals math.order alien.accessors ;
IN: classes.struct.bit-accessors
! Bitfield accessors are little-endian on all platforms
! Why not? It's unspecified in C
: ones-between ( start end -- n )
[ 2^ 1 - ] bi@ swap bitnot bitand ;
:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
offset 8 /mod :> start-bit :> i
start-bit bits + 8 min :> end-bit
start-bit end-bit ones-between :> mask
end-bit start-bit - :> used-bits
i mask start-bit step-quot call( i mask start-bit -- quot )
used-bits
i 1 + 8 *
bits used-bits - ; inline
:: bit-manipulator ( offset bits
step-quot: ( i mask start-bit -- quot )
combine-quot: ( prev-quot shift-amount next-quot -- quot )
-- quot )
offset bits step-quot manipulate-bits
dup zero? [ 3drop ] [
step-quot combine-quot bit-manipulator
combine-quot call( prev shift next -- quot )
] if ; inline recursive
: bit-reader ( offset bits -- quot: ( alien -- n ) )
[ neg '[ _ alien-unsigned-1 _ bitand _ shift ] ]
[ swap '[ _ _ bi _ shift bitor ] ]
bit-manipulator ;
:: write-bits ( n alien i mask start-bit -- )
n start-bit shift mask bitand
alien i alien-unsigned-1 mask bitnot bitand
bitor alien i set-alien-unsigned-1 ; inline
: bit-writer ( offset bits -- quot: ( n alien -- ) )
[ '[ _ _ _ write-bits ] ]
[ '[ _ [ [ _ neg shift ] dip @ ] 2bi ] ]
bit-manipulator ;

5
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -23,6 +23,11 @@ IN: classes.struct.prettyprint
[ type>> pprint-c-type ]
[ read-only>> [ \ read-only pprint-word ] when ]
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
[
dup struct-bit-slot-spec?
[ \ bits: pprint-word bits>> pprint* ]
[ drop ] if
]
} cleave block>
\ } pprint-word block> ;

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

@ -352,3 +352,16 @@ STRUCT: struct-that's-a-word { x int } ;
] unit-test
[ f ] [ "a-struct" c-types get key? ] unit-test
STRUCT: bit-field-test
{ a uint bits: 12 }
{ b int bits: 2 }
{ c char } ;
[ S{ bit-field-test f 0 0 0 } ] [ bit-field-test <struct> ] unit-test
[ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test <struct> 1 >>a 2 >>b 3 >>c ] unit-test
[ 4095 ] [ bit-field-test <struct> 8191 >>a a>> ] unit-test
[ 1 ] [ bit-field-test <struct> 1 >>b b>> ] unit-test
[ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
[ 3 ] [ bit-field-test heap-size ] unit-test

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

@ -1,4 +1,4 @@
! (c)Joe Groff bsd license
! (c)Joe Groff, Daniel Ehrenberg bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays classes classes.parser classes.tuple classes.tuple.parser
classes.tuple.private combinators combinators.short-circuit
@ -6,7 +6,9 @@ combinators.smart cpu.architecture definitions functors.backend
fry generalizations generic.parser kernel kernel.private lexer
libc locals macros make math math.order parser quotations
sequences slots slots.private specialized-arrays vectors words
summary namespaces assocs vocabs.parser ;
summary namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays ;
QUALIFIED: math
IN: classes.struct
SPECIALIZED-ARRAY: uchar
@ -22,6 +24,10 @@ TUPLE: struct
TUPLE: struct-slot-spec < slot-spec
type ;
! For a struct-bit-slot-spec, offset is in bits, not bytes
TUPLE: struct-bit-slot-spec < struct-slot-spec
bits signed? ;
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
@ -84,14 +90,36 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
: pad-struct-slots ( values class -- values' class )
[ struct-slots [ initial>> ] map over length tail append ] keep ;
: (reader-quot) ( slot -- quot )
: sign-extend ( n bits -- n' )
! formula from:
! http://guru.multimedia.cx/fast-sign-extension/
1 - -1 swap shift [ + ] keep bitxor ; inline
: sign-extender ( signed? bits -- quot )
'[ _ [ _ sign-extend ] when ] ;
GENERIC: (reader-quot) ( slot -- quot )
M: struct-slot-spec (reader-quot)
[ type>> c-type-getter-boxer ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
: (writer-quot) ( slot -- quot )
M: struct-bit-slot-spec (reader-quot)
[ [ offset>> ] [ bits>> ] bi bit-reader ]
[ [ signed?>> ] [ bits>> ] bi sign-extender ]
bi compose
[ >c-ptr ] prepose ;
GENERIC: (writer-quot) ( slot -- quot )
M: struct-slot-spec (writer-quot)
[ type>> c-setter ]
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
M: struct-bit-slot-spec (writer-quot)
[ offset>> ] [ bits>> ] bi bit-writer
[ >c-ptr ] prepose ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;
@ -186,20 +214,24 @@ M: struct-c-type c-struct? drop t ;
class (unboxer-quot) >>unboxer-quot
class (boxer-quot) >>boxer-quot ;
: align-offset ( offset class -- offset' )
c-type-align align ;
GENERIC: align-offset ( offset class -- offset' )
M: struct-slot-spec align-offset
[ type>> c-type-align 8 * align ] keep
[ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
M: struct-bit-slot-spec align-offset
[ (>>offset) ] [ bits>> + ] 2bi ;
: struct-offsets ( slots -- size )
0 [
[ type>> align-offset ] keep
[ (>>offset) ] [ type>> heap-size + ] 2bi
] reduce ;
0 [ align-offset ] reduce 8 align 8 /i ;
: union-struct-offsets ( slots -- size )
[ 0 >>offset type>> heap-size ] [ max ] map-reduce ;
1 [ 0 >>offset type>> heap-size max ] reduce ;
: struct-align ( slots -- align )
[ type>> c-type-align ] [ max ] map-reduce ;
[ struct-bit-slot-spec? not ] filter
1 [ type>> c-type-align max ] reduce ;
PRIVATE>
M: struct byte-length class "struct-size" word-prop ; foldable
@ -273,11 +305,43 @@ ERROR: invalid-struct-slot token ;
c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ;
SYMBOL: bits:
<PRIVATE
ERROR: bad-type-for-bits type ;
:: set-bits ( slot-spec n -- slot-spec )
struct-bit-slot-spec new
n >>bits
slot-spec type>> {
{ int [ t ] }
{ uint [ f ] }
[ bad-type-for-bits ]
} case >>signed?
slot-spec name>> >>name
slot-spec class>> >>class
slot-spec type>> >>type
slot-spec read-only>> >>read-only
slot-spec initial>> >>initial ;
: peel-off-struct-attributes ( slot-spec array -- slot-spec array )
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
{ read-only [ [ t >>read-only ] dip ] }
{ bits: [ [ first set-bits ] [ rest ] bi ] }
[ bad-slot-attribute ]
} case
] unless ;
PRIVATE>
: <struct-slot-spec> ( name c-type attributes -- slot-spec )
[ struct-slot-spec new ] 3dip
[ >>name ]
[ [ >>type ] [ struct-slot-class >>class ] bi ]
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
[ [ dup empty? ] [ peel-off-struct-attributes ] until drop ] tri* ;
<PRIVATE
: parse-struct-slot ( -- slot )

24
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
@ -242,6 +242,28 @@ M: ##shl-imm constant-fold* drop shift ;
[ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
\ ##load-immediate new-insn ; inline
: unary-constant-fold? ( insn -- ? )
src>> vreg>expr constant-expr? ; inline
GENERIC: unary-constant-fold* ( x insn -- y )
M: ##not unary-constant-fold* drop bitnot ;
M: ##neg unary-constant-fold* drop neg ;
: unary-constant-fold ( insn -- insn' )
[ dst>> ]
[ [ src>> vreg>constant ] [ ] bi unary-constant-fold* ] bi
\ ##load-immediate new-insn ; inline
: maybe-unary-constant-fold ( insn -- insn' )
dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
M: ##neg rewrite
maybe-unary-constant-fold ;
M: ##not rewrite
maybe-unary-constant-fold ;
: reassociate ( insn op -- insn )
[
{

28
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -983,6 +983,34 @@ cell 8 = [
] unit-test
] when
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 -1 }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 1 }
T{ ##neg f 2 1 }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 1 }
T{ ##load-immediate f 2 -2 }
}
] [
{
T{ ##peek f 0 D 0 }
T{ ##load-immediate f 1 1 }
T{ ##not f 2 1 }
} value-numbering-step
] unit-test
! Displaced alien optimizations
3 vreg-counter set-global

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

@ -899,3 +899,10 @@ M: tuple-with-read-only-slot clone
! We want this to inline
[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
[ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
[ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test
[ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test

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

@ -45,6 +45,27 @@ IN: compiler.tree.propagation.transforms
: simplify-bitand? ( value -- ? )
value-info literal>> positive-fixnum? ;
: all-ones? ( int -- ? )
dup 1 + bitand zero? ; inline
: redundant-bitand? ( var 111... -- ? )
[ value-info ] bi@ [ interval>> ] [ literal>> ] bi* {
[ nip integer? ]
[ nip all-ones? ]
[ 0 swap [a,b] interval-subset? ]
} 2&& ;
: (zero-bitand?) ( value-info value-info' -- ? )
[ interval>> ] [ literal>> ] bi* {
[ nip integer? ]
[ nip bitnot all-ones? ]
[ 0 swap bitnot [a,b] interval-subset? ]
} 2&& ;
: zero-bitand? ( var1 var2 -- ? )
[ value-info ] bi@
{ [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ;
{
bitand-integer-integer
bitand-integer-fixnum
@ -53,6 +74,18 @@ IN: compiler.tree.propagation.transforms
} [
[
{
{
[ dup in-d>> first2 zero-bitand? ]
[ drop [ 2drop 0 ] ]
}
{
[ dup in-d>> first2 redundant-bitand? ]
[ drop [ drop ] ]
}
{
[ dup in-d>> first2 swap redundant-bitand? ]
[ drop [ nip ] ]
}
{
[ dup in-d>> first simplify-bitand? ]
[ drop [ >fixnum fixnum-bitand ] ]