Reworked how stack sizes are calculated, and changed how we use them in the build process

Now that we support separate compilation, some of the stack sizes for PROCs depend on the stack sizes of other PROCs that were compiled in different files.  We can't just assume the default 512 bytes for these "foreign" PROCs, because that often won't be enough.  So instead, we must make the stack sizes for the current PROCs depend on (i.e. use in the calculation) the stack sizes of the foreign PROCs.

This dependence adds some issues though.  We cannot declare in one C file a const int that depends on the value of an extern const int from another C file (not valid C, it seems).  So instead, we move all the stack size declarations to header files, and use #includes and the preprocessor to make sure that the stack sizes are statically determined.

This in turn simplifies the build process in some ways.  These headers only need to be compiled by the .occ file that has the main process, by including them all into a C file and compiling that as before.  It means that each .occ file only has one .o file resulting (plus two C headers*, and a .inc file) so linking is a bit less confusing.

* I am keeping the two C headers for now, rather than appending the sizes one to the normal header, because I'm not entirely sure whether having one header that the C file depends on may trigger a recompilation that we don't want in some build systems.  I can always merge them later if that's not a valid worry.

Main.hs

@@ -265,12 +265,11 @@ compileFull inputFile moutputFile
           when (csRunIndent optsPS) $
             exec $ "indent " ++ cFile
 
-          shouldLink <- lift getCompState >>* csHasMain
-
           case csBackend optsPS of
             BackendC ->
               let sFile = outputFile ++ ".s"
                   oFile = outputFile ++ ".o"
+                  postHFile = outputFile ++ "_post.h"
                   postCFile = outputFile ++ "_post.c"
                   postOFile = outputFile ++ "_post.o"
                   occFile = outputFile ++ "_wrapper.occ"
@@ -281,20 +280,20 @@ compileFull inputFile moutputFile
                  exec $ cAsmCommand cFile sFile (csCompilerFlags optsPS)
                  exec $ cCommand sFile oFile (csCompilerFlags optsPS)
                  -- Analyse the assembly for stack sizes, and output a
-                 -- "post" C file
+                 -- "post" H file
-                 lift $ withOutputFile postCFile $ \h -> postCAnalyse sFile ((h,intErr),intErr)
+                 lift $ withOutputFile postHFile $ \h -> postCAnalyse sFile ((h,intErr),intErr)
+
+                 cs <- lift getCompState
+                 when (csHasMain optsPS) $ do
+                   lift $ withOutputFile postCFile $ \h -> liftIO $ hPutStr h $
+                     "#include \"" ++ postHFile ++ "\"\n"
                    -- Compile this new "post" C file into an object file
                    exec $ cCommand postCFile postOFile (csCompilerFlags optsPS)
 
-                 cs <- lift getCompState
+                   let otherOFiles = [usedFile ++ ".tock.o"
-                 let otherOFiles = concat [[usedFile ++ ".tock.o"
-                                           ,usedFile ++ ".tock_post.o"
-                                           ]
                                      | usedFile <- Set.toList $ csUsedFiles cs]
                    
-
                    -- Link the object files into a binary
-                 when shouldLink $
                    exec $ cLinkCommand (oFile : postOFile : otherOFiles) outputFile (csCompilerLinkFlags optsPS)
 
             -- For C++, just compile the source file directly into a binary

backends/AnalyseAsm.hs

@@ -41,6 +41,7 @@ import CompState
 import Errors
 import Pass
 import PrettyShow
+import Utils
 
 -- | Interesting things that we might find in the assembly source.
 data AsmItem =
@@ -103,10 +104,24 @@ parseAsm :: String -> [AsmItem]
 parseAsm asm
   = catMaybes [parseAsmLine l | l <- lines asm]
 
+data StackInfo
+  = Fixed Int
+  | Remote String
+  | Max [StackInfo]
+  | Plus StackInfo StackInfo
+  deriving (Show, Data, Typeable)
+
+findAllDependencies :: StackInfo -> Set.Set String
+findAllDependencies (Remote s) = Set.singleton s
+findAllDependencies (Max as) = foldl Set.union Set.empty $  map findAllDependencies as
+findAllDependencies (Plus a b) = findAllDependencies a `Set.union` findAllDependencies b
+findAllDependencies _ = Set.empty
+
+
 -- | Information about defined functions.
 data FunctionInfo = FunctionInfo {
     fiStack :: Int
-  , fiTotalStack :: Int
+  , fiTotalStack :: Maybe StackInfo
   , fiCalls :: Set.Set String
   }
   deriving (Show, Data, Typeable)
@@ -114,13 +129,16 @@ data FunctionInfo = FunctionInfo {
 emptyFI :: FunctionInfo
 emptyFI = FunctionInfo {
     fiStack = 0
-  , fiTotalStack = -1
+  , fiTotalStack = Nothing
   , fiCalls = Set.empty
   }
 
 -- | Monad for `AnalyseAsm` operations.
 type AAM = StateT (Map.Map String FunctionInfo) PassM
 
+instance CSMR AAM where
+  getCompState = lift getCompState
+
 -- | Collect information about each function that's been defined.
 collectInfo :: [AsmItem] -> AAM ()
 collectInfo ais = collectInfo' ais ""
@@ -156,34 +174,67 @@ baseStackSize :: Int
 baseStackSize = 32
 
 -- | Add the stack sizes for called functions to their callers.
-addCalls :: Int -> AAM ()
+addCalls :: [String] -> Int -> AAM ()
-addCalls unknownSize
+addCalls knownProcs unknownSize
     =  do fmap <- get
-          sequence_ $ map computeStack (Map.keys fmap)
+          sequence_ $ map (computeStack True) (Map.keys fmap)
   where
-    computeStack :: String -> AAM Int
+    computeStack :: Bool -> String -> AAM StackInfo
-    computeStack func
+    computeStack processUser func
         =  do fmap <- get
               let fi = Map.findWithDefault emptyFI func fmap
               let tstack = fiTotalStack fi
-              tstack' <- if Map.member func fmap
+              tstack' <- if Map.member func fmap && processUser
-                           then (if tstack == -1
+                           then (case tstack of
-                                   then userFunc fi
+                                   Nothing -> userFunc fi
-                                   else return tstack)
+                                   Just x -> return x)
                            else systemFunc func
-              modify $ Map.insert func (fi { fiTotalStack = tstack' })
+              when processUser $ modify $ Map.insert func (fi { fiTotalStack = Just tstack' })
               return tstack'
 
-    systemFunc :: String -> AAM Int
+    systemFunc :: String -> AAM StackInfo
     systemFunc func
-        =  do lift $ warnPlainP WarnInternal $ "Unknown function " ++ func ++ "; allocating " ++ show unknownSize ++ " bytes stack"
+        =  do cs <- getCompState
-              return unknownSize
+              fmap <- get
+              if func `elem` (map fst (csExternals cs) ++ knownProcs)
+                then do return $ Remote $ func
+                else do lift $ warnPlainP WarnInternal $ "Unknown function " ++ func
+                          ++ "; allocating " ++ show unknownSize ++ " bytes stack"
+                        return $ Fixed unknownSize
 
-    userFunc :: FunctionInfo -> AAM Int
+    userFunc :: FunctionInfo -> AAM StackInfo
     userFunc fi
         =  do let localStack = fiStack fi + baseStackSize
-              calledStacks <- mapM computeStack $ Set.toList $ fiCalls fi
+              calledStacks <- mapM (computeStack False) $ Set.toList $ fiCalls fi
-              return $ localStack + maximum (0 : calledStacks)
+              return $ Fixed localStack `Plus` Max (Fixed 0 : calledStacks)
+
+-- I don't think we can use sortBy here because we only have a partial ordering,
+-- not a total ordering (transitivity, for one, isn't automatic).
+--
+-- 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`
+      (maybe Set.empty findAllDependencies $ fiTotalStack $ snd item)) | item <- origItems]
+
+    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]
+      | otherwise
+         = firstItems ++ dependenceSort' [(item, deps `Set.difference` ignore)
+                                         | (item, deps) <- rest]
+      where
+        (firstItems, rest) = partition (Set.null . snd) items
+
+        ignore = Set.fromList $ map (fst . fst) firstItems
+      
 
 -- | Analyse assembler and return C source defining sizes.
 analyseAsm :: Maybe [String] -> String -> PassM String
@@ -191,16 +242,54 @@ analyseAsm mprocs asm
   =  do let stream = parseAsm asm
         veryDebug $ pshow stream
         cs <- getCompState
-        info <- execStateT (collectInfo stream >> addCalls (csUnknownStackSize cs)) Map.empty
+        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 $ concat [printf "  %-40s %5d %5d %s\n"
+--        debug $ concat [printf "  %-40s %5d %5d %s\n"
-                          func (fiStack fi) (fiTotalStack fi)
+--                          func (fiStack fi) (fiTotalStack fi)
-                          (concat $ intersperse " " $ Set.toList $ fiCalls fi)
+--                          (concat $ intersperse " " $ Set.toList $ fiCalls fi)
-                        | (func, fi) <- Map.toList $ filterNames info]
+--                        | (func, fi) <- Map.toList $ filterNames info]
-        let lines = ["const int " ++ func ++ "_stack_size = " ++ show (fiTotalStack fi) ++ ";\n"
+
-                     | (func, fi) <- Map.toList $ filterNames info]
+        let lines =  -- Can't remember if max is a standard function so let's make our own:
-        return $ concat lines
+                     "#ifndef TOCK_MAX\n#define TOCK_MAX(x,y) ((x) > (y) ? (x) : (y))\n#endif\n" :
+                     ["#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])
+    findAllPlus (Fixed n) = (n, [])
+    findAllPlus (Plus a b) = findAllPlus a `with` findAllPlus b
+      where
+        with (m, as) (n, bs) = (m + n, as ++ bs)
+    findAllPlus a = (0, [a])
+
+    -- Without  the simplifications in this function, the nesting of TOCK_MAX (and
+    -- its exponentially-sized expansion) was blowing the mind of the C compiler,
+    -- and the memory of my machine.
+    toC :: StackInfo -> String
+    toC (Fixed n) = show n
+    toC (Remote s) = s ++ "_stack_size_CPP"
+    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 ++ ")"
+
+        isNotFixed (Fixed {}) = False
+        isNotFixed _ = True

backends/GenerateC.hs

@@ -164,16 +164,12 @@ generateC = generate cgenOps
 needStackSizes :: (CSMR m, Die m) => m [A.Name]
 needStackSizes
   = do cs <- getCompState
-       main <- if csHasMain cs
+       return $ nub $ ([A.Name emptyMeta $ nameString $ A.Name emptyMeta n
-                  then tlpInterface >>* fst >>* singleton
-                  else return []
-       return $ nub $ (Set.toList $ csParProcs cs `Set.difference`
-                                      Set.fromList (map (A.Name emptyMeta . fst) (csExternals cs)))
-                ++ [A.Name emptyMeta n
                        | A.NameDef {A.ndName = n
-                               ,A.ndSpecType=A.Proc _ (_,A.Recursive) _ _
+                                   ,A.ndSpecType=A.Proc {}
                                    } <- Map.elems $ csNames cs]
-                ++ main
+                      )
+                      \\ (map (A.Name emptyMeta . nameString . A.Name emptyMeta . fst) (csExternals cs))
 
 cgenTopLevel :: String -> A.AST -> CGen ()
 cgenTopLevel headerName s