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

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

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

basis/classes/struct/prettyprint/prettyprint.factor

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

basis/classes/struct/struct-tests.factor

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

basis/classes/struct/struct.factor

@@ -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' )
+GENERIC: align-offset ( offset class -- offset' )
-    c-type-align align ;
+
+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 [
+    0 [ align-offset ] reduce 8 align 8 /i ;
-        [ type>> align-offset ] keep
-        [ (>>offset) ] [ type>> heap-size + ] 2bi
-    ] reduce ;
 
 : 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 )

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -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 )
     [
         {

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

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

basis/compiler/tree/propagation/propagation-tests.factor

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

basis/compiler/tree/propagation/transforms/transforms.factor

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