module Feldspar.Core.Constructs.Integral
( INTEGRAL (..)
) where
import Data.Bits
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Condition
import Feldspar.Range
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Bits
import Feldspar.Core.Constructs.Eq
import Feldspar.Core.Constructs.Ord
import Feldspar.Core.Constructs.Num
import Feldspar.Core.Constructs.Logic
data INTEGRAL a
where
Quot :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)
Rem :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)
Div :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)
Mod :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)
Exp :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)
instance Semantic INTEGRAL
where
semantics Quot = Sem "quot" quot
semantics Rem = Sem "rem" rem
semantics Div = Sem "div" div
semantics Mod = Sem "mod" mod
semantics Exp = Sem "(^)" (^)
instance Equality INTEGRAL where equal = equalDefault; exprHash = exprHashDefault
instance Render INTEGRAL where renderArgs = renderArgsDefault
instance ToTree INTEGRAL
instance Eval INTEGRAL where evaluate = evaluateDefault
instance EvalBind INTEGRAL where evalBindSym = evalBindSymDefault
instance Sharable INTEGRAL
instance AlphaEq dom dom dom env => AlphaEq INTEGRAL INTEGRAL dom env
where
alphaEqSym = alphaEqSymDefault
instance SizeProp (INTEGRAL :|| Type)
where
sizeProp (C' Quot) (WrapFull a :* WrapFull b :* Nil) = rangeQuot (infoSize a) (infoSize b)
sizeProp (C' Rem) (WrapFull a :* WrapFull b :* Nil) = rangeRem (infoSize a) (infoSize b)
sizeProp (C' Div) (WrapFull a :* WrapFull b :* Nil) = rangeDiv (infoSize a) (infoSize b)
sizeProp (C' Mod) (WrapFull a :* WrapFull b :* Nil) = rangeMod (infoSize a) (infoSize b)
sizeProp (C' Exp) (WrapFull a :* WrapFull b :* Nil) = rangeExp (infoSize a) (infoSize b)
instance
( (INTEGRAL :||Type) :<: dom
, (BITS :||Type) :<: dom
, (NUM :||Type) :<: dom
, (EQ :||Type) :<: dom
, (ORD :||Type) :<: dom
, (Condition :||Type) :<: dom
, (Logic :||Type) :<: dom
, OptimizeSuper dom
, Optimize (Condition :|| Type) dom
) =>
Optimize (INTEGRAL :|| Type) dom
where
constructFeatOpt (C' Quot) (a :* b :* Nil)
| Just 1 <- viewLiteral b = return a
constructFeatOpt (C' Quot) (a :* b :* Nil)
| Just b' <- viewLiteral b
, b' > 0
, isPowerOfTwo b'
, let l = log2 b'
, let lLit = literalDecor l
= if isNatural $ infoSize $ getInfo a
then constructFeat (c' ShiftR) (a :* lLit :* Nil)
else do
aIsNeg <- constructFeat (c' LTH) (a :* literalDecor 0 :* Nil)
a' <- constructFeat (c' Add) (a :* literalDecor (2^l1) :* Nil)
negCase <- constructFeat (c' ShiftR) (a' :* lLit :* Nil)
posCase <- constructFeat (c' ShiftR) (a :* lLit :* Nil)
constructFeat (c' Condition)
(aIsNeg :* negCase :* posCase :* Nil)
constructFeatOpt (C' Rem) (a :* b :* Nil)
| rangeLess sza szb
, isNatural sza
= return a
where
sza = infoSize $ getInfo a
szb = infoSize $ getInfo b
constructFeatOpt (C' Div) (a :* b :* Nil)
| Just 1 <- viewLiteral b = return a
constructFeatOpt (C' Div) (a :* b :* Nil)
| Just b' <- viewLiteral b
, b' > 0
, isPowerOfTwo b'
= constructFeat (c' ShiftR) (a :* literalDecor (log2 b') :* Nil)
constructFeatOpt (C' Div) (a :* b :* Nil)
| sameSign (infoSize (getInfo a)) (infoSize (getInfo b))
= constructFeat (c' Quot) (a :* b :* Nil)
constructFeatOpt (C' Mod) (a :* b :* Nil)
| rangeLess sza szb
, isNatural sza
= return a
where
sza = infoSize $ getInfo a
szb = infoSize $ getInfo b
constructFeatOpt (C' Mod) (a :* b :* Nil)
| sameSign (infoSize (getInfo a)) (infoSize (getInfo b))
= constructFeat (c' Rem) (a :* b :* Nil)
constructFeatOpt (C' Exp) (a :* b :* Nil)
| Just 1 <- viewLiteral a = return $ literalDecor 1
| Just 0 <- viewLiteral a = return $ literalDecor 0
| Just 1 <- viewLiteral b = return a
| Just 0 <- viewLiteral b = return $ literalDecor 1
constructFeatOpt (C' Exp) (a :* b :* Nil)
| Just (1) <- viewLiteral a = do
bLSB <- constructFeat (c' BAnd) (b :* literalDecor 1 :* Nil)
bIsEven <- constructFeat (c' Equal) (bLSB :* literalDecor 0 :* Nil)
constructFeat (c' Condition)
(bIsEven :* literalDecor 1 :* literalDecor (1) :* Nil)
constructFeatOpt a args = constructFeatUnOpt a args
constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x
isPowerOfTwo :: (Num a, Bits a) => a -> Bool
isPowerOfTwo x = x .&. (x 1) == 0 && (x /= 0)
log2 :: (BoundedInt a, Integral b) => a -> b
log2 v | v <= 1 = 0
log2 v = 1 + log2 (shiftR v 1)
sameSign :: BoundedInt a => Range a -> Range a -> Bool
sameSign ra rb
= isNatural ra && isNatural rb
|| isNegative ra && isNegative rb