Making struct bitfield writers fast

basis/classes/struct/bit-accessors/bit-accessors-tests.factor

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

basis/classes/struct/bit-accessors/bit-accessors.factor

@@ -9,15 +9,15 @@ IN: classes.struct.bit-accessors
 : ones-between ( start end -- n )
     [ 2^ 1 - ] bi@ swap bitnot bitand ;
 
-:: read-bits ( offset bits -- quot: ( byte-array -- n ) shift-amount offset' bits' )
+: ones-around ( start end -- n )
+    ones-between bitnot ;
+
+:: read-bits ( offset bits -- quot: ( alien -- 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 *
@@ -27,3 +27,25 @@ IN: classes.struct.bit-accessors
     read-bits dup zero? [ 3drop ] [
         bit-reader swap '[ _ _ bi _ shift bitor ]
     ] if ;
+
+:: write-bits ( offset bits -- quot: ( alien -- 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
+
+    [
+        [
+            [ start-bit shift mask bitand ]
+            [ i alien-unsigned-1 mask bitnot bitand ]
+            bi* bitor
+        ] keep i set-alien-unsigned-1
+    ]
+    used-bits
+    i 1 + 8 *
+    bits used-bits - ;
+
+: bit-writer ( offset bits -- quot: ( n alien -- ) )
+    write-bits dup zero? [ 3drop ] [
+        bit-writer '[ _ [ [ _ neg shift ] dip @ ] 2bi ]
+    ] if ;

basis/classes/struct/struct.factor

@@ -116,23 +116,9 @@ M: struct-slot-spec (writer-quot)
     [ type>> c-setter ]
     [ 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 -- )
-    ! This is absurdly inefficient
-    [
-        [ [ swap - math.bits:<bits> ] 2keep ] [ bytes>bits ] bi*
-        replace-slice ?{ } like underlying>>
-    ] keep 0 swap copy ;
-
-: bits@ ( slot -- beginning end )
-    [ offset>> ] [ bits>> ] bi dupd + ;
-
-M: struct-bit-slot-spec (writer-quot) ( slot -- quot )
-    bits@ '[ [ _ _ ] dip (underlying)>> (write-bits) ] ;
+M: struct-bit-slot-spec (writer-quot)
+    [ offset>> ] [ bits>> ] bi bit-writer
+    [ >c-ptr ] prepose ;
 
 : (boxer-quot) ( class -- quot )
     '[ _ memory>struct ] ;