diff --git a/Main.hs b/Main.hs index be08928..aa81598 100644 --- a/Main.hs +++ b/Main.hs @@ -272,9 +272,8 @@ compile mode fn outHandle debugAST ast1 debug "}}}" - output <- - case mode of - ModeParse -> return $ pshow ast1 + case mode of + ModeParse -> liftIO $ hPutStr outHandle $ pshow ast1 ModeFlowGraph -> do procs <- findAllProcesses let fs :: Data t => t -> PassM String @@ -290,7 +289,7 @@ compile mode fn outHandle -- graphs is of course identical to graphsTyped, as you can see here: let (graphsTyped :: [Maybe (FlowGraph' Identity String A.Process)]) = map (transformMaybe fst) graphs -- TODO: output each process to a separate file, rather than just taking the first: - return $ head $ map makeFlowGraphInstr (catMaybes graphsTyped) + liftIO $ hPutStr outHandle $ head $ map makeFlowGraphInstr (catMaybes graphsTyped) ModeCompile -> do progress "Passes:" @@ -301,16 +300,12 @@ compile mode fn outHandle progress $ "- Backend: " ++ (show $ csBackend optsPS) let generator = case csBackend optsPS of - BackendC -> generateC - BackendCPPCSP -> generateCPPCSP - BackendDumpAST -> return . pshow - code <- generator ast2 + BackendC -> generateC outHandle + BackendCPPCSP -> generateCPPCSP outHandle + BackendDumpAST -> liftIO . hPutStr outHandle . pshow + generator ast2 debug "}}}" - return code - - liftIO $ hPutStr outHandle output - progress "Done" -- | Analyse an assembly file. diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index d1a1474..8c7d3b8 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -24,9 +24,8 @@ import Data.Generics import Data.List import Data.Maybe import qualified Data.Set as Set -import Control.Monad.Reader import Control.Monad.State -import Control.Monad.Writer +import System.IO import Text.Printf import Text.Regex @@ -139,10 +138,7 @@ cgenOps = GenOps { --}}} --{{{ top-level -generate :: GenOps -> A.AST -> PassM String -generate ops ast = execWriterT (runReaderT (call genTopLevel ast) ops) >>* concat - -generateC :: A.AST -> PassM String +generateC :: Handle -> A.AST -> PassM () generateC = generate cgenOps cgenTLPChannel :: TLPChannel -> CGen () @@ -153,7 +149,7 @@ cgenTLPChannel TLPError = tell ["err"] cgenTopLevel :: A.AST -> CGen () cgenTopLevel s = do tell ["#include \n"] - cs <- get + cs <- getCompState (tlpName, chans) <- tlpInterface sequence_ $ map (call genForwardDeclaration) @@ -219,7 +215,7 @@ genRightB = tell ["}"] cgenOverArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen () cgenOverArray m var func = do A.Array ds _ <- typeOfVariable var - specs <- sequence [makeNonceVariable "i" m A.Int A.VariableName A.Original | _ <- ds] + specs <- sequence [csmLift $ makeNonceVariable "i" m A.Int A.VariableName A.Original | _ <- ds] let indices = [A.Variable m n | A.Specification _ n _ <- specs] let arg = (\var -> foldl (\v s -> A.SubscriptedVariable m s v) var [A.Subscript m $ A.ExprVariable m i | i <- indices]) @@ -997,7 +993,7 @@ cgenReplicatorLoop (A.For m index base count) general :: CGen () general - = do counter <- makeNonce "replicator_count" + = do counter <- csmLift $ makeNonce "replicator_count" tell ["int ", counter, "="] call genExpression count tell [","] @@ -1192,7 +1188,7 @@ cintroduceSpec (A.Specification _ n (A.IsExpr _ am t e)) (A.ValAbbrev, A.Record _, A.Literal _ _ _) -> -- Record literals are even trickier, because there's no way of -- directly writing a struct literal in C that you can use -> on. - do tmp <- makeNonce "record_literal" + do tmp <- csmLift $ makeNonce "record_literal" tell ["const "] call genType t tell [" ", tmp, " = "] @@ -1469,7 +1465,7 @@ cgenSeq s = call genStructured s doP --{{{ if cgenIf :: Meta -> A.Structured A.Choice -> CGen () cgenIf m s - = do label <- makeNonce "if_end" + = do label <- csmLift $ makeNonce "if_end" tell ["/*",label,"*/"] genIfBody label s call genStop m "no choice matched in IF process" @@ -1533,7 +1529,37 @@ cgenWhile e p -- the same as PAR. cgenPar :: A.ParMode -> A.Structured A.Process -> CGen () cgenPar pm s - = do (count, _, _) <- constantFold $ countStructured s + = do (size, _, _) <- constantFold $ addOne (sizeOfStructured s) + pids <- makeNonce "pids" + pris <- makeNonce "priorities" + index <- makeNonce "i" + when (pm == A.PriPar) $ + do tell ["int ", pris, "["] + call genExpression size + tell ["];\n"] + tell ["Process *", pids, "["] + call genExpression size + tell ["];\n"] + tell ["int ", index, " = 0;\n"] + call genStructured s (createP pids pris index) + tell [pids, "[", index, "] = NULL;\n"] + tell ["if(",pids,"[0] != NULL){"] -- CIF seems to deadlock when you give ProcParList a list + -- beginning with NULL (i.e. with no processes) + case pm of + A.PriPar -> tell ["ProcPriParList (", pids, ", ", pris, ");\n"] + _ -> tell ["ProcParList (", pids, ");\n"] + tell ["}"] + tell [index, " = 0;\n"] + call genStructured s (freeP pids index) + where + createP pids pris index _ p + = do when (pm == A.PriPar) $ + tell [pris, "[", index, "] = ", index, ";\n"] + tell [pids, "[", index, "++] = "] + genProcAlloc p + tell [";\n"] + freeP pids index _ _ + = do tell ["ProcAllocClean (", pids, "[", index, "++]);\n"] bar <- makeNonce "par_barrier" tell ["LightProcBarrier ", bar, ";\n"] @@ -1562,15 +1588,15 @@ cgenAlt isPri s tell ["}\n"] -- Like occ21, this is always a PRI ALT, so we can use it for both. tell ["AltWait (wptr);\n"] - id <- makeNonce "alt_id" + id <- csmLift $ makeNonce "alt_id" tell ["int ", id, " = 0;\n"] tell ["{\n"] genAltDisable id s tell ["}\n"] - fired <- makeNonce "alt_fired" + fired <- csmLift $ makeNonce "alt_fired" tell ["int ", fired, " = AltEnd (wptr);\n"] tell [id, " = 0;\n"] - label <- makeNonce "alt_end" + label <- csmLift $ makeNonce "alt_end" tell ["{\n"] genAltProcesses id fired label s tell ["}\n"] diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index e1fbb61..3e08401 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -21,8 +21,10 @@ module GenerateCBased where import Control.Monad.Error import Control.Monad.Reader +import Control.Monad.State import Control.Monad.Writer import Data.Generics +import System.IO import qualified AST as A import CompState @@ -54,14 +56,26 @@ cCppCommonPreReq = --{{{ monad definition -type CGen' = WriterT [String] PassM +type CGen' = StateT (Either [String] Handle) PassM type CGen = ReaderT GenOps CGen' instance Die CGen where dieReport = throwError -instance CSMR m => CSMR (ReaderT GenOps m) where +instance CSMR CGen' where getCompState = lift getCompState + +instance CSMR CGen where + getCompState = lift getCompState + +tell :: [String] -> CGen () +tell x = do st <- get + case st of + Left prev -> put $ Left (prev ++ x) + Right h -> liftIO $ mapM_ (hPutStr h) x + +csmLift :: PassM a -> CGen a +csmLift = lift . lift --}}} -- | A function that applies a subscript to a variable. @@ -218,3 +232,5 @@ instance CGenCall (a -> b -> c -> d -> (CGen x, y -> CGen z)) where fget :: (GenOps -> a) -> CGen a fget = asks +generate :: GenOps -> Handle -> A.AST -> PassM () +generate ops h ast = evalStateT (runReaderT (call genTopLevel ast) ops) (Right h) diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index 8f656fb..18b7642 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -31,11 +31,11 @@ For channels of direction 'A.DirInput' or 'A.DirOutput' I actually pass the Chan module GenerateCPPCSP (cppcspPrereq, cppgenOps, generateCPPCSP, genCPPCSPPasses) where import Control.Monad.State -import Control.Monad.Writer import Data.Char import Data.Generics import Data.List import Data.Maybe +import System.IO import qualified AST as A import CompState @@ -116,7 +116,7 @@ chansToAny x = do st <- get --{{{ top-level -- | Transforms the given AST into a pass that generates C++ code. -generateCPPCSP :: A.AST -> PassM String +generateCPPCSP :: Handle -> A.AST -> PassM () generateCPPCSP = generate cppgenOps cppcspPrereq :: [Property] @@ -133,7 +133,7 @@ cppgenTopLevel s (name, chans) <- tlpInterface tell ["int main (int argc, char** argv) { csp::Start_CPPCSP();"] (chanType,writer) <- - do st <- get + do st <- getCompState case csFrontend st of FrontendOccam -> return ("tockSendableArrayOfBytes","StreamWriterByteArray") _ -> return ("uint8_t","StreamWriter") @@ -246,14 +246,14 @@ Otherwise, it must not have. -} genCPPCSPTime :: A.Expression -> CGen String genCPPCSPTime e - = do time <- makeNonce "time_exp" + = do time <- csmLift $ makeNonce "time_exp" tell ["unsigned ",time," = (unsigned)"] call genExpression e tell [" ; "] - curTime <- makeNonce "time_exp" - curTimeLow <- makeNonce "time_exp" - curTimeHigh <- makeNonce "time_exp" - retTime <- makeNonce "time_exp" + curTime <- csmLift $ makeNonce "time_exp" + curTimeLow <- csmLift $ makeNonce "time_exp" + curTimeHigh <- csmLift $ makeNonce "time_exp" + retTime <- csmLift $ makeNonce "time_exp" tell ["double ",curTime," = csp::GetSeconds(csp::CurrentTime());"] tell ["unsigned ",curTimeLow," = (unsigned)remainder(1000000.0 * ",curTime,",4294967296.0);"] tell ["unsigned ",curTimeHigh," = (unsigned)((1000000.0 * ",curTime,") / 4294967296.0);"] @@ -373,7 +373,7 @@ cppgenOutputCase c tag ois --We use forking instead of Run\/InParallelOneThread, because it is easier to use forking with replication. cppgenPar :: A.ParMode -> A.Structured A.Process -> CGen () cppgenPar _ s - = do forking <- makeNonce "forking" + = do forking <- csmLift $ makeNonce "forking" tell ["{ csp::ScopedForking ",forking," ; "] call genStructured s (genPar' forking) tell [" }"] @@ -394,17 +394,17 @@ cppgenPar _ s -- | Changed to use C++CSP's Alternative class: cppgenAlt :: Bool -> A.Structured A.Alternative -> CGen () cppgenAlt _ s - = do guards <- makeNonce "alt_guards" + = do guards <- csmLift $ makeNonce "alt_guards" tell ["std::list< csp::Guard* > ", guards, " ; "] initAltGuards guards s - alt <- makeNonce "alt" + alt <- csmLift $ makeNonce "alt" tell ["csp::Alternative ",alt, " ( ", guards, " ); "] - id <- makeNonce "alt_id" + id <- csmLift $ makeNonce "alt_id" tell ["int ", id, " = 0;\n"] - fired <- makeNonce "alt_fired" + fired <- csmLift $ makeNonce "alt_fired" tell ["int ", fired, " = ", alt, " .priSelect();"] - label <- makeNonce "alt_end" + label <- csmLift $ makeNonce "alt_end" tell ["{\n"] genAltProcesses id fired label s tell ["}\n"] @@ -714,7 +714,7 @@ cppgenUnfoldedVariable m var cppgenIf :: Meta -> A.Structured A.Choice -> CGen () cppgenIf m s - = do ifExc <- makeNonce "if_exc" + = do ifExc <- csmLift $ makeNonce "if_exc" tell ["class ",ifExc, "{};try{"] genIfBody ifExc s call genStop m "no choice matched in IF process" diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index cc23071..cfe08f5 100644 --- a/backends/GenerateCTest.hs +++ b/backends/GenerateCTest.hs @@ -34,7 +34,7 @@ module GenerateCTest (tests) where import Control.Monad.Error import Control.Monad.State import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.Writer hiding (tell) import Data.Generics import Data.List (isInfixOf, intersperse) import Data.Maybe (fromMaybe) @@ -109,7 +109,7 @@ evalCGen :: CGen () -> GenOps -> CompState -> IO (Either Errors.ErrorReport [Str evalCGen act ops state = evalCGen' (runReaderT act ops) state evalCGen' :: CGen' () -> CompState -> IO (Either Errors.ErrorReport [String]) -evalCGen' act state = runWriterT (evalStateT (runErrorT $ execWriterT act) state) >>* fst +evalCGen' act state = runWriterT (evalStateT (runErrorT $ execStateT act (Left []) >>* (\(Left x) -> x)) state) >>* fst -- | Checks that running the test for the C and C++ backends produces the right output for each. testBothS ::