content: {-# LANGUAGE CPP #-}
  module AScheduleInfo (
      AScheduleErrInfo(..),
      AScheduleInfo(..),
      Conflicts(..),
      ExclusiveRulesDB(..),
      FastSchedNode(..),
      RuleRelationDB(..),
      RuleRelationInfo(..),
      SchedNode(..),
      areRulesDisjoint,
      areRulesExclusive,
      defaultRuleRelationship,
      erdbFromList,
      erdbToList,
      getRuleRelation,
      getSchedNodeId,
      isSchedNode,
      printRuleRelationInfo,
      rrdbFromList,
      unionRuleRelationInfo
  ) where
  
  #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
  import Prelude hiding ((<>))
  #endif
  
  import qualified Data.Map as M
  import qualified Data.Set as S
  import Data.List(intersperse)
  import Util(thd)
  import Eval
  
  import ErrorUtil
  import PFPrint
  import Position
  import Id(cmpIdByName)
  import ASyntax
  import AUses
  import VModInfo(VSchedInfo)
  import RSchedule(RAT)
  
  
  -- ========================================================================
  -- Data returned by the aSchedule stage
  --
  
  data AScheduleInfo = AScheduleInfo
      {
        -- Warnings during scheduling
        -- (position, tag, msg including position and tag)
        --
        asi_warnings             :: [(Position, String, String)],
  
        -- In order of computation in ASchedule:
  
        -- The method uses map and the rule uses map
        --   They don't have any read method calls used by a rule's assumptions.
        --   XXX except where necessary to make AState work
        --   The rule uses map also doesn't have the method calls to write a
        --   rule's conflict-free condition wires (the method uses map does
        --   because AState needs it).
        --   This will probably change somehow when we have real runtime errors
        --
        asi_method_uses_map      :: MethodUsesMap,
        asi_rule_uses_map        :: RuleUsesMap,
  
        asi_resource_alloc_table :: RAT,
        asi_exclusive_rules_db   :: ExclusiveRulesDB,
        asi_sched_order          :: [SchedNode],
        asi_schedule             :: ASchedule,
        asi_sched_graph          :: [(SchedNode, [SchedNode])],
        asi_rule_relation_db     :: RuleRelationDB,
        asi_v_sched_info         :: VSchedInfo
      } deriving (Show)
  
  
  instance PPrint AScheduleInfo where
      pPrint d p asi =
          text "AScheduleInfo" $+$
          nest 2 (
              text "-- schedule" $+$
              pPrint d 0 (asi_schedule asi) $+$
              text "-- vschedinfo" $+$
              pPrint d 0 (asi_v_sched_info asi) $+$
              text "-- warnings" $+$
              (let ppWarn = vcat . map text . lines
               in  vcat (map (ppWarn . thd) (asi_warnings asi))) $+$
              text "-- method uses map" $+$
              pPrint d 0 (asi_method_uses_map asi) $+$
              text "-- rule uses map" $+$
              pPrint d 0 (asi_rule_uses_map asi) $+$
              text "-- resource allocation table" $+$
              pPrint d 0 (asi_resource_alloc_table asi)
              -- no dump of DBs, sched graph and order
              )
  
  
  -- ---------------
  
  -- When the scheduling stage aborts with an error, this data structure
  -- contains the available information up to that point (for debugging)
  --
  data AScheduleErrInfo = AScheduleErrInfo
      {
        -- Warnings during scheduling
        -- (position, tag, msg including position and tag)
        --
        asei_warnings             :: [(Position, String, String)],
  
        -- Errors during scheduling
        -- (position, tag, msg including position and tag)
        --
        asei_errors               :: [(Position, String, String)],
  
        -- These are computed initially, and therefore are always available:
  
        -- The method uses map and the rule uses map
        --   They don't have any read method calls used by a rule's assumptions.
        --   XXX except where necessary to make AState work
        --   The rule uses map also doesn't have the method calls to write a
        --   rule's conflict-free condition wires (the method uses map does
        --   because AState needs it).
        --   This will probably change somehow when we have real runtime errors
        --
        asei_method_uses_map      :: MethodUsesMap,
        asei_rule_uses_map        :: RuleUsesMap,
  
        -- The remaining fields may not be available.
        -- In order of computation:
        --
        asei_resource_alloc_table :: Maybe RAT,
        asei_exclusive_rules_db   :: Maybe ExclusiveRulesDB,
        asei_sched_order          :: Maybe [SchedNode],
        asei_schedule             :: Maybe ASchedule,
        asei_sched_graph          :: Maybe [(SchedNode, [SchedNode])],
        asei_rule_relation_db     :: Maybe RuleRelationDB,
        asei_v_sched_info         :: Maybe VSchedInfo
      } deriving (Show)
  
  
  instance PPrint AScheduleErrInfo where
      pPrint d p asei =
          text "AScheduleErrInfo" $+$
          nest 2 (
              text "-- schedule" $+$
              pPrint d 0 (asei_schedule asei) $+$
              text "-- vschedinfo" $+$
              pPrint d 0 (asei_v_sched_info asei) $+$
              text "-- warnings" $+$
              (let ppWarn = vcat . map text . lines
               in  vcat (map (ppWarn . thd) (asei_warnings asei))) $+$
              text "-- errors" $+$
              (let ppErr = vcat . map text . lines
               in  vcat (map (ppErr . thd) (asei_errors asei))) $+$
              text "-- method uses map" $+$
              pPrint d 0 (asei_method_uses_map asei) $+$
              text "-- rule uses map" $+$
              pPrint d 0 (asei_rule_uses_map asei) $+$
              text "-- resource allocation table" $+$
              pPrint d 0 (asei_resource_alloc_table asei)
              -- no dump of DBs, sched graph and order
              )
  
  
  -- ---------------
  
  -- A cache of what is known about whether rules are exclusive (post-scheduling)
  -- It can be queried for two pieces of information:
  -- * Are the CAN_FIRE signals for the rules disjoint?
  -- * Are the WILL_FIRE signals for the rules disjoint?
  --   (This is a superset which also takes into account rule executions
  --    that have been forced to be exclusive due to conflicts etc.)
  newtype ExclusiveRulesDB =
      ExclusiveRulesDB (M.Map ARuleId (S.Set ARuleId, S.Set ARuleId))
  
  -- Are the WILL_FIRE signals of the rules exclusive?
  -- (Used in Verilog backend for determining if a priority mux is needed.)
  -- Note: we check both the disjoint set and the exclusive set, since we
  -- do not make a redundant record of exclusivity when it is implied by
  -- disjointness.
  areRulesExclusive :: ExclusiveRulesDB -> ARuleId -> ARuleId -> Bool
  areRulesExclusive (ExclusiveRulesDB exclusive_fmap) r1 r2 =
      let (disj_set, excl_set) = M.findWithDefault (S.empty, S.empty) r1 exclusive_fmap
      in (S.member r2 disj_set) || (S.member r2 excl_set)
  
  -- Are the CAN_FIRE signals of the rules exclusive?
  -- (Used in Bluesim backend for short-circuiting the CF computation,
  -- particularly to avoid computing a CF which has changed due to the
  -- execution of a mutually exclusive rule -- for which no sched edge exists.)
  areRulesDisjoint :: ExclusiveRulesDB -> ARuleId -> ARuleId -> Bool
  areRulesDisjoint (ExclusiveRulesDB exclusive_fmap) r1 r2 =
      let (disj_set, _) = M.findWithDefault (S.empty, S.empty) r1 exclusive_fmap
      in  S.member r2 disj_set
  
  erdbToList :: ExclusiveRulesDB -> [(ARuleId,([ARuleId],[ARuleId]))]
  erdbToList (ExclusiveRulesDB exclusive_map) =
      let conv (r, (d_set, e_set)) = (r, (S.toList d_set, S.toList e_set))
      in  map conv (M.toList exclusive_map)
  
  erdbFromList :: [(ARuleId,([ARuleId],[ARuleId]))] -> ExclusiveRulesDB
  erdbFromList xs =
      let conv (r, (ds, es)) = (r, (S.fromList ds, S.fromList es))
      in  ExclusiveRulesDB (M.fromList (map conv xs))
  
  instance Show ExclusiveRulesDB where
      show erdb = show (erdbToList erdb)
  
  -- ---------------
  
  data SchedNode = Sched AId | Exec AId
    deriving (Eq, Show)
  
  -- comparing by name instead of the default ORD instance for Id
  -- makes the schedule order from the flattened graph stable.
  instance Ord SchedNode where
    compare (Sched _) (Exec _)  = LT
    compare (Exec _)  (Sched _) = GT
    compare (Sched x) (Sched y) = cmpIdByName x y
    compare (Exec x)  (Exec y)  = cmpIdByName x y
  
  instance PPrint SchedNode where
      pPrint d _ (Sched i) = text "Sched" <+> pPrint d 0 i
      pPrint d _ (Exec i) = text "Exec" <+> pPrint d 0 i
  
  getSchedNodeId :: SchedNode -> AId
  getSchedNodeId (Sched i) = i
  getSchedNodeId (Exec i) = i
  
  isSchedNode :: SchedNode -> Bool
  isSchedNode (Sched _) = True
  isSchedNode (Exec _) = False
  
  -- A SchedNode newtype wrapper for SchedNode for the cases
  -- where comparison performance is critical and stable ordering
  -- is not important.
  newtype FastSchedNode = FSN { unFSN :: SchedNode }
    deriving(Eq)
  
  instance Ord FastSchedNode where
    compare (FSN (Sched _)) (FSN (Exec _))  = LT
    compare (FSN (Exec _))  (FSN (Sched _)) = GT
    compare (FSN (Sched x)) (FSN (Sched y)) = compare x y
    compare (FSN (Exec x))  (FSN (Exec y))  = compare x y
  
  
  -- ---------------
  
  -- This structure represents information about pairs of rules:
  --   - If a pair is not in the set, then their predicates are not disjoint
  --   - If a pair is not in the map, then the rules have no conflicts
  --   - If a pair maps to a RuleRelationInfo value, then the breakdown
  --     of conflicts is given in the RuleRelationInfo structure.
  data RuleRelationDB =
      RuleRelationDB (S.Set (ARuleId,ARuleId))                  -- disjointness
                     (M.Map (ARuleId,ARuleId) RuleRelationInfo) -- conflicts
  
  data RuleRelationInfo = RuleRelationInfo { mCF :: Maybe Conflicts
                                           , mSC :: Maybe Conflicts
                                           , mRes :: Maybe Conflicts
                                           , mCycle :: Maybe Conflicts
                                           , mPragma :: Maybe Conflicts
                                           , mArb :: Maybe Conflicts
                                           -- XXX path and urgency info?
                                           } deriving (Eq,Show)
  
  defaultRuleRelationship :: RuleRelationInfo
  defaultRuleRelationship = RuleRelationInfo { mCF     = Nothing
                                             , mSC     = Nothing
                                             , mRes    = Nothing
                                             , mCycle  = Nothing
                                             , mPragma = Nothing
                                             , mArb    = Nothing
                                             }
  
  
  rrdbToList :: RuleRelationDB ->
                [((ARuleId,ARuleId),Bool,(Maybe RuleRelationInfo))]
  rrdbToList (RuleRelationDB dset cmap) =
      let all_pairs = dset `S.union` (M.keysSet cmap)
      in [ (k, k `S.member` dset, M.lookup k cmap) | k <- S.toList all_pairs ]
  
  rrdbFromList :: [((ARuleId,ARuleId),Bool,(Maybe RuleRelationInfo))] ->
                  RuleRelationDB
  rrdbFromList xs =
      let dset = S.fromList [ k | (k,True,_) <- xs ]
          cmap = M.fromList [ (k,rri) | (k,_,(Just rri)) <- xs ]
      in RuleRelationDB dset cmap
  
  instance Show RuleRelationDB where
      show rrdb = show (rrdbToList rrdb)
  
  getRuleRelation :: RuleRelationDB -> ARuleId -> ARuleId -> (Bool,RuleRelationInfo)
  getRuleRelation (RuleRelationDB dset cmap) r1 r2 =
      let disj = S.member (r1,r2) dset
          rri  = M.findWithDefault defaultRuleRelationship (r1,r2) cmap
      in (disj,rri)
  
  -- -----
  
  data Conflicts =
        CUse [(MethodId,MethodId)]
      | CCycle [ARuleId]
      | CMethodsBeforeRules
      | CUserEarliness Position
      | CUserAttribute Position
      | CUserPreempt Position
      | CResource MethodId
      | CArbitraryChoice
      | CFFuncArbitraryChoice
    deriving (Eq,Show)
  
  printConflicts :: Bool -> PDetail -> Conflicts -> Doc
  printConflicts use_pvprint d edge =
      let pfp :: (PVPrint a, PPrint a) => a -> Doc
          pfp = if (use_pvprint)
                then pvPrint d 0
                else pPrint d 0
      in  case (edge) of
              (CUse uses) ->
                  let meths = vcat [pfp m1 <+> text "vs." <+> pfp m2
                                       | (m1, m2) <- uses]
                  in  fsep [s2par "calls to", nest 2 meths]
              (CCycle cycle_rules) ->
                  let cycle = fsep (intersperse (text "->")
                                      [pfp r | r <- cycle_rules])
                  in  fsep [s2par "dropped cycle", nest 2 $ parens cycle]
              (CMethodsBeforeRules) ->
                  s2par "methods fire before rules"
              (CUserEarliness pos) ->
                  fsep [s2par "earliness attribute at", pfp pos]
              (CUserAttribute pos) ->
                  fsep [s2par "scheduling attribute at", pfp pos]
              (CUserPreempt pos) ->
                  fsep [s2par "preempt attribute at", pfp pos]
              (CResource m) -> fsep [s2par "resource limit on", pfp m]
              (CArbitraryChoice) ->
                  s2par "earliness order chosen by the compiler"
              (CFFuncArbitraryChoice) ->
                  s2par ("earliness order chosen by the compiler" ++
                         " (due to system task or foreign function use)")
  
  instance PPrint Conflicts where
      pPrint d p = printConflicts False d
  
  instance PVPrint Conflicts where
      pvPrint d p = printConflicts True d
  
  instance Hyper Conflicts where
      hyper (CUse uses) y = hyper uses y
      hyper (CCycle cycle_rules) y = hyper cycle_rules y
      hyper (CMethodsBeforeRules) y = y
      hyper (CUserEarliness pos) y = hyper pos y
      hyper (CUserAttribute pos) y = hyper pos y
      hyper (CUserPreempt pos) y = hyper pos y
      hyper (CResource m) y = hyper m y
      hyper (CArbitraryChoice) y = y
      hyper (CFFuncArbitraryChoice) y = y
  
  -- -----
  
  printRuleRelationInfo :: ARuleId -> ARuleId -> Bool -> RuleRelationInfo -> Doc
  printRuleRelationInfo rule1 rule2 isDisjoint
          (RuleRelationInfo mCF mSC mRes mCycle mPragma mArb) =
      let
          -- print a single conflict of a given type
          pp_conflict ctype Nothing =
              sep [text "no", text ctype, text "conflict"]
          pp_conflict ctype (Just c) =
              sep [text ctype, text "conflict:", pPrint PDReadable 0 c]
      in
          (text "Scheduling info for rules \"" <>
           pPrint PDReadable 0 rule1 <> text "\" and \"" <>
           pPrint PDReadable 0 rule2 <> text "\":")
          $+$
          sep [text "predicates",
               (if isDisjoint
                then text "are" else text "are not"),
                text "disjoint"]
          $+$
          nest 4 (pp_conflict "<>" mCF $+$
                  pp_conflict "<" mSC $+$
                  pp_conflict "resource" mRes $+$
                  pp_conflict "cycle" mCycle $+$
                  pp_conflict "attribute" mPragma)
                  -- XXX mArb
  
  -- -----
  
  unionRuleRelationInfo :: RuleRelationInfo -> RuleRelationInfo ->
                           RuleRelationInfo
  unionRuleRelationInfo rri1 rri2 =
      let
          unionMaybeWith fn Nothing   m2        = m2
          unionMaybeWith fn m1        Nothing   = m1
          unionMaybeWith fn (Just v1) (Just v2) = Just (fn v1 v2)
  
          unionCUse (CUse us1) (CUse us2) = CUse (us1 ++ us2)
          unionCUse c1 c2 = internalError ("unionCUse: " ++ ppReadable (c1, c2))
  
          -- XXX the info in c2 is lost
          unionCResource c1@(CResource _) (CResource _) = c1
          unionCResource c1 c2 = internalError ("unionCResource: " ++
                                                ppReadable (c1, c2))
  
          -- XXX the info in c2 is lost
          unionCCycle c1@(CCycle _) (CCycle _) = c1
          unionCCycle c1 c2 = internalError ("unionCCycle: " ++
                                             ppReadable (c1, c2))
  
          -- XXX the info in c2 is lost
          unionPragma c1 c2 = c1
  
          -- XXX Since some info may be lost, make sure that any reason
          -- XXX othet than FFunc bias trumps FFunc bias
          unionArb CArbitraryChoice _ = CArbitraryChoice
          unionArb _ CArbitraryChoice = CArbitraryChoice
          unionArb c1 c2 = c1
  
      in
         RuleRelationInfo {
             mCF = unionMaybeWith unionCUse (mCF rri1) (mCF rri2),
             mSC = unionMaybeWith unionCUse (mSC rri1) (mSC rri2),
             mRes = unionMaybeWith unionCResource (mRes rri1) (mRes rri2),
             mCycle = unionMaybeWith unionCCycle (mCycle rri1) (mCycle rri2),
             mPragma = unionMaybeWith unionPragma (mPragma rri1) (mPragma rri2),
             mArb = unionMaybeWith unionArb (mArb rri1) (mArb rri2)
         }
  
  -- ---------------
  