From e0408b9b10cde28bf1c201fbc0957a4012bc8ab4 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Wed, 7 Oct 2009 01:43:32 -0500
Subject: [PATCH 01/10] Adding bit fields to STRUCT:

---
 basis/classes/struct/struct-tests.factor |  5 ++
 basis/classes/struct/struct.factor       | 99 ++++++++++++++++++++++--
 2 files changed, 97 insertions(+), 7 deletions(-)

diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor
index a026417171..b59fc4577c 100755
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@@ -352,3 +352,8 @@ 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 } ;
diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index beddf07dd5..f8bdac530e 100755
--- a/basis/classes/struct/struct.factor
+++ b/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,11 +6,29 @@ 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 bit-arrays ;
+QUALIFIED: math
 IN: classes.struct
 
 SPECIALIZED-ARRAY: uchar
 
+<PRIVATE
+
+TUPLE: bits size signed? ;
+C: <bits> bits
+
+M: bits heap-size size>> 8 / ;
+
+M: bits c-type-align drop 1/8 ;
+
+: align ( m w -- n )
+    ! Really, you could write 'align' correctly
+    ! for any real w; this is just a hack
+    ! that only works here
+    dup integer? [ [ ceiling ] dip math:align ] [ drop ] if ;
+
+PRIVATE>
+
 ERROR: struct-must-have-slots ;
 
 M: struct-must-have-slots summary
@@ -84,14 +102,56 @@ 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 )
+: read-normal ( slot -- quot )
     [ type>> c-type-getter-boxer ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
-: (writer-quot) ( slot -- quot )
+: bits@ ( slot -- beginning end )
+    [ offset>> 8 * ] [ type>> size>> ] 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' )
+    ! formula from:
+    ! http://guru.multimedia.cx/fast-sign-extension/
+    1 - -1 swap shift [ + ] keep bitxor ; inline
+
+: read-bits ( slot -- quot )
+    [ bits@ ] [ type>> signed?>> ] [ type>> size>> ] tri '[
+        [ _ _ ] dip (underlying)>> (read-bits)
+        _ [ _ sign-extend ] when
+    ] ;
+
+: (reader-quot) ( slot -- quot )
+    dup type>> bits? [ read-bits ] [ read-normal ] if ;
+
+: write-normal ( slot -- quot )
     [ type>> c-setter ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
+: overwrite ( donor victim -- )
+    0 swap copy ;
+
+: (write-bits) ( value offset end byte-array -- )
+    ! This is absurdly inefficient
+    [
+        [ [ swap - math.bits:<bits> ] 2keep ] [ bytes>bits ] bi*
+        replace-slice ?{ } like underlying>>
+    ] keep overwrite ;
+
+: write-bits ( slot -- quot )
+    bits@ '[ [ _ _ ] dip (underlying)>> (write-bits) ] ;
+
+: (writer-quot) ( slot -- quot )
+    dup type>> bits? [ write-bits ] [ write-normal ] if ;
+
 : (boxer-quot) ( class -- quot )
     '[ _ memory>struct ] ;
 
@@ -196,10 +256,10 @@ M: struct-c-type c-struct? drop t ;
     ] 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 ;
+    1 [ type>> c-type-align max ] reduce ;
 PRIVATE>
 
 M: struct byte-length class "struct-size" word-prop ; foldable
@@ -273,11 +333,36 @@ 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 )
+    over type>> {
+        { int [ t ] }
+        { uint [ f ] }
+        [ bad-type-for-bits ]
+    } case <bits> >>type ;
+
+: 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 )

From 1a2c137e412df8bdc7d48d15dc54e4378cd8575d Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Wed, 7 Oct 2009 21:35:12 -0500
Subject: [PATCH 02/10] Refactoring bitfields to not use number tower

---
 basis/classes/struct/struct-tests.factor |  8 +++
 basis/classes/struct/struct.factor       | 91 +++++++++++-------------
 2 files changed, 50 insertions(+), 49 deletions(-)

diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor
index b59fc4577c..58ab2df80b 100755
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@@ -357,3 +357,11 @@ 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
diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index f8bdac530e..df0e07c964 100755
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -12,23 +12,6 @@ IN: classes.struct
 
 SPECIALIZED-ARRAY: uchar
 
-<PRIVATE
-
-TUPLE: bits size signed? ;
-C: <bits> bits
-
-M: bits heap-size size>> 8 / ;
-
-M: bits c-type-align drop 1/8 ;
-
-: align ( m w -- n )
-    ! Really, you could write 'align' correctly
-    ! for any real w; this is just a hack
-    ! that only works here
-    dup integer? [ [ ceiling ] dip math:align ] [ drop ] if ;
-
-PRIVATE>
-
 ERROR: struct-must-have-slots ;
 
 M: struct-must-have-slots summary
@@ -40,6 +23,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? ;
 
@@ -102,19 +89,15 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 : pad-struct-slots ( values class -- values' class )
     [ struct-slots [ initial>> ] map over length tail append ] keep ;
 
-: read-normal ( slot -- quot )
-    [ type>> c-type-getter-boxer ]
-    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
-
 : bits@ ( slot -- beginning end )
-    [ offset>> 8 * ] [ type>> size>> ] bi dupd + ;
+    [ 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 )
+: read-bits ( beginning end byte-array -- n )
     ! This is absurdly inefficient
     bytes>bits subseq bit-array>integer ;
 
@@ -123,35 +106,34 @@ QUALIFIED: math.bits
     ! http://guru.multimedia.cx/fast-sign-extension/
     1 - -1 swap shift [ + ] keep bitxor ; inline
 
-: read-bits ( slot -- quot )
-    [ bits@ ] [ type>> signed?>> ] [ type>> size>> ] tri '[
-        [ _ _ ] dip (underlying)>> (read-bits)
+GENERIC: (reader-quot) ( slot -- quot )
+
+M: struct-slot-spec (reader-quot)
+    [ type>> c-type-getter-boxer ]
+    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+
+M: struct-bit-slot-spec (reader-quot)
+    [ bits@ ] [ signed?>> ] [ bits>> ] tri '[
+        [ _ _ ] dip (underlying)>> read-bits
         _ [ _ sign-extend ] when
     ] ;
 
-: (reader-quot) ( slot -- quot )
-    dup type>> bits? [ read-bits ] [ read-normal ] if ;
+GENERIC: (writer-quot) ( slot -- quot )
 
-: write-normal ( slot -- quot )
+M: struct-slot-spec (writer-quot)
     [ type>> c-setter ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
-: overwrite ( donor victim -- )
-    0 swap copy ;
-
 : (write-bits) ( value offset end byte-array -- )
     ! This is absurdly inefficient
     [
         [ [ swap - math.bits:<bits> ] 2keep ] [ bytes>bits ] bi*
         replace-slice ?{ } like underlying>>
-    ] keep overwrite ;
+    ] keep 0 swap copy ;
 
-: write-bits ( slot -- quot )
+M: struct-bit-slot-spec (writer-quot) ( slot -- quot )
     bits@ '[ [ _ _ ] dip (underlying)>> (write-bits) ] ;
 
-: (writer-quot) ( slot -- quot )
-    dup type>> bits? [ write-bits ] [ write-normal ] if ;
-
 : (boxer-quot) ( class -- quot )
     '[ _ memory>struct ] ;
 
@@ -246,19 +228,23 @@ 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 )
     1 [ 0 >>offset type>> heap-size max ] reduce ;
 
 : struct-align ( slots -- align )
+    [ struct-bit-slot-spec? not ] filter
     1 [ type>> c-type-align max ] reduce ;
 PRIVATE>
 
@@ -339,12 +325,19 @@ SYMBOL: bits:
 
 ERROR: bad-type-for-bits type ;
 
-: set-bits ( slot-spec n -- slot-spec )
-    over type>> {
-        { int [ t ] }
-        { uint [ f ] }
-        [ bad-type-for-bits ]
-    } case <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? [

From 4e1aa8f638505028801f33dbef00b00377f785cf Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Wed, 7 Oct 2009 21:42:15 -0500
Subject: [PATCH 03/10] Modifying the struct prettyprinter to display bits

---
 basis/classes/struct/prettyprint/prettyprint.factor | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor
index 43d24e5716..b7b51432dd 100644
--- a/basis/classes/struct/prettyprint/prettyprint.factor
+++ b/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> ;
 

From 3179dacb3e4ad507b4746ac8a748f6de334513cc Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Wed, 7 Oct 2009 23:51:18 -0500
Subject: [PATCH 04/10] Making struct bitfield readers fast

---
 .../struct/bit-accessors/bit-accessors.factor | 29 ++++++++++++++++
 basis/classes/struct/struct.factor            | 34 +++++++++----------
 2 files changed, 46 insertions(+), 17 deletions(-)
 create mode 100644 basis/classes/struct/bit-accessors/bit-accessors.factor

diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor
new file mode 100644
index 0000000000..9d625beab3
--- /dev/null
+++ b/basis/classes/struct/bit-accessors/bit-accessors.factor
@@ -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 ;
diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index df0e07c964..6593e8350d 100755
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -6,7 +6,8 @@ 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 math.functions bit-arrays ;
+summary namespaces assocs vocabs.parser math.functions
+classes.struct.bit-accessors bit-arrays ;
 QUALIFIED: math
 IN: classes.struct
 
@@ -89,23 +90,14 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 : pad-struct-slots ( values class -- values' class )
     [ 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' )
     ! 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)
@@ -113,10 +105,10 @@ M: struct-slot-spec (reader-quot)
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 M: struct-bit-slot-spec (reader-quot)
-    [ bits@ ] [ signed?>> ] [ bits>> ] tri '[
-        [ _ _ ] dip (underlying)>> read-bits
-        _ [ _ sign-extend ] when
-    ] ;
+    [ [ offset>> ] [ bits>> ] bi bit-reader ]
+    [ [ signed?>> ] [ bits>> ] bi sign-extender ]
+    bi compose
+    [ >c-ptr ] prepose ;
 
 GENERIC: (writer-quot) ( slot -- quot )
 
@@ -124,6 +116,11 @@ 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
     [
@@ -131,6 +128,9 @@ M: struct-slot-spec (writer-quot)
         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) ] ;
 

From eb31589092b7c01eb88667b1d59885ecfcc050fd Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Thu, 8 Oct 2009 00:59:15 -0500
Subject: [PATCH 05/10] Adding identity to propagation to remove some redundant
 bitands

---
 .../tree/propagation/propagation-tests.factor    |  3 +++
 .../propagation/transforms/transforms.factor     | 16 ++++++++++++++++
 2 files changed, 19 insertions(+)

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 92964654bf..c1b6691542 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -899,3 +899,6 @@ 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
diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 8aa6a821d8..08ac306248 100644
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -45,6 +45,14 @@ IN: compiler.tree.propagation.transforms
 : simplify-bitand? ( value -- ? )
     value-info literal>> positive-fixnum? ;
 
+: redundant-bitand? ( var 111... -- ? )
+    [ value-info ] bi@ { [
+        nip literal>>
+        { [ positive-fixnum? ] [ dup 1 + bitand zero? ] } 1&&
+    ] [
+        [ interval>> ] [ literal>> ] bi* 0 swap [a,b] interval-subset?
+    ] } 2&& ;
+
 {
     bitand-integer-integer
     bitand-integer-fixnum
@@ -53,6 +61,14 @@ IN: compiler.tree.propagation.transforms
 } [
     [
         {
+            {
+                [ 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 ] ]

From 2db25b937eee673d0c54d9a06b7918e449d36662 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Thu, 8 Oct 2009 01:57:54 -0500
Subject: [PATCH 06/10] Doing constant folding on ##neg and ##not in value
 numbering

---
 .../value-numbering/rewrite/rewrite.factor    | 24 +++++++++++++++-
 .../value-numbering-tests.factor              | 28 +++++++++++++++++++
 2 files changed, 51 insertions(+), 1 deletion(-)

diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 56ec16eed6..4a63777019 100755
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/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 )
     [
         {
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 5f8eda2c08..f98824cb95 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/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
 

From db927ff0ad1aecbfcc0fcc10034c1b6060d21b13 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Thu, 8 Oct 2009 13:10:51 -0500
Subject: [PATCH 07/10] Making struct bitfield writers fast

---
 .../bit-accessors/bit-accessors-tests.factor  |  7 +++++
 .../struct/bit-accessors/bit-accessors.factor | 30 ++++++++++++++++---
 basis/classes/struct/struct.factor            | 20 ++-----------
 3 files changed, 36 insertions(+), 21 deletions(-)
 create mode 100644 basis/classes/struct/bit-accessors/bit-accessors-tests.factor

diff --git a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor
new file mode 100644
index 0000000000..e2ff6dbd9c
--- /dev/null
+++ b/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
diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor
index 9d625beab3..04757a233a 100644
--- a/basis/classes/struct/bit-accessors/bit-accessors.factor
+++ b/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 ;
diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index 6593e8350d..af23834383 100755
--- a/basis/classes/struct/struct.factor
+++ b/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 ] ;

From 8841969ca1bb0cd410dae32426fca28c252ec47c Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Thu, 8 Oct 2009 13:45:52 -0500
Subject: [PATCH 08/10] Refactoring bitfield accessors to eliminate code
 duplication

---
 .../struct/bit-accessors/bit-accessors.factor | 56 +++++++++----------
 1 file changed, 28 insertions(+), 28 deletions(-)

diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor
index 04757a233a..30620b46c1 100644
--- a/basis/classes/struct/bit-accessors/bit-accessors.factor
+++ b/basis/classes/struct/bit-accessors/bit-accessors.factor
@@ -9,43 +9,43 @@ IN: classes.struct.bit-accessors
 : ones-between ( start end -- n )
     [ 2^ 1 - ] bi@ swap bitnot bitand ;
 
-: ones-around ( start end -- n )
-    ones-between bitnot ;
-
-:: read-bits ( offset bits -- quot: ( alien -- n ) shift-amount offset' bits' )
+:: 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 alien-unsigned-1 mask bitand start-bit neg shift ]
+    start-bit i end-bit mask step-quot call( a b c d -- quot )
     used-bits
     i 1 + 8 *
-    bits used-bits - ;
+    bits used-bits - ; inline
+
+:: bit-manipulator ( offset bits
+                    step-quot: ( start-bit i end-bit mask -- 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 ) )
-    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
+    [| start-bit i end-bit mask |
+        [ i alien-unsigned-1 mask bitand start-bit neg shift ]
     ]
-    used-bits
-    i 1 + 8 *
-    bits used-bits - ;
+    [ swap '[ _ _ bi _ shift bitor ] ]
+    bit-manipulator ;
 
 : bit-writer ( offset bits -- quot: ( n alien -- ) )
-    write-bits dup zero? [ 3drop ] [
-        bit-writer '[ _ [ [ _ neg shift ] dip @ ] 2bi ]
-    ] if ;
+    [| start-bit i end-bit mask |
+        [
+            [
+                [ start-bit shift mask bitand ]
+                [ i alien-unsigned-1 mask bitnot bitand ]
+                bi* bitor
+            ] keep i set-alien-unsigned-1
+        ]
+    ]
+    [ '[ _ [ [ _ neg shift ] dip @ ] 2bi ] ]
+    bit-manipulator ;

From 891b7c98044aba1f2522b7c8038cb3742b2d8a46 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Thu, 8 Oct 2009 14:01:43 -0500
Subject: [PATCH 09/10] Cleaning up classes.struct.bit-accessors code

---
 .../struct/bit-accessors/bit-accessors.factor | 23 ++++++++-----------
 1 file changed, 9 insertions(+), 14 deletions(-)

diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor
index 30620b46c1..7a2fdb0cac 100644
--- a/basis/classes/struct/bit-accessors/bit-accessors.factor
+++ b/basis/classes/struct/bit-accessors/bit-accessors.factor
@@ -15,13 +15,13 @@ IN: classes.struct.bit-accessors
     start-bit end-bit ones-between :> mask
     end-bit start-bit - :> used-bits
 
-    start-bit i end-bit mask step-quot call( a b c d -- quot )
+    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: ( start-bit i end-bit mask -- quot )
+                    step-quot: ( i mask start-bit -- quot )
                     combine-quot: ( prev-quot shift-amount next-quot -- quot )
                     -- quot )
     offset bits step-quot manipulate-bits
@@ -31,21 +31,16 @@ IN: classes.struct.bit-accessors
     ] if ; inline recursive
 
 : bit-reader ( offset bits -- quot: ( alien -- n ) )
-    [| start-bit i end-bit mask |
-        [ i alien-unsigned-1 mask bitand start-bit neg shift ]
-    ]
+    [ 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 -- ) )
-    [| start-bit i end-bit mask |
-        [
-            [
-                [ start-bit shift mask bitand ]
-                [ i alien-unsigned-1 mask bitnot bitand ]
-                bi* bitor
-            ] keep i set-alien-unsigned-1
-        ]
-    ]
+    [ '[ _ _ _ write-bits ] ]
     [ '[ _ [ [ _ neg shift ] dip @ ] 2bi ] ]
     bit-manipulator ;

From bb9354305426be1189e6d2d9120f50ba4b4bdb4e Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Thu, 8 Oct 2009 15:20:42 -0500
Subject: [PATCH 10/10] Another identity in value numbering for bitfields

---
 .../struct/bit-accessors/bit-accessors.factor |  2 +-
 .../tree/propagation/propagation-tests.factor |  4 +++
 .../propagation/transforms/transforms.factor  | 29 +++++++++++++++----
 3 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor
index 7a2fdb0cac..c535e52c0a 100644
--- a/basis/classes/struct/bit-accessors/bit-accessors.factor
+++ b/basis/classes/struct/bit-accessors/bit-accessors.factor
@@ -4,7 +4,7 @@ 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
+! Why not? It's unspecified in C
 
 : ones-between ( start end -- n )
     [ 2^ 1 - ] bi@ swap bitnot bitand ;
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index c1b6691542..0a8cb61a9f 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -902,3 +902,7 @@ M: tuple-with-read-only-slot clone
 
 [ 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
diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 08ac306248..b8ff96f833 100644
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -45,13 +45,26 @@ 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@ { [
-        nip literal>>
-        { [ positive-fixnum? ] [ dup 1 + bitand zero? ] } 1&&
-    ] [
-        [ interval>> ] [ literal>> ] bi* 0 swap [a,b] interval-subset?
-    ] } 2&& ;
+    [ 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
@@ -61,6 +74,10 @@ IN: compiler.tree.propagation.transforms
 } [
     [
         {
+            {
+                [ dup in-d>> first2 zero-bitand? ]
+                [ drop [ 2drop 0 ] ]
+            }
             {
                 [ dup in-d>> first2 redundant-bitand? ]
                 [ drop [ drop ] ]