From 3b14eec036fc38d32347ddbdd9a96ab087b8b24e Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Tue, 21 Aug 2007 10:35:18 +0000 Subject: [PATCH] Added direction specifiers and further attributes (such as whether the channel is shared) to the Chan type in the AST --- AST.hs | 15 +++++++++++++-- GenerateC.hs | 26 +++++++++++++------------- GenerateCPPCSP.hs | 26 +++++++++++++------------- Parse.hs | 10 +++++----- RainParse.hs | 2 +- TLP.hs | 2 +- Types.hs | 6 +++--- 7 files changed, 49 insertions(+), 38 deletions(-) diff --git a/AST.hs b/AST.hs index 741c18a..d95c2c6 100644 --- a/AST.hs +++ b/AST.hs @@ -74,6 +74,16 @@ data NameDef = NameDef { } deriving (Show, Eq, Typeable, Data) +-- | The direction of a channel -- input (reading-end), output (writing-end) or unknown (either) +data Direction = DirInput | DirOutput | DirUnknown + deriving (Show, Eq, Typeable, Data) + +data ChanAttributes = ChanAttributes { + caWritingShared :: Bool, + caReadingShared :: Bool + } + deriving (Show, Eq, Typeable, Data) + -- | A data or protocol type. -- The two concepts aren't unified in occam, but they are here, because it -- makes sense to be able to ask what type a particular name is defined to @@ -92,7 +102,8 @@ data Type = | Record Name -- | A user-defined protocol. | UserProtocol Name - | Chan Type + -- | A channel of the specified type. + | Chan Direction ChanAttributes Type -- | A counted input or output. | Counted Type Type | Any @@ -117,7 +128,7 @@ instance Show Type where show (UserDataType n) = nameName n ++ "{data type}" show (Record n) = nameName n ++ "{record}" show (UserProtocol n) = nameName n ++ "{protocol}" - show (Chan t) = "CHAN OF " ++ show t + show (Chan _ _ t) = "CHAN OF " ++ show t show (Counted ct et) = show ct ++ "::" ++ show et show Any = "ANY" show Timer = "TIMER" diff --git a/GenerateC.hs b/GenerateC.hs index 24e3025..1452fd0 100644 --- a/GenerateC.hs +++ b/GenerateC.hs @@ -333,7 +333,7 @@ cgenType ops (A.Array _ t) tell ["*"] cgenType _ (A.Record n) = genName n -- UserProtocol -- not used -cgenType _ (A.Chan t) = tell ["Channel *"] +cgenType _ (A.Chan _ _ t) = tell ["Channel *"] -- Counted -- not used -- Any -- not used --cgenType ops (A.Port t) = @@ -381,7 +381,7 @@ cgenBytesIn' _ (A.Record n) _ return Nothing -- This is so that we can do RETYPES checks on channels; we don't actually -- allow retyping between channels and other things. -cgenBytesIn' _ (A.Chan _) _ +cgenBytesIn' _ (A.Chan {}) _ = do tell ["sizeof (Channel *)"] return Nothing cgenBytesIn' ops t _ @@ -397,7 +397,7 @@ cgenDeclType ops am t call genType ops t case t of A.Array _ _ -> return () - A.Chan _ -> return () + A.Chan {} -> return () A.Record _ -> tell [" *"] _ -> when (am == A.Abbrev) $ tell [" *"] @@ -665,8 +665,8 @@ cgenVariable' ops checkValid v let prefix = case (am, t) of (_, A.Array _ _) -> "" - (A.Original, A.Chan _) -> if isSub then "" else "&" - (A.Abbrev, A.Chan _) -> "" + (A.Original, A.Chan {}) -> if isSub then "" else "&" + (A.Abbrev, A.Chan {}) -> "" (A.Original, A.Record _) -> "&" (A.Abbrev, A.Record _) -> "" (A.Abbrev, _) -> "*" @@ -1040,7 +1040,7 @@ abbrevVariable ops am (A.Array ds _) v@(A.SubscriptedVariable m (A.SubscriptFor = call genSlice ops v v' (makeConstant m 0) count ds abbrevVariable ops am (A.Array _ _) v = (call genVariable ops v, call genArraySize ops True (call genVariable ops v >> tell ["_sizes"])) -abbrevVariable ops am (A.Chan _) v +abbrevVariable ops am (A.Chan {}) v = (call genVariable ops v, noSize) abbrevVariable ops am (A.Record _) v = (call genVariable ops v, noSize) @@ -1110,12 +1110,12 @@ cgenSpec ops spec body -- | Generate the C type corresponding to a variable being declared. -- It must be possible to use this in arrays. cdeclareType :: GenOps -> A.Type -> CGen () -cdeclareType _ (A.Chan _) = tell ["Channel *"] +cdeclareType _ (A.Chan {}) = tell ["Channel *"] cdeclareType ops t = call genType ops t -- | Generate a declaration of a new variable. cgenDeclaration :: GenOps -> A.Type -> A.Name -> CGen () -cgenDeclaration ops (A.Chan _) n +cgenDeclaration ops (A.Chan {}) n = do tell ["Channel "] genName n tell [";\n"] @@ -1167,13 +1167,13 @@ cgenArraySizesLiteral ops ds -- | Initialise an item being declared. cdeclareInit :: GenOps -> Meta -> A.Type -> A.Variable -> Maybe (CGen ()) -cdeclareInit ops _ (A.Chan _) var +cdeclareInit ops _ (A.Chan {}) var = Just $ do tell ["ChanInit ("] call genVariable ops var tell [");\n"] cdeclareInit ops m t@(A.Array ds t') var = Just $ do init <- case t' of - A.Chan _ -> + 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 "] @@ -1325,7 +1325,7 @@ cintroduceSpec ops (A.Specification _ n (A.Retypes m am t v)) -- we need to dereference the pointer that abbrevVariable gives us. let deref = case (am, t) of (_, A.Array _ _) -> False - (_, A.Chan _) -> False + (_, A.Chan {}) -> False (A.ValAbbrev, _) -> True _ -> False when deref $ tell ["*"] @@ -1463,7 +1463,7 @@ cgenInput ops c im cgenInputCase :: GenOps -> Meta -> A.Variable -> A.Structured -> CGen () cgenInputCase ops m c s = do t <- typeOfVariable c - let proto = case t of A.Chan (A.UserProtocol n) -> n + let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n tag <- makeNonce "case_tag" genName proto tell [" ", tag, ";\n"] @@ -1518,7 +1518,7 @@ cgenOutput ops c ois = sequence_ $ map (call genOutputItem ops c) ois cgenOutputCase :: GenOps -> A.Variable -> A.Name -> [A.OutputItem] -> CGen () cgenOutputCase ops c tag ois = do t <- typeOfVariable c - let proto = case t of A.Chan (A.UserProtocol n) -> n + let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n tell ["ChanOutInt ("] call genVariable ops c tell [", "] diff --git a/GenerateCPPCSP.hs b/GenerateCPPCSP.hs index c211295..c974909 100644 --- a/GenerateCPPCSP.hs +++ b/GenerateCPPCSP.hs @@ -166,7 +166,7 @@ cppgenInput ops c im A.InputSimple m is -> do t <- typeOfVariable c case t of - A.Chan (A.UserProtocol innerType) -> + A.Chan _ _ (A.UserProtocol innerType) -> --We read from the channel into a temporary var, then deal with the var afterwards do inputVar <- makeNonce "proto_var" genProtocolName innerType @@ -184,7 +184,7 @@ cppgenInputCase ops m c s = do t <- typeOfVariable c --We have to do complex things with the which() function of the variant (which may be a chained variant) --to actually get the real index of the item we have received. - let proto = case t of A.Chan (A.UserProtocol n) -> n + let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n tag <- makeNonce "case_tag" which <- makeNonce "which_val" genProtocolName proto @@ -402,7 +402,7 @@ cppgenOutput ops c ois = do t <- typeOfVariable c case t of --If it's a protocol, we have to build the appropriate tuple to send down the channel: - A.Chan (A.UserProtocol innerType) -> + A.Chan _ _ (A.UserProtocol innerType) -> do call genVariable ops c tell [" ->writer() << "] genProtocolName innerType @@ -477,7 +477,7 @@ genSubTypes proto tag middle cppgenOutputCase :: GenOps -> A.Variable -> A.Name -> [A.OutputItem] -> CGen () cppgenOutputCase ops c tag ois = do t <- typeOfVariable c - let proto = case t of A.Chan (A.UserProtocol n) -> n + let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n call genVariable ops c tell [" ->writer() << "] genSubTypes proto tag (middle proto) @@ -606,7 +606,7 @@ cppdeclareType ops (A.Counted countType valueType) _ -> call genType ops valueType tell ["/**/>/**/"] -cppdeclareType ops (A.Chan t) +cppdeclareType ops (A.Chan _ _ t) = do tell [" csp::One2OneChannel < "] call genType ops t tell ["/**/>/**/ "] @@ -643,7 +643,7 @@ cppgenDeclaration ops t n cppdeclareInit :: GenOps -> Meta -> A.Type -> A.Variable -> Maybe (CGen ()) cppdeclareInit ops m t@(A.Array ds t') var = Just $ do init <- case t' of - A.Chan _ -> + A.Chan {} -> return (\sub -> Just $ do call genVariable ops (sub var) tell [" = new "] call declareType ops t' @@ -659,7 +659,7 @@ cppdeclareInit _ _ _ _ = Nothing cppdeclareFree :: GenOps -> Meta -> A.Type -> A.Variable -> Maybe (CGen ()) cppdeclareFree ops m t@(A.Array ds t') var = Just $ do free <- case t' of - A.Chan _ -> + A.Chan {} -> return (\sub -> Just $ do tell ["delete "] call genVariable ops (sub var) tell [";\n"] @@ -930,7 +930,7 @@ cppintroduceSpec ops (A.Specification _ n (A.Retypes m am t v)) -- we need to dereference the pointer that cppabbrevVariable gives us. do let deref = case (am, t) of (_, A.Array _ _) -> False - (_, A.Chan _) -> False + (_, A.Chan {}) -> False (A.ValAbbrev, _) -> True _ -> False when deref $ tell ["*"] @@ -987,7 +987,7 @@ cppgenType ops arr@(A.Array _ _) = cppgenArrayType ops False arr 0 cppgenType _ (A.Record n) = genName n cppgenType _ (A.UserProtocol n) = genProtocolName n -cppgenType ops (A.Chan t) +cppgenType ops (A.Chan _ _ t) = do tell ["csp::One2OneChannel < "] call genType ops t tell [" > * "] @@ -1022,7 +1022,7 @@ cppabbrevVariable ops am ty@(A.Array ds _) v@(A.SubscriptedVariable m (A.Subscri = cppgenSlice ops v v' ty (makeConstant m 0) count ds cppabbrevVariable ops am (A.Array _ _) v = call genVariable ops v -cppabbrevVariable ops am (A.Chan _) v +cppabbrevVariable ops am (A.Chan {}) v = call genVariable ops v cppabbrevVariable ops am (A.Record _) v = call genVariable ops v @@ -1176,7 +1176,7 @@ cppgenDeclType ops am t do when (am == A.ValAbbrev) $ tell ["const "] call genType ops t case t of - A.Chan _ -> return () + A.Chan {} -> return () A.Record _ -> tell [" *"] _ -> when (am == A.Abbrev) $ tell [" *"] @@ -1193,8 +1193,8 @@ cppgenVariable' ops checkValid v let prefix = case (am, t) of (_, A.Array _ _) -> "" - (A.Original, A.Chan _) -> if isSub then "" else "&" - (A.Abbrev, A.Chan _) -> "" + (A.Original, A.Chan {}) -> if isSub then "" else "&" + (A.Abbrev, A.Chan {}) -> "" (A.Original, A.Record _) -> "&" (A.Abbrev, A.Record _) -> "" (A.Abbrev, _) -> "*" diff --git a/Parse.hs b/Parse.hs index f14daf3..2f34167 100644 --- a/Parse.hs +++ b/Parse.hs @@ -559,7 +559,7 @@ dataType -- FIXME should probably make CHAN INT work, since that'd be trivial... channelType :: OccParser A.Type channelType - = do { sCHAN; sOF; p <- protocol; return $ A.Chan p } + = do { sCHAN; sOF; p <- protocol; return $ A.Chan A.DirUnknown A.ChanAttributes {A.caWritingShared = False, A.caReadingShared = False} p } <|> arrayType channelType "channel type" @@ -1265,7 +1265,7 @@ chanArrayAbbrev ts <- mapM typeOfVariable cs t <- tableType m ts case t of - (A.Array _ (A.Chan _)) -> return () + (A.Array _ (A.Chan {})) -> return () _ -> fail $ "types do not match in channel array abbreviation" return $ A.Specification m n $ A.IsChannelArray m t cs <|> do m <- md @@ -1275,7 +1275,7 @@ chanArrayAbbrev sLeft ct <- trivialSubscriptType s case ct of - A.Chan _ -> return (ct, s, n) + A.Chan {} -> return (ct, s, n) _ -> pzero) cs <- sepBy1 (channelOfType ct) sComma sRight @@ -1361,7 +1361,7 @@ retypesAbbrev -- | Check that a RETYPES\/RESHAPES is safe. checkRetypes :: A.Type -> A.Type -> OccParser () -- Retyping channels is always "safe". -checkRetypes (A.Chan _) (A.Chan _) = return () +checkRetypes (A.Chan {}) (A.Chan {}) = return () checkRetypes fromT toT = do bf <- bytesInType fromT bt <- bytesInType toT @@ -1893,7 +1893,7 @@ actual (A.Formal am t n) return $ A.ActualExpression t e _ -> case stripArrayType t of - A.Chan _ -> var (channelOfType t) + A.Chan {} -> var (channelOfType t) A.Timer -> var timer A.Port _ -> var (portOfType t) _ -> var (variableOfType t) diff --git a/RainParse.hs b/RainParse.hs index 7fa2002..b38324a 100644 --- a/RainParse.hs +++ b/RainParse.hs @@ -176,7 +176,7 @@ dataType :: RainParser A.Type dataType = do {sBool ; return A.Bool} <|> do {sInt ; return A.Int64} - <|> do {sChannel ; inner <- dataType ; return $ A.Chan inner} + <|> do {sChannel ; inner <- dataType ; return $ A.Chan A.DirUnknown (A.ChanAttributes {A.caWritingShared = False, A.caReadingShared = False}) inner} "data type" variableId :: RainParser A.Variable diff --git a/TLP.hs b/TLP.hs index b538032..51448ae 100644 --- a/TLP.hs +++ b/TLP.hs @@ -49,7 +49,7 @@ tlpInterface return (mainName, chans) where tlpChannel :: (CSM m, Die m) => A.Formal -> m TLPChannel - tlpChannel (A.Formal _ (A.Chan A.Byte) n) + tlpChannel (A.Formal _ (A.Chan _ _ A.Byte) n) = do def <- lookupName n let origN = A.ndOrigName def case lookup origN tlpChanNames of diff --git a/Types.hs b/Types.hs index 71670b1..3b43c62 100644 --- a/Types.hs +++ b/Types.hs @@ -218,7 +218,7 @@ returnTypesOfIntrinsic s -- Returns Left if it's a simple protocol, Right if it's tagged. protocolItems :: (CSM m, Die m) => A.Variable -> m (Either [A.Type] [(A.Name, [A.Type])]) protocolItems v - = do A.Chan t <- typeOfVariable v + = do A.Chan _ _ t <- typeOfVariable v case t of A.UserProtocol proto -> do st <- specTypeOfName proto @@ -366,8 +366,8 @@ simplifyType origT@(A.Record n) simplifyType (A.Array ds t) = do t' <- simplifyType t return $ A.Array ds t' -simplifyType (A.Chan t) - = liftM A.Chan $ simplifyType t +simplifyType (A.Chan d a t) + = liftM (A.Chan d a) $ simplifyType t simplifyType (A.Counted ct it) = do ct' <- simplifyType ct it' <- simplifyType it