module Language.Copilot.Compiler(copilotToAtom) where
import Language.Copilot.Core
import Data.Word
import Data.Maybe
import Data.Map as M
import Data.List
import Control.Monad (when)
import qualified Language.Atom as A
import Language.Copilot.Analyser (getAtomType)
getValue :: PhasedValue a -> A.V a
getValue (Ph _ val) = val
copilotToAtom :: StreamableMaps Spec -> Sends -> Maybe Period -> Maybe [(Var, String)] -> (Period, A.Atom ())
copilotToAtom streams sends p triggers =
(p', A.period p' $ do
prophArrs <- mapStreamableMapsM initProphArr streams
outputs <- mapStreamableMapsM initOutput streams
tmpSamples <- foldStreamableMaps initTmpSamples streams (return emptySM)
updateIndexes <- foldStreamableMaps makeUpdateIndex prophArrs (return M.empty)
outputIndexes <- foldStreamableMaps makeOutputIndex prophArrs (return M.empty)
foldStreamableMaps (makeRule streams outputs prophArrs tmpSamples
updateIndexes outputIndexes)
streams (return ())
foldStreamableMaps (makeTrigger triggers streams prophArrs tmpSamples
outputIndexes)
streams (return ())
foldSendableMaps (makeSend outputs) sends (return ())
sampleVars tmpSamples)
where
optP = getOptimalPeriod streams
p' =
case p of
Nothing -> optP
Just i -> if i >= optP
then i
else error $ "Copilot error: the period is too short, "
++ "it should be at least " ++ show optP ++ " ticks."
initProphArr :: forall a. Streamable a => Var -> Spec a -> A.Atom (BoundedArray a)
initProphArr v s =
let states = initState s
name = "prophVal__" ++ normalizeVar v
n = genericLength states in
if n > 0
then
do
array <- A.array name (states ++ [unit])
return $ B n $ Just array
else return $ B n Nothing
where
initState s' =
case s' of
Append ls s'' -> ls ++ initState s''
_ -> []
initOutput :: forall a. Streamable a => Var -> Spec a -> A.Atom (A.V a)
initOutput v s = streamToUnitValue ("outputVal__" ++ normalizeVar v) s
initTmpSamples :: forall a. Streamable a => Var -> Spec a -> A.Atom TmpSamples -> A.Atom TmpSamples
initTmpSamples _ s tmpSamples =
case s of
Const _ -> tmpSamples
Var _ -> tmpSamples
Drop _ s' -> initTmpSamples undefined s' tmpSamples
Append _ s' -> initTmpSamples undefined s' tmpSamples
F _ _ s0 -> initTmpSamples undefined s0 tmpSamples
F2 _ _ s0 s1 -> initTmpSamples undefined s0 $
initTmpSamples undefined s1 tmpSamples
F3 _ _ s0 s1 s2 -> initTmpSamples undefined s0 $
initTmpSamples undefined s1 $
initTmpSamples undefined s2 tmpSamples
PVar _ v ph ->
do
ts <- tmpSamples
let v' = normalizeVar v ++ "_" ++ show ph
maybeElem = (getMaybeElem v' ts)::(Maybe (PhasedValue a))
name = "tmpSampleVal__" ++ normalizeVar v'
case maybeElem of
Nothing ->
do
val <- streamToUnitValue name s
let m' = M.insert v' (Ph ph val) (getSubMap ts)
return $ updateSubMap (\_ -> m') ts
Just _ -> return ts
makeUpdateIndex :: Var -> BoundedArray a -> A.Atom Indexes -> A.Atom Indexes
makeUpdateIndex v (B n arr) indexes =
case arr of
Nothing -> indexes
Just _ ->
do
mindexes <- indexes
index <- atomConstructor ("updateIndex__" ++ normalizeVar v) n
return $ M.insert v index mindexes
makeOutputIndex :: Var -> BoundedArray a -> A.Atom Indexes -> A.Atom Indexes
makeOutputIndex v (B _ arr) indexes =
case arr of
Nothing -> indexes
Just _ ->
do
mindexes <- indexes
index <- atomConstructor ("outputIndex__" ++ normalizeVar v) 0
return $ M.insert v index mindexes
makeRule :: forall a. Streamable a =>
StreamableMaps Spec -> Outputs -> ProphArrs -> TmpSamples ->
Indexes -> Indexes -> Var -> Spec a -> A.Atom () -> A.Atom ()
makeRule streams outputs prophArrs tmpSamples updateIndexes outputIndexes v s r = do
r
let B n maybeArr = (getElem v prophArrs)::(BoundedArray a)
case maybeArr of
Nothing ->
A.exactPhase 0 $ A.atom ("updateOutput__" ++ normalizeVar v) $ do
((getElem v outputs)::(A.V a)) A.<== nextSt'
Just arr -> do
let updateIndex = fromJust $ M.lookup v updateIndexes
outputIndex = fromJust $ M.lookup v outputIndexes
A.exactPhase 0 $ A.atom ("update__" ++ normalizeVar v) $ do
arr A.! (A.VRef updateIndex) A.<== nextSt'
A.exactPhase 1 $ A.atom ("output__" ++ normalizeVar v) $ do
((getElem v outputs)::(A.V a)) A.<== arr A.!. (A.VRef outputIndex)
outputIndex A.<== (A.VRef outputIndex + A.Const 1) `A.mod_` A.Const (n + 1)
A.phase 1 $ A.atom ("incrUpdateIndex__" ++ normalizeVar v) $ do
updateIndex A.<== (A.VRef updateIndex + A.Const 1) `A.mod_` A.Const (n + 1)
where nextSt' = nextSt streams prophArrs tmpSamples outputIndexes s 0
makeSend :: forall a. Sendable a => Outputs -> Var -> Send a -> A.Atom () -> A.Atom ()
makeSend outputs name (Send (v, ph, port)) r =
r >>
do
A.exactPhase ph $ A.atom ("__send_" ++ name) $
send ((A.value (getElem v outputs))::(A.E a)) port
sampleVars :: TmpSamples -> A.Atom ()
sampleVars tmpSamples =
sequence_ $ foldStreamableMaps sample tmpSamples []
where
sample :: Streamable a => Var -> PhasedValue a -> [A.Atom ()] -> [A.Atom ()]
sample v' (Ph ph val) xs =
(A.exactPhase ph $
A.atom ("sample__" ++ normalizeVar v') $
val A.<== (A.value $ externalAtomConstructor v)
) : xs
where
v0 = reverse (tail (dropWhile (\c -> c /= '_') (reverse v')))
(v1, n_final) = foldl (\ (s, n) c ->
if c == '_'
then (s, n + 1)
else (s ++ underscoreNumber2Symbol n ++ [c],0)
) ("", 0) v0
v = v1 ++ underscoreNumber2Symbol n_final
underscoreNumber2Symbol 0 = ""
underscoreNumber2Symbol 1 = "_"
underscoreNumber2Symbol 2 = "."
underscoreNumber2Symbol 3 = "["
underscoreNumber2Symbol 4 = "]"
underscoreNumber2Symbol _ = undefined
getOptimalPeriod :: StreamableMaps Spec -> Period
getOptimalPeriod streams =
foldStreamableMaps getMaximumSamplingPhase streams 2
where
getMaximumSamplingPhase :: Var -> Spec a -> Period -> Period
getMaximumSamplingPhase _ spec n =
case spec of
PVar _ _ p -> max (p + 1) n
F _ _ s -> getMaximumSamplingPhase "" s n
F2 _ _ s0 s1 -> maximum [n,
(getMaximumSamplingPhase "" s0 n),
(getMaximumSamplingPhase "" s1 n)]
F3 _ _ s0 s1 s2 -> maximum [n,
(getMaximumSamplingPhase "" s0 n),
(getMaximumSamplingPhase "" s1 n),
(getMaximumSamplingPhase "" s2 n)]
Drop _ s -> getMaximumSamplingPhase "" s n
Append _ s -> getMaximumSamplingPhase "" s n
_ -> n