8f767ff0d4
This makes sure that we catch all leftover instances of using SYB to do generic operations that we should be using Polyplate for instead. Most modules should only import Data, and possibly Typeable.
2167 lines
83 KiB
Haskell
2167 lines
83 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007, 2008 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 <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
-- | 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,
|
|
genProcCall = cgenProcCall,
|
|
genProcess = cgenProcess,
|
|
genRecordTypeSpec = cgenRecordTypeSpec,
|
|
genReplicatorStart = cgenReplicatorStart,
|
|
genReplicatorEnd = cgenReplicatorEnd,
|
|
genReplicatorLoop = cgenReplicatorLoop,
|
|
genReschedule = cgenReschedule,
|
|
genRetypeSizes = cgenRetypeSizes,
|
|
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]
|
|
)
|
|
\\ (map (A.Name emptyMeta . nameString . A.Name emptyMeta . fst) (csExternals cs)))
|
|
++
|
|
[A.Name emptyMeta $ nameString $ A.Name emptyMeta n
|
|
| A.NameDef {A.ndName = n
|
|
,A.ndSpecType=A.Function {}
|
|
} <- Map.elems $ csNames cs]
|
|
|
|
cgenTopLevel :: String -> A.AST -> CGen ()
|
|
cgenTopLevel headerName s
|
|
= do tell ["#define occam_INT_size ", show cIntSize,"\n"]
|
|
tell ["#include <tock_support_cif.h>\n"]
|
|
cs <- getCompState
|
|
|
|
let isTopLevelSpec (A.Specification _ n _)
|
|
= A.nameName n `elem` (csOriginalTopLevelProcs cs)
|
|
|
|
tellToHeader $ sequence_ $ map (call genForwardDeclaration)
|
|
(listifyDepth isTopLevelSpec s)
|
|
-- 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)
|
|
(listifyDepth (not . isTopLevelSpec) s)
|
|
|
|
tell ["#include \"", dropPath headerName, "\"\n"]
|
|
|
|
sequence_ [tell ["#include \"", usedFile, ".tock.h\"\n"]
|
|
| usedFile <- Set.toList $ csUsedFiles cs]
|
|
|
|
nss <- needStackSizes
|
|
sequence_ [tell ["extern int "] >> genName n >> tell ["_stack_size;\n"]
|
|
| n <- nss]
|
|
|
|
when (csHasMain 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 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\
|
|
\\n\
|
|
\int main (int argc, char *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]
|
|
|
|
-- | 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 A.Array ds _ <- astTypeOf var
|
|
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' (A.Mobile t@(A.Array {})) = genBytesIn' 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, " */"]
|
|
dressUp m 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 ["(("]
|
|
dressUp m (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
|
|
let cg' = dressUp m (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 ["("]
|
|
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 A.Shared A.Shared) _, _, False, _)
|
|
-> 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 $ Pointer $ Plain "Channel"
|
|
(A.ChanEnd {}, _, False, _) -> return $ Pointer $ Plain "Channel"
|
|
|
|
(A.ChanDataType {}, _, _, _) -> return $ Pointer $ Plain "mt_cb_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 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
|
|
|
|
genChan, genDest :: A.Variable -> CGen ()
|
|
genDest v = call genVariable' v A.Original (Pointer . stripPointers)
|
|
genChan c = call genVariable' c A.Original (const $ Pointer $ Plain "Channel")
|
|
|
|
cgenInputItem :: A.Variable -> A.InputItem -> CGen ()
|
|
cgenInputItem c (A.InCounted m cv av)
|
|
= do call genInputItem c (A.InVariable m cv)
|
|
t <- astTypeOf av
|
|
tell ["ChanIn(wptr,"]
|
|
genChan c
|
|
tell [","]
|
|
genDest 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)
|
|
= 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 v
|
|
case (t, isMobile) of
|
|
(A.Int, _) ->
|
|
do tell ["ChanInInt(wptr,"]
|
|
genChan c
|
|
tell [","]
|
|
rhs
|
|
tell [");"]
|
|
(_, True) ->
|
|
do call genClearMobile m v -- TODO insert this via a pass
|
|
tell ["MTChanIn(wptr,"]
|
|
genChan c
|
|
tell [",(void**)"]
|
|
rhs
|
|
tell [");"]
|
|
_ ->
|
|
do tell ["ChanIn(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 A.Shared A.Shared) _) var
|
|
= 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 _ _ (A.RecordType _ _ _)) = return ()
|
|
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.RetypesExpr _ am t e))
|
|
cintroduceSpec _ n = call genMissing $ "introduceSpec " ++ show n
|
|
|
|
cgenRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
|
|
cgenRecordTypeSpec n attr fs
|
|
= 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 [";"]
|
|
tell ["typedef "]
|
|
genName n
|
|
origN <- lookupName n >>* A.ndOrigName
|
|
tell [" ", nameString $ A.Name emptyMeta origN, ";"]
|
|
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 :: 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 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 _ = 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 :: [A.Formal] -> [A.Actual] -> CGen ()
|
|
cgenActuals 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)
|
|
seqComma [call genActual f a | (f, a) <- zip fs as]
|
|
where
|
|
m | null fs && null as = emptyMeta
|
|
| null fs = findMeta $ head as
|
|
| otherwise = findMeta $ head fs
|
|
|
|
cgenActual :: A.Formal -> A.Actual -> CGen ()
|
|
cgenActual f a = seqComma $ 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 `Set.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 :: A.Name -> [A.Formal] -> [A.Actual] -> CGen (String, CGen ())
|
|
cgenProcAlloc 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) -> ("ProcMTMove", Pointer)
|
|
_ -> ("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, " = 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
|
|
|
|
--{{{ 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 (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 [";"]
|
|
where
|
|
el e = A.ExpressionList m [e]
|
|
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 is -> sequence_ $ map (call genInputItem c) is
|
|
_ -> 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 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
|
|
tell ["{int ext_args[] = {"]
|
|
-- We don't use the formals in csExternals because they won't
|
|
-- have had array sizes added:
|
|
(A.Proc _ _ fs _) <- specTypeOfName n
|
|
call genActuals fs as
|
|
tell ["};"]
|
|
|
|
case c of
|
|
'B' -> tell ["ExternalCallN("]
|
|
'C' -> tell ["BlockingCallN(wptr,"]
|
|
_ -> dieP (A.nameMeta n) "Unknown external PROC format"
|
|
tell [ [if c == '.' then '_' else c | c <- cs]
|
|
, ",1,ext_args);}"]
|
|
|
|
_ -> do genName n
|
|
tell [" (wptr", if null as then "" else ","]
|
|
(A.Proc _ _ fs _) <- specTypeOfName n
|
|
call genActuals fs as
|
|
tell [");\n"]
|
|
--}}}
|
|
--{{{ 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 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 (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"]
|
|
--}}}
|
|
--}}}
|
|
|
|
--{{{ mobiles
|
|
cgenAllocMobile :: Meta -> A.Type -> Maybe A.Expression -> CGen()
|
|
cgenAllocMobile m (A.Mobile t@(A.Array ds innerT)) Nothing
|
|
= do tell ["MTAllocDataArray(wptr,"]
|
|
call genBytesIn m innerT (Left False)
|
|
tell [",", show $ length ds]
|
|
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 [")"]
|
|
|
|
--}}}
|