forsyde-deep-0.2.0: src/ForSyDe/Deep/System/SysDef.hs
{-# LANGUAGE CPP,TemplateHaskell #-}
-----------------------------------------------------------------------------
-- |
-- Module : ForSyDe.Deep.System.SysDef
-- Copyright : (c) ES Group, KTH/ICT/ES 2007-2013
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : forsyde-dev@ict.kth.se
-- Stability : experimental
-- Portability : portable
--
-- This module provides the System Definition type ('SysDef') together with
-- a Template Haskell constructor to build it.
--
-----------------------------------------------------------------------------
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
-- | Interface, describes the input or output ports of the system.
-- Each entry contains the name of the port and its type.
type Iface = [(PortId, FSDTypeRep)]
-- | We add a phantom parameter to indicate the type of the system
newtype SysDef a = SysDef {unSysDef :: PrimSysDef}
-- | The Primitive System Definition.
-- Instead of just providing the value, a reference is provided
-- to allow sharing between instances.
newtype PrimSysDef = PrimSysDef {unPrimSysDef :: URef SysDefVal}
-- | Indicates wether a system is combinational or sequential
-- In practice, a system is sequential if if contains a delay process or
-- a sequential system instance, otherwise its combinational.
data SysLogic = Combinational | Sequential
deriving (Eq, Show)
-- | The System Definition value
data SysDefVal = SysDefVal
{sid :: SysId, -- ^ Identifier of the System
netlist :: Netlist [], -- ^ System netlist
subSys :: [PrimSysDef], -- ^ List of all unique nested subsystems
-- (i.e. flattened tree, without duplicates,
-- of all the systems in lower levels of the
-- hierarchy)
logic :: SysLogic, -- ^ 'SysLogic' of the system
iIface :: Iface, -- ^ Input interface
oIface :: Iface, -- ^ Output interface
loc :: Maybe Loc} -- ^ Location of the call to newSysDef
-- which created this System definition
-- (used for later error reporting)
-- It will initialized or not depending
-- on the newSysDef* function used
-- | 'SysDef' constructor
--
-- Builds a system definition out of a system function describing the system
-- and its port identifers.
newSysDef :: SysFun f => f -- ^ system function
-> SysId -- ^ System identifier
-> [PortId] -- ^ Input interface port identifiers
-> [PortId] -- ^ Output interface port identifiers
-> SysDef f
newSysDef f sysId inIds outIds = either currError id eProneResult
where currError = uError "newSysDef"
eProneResult = newSysDefEProne f Nothing sysId inIds outIds
-- | CURRENTLY BROKEN, do not use!
--
-- 'SysDef' constructor, Template Haskell version
--
-- Builds a system definition out of a system function, a system identifiers
-- and its port identifers.
--
-- For example @$(newSysDefTH mySysFun \"mysys\" [\"in1\"] [\"out1\"])@ creates a
-- system definition from system funcion @mySysFun@ which should have
-- one input and output signals.
--
-- The advantage of 'newSysDefTH' over 'newSysDef' is that it
-- reports errors (e.g duplicated port and process identifiers) earlier,
-- at host-language (Haskell) compile-time.
--
-- In addition, due to the use of Template Haskell, 'newSysDefTH' is
-- aware of the source location at which it was called, making
-- further error reports friendlier to the user.
newSysDefTH :: SysFun f => f -- ^ system function
-> SysId -- ^ System identifier
-> [PortId] -- ^ Input interface port identifiers
-> [PortId] -- ^ Output interface port identifiers
-> ExpQ
newSysDefTH f sysId inIds outIds =
case eProneResult of
Left err -> currError err
-- unfortunately SysDef can't easily be an instance of Lift
-- due to the unsafe, unmutable references used in observable sharing
-- Right sysDef -> [| sysDef |]
Right _ -> intError "newSysDefTH" (Other "Unimplemented")
-- FIXME: Fix this function or remove (updating the documentation of
-- newSysDef* in the latter case).
{-
Right _ -> do
loc <- currentModule
[| let iIds = inIds
oIds = outIds
(nlist, inTypes, outTypes) = applySysFun f iIds
in SysDef $ PrimSysDef $ newURef $ SysDefVal sysId
(Netlist nlist)
(zip iIds inTypes)
(zip oIds outTypes)
(Just loc) |]
-}
where currError = qError "newSysDefTH"
eProneResult = newSysDefEProne f Nothing sysId inIds outIds
-- | 'SysDef' constructor, Template Haskell 'Name' version
--
-- Builds a 'SysDef' out of the name of a system function
-- and its port identifers.
--
-- The system will later be identified by the basename
-- (i.e. unqualified name) of the function.
--
-- For example @$(newSysDefTHName \'mySysFun [\"in1\"] [\"out1\"])@ creates a
-- system definition from system funcion @mySysFun@ which has one input and
-- output signals.
--
-- The advantage of 'newSysDefTHName' over 'newSysDefTH' is that it
-- doesn't suffer from the Template Haskell bug <http://hackage.haskell.org/trac/ghc/ticket/1800>, or in other words, it allows to declare the system
-- defintion and system function in the same module.
--
-- However, since it doesn't have acces to the system function itself,
-- it can only give early error reports related to incorrect port identifiers
-- (process identifier duplicate errors will be reported at runtime).
newSysDefTHName :: Name -- ^ Name of the system function
-> [PortId] -- ^ Input interface port identifiers
-> [PortId] -- ^ Output interface port identifiers
-> ExpQ
newSysDefTHName sysFName inIds outIds = do
sysFInfo <- reify sysFName
-- Check that a function name was provided
sysFType <- case sysFInfo of
#if __GLASGOW_HASKELL__ >= 800
-- Last parameter Fixity was removed in GHC8
VarI _ t _ -> return t
#else
VarI _ t _ _ -> return t
#endif
_ -> currError (NonVarName sysFName)
-- Check that the function complies with the expected type
-- and extract the port types
((inTypes,inN),(outTypes, outN)) <- recover
(currError $ IncomSysF sysFName sysFType)
(checkSysFType sysFType)
-- Check the ports
let portCheck = checkSysDefPorts (show sysFName)
(inIds, inN)
(outIds, outN)
when (isJust portCheck) (currError (fromJust portCheck))
-- Build the system definition
loc <- location
let
errInfo = loc_module loc
-- Input arguments passed to the system function
-- in order to get the netlist
inArgs = [ [| Signal $ newInPort $(litE $ stringL id) |]
| id <- inIds ]
-- The system definition without type signature for the
-- phantom parameter
untypedSysDef =
-- The huge let part of this quasiquote is not
-- really necesary but generates clearer code
[|let
-- Generate the system netlist
toList = $(signalTup2List outN)
outNlSignals = toList $ $(appsE $ varE sysFName : inArgs)
-- Rest of the system defintion
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) |]
-- We are done, we simply specify the concrete type of the SysDef
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))