module Lava.Model where
import Control.Arrow ((***))
import Control.Monad.Writer
import Control.Monad.State
import Data.Char
import Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Hardware.Internal
import qualified Lava2000 as L
data Signal
= PrimInpSig PrimInpId
| CellSig CellId OutPin
deriving (Eq, Show, Ord)
data Declaration lib
= PrimInput PrimInpId
| Cell CellId lib [Signal]
| Label Tag Signal
deriving (Eq, Show)
data DesignDB lib = DesignDB
{ cellDB :: Map CellId (lib,[Signal])
, fanoutDB :: Map Signal [(CellId,InPin)]
, sigTagDB :: Map Signal [Tag]
, tagSigDB :: Map Tag [Signal]
, primIns :: [Signal]
}
deriving (Eq, Show)
class CellLibrary lib
where
numIns :: lib -> InPin
numOuts :: lib -> OutPin
inPinName :: lib -> InPin -> Name
inPinId :: lib -> Name -> InPin
outPinName :: lib -> OutPin -> Name
outPinId :: lib -> Name -> OutPin
isFlop :: lib -> Bool
lava2000Interp :: Interpretation lib (L.Signal Bool)
cellInputs :: CellLibrary lib => CellId -> lib -> [(CellId,InPin)]
cellInputs cid ct = zip (repeat cid) [0 .. numIns ct1]
cellOutputs :: CellLibrary lib => CellId -> lib -> [Signal]
cellOutputs cid ct = map (CellSig cid) [0 .. numOuts ct1]
prop_uniquePrimInputs decls = iids == nub iids
where
iids = [iid | PrimInput iid <- decls]
prop_uniqueCells decls = cids == nub cids
where
cids = [cid | Cell cid _ _ <- decls]
prop_correctCellInputs decls =
and [numIns ct == genericLength ss | Cell _ ct ss <- decls]
prop_validSignals :: CellLibrary lib => [Declaration lib] -> Bool
prop_validSignals decls = all (`elem` validSigs) referred
where
primInps = [PrimInpSig iid | PrimInput iid <- decls]
cellOuts = [s | Cell cid ct _ <- decls, s <- cellOutputs cid ct]
validSigs = primInps ++ cellOuts
referred
= concat [ss | Cell _ _ ss <- decls]
++ [s | Label _ s <- decls]
prop_validDecls :: CellLibrary lib => [Declaration lib] -> Bool
prop_validDecls decls
= prop_uniquePrimInputs decls
&& prop_uniqueCells decls
&& prop_correctCellInputs decls
&& prop_validSignals decls
newtype Lava lib a = Lava
{ unLava :: WriterT [Declaration lib] (State (PrimInpId,CellId)) a }
deriving (Monad, MonadFix)
runLava :: CellLibrary lib => Lava lib a -> (a, DesignDB lib)
runLava (Lava lava) = (a, DesignDB cDB fDB stDB tsDB ins)
where
((a,decls),_) = runState (runWriterT lava) (0,0)
cDB = Map.fromList [ (cid,(ct,ins)) | Cell cid ct ins <- decls ]
stDB = fmap nub $ Map.fromListWith (++) [ (s,[t]) | Label t s <- decls ]
tsDB = fmap nub $ Map.fromListWith (++) [ (t,[s]) | Label t s <- decls ]
fDB = Map.fromListWith (++) $ concat
[ zip ins (map return $ cellInputs cid ct)
++
zip (cellOutputs cid ct) (repeat [])
| Cell cid ct ins <- decls
]
ins = [PrimInpSig iid | PrimInput iid <- decls]
class (Monad m, CellLibrary lib) => MonadLava lib m | m -> lib
where
newPrimInpId :: m PrimInpId
newCellId :: m CellId
declare :: Declaration lib -> m ()
listenDecls :: m a -> m (a, [Declaration lib])
toLava :: m a -> Lava lib a
instance CellLibrary lib => MonadLava lib (Lava lib)
where
newPrimInpId = Lava $ do
(iid,cid) <- get
put (succ iid, cid)
return iid
newCellId = Lava $ do
(iid,cid) <- get
put (iid, succ cid)
return cid
declare = Lava . tell . return
listenDecls = Lava . listen . unLava
toLava = id
inputSig :: MonadLava lib m => m Signal
inputSig = do
iid <- newPrimInpId
declare (PrimInput iid)
return (PrimInpSig iid)
cellList :: MonadLava lib m => lib -> [Signal] -> m [Signal]
cellList ct ins = do
cid <- newCellId
declare $ Cell cid ct ins
return (cellOutputs cid ct)
labelSig :: MonadLava lib m => Tag -> Signal -> m Signal
labelSig tag sig
| not $ all isAlphaNum tag = error msg
| otherwise = declare (Label tag sig) >> return sig
where
msg =
"label: Only alphanumeric characters allowed\n\
\Offending label: " ++ tag
data Interpretation lib x = Interp
{ defaultVal :: x
, accumulator :: x -> x -> x
, propagator :: lib -> ([x] -> [Maybe x])
}
type InterpDesignDB lib x = (DesignDB lib, Map Signal x)
lookupTag :: Tag -> InterpDesignDB lib x -> [x]
lookupTag tag (db,sigMap) = map (sigMap Map.!) (tag `totalLookup` tagSigDB db)
depthInterp :: CellLibrary lib => Interpretation lib Int
depthInterp = Interp
{ defaultVal = 0
, propagator = prop
}
where
prop ct vals
| isFlop ct = genericReplicate no (Just 0) ++ ins
| otherwise = genericReplicate no (Just (d+1)) ++ ins
where
ni = numIns ct
no = numOuts ct
ins = genericReplicate ni Nothing
d = maximum (0 : genericDrop no vals)