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 new file mode 100644 index 0000000000..c535e52c0a --- /dev/null +++ b/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 ; 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> ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index a026417171..58ab2df80b 100755 --- a/basis/classes/struct/struct-tests.factor +++ b/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 ] unit-test +[ S{ bit-field-test f 1 -2 3 } ] [ bit-field-test 1 >>a 2 >>b 3 >>c ] unit-test +[ 4095 ] [ bit-field-test 8191 >>a a>> ] unit-test +[ 1 ] [ bit-field-test 1 >>b b>> ] unit-test +[ -2 ] [ bit-field-test 2 >>b b>> ] unit-test +[ 1 ] [ bit-field-test 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 beddf07dd5..af23834383 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,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: ( 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' ) - 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 ) - [ 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: + +>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> + : ( 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* ; > 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 diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 92964654bf..0a8cb61a9f 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/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* ] { } inlined? ] unit-test [ V{ void*-array } ] [ [ void* ] 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 diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 8aa6a821d8..b8ff96f833 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/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 ] ]