Making struct bitfield readers fast
parent
8ba295d8a8
commit
3179dacb3e
|
@ -0,0 +1,29 @@
|
||||||
|
! 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 platform-dependent in C
|
||||||
|
|
||||||
|
: ones-between ( start end -- n )
|
||||||
|
[ 2^ 1 - ] bi@ swap bitnot bitand ;
|
||||||
|
|
||||||
|
:: read-bits ( offset bits -- quot: ( byte-array -- n ) 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
|
||||||
|
|
||||||
|
! The code generated for this isn't optimal
|
||||||
|
! To improve the code, algebraic simplifications should
|
||||||
|
! have interval information available
|
||||||
|
[ i alien-unsigned-1 mask bitand start-bit neg shift ]
|
||||||
|
used-bits
|
||||||
|
i 1 + 8 *
|
||||||
|
bits used-bits - ;
|
||||||
|
|
||||||
|
: bit-reader ( offset bits -- quot: ( alien -- n ) )
|
||||||
|
read-bits dup zero? [ 3drop ] [
|
||||||
|
bit-reader swap '[ _ _ bi _ shift bitor ]
|
||||||
|
] if ;
|
|
@ -6,7 +6,8 @@ combinators.smart cpu.architecture definitions functors.backend
|
||||||
fry generalizations generic.parser kernel kernel.private lexer
|
fry generalizations generic.parser kernel kernel.private lexer
|
||||||
libc locals macros make math math.order parser quotations
|
libc locals macros make math math.order parser quotations
|
||||||
sequences slots slots.private specialized-arrays vectors words
|
sequences slots slots.private specialized-arrays vectors words
|
||||||
summary namespaces assocs vocabs.parser math.functions bit-arrays ;
|
summary namespaces assocs vocabs.parser math.functions
|
||||||
|
classes.struct.bit-accessors bit-arrays ;
|
||||||
QUALIFIED: math
|
QUALIFIED: math
|
||||||
IN: classes.struct
|
IN: classes.struct
|
||||||
|
|
||||||
|
@ -89,23 +90,14 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
|
||||||
: pad-struct-slots ( values class -- values' class )
|
: pad-struct-slots ( values class -- values' class )
|
||||||
[ struct-slots [ initial>> ] map over length tail append ] keep ;
|
[ struct-slots [ initial>> ] map over length tail append ] keep ;
|
||||||
|
|
||||||
: bits@ ( slot -- beginning end )
|
|
||||||
[ offset>> ] [ bits>> ] bi dupd + ;
|
|
||||||
|
|
||||||
QUALIFIED: math.bits
|
|
||||||
|
|
||||||
: bytes>bits ( byte-array -- bit-array )
|
|
||||||
[ 8 math.bits:<bits> ] { } map-as ?{ } join ;
|
|
||||||
|
|
||||||
: read-bits ( beginning end byte-array -- n )
|
|
||||||
! This is absurdly inefficient
|
|
||||||
bytes>bits subseq bit-array>integer ;
|
|
||||||
|
|
||||||
: sign-extend ( n bits -- n' )
|
: sign-extend ( n bits -- n' )
|
||||||
! formula from:
|
! formula from:
|
||||||
! http://guru.multimedia.cx/fast-sign-extension/
|
! http://guru.multimedia.cx/fast-sign-extension/
|
||||||
1 - -1 swap shift [ + ] keep bitxor ; inline
|
1 - -1 swap shift [ + ] keep bitxor ; inline
|
||||||
|
|
||||||
|
: sign-extender ( signed? bits -- quot )
|
||||||
|
'[ _ [ _ sign-extend ] when ] ;
|
||||||
|
|
||||||
GENERIC: (reader-quot) ( slot -- quot )
|
GENERIC: (reader-quot) ( slot -- quot )
|
||||||
|
|
||||||
M: struct-slot-spec (reader-quot)
|
M: struct-slot-spec (reader-quot)
|
||||||
|
@ -113,10 +105,10 @@ M: struct-slot-spec (reader-quot)
|
||||||
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
||||||
|
|
||||||
M: struct-bit-slot-spec (reader-quot)
|
M: struct-bit-slot-spec (reader-quot)
|
||||||
[ bits@ ] [ signed?>> ] [ bits>> ] tri '[
|
[ [ offset>> ] [ bits>> ] bi bit-reader ]
|
||||||
[ _ _ ] dip (underlying)>> read-bits
|
[ [ signed?>> ] [ bits>> ] bi sign-extender ]
|
||||||
_ [ _ sign-extend ] when
|
bi compose
|
||||||
] ;
|
[ >c-ptr ] prepose ;
|
||||||
|
|
||||||
GENERIC: (writer-quot) ( slot -- quot )
|
GENERIC: (writer-quot) ( slot -- quot )
|
||||||
|
|
||||||
|
@ -124,6 +116,11 @@ M: struct-slot-spec (writer-quot)
|
||||||
[ type>> c-setter ]
|
[ type>> c-setter ]
|
||||||
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
[ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
|
||||||
|
|
||||||
|
QUALIFIED: math.bits
|
||||||
|
|
||||||
|
: bytes>bits ( byte-array -- bit-array )
|
||||||
|
[ 8 math.bits:<bits> ] { } map-as ?{ } join ;
|
||||||
|
|
||||||
: (write-bits) ( value offset end byte-array -- )
|
: (write-bits) ( value offset end byte-array -- )
|
||||||
! This is absurdly inefficient
|
! This is absurdly inefficient
|
||||||
[
|
[
|
||||||
|
@ -131,6 +128,9 @@ M: struct-slot-spec (writer-quot)
|
||||||
replace-slice ?{ } like underlying>>
|
replace-slice ?{ } like underlying>>
|
||||||
] keep 0 swap copy ;
|
] keep 0 swap copy ;
|
||||||
|
|
||||||
|
: bits@ ( slot -- beginning end )
|
||||||
|
[ offset>> ] [ bits>> ] bi dupd + ;
|
||||||
|
|
||||||
M: struct-bit-slot-spec (writer-quot) ( slot -- quot )
|
M: struct-bit-slot-spec (writer-quot) ( slot -- quot )
|
||||||
bits@ '[ [ _ _ ] dip (underlying)>> (write-bits) ] ;
|
bits@ '[ [ _ _ ] dip (underlying)>> (write-bits) ] ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue