-- -- Copyright (c) 2009-2011, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met: -- -- * Redistributions of source code must retain the above copyright notice, -- this list of conditions and the following disclaimer. -- * Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- * Neither the name of the ERICSSON AB nor the names of its contributors -- may be used to endorse or promote products derived from this software -- without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- {-# LANGUAGE UndecidableInstances #-} module Feldspar.Core.Constructs.Bits ( BITS (..) ) where import Data.Hash import Language.Syntactic import Language.Syntactic.Interpretation.Semantics import Language.Syntactic.Constructs.Binding import Feldspar.Range import Feldspar.Lattice import Feldspar.Core.Types import Feldspar.Core.Interpretation import Data.Bits data BITS a where BAnd :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> a :-> Full a) BOr :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> a :-> Full a) BXor :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> a :-> Full a) Complement :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full a) Bit :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (Index :-> Full a) SetBit :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a) ClearBit :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a) ComplementBit :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a) TestBit :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full Bool) ShiftLU :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a) ShiftRU :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a) ShiftL :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> IntN :-> Full a) ShiftR :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> IntN :-> Full a) RotateLU :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a) RotateRU :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a) RotateL :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> IntN :-> Full a) RotateR :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> IntN :-> Full a) ReverseBits :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full a) BitScan :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Index) BitCount :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Index) BitSize :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Index) IsSigned :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Bool) instance WitnessCons BITS where witnessCons BAnd = ConsWit witnessCons BOr = ConsWit witnessCons BXor = ConsWit witnessCons Complement = ConsWit witnessCons Bit = ConsWit witnessCons SetBit = ConsWit witnessCons ClearBit = ConsWit witnessCons ComplementBit = ConsWit witnessCons TestBit = ConsWit witnessCons ShiftLU = ConsWit witnessCons ShiftRU = ConsWit witnessCons ShiftL = ConsWit witnessCons ShiftR = ConsWit witnessCons RotateLU = ConsWit witnessCons RotateRU = ConsWit witnessCons RotateL = ConsWit witnessCons RotateR = ConsWit witnessCons ReverseBits = ConsWit witnessCons BitScan = ConsWit witnessCons BitCount = ConsWit witnessCons BitSize = ConsWit witnessCons IsSigned = ConsWit instance WitnessSat BITS where type SatContext BITS = TypeCtx witnessSat BAnd = SatWit witnessSat BOr = SatWit witnessSat BXor = SatWit witnessSat Complement = SatWit witnessSat Bit = SatWit witnessSat SetBit = SatWit witnessSat ClearBit = SatWit witnessSat ComplementBit = SatWit witnessSat TestBit = SatWit witnessSat ShiftLU = SatWit witnessSat ShiftRU = SatWit witnessSat ShiftL = SatWit witnessSat ShiftR = SatWit witnessSat RotateLU = SatWit witnessSat RotateRU = SatWit witnessSat RotateL = SatWit witnessSat RotateR = SatWit witnessSat ReverseBits = SatWit witnessSat BitScan = SatWit witnessSat BitCount = SatWit witnessSat BitSize = SatWit witnessSat IsSigned = SatWit instance MaybeWitnessSat TypeCtx BITS where maybeWitnessSat = maybeWitnessSatDefault instance Semantic BITS where semantics BAnd = Sem "(.&.)" (.&.) semantics BOr = Sem "(.|.)" (.|.) semantics BXor = Sem "xor" xor semantics Complement = Sem "complement" complement semantics Bit = Sem "bit" (bit . fromIntegral) semantics SetBit = Sem "setBit" (liftIntWord setBit) semantics ClearBit = Sem "clearBit" (liftIntWord clearBit) semantics ComplementBit = Sem "complementBit" (liftIntWord complementBit) semantics TestBit = Sem "testBit" (liftIntWord testBit) semantics ShiftLU = Sem "shiftL" (liftIntWord shiftL) semantics ShiftRU = Sem "shiftR" (liftIntWord shiftR) semantics ShiftL = Sem "shiftL" (liftInt shiftL) semantics ShiftR = Sem "shiftR" (liftInt shiftR) semantics RotateLU = Sem "rotateL" (liftIntWord rotateL) semantics RotateRU = Sem "rotateR" (liftIntWord rotateR) semantics RotateL = Sem "rotateL" (liftInt rotateL) semantics RotateR = Sem "rotateR" (liftInt rotateR) semantics ReverseBits = Sem "reverseBits" evalReverseBits semantics BitScan = Sem "bitScan" evalBitScan semantics BitCount = Sem "bitCount" evalBitCount semantics BitSize = Sem "bitSize" (fromIntegral . bitSize) semantics IsSigned = Sem "isSigned" isSigned liftIntWord :: (a -> Int -> b) -> (a -> WordN -> b) liftIntWord f x = f x . fromIntegral liftInt :: (a -> Int -> b) -> (a -> IntN -> b) liftInt f x = f x . fromIntegral evalReverseBits :: Bits b => b -> b evalReverseBits b = revLoop b 0 (0 `asTypeOf` b) where bSz = bitSize b revLoop b i n | i >= bSz = n revLoop b i n | testBit b i = revLoop b (i+1) (setBit n (bSz - i - 1)) revLoop b i n | otherwise = revLoop b (i+1) n evalBitScan :: Bits b => b -> WordN evalBitScan b = if isSigned b then scanLoop b (testBit b (bitSize b - 1)) (bitSize b - 2) 0 else scanLoop b False (bitSize b - 1) 0 where scanLoop b bit i n | i Prelude.< 0 = n scanLoop b bit i n | testBit b i Prelude./= bit = n scanLoop b bit i n | otherwise = scanLoop b bit (i-1) (n+1) evalBitCount :: Bits b => b -> WordN evalBitCount b = loop b (bitSize b - 1) 0 where loop b i n | i Prelude.< 0 = n loop b i n | testBit b i = loop b (i-1) (n+1) loop b i n | otherwise = loop b (i-1) n instance ExprEq BITS where exprEq = exprEqSem; exprHash = exprHashSem instance Render BITS where renderPart = renderPartSem instance ToTree BITS instance Eval BITS where evaluate = evaluateSem instance EvalBind BITS where evalBindSym = evalBindSymDefault instance Sharable BITS instance AlphaEq dom dom dom env => AlphaEq BITS BITS dom env where alphaEqSym = alphaEqSymDefault instance SizeProp BITS where sizeProp BAnd (WrapFull a :* WrapFull b :* Nil) = rangeAnd (infoSize a) (infoSize b) sizeProp BOr (WrapFull a :* WrapFull b :* Nil) = rangeOr (infoSize a) (infoSize b) sizeProp BXor (WrapFull a :* WrapFull b :* Nil) = rangeXor (infoSize a) (infoSize b) sizeProp ShiftLU (WrapFull a :* WrapFull b :* Nil) = rangeShiftLU (infoSize a) (infoSize b) sizeProp ShiftRU (WrapFull a :* WrapFull b :* Nil) = rangeShiftRU (infoSize a) (infoSize b) sizeProp a args = sizePropDefault a args instance (BITS :<: dom, Optimize dom dom) => Optimize BITS dom where constructFeatOpt BAnd (a :* b :* Nil) | Just 0 <- viewLiteral a = return a | Just x <- viewLiteral a, isAllOnes x = return b | Just 0 <- viewLiteral b = return b | Just x <- viewLiteral b, isAllOnes x = return a constructFeatOpt BOr (a :* b :* Nil) | Just 0 <- viewLiteral a = return b | Just x <- viewLiteral a, isAllOnes x = return a | Just 0 <- viewLiteral b = return a | Just x <- viewLiteral b, isAllOnes x = return b constructFeatOpt BXor (a :* b :* Nil) | Just 0 <- viewLiteral a = return b | Just x <- viewLiteral a, isAllOnes x = constructFeat Complement (b :* Nil) | Just 0 <- viewLiteral b = return a | Just x <- viewLiteral b, isAllOnes x = constructFeat Complement (a :* Nil) constructFeatOpt ShiftLU args = optZero ShiftLU args constructFeatOpt ShiftRU args = optZero ShiftRU args constructFeatOpt ShiftL args = optZero ShiftL args constructFeatOpt ShiftR args = optZero ShiftR args constructFeatOpt RotateLU args = optZero RotateLU args constructFeatOpt RotateRU args = optZero RotateRU args constructFeatOpt RotateL args = optZero RotateL args constructFeatOpt RotateR args = optZero RotateR args constructFeatOpt feat args = constructFeatUnOpt feat args constructFeatUnOpt = constructFeatUnOptDefault isAllOnes :: Bits a => a -> Bool isAllOnes x = x Prelude.== complement 0 optZero f (a :* b :* Nil) | Just 0 <- viewLiteral b = return a | otherwise = constructFeatUnOpt f (a :* b :* Nil)