content: {-# LANGUAGE CPP #-}
  module SimPackage(
                    -- types
                    SimSystem(..),
                    PackageMap,
                    InstModMap,
  
                    SimPackage(..),
                    DefMap,
                    AVInstMap,
                    MethodOrderMap,
  
                    SimSchedule(..),
                    SchedNode(..), getSchedNodeId,
                    DisjointRulesDB,
  
                    -- utilities
                    findPkg,
                    findSubPkg,
                    findDef,
                    findAVInst,
                    findMethodOrderSet,
                    findInstMod,
  
                    getSimPackageInputs,
                    getPortInfo,
  
                    exclRulesDBToDisjRulesDB
                   ) where
  
  #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804)
  import Prelude hiding ((<>))
  #endif
  
  import Eval
  import ErrorUtil(internalError)
  import PPrint
  import Id
  import IdPrint
  import VModInfo
  import Wires
  import Pragma
  import ASyntax
  import ASyntaxUtil
  import AScheduleInfo
  import ABinUtil(InstModMap,ABinMap)
  import SimDomainInfo
  import ForeignFunctions(ForeignFuncMap)
  
  import Control.Monad(when)
  import Data.List(groupBy)
  import qualified Data.Map as M
  import qualified Data.Set as S
  
  -- import Debug.Trace
  
  -- This is a map from AId to the ADef which defines the value for that AId
  type DefMap = M.Map AId ADef
  
  -- This is a map from AId of an instantiated submodule to its information
  type AVInstMap = M.Map AId AVInst
  
  -- map from submodule instance name to a set of pairs of method names
  -- where the first method must execute before the second
  -- (when executed sequentially for atomic execution in one action)
  type MethodOrderMap = M.Map AId (S.Set (AId, AId))
  
  -- map from package Ids to SimPackages
  type PackageMap = M.Map Id SimPackage
  
  data SimSystem =
    SimSystem { ssys_packages    :: PackageMap
              , ssys_schedules   :: [SimSchedule]
              , ssys_top         :: Id  -- name of top package
              , ssys_instmap     :: InstModMap
              , ssys_ffuncmap    :: ForeignFuncMap
              , ssys_filemap     :: ABinMap
              , ssys_default_clk :: Maybe String
              , ssys_default_rst :: Maybe String
              }
    deriving (Show)
  
  data SimPackage =
    SimPackage { sp_name :: Id
               , sp_is_wrapped :: Bool -- carryover
               , sp_version :: String -- from ABin
               , sp_pps :: [PProp] -- from ABinModInfo
               , sp_size_params :: [AId] -- carryover
               , sp_inputs :: [AAbstractInput] -- carryover
               , sp_clock_domains :: [AClockDomain] -- carryover?
               , sp_external_wires :: VWireInfo -- carryover?
               , sp_reset_list :: [(ResetId, AReset)] -- carryover?
               , sp_state_instances :: AVInstMap
               -- inst and mod name of noinline functions as modules
               , sp_noinline_instances :: [(String,String)]
               , sp_method_order_map :: MethodOrderMap
               , sp_local_defs :: DefMap
               , sp_rules :: [ARule]
               , sp_interface :: [AIFace]
               , sp_schedule :: AScheduleInfo
               , sp_pathinfo :: VPathInfo
               -- Assign numbers to the gates in a module, for codegen
               , sp_gate_map :: [AExpr]  -- order is [0..]
               -- if these are handled earlier, then not needed here:
               , sp_schedule_pragmas :: [ASchedulePragma] -- carryover?
               -- could include user-comments (generated in RTL)
               }
    deriving (Show)
  
  -- Trimmed version of ExclusiveRulesDB, to hold just the disjoint info
  type DisjointRulesDB = M.Map ARuleId (S.Set ARuleId)
  
  data SimSchedule = SimSchedule
      { ss_clock :: AClock
      , ss_posedge :: Bool
      , ss_schedule :: ASchedule
      , ss_disjoint_rules_db :: DisjointRulesDB
      , ss_sched_graph :: [(SchedNode, [SchedNode])]
      , ss_sched_order :: [SchedNode]
      , ss_domain_info_map :: DomainInfoMap
      , ss_early_rules :: [ARuleId]
      }
    deriving (Show)
  
  -- -----
  
  instance PPrint SimSystem where
      pPrint d _ ssys =
          (text "SimSystem") $+$
          text "-- Packages" $+$
          pPrint d 0 (ssys_packages ssys) $+$
          text "-- Schedules" $+$
          pPrint d 0 (ssys_schedules ssys) $+$
          text "-- Top module" $+$
          ppId d (ssys_top ssys)
  
  instance PPrint SimPackage where
      pPrint d _ spkg =
          (text "SimPackage" <+> ppId d (sp_name spkg) <>
           if (sp_is_wrapped spkg) then text " -- function" else empty) $+$
          text (sp_version spkg) $+$
          text "-- SimPackage parameters" $+$
          pPrint d 0 (sp_size_params spkg) $+$
          text "-- SimPackage arguments" $+$
          foldr ($+$) (text "") (map (pPrint d 0) (sp_inputs spkg)) $+$
          text "-- SimPackage wire info" $+$
          pPrint d 0 (sp_external_wires spkg) $+$
          text "-- SimPackage clock domains" $+$
          pPrint d 0 (sp_clock_domains spkg) $+$
          text "-- SimPackage resets" $+$
          pPrint d 0 (sp_reset_list spkg) $+$
          text "-- SP state elements" $+$
          foldr ($+$) (text "")
              (map (pPrint d 0) (M.elems (sp_state_instances spkg))) $+$
          text "-- SP noinline elements" $+$
          foldr ($+$) (text "")
              (map (pPrint d 0) (sp_noinline_instances spkg)) $+$
          text "-- SP method order map" $+$
          ppMethodOrderMap d (sp_method_order_map spkg) $+$
          text "-- SP local definitions" $+$
          foldr ($+$) (text "")
              (map (pPrint d 0) (M.elems (sp_local_defs spkg))) $+$
          text "-- SP rules" $+$
          foldr ($+$) (text "") (map (pPrint d 0) (sp_rules spkg)) $+$
          text "-- SP scheduling pragmas" $+$
          pPrint d 0 (sp_schedule_pragmas spkg) $+$
          text "-- SP interface" $+$
          foldr ($+$) empty
              [(text "-- SP  sp_interface def" <+> pPrint d 0 (sp_name spkg)) $+$
               pPrint d 0 i | i <- sp_interface spkg] $+$
          text "-- SP schedule" $+$
          pPrint d 0 (asi_schedule (sp_schedule spkg)) $+$
          text "-- SP path info" $+$
          pPrint d 0 (sp_pathinfo spkg) $+$
          text "-- SP gate map" $+$
          pPrint d 0 (sp_gate_map spkg)
  
  ppMethodOrderMap :: PDetail -> MethodOrderMap -> Doc
  ppMethodOrderMap d mmap =
      let ppOneInst (i, mset) = ppId d i $+$
                                nest 4 (foldr ($+$) (text "")
                                            (map (pPrint d 0) (S.toList mset)))
      in  foldr ($+$) (text "")
              (map ppOneInst (M.toList mmap))
  
  
  instance PPrint SimSchedule where
      pPrint d _ simschedule =
          let label = text "SimSchedule"
              edge = text (if (ss_posedge simschedule)
                           then "posedge"
                           else "negedge")
              domain = text (show (ss_clock simschedule))
          in label $+$
             (nest 2 ((text "-- clock")    $+$
                      edge <+> domain      $+$
                      (text "-- schedule") $+$
                      pPrint d 0 (ss_schedule simschedule) $+$
                      (text "-- seq graph") $+$
                      pPrint d 0 (ss_sched_graph simschedule) $+$
                      (text "-- seq order") $+$
                      pPrint d 0 (ss_sched_order simschedule) $+$
                      (text "-- domain info map") $+$
                      pPrint d 0 (ss_domain_info_map simschedule) $+$
                      (text "-- early rules") $+$
                      pPrint d 0 (ss_early_rules simschedule)
                      ))
  
  -- -----
  
  instance Hyper SimSystem where
      hyper ssim y = hyper3 (ssys_packages ssim)
                            (ssys_schedules ssim)
                            (ssys_top ssim)
                            y
  
  instance Eq SimPackage where
      sp1 == sp2 =
          (
           -- for the scheduleinfo, just check the schedule
           (asi_schedule (sp_schedule sp1) ==
               asi_schedule (sp_schedule sp2)) &&
           -- for the rest, use equality
           (sp_name sp1 == sp_name sp2) &&
           (sp_is_wrapped sp1 == sp_is_wrapped sp2) &&
           (sp_version sp1 == sp_version sp2) &&
           (sp_size_params sp1 == sp_size_params sp2) &&
           (sp_inputs sp1 == sp_inputs sp2) &&
           (sp_clock_domains sp1 == sp_clock_domains sp2) &&
           (sp_external_wires sp1 == sp_external_wires sp2) &&
           (sp_reset_list sp1 == sp_reset_list sp2) &&
           (sp_state_instances sp1 == sp_state_instances sp2) &&
           (sp_noinline_instances sp1 == sp_noinline_instances sp2) &&
           (sp_method_order_map sp1 == sp_method_order_map sp2) &&
           (sp_local_defs sp1 == sp_local_defs sp2) &&
           (sp_rules sp1 == sp_rules sp2) &&
           (sp_interface sp1 == sp_interface sp2) &&
           (sp_pathinfo sp1 == sp_pathinfo sp2) &&
           (sp_gate_map sp1 == sp_gate_map sp2) &&
           (sp_schedule_pragmas sp1 == sp_schedule_pragmas sp2)
          )
  
  instance Hyper SimPackage where
      hyper spkg y = (spkg == spkg) `seq` y
  
  instance Hyper SimSchedule where
      hyper ssched y =
          --- we only care about certain fields
          (
              (ss_clock ssched    == ss_clock ssched)
           && (ss_posedge ssched  == ss_posedge ssched)
           && (ss_schedule ssched == ss_schedule ssched)
           && (ss_sched_graph ssched == ss_sched_graph ssched)
           && (ss_sched_order ssched == ss_sched_order ssched)
           && (ss_domain_info_map ssched == ss_domain_info_map ssched)
           && (ss_early_rules ssched == ss_early_rules ssched)
          ) `seq` y
  
  -- -----
  
  instance (Ord a, AExprs b) => AExprs (M.Map a b) where
      mapAExprs f m = let (ks,vs) = unzip (M.toList m)
                          vs'     = mapAExprs f vs
                      in M.fromList (zip ks vs')
      -- monadic
      mapMAExprs f m =
          do let (ks,vs) = unzip (M.toList m)
             vs' <- mapMAExprs f vs
             return $ M.fromList (zip ks vs')
      -- find
      findAExprs f m = findAExprs f (M.elems m)
  
  instance AExprs SimPackage where
      mapAExprs f pack = pack {
          sp_interface = mapAExprs f (sp_interface pack),
          sp_rules = mapAExprs f (sp_rules pack),
          sp_state_instances = mapAExprs f (sp_state_instances pack),
          sp_local_defs = mapAExprs f (sp_local_defs pack) }
      -- monadic
      mapMAExprs f pack@(SimPackage { sp_interface = ifc,
                                      sp_rules = rs,
                                      sp_state_instances = insts,
                                      sp_local_defs = defs })
          = do ifc' <- mapMAExprs f ifc
               rs' <- mapMAExprs f rs
               insts' <- mapMAExprs f insts
               defs' <- mapMAExprs f defs
               return (pack { sp_interface = ifc',
                              sp_rules = rs',
                              sp_state_instances = insts',
                              sp_local_defs = defs' })
      -- find
      findAExprs f pack =
          findAExprs f (sp_interface pack) ++
          findAExprs f (sp_rules pack) ++
          findAExprs f (sp_state_instances pack) ++
          findAExprs f (sp_local_defs pack)
  
  -- -----
  
  -- Utilities
  
  findPkg :: PackageMap -> Id -> SimPackage
  findPkg pkg_map id =
      case M.lookup id pkg_map of
        Just pkg -> pkg
        Nothing  -> internalError ("SimPackage.findPkg: cannot find " ++
                                     ppReadable id)
  
  findSubPkg :: SimSystem -> SimPackage -> AId -> Maybe SimPackage
  findSubPkg ss parent path =
    let segments = filter (/=".") $ groupBy (\x y -> x /= '.' && y /= '.') (getIdString path)
    in findIt parent (map mk_homeless_id segments)
    where findIt p []     = Just p
          findIt p (x:xs) = let avi      = findAVInst (sp_state_instances p) x
                                mod_name = vName_to_id (vName (avi_vmi avi))
                                sub      = M.lookup mod_name (ssys_packages ss)
                            in case sub of
                                 (Just s) -> findIt s xs
                                 Nothing  -> Nothing
  
  findDef :: DefMap -> AId -> ADef
  findDef def_map id =
      case M.lookup id def_map of
          Just def -> def
          Nothing  -> internalError ("SimPackage.findDef: cannot find " ++
                                     ppReadable id)
  
  findAVInst :: AVInstMap -> AId -> AVInst
  findAVInst avinst_map id =
      case M.lookup id avinst_map of
          Just avi -> avi
          Nothing -> internalError ("SimPackage.findAVInst: cannot find " ++
                                    ppReadable id)
  
  findMethodOrderSet :: MethodOrderMap -> AId -> S.Set (AId, AId)
  findMethodOrderSet mmap id =
      case M.lookup id mmap of
          Just mset -> mset
          Nothing -> internalError ("SimPackage.findMethodOrderSet: " ++
                                    "cannot find " ++ ppReadable id)
  
  findInstMod :: InstModMap -> String -> String
  findInstMod inst_map inst =
      case M.lookup inst inst_map of
          Just mod -> mod
          Nothing -> internalError ("SimPackage.findInstMod: cannot find " ++
                                    ppReadable inst)
  
  -- -----
  
  -- XXX This wouldn't be needed if we called "getAPackageInputs" on
  -- XXX the APackage and stored the result in SimPackage
  getSimPackageInputs :: SimPackage -> [(AAbstractInput, VArgInfo)]
  getSimPackageInputs spkg =
      let
          -- get the two fields
          inputs = sp_inputs spkg
          arginfos = wArgs (sp_external_wires spkg)
  
          -- check that they are the same length
          inputs_length = length (sp_inputs spkg)
          arginfos_length = length arginfos
  
          args_with_info = zip inputs arginfos
      in
          if (inputs_length /= arginfos_length)
          then internalError ("getSimPackageInputs: " ++
                              "length inputs != length arginfos: " ++
                              ppReadable (inputs, arginfos))
          else args_with_info
  
  -- -----
  
  getPortInfo :: [PProp] -> AIFace
              -> Maybe (AId, (Maybe VName, [(AType,AId,VName)], Maybe (AType,VName), Bool, [AId]))
  getPortInfo pps aif =
      let name = aIfaceName aif
          vfi  = aif_fieldinfo aif
          en   = do e <- vf_enable vfi
                    -- always enabled implies enabled when ready
                    when (isEnWhenRdy pps name) (fail "no enable port")
                    return (fst e)
          args = aIfaceArgs aif
          ps   = map fst (vf_inputs vfi)
          ins  = [ (t,i,vn) | ((i,t),vn) <- zip args ps ]
          rt   = aIfaceResType aif
          ret  = case (vf_output vfi) of
                   (Just (vn,_)) -> Just (rt,vn)
                   Nothing       -> Nothing
          isAction = case aif of
                       (AIAction {})      -> True
                       (AIActionValue {}) -> True
                       otherwise          -> False
          rules = map aRuleName (aIfaceRules aif)
      in case vfi of
           (Method {}) -> Just (name, (en, ins, ret, isAction, rules))
           otherwise   -> Nothing
  
  -- -----
  
  exclRulesDBToDisjRulesDB :: ExclusiveRulesDB -> DisjointRulesDB
  exclRulesDBToDisjRulesDB (ExclusiveRulesDB emap) =
      let e_edges = M.toList emap
          convEdge (r,(ds,es)) = (r, ds)
          d_edges = map convEdge e_edges
      in  M.fromList d_edges
  
  -- -----
  