Making struct bitfield readers fast

db4
Daniel Ehrenberg 2009-10-07 23:51:18 -05:00
parent 8ba295d8a8
commit 3179dacb3e
2 changed files with 46 additions and 17 deletions

View File

@ -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 ;

View File

@ -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) ] ;