{-# LANGUAGE CPP #-} module SimCCBlock( SBId , SBMap , SimCCBlock(..) , SimCCSched(..) , SimCCClockGroup(..) , SimCCReset(..) , SimCCGateInfo , SimCCFn(..) , SimCCFnStmt(..) , StmtConv , StmtsConv , ConvState(..) , SBFnSet , initialState , mkResetFnName , mkSetClkFnName , mkGateAssign , mkGateConst , mkLiteralName , mkStringLiteralName , simCCBlockToClassDeclaration , simCCBlockToClassDefinition , simCCScheduleToFunctionDefinition , moduleType , clockType , get_rule_fns , get_method_fns , defs_written , defs_read , lookupSB , isPrimBlock , primBlocks , isWideDef , adjustInstQuals , pfxModel , pfxMod , pfxInst , pfxPort , pfxMeth , renameIds ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) #endif import Id import Prim import ASyntax import ASyntaxUtil import SimDomainInfo(DomainId) import Wires(ClockDomain, noClockDomain, writeClockDomain) import VModInfo(VName(..), vName_to_id) import CCSyntax import ForeignFunctions import SimPrimitiveModules import qualified Data.Map as M import qualified Data.Set as S import IntLit import IntegerUtil(aaaa) import PPrint hiding (char, int) import Util(itos, headOrErr, initOrErr, lastOrErr, snd3, makePairs, concatMapM) import Eval(Hyper(..)) import ErrorUtil(internalError) import Data.Maybe import Data.List(partition, intersperse, intercalate, nub, sortBy) import Data.List.Split(wordsBy) import Numeric(showHex) import Control.Monad.State(State, gets, modify, when) import Data.Char(toLower) import qualified Data.Map as Map -- import Debug.Trace type SBId = Int type SBMap = M.Map SBId SimCCBlock -- Lookup an SBId in an SBMap, generating an error for an unknown id lookupSB :: SBMap -> SBId -> SimCCBlock lookupSB sb_map sbid = case M.lookup sbid sb_map of (Just sb) -> sb Nothing -> internalError ("Unknown SBId: " ++ (show sbid)) -- Get a C++ type combinator for a SimCCBlock with specified arguments moduleType :: SimCCBlock -> [AExpr] -> (CCFragment -> CCFragment) moduleType sb args = userType (pfxMod ++ (fst (sb_naming_fn sb args))) -- Group rules/methods by domains type SBFnSet = (Maybe ClockDomain, [(AId, SimCCFn)]) -- A SimCCBlock represents a class that implements some subset -- of the simulation logic for a module. Typically, there is -- a SimCCBlock that implements the fast module core, and other -- SimCCBlocks which layer over it to compute values for debug -- visibility. data SimCCBlock = SimCCBlock { sb_id :: SBId -- unique identifier , sb_name :: String -- block name , sb_naming_fn :: NamingFn -- module naming function , sb_domains :: [ClockDomain] -- clock domains , sb_state :: [(SBId,AId,[AExpr])] -- sub-modules , sb_parameters :: [(AType,AId,Bool)] -- instantiation parameters , sb_resetDefs :: [(AType,AId)] -- reset values -- method enable, argument and return value ports , sb_methodPorts :: [(AType,AId,VName)] , sb_publicDefs :: [(AType,AId)] -- defs available outside , sb_privateDefs :: [(AType,AId)] -- defs private to the block , sb_rules :: [SBFnSet] -- functions for rules , sb_methods :: [SBFnSet] -- functions for methods , sb_resets :: [SimCCFn] -- reset functions -- defs which receive values from AV tasks , sb_taskDefs :: [AId] -- resets from submods paired with the Id of the submod -- and the output reset Id -- (for calling 'set_rst_fn' on the submod) , sb_resetSources :: [(AId,(AId, AId))] -- resets coming in as instantiation arguments , sb_inputResets :: [AId] -- resets output in the module's interface , sb_outputResets :: [AId] -- clock input ports , sb_inputClocks :: [(AId,ClockDomain)] -- clock gate numbering , sb_gateMap :: [AExpr] -- numbering is [0..] } instance Eq SimCCBlock where a == b = and [ (sb_id a) == (sb_id b) , (sb_name a) == (sb_name b) , (sb_domains a) == (sb_domains b) , (sb_state a) == (sb_state b) , (sb_parameters a) == (sb_parameters b) , (sb_resetDefs a) == (sb_resetDefs b) , (sb_methodPorts a) == (sb_methodPorts b) , (sb_publicDefs a) == (sb_publicDefs b) , (sb_privateDefs a) == (sb_privateDefs b) , (sb_rules a) == (sb_rules b) , (sb_methods a) == (sb_methods b) , (sb_resets a) == (sb_resets b) , (sb_taskDefs a) == (sb_taskDefs b) , (sb_resetSources a) == (sb_resetSources b) , (sb_inputResets a) == (sb_inputResets b) , (sb_outputResets a) == (sb_outputResets b) , (sb_inputClocks a) == (sb_inputClocks b) , (sb_gateMap a) == (sb_gateMap b) ] instance Show SimCCBlock where show sb = let fields = [ show (sb_id sb) , show (sb_name sb) , show (sb_domains sb) , show (sb_state sb) , show (sb_parameters sb) , show (sb_resetDefs sb) , show (sb_methodPorts sb) , show (sb_publicDefs sb) , show (sb_privateDefs sb) , show (sb_rules sb) , show (sb_methods sb) , show (sb_resets sb) , show (sb_taskDefs sb) , show (sb_resetSources sb) , show (sb_inputResets sb) , show (sb_outputResets sb) , show (sb_inputClocks sb) , show (sb_gateMap sb) ] in "SimCCBlock {" ++ intercalate ", " fields ++ "}" get_rule_fns :: SimCCBlock -> [SimCCFn] get_rule_fns sb = map snd (concatMap snd (sb_rules sb)) get_method_fns :: SimCCBlock -> [SimCCFn] get_method_fns sb = map snd (concatMap snd (sb_methods sb)) -- A SimCCFn is a named function (with arguments) and a sequence -- of statements consisting of assignments to either local defs or -- defs in a SimCCBlock. The statements in the SimCCFn body are ordered -- to preserve parallel update semantics. data SimCCFn = SimCCFn { sf_name :: String -- function name , sf_args :: [(AType,AId)] -- function arguments , sf_retType :: Maybe AType -- return type , sf_body :: [SimCCFnStmt] -- function body } deriving (Eq, Show) data SimCCFnStmt = -- Bool is whether the var is a port (else a def) SFSDef Bool (AType,AId) (Maybe AExpr) -- declare local var -- Bool is whether the var is a port (else a def) | SFSAssign Bool AId AExpr -- var = expr OR -- var = vMethod(...) | SFSAction AAction -- aMethod(...) -- Bool is whether the var is a port (else a def) -- AType is for assigning an undet value when the method/task is not called | SFSAssignAction Bool AId AAction AType -- var = avMethod(...) | SFSRuleExec ARuleId -- rule() | SFSCond AExpr [SimCCFnStmt] [SimCCFnStmt] -- if cond ... -- calls corresponding to BSV methods | SFSMethodCall AId AId [AExpr] -- obj.meth(args) -- calls to reset/clock functions | SFSFunctionCall AId String [AExpr] -- obj.func(args) | SFSResets [SimCCFnStmt] -- if (reset) ... | SFSReturn (Maybe AExpr) -- return OR return e | SFSOutputReset AId AExpr -- calls the resetFn of the parent for the output reset -- with the expr as the reset value deriving (Eq, Ord, Show) isReturn :: SimCCFnStmt -> Bool isReturn (SFSReturn _) = True isReturn _ = False -- List of Ids (in raw form) which are written in a function. -- Since both defs and ports can be written, and they are in separate -- namespaces, the Ids are returned as a pair, with a boolean indicating -- which namespace (True for ports) defs_written :: SimCCFnStmt -> [(Bool, AId)] defs_written (SFSDef isPort (_,aid) (Just _)) = [(isPort, aid)] defs_written (SFSAssign isPort aid _) = [(isPort, aid)] defs_written (SFSAssignAction isPort aid _ _) = [(isPort, aid)] defs_written (SFSCond _ ts fs) = (concatMap defs_written ts) ++ (concatMap defs_written fs) defs_written (SFSResets rs) = concatMap defs_written rs defs_written _ = [] -- List of Ids (in raw form) which are read in a function. -- This does not distinguish reads of ports from reads of defs! defs_read :: SimCCFnStmt -> [AId] defs_read (SFSDef _ _ (Just e)) = aVars e defs_read (SFSAssign _ _ e) = aVars e defs_read (SFSAction act) = aVars act defs_read (SFSAssignAction _ _ act _) = aVars act defs_read (SFSCond e ts fs) = (aVars e) ++ (concatMap defs_read ts) ++ (concatMap defs_read fs) defs_read (SFSMethodCall _ _ args) = concatMap aVars args defs_read (SFSFunctionCall _ _ args) = concatMap aVars args defs_read (SFSResets stmts) = concatMap defs_read stmts defs_read (SFSReturn (Just e)) = aVars e defs_read (SFSOutputReset _ e) = aVars e defs_read _ = [] -- Rename the Ids in a SimCCFnStmt based on an Id map mapId :: Map.Map Id Id -> Id -> Id mapId idmap i = Map.findWithDefault i i idmap mapExpr :: Map.Map Id Id -> AExpr -> AExpr mapExpr idmap e = exprMap fn e where fn (ASDef t i) = Just (ASDef t (mapId idmap i)) fn expr = Nothing mapAct :: Map.Map Id Id -> AAction -> AAction mapAct idmap act = mapAExprs (exprMap fn) act where fn (ASDef t i) = Just (ASDef t (mapId idmap i)) fn expr = Nothing renameIds :: Map.Map Id Id -> SimCCFnStmt -> SimCCFnStmt renameIds m (SFSDef b (t,i) Nothing) = SFSDef b (t, mapId m i) Nothing renameIds m (SFSDef b (t,i) (Just e)) = SFSDef b (t, mapId m i) (Just (mapExpr m e)) renameIds m (SFSAssign b i e) = SFSAssign b (mapId m i) (mapExpr m e) renameIds m (SFSAction act) = SFSAction (mapAct m act) renameIds m (SFSAssignAction b i act t) = SFSAssignAction b (mapId m i) (mapAct m act) t renameIds m (SFSCond e ts es) = SFSCond (mapExpr m e) (map (renameIds m) ts) (map (renameIds m) es) renameIds m (SFSMethodCall o mid args) = SFSMethodCall (mapId m o) mid (map (mapExpr m) args) renameIds m (SFSFunctionCall o fn args) = SFSFunctionCall (mapId m o) fn (map (mapExpr m) args) renameIds m (SFSResets ss) = SFSResets (map (renameIds m) ss) renameIds m (SFSReturn (Just e)) = SFSReturn (Just (mapExpr m e)) renameIds m (SFSOutputReset i e) = SFSOutputReset (mapId m i) (mapExpr m e) renameIds _ s = s -- A SimCCSched pairs a clock edge with the SimCCFns that should be -- executed on the edge and possibly also after the edge. data SimCCSched = SimCCSched { sched_clock :: AExpr -- the clock for the schedule , sched_posedge :: Bool -- for the posedge of the clock? , sched_fn :: SimCCFn -- the schedule function definition , sched_after_fn :: Maybe SimCCFn -- sched fn after edge } deriving (Eq, Show) -- A SimCCClockGroup represents a group of per-instance clocks -- that all refer to a single clock by a canonical name data SimCCClockGroup = SimCCClockGroup { grp_canonical :: AClock , grp_instances :: [DomainId] } deriving (Eq, Show) -- A SimCCReset represents a reset function along with the information -- needed to register the reset function at run-time. data SimCCReset = SimCCReset { rst_number :: Integer , rst_port :: Maybe (String, String) , rst_function :: SimCCFn } deriving (Eq, Show) -- SimCCGateInfo is a list of the gate sources for each numbered gate -- of an instance. A gate source is either a constant boolean value -- or a port on a primitive module, represented by a qualified Id. type SimCCGateInfo = [(String, [(Int, Either Bool AId)])] -- the name for the reset method, for a particular reset name mkResetFnName :: AId -> String mkResetFnName i = "reset_" ++ getIdBaseString i -- the name of the field in a child module which holds the pointer to a -- reset function of the parent module (for asserting an output reset) mkResetFnDefName :: AId -> String mkResetFnDefName i = "reset_fn_" ++ getIdBaseString i resetFnDefType :: CCFragment -> CCFragment resetFnDefType = userType "tResetFn" mkSetResetFnName :: AId -> String mkSetResetFnName rstId = "set_reset_fn_" ++ getIdBaseString rstId -- these match definitions in bluesim_types.h badClockHandleName :: String badClockHandleName = "BAD_CLOCK_HANDLE" clockType :: CCFragment -> CCFragment clockType = userType "tClock" -- convert a clock domain into a string clkDomString :: ClockDomain -> String clkDomString dom = if (dom == noClockDomain) then badClockHandleName else show (writeClockDomain dom) -- the name of the field in which the clock handle for a domain is stored mkClkDefName :: ClockDomain -> String mkClkDefName dom = "__clk_handle_" ++ (clkDomString dom) mkSetClkFnName :: ClockDomain -> String mkSetClkFnName dom = "set_clk_" ++ (clkDomString dom) -- name for a static wrapper to a method mkStaticName :: String -> String mkStaticName s = "static_" ++ s -- Static methods use this name for the incoming void* myThis :: String myThis = "my_this" mkLiteralName :: Integer -> Integer -> String mkLiteralName nBits val | nBits > 64 = "UWide_literal_" ++ (show nBits) ++ "_h" ++ (showHex val "") | otherwise = "Arg_literal_" ++ (show nBits) ++ "_h" ++ (showHex val "") mkStringLiteralName :: Integer -> String mkStringLiteralName n = "__str_literal_" ++ (show n) -- convert an AType into a combinator for the appropriate C type aTypeToCType :: AType -> (CCFragment -> CCFragment) aTypeToCType (ATBit size) = (`ofType` (bitsType size CTunsigned)) aTypeToCType (ATString _) = (`ofType` (classType "std::string")) aTypeToCType (ATReal) = (`ofType` doubleType) aTypeToCType (ATArray _ _) = internalError "Unexpected array" aTypeToCType (ATAbstract _ _) = internalError "Unexpected abstract type" -- =============== pfxPort, pfxParam, pfxDef, pfxMeth, pfxInst, pfxMod, pfxArg, pfxModel :: String pfxPort = "PORT_" pfxParam = "PARAM_" pfxDef = "DEF_" pfxMeth = "METH_" pfxInst = "INST_" pfxMod = "MOD_" pfxArg = "ARG_" pfxModel = "MODEL_" -- convert an AId for a port into a CCExpr with full path qualification aPortIdToC :: AId -> CCExpr aPortIdToC id = let (qs, v) = adjustInstQuals id v' = pfxPort ++ v (p:ps) = qs ++ [v'] in foldl cDot (var p) ps aUnqualPortIdToString :: AId -> String aUnqualPortIdToString id = pfxPort ++ getIdBaseString id -- convert an AId for a port into a CCFragment with full path qualification aPortIdToCLval :: AId -> CCFragment aPortIdToCLval id = stmt (aPortIdToC id) -- convert an AId for a param into a CCExpr with full path qualification aParamIdToC :: AId -> CCExpr aParamIdToC id = let (qs, v) = adjustInstQuals id v' = pfxParam ++ v (p:ps) = qs ++ [v'] in foldl cDot (var p) ps -- convert an AId for a param into a CCFragment with full path qualification aParamIdToCLval :: AId -> CCFragment aParamIdToCLval id = stmt (aParamIdToC id) -- convert an AId for a def into a CCExpr with full path qualification aDefIdToC :: AId -> CCExpr aDefIdToC id = let (qs, v) = adjustInstQuals id v' = pfxDef ++ v (p:ps) = qs ++ [v'] in foldl cDot (var p) ps aUnqualDefIdToString :: AId -> String aUnqualDefIdToString id = pfxDef ++ getIdBaseString id -- convert an AId for a def into a CCFragment with full path qualification aDefIdToCLval :: AId -> CCFragment aDefIdToCLval id = stmt (aDefIdToC id) aInstMethIdToC :: AId -> AId -> CCExpr aInstMethIdToC instId methId = let -- drop the qualifier on the method (its package) m = getIdBaseString methId m' = pfxMeth ++ m in (aInstIdToC instId) `cDot` m' -- convert an AId for an inst into a CCExpr with full path qualification aInstIdToC :: AId -> CCExpr aInstIdToC id = let (qs, v) = adjustInstQuals id (p:ps) = qs ++ (if (null v) then [] else [pfxInst ++ v]) in foldl cDot (var p) ps aUnqualInstIdToString :: AId -> String aUnqualInstIdToString id = pfxInst ++ getIdBaseString id -- convert an AId for an inst into a CCFragment with full path qualification aInstIdToCLval :: AId -> CCFragment aInstIdToCLval id = stmt (aInstIdToC id) -- convert an AId for a func arg into a CCExpr with full path qualification aArgIdToC :: AId -> CCExpr aArgIdToC id = let v = getIdBaseString id v' = pfxArg ++ v in -- check that the argument has no qualifier if (getIdQualString id == "") then var v' else internalError ("aArgIdToC: " ++ ppReadable id) -- convert an AId for a func arg into a CCFragment with full path qualification aArgIdToCLval :: AId -> CCFragment aArgIdToCLval id = stmt (aArgIdToC id) -- convert an AId for a rule into a CCExpr with full path qualification aRuleIdToC :: AId -> CCExpr aRuleIdToC id = let (qs, v) = adjustInstQuals id -- rule names need no additional prefix v' = v (p:ps) = qs ++ [v'] in foldl cDot (var p) ps -- convert the unique Int for a clock gate into a CCFragment referencing -- the local array of clock gate pointers aGateIdToC :: Int -> CCExpr aGateIdToC num = cDeref $ cIndex (var "clk_gate") (mkUInt32 (toInteger num)) mkGateConst :: Bool -> CCFragment mkGateConst b = let c = mkBit $ if b then 1 else 0 v = mkVar $ "CONST_gate_" ++ if b then "true" else "false" in static $ (v `assign` c) `ofType` bitsType 1 CTunsigned mkGateDecls :: Integer -> [CCFragment] mkGateDecls sz = [ decl $ arraySz sz $ ptr $ mkVar "clk_gate" `ofType` bitsType 1 CTunsigned ] mkGateAssign :: String -> String -> Int -> Either Bool AId -> CCFragment mkGateAssign top inst num gate_src = let srcToCExpr (Right portId) = -- XXX the arrow syntax requires a string (var top) `cArrow` (ppString (aPortIdToC portId)) srcToCExpr (Left True) = var "CONST_gate_true" srcToCExpr (Left False) = var "CONST_gate_false" -- XXX the arrow syntax requires a string meth = if (inst == "") then "clk_gate" else let -- aInstIdToC will accept an Id with no base instId = setIdQualString (mk_homeless_id "") inst in ppString $ cDot (aInstIdToC instId) "clk_gate" gate_arr = (var top) `cArrow` meth gate_elem = cIndex gate_arr (mkUInt32 (toInteger num)) in assign (stmt gate_elem) (cAddr (srcToCExpr gate_src)) adjustInstQuals :: AId -> ([String], String) adjustInstQuals id = let v = getIdBaseString id qs = wordsBy (=='.') (getIdQualString id) qs' = map (pfxInst ++) qs in (qs', v) -- =============== -- check if an aexpr is just a var id, or other situation not to deal by wop hasWop :: AExpr -> Bool hasWop (APrim { aprim_prim = p }) = (p /= PrimIf) hasWop _ = False -- --------------------- -- The primitive modules -- This is a list of SimCCBlocks describing primitive modules primBlocks :: [SimCCBlock] primBlocks = let mods = [ (name, (f name mod)) | (name, mod, f, _) <- primMap ] mkMod n (name,fn) = SimCCBlock n name fn [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] in zipWith mkMod [1..] mods -- Test if a block is one of the primitive blocks isPrimBlock :: SBId -> Bool isPrimBlock id = any (\sb -> (sb_id sb) == id) primBlocks -- ======================================== -- Utility for converting AExprs to CCExprs -- The conversion is done in a State monad which records: -- 1. values of wide literals appearing in converted -- expressions, since these cannot be generated inline -- in C/C++ and must be declared and defined outside -- of the expressions in which they occur. We also generate -- out-of-line literals for narrow literals which are passed -- as polymorphic arguments to foreign functions, since -- these will be passed as unsigned int*s. -- 2. values of string literals appearing in converted -- expressions, since these need to be std::string -- values defined outside of the expressions in which they -- occur, so that embedded null characters are handled. -- 3. whether any expression contained a foreign function -- whose arguments were copied, so that the memory can -- be released after the function returns. -- It also keeps the map from foreign function names to -- ForeignFunctions, which is read but not written. data ConvState = CS { literals :: [(ASize,Integer)] , str_literal_count :: Integer , str_map :: M.Map String Integer , copied_args :: Bool , function_map :: ForeignFuncMap -- wide data declared in block scopes (looked up by scope) , blk_wdata :: WideDefMap -- wide data declared in the current func's scope , func_wdata :: [AId] -- arguments, when converting inside a function , func_args :: [AId] -- unique ids for gate expressions , gate_map :: M.Map AExpr Int -- choice for don't-care values ("0", "1", or "A") , undet_type :: String } deriving (Eq,Show); type WideDefMap = M.Map String [AId] initialState :: ForeignFuncMap -> WideDefMap -> String -> ConvState initialState ff_map wdef_map undet_type = CS [] 1 M.empty False ff_map wdef_map [] [] M.empty undet_type type ExprConv = State ConvState CCExpr type ExprsConv = State ConvState [CCExpr] type StmtConv = State ConvState CCFragment type StmtsConv = State ConvState [CCFragment] setHasCopiedArg :: State ConvState () setHasCopiedArg = modify (\s -> s { copied_args = True }) clearHasCopiedArg :: State ConvState () clearHasCopiedArg = modify (\s -> s { copied_args = False }) addLit :: (ASize,Integer) -> State ConvState () addLit (w,n) = do lits <- gets literals modify (\s -> s { literals = ((w,n):lits) }) addStringLit :: String -> State ConvState () addStringLit s = do sm <- gets str_map case M.lookup s sm of (Just n) -> return () (Nothing) -> do n <- gets str_literal_count let sm' = M.insert s n sm modify (\s -> s { str_literal_count = n+1 , str_map = sm' }) getStringLiteralName :: String -> State ConvState String getStringLiteralName s = do sm <- gets str_map case M.lookup s sm of (Just n) -> return $ mkStringLiteralName n Nothing -> internalError $ "unknown string literal: " ++ s setFuncWData :: [AId] -> State ConvState () setFuncWData wids = modify (\s -> s {func_wdata = wids}) setFuncArgs :: [AId] -> State ConvState () setFuncArgs args = modify (\s -> s {func_args = args}) setGateMap :: [AExpr] -> State ConvState () setGateMap gs = let gmap = M.fromList (zip gs [0..]) in modify (\s -> s {gate_map = gmap}) getWDataTest :: State ConvState (AId -> Bool) getWDataTest = do bwdata <- gets blk_wdata fwdata <- gets func_wdata let f i = if (i `elem` fwdata) then True else let qual = getIdQualString i base = unQualId i wdefs = M.findWithDefault [] qual bwdata in base `elem` wdefs return f isWideDef :: (AType, AId) -> Bool isWideDef x@(ATBit sz, aid) | sz > 64 = True isWideDef x = False mkUndetVal :: AType -> State ConvState CCExpr mkUndetVal ty = do tgt <- gets undet_type let n = aSize ty v = case tgt of "0" -> 0 "1" -> (2^n) - 1 "A" -> aaaa n _ -> -- this situation should have been rejected when -- we checked command-line flags internalError $ "SimCCBlock.mkUndetVal: unexpected undet type: " ++ show tgt aExprToCExpr noRet $ ASInt dummy_id (ATBit n) (ilSizedHex n v) -- ---------------------- -- Support for primitives sizedName :: String -> Integer -> String sizedName name sz | sz <= 8 = name ++ "8" sizedName name sz | sz <= 32 = name ++ "32" sizedName name sz | sz <= 64 = name ++ "64" sizedName name sz {- sz>64 -} = name ++ "Wide" mkMask :: Integer -> CCExpr mkMask sz | sz <= 8 = mkUInt8 ((2 ^ sz) - 1) mkMask sz | sz <= 32 = mkUInt32 ((2 ^ sz) - 1) mkMask sz | sz <= 64 = mkUInt64 ((2 ^ sz) - 1) mkMask sz = internalError $ "mkMask for wide data (" ++ (show sz) ++ " bits)" -- Mask off bits of an expression result beyond its desired bit size -- For an expression which is already of size 32 or 64, no masking -- is necessary, but expressions of other sizes need masking. -- Specifically, expressions of size 8 do still need masking because -- they may actually have been promoted to size 32 by C semantics. addMask :: Integer -> CCExpr -> CCExpr addMask sz expr | (sz == 32) || (sz == 64) = expr | sz < 64 = (mkMask sz) `cBitAnd` expr addMask sz expr = (var (sizedName "mask" sz)) `cCall` [mkUInt32 sz,expr] -- cast an expression to the correct type for its desired size -- Generate an expression for a simple unary operator (!, ~, -) simplePrim1 :: (Maybe (Bool,AId)) -> (CCExpr -> CCExpr) -> String -> AExpr -> ExprConv simplePrim1 ret op op_name arg = do wdata_test <- getWDataTest v <- aExprToCExpr noRet arg let (w_ret, w_wret) = case ret of Nothing -> ([], False) (Just (False,aid)) -> ([aDefIdToC aid], (wdata_test aid)) (Just (True,aid)) -> ([aPortIdToC aid], (wdata_test aid)) if w_wret then do let wop_name = var ("wop_"++op_name) return $ wop_name `cCall` (v:w_ret) else do return $ op v -- Generate an expression for a simple binary operator (one which does -- not need masking because it doesn't generate high bits). simplePrim2 :: (Maybe (Bool,AId)) -> (CCExpr -> CCExpr -> CCExpr) -> String -> AExpr -> AExpr -> ExprConv simplePrim2 ret op op_name arg1 arg2 = do wdata_test <- getWDataTest v1 <- aExprToCExpr noRet arg1 v2 <- aExprToCExpr noRet arg2 let (w_ret,w_wret) = -- w_wret is true if ret exists & is wide-data case ret of Nothing -> ([], False) (Just (False,aid)) -> ([aDefIdToC aid], (wdata_test aid)) (Just (True,aid)) -> ([aPortIdToC aid], (wdata_test aid)) if w_wret then do let wop_name = var ("wop_"++op_name) return $ wop_name `cCall` ([v1, v2]++w_ret) else do return $ v1 `op` v2 -- Generate an expression for a simple N-ary operator (one which does -- not need masking because it doesn't generate high bits). simplePrimN :: (Maybe (Bool,AId)) -> (CCExpr -> CCExpr -> CCExpr) -> String -> [AExpr] -> ExprConv simplePrimN ret op op_name args = do wdata_test <- getWDataTest vs <- mapM (aExprToCExpr noRet) args let (w_ret,w_wret) = -- w_wret is true if ret exists & is wide-data case ret of Nothing -> ([], False) (Just (False,aid)) -> ([aDefIdToC aid], (wdata_test aid)) (Just (True,aid)) -> ([aPortIdToC aid], (wdata_test aid)) if w_wret -- XXX we will need to support vararg wop_ for {&,|,^} if we ever -- XXX start generating AExprs that could contain wide n-ary versions then do let wop_name = var ("wop_"++op_name) return $ wop_name `cCall` (vs++w_ret) else do return $ foldl1 op vs -- Generate an expression for a unary operator that requires masking maskedPrim1 :: (Maybe (Bool,AId)) -> ASize -> (CCExpr -> CCExpr) -> String -> AExpr -> ExprConv maskedPrim1 ret out_width op op_name arg = do v <- simplePrim1 ret op op_name arg if out_width > 64 then return v else return $ addMask out_width v -- Generate an expression for a binary operator that requires masking maskedPrim2 :: (Maybe (Bool,AId)) -> Integer -> (CCExpr -> CCExpr -> CCExpr) -> String -> AExpr -> AExpr -> ExprConv maskedPrim2 ret out_width op op_name arg1 arg2 = do v <- simplePrim2 ret op op_name arg1 arg2 if out_width > 64 then return v else return $ addMask out_width v -- Generate an expression for a multiplication operator. -- Multiplication is special because we want to use the built-in operator -- but must also deal with the larger size of the result, -- which is not part of the C/C++ semantics for multiplication. mulPrim :: (Maybe (Bool,AId)) -> Integer -> String -> AExpr -> AExpr -> ExprConv mulPrim ret out_width op_name arg1 arg2 = let promote out_w in_w x | out_w > 64 && in_w <= 64 = (var "WideData") `cCall` [mkUInt32 in_w, x] | (bitsType out_w CTunsigned) /= (bitsType in_w CTunsigned) = cCast (bitsType out_w CTunsigned) x | otherwise = x in do v1 <- aExprToCExpr noRet arg1 v2 <- aExprToCExpr noRet arg2 wdata_test <- getWDataTest let p_v1 = promote out_width (aSize arg1) v1 p_v2 = promote out_width (aSize arg2) v2 (w_ret,w_wret) = case ret of Nothing -> ([], False) (Just (False,aid)) -> ([aDefIdToC aid], (wdata_test aid)) (Just (True,aid)) -> ([aPortIdToC aid], (wdata_test aid)) if w_wret then return $ (var ("wop_"++op_name)) `cCall` ([p_v1, p_v2]++w_ret) else return $ addMask out_width (p_v1 `cMul` p_v2) -- Generate an expression for a wide extraction operator. Wide -- bit/part extracts are special because we want to optimize the -- primitive selection based on whether the extraction is byte/word -- aligned or not. wideExtractPrim :: (Maybe (Bool,AId)) -> Integer -> AExpr -> Integer -> Integer -> ExprConv wideExtractPrim ret out_width e hi lo = do v <- aExprToCExpr noRet e wdata_test <- getWDataTest let (w_ret,w_wret) = case ret of Nothing -> ([], False) (Just (False,aid)) -> ([aDefIdToC aid], (wdata_test aid)) (Just (True,aid)) -> ([aPortIdToC aid], (wdata_test aid)) if w_wret then return $ (var "wop_primExtractWide") `cCall` ([ mkUInt32 out_width , mkUInt32 (aSize e), v , mkUInt32 32, mkUInt32 hi , mkUInt32 32, mkUInt32 lo ] ++ w_ret) else if (out_width > 32) then mkPrimCall ret out_width "Extract" [e, aNat hi, aNat lo] else if (((lo `rem` 32) == 0) && (out_width == 32)) then return $ (v `cDot` "get_whole_word") `cCall` [ mkUInt32 (lo `quot` 32) ] else if ((lo `quot` 32) == (hi `quot` 32)) then if (out_width > 8) then return $ (v `cDot` "get_bits_in_word32") `cCall` [ mkUInt32 (lo `quot` 32) , mkUInt32 (lo `rem` 32) , mkUInt32 (hi - lo + 1) ] else return $ (v `cDot` "get_bits_in_word8") `cCall` [ mkUInt32 (lo `quot` 32) , mkUInt32 (lo `rem` 32) , mkUInt32 (hi - lo + 1) ] else mkPrimCall ret out_width "Extract" [e, aNat hi, aNat lo] -- Generate an expression for a wide concatenation operator. -- Wide concats are special because we need to handle 2, 3 or more -- arguments of arbitrary sizes and we want to optimize the primitive -- selection based on whether the concat segments are word aligned -- or not. wideConcatPrim :: (Maybe (Bool,AId)) -> Integer -> [AExpr] -> ExprConv wideConcatPrim ret out_width args = do arg_exprs <- mapM (aExprToCExpr noRet) args let arg_widths = map aSize args shift_amounts = tail $ scanr (+) 0 arg_widths wdata_test <- getWDataTest let (w_ret,w_wret) = case ret of Nothing -> ([], False) (Just (False,aid)) -> ([aDefIdToC aid], (wdata_test aid)) (Just (True,aid)) -> ([aPortIdToC aid], (wdata_test aid)) add_concat_part :: CCExpr -> (CCExpr,Integer,Integer) -> CCExpr add_concat_part base (e,sh,w) = if (((sh `rem` 32) == 0) && (w == 32)) then (base `cDot` "set_whole_word") `cCall` [e, mkUInt32 (sh `quot` 32)] else if ((sh `quot` 32) == ((sh + w) `quot` 32)) then (base `cDot` "set_bits_in_word") `cCall` [e, mkUInt32 (sh `quot` 32), mkUInt32 (sh `rem` 32), mkUInt32 w] else (base `cDot` "build_concat") `cCall` [e, mkUInt32 sh, mkUInt32 w] if w_wret then do return $ foldl add_concat_part (head w_ret) (zip3 arg_exprs shift_amounts arg_widths) else do return $ foldl add_concat_part ((var "bs_wide_tmp") `cCall` [mkUInt32 out_width]) (zip3 arg_exprs shift_amounts arg_widths) -- ------------------------------------------------- -- Converting expressions from ASyntax into CCSyntax -- Make a call to a primitive function mkPrimCall :: (Maybe (Bool,AId)) -> Integer -> String -> [AExpr] -> ExprConv mkPrimCall ret sz name args = do arg_list <- mapM mkArg args let arg_sizes = [ mkUInt32 (arg_size a) | a <- args ] sized_arg_list =concat (zipWith (\a b->[a,b]) arg_sizes arg_list) arg_list' = (mkUInt32 sz):sized_arg_list w_ret = case ret of Nothing -> [] (Just (False,aid)) -> [aDefIdToC aid] (Just (True,aid)) -> [aPortIdToC aid] (arg_list_ret, call_name) = if (sz > 64 && not (null w_ret)) then ((arg_list'++(w_ret)), ("wop_prim" ++ (sizedName name sz))) else (arg_list', "prim" ++ (sizedName name sz)) return $ (var call_name) `cCall` arg_list_ret where arg_size :: AExpr -> ASize arg_size expr = case (aType expr) of (ATString Nothing) -> 0 (ATReal) -> 0 _ -> aSize expr -- overload resolution needs specific information on argument types mkArg expr = if (isConst expr) || (isStringType (aType expr)) || ((aType expr) == ATReal) || ((aSize expr) > 64) then aExprToCExpr noRet expr else do cexpr <- aExprToCExpr noRet expr return $ (bitsType (aSize expr) CTunsigned) `cCast` cexpr numWords :: Integer -> CCExpr numWords n = mkUInt32 ((n + 31) `div` 32) -- convert an argument list into a list of CExprs for a particular -- function call convertArgList :: [Argument] -> ExprsConv convertArgList args = convert args (encodeArgs args) where convert [] _ = return [] convert ((SimHdl):rest) str = do rest' <- convert rest str return ((var "sim_hdl"):rest') convert ((Module):rest) str = do rest' <- convert rest str return ((var "this"):rest') convert ((ArgStr):rest) str = do rest' <- convert rest str return ((mkStr str):rest') convert ((Arg e):rest) str = do e' <- aExprToCExpr noRet e rest' <- convert rest str return (e':rest') convert ((Field e f):rest) str = do e' <- aExprToCExpr noRet e rest' <- convert rest str return ((e' `cDot` f):rest') convert ((Ptr (ASInt _ ty val)):rest) str | aSize ty <= 64 = do let w = aSize ty x = ilValue val e' = (var (mkLiteralName w x)) `cDot` "data" addLit (w,x) -- record the literal for out-of-line generation rest' <- convert rest str return (e':rest') convert ((Ptr e):rest) str = do e' <- aExprToCExpr noRet e rest' <- convert rest str return ((cAddr e'):rest') convert ((Copy a@(Arg _)):rest) str = do e' <- convertSingle a str rest' <- convert rest str setHasCopiedArg let copy = (var "copy_arg") `cCall` [e'] return (copy:rest') convert ((Copy a):rest) str = do e' <- convertSingle a str rest' <- convert rest str setHasCopiedArg let arg_list = case argExpr a of (Just e) -> [e', numWords (aSize e) ] Nothing -> [e'] copy = (var "copy_arg") `cCall` arg_list return (copy:rest') convert ((NoConst a):rest) str = do e' <- convert [a] str rest' <- convert rest str let cast = var "const_cast" return ((cast `cCall` e'):rest') convert (Null:rest) str = do rest' <- convert rest str return (mkNULL:rest') convert ((Alloc n r):rest) str = do rest' <- convert rest str setHasCopiedArg let fn = if r then (var "return_arg") else (var "ignore_arg") alloc = fn `cCall` [ numWords n ] return (alloc:rest') convertSingle e str = do es' <- convert [e] str case es' of [e'] -> return e' _ -> internalError ("convertSingle: unexpected list") wrapReturn :: (Maybe (Bool,AId)) -> CCExpr -> CCExpr wrapReturn (Just (False,aid)) call = (var "write_return") `cCall` [ cGroup (call `cComma` (mkUInt32 0)) , cAddr (aDefIdToC aid) ] wrapReturn (Just (True,aid)) call = (var "write_return") `cCall` [ cGroup (call `cComma` (mkUInt32 0)) , cAddr (aPortIdToC aid) ] wrapReturn Nothing call = call -- Use this for expressions which should never use a return argument noRet :: (Maybe (Bool,AId)) noRet = Nothing -- Helper function to verify the correct number of arguments argCount :: (Int -> Bool) -> [AExpr] -> (a -> a) argCount pred args = if pred (length args) then id else internalError $ "aExprToCExpr: wrong number of arguments:\n" ++ " " ++ (ppReadable args) ++ "\n" getConstVal :: AExpr -> Maybe Integer getConstVal (ASInt _ _ l@(IntLit {})) = Just (ilValue l) getConstVal _ = Nothing -- convert an AExpr into a CExpr -- The first argument is used when the value must be written explicitly -- to the output rather than simply returned (used with wide/polymoprhic -- expressions). aExprToCExpr :: (Maybe (Bool,AId)) -> AExpr -> ExprConv aExprToCExpr ret p@(APrim _ _ PrimAdd args) = argCount (==2) args $ maskedPrim2 ret (aSize p) (cAdd) (toWString PrimAdd) (args!!0) (args!! 1) aExprToCExpr ret p@(APrim _ _ PrimSub args) = argCount (==2) args $ maskedPrim2 ret (aSize p) (cSub) (toWString PrimSub) (args!!0) (args!! 1) aExprToCExpr ret p@(APrim _ _ PrimMul args) = argCount (==2) args $ mulPrim ret (aSize p) (toWString PrimMul) (args!!0) (args!! 1) aExprToCExpr ret p@(APrim _ _ PrimQuot args) = argCount (==2) args $ maskedPrim2 ret (aSize p) (cQuot) (toWString PrimQuot) (args!!0) (args!! 1) aExprToCExpr ret p@(APrim _ _ PrimRem args) = argCount (==2) args $ maskedPrim2 ret (aSize p) (cRem) (toWString PrimRem) (args!!0) (args!! 1) aExprToCExpr ret (APrim _ _ PrimAnd args) = argCount (>1) args $ simplePrimN ret (cBitAnd) (toWString PrimAnd) args aExprToCExpr ret (APrim _ _ PrimOr args) = argCount (>1) args $ simplePrimN ret (cBitOr) (toWString PrimOr) args aExprToCExpr ret (APrim _ _ PrimXor args) = argCount (>1) args $ simplePrimN ret (cBitXor) (toWString PrimXor) args aExprToCExpr ret p@(APrim _ _ PrimSL args) = argCount (==2) args $ mkPrimCall ret (aSize p) "ShiftL" args aExprToCExpr ret p@(APrim _ _ PrimSRL args) = argCount (==2) args $ mkPrimCall ret (aSize p) "ShiftR" args aExprToCExpr ret p@(APrim _ _ PrimSRA args) = argCount (==2) args $ mkPrimCall ret (aSize p) "ShiftRA" args aExprToCExpr ret p@(APrim _ _ PrimInv args) = argCount (==1) args $ maskedPrim1 ret (aSize p) (cCompl) (toWString PrimInv) (args!!0) aExprToCExpr ret p@(APrim _ _ PrimNeg args) = argCount (==1) args $ maskedPrim1 ret (aSize p) (cUMinus) (toWString PrimNeg) (args!!0) aExprToCExpr _ (APrim _ _ PrimEQ args) = argCount (==2) args $ simplePrim2 noRet (cEq) (toWString PrimEQ) (args!!0) (args!!1) -- Bluesim isn't 4-state, so PrimEQ3 is the same as PrimEQ aExprToCExpr _ (APrim _ _ PrimEQ3 args) = argCount (==2) args $ simplePrim2 noRet (cEq) (toWString PrimEQ) (args!!0) (args!!1) aExprToCExpr _ (APrim _ _ PrimULE args) = argCount (==2) args $ simplePrim2 noRet (cLe) (toWString PrimULE) (args!!0) (args!!1) aExprToCExpr _ (APrim _ _ PrimULT args) = argCount (==2) args $ simplePrim2 noRet (cLt) (toWString PrimULT) (args!!0) (args!!1) aExprToCExpr _ p@(APrim _ _ PrimSLE args) = argCount (==2) args $ mkPrimCall noRet (aSize p) "SLE" args aExprToCExpr _ p@(APrim _ _ PrimSLT args) = argCount (==2) args $ mkPrimCall noRet (aSize p) "SLT" args aExprToCExpr _ (APrim _ _ PrimIf args) = argCount (==3) args $ do c <- aExprToCExpr noRet (args!!0) v1 <- aExprToCExpr noRet (args!!1) v0 <- aExprToCExpr noRet (args!!2) return $ cTernary c v1 v0 aExprToCExpr ret p@(APrim _ _ PrimSignExt args) = argCount (==1) args $ mkPrimCall ret (aSize p) "SignExt" args aExprToCExpr ret p@(APrim _ _ PrimZeroExt args) = argCount (==1) args $ mkPrimCall ret (aSize p) "ZeroExt" args aExprToCExpr ret p@(APrim _ _ PrimTrunc args) = argCount (==1) args $ mkPrimCall ret (aSize p) "Trunc" args aExprToCExpr ret p@(APrim _ _ PrimExtract args) = argCount (==3) args $ let mhi = getConstVal (args!!1) mlo = getConstVal (args!!2) in case (mhi,mlo) of (Just hi, Just lo) -> if ((aSize p) > 64) || ((aSize (args!!0)) > 64) then wideExtractPrim ret (aSize p) (args!!0) hi lo else do v <- aExprToCExpr noRet (args!!0) let out_width = aSize p out_type = bitsType out_width CTunsigned v' = v `cRShift` (mkUInt32 lo) v'' = if (hi == (aSize (args!!0)) - 1) then v' else addMask out_width v' return $ out_type `cCast` v'' _ -> mkPrimCall ret (aSize p) "Extract" args aExprToCExpr ret p@(APrim _ _ PrimConcat args) = argCount (>=2) args $ if (aSize p) <= 64 then do let arg_widths = map aSize args arg_types = map (\w -> bitsType w CTunsigned) arg_widths out_width = aSize p out_type = bitsType out_width CTunsigned arg_exprs <- mapM (aExprToCExpr noRet) args let arg_exprs_cast = [ if (t == out_type) then e else (out_type `cCast` e) | (e,t) <- zip arg_exprs arg_types ] shift_amounts = tail $ scanr (+) 0 arg_widths shifted_exprs = zipWith cLShift arg_exprs_cast (map mkUInt32 shift_amounts) or_together = foldl1 cBitOr shifted_exprs return $ addMask out_width or_together else wideConcatPrim ret (aSize p) args aExprToCExpr _ (APrim _ _ PrimBAnd args) = argCount (>1) args $ simplePrimN noRet (cAnd) (toWString PrimBAnd) args aExprToCExpr _ (APrim _ _ PrimBOr args) = argCount (>1) args $ simplePrimN noRet (cOr) (toWString PrimBOr) args aExprToCExpr _ (APrim _ _ PrimBNot args) = argCount (==1) args $ simplePrim1 noRet (cNot) (toWString PrimBNot) (args!!0) aExprToCExpr _ p@(APrim _ _ PrimStringConcat args) = argCount (==2) args $ simplePrim2 noRet (cAdd) (ppString PrimAdd) (args!!0) (args!! 1) aExprToCExpr _ p@(APrim _ _ _ _) = internalError ("unhandled primitive: " ++ (show p)) aExprToCExpr _ (AMethCall _ id mid args) = do arg_list <- mapM (aExprToCExpr noRet) args return $ (aInstMethIdToC id mid) `cCall` arg_list aExprToCExpr _ e@(AMGate _ id clkid) = do gmap <- gets gate_map case (M.lookup e gmap) of Just num -> return $ aGateIdToC num Nothing -> internalError ("Unexpected clock gate: AMGate " ++ getIdString id ++ "." ++ getIdString clkid) aExprToCExpr _ (ASParam _ id) = do return $ aParamIdToC id aExprToCExpr _ e@(ASPort _ id) = do args <- gets func_args gmap <- gets gate_map return $ if (id `elem` args) then aArgIdToC id else case (M.lookup e gmap) of Just num -> aGateIdToC num Nothing -> aPortIdToC id aExprToCExpr _ (ASDef _ id) = do return $ aDefIdToC id aExprToCExpr _ (ASInt _ (ATBit w) val) | w == 1 = do return $ mkBit (ilValue val) | w <= 8 = do return $ mkUInt8 (ilValue val) | w <= 32 = do return $ mkUInt32 (ilValue val) | w <= 64 = do return $ mkUInt64 (ilValue val) | otherwise = do let x = ilValue val addLit (w,x) -- record the wide literal for out-of-line generation return $ var (mkLiteralName w x) aExprToCExpr _ (ASReal _ _ val) = return $ mkDouble val aExprToCExpr _ (ASStr _ _ str) = -- do return $ mkStr str do addStringLit str nm <- getStringLiteralName str return $ var nm aExprToCExpr ret f@(AFunCall {}) = do ff_map <- gets function_map let (ret_style,name,arg_list) = mkCallExpr ff_map ret f ret' = case ret_style of Buffered -> ret otherwise -> Nothing args <- convertArgList arg_list return $ wrapReturn ret' ((var name) `cCall` args) aExprToCExpr _ (ASAny ty _) = internalError "ASAny should not exist past SimExpand" aExprToCExpr _ x = internalError ("Unhandled expr: " ++ (show x)) -- ============================================== -- Converting SimCCBlock structures into CCSyntax -- Generate a C method declaration from a SimCCFn simFnToCDeclaration :: SimCCFn -> CCFragment simFnToCDeclaration (SimCCFn name args ret _) = let arg_list = [ (aTypeToCType ty) (aArgIdToCLval id) | (ty,id) <- args] rt = maybe void aTypeToCType ret in decl $ function rt (mkVar name) arg_list -- Generate a declaration for a static wrapper, which takes a class pointer simFnToStaticCDeclaration :: SimCCFn -> CCFragment simFnToStaticCDeclaration (SimCCFn name args ret _) = let class_ptr = ptr $ void (mkVar myThis) arg_list = [ (aTypeToCType ty) (aArgIdToCLval id) | (ty,id) <- args] rt = maybe void aTypeToCType ret static_name = mkStaticName name in static $ decl $ function rt (mkVar static_name) (class_ptr:arg_list) -- Generate a C statement from a SimCCFnStmt simFnStmtToCStmt :: SimCCFnStmt -> StmtConv simFnStmtToCStmt (SFSDef isPort (ty@(ATString _),aid) Nothing) = do let dst = if isPort then aPortIdToCLval aid else aDefIdToCLval aid return $ decl $ (aTypeToCType ty) dst simFnStmtToCStmt (SFSDef isPort (ty@(ATReal),aid) Nothing) = do let dst = if isPort then aPortIdToCLval aid else aDefIdToCLval aid return $ decl $ (aTypeToCType ty) dst simFnStmtToCStmt (SFSDef isPort (ty,aid) Nothing) = let w = aSize ty dst = if isPort then aPortIdToCLval aid else aDefIdToCLval aid typed_id = (aTypeToCType ty) dst in if w > 64 -- for wide data, use (bits,false) constructor to avoid initialization penalty then return $ construct typed_id [mkUInt32 w, mkBool False] else return $ decl typed_id simFnStmtToCStmt (SFSDef isPort (ty@(ATString (Just sz)),aid) (Just expr)) = do let dst = if isPort then aPortIdToCLval aid else aDefIdToCLval aid typed_id = (aTypeToCType ty) dst v <- aExprToCExpr noRet expr return $ construct typed_id [v, mkUInt32 sz] simFnStmtToCStmt (SFSDef isPort (ty,aid) (Just expr)) = do ff_map <- gets function_map let isCase (APrim _ _ PrimCase _) = True isCase _ = False when (isCase expr) $ internalError ("Case definition cannot have initializer") when (wideReturn ff_map expr || polyReturn ff_map expr) $ internalError "Wide/polymorphic definition cannot have initializer" let dst = if isPort then aPortIdToCLval aid else aDefIdToCLval aid typed_id = (aTypeToCType ty) dst v <- aExprToCExpr (Just (False,aid)) expr return $ decl $ typed_id `assign` v -- eventually, we may want to create SFSSwitch and have a pass that transforms -- a list of SimCCFnStmt so that PrimCase in SFSDef and SFSAssign are handled -- as SFSSwitch (and we can move other stmts into the arms, as further opt) simFnStmtToCStmt (SFSAssign isPort aid (APrim _ _ PrimCase (idx:def:flat_arms))) = do c_idx <- aExprToCExpr noRet idx let arms = makePairs flat_arms -- Combine arms with the same result value; reordering is assumed -- to be OK because the expressions should be constant -- First, eliminate the arms that have the same value as the default. (_, arms') = partition ((== def) . snd) arms -- Then combine all the explicit indices. arms_combined = let combineFn [] = [] combineFn ((n, e) : nes) = let (common_nes, nes') = partition ((== e) . snd) nes common_ns = map fst common_nes in (n:common_ns, e) : combineFn nes' in combineFn arms' armToCCFragment (ns, e) = do -- sort the indices, so that it's consistent and looks nice let ns' = sortBy cmpASInt ns c_ns <- mapM (aExprToCExpr noRet) ns' c_e <- simFnStmtToCStmt (SFSAssign isPort aid e) let (ns_empty, n_last) = (initOrErr "armToCCFragment" c_ns, lastOrErr "armToCCFragment" c_ns) return $ [ (n, []) | n <- ns_empty ] ++ [ (n_last, [c_e, break_loop]) ] c_arms <- concatMapM armToCCFragment arms_combined c_def <- simFnStmtToCStmt (SFSAssign isPort aid def) return $ switch c_idx c_arms (Just [c_def]) simFnStmtToCStmt (SFSAssign isPort aid expr) = do ff_map <- gets function_map wdata_test <- getWDataTest v <- aExprToCExpr (Just (isPort,aid)) expr let b_wop = (hasWop expr) && (wdata_test aid) if wideReturn ff_map expr || polyReturn ff_map expr || b_wop then do return $ stmt v else do let dst = if isPort then aPortIdToCLval aid else aDefIdToCLval aid return $ dst `assign` v simFnStmtToCStmt (SFSAction act) = do (_, cond, call) <- aActionToCFunCall noRet act return $ if_cond cond (stmt call) Nothing simFnStmtToCStmt s@(SFSAssignAction isPort aid act ty) = do (ret_style, cond, call) <- aActionToCFunCall (Just (isPort,aid)) act case ret_style of Direct -> do let dst = if isPort then aPortIdToCLval aid else aDefIdToCLval aid undet <- mkUndetVal ty return $ if_cond cond (dst `assign` call) (Just (dst `assign` undet)) otherwise -> return $ if_cond cond (stmt call) Nothing simFnStmtToCStmt (SFSRuleExec ruleId) = return $ stmt $ (aRuleIdToC ruleId) `cCall` [] simFnStmtToCStmt (SFSCond cond [t] []) = do c <- aExprToCExpr noRet cond s <- simFnStmtToCStmt t return $ if_cond c s Nothing simFnStmtToCStmt (SFSCond cond [] [f]) = do c <- aExprToCExpr noRet cond s <- simFnStmtToCStmt f return $ if_cond (cNot c) s Nothing simFnStmtToCStmt (SFSCond cond t []) = do c <- aExprToCExpr noRet cond s <- mapM simFnStmtToCStmt t return $ if_cond c (block s) Nothing simFnStmtToCStmt (SFSCond cond [] f) = do c <- aExprToCExpr noRet cond s <- mapM simFnStmtToCStmt f return $ if_cond (cNot c) (block s) Nothing simFnStmtToCStmt (SFSCond cond t f) = do c <- aExprToCExpr noRet cond s1 <- mapM simFnStmtToCStmt t s2 <- mapM simFnStmtToCStmt f return $ if_cond c (block s1) (Just (block s2)) simFnStmtToCStmt (SFSMethodCall obj meth args) = do arg_list <- mapM (aExprToCExpr noRet) args return $ stmt $ (aInstMethIdToC obj meth) `cCall` arg_list simFnStmtToCStmt (SFSFunctionCall obj func args) = do arg_list <- mapM (aExprToCExpr noRet) args return $ stmt $ ((aInstIdToC obj) `cDot` func) `cCall` arg_list simFnStmtToCStmt (SFSResets stmts) = do let c = (var "do_reset_ticks") `cCall` [ var "simHdl" ] s <- mapM simFnStmtToCStmt stmts return $ if_cond c (block s) Nothing simFnStmtToCStmt (SFSReturn Nothing) = do return $ ret Nothing simFnStmtToCStmt (SFSReturn (Just expr)) = do v <- aExprToCExpr noRet expr return $ ret (Just v) simFnStmtToCStmt (SFSOutputReset rstId expr) = do let rstFn = mkResetFnDefName rstId rst_expr <- aExprToCExpr noRet expr -- make a call to the resetFn: reset_fn(parent, rst_in) let rstCall = stmt $ (var rstFn) `cCall` [var "parent", rst_expr] -- if the resetFn field is not set, then do nothing return $ if_cond (var rstFn) rstCall Nothing -- helper func to convert an AAction to its condition and its CFunCall, -- for embedding in a larger CC statement aActionToCFunCall :: (Maybe (Bool,AId)) -> AAction -> State ConvState (ReturnStyle, CCExpr, CCExpr) aActionToCFunCall _ c@(ACall id mth_id aargs) = do cargs <- mapM (aExprToCExpr noRet) aargs let (cond, arg_list) = case cargs of (x:xs) -> (x, xs) _ -> internalError ("aActionToCFunCall: missing cond in ACall args") let call = (aInstMethIdToC id mth_id) `cCall` arg_list return (Direct, cond, call) aActionToCFunCall Nothing act@(AFCall {}) = do ff_map <- gets function_map let c = headOrErr "action has no condition" (aact_args act) (_,name,arg_list) = mkCallAction ff_map Nothing act cond <- aExprToCExpr noRet c args <- convertArgList arg_list let call = (var name) `cCall` args return (None, cond, call) aActionToCFunCall ret act@(ATaskAction {}) = do ff_map <- gets function_map let c = headOrErr "action has no condition" (aact_args act) (ret_style,name,arg_list) = mkCallAction ff_map ret act cond <- aExprToCExpr noRet c args <- convertArgList arg_list let call = (var name) `cCall` args ret' = case ret_style of Buffered -> do aid <- ataskact_temp act return (maybe False fst ret, aid) otherwise -> Nothing return (ret_style, cond, wrapReturn ret' call) aActionToCFunCall ret act = internalError $ "aActionToCFunCall: unexpected return/action combination: " ++ (ppReadable (ret,act)) -- Generate a definition for a static wrapper, which takes a class pointer simFnToStaticCDefinition :: String -> SimCCFn -> CCFragment simFnToStaticCDefinition cls (SimCCFn name args rty _) = let class_ptr = ptr $ void (mkVar myThis) arg_list = [ (aTypeToCType ty) (aArgIdToCLval id) | (ty,id) <- args] rt = maybe void aTypeToCType rty prefix = cls ++ "::" static_name = mkStaticName name func = function rt (mkVar (prefix ++ static_name)) (class_ptr:arg_list) -- cast the void* to class* real_ptr = cCast (ptrType (classType cls)) (var myThis) -- call the non-static reset member function wrapped_call = let f = real_ptr `cArrow` name as = map (aArgIdToC . snd) args in f `cCall` as body = block [ if (isNothing rty) then stmt wrapped_call else ret (Just wrapped_call) ] in define func body prefixSimFnName :: String -> SimCCFn -> SimCCFn prefixSimFnName s (SimCCFn name args ret stmts) = SimCCFn (s ++ name) args ret stmts -- Generate a C method definition from a SimCCFn simFnToCDefinition :: Bool -> (Maybe String) -> [CCFragment] -> [CCFragment] -> SimCCFn -> StmtConv simFnToCDefinition is_static scope c_args prologue fn@(SimCCFn name args ret stmts) = do let prefix = maybe "" (++ "::") scope arg_list = c_args ++ [ (aTypeToCType ty) (aArgIdToCLval id) | (ty,id) <- args] rt = maybe void aTypeToCType ret (return_stmts,non_return_stmts) = partition isReturn stmts wdata_fn = concatMap (wideLocalDef) stmts setFuncWData wdata_fn setFuncArgs (map snd args) body_stmts <- mapM simFnStmtToCStmt non_return_stmts final_stmts <- mapM simFnStmtToCStmt return_stmts has_copies <- gets copied_args let free_copies = if has_copies then [ stmt $ (var "delete_arg_copies") `cCall` [] ] else [] body = block (prologue ++ body_stmts ++ free_copies ++ final_stmts) clearHasCopiedArg setFuncArgs [] let def = define (function rt (mkVar (prefix ++ name)) arg_list) body return $ if is_static then static def else def -- Helper routine for creating submodule member declarations memberDecl :: SBMap -> SBId -> AId -> [AExpr] -> CCFragment memberDecl sb_map sbid aid args = decl $ (moduleType (lookupSB sb_map sbid) args) (aInstIdToCLval aid) -- Helper routine for building constructor functions. -- Constructors are not represented as SimCCFn, because -- they have additional initializer lists and implicit -- return types. mkCtor :: Maybe String -> SimCCBlock -> CCFragment mkCtor scope sb = let prefix = maybe "" (++ "::") scope args = [ (aTypeToCType ty) (aArgIdToCLval arg_id) | (ty, arg_id, isPort) <- sb_parameters sb ] in ctor (mkVar (prefix ++ pfxMod ++ (sb_name sb))) ([ (userType "tSimStateHdl") $ (mkVar "simHdl") , ptr . constant . CCSyntax.char $ (mkVar "name") , ptr . (userType "Module") $ (mkVar "parent") ] ++ args) -- Add arguments for a constructor determined by the SimCCBlock. -- This is used for FIFOs, where we want to use the same C++ module -- with extra arguments to disambiguate FIFO1, FIFO2, SizedFIFO, etc. addSBArgs :: SBMap -> (SBId,AId,[AExpr]) -> (AId,[AExpr]) addSBArgs sb_map (sbid,aid,args) = let sb = lookupSB sb_map sbid in (aid, snd (sb_naming_fn sb args)) -- Create an initlist for use with `withInits` mkStateInitList :: [(AId,[AExpr])] -> ExprsConv mkStateInitList state_defs = -- we replace any references to ports or parameters with the argument, -- since the memory location for ports may not be initialized yet let replaceInputs (ASPort t i) = ASPort t i replaceInputs (ASParam t i) = ASPort t i replaceInputs x = x mkOne (aid,args) = do let args' = mapAExprs replaceInputs args arg_list <- mapM (aExprToCExpr noRet) args' let name = mkStr (getIdBaseString aid) return $ cCall (aInstIdToC aid) ([var "simHdl", name, var "this"] ++ arg_list) in mapM mkOne state_defs mkWideInitList :: [(AId,[AExpr])] -> ExprsConv mkWideInitList wide_defs = let mkOne (aid,args) = do arg_list <- mapM (aExprToCExpr noRet) args return $ cCall (aDefIdToC aid) arg_list in mapM mkOne wide_defs -- For ports, we initialize one-bit ports to False, so that -- all enables and readys are covered. For wide ports, we set the size -- and clear the data. mkPortInit :: (AType,AId,VName) -> [CCFragment] mkPortInit ((ATBit 1),_,vn) = [ assign (aPortIdToCLval (vName_to_id vn)) (mkBool False) ] mkPortInit ((ATBit n),_,vn) | n > 64 = let p = aPortIdToC (vName_to_id vn) in [ stmt $ p `cDot` "setSize" `cCall` [ mkUInt32 n ] , stmt $ p `cDot` "clear" `cCall` [] ] mkPortInit ((ATBit n),_,vn) | n > 32 = [ assign (aPortIdToCLval (vName_to_id vn)) (mkUInt64 0) ] mkPortInit ((ATBit n),_,vn) = [ assign (aPortIdToCLval (vName_to_id vn)) (mkUInt32 0) ] mkPortInit p = internalError ("SimCCBlock.mkPortInit: " ++ ppReadable p) -- Create a call to the "set_reset_fn" for submodules with output resets mkResetInit :: (AId,(AId,AId)) -> CCFragment mkResetInit (wire, (submod, reset)) = let rst_fn_name = mkStaticName $ mkResetFnName wire rst_fn_ref = cAddr (var rst_fn_name) set_fn_name = mkSetResetFnName reset set_fn = (aInstIdToC submod) `cDot` set_fn_name in stmt $ cCall set_fn [rst_fn_ref] -- Set the reset fns for this module to NULL mkOutputResetInit :: AId -> CCFragment mkOutputResetInit rstId = let def_name = mkResetFnDefName rstId in (mkVar def_name) `assign` mkNULL -- These should match the tSymTag definitions in src/sim/bluesim_types.h data Symbol = SymModule AId | SymDef AId Integer | SymParam AId Integer | SymPort AId Integer | SymRule | SymUnknown deriving (Eq,Ord,Show) instance PPrint Symbol where pPrint d _ (SymModule i) = (text "Module") <+> (pPrint d 0 i) pPrint d _ (SymDef i _) = (text "Def") <+> (pPrint d 0 i) pPrint d _ (SymParam i _) = (text "Param") <+> (pPrint d 0 i) pPrint d _ (SymPort i _) = (text "Port") <+> (pPrint d 0 i) pPrint _ _ SymRule = (text "Rule") pPrint _ _ SymUnknown = (text "Unknown") -- Setup for symbol data mkSymbolHdr :: Int -> [CCFragment] mkSymbolHdr n = [ (mkVar "symbol_count") `assign` (mkUInt32 (toInteger n)) ] ++ if (n > 0) then [ (mkVar "symbols") `assign` (newArray (classType "tSym") (var "symbol_count")) ] else [] -- Call symbol init method mkSymbolCall :: Int -> CCFragment mkSymbolCall n = stmt $ var ("init_symbols_" ++ (show n)) `cCall` [] -- Initialize entry for one symbol mkSymbolInit :: (Int,(String, Symbol)) -> [CCFragment] mkSymbolInit (num, (name, sym)) = let sym_ptr = cAddr ((var "symbols") `cIndex` (mkUInt32 (toInteger num))) args = [ sym_ptr, mkStr name ] ++ (getSymArgs sym) in [ stmt $ (var "init_symbol") `cCall` args ] where getSymArgs (SymModule i) = [ var "SYM_MODULE", cAddr (aInstIdToC i) ] getSymArgs (SymDef i sz) = [ var "SYM_DEF", cAddr (aDefIdToC i), mkUInt32 sz ] getSymArgs (SymParam i sz) = [ var "SYM_PARAM", cCast (ptrType voidType) $ cAddr (aParamIdToC i), mkUInt32 sz ] getSymArgs (SymPort i sz) = [ var "SYM_PORT", cAddr (aPortIdToC i), mkUInt32 sz ] getSymArgs SymRule = [ var "SYM_RULE" ] getSymArgs s = internalError $ "mkSymbolInit: unknown symbol type '" ++ (ppReadable s) ++ "'" -- Identify the reset infos which are outputs of submodules filterOutputResets :: [(AId,(AId,AId))] -> [SimCCFn] -> [SimCCFn] filterOutputResets srcs fns = let src_fn_names = map (mkResetFnName . fst) srcs in filter (\fn -> sf_name fn `elem` src_fn_names) fns -- void set_reset_fn_gen_rst(tResetFn fn) { reset_fn = fn; } setResetFnProto :: Maybe String -> AId -> CCFragment setResetFnProto scope rstId = let prefix = maybe "" (++ "::") scope fn_name = mkSetResetFnName rstId in function void (mkVar (prefix ++ fn_name)) [resetFnDefType (mkVar "fn")] setResetFnDef :: Maybe String -> AId -> CCFragment setResetFnDef scope rstId = let def_name = mkResetFnDefName rstId def_assign = (mkVar def_name) `assign` (var "fn") in define (setResetFnProto scope rstId) (block [def_assign]) -- void set_clk_n(const char* s) { __clk_handle_n = bk_get_or_define_clock(s); } setClkFnProto :: Maybe String -> ClockDomain -> CCFragment setClkFnProto scope dom = let prefix = maybe "" (++ "::") scope fn_name = mkSetClkFnName dom in function void (mkVar (prefix ++ fn_name)) [ptr . constant . CCSyntax.char $ (mkVar "s")] setClkFnDef :: Maybe String -> ClockDomain -> CCFragment setClkFnDef scope dom = let def_name = mkClkDefName dom handle = (var "bk_get_or_define_clock") `cCall` [var "sim_hdl", var "s"] def_assign = (mkVar def_name) `assign` handle in define (setClkFnProto scope dom) (block [def_assign]) -- Functions used for generating the dump() methods for a SimCCBlock dumpFnProto :: Maybe String -> Bool -> String -> CCFragment dumpFnProto scope with_handle fn_name = let prefix = maybe "" (++ "::") scope harg = if with_handle then [clockType (mkVar "handle")] else [] iarg = [unsigned . int $ (mkVar "indent")] in function void (mkVar (prefix ++ fn_name)) (harg ++ iarg) vcdHdrFnProto :: Maybe String -> CCFragment vcdHdrFnProto scope = let prefix = maybe "" (++ "::") scope in function (unsigned . int) (mkVar (prefix ++ "dump_VCD_defs")) [ unsigned . int $ (mkVar "levels") ] vcdDumpFnProto :: SimCCBlock -> Maybe String -> String -> Bool -> CCFragment vcdDumpFnProto sb scope name with_levels = let prefix = maybe "" (++ "::") scope args = [ (userType "tVCDDumpType") $ (mkVar "dt") ] ++ (if (with_levels) then [ unsigned . int $ (mkVar "levels") ] else []) ++ [ reference . (moduleType sb []) $ (mkVar "backing") ] in function void (mkVar (prefix ++ name)) args vcdFnProto :: SimCCBlock -> Maybe String -> CCFragment vcdFnProto sb scope = vcdDumpFnProto sb scope "dump_VCD" True mkSubCall :: AId -> String -> [CCExpr] -> Maybe CCFragment -> CCFragment mkSubCall inst fn args lval = let rhs = ((aInstIdToC inst) `cDot` fn) `cCall` args in case lval of (Just lhs) -> lhs `assign` rhs Nothing -> stmt $ rhs mkVCDDef :: Map.Map (Bool, AId) ClockDomain -> (AType, AId, Bool) -> [CCFragment] mkVCDDef clk_map (ty,aid,isPort) = let name = getIdBaseString aid def = if isPort then (aPortIdToC aid) else (aDefIdToC aid) -- we lookup based on the AId in a map made by calling "defs_written" -- this requires that the Ids be paired with whether it is a port -- (since ports and defs are in separate namespaces) aid' = (isPort, aid) dom = M.lookup aid' clk_map set_lag = case dom of (Just d) -> [ stmt $ (var "vcd_set_clock") `cCall` [ var "sim_hdl", var "num", var (mkClkDefName d) ] ] Nothing -> [] args = [var "sim_hdl"] ++ (mkVCDCallArgs VCDDef ty name def) write_def = [ stmt $ (var "vcd_write_def") `cCall` args ] in set_lag ++ write_def -- Symbol initialization function prototype symInitFnProto :: (Maybe String) -> Int -> CCFragment symInitFnProto scope n = let prefix = maybe "" (++ "::") scope in function void (mkVar (prefix ++ "init_symbols_" ++ (show n))) [] isOkId :: Id -> Bool isOkId i = not ((isInternal i) || (isBadId i) || (isFromRHSId i)) -- Generate a class declaration for the SimCCBlock. -- The declaration will include all of the state elements and local -- defs, along with rule and method declarations. simCCBlockToClassDeclaration :: SBMap -> SimCCBlock -> CCFragment simCCBlockToClassDeclaration sb_map sb = let clks = [ decl $ clockType (mkVar (mkClkDefName dom)) | dom <- sb_domains sb] clk_defs = [comment "Clock handles" (private clks)] gates = mkGateDecls (toInteger (length (sb_gateMap sb))) gate_defs = [comment "Clock gate handles" (public gates)] st = [ memberDecl sb_map sbid aid args | (sbid,aid,args) <- sb_state sb] state = [comment "Module state" (public st)] ctr = decl $ mkCtor Nothing sb constructor = [comment "Constructor" (public [ctr])] num_symbols = sum [ length (sb_parameters sb) , length (sb_methodPorts sb) , length [ () | (_,i) <- sb_publicDefs sb, isOkId i] , length (sb_state sb) , length (concatMap snd (sb_rules sb)) ] num_symbol_groups = max 1 ((num_symbols + 200) `div` 500) sym_init_protos = map (decl . (symInitFnProto Nothing)) [0..(num_symbol_groups-1)] symbol_init_fns = [comment "Symbol init methods" (private sym_init_protos)] adefs = [ decl $ constant $ (aTypeToCType ty) (aParamIdToCLval arg_id) | (ty, arg_id, False) <- sb_parameters sb ] -- XXX params only need to be public if they are used in rule -- XXX predicates param_defs = [comment "Instantiation parameters" (public adefs)] rdefs = [ decl $ (aTypeToCType ty) (aPortIdToCLval id) | (ty,id) <- sb_resetDefs sb ] reset_defs = [comment "Reset signal definitions" (private rdefs)] mpdefs = [ decl $ (aTypeToCType ty) (aPortIdToCLval arg_id) | (ty, arg_id, True) <- sb_parameters sb ] ++ [ decl $ (aTypeToCType ty) (aPortIdToCLval (vName_to_id vn)) | (ty,_,vn) <- sb_methodPorts sb ] port_defs = [ comment "Port definitions" (public mpdefs)] pdefs = [ decl $ (aTypeToCType ty) (aDefIdToCLval id) | (ty,id) <- sb_publicDefs sb ] public_defs = [comment "Publicly accessible definitions" (public pdefs)] ldefs = [ decl $ (aTypeToCType ty) (aDefIdToCLval id) | (ty,id) <- sb_privateDefs sb ] local_defs = [comment "Local definitions" (private ldefs)] rls = map simFnToCDeclaration (get_rule_fns sb) rules = [comment "Rules" (public rls)] mths = map (simFnToCDeclaration . prefixSimFnName pfxMeth) (get_method_fns sb) methods = [comment "Methods" (public mths)] rsts = map simFnToCDeclaration (sb_resets sb) resets = [comment "Reset routines" (public rsts)] static_rsts = map simFnToStaticCDeclaration (filterOutputResets (sb_resetSources sb) (sb_resets sb)) static_resets = [comment "Static handles to reset routines" (public static_rsts)] rst_fn_fs = [ decl $ resetFnDefType (mkVar (mkResetFnDefName rstId)) | rstId <- sb_outputResets sb ] rst_fn_fields = [comment ("Pointers to reset fns in parent module " ++ "for asserting output resets") (private rst_fn_fs)] set_rst_fns = [comment ("Functions for the parent module " ++ "to register its reset fns") (public (map (decl . (setResetFnProto Nothing)) (sb_outputResets sb)))] set_clk_fns = [comment ("Functions to set the elaborated clock id") (public (map (decl . (setClkFnProto Nothing)) (sb_domains sb)))] state_dump = [comment "State dumping routine" (public [decl $ dumpFnProto Nothing False "dump_state"])] vcd_hdr = decl $ vcdHdrFnProto Nothing is_string_type (ATString _) = True is_string_type _ = False has_members = any (not . null) [ sb_resetDefs sb , [ (t,i) | (t,i) <- ((sb_privateDefs sb) ++ (sb_publicDefs sb)) , not (is_string_type t) ] ] has_prims = or [ isPrimBlock sub | (sub,_,_) <- sb_state sb ] has_submodules = or [ not (isPrimBlock sub) | (sub,_,_) <- sb_state sb ] vcd_changes = [ decl $ vcdFnProto sb Nothing ] ++ (if has_members then [decl $ vcdDumpFnProto sb Nothing "vcd_defs" False] else []) ++ (if has_prims then [decl $ vcdDumpFnProto sb Nothing "vcd_prims" False] else []) ++ (if has_submodules then [decl $ vcdDumpFnProto sb Nothing "vcd_submodules" True] else []) vcd = [comment "VCD dumping routines" (public (vcd_hdr:vcd_changes))] class_decl = c_class (pfxMod ++ (sb_name sb)) (Just "Module") $ concat [ clk_defs , gate_defs , param_defs , state , constructor , symbol_init_fns , reset_defs , port_defs , public_defs , local_defs , rules , methods , resets , static_resets , rst_fn_fields , set_rst_fns , set_clk_fns , state_dump , vcd ] comment_str = "Class declaration for the " ++ (sb_name sb) ++ " module" in comment comment_str (decl class_decl) -- Generate the initializations for defs, to be called from the ctor. -- For wide data, we call a constructor with the size. -- For defs which will hold system tasks, we initialize the value to "aaaa" -- (unless it is wide, in which case the constructor for wide data already -- does that). mkCtorInit :: S.Set AId -> (AType,AId) -> Maybe (AId,[AExpr]) mkCtorInit task_id_set (aty@(ATBit sz),aid) | sz > 64 = Just (aid,[aNat sz]) | (S.member aid task_id_set) = let val = ASInt defaultAId aty (ilHex (aaaa sz)) in Just (aid,[val]) | otherwise = Nothing -- system tasks shouldn't be returning other types (like String), -- so no need to consult the task_id_set mkCtorInit _ _ = Nothing data VCDCallType = VCDDef | VCDX | VCDVal | VCDChange mkVCDCallArgs :: VCDCallType -> AType -> String -> CCExpr -> [CCExpr] mkVCDCallArgs ct ty name def = let size_arg = case ty of (ATString Nothing) -> [ mkUInt32 0 ] otherwise -> [ mkUInt32 (aSize ty) ] in case ct of VCDDef -> [ cPostInc (var "num"), mkStr name ] ++ size_arg VCDX -> [ cPostInc (var "num") ] ++ size_arg VCDVal -> [ cPostInc (var "num"), def ] ++ size_arg VCDChange -> [ var "num", def ] ++ size_arg -- Defines the ordering we want for symbol names. -- This needs to match the ordering used in the match_key function -- in src/sim/module.cxx. symOrd :: (String,Symbol) -> (String,Symbol) -> Ordering symOrd (str1,sym1) (str2,sym2) = case (strCmp str1 str2) of LT -> LT EQ -> compare sym1 sym2 GT -> GT where strCmp [] [] = EQ strCmp [] _ = LT strCmp _ [] = GT strCmp (c1:cs1) (c2:cs2) = case (compare (toLower c1) (toLower c2)) of LT -> LT EQ -> case (compare c1 c2) of LT -> LT EQ -> strCmp cs1 cs2 GT -> GT GT -> GT simCCBlockToClassDefinition :: SBMap -> M.Map (Bool,AId) ClockDomain -> SimCCBlock -> StmtsConv simCCBlockToClassDefinition sb_map sch_map sb = do let scope = Just (pfxMod ++ (sb_name sb)) state_defs = map (addSBArgs sb_map) (sb_state sb) task_id_set = S.fromList (sb_taskDefs sb) pub_def_inits = mapMaybe (mkCtorInit task_id_set) (sb_publicDefs sb) pri_def_inits = mapMaybe (mkCtorInit task_id_set) (sb_privateDefs sb) symbols = sortBy symOrd $ [ (getIdString i, SymParam i sz) -- deliberately drop non-bit parameters -- i.e. real & string | (ATBit sz, i, False) <- sb_parameters sb ] ++ [ (getIdString i, SymPort i (aSize t)) | (t, i, True) <- sb_parameters sb ] ++ [ (getIdString i, SymPort i (aSize t)) | (t, _, vn) <- sb_methodPorts sb , let i = vName_to_id vn ] ++ [ (getIdString i, SymDef i (aSize t)) | (t, i) <- sb_publicDefs sb , isOkId i ] ++ [ (getIdString i, SymModule i) | (_, i, _) <- sb_state sb ] ++ [ (getIdString i, SymRule) | (i,_) <- concatMap snd (sb_rules sb) ] num_symbols = length symbols -- we split up symbol initialization to avoid triggering -- gcc optimizer performance problems num_symbol_groups = max 1 ((num_symbols + 200) `div` 500) symbol_group_size = num_symbols `div` num_symbol_groups splitUp 1 sz xs = [xs] splitUp n sz xs = let (group,rest) = splitAt sz xs in group:(splitUp (n-1) sz rest) symbol_groups = splitUp num_symbol_groups symbol_group_size (zip [0..] symbols) -- put the gate map into the state setGateMap (sb_gateMap sb) -- since state inits can refer to ctor arguments, declare them setFuncArgs (map snd3 (sb_parameters sb)) stateinitlist <- mkStateInitList state_defs setFuncArgs [] wideinitlist <- mkWideInitList (pub_def_inits ++ pri_def_inits) let initlist' = -- call the superclass constructor [ (var "Module") `cCall` [var "simHdl", var "name", var "parent"] ] ++ -- initialize clock handles [ (var (mkClkDefName dom)) `cCall` [var badClockHandleName] | dom <- sb_domains sb ] ++ -- set any instantiation parameters [ (aParamIdToC aid) `cCall` [aArgIdToC aid] | (_,aid,False) <- sb_parameters sb ] ++ -- instantiate submodules stateinitlist ++ -- initialize reset defs (to be off) [ (aPortIdToC aid) `cCall` [mkUInt8 1] | (_,aid) <- sb_resetDefs sb ] ++ -- initialize module argument ports [ (aPortIdToC aid) `cCall` [aArgIdToC aid] | (_,aid,True) <- sb_parameters sb ] ++ -- initialize wide defs wideinitlist port_inits = -- module argument ports were already taken care of, -- leaving just method ports to be initialized (concatMap mkPortInit (sb_methodPorts sb)) reset_inits = map mkResetInit (sb_resetSources sb) output_reset_inits = map mkOutputResetInit (sb_outputResets sb) symbol_inits = (mkSymbolHdr num_symbols) ++ (map mkSymbolCall [0..(num_symbol_groups-1)]) ctor_body = port_inits ++ reset_inits ++ output_reset_inits ++ symbol_inits constructor = define (mkCtor scope sb) (block ctor_body) `withInits` initlist' rules <- mapM (simFnToCDefinition False scope [] []) (get_rule_fns sb) methods <- mapM (simFnToCDefinition False scope [] [] . prefixSimFnName pfxMeth) (get_method_fns sb) resets <- mapM (simFnToCDefinition False scope [] []) (sb_resets sb) let static_resets = map (simFnToStaticCDefinition (pfxMod ++ (sb_name sb))) (filterOutputResets (sb_resetSources sb) (sb_resets sb)) let set_rst_fns = map (setResetFnDef scope) (sb_outputResets sb) let set_clk_fns = map (setClkFnDef scope) (sb_domains sb) -- ---------------------- -- Symbol init routines let symbol_init_fns = [ define proto (block body) | (n,syms) <- (zip [0..] symbol_groups) , let proto = symInitFnProto scope n , let body = concatMap mkSymbolInit syms ] -- ---------------------- -- State dumping routines let label = stmt $ (var "printf") `cCall` [ mkStr "%*s%s:\n" , var "indent" , mkStr "" , var "inst_name" ] let hasState sb = let (prims,subs) = partition isPrimBlock [ sbid | (sbid,_,_) <- sb_state sb ] in (not (null prims)) || (any hasState (map (lookupSB sb_map) subs)) let state_dump_body = if (not (hasState sb)) then block [] else block ([label] ++ [ mkSubCall inst "dump_state" [(var "indent") `cAdd` (mkUInt32 2)] Nothing | (_,inst,_) <- (sb_state sb) ]) let state_dump = define (dumpFnProto scope False "dump_state") state_dump_body -- -------------------- -- VCD dumping routines let ids_by_clock = [ (fromJust clk, nub rl_ids) | (clk, rls) <- sb_rules sb , isJust clk , let rules = map snd rls , let rl_ids = concatMap defs_written (concatMap sf_body rules) ] rl_map = M.fromList [ (i,d) | (d,is) <- ids_by_clock, i <- is ] mc_map = M.fromList [ (i,c) | (c, mths) <- sb_methods sb , i <- map fst mths ] -- RDY methods now get marked with the clock of the method, -- so this indirection should no longer be needed. lookupMClk i | isRdyId i = M.findWithDefault Nothing (dropReadyPrefixId i) mc_map | otherwise = M.findWithDefault Nothing i mc_map (ms1,ms2) = partition (\(c,_) -> c == (Just noClockDomain)) (sb_methods sb) ms1' = M.toList $ M.unionsWith (++) $ [ M.singleton (lookupMClk i) [(i,f)] | (i,f) <- concatMap snd ms1 ] methods' = ms1' ++ ms2 ids_by_clock' = [ (fromJust clk, nub mth_ids) | (clk, mths) <- methods' , (isJust clk) && (fromJust clk /= noClockDomain) , let ms = map snd mths , let mth_ids = concatMap defs_written (concatMap sf_body ms) ] meth_map = M.fromList [ (i,d) | (d,is) <- ids_by_clock', i <- is ] clk_map = M.unions [ rl_map, meth_map, sch_map ] prims = sortBy cmpIdByName (catMaybes [ if isPrimBlock sub then Just inst else Nothing | (sub,inst,_) <- sb_state sb ]) sub_modules = sortBy cmpIdByName (catMaybes [ if isPrimBlock sub then Nothing else Just inst | (sub,inst,_) <- sb_state sb ]) cmp_def (_,i1,_) (_,i2,_) = i1 `cmpIdByName` i2 is_string_type (ATString _) = True is_string_type _ = False members = sortBy cmp_def $ [ (t,i,True) | (t,i) <- (sb_resetDefs sb) ] ++ [ (t,i,False) | (t,i) <- ((sb_privateDefs sb) ++ (sb_publicDefs sb)) , not (is_string_type t) ] ports = sortBy cmp_def [ (t,vName_to_id vn,True) | (t,_,vn) <- sb_methodPorts sb ] num_ids = (length members) + (length ports) + (length prims) -- vcd definitions function num_init = [ (mkVar "vcd_num") `assign` ((var "vcd_reserve_ids") `cCall` [var "sim_hdl", mkUInt32 (toInteger num_ids)]) , decl $ (unsigned . int) $ (mkVar "num") `assign` (var "vcd_num") ] clk_def_loop = [ for (decl $ (unsigned . int) $ (mkVar "clk") `assign` (mkUInt32 0)) ((var "clk") `cLt` ((var "bk_num_clocks") `cCall` [var "sim_hdl"])) (stmt $ cPreInc (var "clk")) (stmt $ (var "vcd_add_clock_def") `cCall` [ var "sim_hdl" , var "this" , (var "bk_clock_name") `cCall` [var "sim_hdl", var "clk"] , (var "bk_clock_vcd_num") `cCall` [var "sim_hdl", var "clk"] ]) ] clk_aliases = [ stmt $ (var "vcd_write_def") `cCall` [var "sim_hdl",num,name,sz] | (port, dom) <- sb_inputClocks sb , let clk = var (mkClkDefName dom) , let num = (var "bk_clock_vcd_num") `cCall` [var "sim_hdl", clk] , let name = mkStr (getIdString port) , let sz = mkUInt32 1 ] prim_calls = [ mkSubCall inst "dump_VCD_defs" [var "num"] (Just (mkVar "num")) | inst <- prims ] sub_calls = [ mkSubCall inst "dump_VCD_defs" [var "l"] (Just (mkVar "num")) | inst <- sub_modules ] member_calls = concatMap (mkVCDDef clk_map) members port_calls = concatMap (mkVCDDef clk_map) ports new_l = cTernary ((var "levels") `cEq` (mkUInt32 0)) (mkUInt32 0) ((var "levels") `cSub` (mkUInt32 1)) vcd_recurse = [ decl $ (unsigned . int) $ (mkVar "l") `assign` new_l ] ++ sub_calls scope_start = [ stmt $ (var "vcd_write_scope_start") `cCall` [var "sim_hdl", var "inst_name"] ] scope_end = [ stmt $ (var "vcd_write_scope_end") `cCall` [var "sim_hdl"] ] vcd_dump_defs_body = block (scope_start ++ num_init ++ clk_def_loop ++ clk_aliases ++ member_calls ++ port_calls ++ prim_calls ++ (if (null sub_calls) then [] else [ if_cond ((var "levels") `cNe` (mkUInt32 1)) (block vcd_recurse) Nothing ]) ++ scope_end ++ [ ret (Just (var "num")) ] ) vcd_dump_defs = define (vcdHdrFnProto scope) vcd_dump_defs_body -- value dumping functions def_name Nothing i = aDefIdToC i def_name (Just x) i = x `cDot` (aUnqualDefIdToString i) port_name Nothing i = aPortIdToC i port_name (Just x) i = x `cDot` (aUnqualPortIdToString i) vcd_write ct (ty,aid,isPort) = let name = getIdBaseString aid name_fn = if isPort then port_name else def_name def = name_fn Nothing aid backing_def = name_fn (Just (var "backing")) aid in [ stmt $ (var "vcd_write_val") `cCall` ([var "sim_hdl"] ++ (mkVCDCallArgs ct ty name def)) , (stmt backing_def) `assign` def ] vcd_write_x (ty,aid,isPort) = let name_fn = if isPort then port_name else def_name def = name_fn Nothing aid in stmt $ (var "vcd_write_x") `cCall` ([var "sim_hdl"] ++ (mkVCDCallArgs VCDX ty "" def)) vcd_write_changed target@(ty,aid,isPort) = let name_fn = if isPort then port_name else def_name def = name_fn Nothing aid backing_def = name_fn (Just (var "backing")) aid in [ if_cond (backing_def `cNe` def) (block (vcd_write VCDChange target)) Nothing , stmt $ cPreInc (var "num") ] member_calls_xs = map vcd_write_x members member_calls_changed = concatMap vcd_write_changed members member_calls_all = concatMap (vcd_write VCDVal) members port_calls_xs = map vcd_write_x ports port_calls_changed = concatMap vcd_write_changed ports port_calls_all = concatMap (vcd_write VCDVal) ports vcd_defs_proto = vcdDumpFnProto sb scope "vcd_defs" False vcd_defs_body = block [ decl $ (unsigned . int) $ (mkVar "num") `assign` (var "vcd_num") , if_cond ((var "dt") `cEq` (var "VCD_DUMP_XS")) (block (member_calls_xs ++ port_calls_xs)) (Just (if_cond ((var "dt") `cEq` (var "VCD_DUMP_CHANGES")) (block (member_calls_changed ++ port_calls_changed)) (Just (block (member_calls_all ++ port_calls_all))))) ] vcd_prims_proto = vcdDumpFnProto sb scope "vcd_prims" False vcd_prims_body = block [ mkSubCall inst "dump_VCD" [ var "dt" , (var "backing") `cDot` (aUnqualInstIdToString inst) ] Nothing | inst <- prims ] vcd_submodules_proto = vcdDumpFnProto sb scope "vcd_submodules" True vcd_submodules_body = block [ mkSubCall inst "dump_VCD" [ var "dt" , var "levels" , (var "backing") `cDot` (aUnqualInstIdToString inst) ] Nothing | inst <- sub_modules ] vcd_dump_body = block ((if (null members) then [] else [ stmt $ (var "vcd_defs") `cCall` [var "dt", var "backing"] ]) ++ (if (null prims) then [] else [ stmt $ (var "vcd_prims") `cCall` [var "dt", var "backing"] ]) ++ (if (null sub_modules) then [] else [ if_cond ((var "levels") `cNe` (mkUInt32 1)) (stmt $ (var "vcd_submodules") `cCall` [ var "dt" , (var "levels") `cSub` (mkUInt32 1) , var "backing" ]) Nothing ]) ) vcd_dump = define (vcdFnProto sb scope) vcd_dump_body vcd_dump_fns = (if (null members) then [] else [ define vcd_defs_proto vcd_defs_body ]) ++ (if (null prims) then [] else [ define vcd_prims_proto vcd_prims_body ]) ++ (if (null sub_modules) then [] else [ define vcd_submodules_proto vcd_submodules_body ]) vcds = [vcd_dump_defs, vcd_dump] ++ vcd_dump_fns -- ------------------- -- Put it all together let fns = [comment "Constructor" constructor] ++ [comment "Symbol init fns" (blankLines 0)] ++ symbol_init_fns ++ [comment "Rule actions" (blankLines 0)] ++ rules ++ [comment "Methods" (blankLines 0)] ++ methods ++ [comment "Reset routines" (blankLines 0)] ++ resets ++ [comment "Static handles to reset routines" (blankLines 0)] ++ static_resets ++ [comment ("Functions for the parent module " ++ "to register its reset fns") (blankLines 0)] ++ set_rst_fns ++ [comment "Functions to set the elaborated clock id" (blankLines 0)] ++ set_clk_fns ++ [comment "State dumping routine" state_dump] ++ [comment "VCD dumping routines" (blankLines 0)] ++ vcds return $ intersperse (blankLines 1) fns -- Generate the schedule function definitions for a SimCCSched. -- We do not collect wide temporaries of top modules in schedule because -- they are used in boolean computations only which do not need optimized -- function implementation simCCScheduleToFunctionDefinition :: SimCCBlock -> SimCCSched -> StmtsConv simCCScheduleToFunctionDefinition top ssched = do let c_args = [ (userType "tSimStateHdl") (mkVar "simHdl") , (ptr . void) (mkVar "instance_ptr") ] top_decl = let ty = moduleType top [] -- XXX for cCast, we need the type, not a combinator modName = pfxMod ++ fst (sb_naming_fn top []) inst_ptr_ty = ptrType (classType modName) inst = cCast inst_ptr_ty (var "instance_ptr") in decl . reference . ty $ (mkVar "INST_top") `assign` (cDeref inst) schedFnToCDef = simFnToCDefinition True Nothing c_args [top_decl] fn1 <- schedFnToCDef (sched_fn ssched) case (sched_after_fn ssched) of (Just f) -> do fn2 <- schedFnToCDef f return [fn1,fn2] Nothing -> return [fn1] -- ======================== -- Helper routines for collecting wide data declarations wideLocalDef :: SimCCFnStmt -> [AId] wideLocalDef (SFSDef _ (ty, aid) _) = if wideDataType ty then [aid] else [] wideLocalDef _ = [] -- return True if this type is wider than 64 bits wideDataType :: AType -> Bool wideDataType (ATBit sz) | sz > 64 = True | otherwise = False wideDataType _ = False -- ======================== -- Pretty-printing routines ppSBId :: SBId -> Doc ppSBId id = text (itos id) instance PPrint SimCCBlock where pPrint d p sb = let label = (text "SimCCBlock") <+> (text (sb_name sb)) <+> (pparen True (ppSBId (sb_id sb))) <> colon state = (text "state:") <+> (pPrint d 0 (sb_state sb)) rst_defs = (text "reset defs:") <+> (pPrint d 0 (sb_resetDefs sb)) pub_defs = (text "public defs:") <+> (pPrint d 0 (sb_publicDefs sb)) pri_defs = (text "private defs:") <+> (pPrint d 0 (sb_privateDefs sb)) rules = (text "rules:") <+> (pPrint d 0 (sb_rules sb)) methods = (text "methods:") <+> (pPrint d 0 (sb_methods sb)) resets = (text "resets:") <+> (pPrint d 0 (sb_resets sb)) task_defs = (text "task defs:") <+> (pPrint d 0 (sb_taskDefs sb)) reset_srcs = (text "reset srcs:") <+> (pPrint d 0 (sb_resetSources sb)) input_resets = (text "input resets:") <+> (pPrint d 0 (sb_inputResets sb)) output_resets = (text "output resets:") <+> (pPrint d 0 (sb_outputResets sb)) body = vsep [ state , rst_defs , pub_defs , pri_defs , rules , methods , resets , task_defs , reset_srcs , input_resets , output_resets ] in label $+$ (nest 2 body) ppDecl :: (AType,AId) -> Doc ppDecl (ty,id) = (pPrint PDReadable 0 ty) <+> (pPrint PDReadable 0 id) instance PPrint SimCCFn where pPrint d p (SimCCFn name args ret body) = let ty = case ret of (Just t) -> pPrint d 0 t Nothing -> text "void" arg_list = pparen True (sepList (map ppDecl args) comma) stmts = vsep (map (pPrint d 0) body) in (ty <+> (text name) <> arg_list) $+$ (nest 2 stmts) instance PPrint SimCCFnStmt where pPrint d p (SFSDef _ decl Nothing) = (text "define") <+> (ppDecl decl) pPrint d p (SFSDef _ decl (Just expr)) = (text "define") <+> (ppDecl decl) <+> (text "=") <+> (pPrint d 0 expr) pPrint d p (SFSAssign _ aid expr) = (pPrint d 0 aid) <+> (text "=") <+> (pPrint d 0 expr) pPrint d p (SFSAction action) = pPrint d 0 action pPrint d p (SFSAssignAction _ aid action _) = (pPrint d 0 aid) <+> (text "=") <+> (pPrint d 0 action) pPrint d p (SFSRuleExec ruleId) = (pPrint d 0 ruleId) pPrint d p (SFSCond cond t f) = (text "if (") <> (pPrint d 0 cond) <> (text ")") $+$ (nest 2 (vsep (map (pPrint d 0) t))) $+$ (text "else") $+$ (nest 2 (vsep (map (pPrint d 0) f))) pPrint d p (SFSMethodCall obj meth args) = (pPrint d 0 obj) <> (text ".") <> (text (getIdBaseString meth)) <> (pparen True (commaSep (map (pPrint d 0) args))) pPrint d p (SFSFunctionCall obj func args) = (pPrint d 0 obj) <> (text ".") <> (text func) <> (pparen True (commaSep (map (pPrint d 0) args))) pPrint d p (SFSResets stmts) = (text "if (do_reset_ticks())") $+$ (nest 2 (vsep (map (pPrint d 0) stmts))) pPrint d p (SFSReturn Nothing) = (text "return") pPrint d p (SFSReturn (Just expr)) = (text "return") <+> (pPrint d 0 expr) pPrint d p (SFSOutputReset rstId val) = (text "assertOutputReset(" <> pPrint d 0 rstId <> text ", " <> pPrint d 0 val <> text ")") instance PPrint SimCCSched where pPrint d p (SimCCSched clk edge fn blocks) = let label = text "SimCCSched" clk_str = (if edge then (text "posedge") else (text "negedge")) <+> (pPrint d 0 clk) func = pPrint d 0 fn blks = (text "applies to blocks:") <+> (pPrint d 0 blocks) in label <+> clk_str <> (text ":") $+$ (nest 2 (func $+$ blks)) instance PPrint SimCCClockGroup where pPrint d p (SimCCClockGroup canonical instances) = let name = pPrint d 0 canonical inst_list = pPrint d 0 instances in name <+> (text "names") <+> inst_list instance PPrint SimCCReset where pPrint d p (SimCCReset n port fn) = let label = (text "SimCCReset ") <+> (pparen True (text (show n))) name = case port of Just (i,p) -> text (i ++ "$" ++ p) Nothing -> text "primary reset" func = pPrint d 0 fn in label <+> name <> (text ":") $+$ (nest 2 func) -- ================================================== -- Hyper instances (needed by phase dumping routines) instance Hyper SimCCBlock where hyper x y = (x==x) `seq` y instance Hyper SimCCFn where hyper x y = (x==x) `seq` y instance Hyper SimCCFnStmt where hyper x y = (x==x) `seq` y instance Hyper SimCCSched where hyper x y = (x==x) `seq` y instance Hyper SimCCClockGroup where hyper x y = (x==x) `seq` y instance Hyper SimCCReset where hyper x y = (x==x) `seq` y