Flags.hs

module Flags(
             Flags(..),
             remapFlagsPaths,
             redSteps,
             ResourceFlag(..), SATFlag(..), MsgListFlag(..),

             DumpFlag(..),
             hasDump, hasDumpStrict, dumpInfo,

             Verbosity(..), extraVerbose, verbose, quiet,
             moreTalkative, lessTalkative, setVerbose,
        ) where

import Control.Applicative((<|>))
import Data.Maybe(isJust)

import Backend

-- -------------------------
-- Internal flags
--
-- This is the data structure which will be carried through the program.

data Flags = Flags {
        aggImpConds :: Bool,
        allowIncoherentMatches :: Bool,
        backend :: Maybe Backend,
        bdir :: Maybe String,
        biasMethodScheduling :: Bool,
        bluespecDir :: String,
        cIncPath :: [String],
        cLibPath :: [String],
        cLibs :: [String],
        cDebug :: Bool,
        cFlags :: [String],
        cxxFlags :: [String],
        cppFlags :: [String],
        linkFlags :: [String],
        cdir :: Maybe String,
        cpp :: Bool,
        defines :: [String],
        demoteErrors :: MsgListFlag,
        disableAssertions :: Bool,
        passThroughAssertions :: Bool,
        doICheck :: Bool,
        dumpAll :: Maybe (Maybe FilePath), -- maybe dump to file or stdout
        dumps :: [(DumpFlag, Maybe FilePath)], -- dump to file or stdout
        -- prefix remappings applied to file paths stored in .bo/.ba
        -- files (source positions, the .ba module path fields, and the
        -- path-valued fields of this record as stored in .ba), so that
        -- outputs do not depend on the build machine's directory layout
        remapPathPrefix :: [(String, String)],
        enablePoisonPills :: Bool,
        entry :: Maybe String,
        expandATSlimit :: Int,
        expandIf :: Bool,
        fdir :: Maybe String,
        finalcleanup :: Int,
        genABin :: Bool,
        genABinVerilog :: Bool,
        genName :: [String],
        genSysC :: Bool,
        ifcPathRaw :: [String],
        ifcPath :: [String],
        infoDir :: Maybe String,
        inlineBool :: Bool,
        inlineISyntax :: Bool,
        inlineSimple :: Bool,
        keepAddSize :: Bool,
        keepFires :: Bool,
        keepInlined :: Bool,
        kill :: Maybe (DumpFlag, Maybe String),
        ifLift :: Bool,
        letGen :: Bool,
        maxTIStackDepth :: Int,
        methodBVI :: Bool,
        methodConf :: Bool,
        methodConditions :: Bool,
        neatNames :: Bool,
        oFile :: String,
        optAggInline :: Bool,
        optATS :: Bool,
        optAndOr :: Bool,
        optBitConst :: Bool,
        optBool :: Bool,
        optFinalPass :: Bool,
        optIfMux :: Bool,
        optIfMuxSize :: Integer,
        optJoinDefs :: Bool,
        optMux :: Bool,
        optMuxExpand :: Bool,
        optMuxConst :: Bool,
        optSched :: Bool,
        optUndet :: Bool,
        crossInfo :: Bool,
        parallelSimLink :: Integer,
        printFlags :: Bool,
        printFlagsHidden :: Bool,
        printFlagsRaw :: Bool,
        preprocessOnly :: Bool,
        promoteWarnings :: MsgListFlag,
        readableMux :: Bool,
        redStepsWarnInterval :: Integer,
        redStepsMaxIntervals :: Integer,
        relaxMethodEarliness :: Bool,
        removeEmptyRules :: Bool,
        removeFalseRules :: Bool,
        removeInoutConnect :: Bool,
        removePrimModules :: Bool,
        removeCReg :: Bool,
        removeReg :: Bool,
        removeRWire :: Bool,
        removeCross :: Bool,
        removeStarvedRules :: Bool,
        removeUnusedMods :: Bool,
        removeVerilogDollar :: Bool,
        resetName :: String,
        resource :: ResourceFlag,
        rstGate :: Bool,
        ruleNameCheck :: Bool,
        satBackend :: SATFlag,
        schedConds:: Bool,
        schedDOT :: Bool,
        schedQueries :: [(String,String)],
        showCSyntax :: Bool,
        showCodeGen :: Bool,
        showElabProgress :: Bool,
        showIESyntax :: Bool,
        showISyntax :: Bool,
        showModuleUse :: Bool,
        showRangeConflict :: Bool,
        showSchedule :: Bool,
        showStats :: Bool,
        showUpds :: Bool,
        simplifyCSyntax :: Bool,
        strictMethodSched :: Bool,
        suppressWarnings :: MsgListFlag,
        synthesize :: Bool,
        systemVerilogTasks :: Bool,
        tclShowHidden :: Bool,
        timeStamps :: Bool,
        showVersion :: Bool,
        testAssert :: Bool,
        unsafeAlwaysRdy :: Bool,
        unSpecTo :: String,
        updCheck :: Bool,
        useDPI :: Bool,
        useNegate :: Bool,
        usePrelude :: Bool,
        useProvisoSAT :: Bool,
        stdlibNames :: Bool,
        v95 :: Bool,
        vFlags :: [String],
        vdir :: Maybe String,
        vPathRaw :: [String],
        vPath :: [String],
        vpp :: Bool,
        vsim :: Maybe String,
        verbosity :: Verbosity,
        verilogDeclareAllFirst :: Bool,
        verilogFilter :: [String],
        warnActionShadowing :: Bool,
        warnMethodUrgency :: Bool,
        warnUndetPred :: Bool
        }
-- don't derive Show -- it causes an optimized ghc build to take a long time
--        deriving (Show)

data Verbosity = Quiet | Normal | Verbose | ExtraVerbose
   deriving(Eq, Show, Ord, Enum)

extraVerbose :: Flags -> Bool
extraVerbose = (== ExtraVerbose) . verbosity

verbose :: Flags -> Bool
verbose = (>= Verbose) . verbosity

setVerbose :: Bool -> Flags -> Flags
setVerbose False f = f
setVerbose True  f = f { verbosity = max Verbose (verbosity f) }

quiet :: Flags -> Bool
quiet = (== Quiet) . verbosity

moreTalkative :: Flags -> Flags
moreTalkative f =
  case verbosity f of
    ExtraVerbose -> f
    v            -> f { verbosity = succ v }

lessTalkative :: Flags -> Flags
lessTalkative f =
  case verbosity f of
    Quiet -> f
    v     -> f { verbosity = pred v }

data DumpFlag
        =
        -- Bluespec source file
          DFdepend
        | DFcpp
        | DFvpp
        | DFbsvlex
        | DFparsed
        | DFimports
        | DFopparse
        | DFsyminitial
        | DFsympostgenwrap
        | DFsympostderiving
        | DFsympostctxreduce
        | DFsympostbinary
        | DFgenfuncwrap
        | DFgenwrap
        | DFderiving
        | DFctxreduce
        | DFconvinst
        | DFtypecheck
        | DFgenforeign
        | DFgenVPI
        | DFsimplified
        | DFinternal
        | DFbinary
        | DFfixup
        | DFisimplify
        | DFwriteBin

        -- module generation
        | DFexpanded
        | DFinlineFmt
        | DFinline
        | DFtransform
        | DFsplitIf
        | DFlift
        | DFiparams
        | DFidroprules
        | DFATS
        | DFATSexpand
        | DFdumpLambdaCalculus
        | DFdumpSAL
        | DFATSperfspec
        | DFATSsplice
        | DFATSclean
        | DFpathsPreSched
        | DFschedule
        | DFresources
        | DFvschedinfo
        | DFscheduledefs
        | DFdumpschedule
        | DFcheckproofs
        | DFpathsPostSched
        | DFnoinline
        | DFaddSchedAssumps
        | DFremoveAssumps
        | DFdropundet
        | DFwriteABin
        | DFwrappergen
        | DFwrappercomp

        -- Wrapper compilation phases
        | DFwrapper_ctxreduce
        | DFwrapper_typecheck
        | DFwrapper_simplified
        | DFwrapper_internal
        | DFwrapper_fixup

        -- Generate Verilog
        | DFforeignMap
        | DFastate
        | DFrwire
        | DFcreg
        | DFrenameio
        | DFadropdefs
        | DFaopt
        | DFsynthesize
        | DFveriquirks
        | DFfinalcleanup
        | DFIOproperties
        | DFverilog
        | DFverilogDollar
        | DFwriteVerilog

        -- Link
        | DFreadelab

        -- Link Verilog
        | DFcompileVPI
        | DFveriloglink

        -- Generate/Link Bluesim
        | DFsimExpand
        | DFsimDepend
        | DFsimPackageOpt
        | DFsimMakeCBlocks
        | DFsimCOpt
        | DFsimBlocksToC
        | DFgenSystemC
        | DFwriteC
        | DFbluesimcompile
        | DFbluesimlink

        deriving (Eq, Read, Show, Enum, Bounded)

data ResourceFlag
       = RFoff    -- don't reschedule: fail if not enough resources
       | RFsimple -- reschedule: arbitrate resources (drop first edge in graph)
       deriving (Eq, Show)

data SATFlag
       = SAT_Yices
       | SAT_STP
       deriving (Eq, Show)

data MsgListFlag = AllMsgs | SomeMsgs [String]
                 deriving (Show, Eq)

-----

-- The number of reduction steps is defined based on the interval
redSteps :: Flags -> Integer
redSteps flags = (redStepsWarnInterval flags) *
                 (redStepsMaxIntervals flags)

-----

hasDump :: Flags -> DumpFlag -> Bool
hasDump f d = (isJust $ dumpAll f) || (hasDumpStrict f d)

hasDumpStrict :: Flags -> DumpFlag -> Bool
hasDumpStrict f d = isJust $ lookup d (dumps f)

dumpInfo :: Flags -> DumpFlag -> Maybe (Maybe FilePath)
dumpInfo f d = lookup d (dumps f) <|> dumpAll f

-- -------------------------

-- Apply the -remap-path-prefix mappings to the path-valued fields of
-- the record itself.  Used on the copy of Flags stored in .ba files
-- (which is consumed only by bluetcl introspection), so that .ba
-- bytes do not depend on the build machine's directory layout.  The
-- remapping helper lives in FileNameUtil; it is passed in here to
-- avoid an import cycle.
remapFlagsPaths :: ([(String, String)] -> FilePath -> FilePath) -> Flags -> Flags
remapFlagsPaths remap flags =
    let ps = remapPathPrefix flags
        r = remap ps
        rM = fmap r
        rL = map r
    in  if null ps then flags else flags {
            -- the stored flags describe the remapped world: no further
            -- remapping applies (and the FROM prefixes are themselves
            -- machine-specific, which is the very thing being scrubbed)
            remapPathPrefix = [],
            bdir = rM (bdir flags),
            bluespecDir = r (bluespecDir flags),
            cIncPath = rL (cIncPath flags),
            cLibPath = rL (cLibPath flags),
            cdir = rM (cdir flags),
            fdir = rM (fdir flags),
            ifcPathRaw = rL (ifcPathRaw flags),
            ifcPath = rL (ifcPath flags),
            infoDir = rM (infoDir flags),
            oFile = r (oFile flags),
            vdir = rM (vdir flags),
            vPathRaw = rL (vPathRaw flags),
            vPath = rL (vPath flags),
            dumps = [ (d, rM mf) | (d, mf) <- dumps flags ],
            dumpAll = fmap rM (dumpAll flags)
        }