diff --git a/GenerateCPPCSP.hs b/GenerateCPPCSP.hs new file mode 100644 index 0000000..83d09b8 --- /dev/null +++ b/GenerateCPPCSP.hs @@ -0,0 +1,1600 @@ +-- | Generate C code from the mangled AST. +module GenerateCPPCSP where + +import Data.Char +import Data.List +import Data.Maybe +import Control.Monad.Writer +import Control.Monad.Error +import Control.Monad.State +import Numeric +import Text.Printf + +import qualified AST as A +import CompState +import EvalConstants +import EvalLiterals +import Metadata +import Pass +import Errors +import TLP +import Types +import Utils + +import GenerateC (CGen,genName,genMeta,missing,genComma,genIntrinsicProc,genBytesIn,genTLPChannel,genDecimal, + genLeftB,genRightB,seqComma,isStringLiteral,genByteLiteral,genTypeSymbol,isZero,genSpecMode,SubscripterFunction) + +{- +Much of this file is influenced by, or taken from, GenerateC. + +Typically there were two reasons to copy code from GenerateC, rather than simply import it: +1. To change the actual behaviour (for example, using C++CSP timers rather than CIF timers) +2. To recurse into my C++CSP generating code rather than C generating code, but otherwise not changing the behaviour + +Reason 1 is obviously necessary - I need to change the CIF calls into C++CSP, and I can also changed some of the C (such as the arrays) into C++. + +Reason 2 is annoying - the code remains the same in both GenerateC and this GenerateCPPCSP module, but I have to move it over so that calls +to other functions use my GenerateCPPCSP versions and not GenerateC versions. +For example, genProcess is identical in GenerateC and GenerateCPPCSP, but in this file it calls (e.g.) GenerateCPPCSP.genInput rather than +GenerateC.genInput. I can't see any easy way to fix this, other than carrying around a dictionary of functions to be called, but that seems +like more hassle than just duplicating the code. + +Code that has been imported verbatim from GenerateC (reason 2) has been tagged accordingly. Assume all other functions are here for reason 1. + +-} + + +{- +For the array handling I am currently using the Blitz++ library: http://www.oonumerics.org/blitz/ + +I considered the following options: +1. in-built C arrays +2. boost::array +3. std::vector +4. boost::multi_array +5. Blitz++ +6. Roll my own. + +Option 1 is what Adam used in GenerateC, but it involves carrying around the array sizes, which is a real pain. +Options 2 and 3 are fairly similar (boost::array is possible because arrays are of constant size in occam) but neither supports multiple dimensions +nor array slicing, so that would have been awkward. +Option 4 does support multiple dimensions and array slicing - but the latter would involve keeping tabs of the dimensions of the *original* array +(that was sliced *from*), even through multiple slices, which would have been a nightmare. +Option 5 makes slicing nice and simple, and multiple dimensions are easy too. Hence, although it adds another dependency (boost would not have counted, +as it is already a dependency of C++CSP) it is definitely the easiest solution for code generation. The dependency could be removed through option 6 +(even to the point of taking some GPL Blitz++ code) but that seems a step too far just to remove a dependency. + +ADDENDUM: I have wrapped blitz::Array into tockArray in order to make the assignment work correctly (resizing before copy) and also provide +some useful constructors + +-} + +{- +For the ANY type I am currently using boost::any, although knowing *exactly* which type to cast into (and indeed, which type it cast from) is +problematic so that may have to be reviewed. +-} + +{- +For the variant protocols I am using boost::variant. But when there are more than 9 cases, I have to chain several variants together. +This is perfectly legal C++, but I think it is causing excessive memory usage in g++ (or possibly the tuples....) +-} + +{- +For the sequential protocols (including those after a tag in variant protocols) I am using boost::tuple for convenience (along with the handy +boost::tie function to extract the values). However I suspect this (or the variants -- see above) is causing a lot of memory usage in g++. Plus, +when more than 9 items are present in the protocol (including variant-tag) I have to chain the tuples together, which means chaining the tie function +as well. May be worth changing in future +-} + +{- +Channels are passed around as pointers to a One2OneChannel<> object. To read I use the reader() function and to write I use the writer() function. +In occam-pi I could possibly use the channel-ends properly, but in occam 2.1 I have to pass the pointer to the channel itself about the place. +-} + + +--{{{ top-level +generateCPPCSP :: A.Process -> PassM String +generateCPPCSP ast + = do (a, w) <- runWriterT (genTopLevel ast) + return $ concat w + +genTopLevel :: A.Process -> CGen () +genTopLevel p + = do tell ["#include \n"] + genProcess p + (name, chans) <- tlpInterface + tell ["int main (int argc, char** argv) { csp::Start_CPPCSP();"] + tell ["csp::One2OneChannel in,out,err;"] --TODO add streamreader + tell [" csp::Run( csp::InParallel (new StreamWriter(std::cout,out.reader())) (new StreamWriter(std::cerr,err.reader())) (csp::InSequenceOneThread ( new proc_"] + genName name + tell ["("] + infixComma [tell ["&"] >> genTLPChannel c | c <- chans] + tell [")) (new csp::common::ChannelPoisoner< csp::Chanout/**/> (out.writer())) (new csp::common::ChannelPoisoner< csp::Chanout/**/> (err.writer())) ) ); csp::End_CPPCSP(); return 0;}"] + +--}}} + + +--CIF has a stop function for stopping processes +--In C++CSP I use the exception handling to make a stop call throw a StopException, +--and the catch is placed so that catching a stop exception immediately finishes the process +genStop :: Meta -> String -> CGen () +genStop m s + = do tell ["throw StopException("] + genMeta m + tell [" \"",s,"\" );"] + + +genInput :: A.Variable -> A.InputMode -> CGen () +genInput c im + = do t <- typeOfVariable c + case t of + A.Timer -> case im of + A.InputSimple m [A.InVariable m' v] -> genTimerRead c v + A.InputAfter m e -> genTimerWait e + _ -> case im of + A.InputSimple m is -> case t of + A.Chan (A.UserProtocol innerType) -> + --We read from the channel into a temporary var, then deal with the var afterwards + do inputVar <- makeNonce "proto_var" + genProtocolName innerType + tell [" ",inputVar, " ; "] + genVariable c + tell [" ->reader() >> ",inputVar," ; "] + cases <- casesOfProtocol innerType + genInputTupleAssign ((length cases) /= 0) inputVar is + _ -> sequence_ $ map (genInputItem c) is + A.InputCase m s -> genInputCase m c s + _ -> missing $ "genInput " ++ show im + +genInputCase :: Meta -> A.Variable -> A.Structured -> CGen () +genInputCase m c s + = do t <- typeOfVariable c + --We have to do complex things with the which() function of the variant (which may be a chained variant) + --to actually get the real index of the item we have received. + let proto = case t of A.Chan (A.UserProtocol n) -> n + tag <- makeNonce "case_tag" + which <- makeNonce "which_val" + genProtocolName proto + tell [" ", tag, " ; "] + tell ["unsigned ", which, " ; "] + genVariable c + tell [" ->reader() >> ", tag, " ; "] + whichExpr proto which tag 0 (genProtocolName proto) + tell [" switch ( ", which, " ) { "] + genInputCaseBody proto tag (return ()) s + tell ["default:"] + genStop m "unhandled variant in CASE input" + tell [" } "] + +--This function processes (potentially chained) variants to get the real index of the data item inside the variant +whichExpr :: A.Name -> String -> String -> Int -> CGen() -> CGen() +whichExpr proto which variant offset protoGen + = do cases <- casesOfProtocol proto + case (offset > (length cases)) of + True -> return () + False -> + do tell [which, " = ", variant , " . which() + ",show offset," ; "] + case ((offset + 9) > (length cases)) of + True -> return () + False -> + do tell ["if ( ", which , " == 9 + ",show offset,") { "] + innerVariant <- makeNonce "case_tag" + innerProto + tell [" & ",innerVariant," = boost::get< /**/"] + innerProto + tell [" /**/>( ",variant," ); "] + whichExpr proto which innerVariant (offset + 9) innerProto + tell [" } "] + where innerProto = protoGen >> tell ["_"] + + +--Gets the variable to input into: +genInputAssign :: A.InputItem -> CGen() +genInputAssign (A.InVariable _ arr) + = genVariable arr +genInputAssign (A.InCounted _ count arr) + = genVariable arr + +--Gets the variable that will receieve the size of an inputted array +genInputSizeAssign :: A.InputItem -> CGen() +genInputSizeAssign (A.InVariable _ arr) + = return () +genInputSizeAssign (A.InCounted _ count arr) + = genVariable count >> tell [" = "] >> genVariable arr >> tell [" .extent(blitz::firstDim);"] + +--Generates the long boost::tie expression that will be used to get all the data out of a tuple that we have read +genInputTupleAssign :: Bool -> String -> [A.InputItem] -> CGen() +genInputTupleAssign hasTag caseVar items + = do genInputTupleAssign' hasTag caseVar items + sequence_ $ map genInputSizeAssign items + where + genInputTupleAssign' :: Bool -> String -> [A.InputItem] -> CGen() + genInputTupleAssign' hasTag caseVar items + = do if ((length rest) /= 0) then tell ["tie10("] else tell ["boost::tuples::tie("] + when (hasTag) (tell ["boost::tuples::ignore,"]) + infixComma (map genInputAssign firstLoad) + when ((length rest) /= 0) (tell [","] >> genInputTupleAssign' False "" rest) + if ((length caseVar) /= 0) then tell [") = ",caseVar," ; "] else tell [")"] + where + (firstLoad,rest) = splitAt (if hasTag then 8 else 9) items + +--Generates the code for getting a particular tagged value out of a (potentially chained) variant +genVariantGet :: A.Name -> A.Name -> String -> CGen() -> CGen String +genVariantGet proto tag var variantName + = do cases <- casesOfProtocol proto + let index = indexOfTag cases tag + genVariantGet' index proto tag var variantName + where + --This is coded oddly, but it does the job! + genVariantGet' :: Int -> A.Name -> A.Name -> String -> CGen() -> CGen String + genVariantGet' index proto tag var variantName + = do caseVar <- makeNonce "case_tag" + (target,recur) <- case (index >= 9) of + True -> return (variantName >> tell ["_"],genVariantGet' (index - 9) proto tag caseVar (variantName >> tell ["_"])) + False -> return (genTupleProtocolTagName proto tag,return caseVar) + target + tell [" & ",caseVar," = boost::get< "] + target + tell [" >( ", var, " );"] + recur + + +-- This handles specs in a slightly odd way, because we can't insert specs into +-- the body of a switch. +genInputCaseBody :: A.Name -> String -> CGen () -> A.Structured -> CGen () +genInputCaseBody proto var coll (A.Spec _ spec s) + = genInputCaseBody proto var (genSpec spec coll) s +genInputCaseBody proto var coll (A.OnlyV _ (A.Variant _ n iis p)) + = do protoType <- specTypeOfName proto + tell ["case ",show (index protoType)," : {"] + coll + case iis of + [] -> return() + _ -> + do caseVar <- genVariantGet proto n var (genProtocolName proto) + genInputTupleAssign True caseVar iis + genProcess p + tell ["break;\n"] + tell ["}\n"] + where + typeList protoType = case protoType of A.ProtocolCase _ types -> types + index protoType = indexOfTag (typeList protoType) n + + +genInputCaseBody proto var coll (A.Several _ ss) + = sequence_ $ map (genInputCaseBody proto var coll) ss + +--C++CSP returns the number of seconds since the epoch as the time +--Since this is too large to be contained in an int once it has been multiplied, +--the remainder is taken to trim the timer back down to something that will be useful in an int +genTimerRead :: A.Variable -> A.Variable -> CGen () +genTimerRead c v + = do tell ["csp::CurrentTime (&"] + genVariable c + tell [");\n"] + genVariable v + tell [" = (int)(unsigned)remainder(1000000.0 * csp::GetSeconds("] + genVariable c + tell ["),4294967296.0);\n"] + +{- + +Time in occam is in microseconds, and is usually stored in the user's programs as a signed 32-bit integer. Therefore the timer wraps round +approx every 72 minutes. A usual pattern of behaviour might be: + + TIMER tim: + INT t: + SEQ + tim ? t -- read current time + t := t PLUS us -- add delay + tim ? AFTER t -- wait until time "t" + +According to Fred's occam page that I took that from, half of time delays are considered in the past and the other half are considered in the future. + +Now consider C++CSP's time. It typically has a more expressive time - on Linux, time is measured since the epoch. Since the epoch was more +than 72 minutes ago, this is problematic when converted to microseconds and stuffed into a 32-bit int. I'll express C++CSP times as (HIGH, LOW) +where LOW is the lowest 32 bits, and HIGH is the higher bits. + +Getting the time for the occam programmer is quite straightforward - we retrieve the C++CSP time, and hand LOW back to the programmer as +a 32-bit signed value (LOW is unsigned normally). + +The occam programmer will now add some delay to their LOW value, making it LOWalpha. They then ask to wait until LOWalpha. We know that +LOWalpha came from LOW at some point in the past and has been added to. We need to combine it with some HIGH value, HIGHalpha to form +(HIGHalpha, LOWalpha), the time to wait until. So what should HIGHalpha be? + +We could say that HIGHalpha = HIGH. But if the user wrapped around LOWalpha, we actually want: HIGHalpha = HIGH + 1. So we need to check +if LOWalpha is a wrapped round version of LOW. This could be done by checking whether LOWalpha < LOW. If this is true, it must have wrapped. +Otherwise, it must not have. +-} + +--Gets a csp::Time to wait with, given a 32-bit microsecond value (returns the temp variable we have put it in) +genCPPCSPTime :: A.Expression -> CGen String +genCPPCSPTime e + = do time <- makeNonce "time_exp" + tell ["unsigned ",time," = (unsigned)"] + genExpression e + tell [" ; "] + curTime <- makeNonce "time_exp" + curTimeLow <- makeNonce "time_exp" + curTimeHigh <- makeNonce "time_exp" + retTime <- 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);"] + --if time is less than curTime, it must have wrapped around so add one: + tell ["csp::Time ",retTime," = csp::Seconds((((double)(",curTimeHigh," + (",time," < ",curTimeLow, " ? 1 : 0)) * 4294967296.0) + (double)",time,") / 1000000.0);"] + return retTime + +genTimerWait :: A.Expression -> CGen () +genTimerWait e + = do + time <- genCPPCSPTime e + tell ["csp::SleepUntil(",time,");"] + +genInputItem :: A.Variable -> A.InputItem -> CGen () +genInputItem c (A.InCounted m cv av) + = do genInputItem c (A.InVariable m av) + --The size is held by the array; we just assign it to the right variable afterwards: + genVariable cv + tell [" = "] + genVariable av + tell [" .extent(blitz::firstDim); "] +genInputItem c (A.InVariable m v) + = do genVariable c + tell ["->reader() >> "] + genVariable v + tell [";\n"] + +genJustOutputItem :: A.OutputItem -> CGen() +genJustOutputItem (A.OutCounted m ce ae) + = do genJustOutputItem (A.OutExpression m ae) + tell[" (blitz::Range(0,"] + genExpression ce + tell[" - 1)) .copy() "] + --TODO fill the rest of the dimensions with blitz::Range::all() +genJustOutputItem (A.OutExpression m e) + = genExpression e + +genOutputItem :: A.Variable -> A.OutputItem -> CGen () +genOutputItem chan item + = do genVariable chan + tell [" ->writer() << "] + genJustOutputItem item + tell [" ; "] + +genOutput :: A.Variable -> [A.OutputItem] -> CGen () +genOutput c ois + = do t <- typeOfVariable c + case t of + --If it's a protocol, we have to build the appropriate tuple to send down the channel: + A.Chan (A.UserProtocol innerType) -> + do genVariable c + tell [" ->writer() << "] + genProtocolName innerType + tell [" ( "] + infixComma $ map genJustOutputItem ois + tell [" ); "] + _ -> sequence_ $ map (genOutputItem c) ois + +--Helper function to place a comma between items, but not before or after +infixComma :: [CGen ()] -> CGen () +infixComma (c0:cs) = c0 >> sequence_ [genComma >> c | c <- cs] +infixComma [] = return () + +--{{{Helper functions for protocol names and tags: + +genProtocolName :: A.Name -> CGen() +genProtocolName proto + = do tell ["protocol_"] + genName proto + +genProtocolTagName :: A.Name -> A.Name -> CGen() +genProtocolTagName proto tag + = do tell ["protocol_tag_"] + genName proto + tell ["_"] + genName tag + +genTupleProtocolTagName :: A.Name -> A.Name -> CGen() +genTupleProtocolTagName proto tag = tell ["tuple_"] >> genProtocolTagName proto tag + + +--Given a list of cases and a tag, finds the index of that tag: +indexOfTag :: [(A.Name, [A.Type])] -> A.Name -> Int +indexOfTag = indexOfTag' 0 + where + indexOfTag' :: Int -> [(A.Name, [A.Type])] -> A.Name -> Int + indexOfTag' n ((possible,_):rest) target + | possible == target = n + | otherwise = indexOfTag' (n+1) rest target + +--Helper for getting all the cases of a given protocol: +casesOfProtocol :: A.Name -> CGen [(A.Name, [A.Type])] +casesOfProtocol proto + = do protoType <- specTypeOfName proto + case protoType of + A.Protocol _ _ -> return ([]) + A.ProtocolCase _ types -> return (types) + +--}}} + +--Used when constructing a chained variant -- we must specify the variant types through the chain, so the +--compiler understands that we're giving it one of the inner variants +genSubTypes :: A.Name -> A.Name -> CGen() -> CGen() +genSubTypes proto tag middle + = do protoType <- specTypeOfName proto + case protoType of + --sequential, no need for sub-types: + A.Protocol _ types -> middle + --choice, do need the sub-types: + A.ProtocolCase _ types -> do sequence_ + [ (genProtocolName proto >> + tell [(replicate ind '_')," ( "]) | ind <- [0 .. byNine] + ] + middle + tell [replicate (byNine + 1) ')'] + --We add one because the protocol tag itself counts as an item in our C++ implementation: + where realIndex = 1 + (indexOfTag types tag) + byNine = realIndex `div` 9 + + +genOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen () +genOutputCase c tag ois + = do t <- typeOfVariable c + let proto = case t of A.Chan (A.UserProtocol n) -> n + genVariable c + tell [" ->writer() << "] + genSubTypes proto tag (middle proto) + tell [" ; "] + where + middle proto = tupleExpression True (genTupleProtocolTagName proto tag) (((genProtocolTagName proto tag) >> tell ["()"]) : map genJustOutputItem ois) + + +--We use the process wrappers here, in order to execute the functions in parallel: +--We use forking instead of Run/InParallelOneThread, because it is easier to use forking with replication +genPar :: A.ParMode -> A.Structured -> CGen () +genPar _ s + = do forking <- makeNonce "forking" + tell ["{ csp::ScopedForking ",forking," ; "] + genStructured s (genPar' forking) + tell [" }"] + where + genPar' :: String -> A.Structured -> CGen () + genPar' forking (A.OnlyP _ p) + = case p of + A.ProcCall _ n as -> + do tell [forking," .forkInThisThread(new proc_"] + genName n + tell ["("] + genActuals as + tell [" ) ); "] + _ -> error ("trying to run something other than a process in parallel") + + + +--Changed to use C++CSP's Alternative class: +genAlt :: Bool -> A.Structured -> CGen () +genAlt _ s + = do guards <- makeNonce "alt_guards" + tell ["std::list< csp::Guard* > ", guards, " ; "] + initAltGuards guards s + alt <- makeNonce "alt" + tell ["csp::Alternative ",alt, " ( ", guards, " ); "] + + id <- makeNonce "alt_id" + tell ["int ", id, " = 0;\n"] + fired <- makeNonce "alt_fired" + tell ["int ", fired, " = ", alt, " .priSelect();"] + label <- makeNonce "alt_end" + tell ["{\n"] + genAltProcesses id fired label s + tell ["}\n"] + tell [label, ":\n;\n"] + +--This function is like the enable function in GenerateC, but this one merely builds a list of guards. It does not do anything other than add to the guard list +initAltGuards :: String -> A.Structured -> CGen () +initAltGuards guardList s = genStructured s doA + where + doA (A.OnlyA _ alt) + = case alt of + A.Alternative _ c im _ -> doIn c im + A.AlternativeCond _ e c im _ -> withIf e $ doIn c im + A.AlternativeSkip _ e _ -> withIf e $ tell [guardList, " . push_back( new csp::SkipGuard() );\n"] + + doIn c im + = do t <- inputType c im + case t of + ITTimerRead -> missing "timer read in ALT" + ITTimerAfter -> + do let time = case im of A.InputAfter _ e -> e + timeVal <- genCPPCSPTime time + tell [guardList, " . push_back( new csp::TimeoutGuard (",timeVal,"));\n"] + ITOther -> + do tell [guardList, " . push_back( "] + genVariable c + tell [" -> reader() . inputGuard());\n"] + +--In GenerateC this uses prefixComma (because "Process * me" is always the first argument), but here we use infixComma: +genActuals :: [A.Actual] -> CGen () +genActuals as = infixComma (map genActual as) + +--In GenerateC this has special code for passing array sizes around, which we don't need: +genActual :: A.Actual -> CGen () +genActual actual + = case actual of + A.ActualExpression t e -> genExpression e + A.ActualVariable am t v -> abbrevVariable am t v + +--The only change from GenerateC is that passing "me" is not necessary in C++CSP +genProcCall :: A.Name -> [A.Actual] -> CGen () +genProcCall n as + = do genName n + tell ["("] + genActuals as + tell [");"] + + +--Changed from CIF's untyped channels to C++CSP's typed (templated) channels: +declareType :: A.Type -> CGen () +declareType (A.Chan t) + = do tell [" csp::One2OneChannel < "] + genType t + tell [" > "] +declareType t = genType t + +--Removed the channel part from GenerateC (not necessary in C++CSP, I think), and also changed the arrays: +genDeclaration :: A.Type -> A.Name -> CGen () +genDeclaration arrType@(A.Array ds t) n + = do declareType arrType + tell [" "] + genName n + genArraySize ds + tell [";\n"] +genDeclaration t n + = do declareType t + tell [" "] + genName n + tell [";\n"] + +--Changed because of channel arrays: +declareInit :: Meta -> A.Type -> A.Variable -> Maybe (CGen ()) +declareInit m t@(A.Array ds t') var + = Just $ do init <- case t' of + A.Chan _ -> + return (\sub -> Just $ do genVariable (sub var) + tell [" = new "] + declareType t' + tell ["();\n"] + doMaybe $ declareInit m t' (sub var)) + + _ -> return (\sub -> declareInit m t' (sub var)) + overArray m var init + +declareInit _ _ _ = Nothing + +--Changed to free channel arrays: +declareFree :: Meta -> A.Type -> A.Variable -> Maybe (CGen ()) + +declareFree m t@(A.Array ds t') var + = Just $ do free <- case t' of + A.Chan _ -> + return (\sub -> Just $ do tell ["delete "] + genVariable (sub var) + tell [";\n"] + --doMaybe $ declareFree m t' (sub var) + ) + + _ -> return (\sub -> declareFree m t' (sub var)) + overArray m var free + +declareFree _ _ _ = Nothing + +--Changed to work properly with declareFree to free channel arrays: +removeSpec :: A.Specification -> CGen () +removeSpec (A.Specification m n (A.Declaration _ t)) + = do case declareFree m t var of + Just p -> p + Nothing -> return () + where + var = A.Variable m n +removeSpec _ = return () + + +--A helper function that maps a function and calls sequence on the resulting [CGen()] +cgmap :: (t -> CGen()) -> [t] -> CGen() +cgmap func list = sequence_ $ map func list + +--A simple function for generating declarations of class variables +genClassVar :: A.Formal -> CGen() +genClassVar (A.Formal am t n) + = do genDecl am t n + tell[";"] + +--Generates the given list of class variables +genClassVars :: [A.Formal] -> CGen () +genClassVars fs = cgmap genClassVar fs + +--A helper function for generating the initialiser list in a process wrapper constructor +genConsItem :: A.Formal -> CGen() +genConsItem (A.Formal am t n) + = do tell[","] + genName n + tell["(_"] + genName n + tell[")"] + +--A function for generating the initialiser list in a process wrapper constructor +genConstructorList :: [A.Formal] -> CGen () +genConstructorList fs = cgmap genConsItem fs + +--A helper function for calling the wrapped functions: +genParam :: A.Formal -> CGen() +genParam (A.Formal _ _ n) = genName n + +--A helper function for calling the wrapped functions: +genParamList :: [A.Formal] -> CGen() +genParamList fs = infixComma $ map genParam fs + +--Changed from GenerateC because we don't need the extra code for array sizes +abbrevExpression :: A.AbbrevMode -> A.Type -> A.Expression -> CGen () +abbrevExpression am t@(A.Array _ _) e + = case e of + A.ExprVariable _ v -> abbrevVariable am t v + A.Literal _ (A.Array ds _) r -> genExpression e + _ -> bad + where + bad = missing "array expression abbreviation" +abbrevExpression am _ e = genExpression e + +--Uses the Blitz library for giving array dimensions -- hence the round brackets, which actually are part of a constructor call +genArraySize :: [A.Dimension] -> CGen () +genArraySize ds + = do tell ["( blitz::shape("] + sequence $ intersperse (tell [" , "]) + [case d of A.Dimension n -> tell [show n] | d <- ds] + tell [") )"] + + +--Used to create boost::variant and boost::tuple types. Both these classes can have a maximum of nine items +--so if there are more than nine items, we must have variants containing variants, or tuples containing tuples +createChainedType :: String -> CGen() -> [CGen()] -> CGen () +createChainedType combinator typeName items + = do when ((length rest) /= 0) + (createChainedType combinator subName rest) + tell ["typedef ",combinator," < "] + infixComma firstNine + when ((length rest) /= 0) + (tell [" , "] >> subName) + --To stop the indent program ruining the C++ Code by combining all the ">" into ">>>" we use these odd blank comments: + tell ["/**/> "] + typeName + tell [" ; "] + where + subName = (typeName >> tell ["_"]) + (firstNine,rest) = splitAt 9 items + +--Used to create (potentially chained) tuple expressions +tupleExpression :: Bool -> CGen() -> [CGen()] -> CGen() +tupleExpression useBrackets tupleType items + = do tupleType + when (useBrackets) (tell [" ( "]) + infixComma firstNine + when ((length rest) /= 0) + (tell [" , "] >> (tupleExpression True (tell ["boost::make_tuple"]) rest)) + when (useBrackets) (tell [" ) "]) + where + (firstNine,rest) = splitAt 9 items + +--Takes a list of dimensions and outputs a comma-seperated list of the numerical values +genDims:: [A.Dimension] -> CGen() +genDims dims = infixComma $ map genDim dims + where + genDim :: A.Dimension -> CGen() + genDim (A.Dimension n) = tell [show n] + genDim dim = missing ("No support for dimension: " ++ show dim) + +introduceSpec :: A.Specification -> CGen () +--I generate process wrappers for all functions by default: +introduceSpec (A.Specification _ n (A.Proc _ sm fs p)) + = do --Generate the "process" as a C++ function: + genSpecMode sm + tell ["void "] + name + tell [" ("] + genFormals (\x -> x) fs + tell [") {\n"] + genProcess p + tell ["}\n"] + + --And generate its CSProcess wrapper: + tell ["class proc_"] + name + tell [" : public csp::CSProcess {private:"] + genClassVars fs + tell ["public:inline proc_"] + name + tell ["("] + genFormals prefixUnderscore fs + tell [") : csp::CSProcess(65536)"] + genConstructorList fs + tell ["{} protected: virtual void run() { try {"] + name + tell [" ( "] + genParamList fs + tell [" ); } catch (StopException e) {std::cerr << \"Stopped because: \" << e.reason << std::endl; } } };"] + where name = genName n +--This clause is unchanged from GenerateC: +introduceSpec (A.Specification m n (A.Declaration _ t)) + = do genDeclaration t n + case declareInit m t (A.Variable m n) of + Just p -> p + Nothing -> return () +--This clause is unchanged from GenerateC: +introduceSpec (A.Specification _ n (A.Is _ am t v)) + = do let rhs = abbrevVariable am t v + genDecl am t n + tell [" = "] + rhs + tell [";\n"] +--Clause only changed to use Blitz++ rather than C arrays: +introduceSpec (A.Specification _ n (A.IsExpr _ am t e)) + = do let rhs = abbrevExpression am t e + case (am, t, e) of + (A.ValAbbrev, A.Array _ ts, A.Literal _ (A.Array dims _) _) -> + -- For "VAL []T a IS [vs]:", we have to use [] rather than * in the + -- declaration, since you can't say "int *foo = {vs};" in C. + do tmp <- makeNonce "array_literal" + tell ["const "] + genType ts + tell [" ",tmp, " [] = "] + rhs + tell [" ; "] + tell ["const tockArray< "] + genType ts + tell [" , ",show (length dims)," > "] + genName n + tell ["(("] + genType ts + tell [" *)",tmp,",blitz::shape("] + genDims dims + tell ["),blitz::duplicateData);\n"] + (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" + tell ["const "] + genType t + tell [" ", tmp, " = "] + rhs + tell [";\n"] + genDecl am t n + tell [" = &", tmp, ";\n"] + _ -> + do genDecl am t n + tell [" = "] + rhs + tell [";\n"] +--TODO check this clause is ok +introduceSpec (A.Specification _ n (A.IsChannelArray _ t cs)) + = do --tell ["tockArray< csp::One2OneChannel< "] + genType t + --tell [" > * , 1 > "] + tell [" "] + genName n + tell ["(blitz::shape(",show (length cs),"));"] + sequence_ $ map genChanArrayElemInit (zip [0 .. ((length cs) - 1)] cs) + where + genChanArrayElemInit (index,var) + = do genName n + tell ["(",show index,") = "] + genVariable var + tell [";"] +--This clause is unchanged from GenerateC: +introduceSpec (A.Specification _ _ (A.DataType _ _)) = return () +--This clause was simplified, because the array handling could be removed: +introduceSpec (A.Specification _ n (A.RecordType _ b fs)) + = do tell ["typedef struct {\n"] + sequence_ [genDeclaration t n + | (n, t) <- fs] + tell ["} "] + when b $ tell ["occam_struct_packed "] + genName n + tell [";\n"] +--We do sequential protocols by introducing a new tuple: +introduceSpec (A.Specification _ n (A.Protocol _ typeList)) + = do createChainedType "boost::tuple" (genProtocolName n) $ map genType typeList +--We do variant protocols by introducing a new variant: +introduceSpec (A.Specification _ n (A.ProtocolCase _ [])) + = do tell ["typedef class {} "] + genName n + tell [";"] +introduceSpec (A.Specification _ n (A.ProtocolCase _ caseList)) + = do sequence_ [tell ["class "] >> genProtocolTagName n tag >> tell [" {}; "] | (tag , _) <- caseList] + cgmap (typedef_genCaseType n) caseList + createChainedType "boost::variant" (genProtocolName n) $ map ((genTupleProtocolTagName n) . fst) caseList + where + typedef_genCaseType :: A.Name -> (A.Name, [A.Type]) -> CGen() + typedef_genCaseType n (tag, typeList) + = createChainedType "boost::tuple" (genTupleProtocolTagName n tag) ((genProtocolTagName n tag) : (map genType typeList)) + +--TODO check this clause +introduceSpec (A.Specification _ n (A.Retypes m am t v)) + = do origT <- typeOfVariable v + let rhs = abbrevVariable A.Abbrev origT v + genDecl am t n + tell [" = "] + -- For scalar types that are VAL abbreviations (e.g. VAL INT64), + -- we need to dereference the pointer that abbrevVariable gives us. + let deref = case (am, t) of + (_, A.Array _ _) -> False + (_, A.Chan _) -> False + (A.ValAbbrev, _) -> True + _ -> False + when deref $ tell ["*"] + tell ["("] + genDeclType am t + when deref $ tell [" *"] + tell [") "] + rhs + tell [";\n"] +--TODO work out what this does +-- genRetypeSizes m am t n origT v + +--This clause is unchanged from GenerateC: +introduceSpec n = missing $ "introduceSpec " ++ show n + +--The only change from GenerateC are the two clauses relating to size: +genExpression :: A.Expression -> CGen () +genExpression (A.Monadic m op e) = genMonadic m op e +genExpression (A.Dyadic m op e f) = genDyadic m op e f +genExpression (A.MostPos m t) = genTypeSymbol "mostpos" t +genExpression (A.MostNeg m t) = genTypeSymbol "mostneg" t +genExpression (A.SizeExpr m e) + = do genExpression e + tell [" .extent(blitz::firstDim) "] +genExpression (A.SizeVariable m v) + = do genVariable v + tell [" .extent(blitz::firstDim)"] +genExpression (A.Conversion m cm t e) = genConversion m cm t e +genExpression (A.ExprVariable m v) = genVariable v +genExpression (A.Literal _ _ lr) = genLiteral lr +genExpression (A.True m) = tell ["true"] +genExpression (A.False m) = tell ["false"] +--genExpression (A.FunctionCall m n es) +genExpression (A.IntrinsicFunctionCall m s es) = genIntrinsicFunction m s es +--genExpression (A.SubscriptedExpr m s e) +--genExpression (A.BytesInExpr m e) +genExpression (A.BytesInType m t) = genBytesIn t Nothing +--genExpression (A.OffsetOf m t n) +genExpression t = missing $ "genExpression " ++ show t + +--}}} + + +--{{{ types +-- | If a type maps to a simple C type, return Just that; else return Nothing. + +--Changed from GenerateC to change the A.Timer type to use C++CSP time +scalarType :: A.Type -> Maybe String +scalarType A.Bool = Just "bool" +scalarType A.Byte = Just "uint8_t" +scalarType A.Int = Just "int" +scalarType A.Int16 = Just "int16_t" +scalarType A.Int32 = Just "int32_t" +scalarType A.Int64 = Just "int64_t" +scalarType A.Real32 = Just "float" +scalarType A.Real64 = Just "double" +scalarType A.Timer = Just "csp::Time" +scalarType _ = Nothing + +--Generates an array type, giving the Blitz++ array the correct dimensions +genArrayType :: A.Type -> Int -> CGen () +genArrayType (A.Array dims t) rank + = genArrayType t (rank + (max 1 (length dims))) +genArrayType t rank + = do tell [" tockArray< "] + genType t + tell [" , ",show rank, " > "] + +--Changed from GenerateC to change the arrays and the channels +--Also changed to add counted arrays and user protocols +genType :: A.Type -> CGen () +genType arr@(A.Array _ _) + = genArrayType arr 0 +genType (A.Record n) = genName n +genType (A.UserProtocol n) = genProtocolName n +genType (A.Chan t) + = do tell ["csp::One2OneChannel < "] + genType t + tell [" > * "] +genType (A.Counted countType valueType) + = genType (A.Array [] valueType) +genType (A.Any) + = tell [" tockAny "] +-- Any -- not used +--genType (A.Port t) = +genType t + = case scalarType t of + Just s -> tell [s] + Nothing -> missing $ "genType " ++ show t + + +--Changed from GenerateC to add a name function (to allow us to use the same function for doing function parameters as constructor parameters) +--and also changed to use infixComma +--To use for a constructor list, pass prefixUnderscore as the function, otherwise pass the identity function +genFormals :: (A.Name -> A.Name) -> [A.Formal] -> CGen () +genFormals nameFunc list = infixComma (map (genFormal nameFunc) list) + +--Changed as genFormals +genFormal :: (A.Name -> A.Name) -> A.Formal -> CGen () +genFormal nameFunc (A.Formal am t n) = genDecl am t (nameFunc n) + +--Helper function for prefixing an underscore (looks like fairly ugly Haskell - maybe there is an easier way?) +prefixUnderscore :: A.Name -> A.Name +prefixUnderscore n = A.Name {A.nameMeta = A.nameMeta n, A.nameType = A.nameType n, A.nameName = "_" ++ A.nameName n} + + +-- | Generate the right-hand side of an abbreviation of a variable. +--Changed from GenerateC because we no longer need the A.Name -> CGen() function returned that dealt with array sizes +--I also pass the type of the array through to genSlice +abbrevVariable :: A.AbbrevMode -> A.Type -> A.Variable -> CGen () +abbrevVariable am (A.Array _ _) v@(A.SubscriptedVariable _ (A.Subscript _ _) _) + = genArrayAbbrev v +abbrevVariable am ty@(A.Array ds _) v@(A.SubscriptedVariable _ (A.SubscriptFromFor _ start count) v') + = genSlice v v' ty start count ds +abbrevVariable am ty@(A.Array ds _) v@(A.SubscriptedVariable m (A.SubscriptFrom _ start) v') + = genSlice v v' ty start (A.Dyadic m A.Minus (A.SizeExpr m (A.ExprVariable m v')) start) ds +abbrevVariable am ty@(A.Array ds _) v@(A.SubscriptedVariable m (A.SubscriptFor _ count) v') + = genSlice v v' ty (makeConstant m 0) count ds +abbrevVariable am (A.Array _ _) v + = genVariable v +abbrevVariable am (A.Chan _) v + = genVariable v +abbrevVariable am (A.Record _) v + = genVariable v +abbrevVariable am t v + = genVariableAM v am + + +--Use C++ array slices: +--TODO put index checking back: +genSlice :: A.Variable -> A.Variable -> A.Type -> A.Expression -> A.Expression -> [A.Dimension] -> CGen () +genSlice _ v ty start count ds + -- We need to disable the index check here because we might be taking + -- element 0 of a 0-length array -- which is valid. + = do genVariableUnchecked v + tell ["(blitz::Range("] + genExpression start + tell [" , "] + genExpression start + tell [" + "] + genExpression count + tell [" ))"] + + +--Removed the sizing and the & from GenerateC: +genArrayAbbrev :: A.Variable -> CGen () +genArrayAbbrev = genVariable + + +--Changed from GenerateC to use Blitz++ subscripting (round brackets with commas) rather than traditional C indexing +genArraySubscript :: Bool -> A.Variable -> [A.Expression] -> CGen () +genArraySubscript checkValid v es + = do t <- typeOfVariable v + let numDims = case t of A.Array ds _ -> length ds + tell ["("] + sequence_ $ intersperse (tell [" , "]) $ genPlainSub v es [0..(numDims - 1)] + tell [")"] + where + -- | Generate the individual offsets that need adding together to find the + -- right place in the array. + -- FIXME This is obviously not the best way to factor this, but I figure a + -- smart C compiler should be able to work it out... + + --Subtly changed this function so that empty dimensions have blitz::Range::all() in the C++ version: + + genPlainSub :: A.Variable -> [A.Expression] -> [Int] -> [CGen ()] + genPlainSub _ _ [] = [] + genPlainSub v [] (sub:subs) = (tell [" blitz::Range::all() "]) : (genPlainSub v [] subs) + genPlainSub v (e:es) (sub:subs) + = gen : genPlainSub v es subs + where + gen = genSub + genSub + = if checkValid + then do tell ["occam_check_index ("] + genExpression e + tell [", "] + genVariable v + tell [".extent(", show sub, "), "] + genMeta (findMeta e) + tell [")"] + else genExpression e +--}}} + +-- | Map an operation over every item of an occam array. +--Changed from GenerateC because it uses the array sizes of Blitz++ +overArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen () +overArray m var func + = do A.Array ds _ <- typeOfVariable var + specs <- sequence [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]) + case func arg of + Just p -> + do sequence_ [do tell ["for (int "] + genVariable i + tell [" = 0; "] + genVariable i + tell [" < "] + genVariable var + tell [".extent(", show v, "); "] + genVariable i + tell ["++) {\n"] + | (v, i) <- zip [0..] indices] + p + sequence_ [tell ["}\n"] | _ <- indices] + Nothing -> return () + + + +-- | Generate an expression inside a record literal. +-- +-- This is awkward: the sort of literal that this produces when there's a +-- variable in here cannot always be compiled at the top level of a C99 program +-- -- because in C99, an array subscript is not a constant, even if it's a +-- constant subscript of a constant array. So we need to be sure that when we +-- use this at the top level, the thing we're unfolding only contains literals. +-- Yuck! + +--Changed to remove array size: +genUnfoldedExpression :: A.Expression -> CGen () +genUnfoldedExpression (A.Literal _ t lr) + = genLiteralRepr lr +genUnfoldedExpression (A.ExprVariable m var) = genUnfoldedVariable m var +genUnfoldedExpression e = genExpression e + +--Changed to remove array size: +genUnfoldedVariable :: Meta -> A.Variable -> CGen () +genUnfoldedVariable m var + = do t <- typeOfVariable var + case t of + A.Array ds _ -> + do genLeftB + unfoldArray ds var + genRightB + A.Record _ -> + do genLeftB + fs <- recordFields m t + seqComma [genUnfoldedVariable m (A.SubscriptedVariable m (A.SubscriptField m n) var) + | (n, t) <- fs] + genRightB + -- We can defeat the usage check here because we know it's safe; *we're* + -- generating the subscripts. + -- FIXME Is that actually true for something like [a[x]]? + _ -> genVariable' False var + where + unfoldArray :: [A.Dimension] -> A.Variable -> CGen () + unfoldArray [] v = genUnfoldedVariable m v + unfoldArray (A.Dimension n:ds) v + = seqComma $ [unfoldArray ds (A.SubscriptedVariable m (A.Subscript m $ makeConstant m i) v) + | i <- [0..(n - 1)]] + unfoldArray _ _ = dieP m "trying to unfold array with unknown dimension" + + +--{{{ if +--Changed to throw a nonce-exception class instead of the goto, because C++ doesn't allow gotos to cross class initialisations (such as arrays) + +genIf :: Meta -> A.Structured -> CGen () +genIf m s + = do ifExc <- makeNonce "if_exc" + tell ["class ",ifExc, " {}; try {"] + genIfBody ifExc s + genStop m "no choice matched in IF process" + tell ["} catch (",ifExc,") {}"] + +genIfBody :: String -> A.Structured -> CGen () +genIfBody ifExc s = genStructured s doC + where + doC (A.OnlyC m (A.Choice m' e p)) + = do tell ["if ("] + genExpression e + tell [") {\n"] + genProcess p + tell ["throw ",ifExc, "(); }\n"] +--}}} + + +{- + +--------------------------------------------------------------------- + +All the code below this point has been taken verbatim from GenerateC: + +--------------------------------------------------------------------- + +-} + +--Taken verbatim from GenerateC +genProcess :: A.Process -> CGen () +genProcess p = case p of + A.Assign m vs es -> genAssign m vs es + A.Input m c im -> genInput c im + A.Output m c ois -> genOutput c ois + A.OutputCase m c t ois -> genOutputCase c t ois + A.Skip m -> tell ["/* skip */\n"] + A.Stop m -> genStop m "STOP process" + A.Main m -> tell ["/* main */\n"] + A.Seq _ s -> genSeqBody s + A.If m s -> genIf m s + A.Case m e s -> genCase m e s + A.While m e p -> genWhile e p + A.Par m pm s -> genPar pm s + -- PROCESSOR does nothing special. + A.Processor m e p -> genProcess p + A.Alt m b s -> genAlt b s + A.ProcCall m n as -> genProcCall n as + A.IntrinsicProcCall m s as -> genIntrinsicProc m s as + +--Taken verbatim from GenerateC +genAssign :: Meta -> [A.Variable] -> A.ExpressionList -> CGen () +genAssign m [v] el + = case el of + A.FunctionCallList _ _ _ -> missing "function call" + A.ExpressionList _ [e] -> + do t <- typeOfVariable v + doAssign t v e + where + doAssign :: A.Type -> A.Variable -> A.Expression -> CGen () + doAssign t@(A.Array _ subT) toV (A.ExprVariable m fromV) + = overArray m fromV (\sub -> Just $ doAssign subT (sub toV) (A.ExprVariable m (sub fromV))) + doAssign rt@(A.Record _) toV (A.ExprVariable m fromV) + = do fs <- recordFields m rt + sequence_ [let subV v = A.SubscriptedVariable m (A.SubscriptField m n) v + in doAssign t (subV toV) (A.ExprVariable m $ subV fromV) + | (n, t) <- fs] + doAssign t v e + = case scalarType t of + Just _ -> + do genVariable v + tell [" = "] + genExpression e + tell [";\n"] + Nothing -> missing $ "assignment of type " ++ show t + + +--Taken verbatim from GenerateC +genSeqBody :: A.Structured -> CGen () +genSeqBody s = genStructured s doP + where + doP (A.OnlyP _ p) = genProcess p + +--{{{ while +--Taken verbatim from GenerateC +genWhile :: A.Expression -> A.Process -> CGen () +genWhile e p + = do tell ["while ("] + genExpression e + tell [") {\n"] + genProcess p + tell ["}\n"] +--}}} + +--Taken verbatim from GenerateC +genStructured :: A.Structured -> (A.Structured -> CGen ()) -> CGen () +genStructured (A.Rep _ rep s) def = genReplicator rep (genStructured s def) +genStructured (A.Spec _ spec s) def = genSpec spec (genStructured s def) +genStructured (A.ProcThen _ p s) def = genProcess p >> genStructured s def +genStructured (A.Several _ ss) def = sequence_ [genStructured s def | s <- ss] +genStructured s def = def s + + +--{{{ replicators +--All taken verbatim from GenerateC + +genReplicator :: A.Replicator -> CGen () -> CGen () +genReplicator rep body + = do tell ["for ("] + genReplicatorLoop rep + tell [") {\n"] + body + tell ["}\n"] + +genReplicatorLoop :: A.Replicator -> CGen () +genReplicatorLoop (A.For m index base count) + = if isZero base + then genSimpleReplicatorLoop index count + else genGeneralReplicatorLoop index base count + +genSimpleReplicatorLoop :: A.Name -> A.Expression -> CGen () +genSimpleReplicatorLoop index count + = do tell ["int "] + genName index + tell [" = 0; "] + genName index + tell [" < "] + genExpression count + tell ["; "] + genName index + tell ["++"] + +genGeneralReplicatorLoop :: A.Name -> A.Expression -> A.Expression -> CGen () +genGeneralReplicatorLoop index base count + = do counter <- makeNonce "replicator_count" + tell ["int ", counter, " = "] + genExpression count + tell [", "] + genName index + tell [" = "] + genExpression base + tell ["; ", counter, " > 0; ", counter, "--, "] + genName index + tell ["++"] + +genReplicatorSize :: A.Replicator -> CGen () +genReplicatorSize rep = genExpression (sizeOfReplicator rep) +--}}} + +--Taken verbatim from GenerateC +genSpec :: A.Specification -> CGen () -> CGen () +genSpec spec body + = do introduceSpec spec + body + removeSpec spec + +--Taken verbatim from GenerateC +genIntrinsicFunction :: Meta -> String -> [A.Expression] -> CGen () +genIntrinsicFunction m s es + = do tell ["occam_", s, " ("] + sequence [genExpression e >> genComma | e <- es] + genMeta m + tell [")"] + +--{{{ operators +--All taken verbatim from GenerateC + +genSimpleMonadic :: String -> A.Expression -> CGen () +genSimpleMonadic s e + = do tell ["(", s] + genExpression e + tell [")"] + +genMonadic :: Meta -> A.MonadicOp -> A.Expression -> CGen () +genMonadic _ A.MonadicSubtr e = genSimpleMonadic "-" e +genMonadic _ A.MonadicBitNot e = genSimpleMonadic "~" e +genMonadic _ A.MonadicNot e = genSimpleMonadic "!" e + +genSimpleDyadic :: String -> A.Expression -> A.Expression -> CGen () +genSimpleDyadic s e f + = do tell ["("] + genExpression e + tell [" ", s, " "] + genExpression f + tell [")"] + +genFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen () +genFuncDyadic m s e f + = do t <- typeOfExpression e + genTypeSymbol s t + tell [" ("] + genExpression e + tell [", "] + genExpression f + tell [", "] + genMeta m + tell [")"] + +genDyadic :: Meta -> A.DyadicOp -> A.Expression -> A.Expression -> CGen () +genDyadic m A.Add e f = genFuncDyadic m "add" e f +genDyadic m A.Subtr e f = genFuncDyadic m "subtr" e f +genDyadic m A.Mul e f = genFuncDyadic m "mul" e f +genDyadic m A.Div e f = genFuncDyadic m "div" e f +genDyadic m A.Rem e f = genFuncDyadic m "rem" e f +genDyadic _ A.Plus e f = genSimpleDyadic "+" e f +genDyadic _ A.Minus e f = genSimpleDyadic "-" e f +genDyadic _ A.Times e f = genSimpleDyadic "*" e f +genDyadic _ A.LeftShift e f = genSimpleDyadic "<<" e f +genDyadic _ A.RightShift e f = genSimpleDyadic ">>" e f +genDyadic _ A.BitAnd e f = genSimpleDyadic "&" e f +genDyadic _ A.BitOr e f = genSimpleDyadic "|" e f +genDyadic _ A.BitXor e f = genSimpleDyadic "^" e f +genDyadic _ A.And e f = genSimpleDyadic "&&" e f +genDyadic _ A.Or e f = genSimpleDyadic "||" e f +genDyadic _ A.Eq e f = genSimpleDyadic "==" e f +genDyadic _ A.NotEq e f = genSimpleDyadic "!=" e f +genDyadic _ A.Less e f = genSimpleDyadic "<" e f +genDyadic _ A.More e f = genSimpleDyadic ">" e f +genDyadic _ A.LessEq e f = genSimpleDyadic "<=" e f +genDyadic _ A.MoreEq e f = genSimpleDyadic ">=" e f + + +genConversion :: Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen () +genConversion m A.DefaultConversion toT e + = do fromT <- typeOfExpression e + genCheckedConversion m fromT toT (genExpression e) +genConversion m cm toT e + = do fromT <- typeOfExpression e + case (isSafeConversion fromT toT, isRealType fromT, isRealType toT) of + (True, _, _) -> + -- A safe conversion -- no need for a check. + genCheckedConversion m fromT toT (genExpression e) + (_, True, True) -> + -- Real to real. + do genConversionSymbol fromT toT cm + tell [" ("] + genExpression e + tell [", "] + genMeta m + tell [")"] + (_, True, False) -> + -- Real to integer -- do real -> int64_t -> int. + do let exp = do genConversionSymbol fromT A.Int64 cm + tell [" ("] + genExpression e + tell [", "] + genMeta m + tell [")"] + genCheckedConversion m A.Int64 toT exp + (_, False, True) -> + -- Integer to real -- do int -> int64_t -> real. + do genConversionSymbol A.Int64 toT cm + tell [" ("] + genCheckedConversion m fromT A.Int64 (genExpression e) + tell [", "] + genMeta m + tell [")"] + _ -> missing $ "genConversion " ++ show cm + +genConversionSymbol :: A.Type -> A.Type -> A.ConversionMode -> CGen () +genConversionSymbol fromT toT cm + = do tell ["occam_convert_"] + genType fromT + tell ["_"] + genType toT + tell ["_"] + case cm of + A.Round -> tell ["round"] + A.Trunc -> tell ["trunc"] + +genCheckedConversion :: Meta -> A.Type -> A.Type -> CGen () -> CGen () +genCheckedConversion m fromT toT exp + = do tell ["(("] + genType toT + tell [") "] + if isSafeConversion fromT toT + then exp + else do genTypeSymbol "range_check" fromT + tell [" ("] + genTypeSymbol "mostneg" toT + tell [", "] + genTypeSymbol "mostpos" toT + tell [", "] + exp + tell [", "] + genMeta m + tell [")"] + tell [")"] +--}}} + + +--{{{ declarations +--All taken verbatim from GenerateC +genDeclType :: A.AbbrevMode -> A.Type -> CGen () +genDeclType am t + = do when (am == A.ValAbbrev) $ tell ["const "] + genType t + case t of + A.Array _ _ -> return () + A.Chan _ -> return () + A.Record _ -> tell [" *"] + _ -> when (am == A.Abbrev) $ tell [" *"] + +genDecl :: A.AbbrevMode -> A.Type -> A.Name -> CGen () +genDecl am t n + = do genDeclType am t + tell [" "] + genName n +--}}} + +--{{{ case +--All taken verbatim from GenerateC +genCase :: Meta -> A.Expression -> A.Structured -> CGen () +genCase m e s + = do tell ["switch ("] + genExpression e + tell [") {\n"] + seenDefault <- genCaseBody (return ()) s + when (not seenDefault) $ + do tell ["default:\n"] + genStop m "no option matched in CASE process" + tell ["}\n"] + +-- FIXME -- can this be made common with genInputCaseBody above? +genCaseBody :: CGen () -> A.Structured -> CGen Bool +genCaseBody coll (A.Spec _ spec s) + = genCaseBody (genSpec spec coll) s +genCaseBody coll (A.OnlyO _ (A.Option _ es p)) + = do sequence_ [tell ["case "] >> genExpression e >> tell [":\n"] | e <- es] + tell ["{\n"] + coll + genProcess p + tell ["break;\n"] + tell ["}\n"] + return False +genCaseBody coll (A.OnlyO _ (A.Else _ p)) + = do tell ["default:\n"] + tell ["{\n"] + coll + genProcess p + tell ["}\n"] + return True +genCaseBody coll (A.Several _ ss) + = do seens <- mapM (genCaseBody coll) ss + return $ or seens +--}}} + + +-- | Generate C code for a variable. +--Taken verbatim from GenerateC +genVariable :: A.Variable -> CGen () +genVariable = genVariable' True + +-- | Generate C code for a variable without doing any range checks. +--Taken verbatim from GenerateC +genVariableUnchecked :: A.Variable -> CGen () +genVariableUnchecked = genVariable' False + +--Taken verbatim from GenerateC +genVariable' :: Bool -> A.Variable -> CGen () +genVariable' checkValid v + = do am <- accessAbbrevMode v + t <- typeOfVariable v + let isSub = case v of + A.Variable _ _ -> False + A.SubscriptedVariable _ _ _ -> True + + let prefix = case (am, t) of + (_, A.Array _ _) -> "" + (A.Original, A.Chan _) -> if isSub then "" else "&" + (A.Abbrev, A.Chan _) -> "" + (A.Original, A.Record _) -> "&" + (A.Abbrev, A.Record _) -> "" + (A.Abbrev, _) -> "*" + _ -> "" + + when (prefix /= "") $ tell ["(", prefix] + inner v + when (prefix /= "") $ tell [")"] + where + -- | Find the effective abbreviation mode for the variable we're looking at. + -- This differs from abbrevModeOfVariable in that it will return Original + -- for array and record elements (because when we're generating C, we can + -- treat c->x as if it's just x). + accessAbbrevMode :: A.Variable -> CGen A.AbbrevMode + accessAbbrevMode (A.Variable _ n) = abbrevModeOfName n + accessAbbrevMode (A.SubscriptedVariable _ sub v) + = do am <- accessAbbrevMode v + return $ case (am, sub) of + (_, A.Subscript _ _) -> A.Original + (_, A.SubscriptField _ _) -> A.Original + _ -> am + + inner :: A.Variable -> CGen () + inner (A.Variable _ n) = genName n + inner sv@(A.SubscriptedVariable _ (A.Subscript _ _) _) + = do let (es, v) = collectSubs sv + genVariable v + genArraySubscript checkValid v es + inner (A.SubscriptedVariable _ (A.SubscriptField m n) v) + = do genVariable v + tell ["->"] + genName n + inner (A.SubscriptedVariable m (A.SubscriptFromFor m' start _) v) + = inner (A.SubscriptedVariable m (A.Subscript m' start) v) + inner (A.SubscriptedVariable m (A.SubscriptFrom m' start) v) + = inner (A.SubscriptedVariable m (A.Subscript m' start) v) + inner (A.SubscriptedVariable m (A.SubscriptFor m' _) v) + = inner (A.SubscriptedVariable m (A.Subscript m' (makeConstant m' 0)) v) + + -- | Collect all the plain subscripts on a variable, so we can combine them. + collectSubs :: A.Variable -> ([A.Expression], A.Variable) + collectSubs (A.SubscriptedVariable _ (A.Subscript _ e) v) + = (es' ++ [e], v') + where + (es', v') = collectSubs v + collectSubs v = ([], v) + +--Taken verbatim from GenerateC due to export annoyances: +data InputType = ITTimerRead | ITTimerAfter | ITOther + +-- | Given an input mode, figure out what sort of input it's actually doing. +--Taken verbatim from GenerateC due to export annoyances: +inputType :: A.Variable -> A.InputMode -> CGen InputType +inputType c im + = do t <- typeOfVariable c + return $ case t of + A.Timer -> + case im of + A.InputSimple _ _ -> ITTimerRead + A.InputAfter _ _ -> ITTimerAfter + _ -> ITOther + + +--Taken verbatim from GenerateC +genVariableAM :: A.Variable -> A.AbbrevMode -> CGen () +genVariableAM v am + = do when (am == A.Abbrev) $ tell ["&"] + genVariable v + +--{{{ literals +--All taken verbatim from GenerateC +genLiteral :: A.LiteralRepr -> CGen () +genLiteral lr + = if isStringLiteral lr + then do tell ["\""] + let A.ArrayLiteral _ aes = lr + sequence_ [genByteLiteral s + | A.ArrayElemExpr (A.Literal _ _ (A.ByteLiteral _ s)) <- aes] + tell ["\""] + else genLiteralRepr lr + +genLiteralRepr :: A.LiteralRepr -> CGen () +genLiteralRepr (A.RealLiteral m s) = tell [s] +genLiteralRepr (A.IntLiteral m s) = genDecimal s +genLiteralRepr (A.HexLiteral m s) = tell ["0x", s] +genLiteralRepr (A.ByteLiteral m s) = tell ["'"] >> genByteLiteral s >> tell ["'"] +genLiteralRepr (A.ArrayLiteral m aes) + = do genLeftB + genArrayLiteralElems aes + genRightB +genLiteralRepr (A.RecordLiteral _ es) + = do genLeftB + seqComma $ map genUnfoldedExpression es + genRightB + +genArrayLiteralElems :: [A.ArrayElem] -> CGen () +genArrayLiteralElems aes + = seqComma $ map genElem aes + where + genElem :: A.ArrayElem -> CGen () + genElem (A.ArrayElemArray aes) = genArrayLiteralElems aes + genElem (A.ArrayElemExpr e) = genUnfoldedExpression e + + + +--}}} + +--Taken verbatim from GenerateC: +withIf :: A.Expression -> CGen () -> CGen () +withIf cond body + = do tell ["if ("] + genExpression cond + tell [") {\n"] + body + tell ["}\n"] + +--Taken verbatim from GenerateC +genAltProcesses :: String -> String -> String -> A.Structured -> CGen () +genAltProcesses id fired label s = genStructured s doA + where + doA (A.OnlyA _ alt) + = case alt of + A.Alternative _ c im p -> doIn c im p + A.AlternativeCond _ e c im p -> withIf e $ doIn c im p + A.AlternativeSkip _ e p -> withIf e $ doCheck (genProcess p) + + doIn c im p + = do t <- inputType c im + case t of + ITTimerRead -> missing "timer read in ALT" + ITTimerAfter -> doCheck (genProcess p) + ITOther -> doCheck (genInput c im >> genProcess p) + + doCheck body + = do tell ["if (", id, "++ == ", fired, ") {\n"] + body + tell ["goto ", label, ";\n"] + tell ["}\n"] + + diff --git a/Makefile b/Makefile index c1191f4..62673af 100644 --- a/Makefile +++ b/Makefile @@ -9,6 +9,7 @@ sources = \ EvalConstants.hs \ EvalLiterals.hs \ GenerateC.hs \ + GenerateCPPCSP.hs \ Indentation.hs \ Intrinsics.hs \ Main.hs \ diff --git a/tock_support.h b/tock_support.h index 17de148..f816ee9 100644 --- a/tock_support.h +++ b/tock_support.h @@ -12,7 +12,14 @@ #include #include +//For C++CSP: +#ifndef NO_CIFCCSP #include +#else +#define EXTERNAL_CALLN(F,I,args...) (F)((I),##args) +#define EXTERNAL_CALL(F) (F)() +#define SetErr() +#endif //{{{ mostneg/mostpos #define occam_mostneg_bool false @@ -45,11 +52,15 @@ //}}} //{{{ runtime check functions + +//C++CSP may have defined this function already: +#ifndef occam_stop #define occam_stop(pos, format, args...) \ do { \ EXTERNAL_CALLN (fprintf, stderr, "Program stopped at %s: " format "\n", pos, ##args); \ SetErr (); \ } while (0) +#endif //occam_stop static inline int occam_check_slice (int, int, int, const char *) occam_unused; static inline int occam_check_slice (int start, int count, int limit, const char *pos) { diff --git a/tock_support_cppcsp.h b/tock_support_cppcsp.h new file mode 100644 index 0000000..dda9b01 --- /dev/null +++ b/tock_support_cppcsp.h @@ -0,0 +1,197 @@ +//To get the UINT8_MAX etc macros in C++: +#define __STDC_LIMIT_MACROS + +#include + +class StopException +{ +public: + std::string reason; + inline StopException(const std::string& _reason) + : reason(_reason) + { + } +}; + +#define occam_stop(pos, format, args...) \ + do { \ + EXTERNAL_CALLN (fprintf, stderr, "Program stopped at %s: " format "\n", pos, ##args); \ + SetErr (); \ + throw StopException(""); \ + } while (0) + +#define NO_CIFCCSP + +#include "tock_support.h" + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +inline blitz::Array string_to_array(char* c) +{ + const size_t n = strlen(c) + 1; + return blitz::Array((unsigned char*)c,blitz::shape(n),blitz::neverDeleteData); +} + + +class StreamWriter : public csp::CSProcess +{ +private: + std::ostream& out; + csp::Chanin in; +protected: + virtual void run() + { + try + { + uint8_t c; + while (true) + { + in >> c; + out << c; + } + out.flush(); + } + catch (csp::PoisonException& e) + { + in.poison(); + } + } +public: + inline StreamWriter(std::ostream& _out,const csp::Chanin& _in) + : out(_out),in(_in) + { + } +}; + + +//For tieing together chained tuples: + +template +inline boost::tuple +tie10(T1& t1, T2& t2, T3& t3, T4& t4, T5& t5, T6& t6, T7& t7, T8& t8, + T9& t9, T10 t10) { + return boost::tuple + (t1, t2, t3, t4, t5, t6, t7, t8, t9, t10); +} + + +class tockAny : public boost::any +{ +public: + inline tockAny() {} + + inline tockAny(const tockAny& t) + : boost::any(*(boost::any*)&t) + { + } + + template + inline tockAny(T t) : boost::any(t) {} + + template + inline operator T () const + { + return boost::any_cast(*this); + } +}; + + +template < typename T, unsigned dims > +class tockArray : public blitz::Array +{ +public: + inline tockArray(const tockArray& _array) + : blitz::Array(*(blitz::Array*)&_array) {} + + inline tockArray(const tockAny& _any) + : blitz::Array(*(blitz::Array*)& (tockArray)_any) {} + + template + inline tockArray(const tockArray& _diffTypeArray) + : blitz::Array( (T*) (_diffTypeArray.dataFirst()), (_diffTypeArray.shape() * (int)sizeof(U)) / (int)sizeof(T),blitz::neverDeleteData) {} + + template + inline tockArray(const tockArray& _diffDimArray) + : blitz::Array( (T*) (_diffDimArray.dataFirst()),blitz::shape(_diffDimArray.size()),blitz::neverDeleteData) {} + + template + inline tockArray(U* u) + : blitz::Array( (T*) u, sizeof(U) / sizeof(T),blitz::neverDeleteData) {} + + inline tockArray(T t) : blitz::Array(1) {(*this)(0) = t;} + + + template + inline tockArray(U u) : blitz::Array(u) {} + + template + inline tockArray(U u,V v) : blitz::Array(u,v) {} + + template + inline tockArray(U u,V v,W w) : blitz::Array(u,v,w) {} + + template + inline tockArray(U u,V v,W w,X x) : blitz::Array(u,v,w,x) {} + + template + inline tockArray(U u,V v,W w,X x,Y y) : blitz::Array(u,v,w,x,y) {} + + template + inline tockArray(U u,V v,W w,X x,Y y,Z z) : blitz::Array(u,v,w,x,y,z) {} + + template + inline tockArray(U u,V v,W w,X x,Y y,Z z,Z0 z0) : blitz::Array(u,v,w,x,y,z,z0) {} + + template + inline tockArray(U u,V v,W w,X x,Y y,Z z,Z0 z0,Z1 z1) : blitz::Array(u,v,w,x,y,z,z0,z1) {} + + template + inline tockArray(U u,V v,W w,X x,Y y,Z z,Z0 z0,Z1 z1,Z2 z2) : blitz::Array(u,v,w,x,y,z,z0,z1,z2) {} + + template + inline tockArray(U u,V v,W w,X x,Y y,Z z,Z0 z0,Z1 z1,Z2 z2,Z3 z3) : blitz::Array(u,v,w,x,y,z,z0,z1,z2,z3) {} + + + inline tockArray() {} + + inline tockArray& operator=(const tockArray& rhs) + { + resize(rhs.shape()); + *((blitz::Array*)this) = *((blitz::Array*)&rhs); + return *this; + } + + inline tockArray& operator=(const tockAny& any) + { + return (*this = (tockArray)any); + } + + inline tockArray& operator=(const T& t) + { + this->resize(blitz::shape(1)); + (*this)(0) = t; + return *this; + } + + template + operator U* () + { + return (U*)(void*)(this->dataFirst()); + } + + template + operator const U* const () + { + return (const U*)(const void*)(this->dataFirst()); + } + +};