root/hiersort/sim/Config.hs

-- | Config.hs
-- Configuration parameters, all at once.
--
-- Copytight (C) 2007, 2008 Serguey Zefirov
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 3, or (at your option)
-- any later version.
-- See file COPYING or visit http://www.gnu.org/licenses for details.

module Config(
                 Config(..)
                ,NodeConfig(..)
                ,getHierParams
                ,getProcessorChanWidth
                ,getHierProcWidth
                ,parseCommandLine
                ,readTaskParam
        ) where


import Data.Char
import qualified Data.Map as M
import Data.Maybe
import System.Environment
import System.Exit
import Control.Monad

import InterfaceTypes

-------------------------------------------------------------------------------
-- Data and defaults declaration.


data Config = Config {
                -- Runner parameters.
                 cfgDebug                       :: Bool
                -- Processor instantiating parameters.
                ,cfgProcMaxThreads              :: Int  -- max threads served
                ,cfgProcParThreads              :: Int  -- parallel threads in one cycle
                ,cfgProcShedulePolicy           :: ProcShedulingPolicy
                ,cfgProcOutWidth                :: Int  -- processor output width.
                -- Matcher parameters.
                ,cfgProcMatcherSize             :: Int
                ,cfgProcMatcherForceUp          :: Int
                ,cfgProcMatcherDnWidth          :: Int
                -- Up buffer parameters.
                ,cfgUpBufMaxLen                 :: Int  -- upstream buffer size
                -- Presorter parameters.
                ,cfgPresorterMaxLen             :: Int  -- presorterarable filter size
                -- Run parameters.
                ,cfgMaxWait                     :: Integer      -- max number of clocks to wait
                -- Task parameters.
                ,cfgTaskSettings                :: M.Map String String
                -- Hierarchy parameters.
                ,cfgHierDepth                   :: Int
                ,cfgHierBaseSortSize            :: Int
                ,cfgHierBaseSortHeight          :: Int
                ,cfgHierSortSizeInc             :: Maybe Double
                ,cfgHierSortSizeMul             :: Double
                ,cfgHierSortForceUpRatio        :: Double
                ,cfgHierSortHeightInc           :: Maybe Double
                ,cfgHierSortHeightMul           :: Double
                -- width
                ,cfgHierBaseProcChanWidth       :: Int
                ,cfgHierChanWidthInc            :: Double
                ,cfgHierChanPresortUpWidthInc   :: Double
        }
        deriving Show

-- Default config.
defConfig = Config {
#ifndef DEBUG
                 cfgDebug                = False
#else
                 cfgDebug                = True
#endif
                ,cfgProcMaxThreads       = 1
                ,cfgProcParThreads       = 1
                ,cfgProcShedulePolicy    = SheduleWindow
                ,cfgUpBufMaxLen          = 6
                ,cfgPresorterMaxLen      = 6
                ,cfgHierDepth            = 0
                ,cfgProcMatcherSize      = 4
                ,cfgProcMatcherForceUp   = 4
                ,cfgProcMatcherDnWidth   = 1
                ,cfgProcOutWidth         = 4
                ,cfgMaxWait              = 1000000000
                ,cfgTaskSettings         = M.empty
                ,cfgHierBaseSortSize     = 16
                ,cfgHierBaseSortHeight   = 4
                ,cfgHierSortSizeInc      = Nothing
                ,cfgHierSortSizeMul      = 1.05
                ,cfgHierSortForceUpRatio = 0.9
                ,cfgHierSortHeightInc    = Nothing
                ,cfgHierSortHeightMul    = 1.5
                -- widths
                ,cfgHierBaseProcChanWidth     = 1
                ,cfgHierChanWidthInc          = 0.0
                ,cfgHierChanPresortUpWidthInc = 0.0
        }


-------------------------------------------------------------------------------
-- Get hierarch parameters from config.

-- Parameters for node in communication hierarchy.
data NodeConfig = NodeConfig {
                -- sorters
                 nodeCfgSortSize                :: Int
                ,nodeCfgSortForceUp             :: Int
                ,nodeCfgSortHeight              :: Int
                -- channels
                ,nodeCfgUpChanWidth             :: Int  -- from/to uplevel
                ,nodeCfgDownChanWidth           :: Int  -- from/to downlevel
                ,nodeCfgPreUpChanWidth          :: Int  -- presort->upbuf
                ,nodeCfgPreSortChanWidth        :: Int  -- presort->sortmach
        }
        deriving Show

-- Getting parameters for nodes from configuration.
-- It returns a list of node parameters, the length of
-- list is the depth of hierarchy.
getHierParams cfg = reverse $ take depth nodeConfigs
        where
                depth = cfgHierDepth cfg
                heightChange = case cfgHierSortHeightInc cfg of
                        Nothing -> (cfgHierSortHeightMul cfg*)
                        Just i  -> (i+)
                lenChange = case cfgHierSortSizeInc cfg of
                        Nothing -> (cfgHierSortSizeMul cfg*)
                        Just i  -> (i+)
                
                heights = iterate heightChange (toEnum $ cfgHierBaseSortHeight cfg)
                lengths = iterate lenChange (toEnum $ cfgHierBaseSortSize cfg)
                forceUps = map (cfgHierSortForceUpRatio cfg*) lengths
                downChanWidths =
                          iterate (+cfgHierChanWidthInc cfg)
                        $ toEnum $ getProcessorChanWidth cfg
                upChanWidths = tail downChanWidths
                presortUpChanWidths =
                        iterate (+cfgHierChanPresortUpWidthInc cfg)
                        $ (/2) $ toEnum $ getProcessorChanWidth cfg
                mkNodeConfig (l,fu,h) (dcw,ucw,pucw)
                        | fu > l || fu < 1 = error "Force up ratio seem bigger that 1 or too small."
                        | otherwise = NodeConfig {
                                 nodeCfgSortSize    = fromEnum $ l+0.5
                                ,nodeCfgSortForceUp = fromEnum $ fu+0.5
                                ,nodeCfgSortHeight  = fromEnum $ h+0.5
                                ,nodeCfgUpChanWidth = fromEnum $ ucw+0.5
                                ,nodeCfgDownChanWidth = fromEnum $ dcw+0.5
                                ,nodeCfgPreUpChanWidth = fromEnum $ pucw+0.5
                                ,nodeCfgPreSortChanWidth = fromEnum $ dcw+ucw/2+0.5
                                }
                nodeConfigs = zipWith mkNodeConfig
                        (zip3 lengths forceUps heights)
                        (zip3 downChanWidths upChanWidths presortUpChanWidths)

getProcessorChanWidth cfg = cfgHierBaseProcChanWidth cfg

getHierProcWidth cfg = case getHierParams cfg of
        [] -> getProcessorChanWidth cfg
        (p:_) -> nodeCfgUpChanWidth p

-------------------------------------------------------------------------------
-- Command-line parameters parsing.

parseCommandLine = do
        args <- getArgs
        parseAnyArgs defConfig args

parseAnyArgs config args = do
        parsed <- foldM (flip parseArg) config args
        validate parsed

-- We can perform some validation here. If we need one.
-- (actually, we need one, but we are too lazy and prefer to stay away
-- from negative widths, for example)
validate config = return config

halt words = do
        putStrLn $ unwords words
        putStrLn "Halted."
        exitFailure

usage words = do
        putStrLn $ unwords words
        usageBody

usageFunc _ _ = usageBody

usageBody = do
        pn <- getProgName
        putStrLn $ unwords ["usage:",pn,"<options>"]
        putStrLn ""
        putStrLn "Options are:"
        putStrLn usageText
        exitFailure
        where
                argNames = map fst argFunctions
                argDescs = map (fst . snd) argFunctions
                maxArgLen = maximum $ (0:) $ map length argNames
                expArgNames = map (\n -> replicate (maxArgLen - length n) ' '++"--"++n) argNames
                usageText = unlines $ zipWith (\a d -> a++" - "++d) expArgNames argDescs

parseArg argS config
        | Just (func,val) <- splitArgS argS = do
                func val config
        | otherwise = usage ["unknown or invalid command-line argument",argS]

splitArgS argS = do
        argthenval <- strip argS
        (arg,val) <- split argthenval
        func <- findFunc arg
        return (func,val)
        where
                strip ('-':'-':argthenval) = Just argthenval
                strip _                    = Nothing
                split atv = case span (/='=') atv of
                        (arg,'=':val) -> Just (arg,val)
                        _             -> Nothing
                findFunc arg =
                        fmap (snd . snd) $
                        listToMaybe $
                        dropWhile ((/=arg) . fst) argFunctions

argFunctions = [
                 ("help"                 ,("print usage",usageFunc))
                ,("debug"                ,("print debug information",boolReadChanger chgCfgDebug))
                ,("file"                 ,("load options from file (one --option=val per line, // and # EOL comments",readConfigFile))
                ,("procMaxThreads"       ,("execution unit max threads",readChanger chgCfgProcMaxThreads))
                ,("procParThreads"       ,("parallel threads in one cycle",readChanger chgCfgProcParThreads))
                ,("procMatcherSize"      ,("matcher size for processor",readChanger chgCfgProcMatcherSize))
                ,("procMatcherForceUp"   ,("matcher force up limit",readChanger chgCfgProcMatcherForceUp))
                ,("procMatcherDnWidth"   ,("number of pairs to generate in one tick",readChanger chgCfgProcMatcherDnWidth))
                ,("procShedulePolicy"    ,("processor shedule policy: "++show [SheduleAllWorkBack ..],readChanger chgCfgProcShedulePolicy))
                ,("procOutWidth"         ,("processor output width",readChanger chgCfgProcOutWidth))
                ,("upBufMaxLen"          ,("upbuf capacity",readChanger chgCfgUpBufMaxLen))
                ,("presorterMaxLen"      ,("presorter capacity",readChanger chgCfgPresorterMaxLen))
                ,("hierDepth"            ,("depth of hierarchy",readChanger chgCfgHierDepth))
                ,("maxWait"              ,("maximum number of cycles to wait program termination.",readChanger chgCfgMaxWait))
                ,("taskOption"           ,("set option for task at hand.",changeTaskSetting))
                ,("hierBaseSortSize"     ,("size of sorter in lowest node",readChanger chgCfgHierBaseSortSize))
                ,("hierBaseSortHeight"   ,("capacity of sorter per lowest node",readChanger chgCfgHierBaseSortHeight))
                ,("hierSortSizeInc"      ,("increment for node sorter size",readChanger chgCfgHierSortSizeInc))
                ,("hierSortSizeMul"      ,("multiplier for node sorter size",readChanger chgCfgHierSortSizeMul))
                ,("hierSortForceUpRatio" ,("sort machine fill ratio for forwarding tokens up",readChanger chgCfgHierSortForceUpRatio))
                ,("hierSortHeightInc"    ,("incrment for node sorter capacity",readChanger chgCfgHierSortHeightInc))
                ,("hierSortHeightMul"    ,("multiplier for node sorter capacity",readChanger chgCfgHierSortHeightMul))
                ,("hierBaseProcChanWidth",("base processor element channel width.",readChanger chgCfgHierBaseProcChanWidth))
                ,("hierChanWidthInc"     ,("channel width hierarchy increment.",readChanger chgCfgHierChanWidthInc))
                ,("hierChanPresortUpWidthInc",("hierarchy internal bus width from presorter to upstream buffer.",readChanger chgCfgHierChanPresortUpWidthInc))
        ]

-------------------------------------------------------------------------------
-- Parsers for different value types.

readChanger :: Read a => (a -> Config -> Config) -> String -> Config -> IO Config
readChanger f val cfg = case readsPrec 0 val of
        [(r,"")] -> return $ f r cfg
        _ -> halt [show val,"does not parse."]

boolReadChanger :: (Bool -> Config -> Config) -> String -> Config -> IO Config
boolReadChanger f val cfg
        | elem lowVal ["off","false","0"] = return $ f False cfg
        | elem lowVal ["on","true","1"] = return $ f True cfg
        where
                lowVal = map toLower val

-------------------------------------------------------------------------------
-- Change different parts of config.

chgCfgDebug b cfg = cfg { cfgDebug = b }
chgCfgProcMaxThreads i cfg = cfg { cfgProcMaxThreads = i }
chgCfgProcParThreads i cfg = cfg { cfgProcParThreads = i }
chgCfgUpBufMaxLen i cfg = cfg { cfgUpBufMaxLen = i }
chgCfgPresorterMaxLen i cfg = cfg { cfgPresorterMaxLen = i }
chgCfgHierDepth i cfg = cfg { cfgHierDepth = i }
chgCfgMaxWait i cfg = cfg { cfgMaxWait = i }
chgCfgProcMatcherSize i cfg = cfg { cfgProcMatcherSize = i }
chgCfgProcMatcherForceUp i cfg = cfg { cfgProcMatcherForceUp = i }
chgCfgProcMatcherDnWidth i cfg = cfg { cfgProcMatcherDnWidth = i }
chgCfgProcShedulePolicy i cfg = cfg { cfgProcShedulePolicy = i }
chgCfgProcOutWidth i cfg = cfg { cfgProcOutWidth = i }
chgCfgHierBaseSortSize i cfg = cfg { cfgHierBaseSortSize = i }
chgCfgHierBaseSortHeight i cfg = cfg { cfgHierBaseSortHeight = i }
chgCfgHierSortSizeInc i cfg = cfg { cfgHierSortSizeInc = Just i }
chgCfgHierSortSizeMul i cfg = cfg { cfgHierSortSizeMul = i }
chgCfgHierSortForceUpRatio i cfg = cfg { cfgHierSortForceUpRatio = i }
chgCfgHierSortHeightInc i cfg = cfg { cfgHierSortHeightInc = Just i }
chgCfgHierSortHeightMul i cfg = cfg { cfgHierSortHeightMul = i }
chgCfgHierBaseProcChanWidth i cfg = cfg { cfgHierBaseProcChanWidth = i }
chgCfgHierChanWidthInc i cfg = cfg { cfgHierChanWidthInc = i }
chgCfgHierChanPresortUpWidthInc i cfg = cfg { cfgHierChanPresortUpWidthInc = i }

-------------------------------------------------------------------------------
-- Change task settings.

changeTaskSetting val cfg
        | valid = return newcfg
        | otherwise = halt [show val, "isn't in 'key=value' syntax"]
        where
                (valid,key,value) = case span (/='=') val of
                        (key,'=':value) -> (True,key,value)
                        _               -> (False,undefined,undefined)
                newcfg = cfg { cfgTaskSettings = M.insert key value (cfgTaskSettings cfg) }

-------------------------------------------------------------------------------
-- Read (as in invoking Read class member) task parameter.

readTaskParam :: (Read a) => String -> a -> Config -> a
readTaskParam pname def cfg = case M.lookup pname (cfgTaskSettings cfg) of
        Nothing -> def
        Just val -> case readsPrec 0 val of
                [(r,"")] -> r
                _ -> error $ unwords [show val,"isn't valid for",pname]

-------------------------------------------------------------------------------
-- Read config file.

stripWhite = dropWhile isSpace . reverse . dropWhile isSpace . reverse

readConfigFile fn cfg = do
        text <- readFile fn
        let args = filter (not . isComment) $ map stripWhite $ lines text
        parseAnyArgs cfg args
        where
                isComment ('/':'/':_) = True
                isComment ('#':_) = True
                isComment "" = True
                isComment _ = False