{- Tock: a compiler for parallel languages Copyright (C) 2007, 2008, 2009 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . -} -- | Generate C code from the mangled AST. Most of the exports here are actually -- for GenerateCPPCSP to use module GenerateC ( cgenOps , cgenReplicatorLoop , cgetCType , cintroduceSpec , cPreReq , cremoveSpec , genCPasses , genDynamicDim , generate , generateC , genLeftB , genMeta , genName , genRightB , genStatic , nameString , needStackSizes , justOnly , withIf ) where import Data.Char import Data.Generics (Data) import Data.List import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set import Control.Monad.State import System.IO import Text.Printf import qualified AST as A import BackendPasses import CompState import Errors import EvalConstants import EvalLiterals import Intrinsics import GenerateCBased import Metadata import Pass import qualified Properties as Prop import ShowCode import TLP import Traversal import Types import TypeSizes import Utils --{{{ passes related to C generation genCPasses :: [Pass A.AST] genCPasses = [transformWaitFor] --}}} cPreReq :: [Property] cPreReq = cCppCommonPreReq ++ [Prop.parsIdentified, Prop.waitForRemoved] --{{{ generator ops -- | Operations for the C backend. cgenOps :: GenOps cgenOps = GenOps { declareFree = cdeclareFree, declareInit = cdeclareInit, genActual = cgenActual, genActuals = cgenActuals, genAlt = cgenAlt, genAllocMobile = cgenAllocMobile, genArrayLiteralElems = cgenArrayLiteralElems, genArrayStoreName = genName, genArraySubscript = cgenArraySubscript, genAssert = cgenAssert, genAssign = cgenAssign, genBytesIn = cgenBytesIn, genCase = cgenCase, genCheckedConversion = cgenCheckedConversion, genClearMobile = cgenClearMobile, genCloneMobile = cgenCloneMobile, genConversion = cgenConversion, genConversionSymbol = cgenConversionSymbol, getCType = cgetCType, genDecl = cgenDecl, genDeclaration = cgenDeclaration, genDirectedVariable = cgenDirectedVariable, genExpression = cgenExpression, genFlatArraySize = cgenFlatArraySize, genForwardDeclaration = cgenForwardDeclaration, genFunctionCall = cgenFunctionCall, genGetTime = cgenGetTime, genIf = cgenIf, genInput = cgenInput, genInputItem = cgenInputItem, genIntrinsicFunction = cgenIntrinsicFunction, genIntrinsicProc = cgenIntrinsicProc, genListAssign = cgenListAssign, genListConcat = cgenListConcat, genListLiteral = cgenListLiteral, genListSize = cgenListSize, genLiteral = cgenLiteral, genLiteralRepr = cgenLiteralRepr, genMissing = cgenMissing, genMissingC = (\x -> x >>= cgenMissing), genOutput = cgenOutput, genOutputCase = cgenOutputCase, genOutputItem = cgenOutputItem, genOverArray = cgenOverArray, genPar = cgenPar, genPoison = error "genPoison", genProcCall = cgenProcCall, genProcess = cgenProcess, genRecordTypeSpec = cgenRecordTypeSpec, genReplicatorStart = cgenReplicatorStart, genReplicatorEnd = cgenReplicatorEnd, genReplicatorLoop = cgenReplicatorLoop, genReschedule = cgenReschedule, genRetypeSizes = cgenRetypeSizes, genSetAff = cgenSetAff, genSetPri = cgenSetPri, genSeq = cgenSeq, genSpec = cgenSpec, genSpecMode = cgenSpecMode, genStop = cgenStop, genStructured = cgenStructured, genTimerRead = cgenTimerRead, genTimerWait = cgenTimerWait, genTopLevel = cgenTopLevel, genTypeSymbol = cgenTypeSymbol, genUnfoldedExpression = cgenUnfoldedExpression, genUnfoldedVariable = cgenUnfoldedVariable, genVariable' = cgenVariableWithAM True, genVariableUnchecked = \v am -> cgenVariableWithAM False v am id, genWhile = cgenWhile, getScalarType = cgetScalarType, introduceSpec = cintroduceSpec, removeSpec = cremoveSpec } --}}} --{{{ top-level generateC :: (Handle, Handle) -> String -> A.AST -> PassM () generateC = generate cgenOps needStackSizes :: (CSMR m, Die m) => m [A.Name] needStackSizes = do cs <- getCompState return $ nub $ ([A.Name emptyMeta $ nameString $ A.Name emptyMeta n | A.NameDef {A.ndName = n ,A.ndSpecType=A.Proc {} } <- Map.elems $ csNames cs] ++ [A.Name emptyMeta $ nameString $ A.Name emptyMeta n | A.NameDef {A.ndName = n ,A.ndSpecType=A.Function {} } <- Map.elems $ csNames cs] ) \\ (map (A.Name emptyMeta . nameString . A.Name emptyMeta . fst) (csExternals cs)) cgenTopLevel :: String -> A.AST -> CGen () cgenTopLevel headerName s = do tell ["#define occam_INT_size ", show cIntSize,"\n"] tell ["#include \n"] cs <- getCompState let isHeaderSpec (A.Specification _ n _) = A.nameName n `elem` (csOriginalTopLevelProcs cs) isBodySpec (A.Specification _ n sp) = A.nameName n `notElem` (csOriginalTopLevelProcs cs) tellToHeader (mungeToC $ dropPath headerName) $ sequence_ $ map (call genForwardDeclaration True) (reverse $ listifyDepth isHeaderSpec s) -- The header now contains record types and such, so we need to include -- that before forward-declaring other PROCs: tell ["#include \"", dropPath headerName, "\"\n"] -- Things like lifted wrapper_procs we still need to forward-declare, -- but we do it in the C file, not in the header: sequence_ $ map (call genForwardDeclaration False) (reverse $ listifyDepth (isBodySpec) s) sequence_ [let usedFile' = if ".tock.inc" `isSuffixOf` usedFile then take (length usedFile - length ".tock.inc") usedFile else usedFile in tell ["#include \"", usedFile', ".tock.h\"\n"] | usedFile <- (Set.toList $ csUsedFiles cs) ++ csExtraIncludes cs] nss <- needStackSizes sequence_ [tell ["extern int "] >> genName n >> tell ["_stack_size;\n"] | n <- nss] when (csHasMain $ csOpts cs) $ do (tlpName, tlpChans) <- tlpInterface tell ["extern int "] genName tlpName tell ["_stack_size;\n"] -- Forward declarations of externals: sequence_ [tell ["extern void ", mungeExternalName n, "(int*);"] | (n, ExternalOldStyle) <- csExternals cs] call genStructured TopLevel s (\m _ -> tell ["\n#error Invalid top-level item: ", show m]) when (csHasMain $ csOpts cs) $ do (tlpName, tlpChans) <- tlpInterface chans <- sequence [csmLift $ makeNonce emptyMeta "tlp_channel" | _ <- tlpChans] killChans <- sequence [csmLift $ makeNonce emptyMeta "tlp_channel_kill" | _ <- tlpChans] workspaces <- sequence [csmLift $ makeNonce emptyMeta "tlp_channel_ws" | _ <- tlpChans] tell ["void tock_main (Workspace wptr) {\n"] sequence_ [do tell [" Channel ", c, ";\n"] tell [" ChanInit (wptr, &", c, ");\n"] | c <- chans ++ killChans] tell ["\n"] funcs <- sequence [genTLPHandler tc c kc ws | (tc, c, kc, ws) <- zip4 tlpChans chans killChans workspaces] tell [" LightProcBarrier bar;\n\ \ LightProcBarrierInit (wptr, &bar, ", show $ length chans, ");\n"] sequence_ [tell [" LightProcStart (wptr, &bar, ", ws, ", (Process) ", func, ");\n"] | (ws, func) <- zip workspaces funcs] tell ["\n\ \ "] genName tlpName tell [" (wptr"] sequence_ [tell [", &", c] | c <- chans] tell [");\n\ \\n"] sequence_ [tell [" ", func, "_kill (wptr, &", kc, ");\n"] | (func, kc) <- zip funcs killChans] let uses_stdin = if TLPIn `elem` (map snd tlpChans) then "true" else "false" tell [" LightProcBarrierWait (wptr, &bar);\n\ \\n\ \ Shutdown (wptr);\n\ \}\n\ \int kroc_argc;char** kroc_argv;\n\ \int main (int argc, char *argv[]) {\n\ \ kroc_argc=argc;kroc_argv=argv;\n\ \ tock_init_ccsp (", uses_stdin, ");\n\ \\n\ \ Workspace p = ProcAllocInitial (0, "] genName tlpName tell ["_stack_size + 512);\n\ \ ProcStartInitial (p, tock_main);\n\ \\n\ \ // NOTREACHED\n\ \ return 0;\n\ \}\n"] where dropPath = reverse . takeWhile (/= '/') . reverse mungeExternalName (_:cs) = [if c == '.' then '_' else c | c <- cs] mungeToC cs = [if c `elem` valid then c else '_' | c <- cs] where valid = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" -- | Allocate a TLP channel handler process, and return the function that -- implements it. genTLPHandler :: (Maybe A.Direction, TLPChannel) -> String -> String -> String -> CGen String genTLPHandler (_, tc) c kc ws = do tell [" Workspace ", ws, " = ProcAlloc (wptr, 3, 1024);\n\ \ ProcParam (wptr, ", ws, ", 0, &", c, ");\n\ \ ProcParam (wptr, ", ws, ", 1, &", kc, ");\n\ \ ProcParam (wptr, ", ws, ", 2, ", fp, ");\n\ \\n"] return func where (fp, func) = case tc of TLPIn -> ("stdin", "tock_tlp_input") TLPOut -> ("stdout", "tock_tlp_output") TLPError -> ("stderr", "tock_tlp_output") --}}} --{{{ utilities cgenMissing :: String -> CGen () cgenMissing s = tell ["\n#error Unimplemented: ", s, "\n"] --{{{ simple punctuation genLeftB :: CGen () genLeftB = tell ["{"] genRightB :: CGen () genRightB = tell ["}"] --}}} -- | Map an operation over every item of an occam array. cgenOverArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen () cgenOverArray m var func = do vart <- astTypeOf var ds <- case vart of A.Array ds _ -> return ds A.Mobile (A.Array ds _) -> return ds _ -> diePC m $ formatCode "genOverArray called on non-array type %" vart specs <- sequence [csmLift $ makeNonceVariable "i" m A.Int 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.NoCheck $ A.ExprVariable m i | i <- indices]) case func arg of Just p -> do sequence_ [do tell ["for(int "] call genVariable i A.Original tell ["=0;"] call genVariable i A.Original tell ["<"] case d of A.UnknownDimension -> genDynamicDim var v A.Dimension n -> call genExpression n tell [";"] call genVariable i A.Original tell ["++){"] | (v :: Int, i, d) <- zip3 [0..] indices ds] p sequence_ [tell ["}"] | _ <- indices] Nothing -> return () -- | Generate code for one of the Structured types. cgenStructured :: Data a => Level -> A.Structured a -> (Meta -> a -> CGen b) -> CGen [b] cgenStructured lvl (A.Spec _ spec s) def = call genSpec lvl spec (call genStructured lvl s def) cgenStructured lvl (A.ProcThen _ p s) def = call genProcess p >> call genStructured lvl s def cgenStructured lvl (A.Several _ ss) def = sequence [call genStructured lvl s def | s <- ss] >>* concat cgenStructured _ (A.Only m s) def = def m s >>* singleton --}}} --{{{ metadata -- | Turn a Meta into a string literal that can be passed to a function -- expecting a const char * argument. genMeta :: Meta -> CGen () genMeta m = tell ["\"", show m, "\""] --}}} --{{{ names nameString :: A.Name -> String nameString n = [if c == '.' then '_' else c | c <- A.nameName n] genName :: A.Name -> CGen () genName n = tell [nameString n] --}}} --{{{ types -- | If a type maps to a simple C type, return Just that; else return Nothing. cgetScalarType :: A.Type -> Maybe String cgetScalarType A.Bool = Just "bool" cgetScalarType A.Byte = Just "uint8_t" cgetScalarType A.UInt16 = Just "uint16_t" cgetScalarType A.UInt32 = Just "uint32_t" cgetScalarType A.UInt64 = Just "uint64_t" cgetScalarType A.Int8 = Just "int8_t" cgetScalarType A.Int = cgetScalarType cIntReplacement cgetScalarType A.Int16 = Just "int16_t" cgetScalarType A.Int32 = Just "int32_t" cgetScalarType A.Int64 = Just "int64_t" cgetScalarType A.Real32 = Just "float" cgetScalarType A.Real64 = Just "double" cgetScalarType (A.Timer A.OccamTimer) = Just "Time" cgetScalarType A.Time = Just "Time" cgetScalarType _ = Nothing indexOfFreeDimensions :: [A.Dimension] -> [Int] indexOfFreeDimensions = (mapMaybe indexOfFreeDimensions') . (zip [0..]) where indexOfFreeDimensions' :: (Int,A.Dimension) -> Maybe Int indexOfFreeDimensions' (_, A.Dimension _) = Nothing indexOfFreeDimensions' (n, A.UnknownDimension) = Just n -- | Generate the number of bytes in a type. cgenBytesIn :: Meta -> A.Type -> Either Bool A.Variable -> CGen () cgenBytesIn m t v = do case (t, v) of (A.Array ds _, Left freeDimensionAllowed) -> case (length (indexOfFreeDimensions ds), freeDimensionAllowed) of (0,_) -> return () (1,False) -> dieP m "genBytesIn type with unknown dimension, when unknown dimensions are not allowed" (1,True) -> return () (_,_) -> dieP m "genBytesIn type with more than one free dimension" _ -> return () genBytesIn' t where genBytesIn' :: A.Type -> CGen () genBytesIn' (A.Array ds t) = do mapM_ genBytesInArrayDim (reverse $ zip ds [0..]) --The reverse is simply to match the existing tests genBytesIn' t genBytesIn' (A.Record n) = do tell ["sizeof("] genName n tell [")"] -- This is so that we can do RETYPES checks on channels; we don't actually -- allow retyping between channels and other things. genBytesIn' t@(A.Chan {}) = do tell ["sizeof("] genType t tell [")"] genBytesIn' t@(A.ChanEnd {}) = do tell ["sizeof("] genType t tell [")"] genBytesIn' t@(A.ChanDataType {}) = tell ["sizeof(mt_cb_t*)"] genBytesIn' (A.Mobile t@(A.Array {})) = tell ["sizeof(mt_array_t*)"] genBytesIn' (A.Mobile _) = tell ["sizeof(void*)"] genBytesIn' (A.List _) = tell ["sizeof(void*)"] genBytesIn' t = do f <- fget getScalarType case f t of Just s -> tell ["sizeof(", s, ")"] Nothing -> diePC m $ formatCode "genBytesIn' %" t -- FIXME: This could be done by generating an expression for the size, -- which is what declareSizesPass has to do -- they should share a helper -- function. genBytesInArrayDim :: (A.Dimension,Int) -> CGen () genBytesInArrayDim (A.Dimension n, _) = do call genExpression n tell ["*"] genBytesInArrayDim (A.UnknownDimension, i) = case v of Right rv -> do genDynamicDim rv i tell ["*"] _ -> return () --}}} genStatic :: Level -> A.Name -> CGen () genStatic NotTopLevel _ = return () genStatic TopLevel n = do cs <- getCompState when (A.nameName n `notElem` csOriginalTopLevelProcs cs) $ tell ["static "] --{{{ declarations cgenDecl :: Level -> A.AbbrevMode -> A.Type -> A.Name -> CGen () cgenDecl lvl am t n = do genStatic lvl n genCType (A.nameMeta n) t am tell [" "] genName n --}}} --{{{ conversions cgenCheckedConversion :: Meta -> A.Type -> A.Type -> CGen () -> CGen () cgenCheckedConversion m fromT toT exp = do tell ["(("] genType toT tell [") "] if isSafeConversion fromT toT then exp else do call genTypeSymbol "range_check" fromT tell [" ("] call genTypeSymbol "mostneg" toT tell [", "] call genTypeSymbol "mostpos" toT tell [", "] exp tell [", "] genMeta m tell [")"] tell [")"] cgenConversion :: Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen () cgenConversion m A.DefaultConversion toT e = do fromT <- astTypeOf e call genCheckedConversion m fromT toT (call genExpression e) cgenConversion m cm toT e = do fromT <- astTypeOf e case (isSafeConversion fromT toT, isRealType fromT, isRealType toT) of (True, _, _) -> -- A safe conversion -- no need for a check. call genCheckedConversion m fromT toT (call genExpression e) (_, True, True) -> -- Real to real. do call genConversionSymbol fromT toT cm tell [" ("] call genExpression e tell [", "] genMeta m tell [")"] (_, True, False) -> -- Real to integer -- do real -> int64_t -> int. do let exp = do call genConversionSymbol fromT A.Int64 cm tell [" ("] call genExpression e tell [", "] genMeta m tell [")"] call genCheckedConversion m A.Int64 toT exp (_, False, True) -> -- Integer to real -- do int -> int64_t -> real. do call genConversionSymbol A.Int64 toT cm tell [" ("] call genCheckedConversion m fromT A.Int64 (call genExpression e) tell [", "] genMeta m tell [")"] _ -> call genMissing $ "genConversion " ++ show cm cgenConversionSymbol :: A.Type -> A.Type -> A.ConversionMode -> CGen () cgenConversionSymbol fromT toT cm = do tell ["occam_convert_"] genType fromT tell ["_"] genType toT tell ["_"] case cm of A.Round -> tell ["round"] A.Trunc -> tell ["trunc"] --}}} --{{{ literals cgenLiteral :: A.LiteralRepr -> A.Type -> CGen () cgenLiteral lr t = if isStringLiteral lr then do tell ["\""] let A.ArrayListLiteral _ (A.Several _ aes) = lr sequence_ [genByteLiteral m s | A.Only _ (A.Literal _ _ (A.ByteLiteral m s)) <- aes] tell ["\""] else call genLiteralRepr lr t -- | Does a LiteralRepr represent something that can be a plain string literal? isStringLiteral :: A.LiteralRepr -> Bool isStringLiteral (A.ArrayListLiteral _ (A.Several _ aes)) = and [case ae of A.Only _ (A.Literal _ _ (A.ByteLiteral _ _)) -> True _ -> False | ae <- aes] isStringLiteral _ = False genLitSuffix :: A.Type -> CGen () genLitSuffix A.UInt32 = tell ["U"] genLitSuffix A.Int64 = tell ["LL"] genLitSuffix A.UInt64 = tell ["ULL"] genLitSuffix A.Real32 = tell ["F"] genLitSuffix _ = return () -- TODO don't allocate for things less than 64-bits in size cgenListLiteral :: A.Structured A.Expression -> A.Type -> CGen () cgenListLiteral (A.Several _ es) t = foldl addItem (tell ["g_queue_new()"]) [e | A.Only _ e <- es] where addItem :: CGen () -> A.Expression -> CGen () addItem prev add = do tell ["g_queue_push_head("] prev tell [","] call genExpression add tell [")"] cgenListSize :: A.Variable -> CGen () cgenListSize v = do tell ["g_queue_get_length("] call genVariable v A.Original tell [")"] cgenListAssign :: A.Variable -> A.Expression -> CGen () cgenListAssign v e = do tell ["tock_free_queue("] call genVariable v A.Original tell [");"] call genVariable v A.Original tell ["="] call genExpression e tell [";"] cgenLiteralRepr :: A.LiteralRepr -> A.Type -> CGen () cgenLiteralRepr (A.RealLiteral m s) t | "Infinity" `isPrefixOf` s = tell ["INFINITY"] | "NaN" `isPrefixOf` s = tell ["NAN"] | otherwise = tell [s] >> genLitSuffix t cgenLiteralRepr (A.IntLiteral m s) t = do genDecimal s genLitSuffix t cgenLiteralRepr (A.HexLiteral m s) t = do f <- fget getScalarType ct <- case f t of Just ct -> return ct Nothing -> diePC m $ formatCode "Non-scalar type for hex literal: " t tell ["((",ct,")0x", s] genLitSuffix t tell [")"] cgenLiteralRepr (A.ByteLiteral m s) _ = tell ["'"] >> genByteLiteral m s >> tell ["'"] cgenLiteralRepr (A.RecordLiteral _ es) _ = do genLeftB seqComma $ map (call genUnfoldedExpression) es genRightB cgenLiteralRepr (A.ArrayListLiteral m aes) (A.Array {}) = genLeftB >> call genArrayLiteralElems aes >> genRightB cgenLiteralRepr (A.ArrayListLiteral _ es) t@(A.List {}) = call genListLiteral es t cgenLiteralRepr (A.ArrayListLiteral m _) t = diePC m $ formatCode "Unknown type for array/list literal: %" t -- | 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! cgenUnfoldedExpression :: A.Expression -> CGen () cgenUnfoldedExpression (A.Literal _ t lr) = do call genLiteralRepr lr t cgenUnfoldedExpression (A.ExprVariable m var) = call genUnfoldedVariable m var cgenUnfoldedExpression e = call genExpression e -- | Generate a variable inside a record literal. cgenUnfoldedVariable :: Meta -> A.Variable -> CGen () cgenUnfoldedVariable m var = do t <- astTypeOf var case t of A.Array ds _ -> do genLeftB unfoldArray ds var genRightB A.Record _ -> do genLeftB fs <- recordFields m t seqComma [call 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]]? _ -> call genVariableUnchecked var A.Original where unfoldArray :: [A.Dimension] -> A.Variable -> CGen () unfoldArray [] v = call genUnfoldedVariable m v unfoldArray (A.Dimension e:ds) v = do n <- evalIntExpression e seqComma $ [unfoldArray ds (A.SubscriptedVariable m (A.Subscript m A.NoCheck $ makeConstant m i) v) | i <- [0..(n - 1)]] unfoldArray _ _ = dieP m "trying to unfold array with unknown dimension" -- | Generate a decimal literal -- removing leading zeroes to avoid producing -- an octal literal! genDecimal :: String -> CGen () genDecimal "0" = tell ["0"] genDecimal ('0':s) = genDecimal s genDecimal ('-':s) = tell ["-"] >> genDecimal s genDecimal s = tell [s] cgenArrayLiteralElems :: A.Structured A.Expression -> CGen () cgenArrayLiteralElems (A.Only _ e) = call genUnfoldedExpression e cgenArrayLiteralElems (A.Several _ aes) = seqComma $ map cgenArrayLiteralElems aes cgenArrayLiteralElems x = call genMissingC $ formatCode "Missing cgenArrayLiteralElems for %" x genByteLiteral :: Meta -> String -> CGen () genByteLiteral m s = do c <- evalByte m s tell [convByte c] convByte :: Char -> String convByte '\'' = "\\'" convByte '"' = "\\\"" convByte '\\' = "\\\\" convByte '\r' = "\\r" convByte '\n' = "\\n" convByte '\t' = "\\t" convByte c | o == 0 = "\\0" | (o < 32 || o > 127) = printf "\\%03o" o | otherwise = [c] where o = ord c --}}} --{{{ variables cgenVariableWithAM :: Bool -> A.Variable -> A.AbbrevMode -> (CType -> CType) -> CGen () cgenVariableWithAM checkValid v am fct = do iv <- inner v t <- astTypeOf v ct <- call getCType m t am >>* fct -- Temporary, for debugging: -- tell ["/* ", show (snd iv), " , trying to get: ", show ct, " */"] vtext <- showCode v dressUp (m, "for variable: " ++ vtext) iv ct where m = findMeta v details :: A.Variable -> CGen CType details v = do t <- astTypeOf v am <- abbrevModeOfVariable v call getCType m t am inner :: A.Variable -> CGen (CGen (), CType) inner v@(A.Variable m n) = do ct <- details v return (genName n, ct) inner (A.DerefVariable m v) = do (A.Mobile t) <- astTypeOf v case t of A.Array _ innerT -> do (cg, ct) <- inner v innerCT <- call getCType m innerT A.Original let cast = tell ["("] >> genType innerT >> tell ["*)"] return (do tell ["("] cast tell ["(("] vtext <- showCode v dressUp (m, "for variable: " ++ vtext) (cg, ct) (Pointer $ Plain "mt_array_t") tell [")->data))"] , Pointer $ innerCT) _ -> inner v inner wholeV@(A.DirectedVariable m dir v) = do (cg, ctInner) <- inner v vtext <- showCode v let cg' = dressUp (m, "for variable: " ++ vtext) (cg, ctInner) (stripPointers ctInner) t <- astTypeOf v wholeT <- astTypeOf wholeV ct <- call getCType m wholeT A.Original return (call genDirectedVariable m t cg' dir, ct) inner (A.VariableSizes m v) = sizes m v inner sv@(A.SubscriptedVariable m sub v) = case sub of A.Subscript _ subCheck _ -> do (es, iv, _) <- collectSubs sv Pointer ct <- details iv let check = if checkValid then subCheck else A.NoCheck -- Arrays should be pointers to the inner element: return (do tell ["("] cgenVariableWithAM checkValid iv A.Original id tell [")"] call genArraySubscript check iv (map (\e -> (findMeta e, call genExpression e)) es) , ct) A.SubscriptField _ fieldName -> do vt <- astTypeOf v fs <- recordFields m vt ct <- case lookup fieldName fs of Just x -> call getCType m x A.Original Nothing -> dieP m $ "Could not find type of field name: " ++ show fieldName case vt of A.Record {} -> -- For records, we expect it to be a pointer to a record: return (do tell ["("] call genVariable' v A.Original stripPointers tell [")."] genName fieldName , ct) A.ChanDataType {} -> return (do tell ["(&(("] call genVariable' v A.Original (const $ Plain "mt_cb_t") let ind = findIndex ((== fieldName) . fst) fs tell [").channels[", maybe "" show ind, "]))"] , ct) A.SubscriptFromFor m' subCheck start count -> do ct <- details v return (do let check = if checkValid then subCheck else A.NoCheck tell ["(&("] cgenVariableWithAM checkValid v A.Original id call genArraySubscript A.NoCheck v [(m', case check of A.NoCheck -> call genExpression start _ -> do tell ["occam_check_slice("] call genExpression start genComma call genExpression count genComma call genVariable (specificDimSize 0 v) A.Original genComma genMeta m' tell [")"] )] tell ["))"] , ct) sizes :: Meta -> A.Variable -> CGen (CGen (), CType) sizes m v = do t <- astTypeOf v f <- fget getScalarType let Just intT = f A.Int case (t, v) of -- For the size of dereferenced arrays, we use the size of the mobile: (A.Array {}, A.DerefVariable m' innerV) -> sizes m innerV -- For mobile arrays, we just need to use the dimensions member: (A.Mobile (A.Array {}), _) -> return (do tell ["(("] genType A.Int tell ["*)("] cgenVariableWithAM checkValid v A.Original (const $ Plain "mt_array_t") tell [").dimensions)"] , Pointer $ Plain intT) (A.Array {}, A.Variable _ n) -> do ss <- getCompState >>* csArraySizes case Map.lookup (A.nameName n) ss of Just n_sizes -> return (genName n_sizes ,Pointer $ Plain intT) Nothing -> dieP m $ "No sizes for " ++ A.nameName n ++ " -- full list: " ++ show (Map.keys ss) (A.Array {}, A.SubscriptedVariable {}) -> do (es, innerV, _) <- collectSubs v case innerV of plainV@(A.Variable {}) -> do (gen, ct) <- inner (A.VariableSizes m plainV) return (do tell ["("] gen tell ["+", show (length es),")"] ,ct) _ -> diePC m $ formatCode "Cannot handle complex sizes expression %" v _ -> diePC m $ formatCode "Cannot handle complex sizes expression %" v -- | Collect all the plain subscripts on a variable, so we can combine them. collectSubs :: A.Variable -> CGen ([A.Expression], A.Variable, A.Type) collectSubs (A.SubscriptedVariable m (A.Subscript _ _ e) v) = do (es', v', t') <- collectSubs v t <- trivialSubscriptType m t' return (es' ++ [e], v', t) collectSubs v = do t <- astTypeOf v return ([], v, t) unwrapMobileType :: A.Type -> CGen (Bool, A.Type) unwrapMobileType (A.Mobile t) = return (True, t) unwrapMobileType t@(A.Record n) = do isMobile <- recordAttr (A.nameMeta n) t >>* A.mobileRecord return (isMobile, t) unwrapMobileType t = return (False, t) cgetCType :: Meta -> A.Type -> A.AbbrevMode -> CGen CType cgetCType m origT am = do (isMobile, t) <- unwrapMobileType origT sc <- fget getScalarType >>* ($ t) case (t, sc, isMobile, am) of -- Channel arrays are a special case, because they are arrays of pointers -- to channels (so that an abbreviated array of channels, and an array -- of abbreviations of channels, both look the same) (A.Array _ t@(A.Chan {}), _, False, _) -> call getCType m t A.Original >>* (Pointer . Pointer) (A.Array _ t@(A.ChanEnd {}), _, False, _) -> call getCType m t A.Original >>* Pointer -- All abbrev modes: (A.Array _ t, _, False, _) -> call getCType m t A.Original >>* (Pointer . const) (A.Array {}, _, True, A.Abbrev) -> return $ Pointer $ Pointer $ Plain "mt_array_t" (A.Array {}, _, True, _) -> return $ Pointer $ Plain "mt_array_t" (A.Record n, _, False, A.Original) -> return $ Plain $ nameString n -- Abbrev and ValAbbrev, and mobile: (A.Record n, _, False, _) -> return $ Const . Pointer $ const $ Plain $ nameString n (A.Record n, _, True, A.Abbrev) -> return $ Pointer $ Pointer $ Plain $ nameString n (A.Record n, _, True, _) -> return $ Pointer $ const $ Plain $ nameString n (A.Chan (A.ChanAttributes shW shR) _, _, False, _) | shW == A.Shared || shR == A.Shared -> return $ Pointer $ Plain "mt_cb_t" (A.ChanEnd _ A.Shared _, _, False, _) -> return $ Pointer $ Plain "mt_cb_t" (A.Chan {}, _, False, A.Original) -> return $ Plain "Channel" (A.Chan {}, _, False, _) -> return $ Const $ Pointer $ Plain "Channel" (A.ChanEnd {}, _, False, _) -> return $ Const $ Pointer $ Plain "Channel" (A.ChanDataType {}, _, _, A.Abbrev) -> return $ Pointer $ Pointer $ Plain "mt_cb_t" (A.ChanDataType {}, _, _, _) -> return $ Pointer $ Plain "mt_cb_t" (A.Barrier, _, False, A.Original) -> return $ Pointer $ Plain "mt_barrier_t" (A.Barrier, _, False, A.Abbrev) -> return $ Pointer $ Plain "mt_barrier_t" -- Scalar types: (_, Just pl, False, A.Original) -> return $ Plain pl (_, Just pl, False, A.Abbrev) -> return $ Const $ Pointer $ Plain pl (_, Just pl, False, A.ValAbbrev) -> return $ Const $ Plain pl -- Mobile scalar types: (_, Just pl, True, A.Original) -> return $ Pointer $ Plain pl (_, Just pl, True, A.Abbrev) -> return $ Pointer $ Pointer $ Plain pl (_, Just pl, True, A.ValAbbrev) -> return $ Pointer $ Const $ Plain pl -- This shouldn't happen, but no harm: (A.UserDataType {}, _, _, _) -> do t' <- resolveUserType m t cgetCType m t' am -- Must have missed one: (_,_,_,am) -> diePC m $ formatCode ("Cannot work out the C type for: % (" ++ show (origT, am) ++ ")") origT where const = if am == A.ValAbbrev then Const else id cgenDirectedVariable :: Meta -> A.Type -> CGen () -> A.Direction -> CGen () cgenDirectedVariable _ _ var _ = var genDynamicDim :: A.Variable -> Int -> CGen () genDynamicDim v i = do A.Array ds _ <- astTypeOf v case ds !! i of A.Dimension e -> call genExpression e A.UnknownDimension -> call genVariable (A.SubscriptedVariable m (A.Subscript m A.NoCheck $ makeConstant m i) $ A.VariableSizes m v) A.Original where m = findMeta v cgenArraySubscript :: A.SubscriptCheck -> A.Variable -> [(Meta, CGen ())] -> CGen () cgenArraySubscript check v es = do t <- astTypeOf v let numDims = case t of A.Array ds _ -> length ds A.Mobile (A.Array ds _) -> length ds tell ["["] sequence_ $ intersperse (tell ["+"]) $ genPlainSub (genDynamicDim 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... genPlainSub :: (Int -> CGen ()) -> [(Meta, CGen ())] -> [Int] -> [CGen ()] genPlainSub _ [] _ = [] genPlainSub _ (_:_) [] = [dieP (findMeta v) "Fewer subscripts than dimensions in genPlainSub"] genPlainSub genDim ((m,e):es) (sub:subs) = gen : genPlainSub genDim es subs where gen = sequence_ $ intersperse (tell ["*"]) $ genSub : genChunks genSub = case check of A.NoCheck -> e A.CheckBoth -> do tell ["occam_check_index("] e tell [","] genDim sub tell [","] genMeta m tell [")"] A.CheckUpper -> do tell ["occam_check_index_upper("] e tell [","] genDim sub tell [","] genMeta m tell [")"] A.CheckLower -> do tell ["occam_check_index_lower("] e tell [","] genMeta m tell [")"] genChunks = map genDim subs --}}} --{{{ expressions cgenExpression :: A.Expression -> CGen () cgenExpression (A.MostPos m t) = call genTypeSymbol "mostpos" t cgenExpression (A.MostNeg m t) = call genTypeSymbol "mostneg" t --cgenExpression (A.SizeType m t) cgenExpression (A.SizeExpr m (A.ExprVariable _ v)) = do call genVariable (specificDimSize 0 v) A.Original cgenExpression (A.Conversion m cm t e) = call genConversion m cm t e cgenExpression (A.ExprVariable m v) = call genVariable v A.Original cgenExpression (A.Literal _ t lr) = call genLiteral lr t cgenExpression (A.True m) = tell ["true"] cgenExpression (A.False m) = tell ["false"] -- Any function calls remaining must be to the built-in operator functions: cgenExpression (A.FunctionCall m n es) = call genFunctionCall m n es cgenExpression (A.IntrinsicFunctionCall m s es) = call genIntrinsicFunction m s es --cgenExpression (A.BytesInExpr m e) cgenExpression (A.BytesInExpr m (A.ExprVariable _ v)) = do t <- astTypeOf v call genBytesIn m t (Right v) cgenExpression (A.BytesInType m t) = call genBytesIn m t (Left False) --cgenExpression (A.OffsetOf m t n) --cgenExpression (A.ExprConstr {}) cgenExpression (A.AllocMobile m t me) = call genAllocMobile m t me cgenExpression (A.CloneMobile m e) = call genCloneMobile m e cgenExpression (A.IsDefined m (A.ExprVariable _ (A.DerefVariable _ v))) = tell ["("] >> call genVariable v A.Original >> tell ["!=NULL)"] cgenExpression (A.IsDefined m e) = tell ["("] >> call genExpression e >> tell ["!=NULL)"] cgenExpression t = call genMissing $ "genExpression " ++ show t cgenFunctionCall :: Meta -> A.Name -> [A.Expression] -> CGen () cgenFunctionCall m n es = do A.Function _ _ _ fs _ <- specTypeOfName n genName n tell ["(wptr,"] call genActuals genComma fs (map A.ActualExpression es) tell [","] genMeta m tell [")"] cgenTypeSymbol :: String -> A.Type -> CGen () cgenTypeSymbol s t = do f <- fget getScalarType case (t, f t) of (A.Time, _) -> tell ["occam_", s, "_time"] (_, Just ct) -> tell ["occam_", s, "_", ct] (_, Nothing) -> call genMissingC $ formatCode "genTypeSymbol %" t cgenIntrinsicFunction :: Meta -> String -> [A.Expression] -> CGen () cgenIntrinsicFunction m s es = do let (funcName, giveMeta) = case lookup s simpleFloatIntrinsics of Just (_,cName) -> (cName, False) Nothing -> ("occam_" ++ [if c == '.' then '_' else c | c <- s], True) tell [funcName, "("] seqComma [call genExpression e | e <- es] when (giveMeta) $ genComma >> genMeta m tell [")"] --}}} --{{{ operators --}}} cgenListConcat :: A.Expression -> A.Expression -> CGen () cgenListConcat a b = do tell ["tock_queue_concat("] call genExpression a tell [","] call genExpression b tell [")"] --{{{ input/output items genDest :: (CType -> CType) -> A.Variable -> CGen () genDest f v = call genVariable' v A.Original (f . Pointer . stripPointers) genChan :: A.Variable -> CGen () genChan c = call genVariable' c A.Original (const $ Pointer $ Plain "Channel") cgenInputItem :: A.Variable -> A.InputItem -> Maybe A.Process -> CGen () cgenInputItem c (A.InCounted m cv av) mp = do call genInputItem c (A.InVariable m cv) Nothing case mp of Nothing -> cgenInputItem' "" Just p -> do tell ["ChanXAble(wptr,"] genChan c tell [");"] cgenInputItem' "X" call genProcess p tell ["ChanXEnd(wptr,"] genChan c tell [");"] where cgenInputItem' x = do t <- astTypeOf av tell ["Chan", x, "In(wptr,"] genChan c tell [","] genDest id av tell [","] subT <- trivialSubscriptType m t call genVariable cv A.Original tell ["*"] call genBytesIn m subT (Right av) tell [");"] cgenInputItem c (A.InVariable m v) mp = case mp of Nothing -> cgenInputItem' "" Just p -> do tell ["ChanXAble(wptr,"] genChan c tell [");"] cgenInputItem' "X" call genProcess p tell ["ChanXEnd(wptr,"] genChan c tell [");"] where cgenInputItem' x = do case v of -- If we are reading into a dereferenced mobile, we must make sure -- that something is in that mobile first: A.DerefVariable _ v' -> do tell ["if ("] call genVariable v' A.Original tell ["==NULL){"] call genVariable v' A.Original tell ["="] t <- astTypeOf v' call genAllocMobile m t Nothing tell [";}"] _ -> return () t <- astTypeOf v isMobile <- isMobileType t let rhs = genDest (if isMobile then Pointer else id) v if isMobile then do call genClearMobile m v -- TODO insert this via a pass tell ["MTChan", x, "In(wptr,"] genChan c tell [",(void**)"] rhs tell [");"] else do tell ["Chan", x, "In(wptr,"] genChan c tell [","] rhs tell [","] call genBytesIn m t (Right v) tell [");"] cgenOutputItem :: A.Type -> A.Variable -> A.OutputItem -> CGen () cgenOutputItem _ c (A.OutCounted m ce ae) = do tce <- astTypeOf ce call genOutputItem tce c (A.OutExpression m ce) t <- astTypeOf ae case ae of A.ExprVariable m v -> do tell ["ChanOut(wptr,"] genChan c tell [","] call genVariable v A.Abbrev tell [","] subT <- trivialSubscriptType m t call genExpression ce tell ["*"] call genBytesIn m subT (Right v) tell [");"] cgenOutputItem innerT c (A.OutExpression m e) = do isMobile <- isMobileType innerT case (innerT, isMobile, e) of (A.Int, _, _) -> do tell ["ChanOutInt(wptr,"] genChan c tell [","] call genExpression e tell [");"] (_, True, A.ExprVariable _ v) -> do tell ["MTChanOut(wptr,"] genChan c tell [",(void*)"] call genVariable' v A.Original Pointer tell [");"] (_, _, A.ExprVariable _ v) -> do tell ["ChanOut(wptr,"] genChan c tell [","] call genVariable v A.Abbrev tell [","] te <- astTypeOf e call genBytesIn m te (Right v) tell [");"] --}}} --{{{ replicators cgenReplicatorStart :: A.Name -> A.Replicator -> CGen () cgenReplicatorStart n rep = do tell ["for("] call genReplicatorLoop n rep tell ["){"] cgenReplicatorEnd :: A.Replicator -> CGen () cgenReplicatorEnd rep = tell ["}"] cgenReplicatorLoop :: A.Name -> A.Replicator -> CGen () cgenReplicatorLoop index (A.For m base count step) -- It is now too hard to work out statically if we could make this a -- simple loop (without an additional counter), because step may be -- negative (and that may be determined at run-time. So we will generate the -- most general loop, and let the C compiler optimise if possibe: = do counter <- csmLift $ makeNonce m "replicator_count" tell ["int ", counter, "="] call genExpression count tell [","] genName index tell ["="] call genExpression base tell [";", counter, ">0;", counter, "--,"] genName index tell ["+="] call genExpression step cgenReplicatorLoop _ _ = cgenMissing "ForEach loops not yet supported in the C backend" --}}} --{{{ abbreviations -- | Generate the size part of a RETYPES\/RESHAPES abbrevation of a variable. cgenRetypeSizes :: Meta -> A.Type -> A.Name -> A.Type -> A.Variable -> CGen () cgenRetypeSizes _ (A.Chan {}) _ (A.Chan {}) _ = return () cgenRetypeSizes _ (A.ChanEnd {}) _ (A.ChanEnd {}) _ = return () cgenRetypeSizes m destT destN srcT srcV = let size = do tell ["occam_check_retype("] call genBytesIn m srcT (Right srcV) tell [","] call genBytesIn m destT (Left True) tell [","] genMeta m tell [")"] isVarArray = case destT of A.Array ds _ -> A.UnknownDimension `elem` ds _ -> False in if isVarArray then size >> tell [";"] else do tell ["if("] size tell ["!=1){"] call genStop m "size mismatch in RETYPES" tell ["}"] -- | Generate the right-hand side of an abbreviation of an expression. abbrevExpression :: A.AbbrevMode -> A.Type -> A.Expression -> CGen () abbrevExpression am t@(A.Array _ _) e = case e of A.ExprVariable _ v -> call genVariable v am A.Literal _ t@(A.Array _ _) r -> call genExpression e _ -> call genMissingC $ formatCode "array expression abbreviation %" e abbrevExpression am t@(A.Record _) (A.ExprVariable _ v) = call genVariable v am abbrevExpression am _ e = call genExpression e --}}} --{{{ specifications cgenSpec :: Level -> A.Specification -> CGen b -> CGen b cgenSpec lvl spec body = do call introduceSpec lvl spec x <- body call removeSpec spec return x -- | Generate a declaration of a new variable. cgenDeclaration :: Level -> A.Type -> A.Name -> Bool -> CGen () cgenDeclaration lvl at@(A.Array ds t) n False = do genStatic lvl n genType t tell [" "] case t of A.Chan _ _ -> do genName n tell ["_storage"] call genFlatArraySize ds tell [";"] genType t tell ["* "] _ -> return () call genArrayStoreName n call genFlatArraySize ds tell [";"] cgenDeclaration lvl (A.Array ds t) n True = do genStatic lvl n genType t tell [" "] call genArrayStoreName n call genFlatArraySize ds tell [";"] cgenDeclaration lvl t n _ = do genStatic lvl n genType t tell [" "] genName n tell [";"] -- | Generate the size of the C array that an occam array of the given -- dimensions maps to. cgenFlatArraySize :: [A.Dimension] -> CGen () cgenFlatArraySize ds = do tell ["["] sequence $ intersperse (tell ["*"]) [call genExpression n | A.Dimension n <- ds] tell ["]"] -- FIXME: genBytesInArrayDim could share with this -- | Initialise an item being declared. cdeclareInit :: Meta -> A.Type -> A.Variable -> Maybe (CGen ()) cdeclareInit _ (A.Chan (A.ChanAttributes A.Unshared A.Unshared) _) var = Just $ do tell ["ChanInit(wptr,"] call genVariableUnchecked var A.Abbrev tell [");"] cdeclareInit _ (A.Chan (A.ChanAttributes shW shR) _) var | shW == A.Shared || shR == A.Shared = Just $ do call genVariable' var A.Original (const $ Pointer $ Plain "mt_cb_t") tell [" = MTAllocChanType(wptr, 1, true);"] cdeclareInit m t@(A.Array ds t') var = Just $ do case t' of A.Chan _ _ -> do tell ["tock_init_chan_array("] call genVariableUnchecked var A.Original tell ["_storage,"] call genVariableUnchecked var A.Original tell [","] sequence_ $ intersperse (tell ["*"]) [call genExpression n | A.Dimension n <- ds] -- FIXME: and again tell [");"] _ -> return () fdeclareInit <- fget declareInit init <- return (\sub -> fdeclareInit m t' (sub var)) call genOverArray m var init cdeclareInit m rt@(A.Record _) var = Just $ do fs <- recordFields m rt sequence_ [initField t (A.SubscriptedVariable m (A.SubscriptField m n) var) | (n, t) <- fs] isMobile <- recordAttr m rt >>* A.mobileRecord when isMobile $ do call genVariableUnchecked var A.Original tell ["=NULL;"] call genAssign m [var] $ A.ExpressionList m [A.AllocMobile m rt Nothing] where initField :: A.Type -> A.Variable -> CGen () initField t v = do fdeclareInit <- fget declareInit doMaybe $ fdeclareInit m t v cdeclareInit m t@(A.Mobile t') var = Just $ do call genVariableUnchecked var A.Original tell ["=NULL;"] {- case t' of A.Array ds _ | A.UnknownDimension `elem` ds -> return () _ -> call genAssign m [var] $ A.ExpressionList m [A.AllocMobile m t Nothing] -} cdeclareInit m (A.ChanDataType {}) var = Just $ do call genVariable' var A.Original (const $ Pointer $ Plain "mt_cb_t") tell ["=NULL;"] cdeclareInit _ _ _ = Nothing -- | Free a declared item that's going out of scope. cdeclareFree :: Meta -> A.Type -> A.Variable -> Maybe (CGen ()) cdeclareFree m (A.Mobile {}) v = Just $ call genClearMobile m v cdeclareFree _ _ _ = Nothing {- Original Abbrev INT x IS y: int *x = &y; int *x = &(*y); []INT xs IS ys: int *xs = ys; int *xs = ys; const int xs_sizes[] = ys_sizes; CHAN OF INT c IS d: Channel *c = d; [10]CHAN OF INT cs: Channel tmp[10]; Channel *cs[10]; for (...) { cs[i] = &tmp[i]; ChanInit(cs[i]); } const int cs_sizes[] = { 10 }; []CHAN OF INT ds IS cs: Channel **ds = cs; const int *ds_sizes = cs_sizes; -} cintroduceSpec :: Level -> A.Specification -> CGen () cintroduceSpec lvl (A.Specification m n (A.Declaration _ t)) = do call genDeclaration lvl t n False fdeclareInit <- fget declareInit case fdeclareInit m t (A.Variable m n) of Just p -> p Nothing -> return () cintroduceSpec lvl (A.Specification _ n (A.Is _ am t (A.ActualVariable v))) = do let rhs = call genVariable v am call genDecl lvl am t n tell ["="] rhs tell [";"] cintroduceSpec lvl (A.Specification m n (A.Is _ am t (A.ActualExpression e))) = do let rhs = abbrevExpression am t e case (am, t, e) of (A.ValAbbrev, A.Array _ ts, A.Literal _ _ _) -> -- 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 genStatic lvl n tell ["const "] genType ts tell [" "] genName n tell ["[] = "] rhs tell [";\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 <- csmLift $ makeNonce m "record_literal" genStatic lvl n tell ["const "] genType t tell [" ", tmp, " = "] rhs tell [";\n"] call genDecl lvl am t n tell [" = &", tmp, ";\n"] _ -> do call genDecl lvl am t n tell [" = "] rhs tell [";\n"] cintroduceSpec lvl (A.Specification _ n (A.Is _ _ (A.Array _ c) (A.ActualChannelArray cs))) = do genStatic lvl n genType c case c of A.Chan _ _ -> tell ["* "] -- Channel ends don't need an extra indirection; in C++ they are not -- pointers, and in C they are already pointers _ -> tell [" "] call genArrayStoreName n tell ["[]={"] seqComma (map (\v -> call genVariable v A.Abbrev) cs) tell ["};"] cintroduceSpec lvl (A.Specification _ n (A.Is _ _ _ (A.ActualClaim v))) = do t <- astTypeOf n case t of A.ChanEnd dir _ _ -> do call genDecl lvl A.Original t n tell ["=(&(((mt_cb_t*)"] lock dir tell [")->channels[0]));"] A.ChanDataType dir _ _ -> do call genDecl lvl A.Original t n tell ["="] lock dir tell [";"] where lock dir = do tell ["TockMTLock(wptr,"] call genVariable' v A.Original (const $ Pointer $ Plain "mt_cb_t") tell [",",if dir == A.DirInput then "MT_CB_CLIENT" else "MT_CB_SERVER" ,")"] cintroduceSpec _ (A.Specification _ _ (A.DataType _ _)) = return () cintroduceSpec _ (A.Specification _ n (A.RecordType _ ra nts)) = call genRecordTypeSpec True n ra nts cintroduceSpec _ (A.Specification _ _ (A.ChanBundleType {})) = return () cintroduceSpec _ (A.Specification _ n (A.Protocol _ _)) = return () cintroduceSpec _ (A.Specification _ n (A.ProtocolCase _ ts)) = do tell ["typedef enum{"] seqComma [genName tag >> tell ["_"] >> genName n | (tag, _) <- ts] -- You aren't allowed to have an empty enum. when (ts == []) $ tell ["empty_protocol_"] >> genName n tell ["}"] genName n tell [";"] cintroduceSpec lvl (A.Specification _ n st@(A.Proc _ _ _ _)) = genProcSpec lvl n st False -- For built-in operators that don't get turned into PROCs: cintroduceSpec _ (A.Specification _ _ (A.Function _ _ _ _ Nothing)) = return () cintroduceSpec lvl (A.Specification _ n (A.Retypes m am t v)) = do origT <- astTypeOf v let rhs = call genVariable v A.Abbrev call genDecl lvl 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.ChanEnd {}) -> False (_, A.Record {}) -> False (A.ValAbbrev, _) -> True _ -> False when deref $ tell ["*"] tell ["("] genCType m t am when deref $ tell ["*"] tell [")("] rhs tell [");"] call genRetypeSizes m t n origT v cintroduceSpec _ (A.Specification _ n (A.Rep m rep)) = call genReplicatorStart n rep cintroduceSpec _ (A.Specification _ n (A.Forking _)) = do tell ["mt_barrier_t* "] genName n tell [" = (mt_barrier_t*)MTAlloc(wptr, MT_MAKE_BARRIER (MT_BARRIER_FORKING), 0);"] --cintroduceSpec (A.Specification _ n (A.RetypesExpr _ am t e)) cintroduceSpec _ n = call genMissing $ "introduceSpec " ++ show n cgenRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen () cgenRecordTypeSpec extraStuff n attr fs | not extraStuff = do tell ["typedef struct{"] sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs] tell ["}"] when (A.packedRecord attr || A.mobileRecord attr) $ tell [" occam_struct_packed "] genName n tell [";"] | otherwise = if null [t | (_, A.Mobile t) <- fs] then do genStatic TopLevel n tell ["const word "] genName n tell ["_mttype = MT_SIMPLE | MT_MAKE_TYPE(MT_DATA);"] genStatic TopLevel n tell ["const int "] genName n tell ["_mtsize = sizeof("] genName n tell [");"] -- Not quite certain CCSP handles these descriptors: else do genStatic TopLevel n tell ["const word "] genName n tell ["_mttype[", show (length mtEntries), "] = {"] seqComma mtEntries tell ["};"] genStatic TopLevel n tell ["const int "] genName n tell ["_mtsize = ", show (length mtEntries), ";"] where mtEntries :: [CGen ()] mtEntries = concatMap (mt . snd) fs mt :: A.Type -> [CGen ()] mt (A.Array ds t) = [do tell ["MT_FARRAY|MT_FARRAY_LEN("] sequence_ $ intersperse (tell ["*"]) [call genExpression e | A.Dimension e <- ds] tell [")"] ] ++ mt t mt t = [mobileElemType False t] cgenForwardDeclaration :: Bool -> A.Specification -> CGen () cgenForwardDeclaration _ (A.Specification _ n st@(A.Proc _ _ _ _)) = genProcSpec TopLevel n st True cgenForwardDeclaration _ (A.Specification _ n (A.RecordType _ b fs)) = call genRecordTypeSpec False n b fs cgenForwardDeclaration _ _ = return () cremoveSpec :: A.Specification -> CGen () cremoveSpec (A.Specification m n (A.Declaration _ t)) = do fdeclareFree <- fget declareFree case fdeclareFree m t var of Just p -> p Nothing -> return () where var = A.Variable m n cremoveSpec (A.Specification _ n (A.Rep _ rep)) = call genReplicatorEnd rep cremoveSpec (A.Specification m n (A.Is _ am t (A.ActualExpression e))) = do fdeclareFree <- fget declareFree case fdeclareFree m t var of Just p -> p Nothing -> return () where var = A.Variable m n cremoveSpec (A.Specification _ n (A.Is _ _ _ (A.ActualClaim v))) = do t <- astTypeOf n let dir = case t of A.ChanEnd dir _ _ -> dir A.ChanDataType dir _ _ -> dir tell ["MTUnlock(wptr,"] call genVariable' v A.Original (const $ Pointer $ Plain "mt_cb_t") tell [",",if dir == A.DirInput then "MT_CB_CLIENT" else "MT_CB_SERVER" ,");"] cremoveSpec (A.Specification _ n (A.Forking _)) = do tell ["MTSync(wptr,"] genName n tell [");"] cremoveSpec _ = return () cgenSpecMode :: A.SpecMode -> CGen () cgenSpecMode A.PlainSpec = return () cgenSpecMode A.InlineSpec = tell ["inline "] --}}} --{{{ formals, actuals, and calling conventions prefixComma :: [CGen ()] -> CGen () prefixComma cs = sequence_ [genComma >> c | c <- cs] cgenActuals :: CGen () -> [A.Formal] -> [A.Actual] -> CGen () cgenActuals inbetween fs as = do when (length fs /= length as) $ dieP m $ "Mismatch in numbers of parameters in backend: " ++ show (length fs) ++ " expected, but actually: " ++ show (length as) sequence_ $ intersperse inbetween [call genActual inbetween f a | (f, a) <- zip fs as] where m | null fs && null as = emptyMeta | null fs = findMeta $ head as | otherwise = findMeta $ head fs cgenActual :: CGen () -> A.Formal -> A.Actual -> CGen () cgenActual inbetween f a = sequence_ $ intersperse inbetween $ realActuals f a id -- | Return generators for all the real actuals corresponding to a single -- actual. realActuals :: A.Formal -> A.Actual -> (CType -> CType) -> [CGen ()] realActuals (A.Formal am _ _) (A.ActualExpression (A.ExprVariable _ v)) fct = [call genVariable' v am fct] realActuals _ (A.ActualExpression e) _ = [call genExpression e] realActuals (A.Formal am _ _) (A.ActualVariable v) fct = [call genVariable' v am fct] -- | Return (type, name) generator pairs for all the real formals corresponding -- to a single formal. realFormals :: A.Formal -> [(CGen (), CGen ())] realFormals (A.Formal am t n) = [(genCType (A.nameMeta n) t am, genName n)] -- | Generate a Proc specification, which maps to a C function. -- This will use ProcGetParam if the Proc is in csParProcs, or the normal C -- calling convention otherwise. If will not munge the name if the process was -- one of the original top-level procs, other than to add an occam_ prefix (which -- avoids name collisions). genProcSpec :: Level -> A.Name -> A.SpecType -> Bool -> CGen () genProcSpec lvl n (A.Proc _ (sm, rm) fs (Just p)) forwardDecl = do cs <- getCompState let (header, params) = if n `Map.member` csParProcs cs || rm == A.Recursive then (genParHeader, genParParams) else (genNormalHeader, return ()) if sm == A.InlineSpec then tell ["static "] -- definitely static else genStatic lvl n header if forwardDecl then tell [";\n"] else do tell ["{\n"] params call genProcess p tell ["}\n"] where rfs = concatMap realFormals fs genParHeader :: CGen () genParHeader = do -- These can't be inlined, since they're only used as function -- pointers. tell ["void "] genName n tell [" (Workspace wptr)"] genParParams :: CGen () genParParams = sequence_ [do t tell [" "] n tell [" = ProcGetParam (wptr, " ++ show num ++ ", "] t tell [");\n"] | (num, (t, n)) <- zip [(0 :: Int) ..] rfs] genNormalHeader :: CGen () genNormalHeader = do call genSpecMode sm tell ["void "] genName n tell [" (Workspace wptr"] sequence_ [do tell [", "] case origT of {- A.Record rn | forwardDecl -> do origN <- lookupName rn >>* A.ndOrigName ct <- call getCType (A.nameMeta rn) (A.Record rn) am tell [show $ replacePlainType (nameString rn) (nameString $ A.Name emptyMeta origN) ct ] -} _ -> t tell [" "] n | (A.Formal am origT _, (t, n)) <- zip fs rfs] tell [")"] -- For externals, do nothing here: genProcSpec _ _ (A.Proc _ _ _ Nothing) _ = return () -- | Generate a ProcAlloc for a PAR subprocess, returning a nonce for the -- workspace pointer and the name of the function to call. cgenProcAlloc :: Bool -> A.Name -> [A.Formal] -> [A.Actual] -> CGen (String, CGen ()) cgenProcAlloc forking n fs as = do ras <- liftM concat $ sequence [do isMobile <- isMobileType t let (s, fct) = case (am, isMobile) of (A.ValAbbrev, _) -> ("ProcParam", id) -- This is not needed unless forking: (_, True) | forking -> ("ProcMTMove", Pointer . Pointer . stripPointers) -- This will screw things up with barriers proper -- being passed to forking processes, -- but will work for other forking: _ | forking && t == A.Barrier -> ("ProcMTCopy", const $ Pointer $ Plain "mt_barrier_t") _ -> ("ProcParam", id) return $ zip (repeat s) $ realActuals f a fct | (f@(A.Formal am t _), a) <- zip fs as] ws <- csmLift $ makeNonce (A.nameMeta n) "workspace" tell ["Workspace ", ws, " = ", if forking then "ProcAlloc" else "TockProcAlloc"," (wptr, ", show $ length ras, ", "] genName n tell ["_stack_size);\n"] sequence_ [do tell [pc, " (wptr, ", ws, ", ", show num, ", "] ra tell [");\n"] | (num, (pc, ra)) <- zip [(0 :: Int)..] ras] return (ws, genName n) --}}} --{{{ processes cgenProcess :: A.Process -> CGen () cgenProcess p = case p of A.Assign m vs es -> call genAssign m vs es A.Input m c im -> call genInput c im A.Output m c ois -> do Left ts <- protocolItems m c call genOutput c $ zip ts ois A.OutputCase m c t ois -> call genOutputCase c t ois A.Skip m -> tell ["/* skip */\n"] A.Stop m -> call genStop m "STOP process" A.Seq _ s -> call genSeq s A.If m s -> call genIf m s A.Case m e s -> call genCase m e s A.While m e p -> call genWhile e p A.Par m pm s -> call genPar pm s -- PROCESSOR does nothing special. A.Processor m e p -> call genProcess p A.Alt m b s -> call genAlt b s A.InjectPoison m ch -> call genPoison m ch A.ProcCall m n as -> call genProcCall n as A.IntrinsicProcCall m s as -> call genIntrinsicProc m s as A.Fork m (Just n) p -> do (n, as) <- case p of A.ProcCall _ n as -> return (n, as) A.Seq _ (A.Only _ (A.ProcCall _ n as)) -> return (n, as) _ -> diePC m $ formatCode "Cannot FORK off: %" p A.Proc _ _ fs _ <- specTypeOfName n (ws, func) <- cgenProcAlloc True n fs as tell ["ProcStart(wptr,", ws, ","] func tell [");"] A.ClearMobile m v -> call genClearMobile m v --{{{ assignment cgenAssign :: Meta -> [A.Variable] -> A.ExpressionList -> CGen () cgenAssign m [v] (A.ExpressionList _ [e]) = do t <- astTypeOf v trhs <- astTypeOf e f <- fget getScalarType isMobile <- isMobileType t case f t of Just _ -> doAssign v e Nothing -> case (t, isMobile, trhs) of -- Assignment of channel-ends, but not channels, is possible (at least in Rain): (A.ChanEnd A.DirInput _ _, _, _) -> doAssign v e (A.ChanEnd A.DirOutput _ _, _, _) -> doAssign v e (A.List _, _, _) -> call genListAssign v e (A.Mobile (A.List _), _, _) -> call genListAssign v e (_, True, _) -> do call genClearMobile m v case e of A.AllocMobile _ _ Nothing -> doAssign v e A.AllocMobile m t (Just init) -> do doAssign v $ A.AllocMobile m t Nothing call genAssign m [A.DerefVariable m v] $ A.ExpressionList m [init] A.CloneMobile {} -> doAssign v e A.ExprVariable _ vrhs -> do doAssign v e call genVariable vrhs A.Original tell ["=NULL;"] _ -> call genMissing $ "Mobile assignment from " ++ show e (A.Array ds innerT, _, A.Array dsrhs _) | isPOD innerT -> do tell ["memcpy("] call genVariable v A.Abbrev tell [","] call genExpression e tell [","] let f i = A.ExprVariable m $ A.SubscriptedVariable m (A.Subscript m A.NoCheck $ makeConstant m i) (A.VariableSizes m v) ds' = map (workOutDim f) $ zip3 [0..] ds dsrhs call genBytesIn m (A.Array ds' innerT) (Left False) tell [");"] _ -> call genMissingC $ formatCode "assignment of type % (% := %)" t v e where workOutDim :: (Int -> A.Expression) -> (Int, A.Dimension, A.Dimension) -> A.Dimension workOutDim _ (_, A.Dimension e, _) = A.Dimension e workOutDim _ (_, _, A.Dimension e) = A.Dimension e workOutDim func (i, A.UnknownDimension, A.UnknownDimension) = A.Dimension $ func i doAssign :: A.Variable -> A.Expression -> CGen () doAssign v e = do call genVariable v A.Original tell ["="] call genExpression e tell [";"] -- For built-in operators: cgenAssign m [v] (A.FunctionCallList _ n es) = do call genVariable v A.Original tell ["="] call genFunctionCall m n es tell [";"] cgenAssign m (v:vs) (A.IntrinsicFunctionCallList _ n es) = do call genVariable v A.Original let (funcName, giveMeta) = case lookup n simpleFloatIntrinsics of Just (_,cName) -> (cName, False) Nothing -> ("occam_" ++ [if c == '.' then '_' else c | c <- n], True) tell ["=",funcName,"("] seqComma $ map (call genExpression) es mapM (\v -> tell [","] >> call genActual genComma (A.Formal A.Abbrev A.Int (A.Name emptyMeta "dummy_intrinsic_param")) (A.ActualVariable v)) vs when giveMeta $ genComma >> genMeta m tell [");"] cgenAssign m [vA, vB] (A.AllocChannelBundle _ n) = do t@(A.ChanDataType dirA shA _) <- astTypeOf vA A.ChanDataType dirB shB _ <- astTypeOf vB call genClearMobile m vA call genClearMobile m vB fs <- recordFields m t call genVariable' vA A.Original (const $ Pointer $ Plain "mt_cb_t") tell ["=MTAllocChanType(wptr,", show (length fs), ",", if shA == A.Shared || shB == A.Shared then "true" else "false", ");"] -- Mobile channel types start with a reference count of 2, so no need -- to clone, just assign: call genVariable' vB A.Original (const $ Pointer $ Plain "mt_cb_t") tell ["="] call genVariable' vA A.Original (const $ Pointer $ Plain "mt_cb_t") tell [";"] cgenAssign m _ _ = call genMissing "Cannot perform assignment with multiple destinations or multiple sources" isPOD :: A.Type -> Bool isPOD = isJust . cgetScalarType --}}} --{{{ input cgenInput :: A.Variable -> A.InputMode -> CGen () cgenInput c im = do case im of A.InputTimerRead m (A.InVariable m' v) -> call genTimerRead c v A.InputTimerAfter m e -> call genTimerWait e A.InputSimple m [ii] mp -> call genInputItem c ii mp _ -> call genMissing $ "genInput " ++ show im cgenTimerRead :: A.Variable -> A.Variable -> CGen () cgenTimerRead _ v = cgenGetTime v cgenTimerWait :: A.Expression -> CGen () cgenTimerWait e = do tell ["TimerWait(wptr,"] call genExpression e tell [");"] cgenGetTime :: A.Variable -> CGen () cgenGetTime v = do call genVariable v A.Original tell [" = TimerRead(wptr);"] --}}} --{{{ output cgenOutput :: A.Variable -> [(A.Type, A.OutputItem)] -> CGen () cgenOutput c tois = sequence_ [call genOutputItem t c oi | (t, oi) <- tois] cgenOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen () cgenOutputCase c tag ois = do t <- astTypeOf c let proto = case t of A.Chan _ (A.UserProtocol n) -> n A.ChanEnd _ _ (A.UserProtocol n) -> n tell ["ChanOutInt(wptr,"] call genVariable c A.Abbrev tell [","] genName tag tell ["_"] genName proto tell [");"] Right ps <- protocolItems (findMeta c) c let ts = fromMaybe (error "genOutputCase unknown tag") $ lookup tag ps call genOutput c $ zip ts ois --}}} --{{{ stop cgenStop :: Meta -> String -> CGen () cgenStop m s = do tell ["occam_stop("] genMeta m tell [",1,\"", s, "\");"] --}}} --{{{ seq cgenSeq :: A.Structured A.Process -> CGen () cgenSeq s = call genStructured NotTopLevel s doP >> return () where doP _ p = call genProcess p --}}} --{{{ if cgenIf :: Meta -> A.Structured A.Choice -> CGen () cgenIf m s | justOnly s = do call genStructured NotTopLevel s doCplain tell ["{"] call genStop m "no choice matched in IF process" tell ["}"] | otherwise = do label <- csmLift $ makeNonce m "if_end" tell ["/*",label,"*/"] genIfBody label s call genStop m "no choice matched in IF process" tell [label, ":;"] where genIfBody :: String -> A.Structured A.Choice -> CGen () genIfBody label s = call genStructured NotTopLevel s doC >> return () where doC m (A.Choice m' e p) = do tell ["if("] call genExpression e tell ["){"] call genProcess p tell ["goto ", label, ";"] tell ["}"] doCplain _ (A.Choice _ e p) = do tell ["if("] call genExpression e tell ["){"] call genProcess p tell ["}else "] justOnly :: Data a => A.Structured a -> Bool justOnly (A.Only {}) = True justOnly (A.Several _ ss) = all justOnly ss justOnly _ = False --}}} --{{{ case cgenCase :: Meta -> A.Expression -> A.Structured A.Option -> CGen () cgenCase m e s = do tell ["switch("] call genExpression e tell ["){"] seenDefault <- genCaseBody (return ()) s when (not seenDefault) $ do tell ["default:"] call genStop m "no option matched in CASE process" tell ["}"] where genCaseBody :: CGen () -> A.Structured A.Option -> CGen Bool genCaseBody coll (A.Spec _ spec s) = genCaseBody (call genSpec NotTopLevel spec coll) s genCaseBody coll (A.Only _ (A.Option _ es p)) = do sequence_ [tell ["case "] >> call genExpression e >> tell [":"] | e <- es] tell ["{"] coll call genProcess p tell ["}break;"] return False genCaseBody coll (A.Only _ (A.Else _ p)) = do tell ["default:"] tell ["{"] coll call genProcess p tell ["}break;"] return True genCaseBody coll (A.Several _ ss) = do seens <- mapM (genCaseBody coll) ss return $ or seens --}}} --{{{ while cgenWhile :: A.Expression -> A.Process -> CGen () cgenWhile e p = do tell ["while("] call genExpression e tell ["){"] call genProcess p tell ["}"] --}}} --{{{ par -- FIXME: The ParMode is now ignored (as it is in occ21), so PRI PAR behaves -- the same as PAR. cgenPar :: A.ParMode -> A.Structured A.Process -> CGen () cgenPar pm s = do bar <- csmLift $ makeNonce emptyMeta "par_barrier" tell ["LightProcBarrier ", bar, ";"] let count = countStructured s wss <- csmLift $ makeNonce emptyMeta "wss" tell ["Workspace* ",wss,"=(Workspace*)malloc(sizeof(int)*"] call genExpression count tell [");"] tell ["int ",wss,"_count=0;"] tell ["LightProcBarrierInit(wptr,&", bar, ","] call genExpression count tell [");"] call genStructured NotTopLevel s (startP bar wss) tell ["LightProcBarrierWait (wptr, &", bar, ");\n"] tell ["{int i;for(i=0;i<"] call genExpression count tell [";i++){TockProcFree(wptr, ", wss, "[i]);}}"] tell ["free(", wss, ");"] where startP :: String -> String -> Meta -> A.Process -> CGen () startP bar wss _ (A.ProcCall _ n as) = do (A.Proc _ _ fs _) <- specTypeOfName n (ws, func) <- cgenProcAlloc False n fs as tell ["LightProcStart (wptr, &", bar, ", ", ws, ", "] func tell [");"] tell [wss,"[",wss,"_count++]=", ws,";"] --}}} --{{{ alt cgenAlt :: Bool -> A.Structured A.Alternative -> CGen () cgenAlt isPri s = do id <- csmLift $ makeNonce emptyMeta "alt_id" tell ["int ", id, " = 0;\n"] let isTimerAlt = containsTimers s tell [if isTimerAlt then "TimerAlt" else "Alt", " (wptr);\n"] tell ["{\n"] genAltEnable id s tell ["}\n"] -- Like occ21, this is always a PRI ALT, so we can use it for both. tell [if isTimerAlt then "TimerAltWait" else "AltWait", " (wptr);\n"] tell [id, " = 0;\n"] tell ["{\n"] genAltDisable id s tell ["}\n"] fired <- csmLift $ makeNonce emptyMeta "alt_fired" tell ["int ", fired, " = AltEnd (wptr);\n"] tell [id, " = 0;\n"] label <- csmLift $ makeNonce emptyMeta "alt_end" tell ["{\n"] genAltProcesses id fired label s tell ["}\n"] tell [label, ":\n;\n"] where containsTimers :: A.Structured A.Alternative -> Bool containsTimers (A.Spec _ _ s) = containsTimers s containsTimers (A.ProcThen _ _ s) = containsTimers s containsTimers (A.Only _ a) = case a of A.Alternative _ _ _ (A.InputTimerRead _ _) _ -> True A.Alternative _ _ _ (A.InputTimerAfter _ _) _ -> True _ -> False containsTimers (A.Several _ ss) = or $ map containsTimers ss genAltEnable :: String -> A.Structured A.Alternative -> CGen () genAltEnable id s = call genStructured NotTopLevel s doA >> return () where doA _ alt = case alt of A.Alternative _ e c im _ -> withIf e $ doIn c im A.AlternativeSkip _ e _ -> withIf e $ tell ["AltEnableSkip (wptr,", id, "++);\n"] doIn c im = do case im of A.InputTimerRead _ _ -> call genMissing "timer read in ALT" A.InputTimerAfter _ time -> do tell ["AltEnableTimer (wptr,", id, "++,"] call genExpression time tell [");\n"] _ -> do tell ["AltEnableChannel (wptr,", id, "++,"] call genVariable c A.Abbrev tell [");\n"] genAltDisable :: String -> A.Structured A.Alternative -> CGen () genAltDisable id s = call genStructured NotTopLevel s doA >> return () where doA _ alt = case alt of A.Alternative _ e c im _ -> withIf e $ doIn c im A.AlternativeSkip _ e _ -> withIf e $ tell ["AltDisableSkip (wptr,", id, "++);\n"] doIn c im = do case im of A.InputTimerRead _ _ -> call genMissing "timer read in ALT" A.InputTimerAfter _ time -> do tell ["AltDisableTimer (wptr,", id, "++, "] call genExpression time tell [");\n"] _ -> do tell ["AltDisableChannel (wptr,", id, "++, "] call genVariable c A.Abbrev tell [");\n"] genAltProcesses :: String -> String -> String -> A.Structured A.Alternative -> CGen () genAltProcesses id fired label s = call genStructured NotTopLevel s doA >> return () where doA _ alt = case alt of A.Alternative _ e c im p -> withIf e $ doIn c im p A.AlternativeSkip _ e p -> withIf e $ doCheck (call genProcess p) doIn c im p = do case im of A.InputTimerRead _ _ -> call genMissing "timer read in ALT" A.InputTimerAfter _ _ -> doCheck (call genProcess p) _ -> doCheck (call genInput c im >> call genProcess p) doCheck body = do tell ["if (", id, "++ == ", fired, ") {\n"] body tell ["goto ", label, ";\n"] tell ["}\n"] withIf :: A.Expression -> CGen () -> CGen () withIf cond body = do tell ["if ("] call genExpression cond tell [") {\n"] body tell ["}\n"] --}}} --{{{ proc call cgenProcCall :: A.Name -> [A.Actual] -> CGen () cgenProcCall n as = do A.Proc _ (_, rm) _ _ <- specTypeOfName n externalProcs <- getCompState >>* csExternals let ext = lookup (A.nameName n) externalProcs case (rm, ext) of -- This is rather inefficient, because if a recursive PROC is called -- anywhere (from other processes as well as from itself), it will -- be done in a PAR. (A.Recursive, _) -> let m = A.nameMeta n in call genPar A.PlainPar $ A.Only m $ A.ProcCall m n as (_, Just ExternalOldStyle) -> do let (c:cs) = A.nameName n afters <- if null as then tell ["{int ext_args[] = {};"] >> return (return ()) else do tell ["{int ext_args[] = {(int)("] (A.Proc _ _ fs _) <- specTypeOfName n when (length fs /= length as) $ dieP (A.nameMeta n) "Mismatched number of arguments to external call" let inbetween :: CGen (CGen ()) inbetween = tell ["),(int)("] >> return (return ()) afters <- flip evalStateT 0 $ sequence $ intersperse (lift inbetween) $ map (uncurry $ genExternalActual (inbetween >> return ())) $ zip fs as tell [")};"] return $ sequence_ afters case c of 'B' -> tell ["BlockingCallN(wptr,"] 'C' -> tell ["ExternalCallN("] _ -> dieP (A.nameMeta n) "Unknown external PROC format" tell [ [if c == '.' then '_' else c | c <- cs] , ",1,ext_args);"] afters tell ["}"] _ -> do genName n tell [" (wptr", if null as then "" else ","] (A.Proc _ _ fs _) <- specTypeOfName n call genActuals genComma fs as tell [");\n"] where -- This returns any actions that need to take place after the external call genExternalActual :: CGen () -> A.Formal -> A.Actual -> StateT Int CGen (CGen ()) genExternalActual inbetween f@(A.Formal am t n) a = case (t, a) of (A.Mobile arrT@(A.Array {}), A.ActualVariable v) -> -- The extra dimensions parameters have already been added, but KRoC -- passes both the array data and the address of the mobile, so we -- had better do the same: do lift $ call genActual inbetween (A.Formal A.Abbrev arrT n) (A.ActualVariable $ A.DerefVariable (findMeta v) v) modify (+1) lift inbetween -- We need to pass mobiles as the plain pointers (not abbreviated): lift $ call genActual inbetween (A.Formal A.Original arrT n) a i <- modify' (+1) -- i is the value before the second modification return $ do call genVariable' v A.Original (const $ Pointer $ Plain "mt_array_t") tell ["=ext_args[", show i, "];"] _ -> lift (call genActual inbetween f a) >> modify (+1) >> return (return ()) --}}} --{{{ intrinsic procs cgenIntrinsicProc :: Meta -> String -> [A.Actual] -> CGen () cgenIntrinsicProc m "ASSERT" [A.ActualExpression e] = call genAssert m e cgenIntrinsicProc _ "RESCHEDULE" [] = call genReschedule cgenIntrinsicProc m "CAUSEERROR" [] = call genStop m "CAUSEERROR" cgenIntrinsicProc m "EXIT" [A.ActualExpression e] = do tell ["exit("] call genExpression e tell [");"] cgenIntrinsicProc m "SETAFF" [A.ActualExpression e] = call genSetAff m e cgenIntrinsicProc m "SETPRI" [A.ActualExpression e] = call genSetPri m e cgenIntrinsicProc m s as = case lookup s intrinsicProcs of Just amtns -> do tell ["occam_", [if c == '.' then '_' else c | c <- s], "(wptr,"] when (s == "RESIZE.MOBILE.ARRAY.1D") $ do let mob = head as A.Mobile (A.Array _ t) <- astTypeOf mob call genBytesIn m t (Left False) tell [","] seqComma [call genActual genComma (A.Formal am t (A.Name emptyMeta n)) a | ((am, t, n), a) <- zip amtns as] tell [");"] Nothing -> call genMissing $ "intrinsic PROC " ++ s cgenReschedule :: CGen () cgenReschedule = tell ["Reschedule (wptr);"] cgenAssert :: Meta -> A.Expression -> CGen () cgenAssert m e = do tell ["if (!"] call genExpression e tell [") {\n"] call genStop m "assertion failed" tell ["}\n"] cgenSetAff :: Meta -> A.Expression -> CGen () cgenSetAff _ e = do tell ["SetAffinity(wptr,"] call genExpression e tell [");"] cgenSetPri :: Meta -> A.Expression -> CGen () cgenSetPri _ e = do tell ["SetPriority(wptr,"] call genExpression e tell [");"] --}}} --}}} --{{{ mobiles cgenAllocMobile :: Meta -> A.Type -> Maybe A.Expression -> CGen() cgenAllocMobile m (A.Mobile t@(A.Array ds innerT)) Nothing | A.UnknownDimension `elem` ds = dieP m "Cannot allocate mobile array with unknown dimension" | otherwise = do let elemSize = call genBytesIn m innerT (Left False) numDims = show $ length ds wrap alloc = do tell ["TockZeroMobileArray("] alloc tell [","] elemSize tell [",", numDims, ")"] mobInner <- isMobileType innerT (if mobInner then wrap else id) $ do tell ["MTAllocDataArray(wptr,"] elemSize tell [",", numDims] prefixComma $ [call genExpression e | A.Dimension e <- ds] tell [")"] cgenAllocMobile m (A.Mobile t) Nothing = do tell ["MTAlloc(wptr,"] mobileElemType False t tell [","] call genBytesIn m t (Left False) tell [")"] cgenAllocMobile m t@(A.Record n) Nothing = do isMobile <- recordAttr m t >>* A.mobileRecord if isMobile then do tell ["MTAlloc(wptr,"] mobileElemType False t tell [","] genName n tell ["_mtsize)"] else dieP m "Attempted to allocate a non-mobile record type" --TODO add a pass, just for C, that pulls out the initialisation expressions for mobiles -- into a subsequent assignment cgenAllocMobile _ _ _ = call genMissing "Mobile allocation with initialising-expression" -- The Bool is True if inside an array, False otherwise mobileElemType :: Bool -> A.Type -> CGen () mobileElemType _ (A.Record n) = do tell ["(word)"] genName n tell ["_mttype"] mobileElemType b A.Int = mobileElemType b cIntReplacement mobileElemType b A.Bool = mobileElemType b A.Byte -- CCSP only supports NUM with MTAlloc inside arrays: mobileElemType True t = tell ["MT_MAKE_NUM(MT_NUM_", showOccam t,")"] mobileElemType False t = tell ["MT_SIMPLE|MT_MAKE_TYPE(MT_DATA)"] cgenClearMobile :: Meta -> A.Variable -> CGen () cgenClearMobile _ v = do tell ["if("] genVar tell ["!=NULL){MTRelease(wptr,(void*)"] genVar tell [");"] genVar tell ["=NULL;}"] where genVar = call genVariable v A.Original cgenCloneMobile :: Meta -> A.Expression -> CGen () cgenCloneMobile _ e = do tell ["MTClone(wptr,(void*)"] call genExpression e tell [")"] --}}}