1590 lines
55 KiB
Haskell
1590 lines
55 KiB
Haskell
-- | Generate C code from the mangled AST.
|
|
module GenerateC where
|
|
|
|
import Data.Char
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Control.Monad.Writer
|
|
import Control.Monad.Error
|
|
import Control.Monad.State
|
|
import Numeric
|
|
import Text.Printf
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import EvalConstants
|
|
import EvalLiterals
|
|
import Metadata
|
|
import Pass
|
|
import Errors
|
|
import TLP
|
|
import Types
|
|
import Utils
|
|
|
|
--{{{ monad definition
|
|
type CGen = WriterT [String] PassM
|
|
|
|
instance Die CGen where
|
|
die = throwError
|
|
--}}}
|
|
|
|
--{{{ top-level
|
|
generateC :: A.Process -> PassM String
|
|
generateC ast
|
|
= do (a, w) <- runWriterT (genTopLevel ast)
|
|
return $ concat w
|
|
|
|
genTLPChannel :: TLPChannel -> CGen ()
|
|
genTLPChannel TLPIn = tell ["in"]
|
|
genTLPChannel TLPOut = tell ["out"]
|
|
genTLPChannel TLPError = tell ["err"]
|
|
|
|
genTopLevel :: A.Process -> CGen ()
|
|
genTopLevel p
|
|
= do tell ["#include <tock_support.h>\n"]
|
|
genProcess p
|
|
(name, chans) <- tlpInterface
|
|
tell ["void tock_main (Process *me, Channel *in, Channel *out, Channel *err) {\n"]
|
|
genName name
|
|
tell [" (me"]
|
|
sequence_ [tell [", "] >> genTLPChannel c | c <- chans]
|
|
tell [");\n"]
|
|
tell ["}\n"]
|
|
--}}}
|
|
|
|
--{{{ utilities
|
|
missing :: String -> CGen ()
|
|
missing s = tell ["\n#error Unimplemented: ", s, "\n"]
|
|
|
|
--{{{ simple punctuation
|
|
genComma :: CGen ()
|
|
genComma = tell [", "]
|
|
|
|
seqComma :: [CGen ()] -> CGen ()
|
|
seqComma ps = sequence_ $ intersperse genComma ps
|
|
|
|
genLeftB :: CGen ()
|
|
genLeftB = tell ["{ "]
|
|
|
|
genRightB :: CGen ()
|
|
genRightB = tell [" }"]
|
|
--}}}
|
|
|
|
-- | A function that applies a subscript to a variable.
|
|
type SubscripterFunction = A.Variable -> A.Variable
|
|
|
|
-- | Map an operation over every item of an occam array.
|
|
overArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen ()
|
|
overArray m var func
|
|
= do A.Array ds _ <- typeOfVariable var
|
|
specs <- sequence [makeNonceVariable "i" m A.Int A.VariableName A.Original | _ <- ds]
|
|
let indices = [A.Variable m n | A.Specification _ n _ <- specs]
|
|
|
|
let arg = (\var -> foldl (\v s -> A.SubscriptedVariable m s v) var [A.Subscript m $ A.ExprVariable m i | i <- indices])
|
|
case func arg of
|
|
Just p ->
|
|
do sequence_ [do tell ["for (int "]
|
|
genVariable i
|
|
tell [" = 0; "]
|
|
genVariable i
|
|
tell [" < "]
|
|
genVariable var
|
|
tell ["_sizes[", show v, "]; "]
|
|
genVariable i
|
|
tell ["++) {\n"]
|
|
| (v, i) <- zip [0..] indices]
|
|
p
|
|
sequence_ [tell ["}\n"] | _ <- indices]
|
|
Nothing -> return ()
|
|
|
|
-- | Generate code for one of the Structured types.
|
|
genStructured :: A.Structured -> (A.Structured -> CGen ()) -> CGen ()
|
|
genStructured (A.Rep _ rep s) def = genReplicator rep (genStructured s def)
|
|
genStructured (A.Spec _ spec s) def = genSpec spec (genStructured s def)
|
|
genStructured (A.ProcThen _ p s) def = genProcess p >> genStructured s def
|
|
genStructured (A.Several _ ss) def = sequence_ [genStructured s def | s <- ss]
|
|
genStructured s def = def s
|
|
|
|
data InputType = ITTimerRead | ITTimerAfter | ITOther
|
|
|
|
-- | Given an input mode, figure out what sort of input it's actually doing.
|
|
inputType :: A.Variable -> A.InputMode -> CGen InputType
|
|
inputType c im
|
|
= do t <- typeOfVariable c
|
|
return $ case t of
|
|
A.Timer ->
|
|
case im of
|
|
A.InputSimple _ _ -> ITTimerRead
|
|
A.InputAfter _ _ -> ITTimerAfter
|
|
_ -> ITOther
|
|
--}}}
|
|
|
|
--{{{ 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
|
|
genName :: A.Name -> CGen ()
|
|
genName n = tell [[if c == '.' then '_' else c | c <- A.nameName n]]
|
|
--}}}
|
|
|
|
--{{{ types
|
|
-- | If a type maps to a simple C type, return Just that; else return Nothing.
|
|
scalarType :: A.Type -> Maybe String
|
|
scalarType A.Bool = Just "bool"
|
|
scalarType A.Byte = Just "uint8_t"
|
|
scalarType A.Int = Just "int"
|
|
scalarType A.Int16 = Just "int16_t"
|
|
scalarType A.Int32 = Just "int32_t"
|
|
scalarType A.Int64 = Just "int64_t"
|
|
scalarType A.Real32 = Just "float"
|
|
scalarType A.Real64 = Just "double"
|
|
scalarType A.Timer = Just "Time"
|
|
scalarType _ = Nothing
|
|
|
|
genType :: A.Type -> CGen ()
|
|
genType (A.Array _ t)
|
|
= do genType t
|
|
tell ["*"]
|
|
genType (A.Record n) = genName n
|
|
-- UserProtocol -- not used
|
|
genType (A.Chan t) = tell ["Channel *"]
|
|
-- Counted -- not used
|
|
-- Any -- not used
|
|
--genType (A.Port t) =
|
|
genType t
|
|
= case scalarType t of
|
|
Just s -> tell [s]
|
|
Nothing -> missing $ "genType " ++ show t
|
|
|
|
-- | Generate the number of bytes in a type that must have a fixed size.
|
|
genBytesIn :: A.Type -> Maybe A.Variable -> CGen ()
|
|
genBytesIn t v
|
|
= do free <- genBytesIn' t v
|
|
case free of
|
|
Nothing -> return ()
|
|
Just _ -> die "genBytesIn type with unknown dimension"
|
|
|
|
-- | Generate the number of bytes in a type that may have one free dimension.
|
|
genBytesIn' :: A.Type -> Maybe A.Variable -> CGen (Maybe Int)
|
|
genBytesIn' (A.Array ds t) v
|
|
= do free <- genBytesInArray ds 0
|
|
genBytesIn' t v
|
|
return free
|
|
where
|
|
genBytesInArray [] _ = return Nothing
|
|
genBytesInArray ((A.Dimension n):ds) i
|
|
= do free <- genBytesInArray ds (i + 1)
|
|
tell [show n, " * "]
|
|
return free
|
|
genBytesInArray (A.UnknownDimension:ds) i
|
|
= case v of
|
|
Just rv ->
|
|
do free <- genBytesInArray ds (i + 1)
|
|
genVariable rv
|
|
tell ["_sizes[", show i, "] * "]
|
|
return free
|
|
Nothing ->
|
|
do free <- genBytesInArray ds (i + 1)
|
|
case free of
|
|
Nothing -> return $ Just i
|
|
Just _ -> die "genBytesIn' type with more than one free dimension"
|
|
genBytesIn' (A.Record n) _
|
|
= do tell ["sizeof ("]
|
|
genName n
|
|
tell [")"]
|
|
return Nothing
|
|
-- This is so that we can do RETYPES checks on channels; we don't actually
|
|
-- allow retyping between channels and other things.
|
|
genBytesIn' (A.Chan _) _
|
|
= do tell ["sizeof (Channel *)"]
|
|
return Nothing
|
|
genBytesIn' t _
|
|
= case scalarType t of
|
|
Just s -> tell ["sizeof (", s, ")"] >> return Nothing
|
|
Nothing -> die $ "genBytesIn' " ++ show t
|
|
--}}}
|
|
|
|
--{{{ declarations
|
|
genDeclType :: A.AbbrevMode -> A.Type -> CGen ()
|
|
genDeclType am t
|
|
= do when (am == A.ValAbbrev) $ tell ["const "]
|
|
genType t
|
|
case t of
|
|
A.Array _ _ -> return ()
|
|
A.Chan _ -> return ()
|
|
A.Record _ -> tell [" *"]
|
|
_ -> when (am == A.Abbrev) $ tell [" *"]
|
|
|
|
genDecl :: A.AbbrevMode -> A.Type -> A.Name -> CGen ()
|
|
genDecl am t n
|
|
= do genDeclType am t
|
|
tell [" "]
|
|
genName n
|
|
--}}}
|
|
|
|
--{{{ conversions
|
|
genCheckedConversion :: Meta -> A.Type -> A.Type -> CGen () -> CGen ()
|
|
genCheckedConversion m fromT toT exp
|
|
= do tell ["(("]
|
|
genType toT
|
|
tell [") "]
|
|
if isSafeConversion fromT toT
|
|
then exp
|
|
else do genTypeSymbol "range_check" fromT
|
|
tell [" ("]
|
|
genTypeSymbol "mostneg" toT
|
|
tell [", "]
|
|
genTypeSymbol "mostpos" toT
|
|
tell [", "]
|
|
exp
|
|
tell [", "]
|
|
genMeta m
|
|
tell [")"]
|
|
tell [")"]
|
|
|
|
genConversion :: Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen ()
|
|
genConversion m A.DefaultConversion toT e
|
|
= do fromT <- typeOfExpression e
|
|
genCheckedConversion m fromT toT (genExpression e)
|
|
genConversion m cm toT e
|
|
= do fromT <- typeOfExpression e
|
|
case (isSafeConversion fromT toT, isRealType fromT, isRealType toT) of
|
|
(True, _, _) ->
|
|
-- A safe conversion -- no need for a check.
|
|
genCheckedConversion m fromT toT (genExpression e)
|
|
(_, True, True) ->
|
|
-- Real to real.
|
|
do genConversionSymbol fromT toT cm
|
|
tell [" ("]
|
|
genExpression e
|
|
tell [", "]
|
|
genMeta m
|
|
tell [")"]
|
|
(_, True, False) ->
|
|
-- Real to integer -- do real -> int64_t -> int.
|
|
do let exp = do genConversionSymbol fromT A.Int64 cm
|
|
tell [" ("]
|
|
genExpression e
|
|
tell [", "]
|
|
genMeta m
|
|
tell [")"]
|
|
genCheckedConversion m A.Int64 toT exp
|
|
(_, False, True) ->
|
|
-- Integer to real -- do int -> int64_t -> real.
|
|
do genConversionSymbol A.Int64 toT cm
|
|
tell [" ("]
|
|
genCheckedConversion m fromT A.Int64 (genExpression e)
|
|
tell [", "]
|
|
genMeta m
|
|
tell [")"]
|
|
_ -> missing $ "genConversion " ++ show cm
|
|
|
|
genConversionSymbol :: A.Type -> A.Type -> A.ConversionMode -> CGen ()
|
|
genConversionSymbol fromT toT cm
|
|
= do tell ["occam_convert_"]
|
|
genType fromT
|
|
tell ["_"]
|
|
genType toT
|
|
tell ["_"]
|
|
case cm of
|
|
A.Round -> tell ["round"]
|
|
A.Trunc -> tell ["trunc"]
|
|
--}}}
|
|
|
|
--{{{ literals
|
|
genLiteral :: A.LiteralRepr -> CGen ()
|
|
genLiteral lr
|
|
= if isStringLiteral lr
|
|
then do tell ["\""]
|
|
let A.ArrayLiteral _ aes = lr
|
|
sequence_ [genByteLiteral s
|
|
| A.ArrayElemExpr (A.Literal _ _ (A.ByteLiteral _ s)) <- aes]
|
|
tell ["\""]
|
|
else genLiteralRepr lr
|
|
|
|
-- | Does a LiteralRepr represent something that can be a plain string literal?
|
|
isStringLiteral :: A.LiteralRepr -> Bool
|
|
isStringLiteral (A.ArrayLiteral _ aes)
|
|
= and [case ae of
|
|
A.ArrayElemExpr (A.Literal _ _ (A.ByteLiteral _ _)) -> True
|
|
_ -> False
|
|
| ae <- aes]
|
|
isStringLiteral _ = False
|
|
|
|
genLiteralRepr :: A.LiteralRepr -> CGen ()
|
|
genLiteralRepr (A.RealLiteral m s) = tell [s]
|
|
genLiteralRepr (A.IntLiteral m s) = genDecimal s
|
|
genLiteralRepr (A.HexLiteral m s) = tell ["0x", s]
|
|
genLiteralRepr (A.ByteLiteral m s) = tell ["'"] >> genByteLiteral s >> tell ["'"]
|
|
genLiteralRepr (A.ArrayLiteral m aes)
|
|
= do genLeftB
|
|
genArrayLiteralElems aes
|
|
genRightB
|
|
genLiteralRepr (A.RecordLiteral _ es)
|
|
= do genLeftB
|
|
seqComma $ map genUnfoldedExpression es
|
|
genRightB
|
|
|
|
-- | 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!
|
|
genUnfoldedExpression :: A.Expression -> CGen ()
|
|
genUnfoldedExpression (A.Literal _ t lr)
|
|
= do genLiteralRepr lr
|
|
case t of
|
|
A.Array ds _ ->
|
|
do genComma
|
|
genLeftB
|
|
genArraySizesLiteral ds
|
|
genRightB
|
|
_ -> return ()
|
|
genUnfoldedExpression (A.ExprVariable m var) = genUnfoldedVariable m var
|
|
genUnfoldedExpression e = genExpression e
|
|
|
|
-- | Generate a variable inside a record literal.
|
|
genUnfoldedVariable :: Meta -> A.Variable -> CGen ()
|
|
genUnfoldedVariable m var
|
|
= do t <- typeOfVariable var
|
|
case t of
|
|
A.Array ds _ ->
|
|
do genLeftB
|
|
unfoldArray ds var
|
|
genRightB
|
|
genComma
|
|
genLeftB
|
|
genArraySizesLiteral ds
|
|
genRightB
|
|
A.Record _ ->
|
|
do genLeftB
|
|
fs <- recordFields m t
|
|
seqComma [genUnfoldedVariable m (A.SubscriptedVariable m (A.SubscriptField m n) var)
|
|
| (n, t) <- fs]
|
|
genRightB
|
|
-- We can defeat the usage check here because we know it's safe; *we're*
|
|
-- generating the subscripts.
|
|
-- FIXME Is that actually true for something like [a[x]]?
|
|
_ -> genVariable' False var
|
|
where
|
|
unfoldArray :: [A.Dimension] -> A.Variable -> CGen ()
|
|
unfoldArray [] v = genUnfoldedVariable m v
|
|
unfoldArray (A.Dimension n:ds) v
|
|
= seqComma $ [unfoldArray ds (A.SubscriptedVariable m (A.Subscript m $ makeConstant m i) v)
|
|
| i <- [0..(n - 1)]]
|
|
unfoldArray _ _ = dieP m "trying to unfold array with unknown dimension"
|
|
|
|
-- | 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]
|
|
|
|
genArrayLiteralElems :: [A.ArrayElem] -> CGen ()
|
|
genArrayLiteralElems aes
|
|
= seqComma $ map genElem aes
|
|
where
|
|
genElem :: A.ArrayElem -> CGen ()
|
|
genElem (A.ArrayElemArray aes) = genArrayLiteralElems aes
|
|
genElem (A.ArrayElemExpr e) = genUnfoldedExpression e
|
|
|
|
genByteLiteral :: String -> CGen ()
|
|
genByteLiteral s
|
|
= do c <- evalByte 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
|
|
{-
|
|
The various types are generated like this:
|
|
|
|
================= Use =================
|
|
Original ValAbbrev Abbrev
|
|
--------------------------------------
|
|
INT x: int x; int x; int *x;
|
|
x x x *x
|
|
|
|
[10]INT xs: int xs[10]; int *xs; int *xs;
|
|
xs xs xs xs
|
|
xs[i] xs[i] xs[i] xs[i]
|
|
|
|
[20][10]INT xss: int xss[20*10]; int *xss; int *xss;
|
|
xss xss xss xss
|
|
xss[i] &xss[i*10] &xss[i*10] &xss[i*10] (where 10 = xss_sizes[1])
|
|
xss[i][j] xss[i*10+j] xss[i*10+j] xss[i*10+j]
|
|
|
|
[6][4][2]INT xsss: int xsss[6*4*2]; int *xsss;
|
|
xsss xsss (as left)
|
|
xsss[i] &xsss[i*4*2]
|
|
xsss[i][j] &xsss[i*4*2+j*2]
|
|
xsss[i][j][k] xsss[i*4*2+j*2+k]
|
|
|
|
MYREC r: MYREC r; MYREC *r; MYREC *r;
|
|
r &r r r
|
|
r[F] (&r)->F (r)->F (r)->F
|
|
|
|
[10]MYREC rs: MYREC rs[10]; MYREC *rs; MYREC *rs;
|
|
rs rs rs rs
|
|
rs[i] &rs[i] &rs[i] &rs[i]
|
|
rs[i][F] (&rs[i])->F (&rs[i])->F (&rs[i])->F
|
|
-- depending on what F is -- if it's another record...
|
|
|
|
CHAN OF INT c: Channel c; Channel *c;
|
|
c &c c
|
|
|
|
[10]CHAN OF INT cs: Channel **cs; Channel **cs;
|
|
cs cs cs
|
|
cs[i] cs[i] cs[i]
|
|
|
|
I suspect there's probably a nicer way of doing this, but as a translation of
|
|
the above table this isn't too horrible...
|
|
-}
|
|
-- | Generate C code for a variable.
|
|
genVariable :: A.Variable -> CGen ()
|
|
genVariable = genVariable' True
|
|
|
|
-- | Generate C code for a variable without doing any range checks.
|
|
genVariableUnchecked :: A.Variable -> CGen ()
|
|
genVariableUnchecked = genVariable' False
|
|
|
|
-- FIXME This needs to detect when we've "gone through" a record and revert to
|
|
-- the Original prefixing behaviour. (Can do the same for arrays?)
|
|
-- Best way to do this is probably to make inner return a reference and a prefix,
|
|
-- so that we can pass prefixes upwards...
|
|
genVariable' :: Bool -> A.Variable -> CGen ()
|
|
genVariable' checkValid v
|
|
= do am <- accessAbbrevMode v
|
|
t <- typeOfVariable v
|
|
let isSub = case v of
|
|
A.Variable _ _ -> False
|
|
A.SubscriptedVariable _ _ _ -> True
|
|
|
|
let prefix = case (am, t) of
|
|
(_, A.Array _ _) -> ""
|
|
(A.Original, A.Chan _) -> if isSub then "" else "&"
|
|
(A.Abbrev, A.Chan _) -> ""
|
|
(A.Original, A.Record _) -> "&"
|
|
(A.Abbrev, A.Record _) -> ""
|
|
(A.Abbrev, _) -> "*"
|
|
_ -> ""
|
|
|
|
when (prefix /= "") $ tell ["(", prefix]
|
|
inner v
|
|
when (prefix /= "") $ tell [")"]
|
|
where
|
|
-- | Find the effective abbreviation mode for the variable we're looking at.
|
|
-- This differs from abbrevModeOfVariable in that it will return Original
|
|
-- for array and record elements (because when we're generating C, we can
|
|
-- treat c->x as if it's just x).
|
|
accessAbbrevMode :: A.Variable -> CGen A.AbbrevMode
|
|
accessAbbrevMode (A.Variable _ n) = abbrevModeOfName n
|
|
accessAbbrevMode (A.SubscriptedVariable _ sub v)
|
|
= do am <- accessAbbrevMode v
|
|
return $ case (am, sub) of
|
|
(_, A.Subscript _ _) -> A.Original
|
|
(_, A.SubscriptField _ _) -> A.Original
|
|
_ -> am
|
|
|
|
inner :: A.Variable -> CGen ()
|
|
inner (A.Variable _ n) = genName n
|
|
inner sv@(A.SubscriptedVariable _ (A.Subscript _ _) _)
|
|
= do let (es, v) = collectSubs sv
|
|
genVariable v
|
|
genArraySubscript checkValid v es
|
|
inner (A.SubscriptedVariable _ (A.SubscriptField m n) v)
|
|
= do genVariable v
|
|
tell ["->"]
|
|
genName n
|
|
inner (A.SubscriptedVariable m (A.SubscriptFromFor m' start _) v)
|
|
= inner (A.SubscriptedVariable m (A.Subscript m' start) v)
|
|
inner (A.SubscriptedVariable m (A.SubscriptFrom m' start) v)
|
|
= inner (A.SubscriptedVariable m (A.Subscript m' start) v)
|
|
inner (A.SubscriptedVariable m (A.SubscriptFor m' _) v)
|
|
= inner (A.SubscriptedVariable m (A.Subscript m' (makeConstant m' 0)) v)
|
|
|
|
-- | Collect all the plain subscripts on a variable, so we can combine them.
|
|
collectSubs :: A.Variable -> ([A.Expression], A.Variable)
|
|
collectSubs (A.SubscriptedVariable _ (A.Subscript _ e) v)
|
|
= (es' ++ [e], v')
|
|
where
|
|
(es', v') = collectSubs v
|
|
collectSubs v = ([], v)
|
|
|
|
genArraySubscript :: Bool -> A.Variable -> [A.Expression] -> CGen ()
|
|
genArraySubscript checkValid v es
|
|
= do t <- typeOfVariable v
|
|
let numDims = case t of A.Array ds _ -> length ds
|
|
tell ["["]
|
|
sequence_ $ intersperse (tell [" + "]) $ genPlainSub v es [0..(numDims - 1)]
|
|
tell ["]"]
|
|
where
|
|
-- | Generate the individual offsets that need adding together to find the
|
|
-- right place in the array.
|
|
-- FIXME This is obviously not the best way to factor this, but I figure a
|
|
-- smart C compiler should be able to work it out...
|
|
genPlainSub :: A.Variable -> [A.Expression] -> [Int] -> [CGen ()]
|
|
genPlainSub _ [] _ = []
|
|
genPlainSub v (e:es) (sub:subs)
|
|
= gen : genPlainSub v es subs
|
|
where
|
|
gen = sequence_ $ intersperse (tell [" * "]) $ genSub : genChunks
|
|
genSub
|
|
= if checkValid
|
|
then do tell ["occam_check_index ("]
|
|
genExpression e
|
|
tell [", "]
|
|
genVariable v
|
|
tell ["_sizes[", show sub, "], "]
|
|
genMeta (findMeta e)
|
|
tell [")"]
|
|
else genExpression e
|
|
genChunks = [genVariable v >> tell ["_sizes[", show i, "]"] | i <- subs]
|
|
--}}}
|
|
|
|
--{{{ expressions
|
|
genExpression :: A.Expression -> CGen ()
|
|
genExpression (A.Monadic m op e) = genMonadic m op e
|
|
genExpression (A.Dyadic m op e f) = genDyadic m op e f
|
|
genExpression (A.MostPos m t) = genTypeSymbol "mostpos" t
|
|
genExpression (A.MostNeg m t) = genTypeSymbol "mostneg" t
|
|
--genExpression (A.SizeType m t)
|
|
genExpression (A.SizeExpr m e)
|
|
= do genExpression e
|
|
tell ["_sizes[0]"]
|
|
genExpression (A.SizeVariable m v)
|
|
= do genVariable v
|
|
tell ["_sizes[0]"]
|
|
genExpression (A.Conversion m cm t e) = genConversion m cm t e
|
|
genExpression (A.ExprVariable m v) = genVariable v
|
|
genExpression (A.Literal _ _ lr) = genLiteral lr
|
|
genExpression (A.True m) = tell ["true"]
|
|
genExpression (A.False m) = tell ["false"]
|
|
--genExpression (A.FunctionCall m n es)
|
|
genExpression (A.IntrinsicFunctionCall m s es) = genIntrinsicFunction m s es
|
|
--genExpression (A.SubscriptedExpr m s e)
|
|
--genExpression (A.BytesInExpr m e)
|
|
genExpression (A.BytesInType m t) = genBytesIn t Nothing
|
|
--genExpression (A.OffsetOf m t n)
|
|
genExpression t = missing $ "genExpression " ++ show t
|
|
|
|
genTypeSymbol :: String -> A.Type -> CGen ()
|
|
genTypeSymbol s t
|
|
= case scalarType t of
|
|
Just ct -> tell ["occam_", s, "_", ct]
|
|
Nothing -> missing $ "genTypeSymbol " ++ show t
|
|
|
|
genIntrinsicFunction :: Meta -> String -> [A.Expression] -> CGen ()
|
|
genIntrinsicFunction m s es
|
|
= do tell ["occam_", s, " ("]
|
|
sequence [genExpression e >> genComma | e <- es]
|
|
genMeta m
|
|
tell [")"]
|
|
--}}}
|
|
|
|
--{{{ operators
|
|
genSimpleMonadic :: String -> A.Expression -> CGen ()
|
|
genSimpleMonadic s e
|
|
= do tell ["(", s]
|
|
genExpression e
|
|
tell [")"]
|
|
|
|
genMonadic :: Meta -> A.MonadicOp -> A.Expression -> CGen ()
|
|
genMonadic _ A.MonadicSubtr e = genSimpleMonadic "-" e
|
|
genMonadic _ A.MonadicBitNot e = genSimpleMonadic "~" e
|
|
genMonadic _ A.MonadicNot e = genSimpleMonadic "!" e
|
|
|
|
genSimpleDyadic :: String -> A.Expression -> A.Expression -> CGen ()
|
|
genSimpleDyadic s e f
|
|
= do tell ["("]
|
|
genExpression e
|
|
tell [" ", s, " "]
|
|
genExpression f
|
|
tell [")"]
|
|
|
|
genFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen ()
|
|
genFuncDyadic m s e f
|
|
= do t <- typeOfExpression e
|
|
genTypeSymbol s t
|
|
tell [" ("]
|
|
genExpression e
|
|
tell [", "]
|
|
genExpression f
|
|
tell [", "]
|
|
genMeta m
|
|
tell [")"]
|
|
|
|
genDyadic :: Meta -> A.DyadicOp -> A.Expression -> A.Expression -> CGen ()
|
|
genDyadic m A.Add e f = genFuncDyadic m "add" e f
|
|
genDyadic m A.Subtr e f = genFuncDyadic m "subtr" e f
|
|
genDyadic m A.Mul e f = genFuncDyadic m "mul" e f
|
|
genDyadic m A.Div e f = genFuncDyadic m "div" e f
|
|
genDyadic m A.Rem e f = genFuncDyadic m "rem" e f
|
|
genDyadic _ A.Plus e f = genSimpleDyadic "+" e f
|
|
genDyadic _ A.Minus e f = genSimpleDyadic "-" e f
|
|
genDyadic _ A.Times e f = genSimpleDyadic "*" e f
|
|
genDyadic _ A.LeftShift e f = genSimpleDyadic "<<" e f
|
|
genDyadic _ A.RightShift e f = genSimpleDyadic ">>" e f
|
|
genDyadic _ A.BitAnd e f = genSimpleDyadic "&" e f
|
|
genDyadic _ A.BitOr e f = genSimpleDyadic "|" e f
|
|
genDyadic _ A.BitXor e f = genSimpleDyadic "^" e f
|
|
genDyadic _ A.And e f = genSimpleDyadic "&&" e f
|
|
genDyadic _ A.Or e f = genSimpleDyadic "||" e f
|
|
genDyadic _ A.Eq e f = genSimpleDyadic "==" e f
|
|
genDyadic _ A.NotEq e f = genSimpleDyadic "!=" e f
|
|
genDyadic _ A.Less e f = genSimpleDyadic "<" e f
|
|
genDyadic _ A.More e f = genSimpleDyadic ">" e f
|
|
genDyadic _ A.LessEq e f = genSimpleDyadic "<=" e f
|
|
genDyadic _ A.MoreEq e f = genSimpleDyadic ">=" e f
|
|
--}}}
|
|
|
|
--{{{ input/output items
|
|
genInputItem :: A.Variable -> A.InputItem -> CGen ()
|
|
genInputItem c (A.InCounted m cv av)
|
|
= do genInputItem c (A.InVariable m cv)
|
|
t <- typeOfVariable av
|
|
tell ["ChanIn ("]
|
|
genVariable c
|
|
tell [", "]
|
|
fst $ abbrevVariable A.Abbrev t av
|
|
tell [", "]
|
|
subT <- trivialSubscriptType t
|
|
genVariable cv
|
|
tell [" * "]
|
|
genBytesIn subT (Just av)
|
|
tell [");\n"]
|
|
genInputItem c (A.InVariable m v)
|
|
= do t <- typeOfVariable v
|
|
let rhs = fst $ abbrevVariable A.Abbrev t v
|
|
case t of
|
|
A.Int ->
|
|
do tell ["ChanInInt ("]
|
|
genVariable c
|
|
tell [", "]
|
|
rhs
|
|
tell [");\n"]
|
|
_ ->
|
|
do tell ["ChanIn ("]
|
|
genVariable c
|
|
tell [", "]
|
|
rhs
|
|
tell [", "]
|
|
genBytesIn t (Just v)
|
|
tell [");\n"]
|
|
|
|
genOutputItem :: A.Variable -> A.OutputItem -> CGen ()
|
|
genOutputItem c (A.OutCounted m ce ae)
|
|
= do genOutputItem c (A.OutExpression m ce)
|
|
t <- typeOfExpression ae
|
|
case ae of
|
|
A.ExprVariable m v ->
|
|
do tell ["ChanOut ("]
|
|
genVariable c
|
|
tell [", "]
|
|
fst $ abbrevVariable A.Abbrev t v
|
|
tell [", "]
|
|
subT <- trivialSubscriptType t
|
|
genExpression ce
|
|
tell [" * "]
|
|
genBytesIn subT (Just v)
|
|
tell [");\n"]
|
|
genOutputItem c (A.OutExpression m e)
|
|
= do t <- typeOfExpression e
|
|
case (t, e) of
|
|
(A.Int, _) ->
|
|
do tell ["ChanOutInt ("]
|
|
genVariable c
|
|
tell [", "]
|
|
genExpression e
|
|
tell [");\n"]
|
|
(_, A.ExprVariable _ v) ->
|
|
do tell ["ChanOut ("]
|
|
genVariable c
|
|
tell [", "]
|
|
fst $ abbrevVariable A.Abbrev t v
|
|
tell [", "]
|
|
genBytesIn t (Just v)
|
|
tell [");\n"]
|
|
_ ->
|
|
do n <- makeNonce "output_item"
|
|
tell ["const "]
|
|
genType t
|
|
tell [" ", n, " = "]
|
|
genExpression e
|
|
tell [";\n"]
|
|
tell ["ChanOut ("]
|
|
genVariable c
|
|
tell [", &", n, ", "]
|
|
genBytesIn t Nothing
|
|
tell [");\n"]
|
|
--}}}
|
|
|
|
--{{{ replicators
|
|
genReplicator :: A.Replicator -> CGen () -> CGen ()
|
|
genReplicator rep body
|
|
= do tell ["for ("]
|
|
genReplicatorLoop rep
|
|
tell [") {\n"]
|
|
body
|
|
tell ["}\n"]
|
|
|
|
isZero :: A.Expression -> Bool
|
|
isZero (A.Literal _ A.Int (A.IntLiteral _ "0")) = True
|
|
isZero _ = False
|
|
|
|
genReplicatorLoop :: A.Replicator -> CGen ()
|
|
genReplicatorLoop (A.For m index base count)
|
|
= if isZero base
|
|
then genSimpleReplicatorLoop index count
|
|
else genGeneralReplicatorLoop index base count
|
|
|
|
genSimpleReplicatorLoop :: A.Name -> A.Expression -> CGen ()
|
|
genSimpleReplicatorLoop index count
|
|
= do tell ["int "]
|
|
genName index
|
|
tell [" = 0; "]
|
|
genName index
|
|
tell [" < "]
|
|
genExpression count
|
|
tell ["; "]
|
|
genName index
|
|
tell ["++"]
|
|
|
|
genGeneralReplicatorLoop :: A.Name -> A.Expression -> A.Expression -> CGen ()
|
|
genGeneralReplicatorLoop index base count
|
|
= do counter <- makeNonce "replicator_count"
|
|
tell ["int ", counter, " = "]
|
|
genExpression count
|
|
tell [", "]
|
|
genName index
|
|
tell [" = "]
|
|
genExpression base
|
|
tell ["; ", counter, " > 0; ", counter, "--, "]
|
|
genName index
|
|
tell ["++"]
|
|
|
|
genReplicatorSize :: A.Replicator -> CGen ()
|
|
genReplicatorSize rep = genExpression (sizeOfReplicator rep)
|
|
--}}}
|
|
|
|
--{{{ abbreviations
|
|
-- FIXME: This code is horrible, and I can't easily convince myself that it's correct.
|
|
|
|
genSlice :: A.Variable -> A.Variable -> A.Expression -> A.Expression -> [A.Dimension] -> (CGen (), A.Name -> CGen ())
|
|
genSlice v (A.Variable _ on) start count ds
|
|
-- We need to disable the index check here because we might be taking
|
|
-- element 0 of a 0-length array -- which is valid.
|
|
= (tell ["&"] >> genVariableUnchecked v,
|
|
genArraySize False
|
|
(do tell ["occam_check_slice ("]
|
|
genExpression start
|
|
tell [", "]
|
|
genExpression count
|
|
tell [", "]
|
|
genName on
|
|
tell ["_sizes[0], "]
|
|
genMeta (findMeta count)
|
|
tell [")"]
|
|
sequence_ [do tell [", "]
|
|
genName on
|
|
tell ["_sizes[", show i, "]"]
|
|
| i <- [1..(length ds - 1)]]))
|
|
|
|
genArrayAbbrev :: A.Variable -> (CGen (), A.Name -> CGen ())
|
|
genArrayAbbrev v
|
|
= (tell ["&"] >> genVariable v, genAASize v 0)
|
|
where
|
|
genAASize (A.SubscriptedVariable _ (A.Subscript _ _) v) arg
|
|
= genAASize v (arg + 1)
|
|
genAASize (A.Variable _ on) arg
|
|
= genArraySize True
|
|
(tell ["&"] >> genName on >> tell ["_sizes[", show arg, "]"])
|
|
|
|
genArraySize :: Bool -> CGen () -> A.Name -> CGen ()
|
|
genArraySize isPtr size n
|
|
= if isPtr
|
|
then do tell ["const int *"]
|
|
genName n
|
|
tell ["_sizes = "]
|
|
size
|
|
tell [";\n"]
|
|
else do tell ["const int "]
|
|
genName n
|
|
tell ["_sizes[] = { "]
|
|
size
|
|
tell [" };\n"]
|
|
|
|
noSize :: A.Name -> CGen ()
|
|
noSize n = return ()
|
|
|
|
genVariableAM :: A.Variable -> A.AbbrevMode -> CGen ()
|
|
genVariableAM v am
|
|
= do when (am == A.Abbrev) $ tell ["&"]
|
|
genVariable v
|
|
|
|
-- | Generate the right-hand side of an abbreviation of a variable.
|
|
abbrevVariable :: A.AbbrevMode -> A.Type -> A.Variable -> (CGen (), A.Name -> CGen ())
|
|
abbrevVariable am (A.Array _ _) v@(A.SubscriptedVariable _ (A.Subscript _ _) _)
|
|
= genArrayAbbrev v
|
|
abbrevVariable am (A.Array ds _) v@(A.SubscriptedVariable _ (A.SubscriptFromFor _ start count) v')
|
|
= genSlice v v' start count ds
|
|
abbrevVariable am (A.Array ds _) v@(A.SubscriptedVariable m (A.SubscriptFrom _ start) v')
|
|
= genSlice v v' start (A.Dyadic m A.Minus (A.SizeExpr m (A.ExprVariable m v')) start) ds
|
|
abbrevVariable am (A.Array ds _) v@(A.SubscriptedVariable m (A.SubscriptFor _ count) v')
|
|
= genSlice v v' (makeConstant m 0) count ds
|
|
abbrevVariable am (A.Array _ _) v
|
|
= (genVariable v, genArraySize True (genVariable v >> tell ["_sizes"]))
|
|
abbrevVariable am (A.Chan _) v
|
|
= (genVariable v, noSize)
|
|
abbrevVariable am (A.Record _) v
|
|
= (genVariable v, noSize)
|
|
abbrevVariable am t v
|
|
= (genVariableAM v am, noSize)
|
|
|
|
-- | Generate the size part of a RETYPES/RESHAPES abbrevation of a variable.
|
|
genRetypeSizes :: Meta -> A.AbbrevMode -> A.Type -> A.Name -> A.Type -> A.Variable -> CGen ()
|
|
genRetypeSizes m am destT destN srcT srcV
|
|
= do size <- makeNonce "retype_size"
|
|
tell ["int ", size, " = occam_check_retype ("]
|
|
genBytesIn srcT (Just srcV)
|
|
tell [", "]
|
|
free <- genBytesIn' destT Nothing
|
|
tell [", "]
|
|
genMeta m
|
|
tell [");\n"]
|
|
|
|
case destT of
|
|
-- An array -- figure out the missing dimension, if there is one.
|
|
A.Array destDS _ ->
|
|
do case free of
|
|
-- No free dimensions; check the complete array matches in size.
|
|
Nothing ->
|
|
do tell ["if (", size, " != 1) {\n"]
|
|
genStop m "array size mismatch in RETYPES"
|
|
tell ["}\n"]
|
|
_ -> return ()
|
|
|
|
let dims = [case d of
|
|
A.UnknownDimension ->
|
|
-- Unknown dimension -- insert it.
|
|
case free of
|
|
Just _ -> tell [size]
|
|
Nothing ->
|
|
die "genRetypeSizes expecting free dimension"
|
|
A.Dimension n -> tell [show n]
|
|
| d <- destDS]
|
|
genArraySize False (seqComma dims) destN
|
|
|
|
-- Not array; just check the size is 1.
|
|
_ ->
|
|
do tell ["if (", size, " != 1) {\n"]
|
|
genStop m "size mismatch in RETYPES"
|
|
tell ["}\n"]
|
|
|
|
-- | Generate the right-hand side of an abbreviation of an expression.
|
|
abbrevExpression :: A.AbbrevMode -> A.Type -> A.Expression -> (CGen (), A.Name -> CGen ())
|
|
abbrevExpression am t@(A.Array _ _) e
|
|
= case e of
|
|
A.ExprVariable _ v -> abbrevVariable am t v
|
|
A.Literal _ (A.Array ds _) r -> (genExpression e, declareArraySizes ds)
|
|
_ -> bad
|
|
where
|
|
bad = (missing "array expression abbreviation", noSize)
|
|
abbrevExpression am _ e
|
|
= (genExpression e, noSize)
|
|
--}}}
|
|
|
|
--{{{ specifications
|
|
genSpec :: A.Specification -> CGen () -> CGen ()
|
|
genSpec spec body
|
|
= do introduceSpec spec
|
|
body
|
|
removeSpec spec
|
|
|
|
-- | Generate the C type corresponding to a variable being declared.
|
|
-- It must be possible to use this in arrays.
|
|
declareType :: A.Type -> CGen ()
|
|
declareType (A.Chan _) = tell ["Channel *"]
|
|
declareType t = genType t
|
|
|
|
-- | Generate a declaration of a new variable.
|
|
genDeclaration :: A.Type -> A.Name -> CGen ()
|
|
genDeclaration (A.Chan _) n
|
|
= do tell ["Channel "]
|
|
genName n
|
|
tell [";\n"]
|
|
genDeclaration (A.Array ds t) n
|
|
= do declareType t
|
|
tell [" "]
|
|
genName n
|
|
genFlatArraySize ds
|
|
tell [";\n"]
|
|
declareArraySizes ds n
|
|
genDeclaration t n
|
|
= do declareType t
|
|
tell [" "]
|
|
genName n
|
|
tell [";\n"]
|
|
|
|
-- | Generate the size of the C array that an occam array of the given
|
|
-- dimensions maps to.
|
|
genFlatArraySize :: [A.Dimension] -> CGen ()
|
|
genFlatArraySize ds
|
|
= do tell ["["]
|
|
sequence $ intersperse (tell [" * "])
|
|
[case d of A.Dimension n -> tell [show n] | d <- ds]
|
|
tell ["]"]
|
|
|
|
-- | Generate the size of the _sizes C array for an occam array.
|
|
genArraySizesSize :: [A.Dimension] -> CGen ()
|
|
genArraySizesSize ds
|
|
= do tell ["["]
|
|
tell [show $ length ds]
|
|
tell ["]"]
|
|
|
|
-- | Declare an _sizes array for a variable.
|
|
declareArraySizes :: [A.Dimension] -> A.Name -> CGen ()
|
|
declareArraySizes ds name
|
|
= genArraySize False (genArraySizesLiteral ds) name
|
|
|
|
-- | Generate a C literal to initialise an _sizes array with, where all the
|
|
-- dimensions are fixed.
|
|
genArraySizesLiteral :: [A.Dimension] -> CGen ()
|
|
genArraySizesLiteral ds
|
|
= seqComma dims
|
|
where
|
|
dims :: [CGen ()]
|
|
dims = [case d of
|
|
A.Dimension n -> tell [show n]
|
|
_ -> die "unknown dimension in array type"
|
|
| d <- ds]
|
|
|
|
-- | Initialise an item being declared.
|
|
declareInit :: Meta -> A.Type -> A.Variable -> Maybe (CGen ())
|
|
declareInit _ (A.Chan _) var
|
|
= Just $ do tell ["ChanInit ("]
|
|
genVariable var
|
|
tell [");\n"]
|
|
declareInit m t@(A.Array ds t') var
|
|
= Just $ do init <- case t' of
|
|
A.Chan _ ->
|
|
do A.Specification _ store _ <- makeNonceVariable "storage" m (A.Array ds A.Int) A.VariableName A.Original
|
|
let storeV = A.Variable m store
|
|
tell ["Channel "]
|
|
genName store
|
|
genFlatArraySize ds
|
|
tell [";\n"]
|
|
declareArraySizes ds store
|
|
return (\sub -> Just $ do genVariable (sub var)
|
|
tell [" = &"]
|
|
genVariable (sub storeV)
|
|
tell [";\n"]
|
|
doMaybe $ declareInit m t' (sub var))
|
|
_ -> return (\sub -> declareInit m t' (sub var))
|
|
overArray m var init
|
|
declareInit 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]
|
|
where
|
|
initField :: A.Type -> A.Variable -> CGen ()
|
|
-- An array as a record field; we must initialise the sizes.
|
|
initField t@(A.Array ds _) v
|
|
= do sequence_ [do genVariable v
|
|
tell ["_sizes[", show i, "] = ", show n, ";\n"]
|
|
| (i, A.Dimension n) <- zip [0..(length ds - 1)] ds]
|
|
doMaybe $ declareInit m t v
|
|
initField t v = doMaybe $ declareInit m t v
|
|
declareInit _ _ _ = Nothing
|
|
|
|
-- | Free a declared item that's going out of scope.
|
|
declareFree :: Meta -> A.Type -> A.Variable -> Maybe (CGen ())
|
|
declareFree _ _ _ = 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;
|
|
-}
|
|
introduceSpec :: A.Specification -> CGen ()
|
|
introduceSpec (A.Specification m n (A.Declaration _ t))
|
|
= do genDeclaration t n
|
|
case declareInit m t (A.Variable m n) of
|
|
Just p -> p
|
|
Nothing -> return ()
|
|
introduceSpec (A.Specification _ n (A.Is _ am t v))
|
|
= do let (rhs, rhsSizes) = abbrevVariable am t v
|
|
genDecl am t n
|
|
tell [" = "]
|
|
rhs
|
|
tell [";\n"]
|
|
rhsSizes n
|
|
introduceSpec (A.Specification _ n (A.IsExpr _ am t e))
|
|
= do let (rhs, rhsSizes) = 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 tell ["const "]
|
|
genType ts
|
|
tell [" "]
|
|
genName n
|
|
tell ["[] = "]
|
|
rhs
|
|
tell [";\n"]
|
|
rhsSizes n
|
|
(A.ValAbbrev, A.Record _, A.Literal _ _ _) ->
|
|
-- Record literals are even trickier, because there's no way of
|
|
-- directly writing a struct literal in C that you can use -> on.
|
|
do tmp <- makeNonce "record_literal"
|
|
tell ["const "]
|
|
genType t
|
|
tell [" ", tmp, " = "]
|
|
rhs
|
|
tell [";\n"]
|
|
genDecl am t n
|
|
tell [" = &", tmp, ";\n"]
|
|
rhsSizes n
|
|
_ ->
|
|
do genDecl am t n
|
|
tell [" = "]
|
|
rhs
|
|
tell [";\n"]
|
|
rhsSizes n
|
|
introduceSpec (A.Specification _ n (A.IsChannelArray _ t cs))
|
|
= do tell ["Channel *"]
|
|
genName n
|
|
tell ["[] = {"]
|
|
seqComma (map genVariable cs)
|
|
tell ["};\n"]
|
|
declareArraySizes [A.Dimension $ length cs] n
|
|
introduceSpec (A.Specification _ _ (A.DataType _ _)) = return ()
|
|
introduceSpec (A.Specification _ n (A.RecordType _ b fs))
|
|
= do tell ["typedef struct {\n"]
|
|
sequence_ [case t of
|
|
-- Arrays need the corresponding _sizes array.
|
|
A.Array ds t' ->
|
|
do genType t'
|
|
tell [" "]
|
|
genName n
|
|
genFlatArraySize ds
|
|
tell [";\n"]
|
|
tell ["int "]
|
|
genName n
|
|
tell ["_sizes"]
|
|
genArraySizesSize ds
|
|
tell [";\n"]
|
|
_ -> genDeclaration t n
|
|
| (n, t) <- fs]
|
|
tell ["} "]
|
|
when b $ tell ["occam_struct_packed "]
|
|
genName n
|
|
tell [";\n"]
|
|
introduceSpec (A.Specification _ n (A.Protocol _ _)) = return ()
|
|
introduceSpec (A.Specification _ n (A.ProtocolCase _ ts))
|
|
= do tell ["typedef enum {\n"]
|
|
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 ["\n"]
|
|
tell ["} "]
|
|
genName n
|
|
tell [";\n"]
|
|
introduceSpec (A.Specification _ n (A.Proc _ sm fs p))
|
|
= do genSpecMode sm
|
|
tell ["void "]
|
|
genName n
|
|
tell [" (Process *me"]
|
|
genFormals fs
|
|
tell [") {\n"]
|
|
genProcess p
|
|
tell ["}\n"]
|
|
introduceSpec (A.Specification _ n (A.Retypes m am t v))
|
|
= do origT <- typeOfVariable v
|
|
let (rhs, rhsSizes) = abbrevVariable A.Abbrev origT v
|
|
genDecl am t n
|
|
tell [" = "]
|
|
-- For scalar types that are VAL abbreviations (e.g. VAL INT64),
|
|
-- we need to dereference the pointer that abbrevVariable gives us.
|
|
let deref = case (am, t) of
|
|
(_, A.Array _ _) -> False
|
|
(_, A.Chan _) -> False
|
|
(A.ValAbbrev, _) -> True
|
|
_ -> False
|
|
when deref $ tell ["*"]
|
|
tell ["("]
|
|
genDeclType am t
|
|
when deref $ tell [" *"]
|
|
tell [") "]
|
|
rhs
|
|
tell [";\n"]
|
|
genRetypeSizes m am t n origT v
|
|
--introduceSpec (A.Specification _ n (A.RetypesExpr _ am t e))
|
|
introduceSpec n = missing $ "introduceSpec " ++ show n
|
|
|
|
removeSpec :: A.Specification -> CGen ()
|
|
removeSpec (A.Specification m n (A.Declaration _ t))
|
|
= case t of
|
|
A.Array _ t' -> overArray m var (\sub -> declareFree m t' (sub var))
|
|
_ ->
|
|
do case declareFree m t var of
|
|
Just p -> p
|
|
Nothing -> return ()
|
|
where
|
|
var = A.Variable m n
|
|
removeSpec _ = return ()
|
|
|
|
genSpecMode :: A.SpecMode -> CGen ()
|
|
genSpecMode A.PlainSpec = return ()
|
|
genSpecMode A.InlineSpec = tell ["inline "]
|
|
--}}}
|
|
|
|
--{{{ actuals/formals
|
|
prefixComma :: [CGen ()] -> CGen ()
|
|
prefixComma cs = sequence_ [genComma >> c | c <- cs]
|
|
|
|
genActuals :: [A.Actual] -> CGen ()
|
|
genActuals as = prefixComma (map genActual as)
|
|
|
|
genActual :: A.Actual -> CGen ()
|
|
genActual actual
|
|
= case actual of
|
|
A.ActualExpression t e ->
|
|
case (t, e) of
|
|
(A.Array _ _, A.ExprVariable _ v) ->
|
|
do genVariable v
|
|
tell [", "]
|
|
genVariable v
|
|
tell ["_sizes"]
|
|
_ -> genExpression e
|
|
A.ActualVariable am t v ->
|
|
case t of
|
|
A.Array _ _ ->
|
|
do genVariable v
|
|
tell [", "]
|
|
genVariable v
|
|
tell ["_sizes"]
|
|
_ -> fst $ abbrevVariable am t v
|
|
|
|
numCArgs :: [A.Actual] -> Int
|
|
numCArgs [] = 0
|
|
numCArgs (A.ActualVariable _ (A.Array _ _) _:fs) = 2 + numCArgs fs
|
|
numCArgs (A.ActualExpression (A.Array _ _) _:fs) = 2 + numCArgs fs
|
|
numCArgs (_:fs) = 1 + numCArgs fs
|
|
|
|
genFormals :: [A.Formal] -> CGen ()
|
|
genFormals fs = prefixComma (map genFormal fs)
|
|
|
|
genFormal :: A.Formal -> CGen ()
|
|
genFormal (A.Formal am t n)
|
|
= case t of
|
|
A.Array _ t' ->
|
|
do genDecl am t n
|
|
tell [", const int *"]
|
|
genName n
|
|
tell ["_sizes"]
|
|
_ -> genDecl am t n
|
|
--}}}
|
|
|
|
--{{{ processes
|
|
genProcess :: A.Process -> CGen ()
|
|
genProcess p = case p of
|
|
A.Assign m vs es -> genAssign m vs es
|
|
A.Input m c im -> genInput c im
|
|
A.Output m c ois -> genOutput c ois
|
|
A.OutputCase m c t ois -> genOutputCase c t ois
|
|
A.Skip m -> tell ["/* skip */\n"]
|
|
A.Stop m -> genStop m "STOP process"
|
|
A.Main m -> tell ["/* main */\n"]
|
|
A.Seq _ s -> genSeqBody s
|
|
A.If m s -> genIf m s
|
|
A.Case m e s -> genCase m e s
|
|
A.While m e p -> genWhile e p
|
|
A.Par m pm s -> genPar pm s
|
|
-- PROCESSOR does nothing special.
|
|
A.Processor m e p -> genProcess p
|
|
A.Alt m b s -> genAlt b s
|
|
A.ProcCall m n as -> genProcCall n as
|
|
A.IntrinsicProcCall m s as -> genIntrinsicProc m s as
|
|
|
|
--{{{ assignment
|
|
genAssign :: Meta -> [A.Variable] -> A.ExpressionList -> CGen ()
|
|
genAssign m [v] el
|
|
= case el of
|
|
A.FunctionCallList _ _ _ -> missing "function call"
|
|
A.ExpressionList _ [e] ->
|
|
do t <- typeOfVariable v
|
|
doAssign t v e
|
|
where
|
|
doAssign :: A.Type -> A.Variable -> A.Expression -> CGen ()
|
|
doAssign t@(A.Array _ subT) toV (A.ExprVariable m fromV)
|
|
= overArray m fromV (\sub -> Just $ doAssign subT (sub toV) (A.ExprVariable m (sub fromV)))
|
|
doAssign rt@(A.Record _) toV (A.ExprVariable m fromV)
|
|
= do fs <- recordFields m rt
|
|
sequence_ [let subV v = A.SubscriptedVariable m (A.SubscriptField m n) v
|
|
in doAssign t (subV toV) (A.ExprVariable m $ subV fromV)
|
|
| (n, t) <- fs]
|
|
doAssign t v e
|
|
= case scalarType t of
|
|
Just _ ->
|
|
do genVariable v
|
|
tell [" = "]
|
|
genExpression e
|
|
tell [";\n"]
|
|
Nothing -> missing $ "assignment of type " ++ show t
|
|
--}}}
|
|
--{{{ input
|
|
genInput :: A.Variable -> A.InputMode -> CGen ()
|
|
genInput c im
|
|
= do t <- typeOfVariable c
|
|
case t of
|
|
A.Timer -> case im of
|
|
A.InputSimple m [A.InVariable m' v] -> genTimerRead c v
|
|
A.InputAfter m e -> genTimerWait e
|
|
_ -> case im of
|
|
A.InputSimple m is -> sequence_ $ map (genInputItem c) is
|
|
A.InputCase m s -> genInputCase m c s
|
|
_ -> missing $ "genInput " ++ show im
|
|
|
|
genInputCase :: Meta -> A.Variable -> A.Structured -> CGen ()
|
|
genInputCase m c s
|
|
= do t <- typeOfVariable c
|
|
let proto = case t of A.Chan (A.UserProtocol n) -> n
|
|
tag <- makeNonce "case_tag"
|
|
genName proto
|
|
tell [" ", tag, ";\n"]
|
|
tell ["ChanInInt ("]
|
|
genVariable c
|
|
tell [", &", tag, ");\n"]
|
|
tell ["switch (", tag, ") {\n"]
|
|
genInputCaseBody proto c (return ()) s
|
|
tell ["default:\n"]
|
|
genStop m "unhandled variant in CASE input"
|
|
tell ["}\n"]
|
|
|
|
-- This handles specs in a slightly odd way, because we can't insert specs into
|
|
-- the body of a switch.
|
|
genInputCaseBody :: A.Name -> A.Variable -> CGen () -> A.Structured -> CGen ()
|
|
genInputCaseBody proto c coll (A.Spec _ spec s)
|
|
= genInputCaseBody proto c (genSpec spec coll) s
|
|
genInputCaseBody proto c coll (A.OnlyV _ (A.Variant _ n iis p))
|
|
= do tell ["case "]
|
|
genName n
|
|
tell ["_"]
|
|
genName proto
|
|
tell [": {\n"]
|
|
coll
|
|
sequence_ $ map (genInputItem c) iis
|
|
genProcess p
|
|
tell ["break;\n"]
|
|
tell ["}\n"]
|
|
genInputCaseBody proto c coll (A.Several _ ss)
|
|
= sequence_ $ map (genInputCaseBody proto c coll) ss
|
|
|
|
genTimerRead :: A.Variable -> A.Variable -> CGen ()
|
|
genTimerRead c v
|
|
= do tell ["ProcTime (&"]
|
|
genVariable c
|
|
tell [");\n"]
|
|
genVariable v
|
|
tell [" = "]
|
|
genVariable c
|
|
tell [";\n"]
|
|
|
|
genTimerWait :: A.Expression -> CGen ()
|
|
genTimerWait e
|
|
= do tell ["ProcTimeAfter ("]
|
|
genExpression e
|
|
tell [");\n"]
|
|
--}}}
|
|
--{{{ output
|
|
genOutput :: A.Variable -> [A.OutputItem] -> CGen ()
|
|
genOutput c ois = sequence_ $ map (genOutputItem c) ois
|
|
|
|
genOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen ()
|
|
genOutputCase c tag ois
|
|
= do t <- typeOfVariable c
|
|
let proto = case t of A.Chan (A.UserProtocol n) -> n
|
|
tell ["ChanOutInt ("]
|
|
genVariable c
|
|
tell [", "]
|
|
genName tag
|
|
tell ["_"]
|
|
genName proto
|
|
tell [");\n"]
|
|
genOutput c ois
|
|
--}}}
|
|
--{{{ stop
|
|
genStop :: Meta -> String -> CGen ()
|
|
genStop m s
|
|
= do tell ["occam_stop ("]
|
|
genMeta m
|
|
tell [", \"", s, "\");\n"]
|
|
--}}}
|
|
--{{{ seq
|
|
genSeqBody :: A.Structured -> CGen ()
|
|
genSeqBody s = genStructured s doP
|
|
where
|
|
doP (A.OnlyP _ p) = genProcess p
|
|
--}}}
|
|
--{{{ if
|
|
genIf :: Meta -> A.Structured -> CGen ()
|
|
genIf m s
|
|
= do label <- makeNonce "if_end"
|
|
genIfBody label s
|
|
genStop m "no choice matched in IF process"
|
|
tell [label, ":\n;\n"]
|
|
|
|
genIfBody :: String -> A.Structured -> CGen ()
|
|
genIfBody label s = genStructured s doC
|
|
where
|
|
doC (A.OnlyC m (A.Choice m' e p))
|
|
= do tell ["if ("]
|
|
genExpression e
|
|
tell [") {\n"]
|
|
genProcess p
|
|
tell ["goto ", label, ";\n"]
|
|
tell ["}\n"]
|
|
--}}}
|
|
--{{{ case
|
|
genCase :: Meta -> A.Expression -> A.Structured -> CGen ()
|
|
genCase m e s
|
|
= do tell ["switch ("]
|
|
genExpression e
|
|
tell [") {\n"]
|
|
seenDefault <- genCaseBody (return ()) s
|
|
when (not seenDefault) $
|
|
do tell ["default:\n"]
|
|
genStop m "no option matched in CASE process"
|
|
tell ["}\n"]
|
|
|
|
-- FIXME -- can this be made common with genInputCaseBody above?
|
|
genCaseBody :: CGen () -> A.Structured -> CGen Bool
|
|
genCaseBody coll (A.Spec _ spec s)
|
|
= genCaseBody (genSpec spec coll) s
|
|
genCaseBody coll (A.OnlyO _ (A.Option _ es p))
|
|
= do sequence_ [tell ["case "] >> genExpression e >> tell [":\n"] | e <- es]
|
|
tell ["{\n"]
|
|
coll
|
|
genProcess p
|
|
tell ["break;\n"]
|
|
tell ["}\n"]
|
|
return False
|
|
genCaseBody coll (A.OnlyO _ (A.Else _ p))
|
|
= do tell ["default:\n"]
|
|
tell ["{\n"]
|
|
coll
|
|
genProcess p
|
|
tell ["}\n"]
|
|
return True
|
|
genCaseBody coll (A.Several _ ss)
|
|
= do seens <- mapM (genCaseBody coll) ss
|
|
return $ or seens
|
|
--}}}
|
|
--{{{ while
|
|
genWhile :: A.Expression -> A.Process -> CGen ()
|
|
genWhile e p
|
|
= do tell ["while ("]
|
|
genExpression e
|
|
tell [") {\n"]
|
|
genProcess p
|
|
tell ["}\n"]
|
|
--}}}
|
|
--{{{ par
|
|
genPar :: A.ParMode -> A.Structured -> CGen ()
|
|
genPar pm s
|
|
= do (size, _, _) <- constantFold $ addOne (sizeOfStructured s)
|
|
pids <- makeNonce "pids"
|
|
pris <- makeNonce "priorities"
|
|
index <- makeNonce "i"
|
|
when (pm == A.PriPar) $
|
|
do tell ["int ", pris, "["]
|
|
genExpression size
|
|
tell ["];\n"]
|
|
tell ["Process *", pids, "["]
|
|
genExpression size
|
|
tell ["];\n"]
|
|
tell ["int ", index, " = 0;\n"]
|
|
genStructured s (createP pids pris index)
|
|
tell [pids, "[", index, "] = NULL;\n"]
|
|
case pm of
|
|
A.PriPar -> tell ["ProcPriParList (", pids, ", ", pris, ");\n"]
|
|
_ -> tell ["ProcParList (", pids, ");\n"]
|
|
tell [index, " = 0;\n"]
|
|
genStructured s (freeP pids index)
|
|
where
|
|
createP pids pris index (A.OnlyP _ p)
|
|
= do when (pm == A.PriPar) $
|
|
tell [pris, "[", index, "] = ", index, ";\n"]
|
|
tell [pids, "[", index, "++] = "]
|
|
genProcAlloc p
|
|
tell [";\n"]
|
|
freeP pids index (A.OnlyP _ _)
|
|
= do tell ["ProcAllocClean (", pids, "[", index, "++]);\n"]
|
|
|
|
genProcAlloc :: A.Process -> CGen ()
|
|
genProcAlloc (A.ProcCall m n as)
|
|
= do tell ["ProcAlloc ("]
|
|
genName n
|
|
-- FIXME stack size fixed here
|
|
let stackSize = 65536
|
|
tell [", ", show stackSize, ", ", show $ numCArgs as]
|
|
genActuals as
|
|
tell [")"]
|
|
genProcAlloc p = missing $ "genProcAlloc " ++ show p
|
|
--}}}
|
|
--{{{ alt
|
|
genAlt :: Bool -> A.Structured -> CGen ()
|
|
genAlt isPri s
|
|
= do tell ["AltStart ();\n"]
|
|
tell ["{\n"]
|
|
genAltEnable s
|
|
tell ["}\n"]
|
|
-- Like occ21, this is always a PRI ALT, so we can use it for both.
|
|
tell ["AltWait ();\n"]
|
|
id <- makeNonce "alt_id"
|
|
tell ["int ", id, " = 0;\n"]
|
|
tell ["{\n"]
|
|
genAltDisable id s
|
|
tell ["}\n"]
|
|
fired <- makeNonce "alt_fired"
|
|
tell ["int ", fired, " = AltEnd ();\n"]
|
|
tell [id, " = 0;\n"]
|
|
label <- makeNonce "alt_end"
|
|
tell ["{\n"]
|
|
genAltProcesses id fired label s
|
|
tell ["}\n"]
|
|
tell [label, ":\n;\n"]
|
|
|
|
withIf :: A.Expression -> CGen () -> CGen ()
|
|
withIf cond body
|
|
= do tell ["if ("]
|
|
genExpression cond
|
|
tell [") {\n"]
|
|
body
|
|
tell ["}\n"]
|
|
|
|
genAltEnable :: A.Structured -> CGen ()
|
|
genAltEnable s = genStructured s doA
|
|
where
|
|
doA (A.OnlyA _ alt)
|
|
= case alt of
|
|
A.Alternative _ c im _ -> doIn c im
|
|
A.AlternativeCond _ e c im _ -> withIf e $ doIn c im
|
|
A.AlternativeSkip _ e _ -> withIf e $ tell ["AltEnableSkip ();\n"]
|
|
|
|
doIn c im
|
|
= do t <- inputType c im
|
|
case t of
|
|
ITTimerRead -> missing "timer read in ALT"
|
|
ITTimerAfter ->
|
|
do let time = case im of A.InputAfter _ e -> e
|
|
tell ["AltEnableTimer ("]
|
|
genExpression time
|
|
tell [");\n"]
|
|
ITOther ->
|
|
do tell ["AltEnableChannel ("]
|
|
genVariable c
|
|
tell [");\n"]
|
|
|
|
genAltDisable :: String -> A.Structured -> CGen ()
|
|
genAltDisable id s = genStructured s doA
|
|
where
|
|
doA (A.OnlyA _ alt)
|
|
= case alt of
|
|
A.Alternative _ c im _ -> doIn c im
|
|
A.AlternativeCond _ e c im _ -> withIf e $ doIn c im
|
|
A.AlternativeSkip _ e _ -> withIf e $ tell ["AltDisableSkip (", id, "++);\n"]
|
|
|
|
doIn c im
|
|
= do t <- inputType c im
|
|
case t of
|
|
ITTimerRead -> missing "timer read in ALT"
|
|
ITTimerAfter ->
|
|
do let time = case im of A.InputAfter _ e -> e
|
|
tell ["AltDisableTimer (", id, "++, "]
|
|
genExpression time
|
|
tell [");\n"]
|
|
ITOther ->
|
|
do tell ["AltDisableChannel (", id, "++, "]
|
|
genVariable c
|
|
tell [");\n"]
|
|
|
|
genAltProcesses :: String -> String -> String -> A.Structured -> CGen ()
|
|
genAltProcesses id fired label s = genStructured s doA
|
|
where
|
|
doA (A.OnlyA _ alt)
|
|
= case alt of
|
|
A.Alternative _ c im p -> doIn c im p
|
|
A.AlternativeCond _ e c im p -> withIf e $ doIn c im p
|
|
A.AlternativeSkip _ e p -> withIf e $ doCheck (genProcess p)
|
|
|
|
doIn c im p
|
|
= do t <- inputType c im
|
|
case t of
|
|
ITTimerRead -> missing "timer read in ALT"
|
|
ITTimerAfter -> doCheck (genProcess p)
|
|
ITOther -> doCheck (genInput c im >> genProcess p)
|
|
|
|
doCheck body
|
|
= do tell ["if (", id, "++ == ", fired, ") {\n"]
|
|
body
|
|
tell ["goto ", label, ";\n"]
|
|
tell ["}\n"]
|
|
--}}}
|
|
--{{{ proc call
|
|
genProcCall :: A.Name -> [A.Actual] -> CGen ()
|
|
genProcCall n as
|
|
= do genName n
|
|
tell [" (me"]
|
|
genActuals as
|
|
tell [");\n"]
|
|
--}}}
|
|
--{{{ intrinsic procs
|
|
genIntrinsicProc :: Meta -> String -> [A.Actual] -> CGen ()
|
|
genIntrinsicProc m "ASSERT" [A.ActualExpression A.Bool e] = genAssert m e
|
|
genIntrinsicProc _ s _ = missing $ "intrinsic PROC " ++ s
|
|
|
|
genAssert :: Meta -> A.Expression -> CGen ()
|
|
genAssert m e
|
|
= do tell ["if (!"]
|
|
genExpression e
|
|
tell [") {\n"]
|
|
genStop m "assertion failed"
|
|
tell ["}\n"]
|
|
--}}}
|
|
--}}}
|
|
|