diff --git a/Main.hs b/Main.hs index d722070..fce4dfd 100644 --- a/Main.hs +++ b/Main.hs @@ -58,7 +58,7 @@ import ShowCode import Utils -- Either gives back options, or an exact string to print out: -type OptFunc = CompState -> ErrorT String IO CompState +type OptFunc = CompOpts -> ErrorT String IO CompOpts printString :: String -> ErrorT String IO a printString = throwError @@ -188,7 +188,7 @@ optPrintHelp _ = printString $ usageInfo "Usage: tock [OPTION...] SOURCEFILE" op optPrintWarningHelp :: OptFunc optPrintWarningHelp _ = printString $ usageInfo "Usage: tock [OPTION...] SOURCEFILE" optionsWarnings -optOnOff :: (String, Bool -> CompState -> CompState) -> String -> OptFunc +optOnOff :: (String, Bool -> CompOpts -> CompOpts) -> String -> OptFunc optOnOff (n, f) s ps = do mode <- case s of "on" -> return True @@ -240,7 +240,7 @@ main = do Just $ take (length fn - length ".rain") fn) else (id, Nothing) - res <- runErrorT $ foldl (>>=) (return $ frontendGuess emptyState) opts + res <- runErrorT $ foldl (>>=) (return $ frontendGuess emptyOpts) opts case res of Left str -> putStrLn str Right initState -> do @@ -250,7 +250,7 @@ main = do mode -> useOutputOptions (compile mode fn) -- Run the compiler. - v <- runPassM initState operation + v <- runPassM (emptyState { csOpts = initState}) operation case v of (Left e, cs) -> showWarnings (csWarnings cs) >> dieIO e (Right r, cs) -> showWarnings (csWarnings cs) @@ -279,14 +279,14 @@ instance Die FilesPassM where -- If removing the files fails, we don't want to die with that -- error; we want the user to see the original error, so ignore -- errors arising from removing the files: - optsPS <- getCompState + optsPS <- getCompOpts when (not $ csKeepTemporaries optsPS) $ liftIO $ removeFiles files FilesPassM $ dieReport err compileFull :: String -> Maybe String -> FilesPassM () compileFull inputFile moutputFile - = do optsPS <- getCompState + = do optsPS <- getCompOpts outputFile <- case (csOutputFile optsPS, moutputFile) of -- If the user hasn't given an output file, we guess by -- using a stem (input file minus known extension). @@ -307,7 +307,7 @@ compileFull inputFile moutputFile let cFile = outputFile ++ cExtension hFile = outputFile ++ hExtension iFile = outputFile ++ ".tock.inc" - modifyCompState $ \cs -> cs { csOutputIncFile = Just iFile } + modifyCompOpts $ \cs -> cs { csOutputIncFile = Just iFile } withOutputFile cFile $ \hb -> withOutputFile hFile $ \hh -> FilesPassM $ lift $ compile ModeCompile inputFile ((hb, hh), hFile) @@ -316,7 +316,7 @@ compileFull inputFile moutputFile exec $ "indent " ++ cFile cs <- getCompState - case csBackend cs of + case csBackend (csOpts cs) of BackendC -> let sFile = outputFile ++ ".tock.s" oFile = outputFile ++ ".tock.o" @@ -325,52 +325,55 @@ compileFull inputFile moutputFile postOFile = outputFile ++ ".tock_post.o" in do sequence_ $ map noteFile $ [sFile, postCFile, postOFile] - ++ if csHasMain cs then [oFile] else [] + ++ if csHasMain (csOpts cs) then [oFile] else [] -- The object file is a temporary to-be-removed -- iff we are also linking the end product -- Compile the C into assembly, and assembly into an object file - exec $ cAsmCommand cFile sFile (csCompilerFlags cs) - exec $ cCommand sFile oFile (csCompilerFlags cs) + exec $ cAsmCommand cFile sFile (csCompilerFlags $ csOpts cs) + exec $ cCommand sFile oFile (csCompilerFlags $ csOpts cs) -- Analyse the assembly for stack sizes, and output a -- "post" H file sizes <- withOutputFile sizesFile $ \h -> FilesPassM $ lift $ postCAnalyse sFile ((h,intErr),intErr) - when (csHasMain cs) $ do + when (csHasMain $ csOpts cs) $ do withOutputFile postCFile $ \h -> - computeFinalStackSizes searchReadFile (csUnknownStackSize cs) + computeFinalStackSizes searchReadFile (csUnknownStackSize $ csOpts cs) (Meta (Just sizesFile) 1 1) sizes >>= (liftIO . hPutStr h) -- Compile this new "post" C file into an object file - exec $ cCommand postCFile postOFile (csCompilerFlags cs) + exec $ cCommand postCFile postOFile (csCompilerFlags $ csOpts cs) let otherOFiles = [usedFile ++ ".tock.o" | usedFile <- Set.toList $ csUsedFiles cs] -- Link the object files into a binary - exec $ cLinkCommand (oFile : postOFile : otherOFiles) outputFile (csCompilerLinkFlags cs) + exec $ cLinkCommand (oFile : postOFile : otherOFiles) outputFile + (csCompilerLinkFlags $ csOpts cs) -- For C++, just compile the source file directly into a binary BackendCPPCSP -> do cs <- getCompState - if csHasMain cs + if csHasMain $ csOpts cs then let otherOFiles = [usedFile ++ ".tock.o" | usedFile <- Set.toList $ csUsedFiles cs] in exec $ cxxCommand cFile outputFile - (concat (intersperse " " otherOFiles) ++ " " ++ csCompilerFlags cs ++ " " ++ csCompilerLinkFlags cs) + (concat (intersperse " " otherOFiles) ++ " " + ++ csCompilerFlags (csOpts cs) ++ " " + ++ csCompilerLinkFlags (csOpts cs)) else exec $ cxxCommand cFile (outputFile ++ ".tock.o") - ("-c " ++ csCompilerFlags cs) + ("-c " ++ csCompilerFlags (csOpts cs)) BackendCHP -> exec $ hCommand cFile outputFile _ -> dieReport (Nothing, "Cannot use specified backend: " - ++ show (csBackend cs) + ++ show (csBackend $ csOpts cs) ++ " with full-compile mode") -- Finally, remove the temporary files: tempFiles <- FilesPassM get - when (not $ csKeepTemporaries cs) $ + when (not $ csKeepTemporaries $ csOpts cs) $ liftIO $ removeFiles tempFiles where @@ -404,7 +407,7 @@ compileFull inputFile moutputFile -- | Picks out the handle from the options and passes it to the function: useOutputOptions :: (((Handle, Handle), String) -> PassM a) -> PassM a useOutputOptions func - = do optsPS <- get + = do optsPS <- getCompOpts withHandleFor (csOutputFile optsPS) $ \hb -> withHandleFor (csOutputHeaderFile optsPS) $ \hh -> func ((hb, hh), csOutputHeaderFile optsPS) @@ -459,7 +462,7 @@ showTokens html ts = evalState (mapM showToken ts >>* spaceOut) 0 -- because then it's very easy to pass the state around. compile :: CompMode -> String -> ((Handle, Handle), String) -> PassM () compile mode fn (outHandles@(outHandle, _), headerName) - = do optsPS <- get + = do optsPS <- getCompOpts debug "{{{ Parse" progress "Parse" diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index bf86bda..5e98484 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -203,7 +203,7 @@ cgenTopLevel headerName s sequence_ [tell ["extern int "] >> genName n >> tell ["_stack_size;\n"] | n <- nss] - when (csHasMain cs) $ do + when (csHasMain $ csOpts cs) $ do (tlpName, tlpChans) <- tlpInterface tell ["extern int "] genName tlpName @@ -215,7 +215,7 @@ cgenTopLevel headerName s call genStructured TopLevel s (\m _ -> tell ["\n#error Invalid top-level item: ", show m]) - when (csHasMain cs) $ do + when (csHasMain $ csOpts cs) $ do (tlpName, tlpChans) <- tlpInterface chans <- sequence [csmLift $ makeNonce emptyMeta "tlp_channel" | _ <- tlpChans] killChans <- sequence [csmLift $ makeNonce emptyMeta "tlp_channel_kill" | _ <- tlpChans] diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index f452b88..ef2086e 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -100,7 +100,7 @@ chansToAny :: PassOn A.Type chansToAny = cppOnlyPass "Transform channels to ANY" [Prop.processTypesChecked] [Prop.allChansToAnyOrProtocol] - $ \x -> do st <- get + $ \x -> do st <- getCompOpts case csFrontend st of FrontendOccam -> do chansToAnyInCompState @@ -118,7 +118,7 @@ chansToAny = cppOnlyPass "Transform channels to ANY" chansToAnyM = applyBottomUpM chansToAny' chansToAnyInCompState :: PassM () - chansToAnyInCompState = do st <- get + chansToAnyInCompState = do st <- getCompState csn <- chansToAnyM (csNames st) put $ st {csNames = csn} return () @@ -160,12 +160,12 @@ cppgenTopLevel headerName s call genStructured TopLevel s (\m _ -> tell ["\n#error Invalid top-level item: ",show m]) - when (csHasMain cs) $ do + when (csHasMain $ csOpts cs) $ do (name, chans) <- tlpInterface tell ["int main (int argc, char** argv) { csp::Start_CPPCSP();"] (chanTypeRead, chanTypeWrite, writer, reader) <- do st <- getCompState - case csFrontend st of + case csFrontend $ csOpts st of FrontendOccam -> return ("tockSendableArrayOfBytes", "tockSendableArrayOfBytes", "StreamWriterByteArray", diff --git a/common/OccamEDSL.hs b/common/OccamEDSL.hs index 6535c52..23d0403 100644 --- a/common/OccamEDSL.hs +++ b/common/OccamEDSL.hs @@ -396,7 +396,7 @@ testOccamPassWarn str check code pass (put $ inpS {csWarnings = []}) -- Blank the warnings for the new pass (assertEqual str (csNames expS) . csNames) where - emptyStateWithWarnings = emptyState { csEnabledWarnings = Set.fromList [minBound..maxBound] } + emptyStateWithWarnings = emptyState { csOpts = emptyOpts {csEnabledWarnings = Set.fromList [minBound..maxBound]} } -- | Like testOccamPass, but applies a transformation to the patterns (such as -- using stopCaringPattern) before pattern-matching diff --git a/common/ShowCode.hs b/common/ShowCode.hs index 2c42c97..ea4ab95 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -179,7 +179,7 @@ instance ShowRain () where showCode :: (CSMR m, ShowOccam a, ShowRain a) => a -> m String showCode o = do st <- getCompState - case csFrontend st of + case csFrontend $ csOpts st of FrontendOccam -> return $ concat $ snd $ runWriter $ evalStateT (showOccamM o) (initialShowCodeState $ transformNames $ csNames st) FrontendRain -> return $ concat $ snd $ runWriter $ evalStateT (showRainM o) diff --git a/common/TestHarness.hs b/common/TestHarness.hs index 5936c39..1a97559 100644 --- a/common/TestHarness.hs +++ b/common/TestHarness.hs @@ -70,8 +70,11 @@ data AutoTest = AutoTest automaticTest :: CompFrontend -> Int -> FilePath -> IO Test automaticTest fr verb fileName = readFile fileName >>* performTest fr verb fileName +defaultOpts :: CompFrontend -> Int -> CompOpts +defaultOpts fr v = emptyOpts {csVerboseLevel = v, csFrontend = fr} + defaultState :: CompFrontend -> Int -> CompState -defaultState fr v = emptyState {csVerboseLevel = v, csFrontend = fr} +defaultState fr v = emptyState { csOpts = defaultOpts fr v } -- | Tests if compiling the given source gives any errors. -- If there are errors, they are returned. Upon success, Nothing is returned @@ -83,7 +86,7 @@ testOccam v source = do (result,_) <- runPassM (defaultState FrontendOccam v) co where compilation = preprocessOccamSource source >>= parseOccamProgram - >>= runPasses (getPassList $ defaultState FrontendOccam v) + >>= runPasses (getPassList $ defaultOpts FrontendOccam v) testRain :: Int -> String -> IO (Maybe (Maybe Meta, String)) testRain v source = do (result,_) <- runPassM (defaultState FrontendRain v) compilation @@ -92,7 +95,7 @@ testRain v source = do (result,_) <- runPassM (defaultState FrontendRain v) comp Right _ -> Nothing where compilation = parseRainProgram "" source - >>= runPasses (getPassList $ defaultState FrontendRain v) + >>= runPasses (getPassList $ defaultOpts FrontendRain v) -- | Substitutes each substitution into the prologue substitute :: AutoTest -> Either String [(Bool, String, String)] diff --git a/common/TestUtils.hs b/common/TestUtils.hs index 4d9e01b..2f48103 100644 --- a/common/TestUtils.hs +++ b/common/TestUtils.hs @@ -630,7 +630,7 @@ testPassShouldFail' testName actualPass startStateTrans = --{{{ miscellaneous utilities markRainTest :: State CompState () -markRainTest = modify (\cs -> cs { csFrontend = FrontendRain }) +markRainTest = modifyCompOpts (\cs -> cs { csFrontend = FrontendRain }) castOrFail :: (Typeable b) => String -> String -> Items -> IO b castOrFail testName key items = diff --git a/common/Types.hs b/common/Types.hs index 46cf792..81f8ec6 100644 --- a/common/Types.hs +++ b/common/Types.hs @@ -330,7 +330,7 @@ returnTypesOfFunction n returnTypesOfIntrinsic :: (CSMR m, Die m) => Meta -> String -> m [A.Type] returnTypesOfIntrinsic m s - = do frontend <- getCompState >>* csFrontend + = do frontend <- getCompOpts >>* csFrontend let intrinsicList = case frontend of FrontendOccam -> intrinsicFunctions FrontendRain -> rainIntrinsicFunctions @@ -623,7 +623,7 @@ justSize n = return $ BIJust $ makeConstant emptyMeta n -- backend. If the backend is not recognised, the C sizes are used. justSizeBackends :: CSMR m => Int -> Int -> m BytesInResult justSizeBackends c cxx - = do backend <- getCompState >>* csBackend + = do backend <- getCompOpts >>* csBackend case backend of BackendCPPCSP -> justSize c _ -> justSize cxx diff --git a/data/CompState.hs b/data/CompState.hs index 9843afc..707bf16 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -97,14 +97,13 @@ data NameAttr = NameShared | NameAliasesPermitted deriving (Typeable, Data, Eq, data ExternalType = ExternalOldStyle | ExternalOccam deriving (Typeable, Data, Eq, Show, Ord) --- | State necessary for compilation. -data CompState = CompState { - -- This structure needs to be printable with pshow. - -- There are explicit rules for the Maps and Sets used here - -- in PrettyShow.hs; if you add any new ones here then remember - -- to add matching rules there. - - -- Set by Main (from command-line options) +-- | Options for the compiler. +-- +-- CompOpts should contain things are adjustable from the command-line. They may +-- also change during compilation; for example, the preprocessor definitions will +-- be affected by the preprocessor, and other options may be affected by pragmas +-- in future. +data CompOpts = CompOpts { csMode :: CompMode, csBackend :: CompBackend, csFrontend :: CompFrontend, @@ -124,6 +123,21 @@ data CompState = CompState { csUnknownStackSize :: Integer, csSearchPath :: [String], csImplicitModules :: [String], + + csDefinitions :: Map String PreprocDef + } + deriving (Data, Typeable, Show) + +-- | State necessary for compilation. +data CompState = CompState { + -- This structure needs to be printable with pshow. + -- There are explicit rules for the Maps and Sets used here + -- in PrettyShow.hs; if you add any new ones here then remember + -- to add matching rules there. + + -- Set by Main (from command-line options) + csOpts :: CompOpts, + -- Extra sizes files to look up. These are stored without the tock suffix csExtraSizes :: [String], -- Extra include files, stored without the .tock.h suffix. @@ -133,7 +147,6 @@ data CompState = CompState { csCurrentFile :: String, -- Also used by some later passes! -- #USEd files. These are stored with any (known) extensions removed: csUsedFiles :: Set String, - csDefinitions :: Map String PreprocDef, -- Set by Parse csMainLocals :: [(String, (A.Name, NameType))], @@ -159,8 +172,8 @@ data CompState = CompState { } deriving (Data, Typeable, Show) -emptyState :: CompState -emptyState = CompState { +emptyOpts :: CompOpts +emptyOpts = CompOpts { csMode = ModeFull, csBackend = BackendC, csFrontend = FrontendOccam, @@ -185,16 +198,22 @@ emptyState = CompState { csUnknownStackSize = 512, csSearchPath = [".", tockIncludeDir], csImplicitModules = [], + + csDefinitions = Map.fromList [("COMPILER.TOCK", PreprocNothing) + ,("TARGET.BITS.PER.WORD", PreprocInt $ show $ cIntSize * 8) + ,("TARGET.BYTES.PER.WORD", PreprocInt $ show cIntSize) +-- ,("TARGET.HAS.FPU", PreprocNothing) + ] + } + +emptyState :: CompState +emptyState = CompState { + csOpts = emptyOpts, csExtraSizes = [], csExtraIncludes = [], csCurrentFile = "none", csUsedFiles = Set.empty, - csDefinitions = Map.fromList [("COMPILER.TOCK", PreprocNothing) - ,("TARGET.BITS.PER.WORD", PreprocInt $ show $ cIntSize * 8) - ,("TARGET.BYTES.PER.WORD", PreprocInt $ show cIntSize) --- ,("TARGET.HAS.FPU", PreprocNothing) - ], csMainLocals = [], csNames = Map.empty, @@ -229,6 +248,9 @@ class (Monad m, CSMR m) => CSM m where modifyCompState :: (CompState -> CompState) -> m () modifyCompState f = (getCompState >>* f) >>= putCompState +modifyCompOpts :: CSM m => (CompOpts -> CompOpts) -> m () +modifyCompOpts f = modifyCompState $ \cs -> cs { csOpts = f (csOpts cs) } + -- If it's State CompState, I doubt they will want any other instance than this -- one: instance CSM (State CompState) where @@ -268,6 +290,8 @@ instance (CSMR m, Error e) => CSMR (ErrorT e m) where instance (CSMR m, Monoid w) => CSMR (WriterT w m) where getCompState = lift getCompState +getCompOpts :: CSMR m => m CompOpts +getCompOpts = getCompState >>* csOpts --instance (MonadWriter [WarningReport] m) => Warn m where -- warnReport r = tell [r] @@ -475,7 +499,7 @@ searchFile m filename = do cs <- getCompState let currentFile = csCurrentFile cs let possibilities = joinPath currentFile filename - : [dir ++ "/" ++ filename | dir <- csSearchPath cs] + : [dir ++ "/" ++ filename | dir <- (csSearchPath . csOpts) cs] openOneOf possibilities possibilities where openOneOf :: [String] -> [String] -> m (Handle, String) diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index 504d932..568caf9 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -61,7 +61,7 @@ occamPasses = writeIncFile :: Pass A.AST writeIncFile = occamOnlyPass "Write .inc file" [] [] (passOnlyOnAST "writeIncFile" (\t -> - do out <- getCompState >>* csOutputIncFile + do out <- getCompOpts >>* csOutputIncFile case out of Just fn -> do f <- liftIO $ openFile fn WriteMode contents <- emitProcsAsExternal t >>* (unlines . F.toList) diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 8aa69ab..5fc2fbd 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -65,7 +65,7 @@ addLocalName n = do st <- getState instance Warn (GenParser tok OccParserState) where warnReport w@(_,t,_) = modifyCompState $ \cs -> cs { csWarnings = - if t `Set.member` csEnabledWarnings cs + if t `Set.member` csEnabledWarnings (csOpts cs) then csWarnings cs ++ [w] else csWarnings cs } @@ -1536,7 +1536,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta modifyCompState $ \cs -> cs { csExtraIncludes = (f' ++ pragStr) : csExtraIncludes cs } return Nothing handleNativeLink m [pragStr] - = do modifyCompState $ \cs -> cs { csCompilerLinkFlags = csCompilerLinkFlags cs ++ " " ++ pragStr} + = do modifyCompOpts $ \cs -> cs { csCompilerLinkFlags = csCompilerLinkFlags cs ++ " " ++ pragStr} return Nothing handleExternal isCExternal m diff --git a/frontends/PreprocessOccam.hs b/frontends/PreprocessOccam.hs index eb3bc54..57fa67a 100644 --- a/frontends/PreprocessOccam.hs +++ b/frontends/PreprocessOccam.hs @@ -51,11 +51,11 @@ preprocessFile m implicitMods filename then Set.insert (dropTockInc realFilename) . Set.delete (dropTockInc filename) else id - modify (\cs -> cs { csCurrentFile = realFilename - , csUsedFiles = modFunc $ csUsedFiles cs }) + modifyCompState (\cs -> cs { csCurrentFile = realFilename + , csUsedFiles = modFunc $ csUsedFiles cs }) s <- liftIO $ hGetContents handle toks <- preprocessSource m implicitMods realFilename s - modify (\cs -> cs { csCurrentFile = csCurrentFile origCS }) + modifyCompState (\cs -> cs { csCurrentFile = csCurrentFile origCS }) return toks where -- drops ".tock.inc" from the end if it's there: @@ -146,7 +146,7 @@ preprocessOccam (Token m (TokPreprocessor s) : ts) stripPrefix _ = error "bad TokPreprocessor prefix" preprocessOccam (Token _ (TokReserved "##") : Token m (TokIdentifier var) : ts) = do st <- get - case Map.lookup var (csDefinitions st) of + case Map.lookup var (csDefinitions $ csOpts st) of Just (PreprocInt num) -> toToken $ TokIntLiteral num Just (PreprocString str) -> toToken $ TokStringLiteral str Just (PreprocNothing) -> dieP m $ var ++ " is defined, but has no value" @@ -243,16 +243,16 @@ handleUse m (modName:_) handleDefine :: DirectiveFunc handleDefine m [definition] = do (var, value) <- runPreprocParser m defineDirective definition - st <- get + st <- getCompState >>* csOpts when (Map.member var $ csDefinitions st) $ dieP m $ "Preprocessor symbol is already defined: " ++ var - put $ st { csDefinitions = Map.insert var value $ csDefinitions st } + modifyCompOpts $ \st -> st { csDefinitions = Map.insert var value $ csDefinitions st } return return -- | Handle the @#UNDEF@ directive. handleUndef :: DirectiveFunc handleUndef m [var] - = do modify $ \st -> st { csDefinitions = Map.delete var $ csDefinitions st } + = do modifyCompOpts $ \st -> st { csDefinitions = Map.delete var $ csDefinitions st } return return -- | Handle the @#IF@ directive. @@ -408,7 +408,7 @@ expression -- | Match a 'PreprocParser' production. runPreprocParser :: Meta -> PreprocParser a -> String -> PassM a runPreprocParser m prod s - = do st <- get + = do st <- getCompState >>* csOpts case runParser wrappedProd (csDefinitions st) (show m) s of Left err -> dieP m $ "Error parsing preprocessor instruction: " ++ show err Right b -> return b @@ -423,10 +423,10 @@ runPreprocParser m prod s -- | Load and preprocess an occam program. preprocessOccamProgram :: String -> PassM [Token] preprocessOccamProgram filename - = do mods <- getCompState >>* csImplicitModules + = do mods <- getCompState >>* (csImplicitModules . csOpts) toks <- preprocessFile emptyMeta mods filename -- Leave the main file name in the csCurrentFile slot: - modify $ \cs -> cs { csCurrentFile = filename } + modifyCompState $ \cs -> cs { csCurrentFile = filename } veryDebug $ "{{{ tokenised source" veryDebug $ pshow toks veryDebug $ "}}}" diff --git a/pass/Pass.hs b/pass/Pass.hs index 9278e45..8527ed9 100644 --- a/pass/Pass.hs +++ b/pass/Pass.hs @@ -46,7 +46,7 @@ instance Die PassM where instance Warn PassM where warnReport w@(_,t,_) = lift $ modify $ \cs -> cs { csWarnings = - if t `Set.member` csEnabledWarnings cs + if t `Set.member` csEnabledWarnings (csOpts cs) then csWarnings cs ++ [w] else csWarnings cs } @@ -102,7 +102,7 @@ data Pass t = Pass { , passName :: String , passPre :: Set.Set Property , passPost :: Set.Set Property - , passEnabled :: CompState -> Bool + , passEnabled :: CompOpts -> Bool } instance Eq (Pass t) where @@ -130,7 +130,7 @@ runPassM :: CompState -> PassM a -> IO (Either ErrorReport a, CompState) runPassM cs pass = flip runStateT cs $ runErrorT pass -enablePassesWhen :: (CompState -> Bool) -> [Pass A.AST] -> [Pass A.AST] +enablePassesWhen :: (CompOpts -> Bool) -> [Pass A.AST] -> [Pass A.AST] enablePassesWhen f = map (\p -> p { passEnabled = \c -> f c && (passEnabled p c) }) @@ -140,7 +140,7 @@ passOnlyOnAST name = id type PassMaker t = String -> [Property] -> [Property] -> PassType t -> Pass t -passMakerHelper :: (CompState -> Bool) -> PassMaker t +passMakerHelper :: (CompOpts -> Bool) -> PassMaker t passMakerHelper f name pre post code = Pass { passCode = code , passName = name @@ -186,7 +186,7 @@ runPasses (p:ps) ast verboseMessage :: (CSMR m, MonadIO m) => Int -> String -> m () verboseMessage n s = do ps <- getCompState - when (csVerboseLevel ps >= n) $ + when (csVerboseLevel (csOpts ps) >= n) $ liftIO $ hPutStrLn stderr s -- | Print a progress message. diff --git a/pass/PassList.hs b/pass/PassList.hs index b601a72..f3cb307 100644 --- a/pass/PassList.hs +++ b/pass/PassList.hs @@ -47,7 +47,7 @@ import SimplifyTypes import Unnest import Utils -commonPasses :: CompState -> [Pass A.AST] +commonPasses :: CompOpts -> [Pass A.AST] commonPasses opts = concat $ -- Rain does simplifyTypes separately: [ enablePassesWhen ((== FrontendOccam) . csFrontend) simplifyTypes @@ -72,7 +72,7 @@ commonPasses opts = concat $ -- (passOnlyOnAST "checkUnusedVar" (runChecks checkUnusedVar))] ] -filterPasses :: CompState -> [Pass t] -> [Pass t] +filterPasses :: CompOpts -> [Pass t] -> [Pass t] filterPasses opts = filter (\p -> passEnabled p opts) -- This pass is so small that we may as well just give it here: @@ -94,7 +94,7 @@ nullStateBodies = Pass nullProcFuncDefs x = x -getPassList :: CompState -> [Pass A.AST] +getPassList :: CompOpts -> [Pass A.AST] getPassList optsPS = checkList $ filterPasses optsPS $ concat [ [nullStateBodies] , enablePassesWhen ((== FrontendOccam) . csFrontend) @@ -108,7 +108,7 @@ getPassList optsPS = checkList $ filterPasses optsPS $ concat calculatePassList :: CSMR m => m [Pass A.AST] calculatePassList - = do optsPS <- getCompState + = do optsPS <- getCompOpts let passes = getPassList optsPS return $ if csSanityCheck optsPS then addChecks passes diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index f1f2de4..ccfe8ce 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -82,7 +82,7 @@ addForkNames = occamOnlyPass "Add FORK labels" [] [] return $ A.Spec m spec scope' doStructured (A.Spec m (A.Specification m' n spec@(A.Proc m'' smrm fs mbody)) scope) = do cs <- lift getCompState - if csHasMain cs && Just n == listToMaybe (map (fst . snd) (csMainLocals cs)) + if csHasMain (csOpts cs) && Just n == listToMaybe (map (fst . snd) (csMainLocals cs)) then do scope' <- recurse scope mbody' <- case mbody of Nothing -> return Nothing