Changed the C and C++ backends to write directly to the output file, to save building up the strings in memory

Main.hs

@@ -272,9 +272,8 @@ compile mode fn outHandle
         debugAST ast1
         debug "}}}"
 
-        output <-
         case mode of
-            ModeParse -> return $ pshow ast1
+            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
+                           BackendC -> generateC outHandle
-                           BackendCPPCSP -> generateCPPCSP
+                           BackendCPPCSP -> generateCPPCSP outHandle
-                           BackendDumpAST -> return . pshow
+                           BackendDumpAST -> liftIO . hPutStr outHandle . pshow
-                 code <- generator ast2
+                 generator ast2
                  debug "}}}"
 
-                 return code
-
-        liftIO $ hPutStr outHandle output
-
         progress "Done"
 
 -- | Analyse an assembly file.

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
+generateC :: Handle -> A.AST -> PassM ()
-generate ops ast = execWriterT (runReaderT (call genTopLevel ast) ops) >>* concat
-
-generateC :: A.AST -> PassM String
 generateC = generate cgenOps
 
 cgenTLPChannel :: TLPChannel -> CGen ()
@@ -153,7 +149,7 @@ cgenTLPChannel TLPError = tell ["err"]
 cgenTopLevel :: A.AST -> CGen ()
 cgenTopLevel s
     =  do tell ["#include <tock_support_cif.h>\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"]

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)

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"
+          curTime <- csmLift $ makeNonce "time_exp"
-          curTimeLow <- makeNonce "time_exp"
+          curTimeLow <- csmLift $ makeNonce "time_exp"
-          curTimeHigh <- makeNonce "time_exp"
+          curTimeHigh <- csmLift $ makeNonce "time_exp"
-          retTime <- 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"

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 ::