content: module AAddSchedAssumps(aAddSchedAssumps, aAddCFConditionWires) where
  
  import CSyntax
  import SymTab
  import TypeCheck(topExpr)
  import CType
  import Type
  import qualified TIMonad as TIM(runTI)
  import Flags(Flags, showElabProgress)
  import IConv(iConvExpr)
  import ASyntax
  import ASyntaxUtil
  import ISyntax
  import ISyntaxUtil hiding (noReset)
  import IExpandUtils(HExpr, HeapData)
  import IExpand(iExpand)
  import ISplitIf(iSplitIf)
  import AConv(aConv)
  import ASchedule(extractCFPairsSP, errAction)
  import AUses(MethodId(..), MethodUsers, UniqueUse(..), MethodUsesList, ucTrue,
               mergeUseMapData, extractCondition, ruleMethodUsesToUUs)
  import AScheduleInfo(AScheduleInfo(..))
  import VModInfo(VMethodConflictInfo, vSched)
  import SchedInfo(SchedInfo(..), MethodConflictInfo(..))
  import PreIds
  import qualified Data.Map as M
  import qualified Data.Set as S
  import PPrint
  import Pragma(ASchedulePragma)
  import Error(internalError, ErrMsg(..), showErrorList, ErrorHandle)
  import Id
  import Position(noPosition)
  import Util(unzipWith, ordPairBy)
  import Util(mapSnd)
  
  -- | Method name mapped to condition of usage
  type MethodCondMap = M.Map AMethodId AExpr
  
  -- | State elements to the map of method condition usage
  type OMCondMap = M.Map AId (MethodCondMap)
  
  -- | Rules to the objects whose methods they use (with conditions)
  type RuleMethodMap = M.Map ARuleId (OMCondMap)
  
  -- | We only need the method conflict info
  type OSchedMap = M.Map AId VMethodConflictInfo
  
  buildOMCondMap :: MethodUsesList -> OMCondMap
  buildOMCondMap uses = M.fromListWith (M.unionWith aOr) omuses'
    where uses'   = mapSnd buildUseConditions uses
          omuses  = [(o, (m, c)) | (MethodId o m, c) <- uses' ]
          omuses' :: [(AId, MethodCondMap)]
          omuses' = mapSnd (uncurry M.singleton) omuses
  
  buildUseConditions :: [UniqueUse] -> AExpr
  buildUseConditions = aOrs . (map extractCondition)
  
  uqWGet, uqWSet :: Id
  uqWGet = unQualId idWGet
  uqWSet = unQualId idWSet
  
  aAddSchedAssumps :: APackage -> ASchedule -> AScheduleInfo -> (APackage, AScheduleInfo)
  aAddSchedAssumps apkg schedule schedinfo = (apkg'', schedinfo')
    where ruleMap :: M.Map ARuleId Integer
          ruleMap = M.fromList (zip (asch_rev_exec_order schedule) [0..])
          err i = internalError ("AAddAssumps - unknown rule: " ++ ppReadable i)
          get i = M.findWithDefault (err i) i ruleMap
          -- use reverse order because we want the last rule to come first
          -- since later rules will do the checking
          cmpRule r1 r2 = compare (get r1) (get r2)
          pragmas = apkg_schedule_pragmas apkg
          ruleMethodMap :: RuleMethodMap
          ruleMethodMap = M.map (buildOMCondMap .
                                 ruleMethodUsesToUUs . snd)
                                (asi_rule_uses_map schedinfo)
          instSchedMap :: OSchedMap
          instSchedMap = M.fromList
                           [(n, methodConflictInfo (vSched vmi))
                               | AVInst { avi_vname = n, avi_vmi = vmi }  <- insts ]
          insts = apkg_state_instances apkg
          apkg' = apkg
          doCFAssumps = addCFAssumps pragmas ruleMethodMap instSchedMap cmpRule
          (rs', newUseInfos) = unzip (map doCFAssumps (apkg_rules apkg'))
          newUseInfo = concat newUseInfos
          apkg'' = apkg' { apkg_rules = rs' }
          newRatEntries = map useInfoToRatEntry newUseInfo
          newUseMapEntries = map useInfoToUseMapEntry newUseInfo
          newRat = asi_resource_alloc_table schedinfo ++ newRatEntries
          newUseMap = M.unionWith (mergeUseMapData)
                        (asi_method_uses_map schedinfo)
                        (M.fromListWith (mergeUseMapData) newUseMapEntries)
          schedinfo' = schedinfo { asi_method_uses_map = newUseMap,
                                   asi_resource_alloc_table = newRat }
  
  
  addCFAssumps :: [ASchedulePragma] -> RuleMethodMap -> OSchedMap
               -> (ARuleId -> ARuleId -> Ordering) -> ARule
               -> (ARule, [(ARuleId, MethodId, UniqueUse)])
  addCFAssumps pragmas ruleMethodMap instSchedMap cmpRule = proc_rule
    where cf_pairs = extractCFPairsSP pragmas
          sorted_cf_pairs = map (ordPairBy cmpRule) cf_pairs
          check_pairs = [ (a, [b]) | (a, b) <- sorted_cf_pairs ]
          check_map = M.fromListWith (++) check_pairs
          proc_rule r@(ARule { arule_id = rid }) =
            case (M.lookup rid check_map) of
              Nothing -> (r, [])
              Just rids ->
               let (new_assumps, useinfos) = unzip (mkCFAssumps ruleMethodMap instSchedMap rid rids)
               in (r { arule_assumps = arule_assumps r ++ new_assumps }, useinfos)
  
  mkCFAssumps :: RuleMethodMap -> OSchedMap -> ARuleId -> [ARuleId]
              -> [(AAssumption, (ARuleId, MethodId, UniqueUse))]
  mkCFAssumps ruleMethodMap instSchedMap rid rids = concatMap (mkCFAssump ruleMethodMap instSchedMap rid) rids
  
  mkCFAssump :: RuleMethodMap -> OSchedMap -> ARuleId -> ARuleId
             -> [(AAssumption, (ARuleId, MethodId, UniqueUse))]
  mkCFAssump ruleMethodMap instSchedMap r1 r2 = concat $ M.elems overlapMap
    where
      omcm_r1 = getOMCond r1
      omcm_r2 = getOMCond r2
      r1_s = getIdString r1
      r2_s = getIdString r2
      r2_WF = aBoolVar (mkIdWillFire r2)
      getOMCond r = case (M.lookup r ruleMethodMap) of
                      Nothing -> err r
                      Just m -> m
      err r = internalError ("AAddSchedAssumps: no OMCondMap: " ++ ppReadable r)
      overlapMap = M.intersectionWithKey checkMethodCalls omcm_r1 omcm_r2
      -- methods are ok if they appear in the CF list in either order
      -- or if they appear in the SB or SBR list in the correct execution order
      -- remember r2 executes before r1!
      -- r1 is the "second" rule, to which we attach scheduling logic
      isOKPair sched p@(m1, m2) = p `elem` sCF sched || p2 `elem` sCF sched ||
                                  p2 `elem` sSB sched ||
                                  p2 `elem` sSBR sched
         where p2 = (m2, m1)
      checkMethodCalls o methCondMap1 methCondMap2 = newAssumps
        where
          o_s = getIdString o
          sched = case (M.lookup o instSchedMap) of
                    Nothing -> internalError ("AddSchedAssumps: no VSchedInfo: " ++ ppReadable o)
                    Just sched -> sched
          -- convert to lists to do a cross-product
          newAssumps = [ (assump, useinfo) | (m1, c1) <- M.toList methCondMap1,
                                             (m2, _) <- M.toList methCondMap2,
                                             not (isOKPair sched (m1, m2)),
                                             let obj = mkCFCondWireInstId r2 o m2,
                                             -- extracts m2's condition from the wire
                                             -- include the WILL_FIRE because we don't check the tag bit
                                             let c2 = AMethCall aTBool obj uqWGet [],
                                             let c = aAnds [r2_WF, c1, c2],
                                             let m1_s = getIdString m1,
                                             let m2_s = getIdString m2,
                                             let cferr = (getPosition r1,
                                                          EConflictFreeRulesFail (r1_s, r2_s) o_s (m1_s, m2_s)),
                                             let str = showErrorList [cferr],
                                             let a = [errAction str],
                                             let assump = AAssumption c a,
                                             -- XXX ucTrue is conservative, but we don't use the UseCond anyway
                                             let useinfo = (r1, MethodId obj uqWGet, UUExpr c2 ucTrue)]
  
  -- | Rule to the methods it uses (with conditions)
  type RuleMethCondMap = M.Map ARuleId [(MethodId, AExpr)]
  
  aAddCFConditionWires :: ErrorHandle -> SymTab -> M.Map AId HExpr -> Flags ->
                          APackage -> AScheduleInfo ->
                          IO (APackage, AScheduleInfo)
  aAddCFConditionWires errh r alldefs flags apkg schedinfo =
     if (null cfPairs) then
      -- when tracing other stages, the unnecessary output from getRWireInstFn is
      -- annoying, so don't call it if not necessary
      return (apkg, schedinfo)
     else do
      rWireInstFn <- getRWireInstFn errh flags r alldefs
      let mkWireInst r (MethodId obj meth)= rWireInstFn (mkCFCondWireInstId r obj meth)
      let newWires = concatMap (buildWireInsts ruleMethodMap mkWireInst) (S.toList cfRules)
      return (apkg { apkg_rules = rules',
                     apkg_state_instances = oldState ++ newWires },
              schedinfo { asi_resource_alloc_table = newRat,
                          asi_method_uses_map = newUseMap })
  
    where pragmas = apkg_schedule_pragmas apkg
          cfPairs = extractCFPairsSP pragmas
          cfRules = S.fromList ((map fst cfPairs) ++ (map snd cfPairs))
          ruleMethodMap :: RuleMethCondMap
          ruleMethodMap = M.map (buildMethCondList .
                                 ruleMethodUsesToUUs . snd)
                                (asi_rule_uses_map schedinfo)
          oldState = apkg_state_instances apkg
          (rules', newUseInfos) = unzipWith (addCFCondWires cfRules ruleMethodMap) (apkg_rules apkg)
          newUseInfo = concat newUseInfos
          newRatEntries = map useInfoToRatEntry newUseInfo
          newUseMapEntries = map useInfoToUseMapEntry newUseInfo
          newRat = asi_resource_alloc_table schedinfo ++ newRatEntries
          newUseMap = M.unionWith (mergeUseMapData)
                        (asi_method_uses_map schedinfo)
                        (M.fromListWith (mergeUseMapData) newUseMapEntries)
  
  useInfoToRatEntry :: (ARuleId, MethodId, UniqueUse)
                    -> (MethodId, [(UniqueUse, Integer)])
  useInfoToRatEntry (_,mid,u) = (mid, [(u, 1)])
  
  useInfoToUseMapEntry :: (ARuleId, MethodId, UniqueUse)
                       -> (MethodId, [(UniqueUse, MethodUsers)])
  useInfoToUseMapEntry (rid, mid, u) = (mid, [(u, ([],[rid],[]))])
  
  buildMethCondList :: MethodUsesList -> [(MethodId, AExpr)]
  buildMethCondList uses = M.toList (M.fromListWith aOr uses')
    where uses'   = mapSnd buildUseConditions uses
  
  -- | We need a function that will take an id and make us the RWire instance we want.
  -- It's a little more complicated than you might expect
  getRWireInstFn :: ErrorHandle -> Flags -> SymTab ->
                    M.Map AId HExpr -> IO (Id -> AVInst)
  getRWireInstFn errh flags r alldefs = do
    let blobT = TAp tModule (TAp tVRWireN (cTNum 1 noPosition))
    case fst $ (TIM.runTI flags False r (topExpr blobT (CVar idVmkRWire1))) of
      Left errs -> internalError (ppReadable errs)
      Right (_,e') -> do
        let iexpr = iConvExpr errh flags r alldefs e'
        let def :: IDef HeapData
            def = IDef id_x (iGetType iexpr) iexpr []
        let flags' = flags { showElabProgress = False }
        iepkg <- iExpand errh flags' r alldefs False [] def
        rwire_pkg <- aConv errh [] flags (iSplitIf flags iepkg)
        case (apkg_state_instances rwire_pkg) of
          [rwire_inst] ->
            let params = take 1 (avi_iargs rwire_inst) ++ [nullClock, noReset]
                rwire_inst' = rwire_inst { avi_iargs = params }
            in return (\i -> rwire_inst' { avi_vname = i })
          is -> internalError ("getRWireBlob: " ++ ppReadable is)
  
  -- | A clock that never ticks but is always ready
  nullClock :: AExpr
  nullClock = ASClock aTClock (AClock aFalse aTrue)
  
  noReset :: AExpr
  noReset = aNoReset
  
  buildWireInsts :: RuleMethCondMap -> (ARuleId -> MethodId -> AVInst) -> ARuleId -> [AVInst]
  buildWireInsts ruleMethCondMap mkWireInst r = map (mkWireInst r) methIds
    where methIds = case (M.lookup r ruleMethCondMap) of
                      Just ms -> map fst ms
                      Nothing -> internalError ("AAddSchedAssumps.buildWireInsts missing rule: " ++
                                               ppReadable r ++ ppReadable ruleMethCondMap)
  
  -- | Add wire-setting actions and return new RAT entries
  addCFCondWires :: S.Set ARuleId -> RuleMethCondMap -> ARule -> (ARule, [(ARuleId, MethodId, UniqueUse)])
  addCFCondWires cfRules ruleMethCondMap r | rid `S.member` cfRules =
    case (M.lookup rid ruleMethCondMap) of
      Just ms ->
        let (newActions, newUseInfo) = unzip $ [(a, (rid, mid, UUAction a)) | (MethodId o m, c) <- ms,
                                                                              let obj = mkCFCondWireInstId rid o m,
                                                                              let mid = MethodId obj uqWSet,
                                                                              let a   = ACall obj uqWSet [aTrue,c]]
        in (r { arule_actions = arule_actions r ++ newActions }, newUseInfo)
      Nothing -> internalError ("AAddAchedAssumps.addCFCondWires missing rule: " ++
                                ppReadable r ++ ppReadable ruleMethCondMap)
    where rid = arule_id r
  addCFCondWires cfRules ruleMethCondMap r = (r, [])
  