{-# LANGUAGE CPP #-} module Main_showrules(main) where import Exceptions(bsCatch) import Version import FileNameUtil(hasDotSuf, hasNoSuffix, vcdSuffix) import ABinUtil(getABIHierarchy, assertNoSchedErr, InstModMap, HierMap) import Position(noPosition) import Id( Id, getIdString, getIdBaseString, getIdQualString , mkIdCanFire, mkIdWillFire, isIdCanFire, dropCanFirePrefixId , addToQual, setIdQualString, emptyId, mk_homeless_id ) import Error(internalError, EMsg, WMsg, ErrMsg(..), ErrorHandle, initErrorHandle, exitOK, exitFail, bsErrorNoExit, bsWarning, convErrorTToIO) import Util(separate) import IOUtil(getEnvDef) import TopUtils(dfltBluespecDir) import ASyntax import ASyntaxUtil import ABin(ABinModInfo(..)) import AScheduleInfo(SchedNode(..)) import SimCCBlock(SimCCBlock(..), primBlocks) import SimPrimitiveModules(isPrimitiveModule, isFIFO) import SimExpand(simExpandSched) import SimDomainInfo(DomainInfo(..)) import SimPackage(SimSchedule(..), DefMap) import Wires(writeClockDomain) import VCD import CondTree import ListUtil(dropRepeatsBy) import APrims import PPrint import Eval(Hyper(..)) import qualified DynamicMap as DM import System.Environment(getArgs) import System.Console.GetOpt import System.IO import System.IO.Unsafe(unsafePerformIO) import System.Time import Control.Monad(when, msum, foldM) import Control.Exception(bracket) import Data.List( partition, intercalate, genericLength , sort, findIndex, sortBy, groupBy ) import Data.List.Split(wordsBy) import Data.Maybe(isJust, fromJust, fromMaybe, mapMaybe, catMaybes) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.ByteString.Lazy.Char8 as C import Text.Regex -- import Debug.Trace -- Version string (matches main BSC version numbering) versionString :: String versionString = versionStr True (bluespec ++ " showrules utility") -- ------------------------------------------------------------------- -- Option processing -- Structure which holds all option settings data Options = Options { optVerbose :: Bool , optDebug :: Maybe FilePath , optShowVersion :: Bool , optShowHelp :: Bool , optShowProgress :: Bool , optInputVCD :: Maybe FilePath , optOutputVCD :: Maybe FilePath , optOutputNovas :: Maybe FilePath , optTopModule :: Maybe String , optRoot :: String , optBAPath :: [String] } deriving (Show) -- Default settings defaultOptions :: String -> Options defaultOptions bluespecdir = Options { optVerbose = False , optDebug = Nothing , optShowVersion = False , optShowHelp = False , optShowProgress = False , optInputVCD = Nothing , optOutputVCD = Nothing , optOutputNovas = Nothing , optTopModule = Nothing , optRoot = "main.top" , optBAPath = original_path bluespecdir } original_path :: String -> [String] original_path bluespecdir = [ "." , bluespecdir ++ "/Libraries" ] -- Description of command-line options options :: [OptDescr (Options -> Options)] options = [ Option ['v'] ["verbose"] (NoArg (\opts -> opts { optVerbose = True })) "write verbose status messages" , Option [] ["debug"] (OptArg (\mf opts -> opts { optDebug = Just (fromMaybe "" mf) }) "FILE") "generate very detailed debug traces" , Option ['V'] ["version"] (NoArg (\opts -> opts { optShowVersion = True })) "show version information and exit" , Option ['h','?'] ["help"] (NoArg (\opts -> opts { optShowHelp = True })) "print usage information and exit" , Option ['o'] ["output"] (ReqArg (\f opts -> opts { optOutputVCD = Just f }) "FILE") "output VCD file" , Option [] ["novas"] (ReqArg (\f opts -> opts { optOutputNovas = Just f }) "FILE") "output alias file for Novas tools" , Option [] ["progress"] (NoArg (\opts -> opts { optShowProgress = True })) "show VCD conversion progress indicators" , Option ['p'] ["path"] (ReqArg (\s opts -> let p = optBAPath opts in opts { optBAPath = (s:p) }) "PATH") ".ba file search path (% = $BLUESPECDIR and + = original path)" , Option ['r'] ["root"] (ReqArg (\s opts -> opts { optRoot = s }) "NAME") "hierarchical name of top BSV module in hierarchy" ] -- Header used in usage message usage_header :: String usage_header = "Usage: showrules [OPTIONS] " -- Parse the command line to produce the option structure, etc. parseOpts :: [String] -> String -> (Options, [String], [EMsg]) parseOpts argv bluespecdir = let (opts,args0,errs) = getOpt Permute options argv options0 = foldl (flip id) (defaultOptions bluespecdir) opts (vcds,args1) = partition (hasDotSuf vcdSuffix) args0 (mods,args2) = partition hasNoSuffix args1 emsgs0 = map toEMsg errs (options1,emsgs1) = checkVCDs vcds (options0,emsgs0) (options2,emsgs2) = checkMods mods (options1,emsgs1) emsgs3 = if (null args2) then emsgs2 else emsgs2 ++ [(noPosition, EUnrecognizedCmdLineText (unwords args2))] options3 = interpretPath options2 in (options3, [], emsgs3) where checkVCDs fs (os,es) = if (length fs /= 1) then (os,es ++ [(noPosition, EExactlyOneArgRequired "input VCD file name" fs)]) else (os { optInputVCD = Just (head fs) }, es) checkMods fs (os,es) = if (length fs /= 1) then (os,es ++ [(noPosition, EExactlyOneArgRequired "name for the top BSV module" fs)]) else (os { optTopModule = Just (head fs) }, es) -- Path options are accumulated during option processing and -- and then must be analyzed to determine the resulting path. -- The optBAPath will have one element for each --path option, -- followed for the original path elements. The elements from -- the user are split off, broken up at ':' separators and then -- interpreted in order (replacing '+' and '%') to determine -- the final path. interpretPath os = let n = length (original_path bluespecdir) n' = length (optBAPath os) (user_paths,orig_path) = splitAt (n'-n) (optBAPath os) new_path = foldr addPath orig_path user_paths in os { optBAPath = new_path } addPath s ps = let xs = wordsBy (=='.') s xs' = concatMap (\x -> if (x == "+") then ps else [x]) xs xs'' = [ concatMap (\c -> if (c == '%') then bluespecdir else [c]) x | x <- xs' ] in xs'' -- Produce a standard EMsg value from an option parser error string toEMsg :: String -> EMsg toEMsg s = fromMaybe (noPosition, EGeneric s) $ msum [f s | f <- [ bad_option , missing_arg ]] where bad_option_regex = mkRegex "unrecognized option `(.*)'" bad_option x = do [opt] <- matchRegex bad_option_regex s return (noPosition, EUnknownFlag opt) missing_arg_regex = mkRegex "option `(.*)' requires an argument .*" missing_arg x = do [opt] <- matchRegex missing_arg_regex s return (noPosition, EOneArgFlag opt) -- Validate command-line and process help requests checkCmdLine :: ErrorHandle -> Options -> [String] -> [EMsg] -> IO () checkCmdLine errh opts args errs = do when (optShowVersion opts) $ do hPutStrLn stdout versionString hPutStrLn stdout copyright when (optShowHelp opts) $ hPutStrLn stdout (usageInfo usage_header options) when ((optShowVersion opts) || (optShowHelp opts)) $ exitOK errh when (not (null errs)) $ do bsErrorNoExit errh errs hPutStrLn stderr (usageInfo usage_header options) exitFail errh -- ------------------------------------------------------------------- -- Main program routine type RuleMap = M.Map String Integer type InvRuleMap = M.Map Integer String type SignalMap = M.Map String (Code,Integer) type InvSignalMap = M.Map Code String type ClockMap = M.Map Int ([String],[SchedNode]) type CodeSet = S.Set Code type CodeMap = M.Map Code Signal type ValueMap = DM.Map Integer Code (VCDValue,ChangeReason) type ClockEdgeMap = M.Map Code Integer type RuleConds = ([(String,AExpr)],Integer) type ActionMap = M.Map Int (M.Map (String,AMethodId) [RuleConds]) type Realignment = [(Code,[RuleConds])] type ModDefMap = M.Map String DefMap data ChangeReason = Stable | Changed | InTask String deriving (Eq,Ord,Show) data Signal = ClockSignal { clk_domain :: Int , clk_name :: String , fired_code :: Code , blocked_code :: Code , virtual_width :: Integer , fire_signals :: [(Code,Code,Integer)] , realignment :: Realignment , rw_realignment :: Realignment } | CFSignal | WFSignal deriving (Eq,Show) -- The conversion is a lazy left-fold over a list of VCD commands, which -- tracks the state of the fold using the ConvState structure. data ConvState = ConvState { be_verbose :: Bool , debug_to :: Maybe Handle , root :: String , root_find :: Maybe [String] , time_factor :: Integer , current_time :: Integer , scope :: [String] , rule_map :: RuleMap , inv_rule_map :: InvRuleMap , signal_map :: SignalMap , inv_signal_map :: InvSignalMap , clock_map :: ClockMap , code_map :: CodeMap , clk_edge_map :: ClockEdgeMap , value_map :: ValueMap , inst_map :: InstModMap , action_map :: ActionMap , edges :: [(Code,Signal)] , modified_set :: CodeSet , mod_def_map :: ModDefMap , prev_time :: Double , prev_bytes :: Integer , curr_bytes :: Integer , total_bytes :: Integer , progress_at :: Maybe Integer } -- Type used to return errors, messages, etc. from conversion process data Status = Err EMsg | Warn WMsg | Info String deriving (Show) main :: IO () main = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering hSetEncoding stdout latin1 hSetEncoding stderr latin1 argv <- getArgs -- catch errors, print them nicely, and exit bsCatch (hmain argv) hmain :: [String] -> IO () hmain argv = do errh <- initErrorHandle bluespecdir <- getEnvDef "BLUESPECDIR" dfltBluespecDir -- parse command line arguments let (opts, args, emsgs) = parseOpts argv bluespecdir -- handle errors and/or request for help and version info checkCmdLine errh opts args emsgs -- read in .ba file data let top_mod = fromJust (optTopModule opts) verbose = optVerbose opts ba_path = optBAPath opts let prim_names = map sb_name primBlocks when (verbose) $ putStrLn "Reading design data from .ba files..." (_, hier_map, inst_map, _, _, _, abemis_by_name) <- convErrorTToIO errh $ getABIHierarchy errh verbose ba_path Nothing prim_names top_mod [] abmis_by_name <- convErrorTToIO errh $ assertNoSchedErr abemis_by_name -- analyze design in preparation for VCD interpretation when (verbose) $ putStrLn "Analyzing design structure..." initState <- mkMorphState opts inst_map hier_map abmis_by_name top_mod -- write out debug info collected so far dbg (debug_to initState) ((unlines [ "---- PARSING COMMAND LINE ----" , "ARGS: " ++ (show argv) , "BLUESPECDIR: " ++ (show bluespecdir) ]) ++ (show opts) ++ "\n" ++ "-------\n") dbg (debug_to initState) ("---- BA FILE DATA ----\n" ++ "INSTANCE MAP:\n" ++ (unlines [ inst ++ " -> " ++ mod | (inst,mod) <- M.toList inst_map ]) ++ "ABMI MAP:\n" ++ (concat [ "ABMI FOR MODULE: " ++ mod ++ "\n" ++ (ppReadable abmi) | (mod,abmi) <- abmis_by_name ]) ++ "-------\n") dbg (debug_to initState) ("---- RULE MAP ----\n" ++ (unlines [ name ++ " -> " ++ (show rnum) | (name,rnum) <- M.toList (rule_map initState) ]) ++ "-------\n") dbg (debug_to initState) ("---- CLOCK MAP ----\n" ++ (unlines [ "Domain " ++ (show dom) ++ " " ++ (show clks) ++ "\n" ++ (unlines (map (\s -> " " ++ (show s)) sched)) | (dom,(clks,sched)) <- M.toList (clock_map initState) ]) ++ "-------\n") -- process the input VCD file and write the output VCD file let vcd_in = fromJust (optInputVCD opts) vcd_out = fromMaybe "showrules.vcd" (optOutputVCD opts) when (verbose) $ putStrLn "Analyzing VCD hierarchy..." end_state <- bracket (openFile vcd_in ReadMode) (\hIn -> do { hClose hIn; return Nothing }) (\hIn -> do st <- setupProgress (optShowProgress opts) hIn initState bracket (openFile vcd_out WriteMode) (\hOut -> do { hClose hOut; return Nothing }) (\hOut -> processVCD errh hIn hOut st)) -- generate the novas command file if requested when ((isJust (optOutputNovas opts)) && (isJust end_state)) $ do let cmd_file = fromJust (optOutputNovas opts) when (verbose) $ putStrLn "Writing Novas command file..." bracket (openFile cmd_file WriteMode) hClose $ \hOut -> do hPutStr hOut (formatNovas (fromJust end_state)) hFlush hOut -- done: exit normally when (verbose) $ putStrLn "VCD conversion is complete." case (maybe Nothing debug_to end_state) of Nothing -> return () (Just hdl) -> when (hdl /= stdout) $ hClose hdl -- XXX we may still reach this point if there were errors -- XXX because we use "bsErrorNoExit" exitOK errh -- File operations and VCD conversion. Performs IO and returns -- Just the final conversion state. This should be bracketed with -- exception handlers that close the handles and return Nothing. processVCD :: ErrorHandle -> Handle -> Handle -> ConvState -> IO (Maybe ConvState) processVCD errh hIn hOut initState = do cs <- C.hGetContents hIn writeVCD hOut [Version versionString] let cmds = parseVCDSize cs finalState <- foldM (morphVCD errh hOut) initState cmds endOfVCD errh hOut finalState hFlush hOut return (Just finalState) writeVCD :: Handle -> VCD -> IO () writeVCD hOut vcd = hPutStr hOut (formatVCD vcd) -- ------------------------------------------------------------------- -- VCD conversion details -- Create initial VCD conversion state -- -- This requires analyzing some aspects of the design, particularly -- the rules and the clocks. We build a number of maps used to direct -- the conversion process. mkMorphState :: Options -> InstModMap -> HierMap -> [(String, (ABinModInfo, String))] -> String -> IO ConvState mkMorphState opts instmap hiermap abmis_by_name top_mod = do let abmimap = M.fromList [ (mod,abmi) | (mod, (abmi,_)) <- abmis_by_name ] -- determine debug logging target dbg_target <- case (optDebug opts) of Nothing -> return Nothing (Just "") -> return (Just stdout) (Just f) -> do hdl <- openFile f WriteMode return (Just hdl) -- generate a unique numeric Id for each rule let user_modules = [ (inst,abmi) | (inst,mod) <- M.toList instmap , not (isPrimitiveModule mod) , let (Just abmi) = M.lookup mod abmimap ] all_rules = [ (inst,rule) | (inst,abmi) <- user_modules , rule <- apkg_rules (abmi_apkg abmi) ] rulemap = M.fromList [ (joinName inst (aRuleName rule), n) | ((inst,rule),n) <- zip all_rules [0..] ] invrulemap = M.fromList [ (n, joinName inst (aRuleName rule)) | ((inst,rule),n) <- zip all_rules [0..] ] rule_count = fromIntegral (M.size rulemap) when (optVerbose opts) $ putStrLn $ "found " ++ (show rule_count) ++ " rules in the design" -- identify the clock signals and clock domains simscheds <- simExpandSched abmis_by_name hiermap instmap top_mod let clkmap = M.fromList [ (num, (clks, order)) | sched <- simscheds , let dim = ss_domain_info_map sched , let num = writeClockDomain . snd $ head (M.keys dim) , let clks = mapMaybe (getClkName (optRoot opts)) (di_clocks $ head (M.elems dim)) , let order = ss_sched_order sched ] when (optVerbose opts) $ putStrLn $ "found " ++ (show (M.size clkmap)) ++ " clock domains in the design" -- determine the expected scope for the root let root_scope = reverse (wordsBy (=='.') (optRoot opts)) -- build the data-structures for determining which rule -- has updated each value let methmap = M.fromList [ ((inst,name),rules) | (inst,abmi) <- user_modules , aif <- apkg_interface (abmi_apkg abmi) , let name = aIfaceName aif , let rules = aIfaceRules aif , not (null rules) ] let getRuleActs i r = If (i,(arule_pred r)) (getActs i (arule_actions r)) getActs i [] = [] getActs i ((ACall o m args):acts) = let (cond:_) = args sub_inst = joinName i o m' = setIdQualString m "" sub_acts = case (M.lookup (sub_inst,m') methmap) of (Just rs) -> map (getRuleActs sub_inst) rs Nothing -> [Leaf (sub_inst,m)] in if (null sub_acts) then getActs i acts else (If (i,cond) sub_acts):(getActs i acts) getActs i (_:acts) = getActs i acts dom_map = M.fromList [ (rule,dom) | (dom,(_,sns)) <- M.toList clkmap , rule <- [ rid | (Exec rid) <- sns ] ] expr_to_bool e | isTrue e = Just True | isFalse e = Just False | otherwise = Nothing err n = internalError $ "Unknown rule '" ++ n ++ "'" write_conds = [ (dom, M.singleton meth [(conds,rnum)]) | (inst,rule) <- all_rules , let name = aRuleName rule , let hname = joinName inst name , let qname = addToQual inst name , let rnum = M.findWithDefault (err hname) hname rulemap , let dom = M.findWithDefault (-1) qname dom_map , let cts = simplify (expr_to_bool . snd) (getRuleActs inst rule) , let actions = map cf_to_wf cts , (conds,meth) <- concatMap enumerate actions ] actionmap = M.fromListWith (M.unionWith (++)) write_conds -- construct a map from defs to exprs mkDefMap abmi = M.fromList $ map (\d -> (adef_objid d,d)) (apkg_local_defs (abmi_apkg abmi)) moddefmap = M.map mkDefMap abmimap -- construct and return the initial conversion state return $ hyper (rulemap, invrulemap, clkmap, instmap, actionmap, moddefmap) ConvState { be_verbose = optVerbose opts , debug_to = dbg_target , root = optRoot opts , root_find = Just root_scope , time_factor = ilog1000 rule_count , current_time = 0 , scope = [] , rule_map = rulemap , inv_rule_map = invrulemap , signal_map = M.empty , inv_signal_map = M.empty , clock_map = clkmap , code_map = M.empty , clk_edge_map = M.empty , value_map = DM.empty , inst_map = instmap , action_map = actionmap , edges = [] , modified_set = S.empty , mod_def_map = moddefmap -- these get initialized in setupProgress , prev_time = 0 , prev_bytes = 0 , curr_bytes = 0 , total_bytes = 0 , progress_at = Nothing } setupProgress :: Bool -> Handle -> ConvState -> IO ConvState setupProgress False hIn st = return st setupProgress True hIn st = do -- record the start time (TOD s ps) <- getClockTime let now = (fromInteger s) + (fromInteger ps / (10.0^(12 :: Int))) -- record the total input file size file_sz <- hFileSize hIn -- return the updated state return $ st { prev_time = now , total_bytes = file_sz , progress_at = Just (file_sz `div` 100) } -- One step of lazy VCD conversion -- -- This function gets called on each VCD command in the input VCD stream. -- It handles processing of the definition header as well as the value -- changes. When processing commands in the header it builds a symbol -- table and correlates data from the .ba files with the symbols in the -- VCD file. Once an EndDefs command is encountered, we know that all of -- the design data is known, so more processing is done to build efficient -- structures for handling the value changes to come. morphVCD :: ErrorHandle -> Handle -> ConvState -> (VCDCmd,Integer) -> IO ConvState morphVCD errh hOut st (cmd,bytes) = do st' <- doProgress st bytes morphVCD' errh hOut st' cmd -- These are all VCD commands in the header -- expand timescale to accommodate microticks morphVCD' :: ErrorHandle -> Handle -> ConvState -> VCDCmd -> IO ConvState morphVCD' errh hOut st (Timescale n u) = do let u' = u + (time_factor st) writeVCD hOut [Timescale n u'] return st -- convert original version string to a comment morphVCD' errh hOut st (Version s) = do let s' = unlines ["Original VCD version:",s] writeVCD hOut [Comment s'] return st -- add scope level for following Vars morphVCD' errh hOut st cmd@(Scope _ s) = do let scope' = s:(scope st) root_find' = case (root_find st) of (Just rs) -> if (scope' == rs) then Nothing else (Just rs) Nothing -> Nothing st' = st { scope = scope', root_find = root_find' } writeVCD hOut [cmd] return st' -- record mapping of qualified name to VCD code and width morphVCD' errh hOut st cmd@(Var _ w c s) = do let s' = strip_width_brackets s name = intercalate "." (reverse (s':(scope st))) smap = M.insert name (c,w) (signal_map st) st' = st { signal_map = smap } writeVCD hOut [cmd] return st' -- pop off one scope level morphVCD' errh hOut st UpScope = do let scope' = tail (scope st) st' = st { scope = scope' } writeVCD hOut [UpScope] return st' -- end of definitions, prepare for value changes morphVCD' errh hOut st EndDefs = do let -- do sanity checks now that we know all signals, hierarchy, etc. checks = [found_root_scope] results = concat [ f st | f <- checks ] -- determine the largest signal code in use smap = signal_map st max_code = if (M.null smap) then 0 else maximum (map fst (M.elems smap)) -- locate clock signals for each domain cmap = clock_map st (clks_not_found,clks_found) = separate (map (find_clk smap) (M.toList cmap)) -- locate signals to associate with each clock edge -- and conditions used to realign state transitions (clock_info,ci_status) = mkClockInfo clks_found max_code st clock_code_map = M.fromList clock_info -- create virtual signals for each domain vsigs = concat [ [ (fired,(fc,w)), (blocked,(bc,w)) ] | (_,ClockSignal _ s fc bc w _ _ _) <- clock_info , let fired = "FIRED_RULE_" ++ s , let blocked = "BLOCKED_RULE_" ++ s ] virtual_vars = [ Var Wire width code name | (name,(code,width)) <- vsigs ] -- record all virtual firing codes as modified vcode_set = S.fromList [ code | (_,(code,_)) <- vsigs ] modified' = (modified_set st) `S.union` vcode_set -- create an inverted signal map for use in error messages invsigmap = M.fromList [ (c,n) | (n,(c,_)) <- M.toList smap ] -- inform user about any cross-rule CF/WF aliases fire_codes = concat [ [(cfc,S.singleton rn),(wfc,S.singleton rn)] | (_, cs@(ClockSignal {})) <- clock_info , (cfc,wfc,rn) <- fire_signals cs ] fire_code_map = M.fromListWith (S.union) fire_codes cross_rule_aliases = [ Info $ unlines $ ["The input VCD aliases CAN_FIRE/WILL_FIRE signals for these rules:"] ++ (map (" " ++) rule_names) | (_,rs) <- M.toList fire_code_map , (S.size rs) > 1 , let rule_names = map (\rn -> M.findWithDefault "?" rn invrulemap) (S.toList rs) ] -- compose debugging information related to the VCD header invrulemap = inv_rule_map st debug_msg = "---- SIGNAL MAP ----\n" ++ (unlines [ name ++ " -> " ++ (vcd_code_to_string code) ++ " (" ++ (show width) ++ " bits)" | (name,(code,width)) <- M.toList smap ]) ++ "-------\n" ++ "---- VIRTUAL SIGNALS ----\n" ++ (unlines [ name ++ " -> " ++ (vcd_code_to_string code) ++ " (" ++ (show width) ++ " bits)" | (name,(code,width)) <- vsigs ]) ++ "-------\n" ++ "---- CLOCK ACTION INFO ----\n" ++ (unlines (concat [ [ (clk_name cs) ++ " (Domain " ++ (show dom) ++ ")" , " fired code = " ++ (vcd_code_to_string (fired_code cs)) , " blocked code = " ++ (vcd_code_to_string (blocked_code cs)) , " CAN_FIRE and WILL_FIRE adjustments:" ] ++ cf_wf_lines ++ [ " signal realignments:" ] ++ realignment_lines | (dom, cs@(ClockSignal {})) <- clock_info , let cf_wf_lines = [ " Rule " ++ rule_name ++ " CF: " ++ cf ++ " WF: " ++ wf | (cfc,wfc,rn) <- fire_signals cs , let cf = vcd_code_to_string cfc , let wf = vcd_code_to_string wfc , let rule_name = M.findWithDefault "?" rn invrulemap ] , let realignment_lines = concat [ [ " Signal: " ++ (vcd_code_to_string code) ++ " " ++ sig_name] ++ cond_lines | (code,conds) <- (realignment cs) ++ (rw_realignment cs) , let sig_name = M.findWithDefault "?" code invsigmap , let cond_lines = [ " [" ++ (intercalate ", " exprs) ++ "] => " ++ rule_name | (es,rn) <- conds , let exprs = [ inst ++ " " ++ (init (ppReadable e)) | (inst,e) <- es ] , let rule_name = M.findWithDefault "?" rn invrulemap ] ] ])) ++ "-------\n" -- compose info messages info = if (be_verbose st) then map Info [ "found " ++ (show (M.size smap)) ++ " signals in the VCD file" , "Processing VCD data..." ] else [] dbg (debug_to st) debug_msg handleMsgs errh (results ++ clks_not_found ++ info ++ ci_status ++ cross_rule_aliases) writeVCD hOut (virtual_vars ++ [EndDefs]) let st' = hyper (invsigmap,clock_code_map,modified') st { inv_signal_map = invsigmap , code_map = clock_code_map , action_map = M.empty -- not needed after EndDefs , modified_set = modified' } return st' -- These are all VCD commands in the value change section -- update time, scale up timestamps to accommodate microticks, and -- handle any clock edges at the previous time morphVCD' errh hOut st (Timestamp t) = do let t' = t * (10 ^ (time_factor st)) (cmds_out,status,st') = foldl handleClkEdge ([],[],st) (edges st) st'' = st' { current_time = t' } handleMsgs errh status writeVCD hOut cmds_out return st'' -- record all signal changes associated with the task morphVCD' errh _ st cmd@(Task s cs) = do let t = current_time st valmap = foldl (\m (c,v) -> DM.insert t c (v, InTask s) m) (value_map st) [ (code,val) | chg <- cs , let code = signal_code chg , let val = new_value chg ] st' = st { value_map = valmap } return st' -- record an individual signal change and detect if this change -- represents a clock edge we need to process at the end of this -- time's section morphVCD' errh _ st cmd@(Change c) = do let -- record signal changes t = current_time st code = signal_code c val = new_value c valmap = DM.insert t code (val, Changed) (value_map st) -- detect clock edges cmap = code_map st sig = M.lookup code cmap posedge_clk = case sig of (Just (ClockSignal {})) -> val == (Scalar (Logic True)) _ -> False st' = if (posedge_clk && (t > 0)) then let edges' = (code, fromJust sig):(edges st) in st { value_map = valmap , edges = edges' } else st { value_map = valmap } return st' -- Handle VCD errors and unknown commands morphVCD' errh _ st (VCDErr msg input) = do let -- compose an error message emsg = msg ++ " while parsing '" ++ input ++ "'" handleMsgs errh [Err (noPosition, EGeneric emsg)] return st morphVCD' errh hOut st cmd = do writeVCD hOut [cmd] -- pass command through unchanged return st -- Generate progress indicator doProgress :: ConvState -> Integer -> IO ConvState doProgress st bytes = let new_bytes = (curr_bytes st) + bytes st' = st { curr_bytes = new_bytes } show_it = case (progress_at st) of Just tgt -> new_bytes >= tgt Nothing -> False in if (show_it) then do (TOD s ps) <- getClockTime let now = (fromInteger s) + (fromInteger ps / (10.0^(12 :: Int))) bytes_per_sec = (fromInteger (new_bytes - (prev_bytes st))) / (now - (prev_time st)) percentage = ((100 * new_bytes) + ((total_bytes st) `div` 4)) `div` (total_bytes st) next_progress = ((percentage + 1) * (total_bytes st)) `div` 100 msg = (show percentage) ++ "% complete (" ++ (show ((round bytes_per_sec) :: Integer)) ++ " bytes/sec)" putStrLn msg return $ st' { prev_time = now , prev_bytes = new_bytes , progress_at = Just next_progress } else return st' -- Auxiliary routines used during VCD conversion -- Check that the root scope was found found_root_scope :: ConvState -> [Status] found_root_scope st = case (root_find st) of (Just _) -> [Err (noPosition, EGeneric $ "Failed to locate root '" ++ (root st) ++ "' in VCD hierarchy")] Nothing -> [] -- Find a clock signal in the VCD hierarchy find_clk :: SignalMap -> (Int,([String],a)) -> Either Status (String,Code,Int) find_clk smap (n,(xs,_)) = match xs where match [] = Left $ Err (noPosition, EGeneric msg) match (s:rest) = case (M.lookup s smap) of Nothing -> match rest (Just (c,_)) -> Right (s,c,n) msg = unlines $ ["Failed to locate any clock for a domain. Candidates were:"] ++ (map (" " ++) xs) -- Create a list used for realigning signals by converting the key from -- a method identifier to a set of signal codes which can toggle in response -- to the method call. mkRealignment :: InstModMap -> SignalMap -> ClockMap -> RuleMap -> String -> M.Map (String,AMethodId) [RuleConds] -> (Realignment,Realignment,[Status]) mkRealignment instmap sigmap clkmap rulemap root_name m = let -- partition methods into RWire wsets and non-RWire methods (rw_meths, normal_meths) = partition ((isRWireMethod instmap) . fst) (M.toList m) -- convert methods to signals affected by the method ls = [ (codes, xs, ss) | (meth, xs) <- normal_meths , let (codes,ss) = getMethodSignals instmap sigmap root_name meth ] -- convert RWire methods to signals affected by the method rw_ls = [ (codes, xs, ss) | (meth, xs) <- rw_meths , let (codes,ss) = getMethodSignals instmap sigmap root_name meth ] -- permute a list of conditions so that they match the -- urgency order of their associated rules err1 name = internalError $ "Unknown rule '" ++ name ++ "'" err2 rn = internalError $ "Unknown rule number " ++ (show rn) snodes = [ M.findWithDefault (err1 name) name rulemap | (Sched r) <- concatMap snd (M.elems clkmap) , let name = getIdString r ] urg_map = M.fromList $ zip snodes [(0::Integer)..] reorder xs = map snd $ sort [ (urg,x) | x@(_,rn) <- xs , let urg = M.findWithDefault (err2 rn) rn urg_map ] rmap = M.fromListWith (++) [ (code, xs) | (codes, xs, _) <- ls , code <- codes ] rmap' = M.map reorder rmap rw_rmap = M.fromListWith (++) [ (code, xs) | (codes, xs, _) <- rw_ls , code <- codes ] rw_rmap' = M.map reorder rw_rmap status = concat [ ss | (_,_,ss) <- (ls ++ rw_ls) ] in (M.toList rmap', M.toList rw_rmap', status) -- Get all signals which can be modified by a call to a given method getMethodSignals :: InstModMap -> SignalMap -> String -> (String,AMethodId) -> ([Code],[Status]) getMethodSignals instmap sigmap root_name (inst,mid) = let err = internalError $ "Unknown instance name '" ++ inst ++ "'" mod = M.findWithDefault (err inst) inst instmap in if (isPrimitiveModule mod) then let meth = getIdBaseString mid inst' = if (null root_name) then inst else root_name ++ "." ++ inst (signals,status) = methodSignals mod meth inst' codes = map fst $ mapMaybe (flip M.lookup sigmap) signals in (codes,status) else ([],[]) -- Create the ClockSignal data that aggregates all information needed -- to process a clock edge mkClockInfo :: [(String,Code,Int)] -> Code -> ConvState -> ([(Code,Signal)],[Status]) mkClockInfo clks_found max_code st = let root_name = root st clkmap = clock_map st instmap = inst_map st smap = signal_map st rmap = rule_map st amap = action_map st err1 s = "no signal named '" ++ s ++ "'" err2 r = "no rule named '" ++ (getIdString r) ++ "'" errs = concat [ concat es | (_,_,n) <- clks_found , let (_,sns) = M.findWithDefault ([],[]) n clkmap , let es = [ cf_err ++ wf_err ++ rn_err | (Exec r) <- sns , let cf = root_name `joinName` (mkIdCanFire r) , let cf_err = if (M.notMember cf smap) then [err1 cf] else [] , let wf = root_name `joinName` (mkIdWillFire r) , let wf_err = if (M.notMember wf smap) then [err1 wf] else [] , let rn_err = if (M.notMember (getIdString r) rmap) then [err2 r] else [] ] ] info = [ ((c,ClockSignal n s fc bc w fs ral rw_ral), ral_status) | ((s,c,n),x) <- zip clks_found [1,3..] , let fc = max_code + x , let bc = max_code + x + 1 , let (_,sns) = M.findWithDefault ([],[]) n clkmap , let fs = [ (cf_code, wf_code, num) | (Exec r) <- sns , let cf = root_name `joinName` (mkIdCanFire r) , let mcf = M.lookup cf smap , isJust mcf , let cf_code = fst (fromJust mcf) , let wf = root_name `joinName` (mkIdWillFire r) , let mwf = M.lookup wf smap , isJust mwf , let wf_code = fst (fromJust mwf) , let mnum = M.lookup (getIdString r) rmap , isJust mnum , let num = fromJust mnum ] -- 1-bit signals show up differently in waves, so stay > 1 , let w = if (null fs) then 2 else max 2 (bitWidth (maximum (map (\(_,_,n) -> n) fs))) -- build the realignment data for this domain , let (ral, rw_ral, ral_status) = mkRealignment instmap smap clkmap rmap root_name (M.findWithDefault M.empty n amap) ] (clock_info,status) = unzip info in (clock_info, (concat status) ++ [ Err (noPosition, EGeneric emsg) | emsg <- errs ]) -- Process stored change data in response to the posedge of a clock handleClkEdge :: ([VCDCmd],[Status],ConvState) -> (Code,Signal) -> ([VCDCmd],[Status],ConvState) handleClkEdge (cmds,status,st) (code,clk) = let now = current_time st -- update edge data for this clock pos = M.findWithDefault 0 code (clk_edge_map st) new_edge_map = M.insert code now (clk_edge_map st) -- extract clock signal information fc = fired_code clk bc = blocked_code clk w = virtual_width clk fs = fire_signals clk ral = realignment clk rw_ral = rw_realignment clk -- determine which rules wrote signals which need realignment valmap0 = value_map st smap = signal_map st instmap = inst_map st root_name = root st moddefmap = mod_def_map st get_val inst e = let pfx = case (root_name, inst) of ("","") -> "" (x,"") -> x ("",y) -> y (x,y) -> x ++ "." ++ y in case (M.lookup inst instmap) of (Just mod) -> case (M.lookup mod moddefmap) of (Just defmap) -> getAExprValue smap valmap0 pfx inst defmap instmap (now-1) e Nothing -> Left $ "No definitions for module " ++ mod Nothing -> Left $ "Unknown instance " ++ inst to_bool (inst,e) = case (get_val inst e) of (Right v) -> Right (vcd_is_true_bit v) (Left err) -> Left err writers = [ (code,fired) | (code,tests) <- ral , changed_at now code valmap0 , let fired = [ (rn,errs) | (conds,rn) <- tests , let ebs = map to_bool conds , let (errs,bs) = separate ebs , and bs ] ] rw_writers = [ (code,fired) | (code,tests) <- rw_ral , not (x_at pos code valmap0) , let fired = [ (rn,errs) | (conds,rn) <- tests , let ebs = map to_bool conds , let (errs,bs) = separate ebs , and bs ] ] -- add virtual signal entries for this clock domain dflt = (Scalar X, Stable) rule_values = [ (n,(cfc,cfv),(wfc,wfv)) | (cfc,wfc,n) <- fs , let cfv = fst $ DM.findWithDefault dflt (now-1) cfc valmap0 , let wfv = fst $ DM.findWithDefault dflt (now-1) wfc valmap0 ] rules_of_interest = filter (\(_,(_,cf),_) -> vcd_is_true_bit cf) rule_values fchgs = (fc, [ if (vcd_is_true_bit wfv) then to_VCDValue w rn else to_X_VCDValue w | (rn,_,(_,wfv)) <- rules_of_interest ]) bchgs = (bc, [ if (vcd_is_true_bit wfv) then to_X_VCDValue w else to_VCDValue w rn | (rn,_,(_,wfv)) <- rules_of_interest ]) valmap1 = foldl (fill pos now w) valmap0 [fchgs, bchgs] -- rewrite CAN_FIRE/WILL_FIRE signals period = now - pos time_slots = genericLength rules_of_interest low = Scalar (Logic False) new_cf_wf = concat [ if (cfc == wfc) then [ (cfc,pos,low,t0,cfv,t1,low,now) ] else [ (cfc,pos,low,t0,cfv,t1,low,now) , (wfc,pos,low,t0,wfv,t1,low,now) ] | ((_,(cfc,cfv),(wfc,wfv)),n) <- zip rules_of_interest [0..] , let t0 = pos + ((period * n) `quot` time_slots) , let t1 = pos + ((period * (n+1)) `quot` time_slots) ] valmap2 = foldl contract valmap1 (combineCFWF new_cf_wf) -- realign signals to microtick edges (no_writer, maybe_writers) = partition (null . snd) (writers ++ rw_writers) oneWriter (_,[(_,[])]) = True oneWriter _ = False (ws, maybe_multiple) = partition oneWriter maybe_writers noErrs (_,xs) = all (null . snd) xs (multiple_writers, undetermined) = partition noErrs maybe_multiple get_slot_num rn = fromJust $ findIndex (\(rn',_,_) -> rn' == rn) rules_of_interest single_writers = [ (c, get_slot_num rn) | (c,[(rn,_)]) <- ws ] (_,last_multiple_writers) = unzip $ [ ((c, minimum ns), (c, maximum ns)) | (c,rs) <- multiple_writers , let ns = map (get_slot_num . fst) rs ] writers' = single_writers ++ last_multiple_writers invrulemap = inv_rule_map st invsigmap = inv_signal_map st ral_status = [ Info $ "No rule identified for change in " ++ sig_name ++ " at time " ++ (show now) | (c,_) <- no_writer , let sig_name = M.findWithDefault "?" c invsigmap ] ++ [ Info $ "Multiple rules wrote to " ++ sig_name ++ " at time " ++ (show now) ++": " ++ (intercalate ", " rule_names) | (c,rinfo) <- multiple_writers , let sig_name = M.findWithDefault "?" c invsigmap , let rule_names = [ M.findWithDefault "?" rn invrulemap | (rn,_) <- rinfo ] ] ++ [ Info $ "Unable to determine which rule(s) changed " ++ sig_name ++ " at time " ++ (show now) ++ ": " ++ (intercalate "; " err_msgs) | (c,rinfo) <- undetermined , let sig_name = M.findWithDefault "?" c invsigmap , let err_msgs = [ "For rule " ++ rule_name ++ ": " ++ (intercalate ", " errs) | (rn,errs) <- rinfo , let rule_name = M.findWithDefault "?" rn invrulemap ] ] rw_codes = S.fromList (map fst rw_writers) valmap3 = foldl (realign pos now time_slots rw_codes) valmap2 writers' -- update the set of modified signals mods = S.fromList $ concat [ if (cfc == wfc) then [cfc] else [cfc,wfc] | (_,(cfc,_),(wfc,_)) <- rules_of_interest ] ++ (map fst writers') new_mod_set = (modified_set st) `S.union` mods -- possibly flush VCD data prior to previous edge of this clock (new_cmds,new_status,new_st) = hyper new_mod_set $ flushChanges $ st { clk_edge_map = new_edge_map , value_map = valmap3 , edges = [] , modified_set = new_mod_set } -- compose a debugging message cond_records = [ [ " For signal " ++ (vcd_code_to_string code) ++ " " ++ sig_name ] ++ [ " " ++ (if ok then "* [" else " [") ++ (intercalate ", " vals) ++ "] => " ++ rule_name | (xs, rn) <- cond_values , let ok = and [ b | ebs <- map snd xs , let b = case ebs of (Left err) -> False (Right x) -> x ] , let vals = [ inst ++ " " ++ (init (ppReadable e)) ++ " (" ++ desc ++ ")" | ((inst,e),ebs) <- xs , let desc = case ebs of (Left err) -> err (Right b) -> show b ] , let rule_name = M.findWithDefault "?" rn invrulemap ] | (code,tests) <- ral , changed_at now code valmap0 , let cond_values = [ (zip conds bs, rn) | (conds,rn) <- tests , let bs = map to_bool conds ] , let sig_name = M.findWithDefault "?" code invsigmap ] debug_msg = "---- PROCESSED " ++ (show (clk_domain clk)) ++ " CLOCK EDGE AT TIME " ++ (show now) ++ " ----\n" ++ (show rule_values) ++ "\n" ++ "CONDITIONS:\n" ++ (unlines (concat cond_records)) ++ "REALIGNMENT STATUS:" ++ "\n" ++ (unlines (map (\x -> " " ++ (show x)) ral_status)) in dbg_trace (debug_to new_st) debug_msg (cmds ++ new_cmds, status ++ ral_status ++ new_status, new_st) -- flush value changes that are in their final form flushChanges :: ConvState -> ([VCDCmd],[Status],ConvState) flushChanges st = let -- find the current flush limit limit = minimum (M.elems (clk_edge_map st)) -- split out all value changes below the limit (flush,keep) = DM.split limit (\(v,_) -> (v,Stable)) (value_map st) st' = st { value_map = keep } -- convert flushed changes to VCD commands chgs = M.fromListWith (M.unionWith S.union) [ (t, M.singleton r (S.singleton (c,v))) | (t,c,(v,r)) <- DM.toList flush ] mkCmds (Changed,set) = map Change (S.toList set) mkCmds (InTask s,set) = [Task s (S.toList set)] mkCmds (Stable,_) = [] cmds = concat [ (Timestamp t):(concatMap mkCmds (M.toList map)) | (t,map) <- M.toAscList chgs ] info = [] in (cmds, info, st') -- Print the messages from the conversion stream handleMsgs :: ErrorHandle -> [Status] -> IO () handleMsgs errh status = do let errs = [ e | (Err e) <- status ] warns = [ w | (Warn w) <- status ] msgs = [ s | (Info s) <- status ] when (not (null msgs)) $ mapM_ putStrLn msgs when (not (null warns)) $ bsWarning errh warns when (not (null errs)) $ bsErrorNoExit errh errs return () -- Handle termination of VCD data endOfVCD :: ErrorHandle -> Handle -> ConvState -> IO () endOfVCD errh hOut s = do let t = (current_time s) + 1 new_edge_map = M.map (const t) (clk_edge_map s) (cmds,status,_) = flushChanges (s { clk_edge_map = new_edge_map }) handleMsgs errh status writeVCD hOut cmds -- ------------------------------------------------------------------- -- Novas command generation formatNovas :: ConvState -> String formatNovas st = let -- Build an alias table of names for rule numbers. -- Shorten names to keep only enough suffix to uniquely identify rule. rmap = rule_map st full_names = [ (n, x, xs) | (s,n) <- M.toList rmap , let (x:xs) = reverse (wordsBy (=='.') s) ] lengthen n name [] = internalError "duplicate keys in map!?!?" lengthen n name (x:xs) = (n, x ++ "." ++ name, xs) try_to_add m [] = m try_to_add m ((n,name,dropped):rest) = case (M.lookup name m) of (Just (Just (n',dropped'))) -> -- collision let m' = M.insert name Nothing m x1 = lengthen n name dropped x2 = lengthen n' name dropped' in try_to_add m' (x1:x2:rest) (Just Nothing) -> -- multiple collision let x = lengthen n name dropped in try_to_add m (x:rest) Nothing -> -- no collision let m' = M.insert name (Just (n,dropped)) m in try_to_add m' rest abbrev_map = try_to_add M.empty full_names rule_tbl = unlines $ [ "# Setup rule name alias table" , "wvAddAliasTable -table RuleNames" ] ++ [ "wvAddAliasTable -table RuleNames -row " ++ s ++ " " ++ (show n) | (s, Just (n,_)) <- M.toList abbrev_map ] -- Add virtual signals to alias map sigs = M.toList (code_map st) alias_map = unlines $ [ "# Add aliases for virtual signals" ] ++ [ "set aliases(" ++ (toNovas s) ++ ") RuleNames" | (_,ClockSignal { clk_name = name }) <- sigs , s <- [ "\\FIRED_RULE_" ++ name ++ " " , "\\BLOCKED_RULE_" ++ name ++ " " ] ] -- Add color entries for signals to the color map code_list = [ (s,c) | (s,(c,_)) <- M.toList (signal_map st) ] color_map = unlines $ [ "# Add color entries for signals" ] ++ [ "set colors(" ++ (toNovas s) ++ ") " ++ (fromJust color) | (s,c) <- code_list , let color = choose_sig_color st c , isJust color ] in rule_tbl ++ "\n" ++ alias_map ++ "\n" ++ color_map ++ "\n" ++ add_signal_callback -- Convert a signal name to Novas TCL format toNovas :: String -> String toNovas s@('\\':_) = '/':(esc s) toNovas s = '/':((esc . dotToSlash) s) esc :: String -> String esc = concatMap (\c -> if (c `elem` " $\\") then ['\\',c] else [c]) dotToSlash :: String -> String dotToSlash = map (\c -> if (c == '.') then '/' else c) -- Boilerplate common to all command scripts add_signal_callback :: String add_signal_callback = unlines $ [ "# Setup event callback for setting signal properties" , "proc sigCB args {" , " upvar aliases aliases" , " upvar colors colors" , "" , " # Get the list of signals being added" , " set nargs [llength $args]" , " set signals [lrange $args 4 [expr $nargs - 1]]" , "" , " # Record the current selection set" , " set selected [wvGetSelectedSignals]" , "" , " # Consider each signal in turn" , " foreach sig $signals {" , "" , " # Set alias if one is specified" , " if {[info exists aliases($sig)]} {" , " wvDeselectAll" , " wvSelectSignal $sig" , " wvSetAliasTable -table $aliases($sig)" , " }" , "" , " # Set color if one is specified" , " if {[info exists colors($sig)]} {" , " wvDeselectAll" , " wvSelectSignal $sig" , " wvChangeDisplayAttr -color $colors($sig)" , " }" , "" , " }" , "" , " # Restore the original selection" , " wvSelectSignal $selected" , "}" , "" , "# Add the callback to handle signal adds" , "AddEventCallback [tk appname] sigCB wvAddSignal 1" ] choose_sig_color :: ConvState -> Code -> Maybe String choose_sig_color st code = let is_modified = S.member code (modified_set st) sig = M.lookup code (code_map st) is_clock = case sig of (Just (ClockSignal {})) -> True _ -> False in if (is_modified || is_clock) then Nothing else Just "slategray" -- ------------------------------------------------------------------- -- ValueMap manipulation functions -- Test if there is a change at a particular time changed_at :: Integer -> Code -> ValueMap -> Bool changed_at t code valmap = case (DM.lookup t code valmap) of (Just (t',_)) -> (t == t') Nothing -> False -- Test if a value was X at a particular time x_at :: Integer -> Code -> ValueMap -> Bool x_at t code valmap = case (DM.lookup t code valmap) of (Just (_,(v,_))) -> vcd_is_x v Nothing -> False -- Given a time interval and a list of values for a code, -- fill the interval in the value map with evenly spaced transitions -- to each value in the list. If the list if empty, the interval is -- filled with an X value of the specified width. fill :: Integer -> Integer -> Integer -> ValueMap -> (Code,[VCDValue]) -> ValueMap fill t0 t1 width m (code,vs) = let slots = genericLength vs period = t1 - t0 chgs = if (slots == 0) then [ (t0,(to_X_VCDValue width,Changed)) ] else [ (t,(v,Changed)) | (v,n) <- zip vs [0..] , let t = t0 + ((period * n) `quot` slots) ] chgs' = dropRepeatsBy (\(_,(v1,_)) (_,(v2,_)) -> v1 == v2) chgs in DM.adjust (M.union (M.fromList chgs')) code m -- Shrink the duration of a a signal to a portion of the clock cycle, -- filling in the gaps before and after the shrunken interval with -- default values. contract :: ValueMap -> (Code,Integer,VCDValue,Integer,VCDValue,Integer,VCDValue,Integer) -> ValueMap contract m (c,t0,v_pre,t0',v,t1',v_post,t1) = DM.adjust (fixup (t0,v_pre,t0',v,t1',v_post,t1)) c m fixup :: (Integer,VCDValue,Integer,VCDValue,Integer,VCDValue,Integer) -> M.Map Integer (VCDValue,ChangeReason) -> M.Map Integer (VCDValue,ChangeReason) fixup (t0,v_pre,t0',v,t1',v_post,t1) m = let -- determine the value at the beginning of the interval -- and prior to the start of the interval c = M.lookupLE t0 m (val_before,at) = case c of Nothing -> (Nothing,Nothing) Just (t,v) | t == t0 -> (M.lookupLE (t0-1) m, Just v) | otherwise -> (c,Nothing) -- determine the value we want at t0 t0_val = if (t0' == t0) then v else v_pre -- decide what to do at t0 -- + if there is already a change at t0 to the correct value, -- we should keep it -- + if there is a previous value and it is the same as t0_val, -- then we don't need any change at t0 -- + otherwise, we should add a new change to t0_val at t0 (del_t0,t0_chg) = case at of (Just val@(x,r)) | x == t0_val -> (False,Nothing) (Just _) -> case val_before of (Just (_,(x,_))) | x == t0_val -> (True,Nothing) _ -> (True, Just (t0,(t0_val,Changed))) Nothing -> case val_before of (Just (_,(x,_))) | x == t0_val -> (False,Nothing) _ -> (False, Just (t0,(t0_val,Changed))) -- determine if we need a change at t0' t0'_chg = if ((t0' == t0) || (t0_val == v)) then Nothing else Just (t0',(v,Changed)) -- determine if we need a change at t1' t1'_chg = if ((v == v_post) || (t1' == t1)) then Nothing else Just (t1',(v_post,Changed)) -- determine if we need to restore the value at t1 (so that -- lookups will see the correct value as if it hadn't been -- contracted). t1_chg = if ((v == v_post) || (t1' == t1)) then Nothing else Just (t1,(v,Changed)) -- update the map to reflect the changes chgs = catMaybes [t0_chg, t0'_chg, t1'_chg, t1_chg] m' = (if del_t0 then M.delete t0 m else m) `M.union` (M.fromList chgs) in m' -- Realign an edge at given time (if it exists) to another point realign :: Integer -> Integer -> Integer -> S.Set Code -> ValueMap -> (Code,Int) -> ValueMap realign _ _ 0 _ vmap _ = vmap realign t0 t1 slots rwires vmap (c,n) = let t = t0 + (((t1 - t0) * (fromIntegral (n+1))) `div` slots) move_from = if (c `S.member` rwires) then t0 else t1 move_edge m = case (M.lookup move_from m) of (Just x) -> M.insert t x (M.delete move_from m) Nothing -> m in DM.adjust move_edge c vmap -- Some simulators will generate VCD aliases in which CF/WF signals for -- different rules use the same VCD signal code because they always -- fire together. This can lead to the same code appearing multiple times -- in the CF/WF contraction list with different areas for each of the -- rule aliases. This routine is used to modify the CF/WF contraction -- list so that these shared codes do not interfere with each other. combineCFWF :: [(Code,Integer,VCDValue,Integer,VCDValue,Integer,VCDValue,Integer)] -> [(Code,Integer,VCDValue,Integer,VCDValue,Integer,VCDValue,Integer)] combineCFWF cl = let get_code (c,_,_,_,_,_,_,_) = c cl' = sortBy (\x y -> (get_code x) `compare` (get_code y)) cl groups = groupBy (\x y -> (get_code x) == (get_code y)) cl' splice [x] = [x] splice xs = let (starts,stops) = unzip [ (t0',t1') | (_,_,_,t0',_,t1',_,_) <- xs ] in map (adjust_ends starts stops) xs adjust_ends starts stops (c,t0,v_pre,t0',v,t1',v_post,t1) = let before_t0' = filter (t1') starts new_t0 = if (null before_t0') then t0 else maximum before_t0' new_t1 = if (null after_t1') then t1 else minimum after_t1' in (c,new_t0,v_pre,t0',v,t1',v_post,new_t1) in concat (map splice groups) -- ------------------------------------------------------------------- -- Evaluating AExprs using VCD value -- Get an Integer value associated with a signal, if there is one lookupId :: SignalMap -> ValueMap -> Integer -> String -> AId -> Maybe Integer lookupId smap vmap at pfx i = let name = case (getIdQualString (addToQual pfx i)) of "" -> getIdBaseString i s -> s ++ "." ++ (getIdBaseString i) in do (code,_) <- M.lookup name smap (_,(val,_)) <- DM.lookup at code vmap vcd_to_integer val -- Get the AExpr value associated with an identifier, if there is one lookupAExpr :: String -> DefMap -> AId -> Maybe AExpr lookupAExpr pfx defmap i = do let i' = setIdQualString i "" def <- M.lookup i' defmap return (adef_expr def) -- Get a list of alternative AExprs in which to look for the value -- of a method call. lookupMeth :: String -> InstModMap -> (AId,AId) -> [AId] lookupMeth pfx instmap (oid,mid) = let name = getIdString oid inst = if (null pfx) then name else pfx ++ "." ++ name meth = getIdBaseString mid in case (M.lookup inst instmap) of (Just mod) -> if (isPrimitiveModule mod) then map to_id (resolveMethodValue mod meth name) else [] Nothing -> [] -- Compute the value of an AExpr at a given time getAExprValue :: SignalMap -> ValueMap -> String -> String -> DefMap -> InstModMap -> Integer -> AExpr -> Either String VCDValue getAExprValue smap vmap pfx pfx_noroot defmap instmap at e = let valfn = lookupId smap vmap at pfx exprfn = lookupAExpr pfx defmap methfn = lookupMeth pfx_noroot instmap in case (aType e) of (ATBit n) -> case (evalAExprToInteger valfn exprfn methfn e) of (Right x) -> Right $ to_VCDValue x n (Left msg) -> Left msg _ -> Left "Cannot reconstruct non-bit types" -- ------------------------------------------------------------------- -- Routines describing primitive module behaviors isRWireMethod :: InstModMap -> (String,AMethodId) -> Bool isRWireMethod instmap (inst,mid) = let err = internalError $ "Unknown instance name '" ++ inst ++ "'" mod = M.findWithDefault (err inst) inst instmap meth = getIdBaseString mid in (meth == "wset") && ((mod == "RWire") || (mod == "RWire0")) && (isPrimitiveModule mod) -- Get the set of signals which might be changed due to an -- Action method call on a primitive module. methodSignals :: String -> String -> String -> ([String],[Status]) methodSignals "RegN" "write" inst = ([inst],[]) methodSignals "RegUN" "write" inst = ([inst],[]) methodSignals "RegA" "write" inst = ([inst],[]) methodSignals "RWire" "wset" inst = ([inst],[]) methodSignals "RWire0" "wset" inst = ([inst],[]) methodSignals "SyncRegister" "write" inst = ([],[]) methodSignals "RegFile" "upd" inst = ([],[]) methodSignals "RegFileLoad" "upd" inst = ([],[]) methodSignals mod "enq" inst | isFIFO mod = (map (inst ++) [".FULL_N",".EMPTY_N",".D_OUT"],[]) methodSignals mod "deq" inst | isFIFO mod = (map (inst ++) [".FULL_N",".EMPTY_N",".D_OUT"],[]) methodSignals mod "clear" inst | isFIFO mod = (map (inst ++) [".FULL_N",".EMPTY_N",".D_OUT"],[]) methodSignals s m _ = ([],[Warn (noPosition, EGeneric $ "Unknown primitive Action method '" ++ s ++ "." ++ m ++ "'")]) -- Get a list of alternative signals for a value method call -- on a primitive module. resolveMethodValue :: String -> String -> String -> [String] resolveMethodValue "RegN" "read" inst = [inst] resolveMethodValue "RegUN" "read" inst = [inst] resolveMethodValue "RegA" "read" inst = [inst] resolveMethodValue "RWire" "wget" inst = [inst] resolveMethodValue "RWire" "whas" inst = [] resolveMethodValue "RWire0" "whas" inst = [inst] resolveMethodValue "SyncRegister" "RDY_write" inst = [inst ++ ".sRDY"] resolveMethodValue "SyncRegister" "read" inst = [inst ++ ".dD_OUT"] resolveMethodValue mod "first" inst | isFIFO mod = [inst ++ ".D_OUT"] resolveMethodValue s m _ = internalError $ "Unknown primitive value method '" ++ s ++ "." ++ m ++ "'" -- ------------------------------------------------------------------- -- Utility functions ilog1000 :: Integer -> Integer ilog1000 n = helper n 1 0 where helper n x r = if (n <= x) then r else helper n (1000*x) (r+3) bitWidth :: Integer -> Integer bitWidth 0 = 1 bitWidth 1 = 1 bitWidth n = 1 + (bitWidth (n `quot` 2)) joinName :: String -> Id -> String joinName "" i = getIdString i joinName q i = q ++ "." ++ (getIdString i) getClkName :: String -> AClock -> Maybe String getClkName "" clk = case (aclock_osc clk) of (ASPort _ i) -> Just (getIdString i) _ -> Nothing getClkName root_name clk = case (aclock_osc clk) of (ASPort _ i) -> Just (root_name ++ "." ++ (getIdString i)) _ -> Nothing -- Convert a CondTree's CAN_FIRE conditions to WILL_FIRE conditions cf_to_wf :: CondTree (String,AExpr) a -> CondTree (String,AExpr) a cf_to_wf = map_cond conv_cf where conv_cf (inst,(ASDef t i)) | isIdCanFire i = (inst,ASDef t (mkIdWillFire (dropCanFirePrefixId i))) conv_cf c = c -- Remove a width specifier in brackets ([7:0]) from a signal name strip_width_brackets :: String -> String strip_width_brackets s = takeWhile (/= '[') s -- Turn a string into an AId to_id :: String -> AId to_id "" = emptyId to_id s = let segs = wordsBy (=='.') s qual = intercalate "." (init segs) base = last segs in setIdQualString (mk_homeless_id base) qual -- Write to a debug log, if one is active dbg :: (Maybe Handle) -> String -> IO () dbg Nothing _ = return () dbg (Just hdl) s = do hPutStr hdl s hFlush hdl -- Like dbg, but used in non-IO context (uses unsafePerformIO) {-# NOINLINE dbg_trace #-} dbg_trace :: (Maybe Handle) -> String -> a -> a dbg_trace Nothing _ x = x dbg_trace (Just hdl) s x = unsafePerformIO $ do hPutStr hdl s hFlush hdl return x -- --------------- -- Hyper instances instance Hyper SchedNode where hyper n x = (n == n) `seq` x instance Hyper Signal where hyper s x = (s == s) `seq` x