module Feldspar.Core.Constructs.Array
where
import Data.List
import Data.Map (notMember)
import Language.Syntactic
import Language.Syntactic.Constructs.Binding hiding (betaReduce)
import Language.Syntactic.Constructs.Binding.HigherOrder (CLambda)
import Feldspar.Range
import Feldspar.Lattice
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Binding
import Feldspar.Core.Constructs.Num
import Feldspar.Core.Constructs.Ord
data Array a
where
Parallel :: Type a => Array (Length :-> (Index -> a) :-> Full [a])
Sequential :: (Type a, Type st) =>
Array (Length :-> st :-> (Index -> st -> (a,st)) :-> Full [a])
Append :: Type a => Array ([a] :-> [a] :-> Full [a])
GetIx :: Type a => Array ([a] :-> Index :-> Full a)
SetIx :: Type a => Array ([a] :-> Index :-> a :-> Full [a])
GetLength :: Type a => Array ([a] :-> Full Length)
SetLength :: Type a => Array (Length :-> [a] :-> Full [a])
instance Semantic Array
where
semantics Append = Sem "(++)" (++)
semantics GetIx = Sem "(!)" genericIndex
semantics GetLength = Sem "getLength" genericLength
semantics SetLength = Sem "setLength"
(\n as -> genericTake n (as ++ repeat err))
where
err = error "reading uninitialized array element"
semantics Parallel = Sem "parallel"
(\len ixf -> genericTake len $ map ixf [0..])
semantics Sequential = Sem "sequential"
(\len i step -> genericTake len $
snd $ mapAccumL (\a ix -> swap (step ix a)) i [0..])
where swap (a,b) = (b,a)
semantics SetIx = Sem "setIx" evalSetIx
where
evalSetIx as i v
| i < len = genericTake i as ++ [v] ++ genericDrop (i+1) as
| otherwise = error $ unwords
[ "setIx: assigning index"
, show i
, "past the end of an array of length"
, show len
]
where
len = genericLength as
instance Equality Array where equal = equalDefault; exprHash = exprHashDefault
instance Render Array where renderArgs = renderArgsDefault
instance ToTree Array
instance Eval Array where evaluate = evaluateDefault
instance EvalBind Array where evalBindSym = evalBindSymDefault
instance AlphaEq dom dom dom env => AlphaEq Array Array dom env
where
alphaEqSym = alphaEqSymDefault
instance Sharable Array
where
sharable GetIx = False
sharable _ = True
instance SizeProp (Array :|| Type)
where
sizeProp (C' Parallel) (WrapFull len :* WrapFull ixf :* Nil) =
infoSize len :> infoSize ixf
sizeProp (C' Sequential) (WrapFull len :* _ :* WrapFull step :* Nil) =
infoSize len :> fst (infoSize step)
sizeProp (C' Append) (WrapFull arra :* WrapFull arrb :* Nil) =
(alen + blen) :> (aelem \/ belem)
where
alen :> aelem = infoSize arra
blen :> belem = infoSize arrb
sizeProp (C' GetIx) (WrapFull arr :* _ :* Nil) = el
where
_ :> el = infoSize arr
sizeProp (C' SetIx) (WrapFull arr :* _ :* WrapFull e :* Nil) =
len :> (el \/ infoSize e)
where
len :> el = infoSize arr
sizeProp (C' GetLength) (WrapFull arr :* Nil) = len
where
len :> _ = infoSize arr
sizeProp (C' SetLength) (WrapFull len :* WrapFull arr :* Nil) =
infoSize len :> el
where
_ :> el = infoSize arr
instance
( (Array :|| Type) :<: dom
, (NUM :|| Type) :<: dom
, (ORD :|| Type) :<: dom
, (Variable :|| Type) :<: dom
, CLambda Type :<: dom
, OptimizeSuper dom
) =>
Optimize (Array :|| Type) dom
where
optimizeFeat sym@(C' Parallel) (len :* ixf :* Nil) = do
len' <- optimizeM len
let szI = infoSize (getInfo len')
ixRange = rangeByRange 0 (szI1)
ixf' <- optimizeFunction optimizeM (mkInfo ixRange) ixf
constructFeat sym (len' :* ixf' :* Nil)
optimizeFeat sym@(C' Sequential) (len :* inital :* step :* Nil) = do
len' <- optimizeM len
init' <- optimizeM inital
let szI = infoSize (getInfo len')
ixRange = rangeByRange 0 (szI1)
step' <- optimizeFunction
optimizeM
(mkInfo ixRange)
step
constructFeat sym (len' :* init' :* step' :* Nil)
optimizeFeat a args = optimizeFeatDefault a args
constructFeatOpt (C' Parallel) (len :* _ :* Nil)
| Just 0 <- viewLiteral len
= return $ literalDecor []
constructFeatOpt (C' Parallel) (len :* (lam :$ (gix :$ arr2 :$ ix)) :* Nil)
| Just (SubConstr2 (Lambda v1)) <- prjLambda lam
, Just (C' GetIx) <- prjF gix
, Just (C' (Variable v2)) <- prjF ix
, v1 == v2
, v1 `notMember` infoVars (getInfo arr2)
= constructFeat (c' SetLength) (len :* arr2 :* Nil)
constructFeatOpt (C' Sequential) (len :* _ :* _ :* Nil)
| Just 0 <- viewLiteral len
= return $ literalDecor []
constructFeatOpt (C' Append) (a :* b :* Nil)
| Just [] <- viewLiteral a = return b
| Just [] <- viewLiteral b = return a
constructFeatOpt (C' GetIx) ((op :$ _ :$ ixf) :* ix :* Nil)
| Just (C' Parallel) <- prjF op
= optimizeM $ betaReduce (stripDecor ix) (stripDecor ixf)
constructFeatOpt s@(C' GetIx) ((op :$ _ :$ arr) :* ix :* Nil)
| Just (C' SetLength) <- prjF op
= constructFeat s (arr :* ix :* Nil)
constructFeatOpt (C' GetLength) (arr :* Nil)
| Just as <- viewLiteral arr = return $ literalDecor $ genericLength as
constructFeatOpt s@(C' GetLength) ((op :$ a :$ _ :$ _) :* Nil)
| Just (C' Sequential) <- prjF op = return a
| Just (C' SetIx) <- prjF op = constructFeat s (a :* Nil)
constructFeatOpt sym@(C' GetLength) ((op :$ a :$ b) :* Nil)
| Just (C' Append) <- prjF op = do
aLen <- constructFeat sym (a :* Nil)
bLen <- constructFeat sym (b :* Nil)
constructFeatOpt (c' Add) (aLen :* bLen :* Nil)
| Just (C' Parallel) <- prjF op = return a
| Just (C' SetLength) <- prjF op = return a
constructFeatOpt (C' GetLength) (arr :* Nil)
| len :> _ <- infoSize $ getInfo arr
, isSingleton len
= return $ literalDecor $ lowerBound len
constructFeatOpt (C' SetLength) (len :* _ :* Nil)
| Just 0 <- viewLiteral len = return $ literalDecor []
constructFeatOpt (C' SetLength) ((getLength :$ arr') :* arr :* Nil)
| Just (C' GetLength) <- prjF getLength
, alphaEq arr arr'
= return arr
constructFeatOpt (C' SetLength) (len :* arr :* Nil)
| rlen <- infoSize $ getInfo len
, rarr :> _ <- infoSize $ getInfo arr
, isSingleton rlen
, isSingleton rarr
, rlen == rarr
= return arr
constructFeatOpt a args = constructFeatUnOpt a args
constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x