{-# LANGUAGE CPP,TemplateHaskell #-}
module ForSyDe.Deep.System.SysDef
(SysDef(..),
PrimSysDef(..),
SysDefVal(..),
SysLogic(..),
newSysDef,
newSysDefTH,
newSysDefTHName,
Iface) where
import ForSyDe.Deep.Ids
import ForSyDe.Deep.Netlist
import ForSyDe.Deep.Netlist.Traverse
import ForSyDe.Deep.OSharing
import ForSyDe.Deep.ForSyDeErr
import ForSyDe.Deep.System.SysFun (checkSysFType, SysFun(..))
import Data.Maybe (isJust, fromJust)
import Control.Monad.ST
import Control.Monad.State
import Data.Typeable
import Language.Haskell.TH hiding (Loc)
import Language.Haskell.TH.LiftInstances ()
import Data.Typeable.FSDTypeRepLib
type Iface = [(PortId, FSDTypeRep)]
newtype SysDef a = SysDef {unSysDef :: PrimSysDef}
newtype PrimSysDef = PrimSysDef {unPrimSysDef :: URef SysDefVal}
data SysLogic = Combinational | Sequential
deriving (Eq, Show)
data SysDefVal = SysDefVal
{sid :: SysId,
netlist :: Netlist [],
subSys :: [PrimSysDef],
logic :: SysLogic,
iIface :: Iface,
oIface :: Iface,
loc :: Maybe Loc}
newSysDef :: SysFun f => f
-> SysId
-> [PortId]
-> [PortId]
-> SysDef f
newSysDef f sysId inIds outIds = either currError id eProneResult
where currError = uError "newSysDef"
eProneResult = newSysDefEProne f Nothing sysId inIds outIds
newSysDefTH :: SysFun f => f
-> SysId
-> [PortId]
-> [PortId]
-> ExpQ
newSysDefTH f sysId inIds outIds =
case eProneResult of
Left err -> currError err
Right _ -> intError "newSysDefTH" (Other "Unimplemented")
where currError = qError "newSysDefTH"
eProneResult = newSysDefEProne f Nothing sysId inIds outIds
newSysDefTHName :: Name
-> [PortId]
-> [PortId]
-> ExpQ
newSysDefTHName sysFName inIds outIds = do
sysFInfo <- reify sysFName
sysFType <- case sysFInfo of
#if __GLASGOW_HASKELL__ >= 800
VarI _ t _ -> return t
#else
VarI _ t _ _ -> return t
#endif
_ -> currError (NonVarName sysFName)
((inTypes,inN),(outTypes, outN)) <- recover
(currError $ IncomSysF sysFName sysFType)
(checkSysFType sysFType)
let portCheck = checkSysDefPorts (show sysFName)
(inIds, inN)
(outIds, outN)
when (isJust portCheck) (currError (fromJust portCheck))
loc <- location
let
errInfo = loc_module loc
inArgs = [ [| Signal $ newInPort $(litE $ stringL id) |]
| id <- inIds ]
untypedSysDef =
[|let
toList = $(signalTup2List outN)
outNlSignals = toList $ $(appsE $ varE sysFName : inArgs)
inIface = $(genIface inIds inTypes)
outIface = $(genIface outIds outTypes)
errorInfo = errInfo
nlist = Netlist outNlSignals
(subSys,logic) = either (intError currFun) id
(checkSysDef nlist)
in SysDef $ PrimSysDef $ newURef $
SysDefVal (nameBase sysFName)
nlist
subSys
logic
inIface
outIface
(Just errorInfo) |]
sigE untypedSysDef (return $ ConT ''SysDef `AppT` sysFType)
where currError = qError currFun
currFun = "newSysDef"
----------------------------
-- Internal Helper Functions
----------------------------
-- | Error prone version of 'newSysDef'
newSysDefEProne :: SysFun f => f -- ^ system function
-> Maybe Loc -- ^ Location where the originating
-- call took place (if available)
-> SysId -- ^ System function
-> [PortId] -- ^ Input interface port identifiers
-> [PortId] -- ^ Output interface port identifiers
-> EProne (SysDef f)
newSysDefEProne f mLoc sysId inIds outIds
-- check the ports for problems
| isJust portCheck = throwError (fromJust portCheck)
| otherwise = do
let nl = Netlist nlist
(subSys, logic) <- checkSysDef nl
return (SysDef $ PrimSysDef $ newURef $ SysDefVal sysId
nl
subSys
logic
(zip inIds inTypes)
(zip outIds outTypes)
mLoc)
where (nlist, inTypes, outTypes) = applySysFun f inIds
inN = length inIds
outN = length outIds
portCheck = checkSysDefPorts sysId (inIds, inN) (outIds, outN)
-- | Check that the system definition ports match certain lengths and
-- don't containt duplicates
checkSysDefPorts :: SysId -- ^ System currently being checked
-> ([PortId], Int) -- ^ input ports and expected length
-> ([PortId], Int) -- ^ output ports and expected length
-> Maybe ForSyDeErr
checkSysDefPorts sysId (inIds, inN) (outIds, outN)
| inN /= inIdsL = Just $ InIfaceLength (sysId, inN) (inIds, inIdsL)
| outN /= outIdsL = Just $ OutIfaceLength (sysId, outN) (outIds, outIdsL)
| isJust (maybeDup) = Just $ MultPortId (fromJust maybeDup)
| otherwise = Nothing
where inIdsL = length inIds
outIdsL = length outIds
maybeDup = findDup (inIds ++ outIds)
-- | In order to check the system for identifier duplicates we keep track
-- of the process identifiers and of the accumulated subsytem definitions
data CheckState = CheckState {accumSubSys :: [PrimSysDef],
accumProcIds :: [ProcId] ,
accumLogic :: SysLogic }
-- Monad used to traverse the system in order to check that there are no
-- duplicates
type CheckSysM st a = TravSEST CheckState ForSyDeErr st a
-- | Check that the system netlist does not contain process identifier
-- duplicates (i.e. different processes with the same process
-- identifier) or instances of different systems with the same identifier.
-- In case there are no duplicates, the list of nested subsystems together
-- with the the logic is returned.
checkSysDef :: Netlist [] -> EProne ([PrimSysDef], SysLogic)
checkSysDef nl = do
endSt <- runST (runErrorT
(execStateT (traverseSEST newCheckSys defineCheckSys nl) initState))
let finalSubSys = accumSubSys endSt
-- we already checked all the delay processes of the system
-- but the system can still be sequential if any of the subsystems is
-- sequential
finalLogic =
if (accumLogic endSt == Sequential) ||
(any (\s -> (logic.readURef.unPrimSysDef) s == Sequential) finalSubSys)
then Sequential
else Combinational
return (finalSubSys, finalLogic)
where initState = CheckState [] [] Combinational
defineCheckSys :: [(NlNodeOut, ())] -> NlNode () -> CheckSysM st ()
defineCheckSys _ _= return ()
newCheckSys :: NlNode NlSignal -> CheckSysM st [(NlNodeOut, ())]
newCheckSys node = do
st <- get
let acIds = accumProcIds st
acSys = accumSubSys st
acLog = accumLogic st
-- check the process Id of current node for duplicates
acIds' <- case node of
-- input ports don't count as process identifiers
InPort _ -> return acIds
Proc pid _ -> if pid `elem` acIds
then throwError $ MultProcId pid
else return (pid:acIds)
-- If the node is a system instance, check that
-- the system and all its subsytems are either:
-- * already in the accumulated systems
-- * not in the accumulated systems, but have a different system
-- identifiers
-- FIXME: in order to avoid making so many comparisons, it
-- would probably be more efficient to also mark which
-- subsystems belong to the first hierarchy level in
-- SysVal (i.e. creating a tree-structure as a reult).
-- Then, if the system to compare (psys) matches a
-- root in the accumulated subsystems there would be
-- no need to continue comparing the childs of psys.
acSys' <- case node of
Proc _ (SysIns pSys _) ->
liftEither $
mergeSysIds (pSys:(subSys.readURef.unPrimSysDef) pSys) acSys
_ -> return acSys
let acLog' = case node of
Proc _ (DelaySY _ _) -> Sequential
_ -> acLog
put $ CheckState acSys' acIds' acLog'
-- return a phony value for each output of the node
return $ map (\tag -> (tag,())) (outTags node)
where mergeSysIds :: [PrimSysDef] -> [PrimSysDef] -> EProne [PrimSysDef]
mergeSysIds xs [] = return xs
mergeSysIds [] xs = return xs
mergeSysIds (x:xs) ys = do
shouldAdd <- addSysId x ys
if shouldAdd then do rest <- mergeSysIds xs ys
return (x:rest)
else mergeSysIds xs ys
-- should we add the Id to the accumulated ones?
addSysId :: PrimSysDef -> [PrimSysDef] -> EProne Bool
addSysId _ [] = return True
addSysId psdef (x:xs)
-- Both systems are equal
| unx == unpsdef = return False
-- Both systems are different, but their ids
-- are equal
| sdefid == sid xval =
throwError (SubSysIdClash sdefid (loc sdefval) (loc xval))
| otherwise = addSysId psdef xs
where unpsdef = unPrimSysDef psdef
unx = unPrimSysDef x
xval = readURef unx
sdefval = readURef unpsdef
sdefid = sid sdefval
-- | Generate a lambda expression to transform a tuple of N 'Signal's into a
-- a list of 'NlSignal's
signalTup2List :: Int -- ^ size of the tuple
-> ExpQ
signalTup2List n = do -- Generate N signal variable paterns and
-- variable expressions refering to the same names
names <- replicateM n (newName "i")
let tupPat = tupP [conP 'Signal [varP n] | n <- names]
listExp = listE [varE n | n <- names]
lamE [tupPat] listExp
-- | Find a duplicate in a list
findDup :: Eq a => [a] -> Maybe a
findDup [] = Nothing
findDup [_] = Nothing
findDup (x:xs)
| elem x xs = Just x
| otherwise = findDup xs
-- | Generate a TypeRep expression given a Template Haskell Type
-- note that the use of typeOf cannot lead to errors since all the signal
-- types in a system function are guaranteed to be Typeable by construction
type2TypeRep :: Type -> ExpQ
type2TypeRep t = [| typeOf $(sigE [| undefined |] (return t) ) |]
-- | Generate an interface given its identifiers and Template Haskell Types
genIface :: [PortId] -> [Type] -> ExpQ
genIface [] _ = listE []
genIface _ [] = listE []
genIface (i:ix) (t:tx) = do
ListE rest <- genIface ix tx
tupExp <- tupE [[| i |], type2TypeRep t]
return (ListE (tupExp:rest))