Better option handling and print passes as they're executed

fco2/Main.hs

@@ -9,6 +9,7 @@ import System.IO
 import Pass
 import PrettyShow
 import Parse
+import ParseState
 import SimplifyExprs
 import SimplifyProcs
 import Unnest
@@ -21,13 +22,11 @@ passes =
   , ("Flatten nested declarations", unnest)
   ]
 
-data Flag = ParseOnly | Verbose
-  deriving (Eq, Show)
-
 options :: [OptDescr Flag]
 options =
   [ Option [] ["parse-only"] (NoArg ParseOnly) "only parse input file"
-  , Option ['v'] ["verbose"] (NoArg Verbose) "show more detail about what's going on"
+  , Option ['v'] ["verbose"] (NoArg Verbose) "show progress information"
+  , Option [] ["debug"] (NoArg Debug) "show detailed information for debugging"
   ]
 
 getOpts :: [String] -> IO ([Flag], [String])
@@ -49,31 +48,34 @@ main = do
               [fn] -> fn
               _ -> error "Must specify a single input file"
 
-  let progress = if Verbose `elem` opts then hPutStrLn stderr else (\s -> return ())
+  let state0 = emptyState { psFlags = opts }
 
-  progress $ "Options: " ++ (show opts)
-  progress $ "Compiling " ++ fn
-  progress ""
+  progressIO state0 $ "Options: " ++ show opts
+  progressIO state0 $ "Compiling " ++ fn
+  progressIO state0 ""
 
-  progress "{{{ Preprocessor"
+  debugIO state0 "{{{ Preprocess"
+  progressIO state0 $ "Preprocess " ++ fn
   preprocessed <- readSource fn
-  progress $ numberedListing preprocessed
-  progress "}}}"
+  debugIO state0 $ numberedListing preprocessed
+  debugIO state0 "}}}"
 
-  progress "{{{ Parser"
-  (ast, state) <- parseSource preprocessed fn
-  progress $ pshow ast
-  progress $ pshow state
-  progress "}}}"
+  debugIO state0 "{{{ Parse"
+  progressIO state0 $ "Parse " ++ fn
+  (ast1, state1) <- parseSource preprocessed fn state0
+  debugASTIO state1 ast1
+  debugIO state1 "}}}"
 
   if ParseOnly `elem` opts then
-      putStrLn $ show ast
+      putStrLn $ show ast1
     else do
-      (ast', state') <- runPass (runPasses progress passes) ast state
+      progressIO state1 "Passes:"
+      (ast2, state2) <- runPass (runPasses passes) ast1 state1
 
-      progress "{{{ Generate C"
-      c <- generateC state' ast'
+      debugIO state2 "{{{ Generate C"
+      progressIO state2 "Generate C"
+      c <- generateC state2 ast2
       putStr c
-      progress "}}}"
-      progress "Done"
+      debugIO state2 "}}}"
+      progressIO state2 "Done"
 

fco2/Makefile

@@ -24,7 +24,7 @@ $(targets): $(sources)
 CFLAGS = -g -std=gnu99 -Wall `kroc --cflags` `kroc --ccincpath`
 
 %.fco.c: %.occ fco
-	./fco $< >$@ || ( rm -f $@; exit 1 )
+	./fco -v $< >$@ || ( rm -f $@; exit 1 )
 	indent -kr -pcs $@
 
 %.fco: %.fco.o kroc-wrapper-c.o kroc-wrapper.occ

fco2/Parse.hs

@@ -1346,9 +1346,9 @@ testParse prod text
     = do let r = runParser prod emptyState "" text
          putStrLn $ "Result: " ++ show r
 
-parseSource :: String -> String -> IO (A.Process, ParseState)
-parseSource prep sourceFileName
-  = case runParser sourceFile emptyState sourceFileName prep of
+parseSource :: String -> String -> ParseState -> IO (A.Process, ParseState)
+parseSource prep sourceFileName state
+  = case runParser sourceFile state sourceFileName prep of
       Left err -> die $ "Parse error: " ++ show err
       Right result -> return result
 --}}}

fco2/ParseState.hs

@@ -7,11 +7,20 @@ import Control.Monad.State
 import qualified AST as A
 import Metadata
 
+data Flag = ParseOnly | Verbose | Debug
+  deriving (Eq, Show, Data, Typeable)
+
 -- | State necessary for compilation.
 data ParseState = ParseState {
+    -- Set by Main
+    psFlags :: [Flag],
+
+    -- Set by Parse
     psLocalNames :: [(String, A.Name)],
     psNames :: [(String, A.NameDef)],
     psNameCounter :: Int,
+
+    -- Set by passes
     psNonceCounter :: Int,
     psFunctionReturns :: [(String, [A.Type])],
     psPulledItems :: [A.Process -> A.Process],
@@ -25,9 +34,12 @@ instance Show (A.Process -> A.Process) where
 
 emptyState :: ParseState
 emptyState = ParseState {
+    psFlags = [],
+
     psLocalNames = [],
     psNames = [],
     psNameCounter = 0,
+
     psNonceCounter = 0,
     psFunctionReturns = [],
     psPulledItems = [],

fco2/Pass.hs

@@ -6,6 +6,7 @@ import System.IO
 
 import qualified AST as A
 import ParseState
+import PrettyShow
 
 type PassM a = StateT ParseState IO a
 
@@ -14,15 +15,43 @@ type Pass = A.Process -> PassM A.Process
 runPass :: Pass -> A.Process -> ParseState -> IO (A.Process, ParseState)
 runPass pass ast st = runStateT (pass ast) st
 
-runPasses :: (String -> IO ()) -> [(String, Pass)] -> A.Process -> PassM A.Process
-runPasses _ [] ast = return ast
-runPasses progress ((s, p):ps) ast
-    =  do liftIO $ progress $ "{{{ " ++ s
+runPasses :: [(String, Pass)] -> A.Process -> PassM A.Process
+runPasses [] ast = return ast
+runPasses ((s, p):ps) ast
+    =  do debug $ "{{{ " ++ s
+          progress $ "- " ++ s 
           ast' <- p ast
-          liftIO $ progress $ "}}}"
-          ast'' <- runPasses progress ps ast'
-          return ast''
+          debugAST ast'
+          debug $ "}}}"
+          runPasses ps ast'
+
+progress :: String -> PassM ()
+progress s
+    =  do ps <- get
+          liftIO $ progressIO ps s
+
+progressIO :: ParseState -> String -> IO ()
+progressIO ps s = when (Verbose `elem` psFlags ps) $ hPutStrLn stderr s
 
 debug :: String -> PassM ()
-debug s = liftIO $ hPutStrLn stderr s
+debug s
+    =  do ps <- get
+          liftIO $ debugIO ps s
+
+debugIO :: ParseState -> String -> IO ()
+debugIO ps s = when (Debug `elem` psFlags ps) $ hPutStrLn stderr s
+
+debugASTIO :: ParseState -> A.Process -> IO ()
+debugASTIO ps p
+    =  do debugIO ps $ "{{{ AST"
+          debugIO ps $ pshow p
+          debugIO ps $ "}}}"
+          debugIO ps $ "{{{ State"
+          debugIO ps $ pshow ps
+          debugIO ps $ "}}}"
+
+debugAST :: A.Process -> PassM ()
+debugAST p
+    =  do ps <- get
+          liftIO $ debugASTIO ps p
 

fco2/SimplifyExprs.hs

@@ -12,7 +12,12 @@ import Types
 import Pass
 
 simplifyExprs :: A.Process -> PassM A.Process
-simplifyExprs p = functionsToProcs p >>= pullUp
+simplifyExprs = runPasses passes
+  where
+    passes =
+      [ ("Convert FUNCTIONs to PROCs", functionsToProcs)
+      , ("Pull up definitions", pullUp)
+      ]
 
 -- | Convert FUNCTION declarations to PROCs.
 functionsToProcs :: Data t => t -> PassM t

fco2/SimplifyProcs.hs

@@ -13,9 +13,12 @@ import Types
 import Pass
 
 simplifyProcs :: A.Process -> PassM A.Process
-simplifyProcs p
-    = parsToProcs p
-       >>= removeParAssign
+simplifyProcs = runPasses passes
+  where
+    passes =
+      [ ("Wrap PAR subprocesses in PROCs", parsToProcs)
+      , ("Remove parallel assignment", removeParAssign)
+      ]
 
 -- | Wrap the subprocesses of PARs in no-arg PROCs.
 parsToProcs :: Data t => t -> PassM t

fco2/TODO

@@ -1,15 +1,7 @@
 To-do list for FCO
 ------------------
 
-Have a "compiler options" field in ParseState, which can contain things like:
-- whether -v is on (which avoids needing to pass "progress" around -- and means
-  we can have a pass composition operator)
-- optional tracing in passes
-- whether to compile out overflow/bounds checks
-
-(Then things get proper names and we can write a genAssignment function that
-handles different types.)
- - and then array assignment can be made to work properly.
+Add an option for whether to compile out overflow/bounds checks.
 
 Have a final pass that checks all the mangling has been done -- i.e. function
 calls have been removed, and so on.

fco2/Unnest.hs

@@ -13,10 +13,13 @@ import Types
 import Pass
 
 unnest :: A.Process -> PassM A.Process
-unnest p
-    = removeFreeNames p
-       >>= removeNesting
-       >>= removeNoSpecs
+unnest = runPasses passes
+  where
+    passes =
+      [ ("Convert free names to arguments", removeFreeNames)
+      , ("Pull nested definitions to top level", removeNesting)
+      , ("Clean up removed specifications", removeNoSpecs)
+      ]
 
 type NameMap = Map.Map String A.Name