From e2643d137eb8dd77f1efdfdae845739654f2a02f Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Fri, 10 Jul 2020 15:32:33 -0500 Subject: [PATCH 1/4] [feature] RAPL change: using both time windows. --- hsnrm/hsnrm/src/NRM/Node/Sysfs.hs | 11 ++- hsnrm/hsnrm/src/NRM/Node/Sysfs/Internal.hs | 71 +++++++++++------- hsnrm/hsnrm/src/NRM/State.hs | 75 ++++++++----------- hsnrm/hsnrm/src/NRM/Types/Topology/Package.hs | 30 ++++++-- 4 files changed, 110 insertions(+), 77 deletions(-) diff --git a/hsnrm/hsnrm/src/NRM/Node/Sysfs.hs b/hsnrm/hsnrm/src/NRM/Node/Sysfs.hs index dd1d784..f5323f1 100644 --- a/hsnrm/hsnrm/src/NRM/Node/Sysfs.hs +++ b/hsnrm/hsnrm/src/NRM/Node/Sysfs.hs @@ -9,7 +9,8 @@ module NRM.Node.Sysfs RAPLDirs, getDefaultRAPLDirs, measureRAPLDirs, - setRAPLPowercap, + setRAPLPowercapAllWindows, + setRAPLPowercapByWindow, -- * Hwmon getDefaultHwmonDirs, @@ -18,6 +19,7 @@ where import LMap.Map as LM import NRM.Node.Sysfs.Internal +import NRM.Types.Units import Protolude -- | Retreives package RAPL directories at the default location. @@ -29,8 +31,11 @@ measureRAPLDirs :: RAPLDirs -> IO [RAPLMeasurement] measureRAPLDirs (RAPLDirs rapldirpaths) = catMaybes <$> for (LM.elems rapldirpaths) (measureRAPLDir . path) -- | Setting powercap values. -setRAPLPowercap :: FilePath -> RAPLCommand -> IO () -setRAPLPowercap = applyRAPLPcap +setRAPLPowercapAllWindows :: RAPLConfig -> Power -> IO () +setRAPLPowercapAllWindows = setRAPLPowercapByWindow [ShortTerm, LongTerm] + +setRAPLPowercapByWindow :: Set Window -> RAPLConfig -> Power -> IO () +setRAPLPowercapByWindow ws cfg p = applyRAPLPcap cfg (RAPLCommand {powercap = p, windows = ws}) -- | Retreives coretemp Hwmon directories at the default location. getDefaultHwmonDirs :: FilePath -> IO HwmonDirs diff --git a/hsnrm/hsnrm/src/NRM/Node/Sysfs/Internal.hs b/hsnrm/hsnrm/src/NRM/Node/Sysfs/Internal.hs index 1339801..adfe437 100644 --- a/hsnrm/hsnrm/src/NRM/Node/Sysfs/Internal.hs +++ b/hsnrm/hsnrm/src/NRM/Node/Sysfs/Internal.hs @@ -15,6 +15,7 @@ module NRM.Node.Sysfs.Internal RAPLCommand (..), MaxPower (..), MaxEnergy (..), + Window (..), getRAPLDirs, measureRAPLDir, readRAPLConfiguration, @@ -32,9 +33,11 @@ module NRM.Node.Sysfs.Internal ) where +import Control.Lens hiding (re) import Control.Monad.Trans.Maybe import Data.Aeson import Data.Data +import Data.Generics.Labels () import Data.MessagePack import Data.Metrology.Show () import Data.Text as T (length, lines) @@ -55,7 +58,7 @@ newtype HwmonDirs = HwmonDirs [HwmonDir] -- | Maximum RAPL power constraint. newtype MaxPower = MaxPower Power - deriving (Show) + deriving (Show, Generic) -- | Maximum RAPL energy measurement. newtype MaxEnergy = MaxEnergy Energy @@ -63,17 +66,18 @@ newtype MaxEnergy = MaxEnergy Energy -- | RAPL energy measurement newtype MeasuredEnergy = MeasuredEnergy Energy - deriving (Show) + deriving (Show, Generic) -- | Hwmon directory newtype HwmonDir = HwmonDir FilePath - deriving (Show) + deriving (Show, Generic) -newtype RAPLCommand +data RAPLCommand = RAPLCommand - { powercap :: Power + { powercap :: Power, + windows :: Set Window } - deriving (Show) + deriving (Show, Generic) -- | RAPL directory data RAPLDir @@ -88,10 +92,12 @@ data RAPLConfig = RAPLConfig { configPath :: FilePath, enabled :: Bool, - constraintShortTerm :: RAPLConstraint, - constraintLongTerm :: RAPLConstraint + constraintShortTermMaxPowerUw :: RAPLConstraint, + constraintLongTermMaxPowerUw :: RAPLConstraint, + shortTermID :: Int, + longTermID :: Int } - deriving (Show) + deriving (Show, Generic) -- | RAPL power constraint data RAPLConstraint @@ -99,7 +105,7 @@ data RAPLConstraint { timeWindow :: Time, maxPower :: MaxPower } - deriving (Show) + deriving (Show, Generic) -- | RAPL power measurement data RAPLMeasurement @@ -107,25 +113,31 @@ data RAPLMeasurement { measurementPath :: FilePath, energy :: Energy } - deriving (Show) + deriving (Show, Generic) + +data Window = ShortTerm | LongTerm deriving (Show, Generic, Ord, Eq) -- | Read configuration from a RAPL directory. readRAPLConfiguration :: FilePath -> IO (Maybe RAPLConfig) readRAPLConfiguration fp = runMaybeT $ do enabled <- (== ("1" :: Text)) <$> maybeTReadLine (fp <> "/enabled") - name0 <- maybeTReadLine (fp <> "/constraint_0_name") - name1 <- maybeTReadLine (fp <> "/constraint_1_name") - constraint0 <- parseConstraint 0 - constraint1 <- parseConstraint 1 - case (name0, name1) of - ("short_term", "long_term") -> - return $ - RAPLConfig fp enabled constraint0 constraint1 - ("long_term", "short_term") -> - return $ - RAPLConfig fp enabled constraint1 constraint0 - _ -> mzero + names <- forOf both (0 :: Int, 1 :: Int) $ \i -> + maybeTReadLine (fp <> "/constraint_" <> show i <> "_name") + maxConstraints <- forOf both (0, 1) parseConstraint + let flippedC = case names of + ("short_term", "long_term") -> False + ("long_term", "short_term") -> True + _ -> panic "rapl constraint name files contain unexpected values" + (shortTerm, longTerm) = (if flippedC then swap else identity) maxConstraints + return RAPLConfig + { configPath = fp, + enabled = enabled, + constraintShortTermMaxPowerUw = shortTerm, + constraintLongTermMaxPowerUw = longTerm, + shortTermID = fromEnum flippedC, + longTermID = fromEnum (not flippedC) + } where parseConstraint :: Int -> MaybeT IO RAPLConstraint parseConstraint i = do @@ -166,11 +178,18 @@ processRAPLFolder fp = rx = [re|package-([0-9]+)(/\S+)?|] -- | Applies powercap commands. -applyRAPLPcap :: FilePath -> RAPLCommand -> IO () -applyRAPLPcap filePath (RAPLCommand cap) = +applyRAPLPcap :: RAPLConfig -> RAPLCommand -> IO () +applyRAPLPcap raplCfg (RAPLCommand cap windows) = for_ windows $ \w -> writeFile - (filePath <> "/constraint_1_power_limit_uw") + (configPath raplCfg <> toS (windowToPath w)) (show . (floor :: Double -> Int) $ fromuW cap) + where + windowToPath :: Window -> Text + windowToPath w = "/constraint_" <> show (raplCfg ^. getID w) <> "_power_limit_uw" + getID :: Window -> Getting Int RAPLConfig Int + getID = \case + ShortTerm -> #shortTermID + LongTerm -> #longTermID -- | Lists available rapl directories. getRAPLDirs :: FilePath -> IO (Maybe RAPLDirs) diff --git a/hsnrm/hsnrm/src/NRM/State.hs b/hsnrm/hsnrm/src/NRM/State.hs index 15fbe10..e1e0d26 100644 --- a/hsnrm/hsnrm/src/NRM/State.hs +++ b/hsnrm/hsnrm/src/NRM/State.hs @@ -41,7 +41,6 @@ import NRM.Types.Process import NRM.Types.Slice import NRM.Types.State as NRMState import NRM.Types.Topology -import NRM.Types.Topology.Package import NRM.Types.Units import NRM.Types.UpstreamClient import Protolude @@ -50,22 +49,39 @@ import Protolude initialState :: Cfg -> Time -> IO NRMState initialState c time = do hwl <- getHwlocData - let packages' = - LM.fromList $ - (,Package {rapl = Nothing}) - <$> selectPackageIDs hwl - packages <- - raplCfg c & \case - Nothing -> return packages' - Just raplc -> - getDefaultRAPLDirs (toS $ Cfg.raplPath raplc) >>= \case - Just (RAPLDirs rapldirs) -> - return $ - Protolude.foldl - (goRAPL (referencePower raplc) (raplActions raplc)) - packages' + let packages' = LM.fromList $ selectPackageIDs hwl <&> (,Package {rapl = Nothing}) + packages <- Cfg.raplCfg c & \case + Nothing -> return packages' + Just raplc -> do + defaultDirs <- getDefaultRAPLDirs (toS $ Cfg.raplPath raplc) + defaultDirs & \case + Nothing -> return packages' + Just (RAPLDirs rapldirs) -> do + configs <- forM rapldirs (readRAPLConfiguration . path) + return $ + packages' + &~ for_ (LM.toList rapldirs) - Nothing -> return packages' + ( \(pkgid, raplDir) -> + at pkgid . _Just . #rapl . _Just + %= execState + ( do + #frequency .= hz 3 + #raplCfg + .= fromMaybe + (panic "initialState: internal raplCfg error 1") + ( fromMaybe + (panic "initialState: internal raplCfg error 1") + (LM.lookup pkgid configs) + ) + #maxEnergyCounterValue .= raplDir ^. #maxEnergy + #max .= watts 150 + #defaultPower .= referencePower raplc + #discreteChoices .= raplActions raplc + #lastRead .= Nothing + #history .= MemBuffer.empty + ) + ) return NRMState { controller = controlCfg c & \case FixedCommand _ -> Nothing @@ -89,33 +105,6 @@ initialState c time = do extraStaticPassiveSensors = Cfg.extraStaticPassiveSensors c <&> concretizeExtraPassiveSensor (activeSensorFrequency c), .. } - where - goRAPL :: - Power -> - [Power] -> - LM.Map PackageID Package -> - (PackageID, RAPLDir) -> - LM.Map PackageID Package - goRAPL defP defA m (pkgid, RAPLDir {..}) = - LM.lookup pkgid m & \case - Nothing -> m - Just oldPackage -> - LM.insert - pkgid - ( oldPackage - { rapl = Just $ Rapl - { frequency = hz 3, - raplPath = path, - maxEnergyCounterValue = maxEnergy, - max = watts 150, - defaultPower = defP, - discreteChoices = defA, - lastRead = Nothing, - history = MemBuffer.empty - } - } - ) - m concretizeExtraPassiveSensor :: Frequency -> Cfg.ExtraPassiveSensor -> NRMState.ExtraPassiveSensor concretizeExtraPassiveSensor f x = NRMState.ExtraPassiveSensor diff --git a/hsnrm/hsnrm/src/NRM/Types/Topology/Package.hs b/hsnrm/hsnrm/src/NRM/Types/Topology/Package.hs index 6b83929..bc6a957 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Topology/Package.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Topology/Package.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | -- Module : NRM.Types.Topology.Package -- Copyright : (c) UChicago Argonne, 2019 @@ -29,7 +31,7 @@ import Protolude hiding (max, to) -- | Record containing all information about a CPU Package. data Rapl = Rapl - { raplPath :: FilePath, + { raplCfg :: RAPLConfig, max :: Power, maxEnergyCounterValue :: Energy, frequency :: Frequency, @@ -60,11 +62,11 @@ instance HasLensMap (PackageID, Package) ActuatorKey Actuator where ) ) where - getter (NRM.Types.Topology.Package.Rapl path _maxPower _maxCounter _freq discreteChoices defaultPower _last _history) = + getter (NRM.Types.Topology.Package.Rapl raplCfg _maxPower _maxCounter _freq discreteChoices defaultPower _last _history) = Actuator { actions = discreteChoices <&> fromWatts, referenceAction = fromWatts defaultPower, - go = setRAPLPowercap path . RAPLCommand . watts + go = setRAPLPowercapAllWindows raplCfg . watts } setter :: Rapl -> Actuator -> Rapl setter rapl (Actuator actions referenceAction _go) = @@ -86,7 +88,7 @@ instance HasLensMap (PackageID, Package) S.PassiveSensorKey S.PassiveSensor wher ) ) where - getter (NRM.Types.Topology.Package.Rapl path maxPower maxCounter freq _discreteChoices _defaultPower lastRead history) = + getter (NRM.Types.Topology.Package.Rapl cfg maxPower maxCounter freq _discreteChoices _defaultPower lastRead history) = S.PassiveSensor { passiveMeta = S.SensorMeta { tags = [S.Minimize, S.Power, S.Rapl], @@ -96,7 +98,7 @@ instance HasLensMap (PackageID, Package) S.PassiveSensorKey S.PassiveSensor wher cumulative = S.CumulativeWithCapacity (fromJoules maxCounter) }, frequency = freq, - perform = measureRAPLDir path <&> fmap (fromJoules . energy) + perform = measureRAPLDir (configPath cfg) <&> fmap (fromJoules . energy) } setter :: Rapl -> S.PassiveSensor -> Rapl setter rapl passiveSensor = @@ -104,3 +106,21 @@ instance HasLensMap (PackageID, Package) S.PassiveSensorKey S.PassiveSensor wher #max .= passiveSensor ^. S._meta . #range . to (watts . sup) #history .= passiveSensor ^. S._meta . #lastReferenceMeasurements #lastRead .= (fmap joules <$> passiveSensor ^. S._meta . #last) + +deriving instance MessagePack RAPLConfig + +deriving instance ToJSON RAPLConfig + +deriving instance FromJSON RAPLConfig + +deriving instance MessagePack RAPLConstraint + +deriving instance ToJSON RAPLConstraint + +deriving instance FromJSON RAPLConstraint + +deriving instance MessagePack MaxPower + +deriving instance ToJSON MaxPower + +deriving instance FromJSON MaxPower -- GitLab From b9d0e8739fe51c43efc303804af07fb8a9cce9ff Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Tue, 14 Jul 2020 10:59:59 -0500 Subject: [PATCH 2/4] [fix] Fix rapl discovery bug. --- hsnrm/common.dhall | 2 - hsnrm/hsnrm/hsnrm.cabal | 3 +- hsnrm/hsnrm/src/NRM/Behavior.hs | 3 +- hsnrm/hsnrm/src/NRM/State.hs | 97 ++++++++++++++++-------------- hsnrm/hsnrm/src/NRM/Types/State.hs | 11 ++-- 5 files changed, 62 insertions(+), 54 deletions(-) diff --git a/hsnrm/common.dhall b/hsnrm/common.dhall index 7bfcddb..6ee8b29 100644 --- a/hsnrm/common.dhall +++ b/hsnrm/common.dhall @@ -142,7 +142,6 @@ let deps = , zeromq4-conduit = nobound "zeromq4-conduit" , zeromq4-haskell = nobound "zeromq4-haskell" , uuid = nobound "uuid" - , editor-open = nobound "editor-open" , text = nobound "text" , dhall = nobound "dhall" , bytestring = nobound "bytestring" @@ -317,7 +316,6 @@ let libdep = , deps.brick , deps.filepath , deps.lens - , deps.editor-open ] in { defexts = defexts diff --git a/hsnrm/hsnrm/hsnrm.cabal b/hsnrm/hsnrm/hsnrm.cabal index d0c4e97..635d4a7 100644 --- a/hsnrm/hsnrm/hsnrm.cabal +++ b/hsnrm/hsnrm/hsnrm.cabal @@ -193,6 +193,5 @@ library mtl -any, brick -any, filepath -any, - lens -any, - editor-open -any + lens -any diff --git a/hsnrm/hsnrm/src/NRM/Behavior.hs b/hsnrm/hsnrm/src/NRM/Behavior.hs index fbab997..a05e3e5 100644 --- a/hsnrm/hsnrm/src/NRM/Behavior.hs +++ b/hsnrm/hsnrm/src/NRM/Behavior.hs @@ -27,6 +27,7 @@ import Control.Lens hiding (_Unwrapped, _Wrapped, to) import Control.Monad.Trans.RWS.Lazy (RWST) import Data.Generics.Labels () import Data.Generics.Wrapped +import Data.Map as Map import LMap.Map as LM import LensMap.Core as LensMap import qualified NRM.CPD as NRMCPD @@ -119,7 +120,7 @@ nrm _callTime (Req clientid msg) = UReq.ReqCPD _ -> rep clientid . URep.RepCPD $ NRMCPD.toCPD (controlCfg c) st UReq.ReqSliceList _ -> - rep clientid . URep.RepList . URep.SliceList . LM.toList $ slices st + rep clientid . URep.RepList . URep.SliceList . Map.toList $ slices st UReq.ReqGetState _ -> rep clientid $ URep.RepGetState st UReq.ReqGetConfig _ -> rep clientid . URep.RepGetConfig $ URep.GetConfig c UReq.ReqRun UReq.Run {..} -> do diff --git a/hsnrm/hsnrm/src/NRM/State.hs b/hsnrm/hsnrm/src/NRM/State.hs index e1e0d26..edefde1 100644 --- a/hsnrm/hsnrm/src/NRM/State.hs +++ b/hsnrm/hsnrm/src/NRM/State.hs @@ -25,6 +25,8 @@ module NRM.State where import Control.Lens +import Data.Map as M +import Data.Map.Merge.Lazy import LMap.Map as LM import NRM.Node.Hwloc import NRM.Node.Sysfs @@ -41,6 +43,7 @@ import NRM.Types.Process import NRM.Types.Slice import NRM.Types.State as NRMState import NRM.Types.Topology +import NRM.Types.Topology.Package import NRM.Types.Units import NRM.Types.UpstreamClient import Protolude @@ -49,44 +52,43 @@ import Protolude initialState :: Cfg -> Time -> IO NRMState initialState c time = do hwl <- getHwlocData - let packages' = LM.fromList $ selectPackageIDs hwl <&> (,Package {rapl = Nothing}) - packages <- Cfg.raplCfg c & \case - Nothing -> return packages' - Just raplc -> do - defaultDirs <- getDefaultRAPLDirs (toS $ Cfg.raplPath raplc) - defaultDirs & \case - Nothing -> return packages' - Just (RAPLDirs rapldirs) -> do - configs <- forM rapldirs (readRAPLConfiguration . path) - return $ - packages' - &~ for_ - (LM.toList rapldirs) - ( \(pkgid, raplDir) -> - at pkgid . _Just . #rapl . _Just - %= execState - ( do - #frequency .= hz 3 - #raplCfg - .= fromMaybe - (panic "initialState: internal raplCfg error 1") - ( fromMaybe - (panic "initialState: internal raplCfg error 1") - (LM.lookup pkgid configs) - ) - #maxEnergyCounterValue .= raplDir ^. #maxEnergy - #max .= watts 150 - #defaultPower .= referencePower raplc - #discreteChoices .= raplActions raplc - #lastRead .= Nothing - #history .= MemBuffer.empty - ) - ) + let packages' = M.fromList $ selectPackageIDs hwl <&> (,Package {rapl = Nothing}) + packages <- fmap fromDataMap $ + Cfg.raplCfg c & \case + Nothing -> pure packages' + Just raplc -> do + defaultDirs <- getDefaultRAPLDirs (toS $ Cfg.raplPath raplc) + defaultDirs & \case + Nothing -> pure packages' + Just (RAPLDirs rapldirs) -> do + configs <- forM rapldirs (readRAPLConfiguration . path) + let fullMap = + merge + dropMissing + dropMissing + (zipWithMaybeMatched (\_ mrapl rapldir -> (,rapldir) <$> mrapl)) + (toDataMap configs) + (toDataMap rapldirs) + updater _pkgid package (packageRaplConfig, packageRaplDir) = + package + { rapl = Just Rapl + { frequency = hz 3, + raplCfg = packageRaplConfig, + maxEnergyCounterValue = packageRaplDir ^. #maxEnergy, + max = watts 150, + defaultPower = referencePower raplc, + discreteChoices = raplActions raplc, + lastRead = Nothing, + history = MemBuffer.empty + } + } + newPkgs = merge preserveMissing dropMissing (zipWithMatched updater) packages' fullMap + return newPkgs return NRMState { controller = controlCfg c & \case FixedCommand _ -> Nothing ccfg -> Just $ initialController time (minimumControlInterval ccfg) [], - slices = LM.fromList [], + slices = M.fromList [], pus = LM.fromList $ (,PU) <$> selectPUIDs hwl, cores = LM.fromList $ (,Core) <$> selectCoreIDs hwl, dummyRuntime = @@ -101,12 +103,19 @@ initialState c time = do if nodeos c then Just NodeosRuntime else Nothing, - extraStaticActuators = Cfg.extraStaticActuators c <&> NRMState.ExtraActuator, - extraStaticPassiveSensors = Cfg.extraStaticPassiveSensors c <&> concretizeExtraPassiveSensor (activeSensorFrequency c), + extraStaticActuators = + Cfg.extraStaticActuators c + <&> NRMState.ExtraActuator, + extraStaticPassiveSensors = + Cfg.extraStaticPassiveSensors c + <&> concretizeExtraPassiveSensor (activeSensorFrequency c), .. } -concretizeExtraPassiveSensor :: Frequency -> Cfg.ExtraPassiveSensor -> NRMState.ExtraPassiveSensor +concretizeExtraPassiveSensor :: + Frequency -> + Cfg.ExtraPassiveSensor -> + NRMState.ExtraPassiveSensor concretizeExtraPassiveSensor f x = NRMState.ExtraPassiveSensor { NRMState.extraPassiveSensor = x, NRMState.history = [], @@ -117,8 +126,8 @@ concretizeExtraPassiveSensor f x = NRMState.ExtraPassiveSensor -- | Removes a slice from the state removeSlice :: SliceID -> NRMState -> (Maybe Slice, NRMState) removeSlice sliceID st = - ( LM.lookup sliceID (slices st), - st {slices = LM.delete sliceID (slices st)} + ( M.lookup sliceID (slices st), + st {slices = M.delete sliceID (slices st)} ) -- | Result annotation for command removal from the state. @@ -167,10 +176,10 @@ createSlice :: NRMState -> NRMState createSlice sliceID st = - case LM.lookup sliceID (slices st) of + case M.lookup sliceID (slices st) of Nothing -> st {slices = slices'} where - slices' = LM.insert sliceID emptySlice (slices st) + slices' = M.insert sliceID emptySlice (slices st) Just _ -> st -- | Registers an awaiting command in an existing slice @@ -181,7 +190,7 @@ registerAwaiting :: NRMState -> NRMState registerAwaiting cmdID cmdValue sliceID st = - st {slices = LM.update f sliceID (slices st)} + st {slices = M.update f sliceID (slices st)} where f c = Just $ c {awaiting = LM.insert cmdID cmdValue (awaiting c)} @@ -201,7 +210,7 @@ registerLaunched cmdID pid st = Right ( st { slices = - LM.insert + M.insert sliceID ( slice { cmds = @@ -225,7 +234,7 @@ registerFailed :: Maybe (NRMState, SliceID, Slice, CmdCore) registerFailed cmdID st = LM.lookup cmdID (awaitingCmdIDMap st) <&> \(cmdCore, sliceID, slice) -> - ( st {slices = LM.update f sliceID (slices st)}, + ( st {slices = M.update f sliceID (slices st)}, sliceID, slice, cmdCore diff --git a/hsnrm/hsnrm/src/NRM/Types/State.hs b/hsnrm/hsnrm/src/NRM/Types/State.hs index bff9a80..4aa8929 100644 --- a/hsnrm/hsnrm/src/NRM/Types/State.hs +++ b/hsnrm/hsnrm/src/NRM/Types/State.hs @@ -36,6 +36,7 @@ import Data.Coerce import Data.Data import Data.Generics.Labels () import Data.JSON.Schema +import Data.Map as Map import Data.MessagePack import Data.Scientific import qualified LMap.Map as LM @@ -65,7 +66,7 @@ data NRMState { pus :: LM.Map PUID PU, cores :: LM.Map CoreID Core, packages :: LM.Map PackageID Package, - slices :: LM.Map SliceID Slice, + slices :: Map SliceID Slice, dummyRuntime :: Maybe DummyRuntime, singularityRuntime :: Maybe SingularityRuntime, nodeosRuntime :: Maybe NodeosRuntime, @@ -197,18 +198,18 @@ showSliceList l = -- | Renders a textual view of running slices showSlices :: NRMState -> Text showSlices NRMState {..} = - showSliceList $ LM.toList slices + showSliceList $ Map.toList slices -- | Insert a slice in the state (with replace) insertSlice :: SliceID -> Slice -> NRMState -> NRMState -insertSlice sliceID slice s = s {slices = LM.insert sliceID slice (slices s)} +insertSlice sliceID slice s = s {slices = Map.insert sliceID slice (slices s)} lookupProcess :: ProcessID -> NRMState -> Maybe (CmdID, Cmd, SliceID, Slice) lookupProcess cmdID st = LM.lookup cmdID (pidMap st) -- | NRM state map view by ProcessID. pidMap :: NRMState -> LM.Map ProcessID (CmdID, Cmd, SliceID, Slice) -pidMap s = mconcat $ LM.toList (slices s) <&> mkMap +pidMap s = mconcat $ Map.toList (slices s) <&> mkMap where mkMap :: forall c. (c, Slice) -> LM.Map ProcessID (CmdID, Cmd, c, Slice) mkMap x@(_, c) = @@ -236,7 +237,7 @@ mkCmdIDMap :: (Slice -> LM.Map k a) -> NRMState -> LM.Map k (a, SliceID, Slice) -mkCmdIDMap accessor s = mconcat $ LM.toList (slices s) <&> mkMap +mkCmdIDMap accessor s = mconcat $ Map.toList (slices s) <&> mkMap where mkMap x@(_, c) = LM.fromList $ -- GitLab From 22b26d12b3b869e0a2eee3ae625b594122efa264 Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Tue, 14 Jul 2020 12:37:03 -0500 Subject: [PATCH 3/4] [refactor] General refactoring of custom map injectors to lenses. --- hsnrm/hsnrm/src/NRM/Behavior.hs | 9 ++-- hsnrm/hsnrm/src/NRM/State.hs | 69 ++++++++++-------------------- hsnrm/hsnrm/src/NRM/Types/Slice.hs | 5 --- hsnrm/hsnrm/src/NRM/Types/State.hs | 6 --- 4 files changed, 29 insertions(+), 60 deletions(-) diff --git a/hsnrm/hsnrm/src/NRM/Behavior.hs b/hsnrm/hsnrm/src/NRM/Behavior.hs index a05e3e5..c627bfb 100644 --- a/hsnrm/hsnrm/src/NRM/Behavior.hs +++ b/hsnrm/hsnrm/src/NRM/Behavior.hs @@ -27,7 +27,7 @@ import Control.Lens hiding (_Unwrapped, _Wrapped, to) import Control.Monad.Trans.RWS.Lazy (RWST) import Data.Generics.Labels () import Data.Generics.Wrapped -import Data.Map as Map +import Data.Map as M import LMap.Map as LM import LensMap.Core as LensMap import qualified NRM.CPD as NRMCPD @@ -120,7 +120,7 @@ nrm _callTime (Req clientid msg) = UReq.ReqCPD _ -> rep clientid . URep.RepCPD $ NRMCPD.toCPD (controlCfg c) st UReq.ReqSliceList _ -> - rep clientid . URep.RepList . URep.SliceList . Map.toList $ slices st + rep clientid . URep.RepList . URep.SliceList . M.toList $ slices st UReq.ReqGetState _ -> rep clientid $ URep.RepGetState st UReq.ReqGetConfig _ -> rep clientid . URep.RepGetConfig $ URep.GetConfig c UReq.ReqRun UReq.Run {..} -> do @@ -209,7 +209,10 @@ nrm _callTime (ChildDied pid exitcode) = do ) pub $ UPub.PubEnd cmdID Nothing -> log "Error during command removal from NRM state" - Nothing -> put $ insertSlice sliceID (Ct.insertCmd cmdID cmd {processState = newPstate} slice) st + Nothing -> + put $ + st & #slices . at sliceID + ?~ (slice & #cmds . at cmdID ?~ cmd {processState = newPstate}) nrm callTime (DownstreamEvent clientid msg) = nrmDownstreamEvent callTime clientid msg <&> ( \case diff --git a/hsnrm/hsnrm/src/NRM/State.hs b/hsnrm/hsnrm/src/NRM/State.hs index edefde1..e49539a 100644 --- a/hsnrm/hsnrm/src/NRM/State.hs +++ b/hsnrm/hsnrm/src/NRM/State.hs @@ -3,9 +3,7 @@ -- License : BSD3 -- Maintainer : fre@freux.fr module NRM.State - ( -- Module : NRM.State - - -- * Initial state + ( -- * Initial state initialState, -- * Creation/Registration @@ -13,9 +11,6 @@ module NRM.State registerAwaiting, registerFailed, registerLaunched, - --unRegisterDownstreamThreadClient, - - -- * Removal -- ** Command removal CmdKey (..), @@ -82,7 +77,13 @@ initialState c time = do history = MemBuffer.empty } } - newPkgs = merge preserveMissing dropMissing (zipWithMatched updater) packages' fullMap + newPkgs = + merge + preserveMissing + dropMissing + (zipWithMatched updater) + packages' + fullMap return newPkgs return NRMState { controller = controlCfg c & \case @@ -164,10 +165,7 @@ removeCmd key st = case key of cmdID, cmd, sliceID, - insertSlice - sliceID - (slice {cmds = LM.delete cmdID (cmds slice)}) - st + st & #slices . ix sliceID . #cmds %~ sans cmdID ) -- | Registers a slice if not already tracked in the state, and returns the new state. @@ -176,26 +174,14 @@ createSlice :: NRMState -> NRMState createSlice sliceID st = - case M.lookup sliceID (slices st) of - Nothing -> st {slices = slices'} - where - slices' = M.insert sliceID emptySlice (slices st) + st ^. #slices . at sliceID & \case + Nothing -> st & #slices . at sliceID ?~ emptySlice Just _ -> st -- | Registers an awaiting command in an existing slice -registerAwaiting :: - CmdID -> - CmdCore -> - SliceID -> - NRMState -> - NRMState -registerAwaiting cmdID cmdValue sliceID st = - st {slices = M.update f sliceID (slices st)} - where - f c = Just $ c {awaiting = LM.insert cmdID cmdValue (awaiting c)} - -{-{ awaiting = LM.delete cmdID (awaiting slice)-} -{-, cmds = LM.insert cmdID c (cmds slice)-} +registerAwaiting :: CmdID -> CmdCore -> SliceID -> NRMState -> NRMState +registerAwaiting cmdID cmdValue sliceID = + #slices . ix sliceID . #awaiting . at cmdID ?~ cmdValue -- | Turns an awaiting command to a launched one. registerLaunched :: @@ -208,21 +194,11 @@ registerLaunched cmdID pid st = Nothing -> Left "No such awaiting command." Just (cmdCore, sliceID, slice) -> Right - ( st - { slices = - M.insert - sliceID - ( slice - { cmds = - LM.insert - cmdID - (registerPID cmdCore pid) - (cmds slice), - awaiting = LM.delete cmdID (awaiting slice) - } - ) - (slices st) - }, + ( st & #slices . at sliceID + ?~ ( slice &~ do + #cmds . at cmdID ?= registerPID cmdCore pid + #awaiting %= sans cmdID + ), sliceID, upstreamClientID cmdCore ) @@ -233,14 +209,15 @@ registerFailed :: NRMState -> Maybe (NRMState, SliceID, Slice, CmdCore) registerFailed cmdID st = - LM.lookup cmdID (awaitingCmdIDMap st) <&> \(cmdCore, sliceID, slice) -> - ( st {slices = M.update f sliceID (slices st)}, + awaitingCmdIDMap st ^. at cmdID <&> \(cmdCore, sliceID, slice) -> + ( st & #slices . at sliceID %~ (>>= f), sliceID, slice, cmdCore ) where + f :: Slice -> Maybe Slice f c = if LM.null (cmds c) then Nothing - else Just $ c {awaiting = LM.delete cmdID (awaiting c)} + else Just $ c & #awaiting %~ sans cmdID diff --git a/hsnrm/hsnrm/src/NRM/Types/Slice.hs b/hsnrm/hsnrm/src/NRM/Types/Slice.hs index 9367602..590324a 100644 --- a/hsnrm/hsnrm/src/NRM/Types/Slice.hs +++ b/hsnrm/hsnrm/src/NRM/Types/Slice.hs @@ -8,7 +8,6 @@ module NRM.Types.Slice ( Slice (..), emptySlice, - insertCmd, SliceID (..), nextSliceID, parseSliceID, @@ -49,10 +48,6 @@ emptySlice = Slice awaiting = LM.fromList [] } --- | Insert a running command in a slice (with replace) -insertCmd :: CmdID -> Cmd -> Slice -> Slice -insertCmd cmdID cmd slice = slice {cmds = LM.insert cmdID cmd (cmds slice)} - data SliceID = SliceID U.UUID | Name Text deriving (Show, Eq, Ord, Generic, FromJSONKey, ToJSONKey, MessagePack) deriving (ToJSON, FromJSON, JSONSchema) via GenericJSON SliceID diff --git a/hsnrm/hsnrm/src/NRM/Types/State.hs b/hsnrm/hsnrm/src/NRM/Types/State.hs index 4aa8929..53d0a71 100644 --- a/hsnrm/hsnrm/src/NRM/Types/State.hs +++ b/hsnrm/hsnrm/src/NRM/Types/State.hs @@ -8,9 +8,6 @@ module NRM.Types.State ExtraActuator (..), ExtraPassiveSensor (..), - -- * Insertion - insertSlice, - -- * Useful maps cmdIDMap, pidMap, @@ -200,9 +197,6 @@ showSlices :: NRMState -> Text showSlices NRMState {..} = showSliceList $ Map.toList slices --- | Insert a slice in the state (with replace) -insertSlice :: SliceID -> Slice -> NRMState -> NRMState -insertSlice sliceID slice s = s {slices = Map.insert sliceID slice (slices s)} lookupProcess :: ProcessID -> NRMState -> Maybe (CmdID, Cmd, SliceID, Slice) lookupProcess cmdID st = LM.lookup cmdID (pidMap st) -- GitLab From b9de2bd00b484219cdea9905c86f082103d7723f Mon Sep 17 00:00:00 2001 From: Valentin Reis Date: Tue, 14 Jul 2020 13:08:13 -0500 Subject: [PATCH 4/4] [syntax] ormolu pass --- hsnrm/hsnrm/src/NRM/Types/State.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/hsnrm/hsnrm/src/NRM/Types/State.hs b/hsnrm/hsnrm/src/NRM/Types/State.hs index 53d0a71..e760a32 100644 --- a/hsnrm/hsnrm/src/NRM/Types/State.hs +++ b/hsnrm/hsnrm/src/NRM/Types/State.hs @@ -33,7 +33,7 @@ import Data.Coerce import Data.Data import Data.Generics.Labels () import Data.JSON.Schema -import Data.Map as Map +import Data.Map as M import Data.MessagePack import Data.Scientific import qualified LMap.Map as LM @@ -195,15 +195,14 @@ showSliceList l = -- | Renders a textual view of running slices showSlices :: NRMState -> Text showSlices NRMState {..} = - showSliceList $ Map.toList slices - + showSliceList $ M.toList slices lookupProcess :: ProcessID -> NRMState -> Maybe (CmdID, Cmd, SliceID, Slice) lookupProcess cmdID st = LM.lookup cmdID (pidMap st) -- | NRM state map view by ProcessID. pidMap :: NRMState -> LM.Map ProcessID (CmdID, Cmd, SliceID, Slice) -pidMap s = mconcat $ Map.toList (slices s) <&> mkMap +pidMap s = mconcat $ M.toList (slices s) <&> mkMap where mkMap :: forall c. (c, Slice) -> LM.Map ProcessID (CmdID, Cmd, c, Slice) mkMap x@(_, c) = @@ -231,7 +230,7 @@ mkCmdIDMap :: (Slice -> LM.Map k a) -> NRMState -> LM.Map k (a, SliceID, Slice) -mkCmdIDMap accessor s = mconcat $ Map.toList (slices s) <&> mkMap +mkCmdIDMap accessor s = mconcat $ M.toList (slices s) <&> mkMap where mkMap x@(_, c) = LM.fromList $ -- GitLab