-- TODO: -- The schedule should always print to a file, and not just stdout. -- aDumpSchedule should be refactored to meet coding standards {-# LANGUAGE CPP #-} module ADumpSchedule( MethodDumpInfo, aDumpSchedule, aDumpScheduleErr, genMethodDumpMap, dumpMethodInfo, dumpMethodBVIInfo ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) #endif import Control.Monad(unless, when, foldM) import System.IO(IOMode(..), hPutChar, hClose, stdout, hFlush) import Data.Maybe(fromMaybe) import Data.List(delete, find) import qualified Data.Set as S import ASyntax import Error(internalError, showWarningList, getErrMsgTag, ErrMsg(..), ErrorHandle, bsWarning, emptyContext) import Id import SAT(initSATState, checkEq) import VModInfo(VSchedInfo) import SchedInfo(SchedInfo(..), MethodConflictInfo(..)) import AScheduleInfo import ADumpScheduleInfo import Flags(Flags, quiet, showSchedule, removeStarvedRules, infoDir, hasDump, DumpFlag(..)) import Position import Pragma import PFPrint import FileNameUtil(mkSchedName, getRelativeFilePath) import FileIOUtil(putStrHandles, openFileCatch) -- import Debug.Trace str_none :: String str_none = "(none)" list_or_none :: [a] -> Doc -> Doc list_or_none l doc = if (not . null) l then doc else text str_none -- convert scheduling group into list of rules and blocking rules ruleBlockers :: AScheduler -> [(ARuleId, [ARuleId])] ruleBlockers (ASchedEsposito espositoSch) = espositoSch dumpRule :: Flags -> [ADef] -> (ARuleId, AExpr, Maybe [ARuleId]) -> Doc dumpRule flags ds (rid, predicate, maybe_blockers) = text ("Rule:") <+> text (dropRulePrefix rid) $$ text ("Predicate:") <+> (pPrintExpandFlags flags ds PDReadable bContext predicate) $$ (case maybe_blockers of Just blockers -> text ("Blocking rules:") <+> (list_or_none blockers (sepList (map (text . dropRulePrefix) blockers) comma)) Nothing -> empty ) $$ space -- insert blank line -- flags aren't really necessary, but dumpMethod wants them dumpMethodInfo :: Flags -> MethodDumpInfo -> [Doc] dumpMethodInfo flags [] = [text str_none] -- show that there is no information dumpMethodInfo flags mdis = map (dumpMethod flags False []) mdis dumpMethod :: Flags -> Bool -> [ADef] -> (AMethodId, AExpr, [(AMethodId, RuleConflictType)]) -> Doc dumpMethod flags dumpRdy ds (mid, p, clist) = let cf_lst = [rid | (rid, cftype) <- clist, cftype == ConflictFree] scbefore_lst = [rid | (rid, cftype) <- clist, cftype == SCBefore] scafter_lst = [rid | (rid, cftype) <- clist, cftype == SCAfter] scbeforeR_lst = [rid | (rid, cftype) <- clist, cftype == SCBeforeR] scafterR_lst = [rid | (rid, cftype) <- clist, cftype == SCAfterR] conflict_lst = [rid | (rid, cftype) <- clist, cftype == Complete] plist str lst = if (not . null) lst then (text str <+> (sepList (map (text . pfpString) lst) comma)) else empty in text ("Method:") <+> text (getFromReady mid) $$ (if dumpRdy then text ("Ready signal:") <+> (pPrintExpandFlags flags ds PDReadable bContext p) else empty ) $$ plist "Conflict-free:" cf_lst $$ plist "Sequenced before:" scbefore_lst $$ plist "Sequenced before (restricted):" scbeforeR_lst $$ plist "Sequenced after:" scafter_lst $$ plist "Sequenced after (restricted):" scafterR_lst $$ plist "Conflicts:" conflict_lst $$ space -- insert blank line dumpMethodBVIInfo :: MethodDumpInfo -> [Doc] dumpMethodBVIInfo [] = [text str_none] -- show that there is no information dumpMethodBVIInfo mdis = map dumpMethodBVI mdis dumpMethodBVI :: (AMethodId, AExpr, [(AMethodId, RuleConflictType)]) -> Doc dumpMethodBVI (mid, p, clist) = let cf_lst = [rid | (rid, cftype) <- clist, cftype == ConflictFree] scbefore_lst = [rid | (rid, cftype) <- clist, cftype == SCBefore] scbeforeR_lst = [rid | (rid, cftype) <- clist, cftype == SCBeforeR] conflict_lst = [rid | (rid, cftype) <- clist, cftype == Complete] plist s_str e_str lst = if (not . null) lst then text "schedule" <+> (text (getFromReady mid) <+> text s_str <+> (sepList (map (text . pfpString) lst) comma)) <+> (text e_str) else empty in plist " CF (" ");" cf_lst $$ plist " SB (" ");" scbefore_lst $$ plist " SBR (" ");" scbeforeR_lst $$ plist " C (" ");" conflict_lst $$ space -- insert blank line aDumpSchedule :: ErrorHandle -> Flags -> [PProp] -> String -> APackage -> AScheduleInfo -> IO (APackage, AScheduleInfo, MethodDumpInfo) aDumpSchedule errh flags pps prefix pkg aschedinfo = do -- Extract fields from the package and schedinfo -- let sch = asi_schedule aschedinfo vSchedInfo = asi_v_sched_info aschedinfo ifc = apkg_interface pkg rs = apkg_rules pkg ds = apkg_local_defs pkg ss = apkg_state_instances pkg let methodDumpMap = genMethodDumpMap vSchedInfo ifc rulePredMap = [(rid, p) | (ARule { arule_id = rid, arule_pred = p }) <- rs ] let removeRules = removeStarvedRules flags -- Dump the schedule -- when (showSchedule flags) $ doShowSchedule errh flags prefix pkg (Right aschedinfo) (Just methodDumpMap) rulePredMap -- initial state for checking whether RDY/WILL_FIRE is constant False -- (rule or method will never fire) -- let str = "dumpsched_" ++ ppString (apkg_name pkg) sat_state0 <- initSATState str errh flags True ds ss -- function to fold over a list of pairs of a rule/method Id and -- its condition, returning a list of the bad Ids, threading the state let checkFoldFn (bad_is, s) (i, cond) = do (res, s') <- checkEq s cond aFalse let bad_is' = if (res == Just True) then (i:bad_is) else bad_is return (bad_is', s') -- Check for methods that are never ready -- let warnRdy i = (getPosition i, WMethodNeverReady (getFromReady i)) let methodRdys = [ (mn, adef_expr v) | (AIDef { aif_name = mn, aif_value = v }) <- ifc , isRdyId mn ] (falseRdys, sat_state1) <- foldM checkFoldFn ([], sat_state0) methodRdys -- reverse the list to put it back in order let rdyWarnings = map warnRdy (reverse falseRdys) -- Check for rules that can never fire -- let warnWillFire i = (getPosition i, WRuleNeverFires (dropRulePrefix i) removeRules) let willFireExprs = [ (i, ASDef aTBool (mkIdWillFire i)) | i <- (map fst rulePredMap) ] (falseWillFires, _) <- foldM checkFoldFn ([], sat_state1) willFireExprs -- reverse the list to put it back in order let willFireWarnings = map warnWillFire (reverse falseWillFires) -- Warnings -- let warnings = rdyWarnings ++ willFireWarnings unless (null warnings) $ bsWarning errh warnings -- Package and schedule minus any rules that can never fire -- let rs' = [r | r@(ARule { arule_id = rid }) <- rs, not (rid `elem` falseWillFires) ] ds' = removeADefMethodPredsByRuleId falseWillFires ds pkg' = pkg { apkg_rules = rs', apkg_local_defs = ds' } sch' = dropScheduleIds falseWillFires sch -- Return the (possibly updated) package and schedule -- and the method dump map -- let new_pkg = if removeRules then pkg' else pkg new_sched = if removeRules then sch' else sch new_warnings = let processWarning e@(pos,msg) = (pos, getErrMsgTag msg, showWarningList [e]) in (asi_warnings aschedinfo) ++ (map processWarning warnings) new_aschedinfo = aschedinfo { asi_schedule = new_sched, asi_warnings = new_warnings } return (new_pkg, new_aschedinfo, methodDumpMap) aDumpScheduleErr :: ErrorHandle -> Flags -> String -> APackage -> AScheduleErrInfo -> IO () aDumpScheduleErr errh flags prefix pkg aschedinfo = do -- Extract fields from the package and schedinfo -- let ifc = apkg_interface pkg rs = apkg_rules pkg let maybe_methodDumpMap = case (asei_v_sched_info aschedinfo) of Just vSchedInfo -> Just (genMethodDumpMap vSchedInfo ifc) _ -> Nothing rulePredMap = [(rid, p) | (ARule { arule_id = rid, arule_pred = p }) <- rs ] -- Dump the schedule -- when (showSchedule flags) $ doShowSchedule errh flags prefix pkg (Left aschedinfo) maybe_methodDumpMap rulePredMap doShowSchedule :: ErrorHandle -> Flags -> String -> APackage -> Either AScheduleErrInfo AScheduleInfo -> Maybe MethodDumpInfo -> [(ARuleId, APred)] -> IO () doShowSchedule errh flags prefix pkg aschedinfo maybe_methodDumpMap rulePredMap = do let maybe_schedule = case (aschedinfo) of Right r -> Just (asi_schedule r) Left l -> asei_schedule l maybe_order = case maybe_schedule of Just s -> Just (asch_rev_exec_order s) Nothing -> Nothing getRuleBlockers rid = case maybe_schedule of Just s -> let ruleBlockerMap = concatMap ruleBlockers (asch_scheduler s) in case (lookup rid ruleBlockerMap) of Nothing -> internalError("Unscheduled rules? " ++ ppReadable rulePredMap) res -> res Nothing -> Nothing let ds = apkg_local_defs pkg let modstr = getIdBaseString (apkg_name pkg) let schedName :: String schedName = mkSchedName (infoDir flags) prefix modstr -- schedFileH <- openFileCatch errh emptyContext schedName WriteMode unless (quiet flags) $ putStrLn $ "Schedule dump file created: " ++ (getRelativeFilePath schedName ) let outputHandles = schedFileH : [stdout | hasDump flags DFschedule] -- -- let schedPutStr :: String -> IO () schedPutStr str = putStrHandles outputHandles str let schedPutStrLn :: String -> IO () schedPutStrLn str = do schedPutStr str mapM_ (`hPutChar` '\n') outputHandles let schedPutDoc :: Doc -> IO () schedPutDoc d = schedPutStr (pretty 78 78 d) let topBanner = "=== Generated schedule for " ++ modstr ++ " ===\n" schedPutStrLn topBanner case (maybe_methodDumpMap) of Just methodDumpMap | ((not . null) methodDumpMap) -> do schedPutStrLn "Method schedule" schedPutStrLn "---------------" mapM_ (schedPutDoc . (dumpMethod flags True ds)) methodDumpMap _ -> return () -- Dump rule schedule -- XXX should we sort, etc. to make this more efficient? let ruleDumpMap = [ (rid, p, blockers) | (rid, p) <- rulePredMap, let blockers = getRuleBlockers rid ] when ((not . null) ruleDumpMap) $ do schedPutStrLn "Rule schedule" schedPutStrLn "-------------" mapM_ (schedPutDoc . (dumpRule flags ds)) ruleDumpMap -- probably always non-null but might as well be safe case (maybe_order) of Just order | ((not . null) order) -> schedPutStr (pretty 78 78 (text ("Logical execution order: ") <> (sepList (map (text . dropRulePrefix) (reverse order)) comma))) _ -> return () schedPutStrLn "" schedPutStrLn (map (const '=') topBanner) -- Close the files mapM_ hFlush outputHandles mapM_ hClose (delete stdout outputHandles) genMethodDumpMap :: VSchedInfo -> [AIFace] -> MethodDumpInfo genMethodDumpMap vSchedInfo ifc = methodDumpMap where -- for now, we only report the conflict info -- XXX could include the rule-between info vMethConf = methodConflictInfo vSchedInfo -- don't include output clocks and resets -- don't include ready Ids methodList = filter (not . isRdyId) $ map aIfaceName (aIfaceMethods ifc) methodRdys = [(mn, p) | (AIDef { aif_name = mn, aif_value = (ADef _ _ p _) }) <- ifc, isRdyId mn] methodDumpMap = [ (mid, p, clist) | mid <- methodList , let p = fromMaybe aTrue (lookup (mkRdyId mid) methodRdys) , let clist = dumpOneLocal mid methodList ] dumpOneLocal = dumpOneConflicts setCF setSB setSBR setCF = S.fromList (sCF vMethConf) setSB = S.fromList (sSB vMethConf) setSBR = S.fromList (sSBR vMethConf) dumpOneConflicts :: S.Set (AId, AId) -> S.Set (AId, AId) -> S.Set (AId, AId) -> AId -> [AId] -> [(AId,RuleConflictType)] dumpOneConflicts _ _ _ mid [] = [] dumpOneConflicts setCF setSB setSBR mid others = dumpConflicts mid others where dumpConflicts :: AId -> [AId] -> [(AId,RuleConflictType)] dumpConflicts mid [] = [] dumpConflicts mid (mid':rest) = case ((mid, mid') `S.member` setCF, (mid', mid) `S.member` setCF, (mid, mid') `S.member` setSB, (mid', mid) `S.member` setSB, (mid, mid') `S.member` setSBR, (mid', mid) `S.member` setSBR ) of (True,_,_,_,_,_) -> ((mid',ConflictFree) : (dumpConflicts mid rest)) (_,True,_,_,_,_) -> ((mid',ConflictFree) : (dumpConflicts mid rest)) (False,False,True,False,False,False) -> ((mid', SCBefore) : (dumpConflicts mid rest)) (False,False,False,True,False,False) -> ((mid', SCAfter) : (dumpConflicts mid rest)) (False,False,True,True,False,False) -> (if (mid == mid') then (mid', SCBefore) -- method SC with itself else (mid', Complete)) -- alternate way of representing complete conflict : (dumpConflicts mid rest) (False,False,False,False,True,False) -> ((mid', SCBeforeR) : (dumpConflicts mid rest)) (False,False,False,False,False,True) -> ((mid', SCAfterR) : (dumpConflicts mid rest)) (False,False,False,False,True,True) -> (if (mid == mid') then (mid', SCBeforeR) -- method SC with itself else (mid', Complete)) -- alternate way of representing complete conflict : (dumpConflicts mid rest) (False,False,False,False,False,False) -> ((mid', Complete) : (dumpConflicts mid rest)) x@(a,b,c,d,e,f) -> internalError ("Unknown conflict type: " ++ ppReadable x ++ " " ++ (ppReadable mid) ++ " " ++ (ppReadable mid') ++ "\n" ++ "Sched sets: " ++ (ppReadable (setCF, setSB, setSBR))) removeADefMethodPredsByRuleId :: [Id] -> [ADef] -> [ADef] removeADefMethodPredsByRuleId [] ds = ds removeADefMethodPredsByRuleId dropped_rule_ids ds = let dropped_id_set = S.fromList dropped_rule_ids isRuleProp (DefP_Rule {}) = True isRuleProp _ = False isForDroppedRule ps = case (find isRuleProp ps) of Just (DefP_Rule r) -> r `S.member` dropped_id_set _ -> internalError ("MethodPred with no DefP_Rule") dropDef (ADef i _ _ ps) = (hasIdProp i IdPMethodPredicate) && (isForDroppedRule ps) in filter (not . dropDef) ds