diff --git a/Main.hs b/Main.hs index 6f7c3bc..ee39c3f 100644 --- a/Main.hs +++ b/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" - BackendCPPCSP -> ".cpp" + BackendC -> ".tock.c" + BackendCPPCSP -> ".tock.cpp" _ -> "" -- Translate input file to C/C++ let cFile = outputFile ++ extension - hFile = outputFile ++ ".h" - iFile = outputFile ++ ".inc" + hFile = outputFile ++ ".tock.h" + 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" - oFile = outputFile ++ ".o" - postHFile = outputFile ++ "_post.h" - postCFile = outputFile ++ "_post.c" - postOFile = outputFile ++ "_post.o" + let sFile = outputFile ++ ".tock.s" + oFile = outputFile ++ ".tock.o" + sizesFile = outputFile ++ ".tock.sizes" + postCFile = outputFile ++ ".tock_post.c" + 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 $ - "#include \"" ++ postHFile ++ "\"\n" + withOutputFile postCFile $ \h -> + 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 + diff --git a/backends/AnalyseAsm.hs b/backends/AnalyseAsm.hs index 008f8c4..4ebda6d 100644 --- a/backends/AnalyseAsm.hs +++ b/backends/AnalyseAsm.hs @@ -24,9 +24,10 @@ with this program. If not, see . 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 - | Remote String - | Max [StackInfo] - | Plus StackInfo StackInfo - deriving (Show, Data, Typeable) + = StackInfo + { fixed :: Integer + , occamExt :: Set.Set (Either Integer String) + , otherExt :: Set.Set String + } + 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 (Max as) = foldl Set.union Set.empty $ map findAllDependencies as -findAllDependencies (Plus a b) = findAllDependencies a `Set.union` findAllDependencies b -findAllDependencies _ = Set.empty +findAllDependencies (StackInfo _ a b) + = Set.union (Set.mapMonotonic (\(Right x) -> x) $ Set.filter isRight a) b + where +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, --- 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 +substitute :: Integer -> [(String, StackInfo)] -> [(String, Integer)] +substitute unknownSize origItems = substitute' [] origItems 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 + substitute' :: [(String, Integer)] -> [(String, StackInfo)] -> [(String, Integer)] + substitute' acc [] = acc + substitute' acc 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) - | (item, deps) <- rest] + = substitute' (acc++newAcc) + [(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] - - let lines = -- Can't remember if max is a standard function so let's make our own: - "#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" + return $ unlines $ map (show . DependsOnModule) deps ++ + [show (s, st) | (s, (FunctionInfo {fiTotalStack=Just st})) + <- Map.toList $ filterNames info] 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]) +-- The String is the contents of the stack sizes file for the last one in the chain, +-- straight from analyseAsm. The function is used to read in files when needed, +-- by looking in the search path. The Int is the unknown-stack-size. +-- +-- The output is the contents of a C file with all the stack sizes. +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 - -- 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 + split :: [String] -> ([String], [(String, StackInfo)]) + split [] = ([], []) + split (l:ls) = case (reads l, reads l) of + ([(DependsOnModule dep, rest)], []) | all isSpace rest -> transformPair (dep:) id $ split ls + ([], [(s, rest)]) | all isSpace rest -> transformPair id (s:) $ split ls + _ -> error $ "Cannot parse line: " ++ l - makeMax a b = "TOCK_MAX(" ++ a ++ "," ++ b ++ ")" - - isNotFixed (Fixed {}) = False - isNotFixed _ = True + toC :: [(String, Integer)] -> String + toC info = unlines [ "const int " ++ nm ++ "_stack_size = " ++ show s ++ ";\n" + | (nm, s) <- info] diff --git a/data/CompState.hs b/data/CompState.hs index f55a0ac..3185dc5 100644 --- a/data/CompState.hs +++ b/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 diff --git a/frontends/PreprocessOccam.hs b/frontends/PreprocessOccam.hs index cca5fc3..73aff21 100644 --- a/frontends/PreprocessOccam.hs +++ b/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