module Feldspar.Core.Constructs.Num
( NUM (..)
) where
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Feldspar.Range
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Literal
data NUM a
where
Abs :: (Type a, Num a, Num (Size a)) => NUM (a :-> Full a)
Sign :: (Type a, Num a, Num (Size a)) => NUM (a :-> Full a)
Add :: (Type a, Num a, Num (Size a)) => NUM (a :-> a :-> Full a)
Sub :: (Type a, Num a, Num (Size a)) => NUM (a :-> a :-> Full a)
Mul :: (Type a, Num a, Num (Size a)) => NUM (a :-> a :-> Full a)
instance Semantic NUM
where
semantics Abs = Sem "abs" abs
semantics Sign = Sem "signum" signum
semantics Add = Sem "(+)" (+)
semantics Sub = Sem "(-)" ()
semantics Mul = Sem "(*)" (*)
instance Equality NUM where equal = equalDefault; exprHash = exprHashDefault
instance Render NUM where renderArgs = renderArgsDefault
instance ToTree NUM
instance Eval NUM where evaluate = evaluateDefault
instance EvalBind NUM where evalBindSym = evalBindSymDefault
instance Sharable NUM
instance AlphaEq dom dom dom env => AlphaEq NUM NUM dom env
where
alphaEqSym = alphaEqSymDefault
instance SizeProp (NUM :|| Type)
where
sizeProp (C' Abs) (WrapFull a :* Nil) = abs (infoSize a)
sizeProp (C' Sign) (WrapFull a :* Nil) = signum (infoSize a)
sizeProp (C' Add) (WrapFull a :* WrapFull b :* Nil) = infoSize a + infoSize b
sizeProp (C' Sub) (WrapFull a :* WrapFull b :* Nil) = infoSize a infoSize b
sizeProp (C' Mul) (WrapFull a :* WrapFull b :* Nil) = infoSize a * infoSize b
instance ( (NUM :|| Type) :<: dom
, (Literal :|| Type) :<: dom
, OptimizeSuper dom
)
=> Optimize (NUM :|| Type) dom
where
constructFeatOpt (C' Abs) (a :* Nil)
| RangeSet r <- infoRange (getInfo a)
, isNatural r
= return a
constructFeatOpt (C' Sign) (a :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, 0 `rangeLess` ra
= return (literalDecor 1)
constructFeatOpt (C' Sign) (a :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, ra `rangeLess` 0
= return (literalDecor (1))
constructFeatOpt (C' Add) (a :* b :* Nil)
| Just 0 <- viewLiteral b = return a
| Just 0 <- viewLiteral a = return b
| alphaEq a b = constructFeatOpt (c' Mul) (a :* literalDecor 2 :* Nil)
constructFeatOpt s@(C' Add) (a :* (op :$ b :$ c) :* Nil)
| Just a' <- viewLiteral a
, Just (C' Add) <- prjF op
, Just c' <- viewLiteral c
= constructFeat s (b :* literalDecor (a'+c') :* Nil)
constructFeatOpt s@(C' Add) (a :* (op :$ b :$ c) :* Nil)
| Just a' <- viewLiteral a
, Just (C' Sub) <- prjF op
, Just c' <- viewLiteral c
= constructFeat s (b :* literalDecor (a'c') :* Nil)
constructFeatOpt s@(C' Add) ((op :$ a :$ b) :* c :* Nil)
| Just c' <- viewLiteral c
, Just (C' Add) <- prjF op
, Just b' <- viewLiteral b
= constructFeat s (a :* literalDecor (b'+c') :* Nil)
constructFeatOpt s@(C' Add) ((op :$ a :$ b) :* c :* Nil)
| Just c' <- viewLiteral c
, Just (C' Sub) <- prjF op
, Just b' <- viewLiteral b
= constructFeat s (a :* literalDecor (c'b') :* Nil)
constructFeatOpt (C' Add) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)
| Just (C' Add) <- prjF op1
, Just (C' Add) <- prjF op2
, Just b' <- viewLiteral b
, Just d' <- viewLiteral d
= do
ac <- constructFeat (c' Add) (a :* c :* Nil)
constructFeat (c' Add) (ac :* literalDecor (b'+d') :* Nil)
constructFeatOpt (C' Add) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)
| Just (C' Add) <- prjF op1
, Just (C' Sub) <- prjF op2
, alphaEq a c
, alphaEq b d
= constructFeat (c' Add) (a :* c :* Nil)
constructFeatOpt (C' Sub) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)
| Just (C' Add) <- prjF op1
, Just (C' Sub) <- prjF op2
, alphaEq a c
, alphaEq b d
= constructFeat (c' Add) (b :* d :* Nil)
constructFeatOpt (C' Sub) (a :* b :* Nil)
| Just 0 <- viewLiteral b = return a
| alphaEq a b = return $ literalDecor 0
constructFeatOpt (C' Mul) (a :* b :* Nil)
| Just 0 <- viewLiteral a = return a
| Just 1 <- viewLiteral a = return b
| Just 0 <- viewLiteral b = return b
| Just 1 <- viewLiteral b = return a
constructFeatOpt s@(C' Mul) (a :* (op :$ b :$ c) :* Nil)
| Just a' <- viewLiteral a
, Just (C' Mul) <- prjF op
, Just c' <- viewLiteral c
= constructFeat s (b :* literalDecor (a'*c') :* Nil)
constructFeatOpt s@(C' Mul) ((op :$ a :$ b) :* c :* Nil)
| Just c' <- viewLiteral c
, Just (C' Mul) <- prjF op
, Just b' <- viewLiteral b
= constructFeat s (a :* literalDecor (b'*c') :* Nil)
constructFeatOpt (C' Mul) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)
| Just (C' Mul) <- prjF op1
, Just (C' Mul) <- prjF op2
, Just b' <- viewLiteral b
, Just d' <- viewLiteral d
= do
ac <- constructFeat (c' Mul) (a :* c :* Nil)
constructFeat (c' Mul) (ac :* literalDecor (b'*d') :* Nil)
constructFeatOpt (C' Add) (a :* b :* Nil)
| Just _ <- viewLiteral a = constructFeatUnOpt (c' Add) (b :* a :* Nil)
constructFeatOpt (C' Mul) (a :* b :* Nil)
| Just _ <- viewLiteral a = constructFeatUnOpt (c' Mul) (b :* a :* Nil)
constructFeatOpt a args = constructFeatUnOpt a args
constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x