Reworked how the stack sizes are recorded and merged together

The previous method, using the C preprocessor was both nasty, and crazily resource-intensive.  The new method stores stack size information in files that are read in and processed by the compiler when it comes time to link.

Main.hs

@@ -226,7 +226,7 @@ main = do
     Left str -> putStrLn str
     Right initState -> do
       let operation = case csMode initState of
-            ModePostC -> useOutputOptions (postCAnalyse fn)
+            ModePostC -> useOutputOptions (postCAnalyse fn) >> return ()
             ModeFull -> evalStateT (compileFull fn fileStem) []
             mode -> useOutputOptions (compile mode fn)
 
@@ -266,19 +266,19 @@ compileFull inputFile moutputFile
                           -- using a stem (input file minus known extension).
                           -- If the extension isn't known, the user must specify
                           -- the output file
-                          ("-", Just file) -> return $ file ++ ".tock"
+                          ("-", Just file) -> return $ file
                           ("-", Nothing) -> dieReport (Nothing, "Must specify an output file when using full-compile mode")
                           (file, _) -> return file
 
           let extension = case csBackend optsPS of
-                            BackendC -> ".c"
+                            BackendC -> ".tock.c"
-                            BackendCPPCSP -> ".cpp"
+                            BackendCPPCSP -> ".tock.cpp"
                             _ -> ""
 
           -- Translate input file to C/C++
           let cFile = outputFile ++ extension
-              hFile = outputFile ++ ".h"
+              hFile = outputFile ++ ".tock.h"
-              iFile = outputFile ++ ".inc"
+              iFile = outputFile ++ ".tock.inc"
           lift $ modify $ \cs -> cs { csOutputIncFile = Just iFile }
           lift $ withOutputFile cFile $ \hb ->
             withOutputFile hFile $ \hh ->
@@ -289,11 +289,11 @@ compileFull inputFile moutputFile
 
           case csBackend optsPS of
             BackendC ->
-              let sFile = outputFile ++ ".s"
+              let sFile = outputFile ++ ".tock.s"
-                  oFile = outputFile ++ ".o"
+                  oFile = outputFile ++ ".tock.o"
-                  postHFile = outputFile ++ "_post.h"
+                  sizesFile = outputFile ++ ".tock.sizes"
-                  postCFile = outputFile ++ "_post.c"
+                  postCFile = outputFile ++ ".tock_post.c"
-                  postOFile = outputFile ++ "_post.o"
+                  postOFile = outputFile ++ ".tock_post.o"
               in
               do sequence_ $ map noteFile $ [sFile, postCFile, postOFile]
                                ++ if csHasMain optsPS then [oFile] else []
@@ -305,12 +305,14 @@ compileFull inputFile moutputFile
                  exec $ cCommand sFile oFile (csCompilerFlags optsPS)
                  -- Analyse the assembly for stack sizes, and output a
                  -- "post" H file
-                 lift $ withOutputFile postHFile $ \h -> postCAnalyse sFile ((h,intErr),intErr)
+                 sizes <- lift $ withOutputFile sizesFile $ \h -> postCAnalyse sFile ((h,intErr),intErr)
 
                  cs <- lift getCompState
                  when (csHasMain optsPS) $ do
-                   lift $ withOutputFile postCFile $ \h -> liftIO $ hPutStr h $
+                   withOutputFile postCFile $ \h ->
-                     "#include \"" ++ postHFile ++ "\"\n"
+                     computeFinalStackSizes searchReadFile (csUnknownStackSize cs)
+                       sizes >>= (liftIO . hPutStr h)
+                     
                    -- Compile this new "post" C file into an object file
                    exec $ cCommand postCFile postOFile (csCompilerFlags optsPS)
 
@@ -341,11 +343,12 @@ compileFull inputFile moutputFile
     noteFile :: Monad m => FilePath -> StateT [FilePath] m ()
     noteFile fp = modify (\fps -> (fp:fps))
 
-    withOutputFile :: FilePath -> (Handle -> PassM ()) -> PassM ()
+    withOutputFile :: MonadIO m => FilePath -> (Handle -> m a) -> m a
     withOutputFile path func
         =  do handle <- liftIO $ openFile path WriteMode
-              func handle
+              x <- func handle
               liftIO $ hClose handle
+              return x
 
     exec :: String -> StateT [FilePath] PassM ()
     exec cmd = do lift $ progress $ "Executing command: " ++ cmd
@@ -355,8 +358,13 @@ compileFull inputFile moutputFile
                     ExitSuccess -> return ()
                     ExitFailure n -> dieReport (Nothing, "Command \"" ++ cmd ++ "\" failed: exited with code: " ++ show n)
 
+    searchReadFile :: String -> StateT [FilePath] PassM String
+    searchReadFile fn = do (h, _) <- lift $ searchFile emptyMeta (fn++".tock.sizes")
+                           liftIO $ hGetContents h
+                           -- Don't use hClose because hGetContents is lazy
+
 -- | Picks out the handle from the options and passes it to the function:
-useOutputOptions :: (((Handle, Handle), String) -> PassM ()) -> PassM ()
+useOutputOptions :: (((Handle, Handle), String) -> PassM a) -> PassM a
 useOutputOptions func
   =  do optsPS <- get
         withHandleFor (csOutputFile optsPS) $ \hb ->
@@ -367,8 +375,9 @@ useOutputOptions func
     withHandleFor file func =
             do progress $ "Writing output file " ++ file
                f <- liftIO $ openFile file WriteMode
-               func f
+               x <- func f
                liftIO $ hClose f
+               return x
 
 
 showTokens :: Bool -> [Token] -> String
@@ -472,14 +481,17 @@ compile mode fn (outHandles@(outHandle, _), headerName)
         progress "Done"
 
 -- | Analyse an assembly file.
-postCAnalyse :: String -> ((Handle, Handle), String) -> PassM ()
+postCAnalyse :: String -> ((Handle, Handle), String) -> PassM String
 postCAnalyse fn ((outHandle, _), _)
     =  do asm <- liftIO $ readFile fn
 
           names <- needStackSizes
+          cs <- getCompState
 
           progress "Analysing assembly"
-          output <- analyseAsm (Just $ map A.nameName names) asm
+          output <- analyseAsm (Just $ map A.nameName names) (Set.toList $ csUsedFiles cs) asm
 
           liftIO $ hPutStr outHandle output
 
+          return output
+

backends/AnalyseAsm.hs

@@ -24,9 +24,10 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 module AnalyseAsm (
     AsmItem(..),
-    parseAsmLine, analyseAsm
+    parseAsmLine, analyseAsm, computeFinalStackSizes
   ) where
 
+import Control.Arrow
 import Control.Monad.State
 import Data.Char
 import Data.Generics
@@ -46,7 +47,7 @@ import Utils
 -- | Interesting things that we might find in the assembly source.
 data AsmItem =
   AsmLabel String
-  | AsmStackInc Int
+  | AsmStackInc Integer
   | AsmCall String
   deriving (Show, Eq, Data, Typeable)
 
@@ -104,23 +105,56 @@ parseAsm :: String -> [AsmItem]
 parseAsm asm
   = catMaybes [parseAsmLine l | l <- lines asm]
 
+data Depends
+  = DependsOnModule String
+  deriving (Show, Read)
+
+-- The stack is the fixed amount, plus the maximum of all other dependencies
 data StackInfo
-  = Fixed Int
+  = StackInfo
-  | Remote String
+    { fixed :: Integer
-  | Max [StackInfo]
+    , occamExt :: Set.Set (Either Integer String)
-  | Plus StackInfo StackInfo
+    , otherExt :: Set.Set String
-  deriving (Show, Data, Typeable)
+    }
+    deriving (Data, Typeable)
+
+instance Show StackInfo where
+  show (StackInfo f occ ext)
+    = "(StackInfo " ++ show f ++ " " ++ show (Set.toList occ)
+        ++ " " ++ show (Set.toList ext) ++ ")"
+
+instance Read StackInfo where
+  readsPrec _
+    = readParen True $ \whole -> do
+        -- Let's see if I can figure out the list monad.  Each binding will bind
+        -- one item from a list (of possibles), and then the subsequent part of
+        -- the do will be carried out for that possibility.
+        args123 <- readExact "StackInfo" whole >>* dropSpaces
+        (n, args23) <- reads args123
+        (occ, arg3) <- reads $ dropSpaces args23
+        (ext, rest) <- reads $ dropSpaces arg3
+        return (StackInfo n (Set.fromList occ) (Set.fromList ext), rest)
+   where
+    readExact :: String -> String -> [String]
+    readExact ex str
+      | ex `isPrefixOf` str = [drop (length ex) str]
+      | otherwise = []
+
+    dropSpaces :: String -> String
+    dropSpaces = dropWhile isSpace
 
 findAllDependencies :: StackInfo -> Set.Set String
-findAllDependencies (Remote s) = Set.singleton s
+findAllDependencies (StackInfo _ a b)
-findAllDependencies (Max as) = foldl Set.union Set.empty $  map findAllDependencies as
+  = Set.union (Set.mapMonotonic (\(Right x) -> x) $ Set.filter isRight a) b
-findAllDependencies (Plus a b) = findAllDependencies a `Set.union` findAllDependencies b
+  where
-findAllDependencies _ = Set.empty
 
+isRight :: Either a b -> Bool
+isRight (Right _) = True
+isRight (Left _) = False
 
 -- | Information about defined functions.
 data FunctionInfo = FunctionInfo {
-    fiStack :: Int
+    fiStack :: Integer
   , fiTotalStack :: Maybe StackInfo
   , fiCalls :: Set.Set String
   }
@@ -170,11 +204,11 @@ collectInfo ais = collectInfo' ais ""
 -- | Additional stack size to give to all functions.
 -- This is necessary because CCSP does odd things with the provided stack
 -- size; it doesn't calculate the space that it needs for the arguments.
-baseStackSize :: Int
+baseStackSize :: Integer
 baseStackSize = 32
 
 -- | Add the stack sizes for called functions to their callers.
-addCalls :: [String] -> Int -> AAM ()
+addCalls :: [String] -> Integer -> AAM ()
 addCalls knownProcs unknownSize
     =  do fmap <- get
           sequence_ $ map (computeStack True) (Map.keys fmap)
@@ -197,99 +231,108 @@ addCalls knownProcs unknownSize
         =  do cs <- getCompState
               fmap <- get
               if func `elem` (map fst (csExternals cs) ++ knownProcs)
-                then do return $ Remote $ func
+                then do return $ StackInfo
+                          { fixed = 0
+                          , occamExt = Set.singleton (Right func)
+                          , otherExt = Set.empty
+                          }
                 else do lift $ warnPlainP WarnInternal $ "Unknown function " ++ func
                           ++ "; allocating " ++ show unknownSize ++ " bytes stack"
-                        return $ Fixed unknownSize
+                        return $ StackInfo
+                          { fixed = 0
+                          , occamExt = Set.empty
+                          , otherExt = Set.singleton func
+                          }
 
     userFunc :: FunctionInfo -> AAM StackInfo
     userFunc fi
         =  do let localStack = fiStack fi + baseStackSize
               calledStacks <- mapM (computeStack False) $ Set.toList $ fiCalls fi
-              return $ Fixed localStack `Plus` Max (Fixed 0 : calledStacks)
+              return $ foldl mergeStackInfo (StackInfo localStack Set.empty Set.empty) calledStacks
+     where
+       mergeStackInfo (StackInfo n as bs) (StackInfo n' as' bs')
+         = StackInfo (n + n') (as `Set.union` as') (bs `Set.union` bs')
 
--- I don't think we can use sortBy here because we only have a partial ordering,
+substitute :: Integer -> [(String, StackInfo)] -> [(String, Integer)]
--- not a total ordering (transitivity, for one, isn't automatic).
+substitute unknownSize origItems = substitute' [] origItems
---
--- So our plan is as follows.  We calculate all the dependencies for each item.
--- We put all the items with no dependents first, and then we recurse, removing
--- all the no-dependent items from the dependencies of the others. 
-dependenceSort :: Set.Set String -> [(String, FunctionInfo)] -> [(String, FunctionInfo)]
-dependenceSort ofInterest origItems = map fst $ dependenceSort' itemsWithDependents
   where
-    itemsWithDependents = [(item, ofInterest `Set.intersection`
+    substitute' :: [(String, Integer)] -> [(String, StackInfo)] -> [(String, Integer)]
-      (maybe Set.empty findAllDependencies $ fiTotalStack $ snd item)) | item <- origItems]
+    substitute' acc [] = acc
-
+    substitute' acc items
-    dependenceSort' :: [((String, FunctionInfo), Set.Set String)]
-      -> [((String, FunctionInfo), Set.Set String)]
-    dependenceSort' [] = []
-    dependenceSort' items
       | null firstItems -- Infinite loop if we don't stop it:
          = error $ "Cyclic dependencies in stack sizes: "
-           ++ show [n ++ " depends on " ++ show deps | ((n, _), deps) <- rest]
+           ++ show [n ++ " depends on " ++ show (occamExt s) | (n, s) <- rest]
+           ++ " done processes are: " ++ show (map fst origItems \\ map fst rest)
       | otherwise
-         = firstItems ++ dependenceSort' [(item, deps `Set.difference` ignore)
+         = substitute' (acc++newAcc)
-                                         | (item, deps) <- rest]
+             [(item, s { occamExt = Set.map subAll $ occamExt s })
+             | (item, s) <- rest]
       where
-        (firstItems, rest) = partition (Set.null . snd) items
+        (firstItems, rest) = partition (Set.null . Set.filter isRight . occamExt
+          . snd) items
 
-        ignore = Set.fromList $ map (fst . fst) firstItems
+        newAcc = map (second getFixed) firstItems
+
+        -- We know occamExt must be all Lefts:
+        getFixed (StackInfo {fixed = fix, occamExt = occ, otherExt = ext})
+          = fix + maximum ((if Set.null ext then 0 else unknownSize)
+                           : [n | Left n <- Set.toList occ])
+
+        subAll (Left n) = Left n
+        subAll (Right n) = case lookup n newAcc of
+                             Nothing -> Right n
+                             Just s -> Left s
       
 
 -- | Analyse assembler and return C source defining sizes.
-analyseAsm :: Maybe [String] -> String -> PassM String
+--
-analyseAsm mprocs asm
+-- The first parameter is a possible list of occam PROCs, so we know which stuff
+-- to mark as occam and which to mark as unknown external.
+--
+-- The return value is a string to be written to a file, that can later be read
+-- in and understood by computeFinalStackSizes
+analyseAsm :: Maybe [String] -> [String] -> String -> PassM String
+analyseAsm mprocs deps asm
   =  do let stream = parseAsm asm
         veryDebug $ pshow stream
         cs <- getCompState
-        let unique = concat [if c `elem` (['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'])
-                               then [c]
-                               else '_' : show (ord c)
-                            | c <- csCurrentFile cs]
         info <- execStateT (collectInfo stream >> addCalls (fromMaybe [] mprocs) (csUnknownStackSize cs)) Map.empty
-        debug $ "Analysed function information:"
+--        debug $ "Analysed function information:"
 --        debug $ concat [printf "  %-40s %5d %5d %s\n"
 --                          func (fiStack fi) (fiTotalStack fi)
 --                          (concat $ intersperse " " $ Set.toList $ fiCalls fi)
 --                        | (func, fi) <- Map.toList $ filterNames info]
-
+        return $ unlines $ map (show . DependsOnModule) deps ++
-        let lines =  -- Can't remember if max is a standard function so let's make our own:
+          [show (s, st) | (s, (FunctionInfo {fiTotalStack=Just st}))
-                     "#ifndef TOCK_MAX\n#define TOCK_MAX(x,y) ((x) > (y) ? (x) : (y))\n#endif\n" :
+                                           <- Map.toList $ filterNames info]
-                     ["#include \"" ++ f ++ ".tock_post.h\"\n"
-                     | f <- Set.toList $ csUsedFiles cs] ++
-                     ["#define " ++ func ++ "_stack_size_CPP "
-                         ++ maybe "#error Unknown!" toC (fiTotalStack fi) ++ "\n"
-                     ++ "const int " ++ func ++ "_stack_size = "  ++ func ++ "_stack_size_CPP;\n"
-                     | (func, fi) <- dependenceSort (maybe Set.empty Set.fromList mprocs) $ Map.toList $ filterNames info]
-        return $ "#ifndef INCLUDED_" ++ unique ++ "\n#define INCLUDED_" ++ unique
-          ++ "\n" ++ concat lines ++ "\n#endif\n"
   where
     filterNames = case mprocs of
       Nothing -> id
       Just m -> (`Map.intersection` (Map.fromList (zip m (repeat ()))))
 
-    findAllPlus :: StackInfo -> (Int, [StackInfo])
+-- The String is the contents of the stack sizes file for the last one in the chain,
-    findAllPlus (Fixed n) = (n, [])
+-- straight from analyseAsm.  The function is used to read in files when needed,
-    findAllPlus (Plus a b) = findAllPlus a `with` findAllPlus b
+-- by looking in the search path.  The Int is the unknown-stack-size.
-      where
+--
-        with (m, as) (n, bs) = (m + n, as ++ bs)
+-- The output is the contents of a C file with all the stack sizes.
-    findAllPlus a = (0, [a])
+computeFinalStackSizes :: forall m. Monad m => (String -> m String) -> Integer -> String -> m String
+computeFinalStackSizes readSizesFor unknownSize beginSizes
+  = do infos <- readInAll beginSizes
+       let finalised = substitute unknownSize infos
+       return $ toC finalised
+  where
+    readInAll :: String -> m [(String, StackInfo)]
+    readInAll contents
+      = let (deps, info) = split (lines contents)
+        in concatMapM (readInAll <.< readSizesFor) deps >>* (++ info)
 
-    -- Without  the simplifications in this function, the nesting of TOCK_MAX (and
+    split :: [String] -> ([String], [(String, StackInfo)])
-    -- its exponentially-sized expansion) was blowing the mind of the C compiler,
+    split [] = ([], [])
-    -- and the memory of my machine.
+    split (l:ls) = case (reads l, reads l) of
-    toC :: StackInfo -> String
+      ([(DependsOnModule dep, rest)], []) | all isSpace rest -> transformPair (dep:) id $ split ls
-    toC (Fixed n) = show n
+      ([], [(s, rest)]) | all isSpace rest -> transformPair id (s:) $ split ls
-    toC (Remote s) = s ++ "_stack_size_CPP"
+      _ -> error $ "Cannot parse line: " ++ l
-    toC x@(Plus {}) = let (m, as) = findAllPlus x in
-      (if m == 0 then id else \x -> "(" ++ show m ++ "+" ++ x ++ ")") $
-        concat (intersperse "+" $ map toC as) 
-    toC (Max as) = foldl makeMax (show fixed) (map toC other)
-      where
-        fixed = maximum [n | Fixed n <- as]
-        other = filter isNotFixed as
 
-        makeMax a b = "TOCK_MAX(" ++ a ++ "," ++ b ++ ")"
+    toC :: [(String, Integer)] -> String
-
+    toC info = unlines [ "const int " ++ nm ++ "_stack_size = " ++ show s ++ ";\n"
-        isNotFixed (Fixed {}) = False
+                       | (nm, s) <- info]
-        isNotFixed _ = True

data/CompState.hs

@@ -29,6 +29,7 @@ import qualified Data.Map as Map
 import Data.Maybe
 import Data.Set (Set)
 import qualified Data.Set as Set
+import System.IO
 
 import qualified AST as A
 import Errors (Die, dieP, ErrorReport, Warn, WarningType(..), warnP, WarningReport)
@@ -116,7 +117,7 @@ data CompState = CompState {
     csEnabledWarnings :: Set WarningType,
     csRunIndent :: Bool,
     csClassicOccamMobility :: Bool,
-    csUnknownStackSize :: Int,
+    csUnknownStackSize :: Integer,
     csSearchPath :: [String],
 
     -- Set by preprocessor
@@ -465,3 +466,20 @@ specTypeOfName :: (CSMR m, Die m) => A.Name -> m A.SpecType
 specTypeOfName n
     = liftM A.ndSpecType (lookupNameOrError n $ dieP (A.nameMeta n) $ "Could not find type in specTypeOfName for: " ++ (show $ A.nameName n))
 
+-- | Open an included file, looking for it in the search path.
+-- Return the open filehandle and the location of the file.
+searchFile :: forall m. (Die m, CSMR m, MonadIO m) => Meta -> String -> m (Handle, String)
+searchFile m filename
+    =  do cs <- getCompState
+          let currentFile = csCurrentFile cs
+          let possibilities = joinPath currentFile filename
+                              : [dir ++ "/" ++ filename | dir <- csSearchPath cs]
+          openOneOf possibilities possibilities
+  where
+    openOneOf :: [String] -> [String] -> m (Handle, String)
+    openOneOf all [] = dieP m $ "Unable to find " ++ filename ++ " tried: " ++ show all
+    openOneOf all (fn:fns)
+        =  do r <- liftIO $ maybeIO $ openFile fn ReadMode
+              case r of
+                Just h -> return (h, fn)
+                Nothing -> openOneOf all fns

frontends/PreprocessOccam.hs

@@ -41,25 +41,6 @@ import PrettyShow
 import StructureOccam
 import Utils
 
--- | Open an included file, looking for it in the search path.
--- Return the open filehandle and the location of the file.
--- FIXME: This doesn't actually look at the search path yet.
-searchFile :: Meta -> String -> PassM (Handle, String)
-searchFile m filename
-    =  do cs <- get
-          let currentFile = csCurrentFile cs
-          let possibilities = joinPath currentFile filename
-                              : [dir ++ "/" ++ filename | dir <- csSearchPath cs]
-          openOneOf possibilities possibilities
-  where
-    openOneOf :: [String] -> [String] -> PassM (Handle, String)
-    openOneOf all [] = dieP m $ "Unable to find " ++ filename ++ " tried: " ++ show all
-    openOneOf all (fn:fns)
-        =  do r <- liftIO $ maybeIO $ openFile fn ReadMode
-              case r of
-                Just h -> return (h, fn)
-                Nothing -> openOneOf all fns
-
 -- | Preprocess a file and return its tokenised form ready for parsing.
 preprocessFile :: Meta -> String -> PassM [Token]
 preprocessFile m filename