module Feldspar.Core.Constructs where
import Data.List
import Data.Typeable
import Feldspar.DSL.Expression
import Feldspar.DSL.Lambda
import Feldspar.DSL.Network
import Feldspar.Set
import Feldspar.Range
import Feldspar.Core.Types
import Feldspar.Core.Representation
value' :: Type a => Size a -> a -> Data a
value' sz a = nodeData (sz \/ sizeOf a) (Inject $ Node $ Literal a)
value :: Type a => a -> Data a
value = value' empty
unit :: Data ()
unit = value ()
true :: Data Bool
true = value True
false :: Data Bool
false = value False
array :: Type a => Size a -> a -> Data a
array = value'
cap :: Type a => Size a -> Data a -> Data a
cap sz a = resizeData (sz /\ dataSize a) a
function :: (Syntactic a, Type b)
=> Bool
-> String
-> (Info a -> Size b)
-> (Internal a -> b)
-> (a -> Data b)
function doConstProp fun sizeProp f a = case viewLiteral a of
Just a' | doConstProp -> value (f a')
_ -> func
where
sz = sizeProp (edgeInfo a)
func = nodeData sz $ Inject (Node (Function fun f)) :$: toEdge a
function1 :: (Type a, Type b)
=> String
-> (Size a -> Size b)
-> (a -> b)
-> (Data a -> Data b)
function1 fun sizeProp = function True fun (sizeProp . edgeSize)
function2 :: (Type a, Type b, Type c)
=> String
-> (Size a -> Size b -> Size c)
-> (a -> b -> c)
-> (Data a -> Data b -> Data c)
function2 fun sizeProp f = curry $ function True fun sizeProp' (uncurry f)
where
sizeProp' (i1,i2) = sizeProp (edgeSize i1) (edgeSize i2)
condition :: Syntactic a
=> Data Bool
-> a
-> a
-> a
condition cond t e
| toEdge t == toEdge e = t
| Just True <- viewLiteral cond = t
| Just False <- viewLiteral cond = e
| otherwise
= fromOutEdge info
$ Inject (Node Condition)
:$: toEdge cond
:$: toEdge t
:$: toEdge e
where
info = edgeInfo t \/ edgeInfo e
(?) :: Syntactic a
=> Data Bool
-> (a,a)
-> a
cond ? (t,e) = condition cond t e
infix 1 ?
ifThenElse :: Syntactic a
=> Data Bool
-> a
-> a
-> a
ifThenElse = condition
viewGetIx :: Typeable a => Data Index -> Data a -> Maybe (Data [a])
viewGetIx (Data i) (Data a) = case undoEdge a of
Inject (Node (Function "(!)" _)) :$: (Inject Group2 :$: as :$: i')
| exprEq i i' -> Data `fmap` exprCast as
_ -> Nothing
parallel'' :: Type a =>
Bool -> Data Length -> (Data Index -> Data a) -> Data [a] -> Data [a]
parallel'' optimize l ixf cont | l == value 0 = cont
parallel'' optimize l ixf cont = case viewGetIx ix body of
Just arr | optimize, cont == value [] -> setLength l arr
_
-> nodeData szPar
$ Inject (Node Parallel)
:$: toEdge l
:$: lambda (EdgeSize szi) ixf
:$: toEdge cont
where
szl1 = dataSize l
szi = rangeByRange 0 (szl11)
ix = variable (EdgeSize szi) "TODO"
body = ixf ix
sza = dataSize body
szl2 :> sza' = dataSize cont
szPar = (szl1+szl2) :> (sza \/ sza')
parallel' :: Type a =>
Data Length -> (Data Index -> Data a) -> Data [a] -> Data [a]
parallel' = parallel'' True
parallel :: Type a
=> Data Length
-> (Data Index -> Data a)
-> Data [a]
parallel l ixf = parallel' l ixf (value [])
forLoop :: Syntactic st
=> Data Length
-> st
-> (Data Index -> st -> st)
-> st
forLoop l init body | l == value 0 = init
forLoop l init body | l == value 1 = body (value 0) init
forLoop l init body
= fromOutEdge szst
$ Inject (Node ForLoop)
:$: toEdge l
:$: toEdge init
:$: Lambda (\i -> lambda szst $ body $ nodeData szi i)
where
szi = rangeByRange 0 (dataSize l)
szinit = edgeInfo init
fn _ sz = edgeInfo $ body (variable (EdgeSize szi) "ix")
(variable sz "st")
(szst,_) = indexedFixedPoint (cutOffAt 3 fn) szinit
sequential :: (Type a, Syntactic st)
=> Data Length
-> st
-> (Data Index -> st -> (Data a,st))
-> (st -> Data [a])
-> Data [a]
sequential l init step cont
= nodeData szSeq
$ Inject (Node Sequential)
:$: toEdge l
:$: toEdge init
:$: Lambda (\i -> lambda universal $ step $ nodeData szi i)
:$: lambda universal cont
where
szl1 = dataSize l
szl2 = universal
szi = rangeByRange 0 (szl11)
szSeq = (szl1+szl2) :> universal
noinline :: (Syntactic a, Syntactic b) => String -> (a -> b) -> (a -> b)
noinline name body a
= fromOutEdge szb
$ Inject (Node (NoInline name))
:$: lambda sza body
:$: toEdge a
where
sza = getInfo a
szb = getInfo $ body a
noinline2 :: (Syntactic a, Syntactic b, Syntactic c) =>
String -> (a -> b -> c) -> (a -> b -> c)
noinline2 name = curry . noinline name . uncurry
setLength :: Type a => Data Length -> Data [a] -> Data [a]
setLength l arr = case (undoEdge (unData l), undoEdge (unData arr)) of
(Inject (Node (Function "length" _)) :$: a, _)
| Just b <- exprCast a, b == unData arr -> Data b
(Inject (Node (Literal n)), Inject (Node (Literal as))) ->
nodeData (szLen :> szArrElem) $
Inject $ Node $ Literal $ genericTake n as
(_, Inject (Node Parallel) :$: _ :$: ixf :$: cont)
| cont == unData (value []) -> nodeData (szLen :> szArrElem) $
Inject (Node Parallel) :$: unData l :$: ixf :$: cont
_ -> nodeData (szLen :> szArrElem) $
Inject (Node SetLength) :$: toEdge l :$: toEdge arr
where
szl = dataSize l
szArrLen :> szArrElem = dataSize arr
szLen = rangeMin szl szArrLen