From 12b3c4cd899caad3b2bc150a893d7700b601ddd3 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sun, 22 Mar 2009 18:28:42 +0000 Subject: [PATCH] Added a pass (and adjusted the backends) to deal with the move-in move-out semantics of mobiles Also known as communication semantics, I think. The pass adds an extra channel parameter per mobile (perhaps in future this could be a single extra channel?) that is used to send back the mobile value, and hacked the backend so that the communications to receive these mobiles are done in the right place (after the processes have been run, but before waiting on the barrier for them to complete). cgtest83 now compiles, runs and passes without a segfault. --- backends/BackendPasses.hs | 84 ++++++++++++++++++++++++++++++++++++++ backends/GenerateC.hs | 65 ++++++++++++++++++----------- backends/GenerateCBased.hs | 4 +- backends/GenerateCPPCSP.hs | 6 +-- 4 files changed, 130 insertions(+), 29 deletions(-) diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index d4ec94a..b6ed884 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -21,6 +21,7 @@ module BackendPasses (addSizesActualParameters, addSizesFormalParameters, declar import Control.Monad.State import Data.Generics +import Data.List import qualified Data.Map as Map import qualified AST as A @@ -47,6 +48,7 @@ backendPasses = , addSizesFormalParameters , addSizesActualParameters , fixMinInt + , mobileReturn ] prereq :: [Property] @@ -410,3 +412,85 @@ simplifySlices = occamOnlyPass "Simplify array slices" return (A.SubscriptedVariable m (A.SubscriptFromFor m' check from (A.Dyadic m A.Subtr limit from)) v) doVariable v = return v +-- | Finds all processes that have a MOBILE parameter passed in Abbrev mode, and +-- add the communication back at the end of the process. +mobileReturn :: Pass +mobileReturn = cOnlyPass "Add MOBILE returns" [] [] recurse + where + ops = baseOp `extOpS` doStructured `extOp` doProcess + + descend, recurse :: Data a => Transform a + descend = makeDescend ops + recurse = makeRecurse ops + + ignoreProc :: A.Name -> PassM Bool + ignoreProc n + = do nd <- lookupName n + return $ "copy_" `isPrefixOf` A.ndOrigName nd -- Bit of a hard-hack + + doProcess :: Transform A.Process + doProcess (A.ProcCall m n as) + = do sp <- specTypeOfName n + fs <- case sp of + A.Proc _ _ fs _ -> return fs + _ -> dieP m "PROC with unknown spec-type" + ig <- ignoreProc n + if ig + then return $ A.ProcCall m n as + else do (surr, as') <- addChansAct m $ zip fs as + return $ surr $ A.ProcCall m n as' + doProcess p = descend p + + chanT t = A.Chan (A.ChanAttributes False False) t + + addChansAct :: Meta -> [(A.Formal, A.Actual)] -> PassM (A.Process -> A.Process, [A.Actual]) + addChansAct _ [] = return (id, []) + addChansAct m ((A.Formal am t n, a):fas) + = do isMobile <- isMobileType t + (recF, recAS) <- addChansAct m fas + case (am, isMobile) of + (A.Abbrev, True) + -> do sp@(A.Specification _ c _) <- defineNonce m (A.nameName n) + (A.Declaration m $ chanT t) A.Original + let av = getV a + return (\p -> A.Seq m $ A.Spec m sp $ A.Several m + [A.Only m (recF p) + ,A.Only m $ A.Input m (A.Variable m c) $ + A.InputSimple m [A.InVariable m av]] + , a : A.ActualVariable (A.Variable m c) : recAS) + _ -> return (recF, a : recAS) + + getV (A.ActualVariable v) = v + getV (A.ActualExpression (A.ExprVariable _ v)) = v + + addChansForm :: Meta -> [A.Formal] -> PassM ([A.Process], [A.Formal]) + addChansForm _ [] = return ([], []) + addChansForm m (f@(A.Formal am t n):fs) + = do (ps, fs') <- addChansForm m fs + isMobile <- isMobileType t + case (am, isMobile) of + (A.Abbrev, True) + -> do A.Specification _ c _ <- defineNonce m (A.nameName n) + (A.Declaration m $ chanT t) A.Abbrev + modifyName n $ \nd -> nd {A.ndAbbrevMode = A.Original} + return ( ps ++ [A.Output m (A.Variable m c) + [A.OutExpression m + $ A.ExprVariable m $ A.Variable m n]] + , A.Formal A.Original t n : A.Formal A.Abbrev (chanT t) c : fs') + _ -> return (ps, f : fs') + + doStructured :: Data a => Transform (A.Structured a) + doStructured s@(A.Spec msp (A.Specification m n (A.Proc m' sm fs pr)) scope) + = do pr' <- recurse pr + -- We do the scope first, so that all the callers are updated before + -- we fix our state: + scope' <- recurse scope + ig <- ignoreProc n + if ig + then return $ A.Spec msp (A.Specification m n (A.Proc m' sm fs pr')) scope' + else do (ps, fs') <- addChansForm m fs + let newSpec = A.Proc m' sm fs' (A.Seq m' $ A.Several m' $ + map (A.Only m') $ pr' : ps) + modifyName n (\nd -> nd {A.ndSpecType = newSpec}) + return $ A.Spec msp (A.Specification m n newSpec) scope' + doStructured s = descend s diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 22a2da7..61151a6 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -280,11 +280,12 @@ cgenOverArray m var func Nothing -> return () -- | Generate code for one of the Structured types. -cgenStructured :: Data a => A.Structured a -> (Meta -> a -> CGen ()) -> CGen () +cgenStructured :: Data a => A.Structured a -> (Meta -> a -> CGen b) -> CGen [b] cgenStructured (A.Spec _ spec s) def = call genSpec spec (call genStructured s def) cgenStructured (A.ProcThen _ p s) def = call genProcess p >> call genStructured s def -cgenStructured (A.Several _ ss) def = sequence_ [call genStructured s def | s <- ss] -cgenStructured (A.Only m s) def = def m s +cgenStructured (A.Several _ ss) def + = sequence [call genStructured s def | s <- ss] >>* concat +cgenStructured (A.Only m s) def = def m s >>* singleton --}}} @@ -630,7 +631,7 @@ cgenVariableWithAM checkValid v am fct t <- astTypeOf v ct <- call getCType m t am >>* fct -- Temporary, for debugging: - tell ["/* ", show (snd iv), " , ", show ct, " */"] + tell ["/* ", show (snd iv), " , trying to get: ", show ct, " */"] dressUp m iv ct where m = findMeta v @@ -1037,7 +1038,7 @@ cgenInputItem c (A.InVariable m v) do call genClearMobile m v -- TODO insert this via a pass tell ["MTChanIn(wptr,"] genChan c - tell [",(void*)"] + tell [",(void**)"] rhs tell [");"] _ -> @@ -1079,7 +1080,7 @@ cgenOutputItem innerT c (A.OutExpression m e) do tell ["MTChanOut(wptr,"] genChan c tell [",(void*)"] - call genVariable v A.Abbrev + call genVariable' v A.Original Pointer tell [");"] (_, _, A.ExprVariable _ v) -> do tell ["ChanOut(wptr,"] @@ -1160,11 +1161,12 @@ abbrevExpression am _ e = call genExpression e --}}} --{{{ specifications -cgenSpec :: A.Specification -> CGen () -> CGen () +cgenSpec :: A.Specification -> CGen b -> CGen b cgenSpec spec body = do call introduceSpec spec - body + x <- body call removeSpec spec + return x -- | Generate a declaration of a new variable. cgenDeclaration :: A.Type -> A.Name -> Bool -> CGen () @@ -1438,15 +1440,15 @@ cgenActuals :: [A.Formal] -> [A.Actual] -> CGen () cgenActuals fs as = prefixComma [call genActual f a | (f, a) <- zip fs as] cgenActual :: A.Formal -> A.Actual -> CGen () -cgenActual f a = seqComma $ realActuals f a +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 -> [CGen ()] -realActuals _ (A.ActualExpression e) +realActuals :: A.Formal -> A.Actual -> (CType -> CType) -> [CGen ()] +realActuals _ (A.ActualExpression e) _ = [call genExpression e] -realActuals (A.Formal am _ _) (A.ActualVariable v) - = [call genVariable v am] +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. @@ -1508,17 +1510,24 @@ genProcSpec n (A.Proc _ (sm, _) fs p) forwardDecl -- 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 let ras = concat [realActuals f a | (f, a) <- zip fs as] + = do ras <- liftM concat $ sequence + [do isMobile <- isMobileType t + let (s, fct) = case (am, isMobile) of + (A.ValAbbrev, _) -> ("ProcParam", id) + (_, 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 "workspace" tell ["Workspace ", ws, " = ProcAlloc (wptr, ", show $ length ras, ", "] genName n tell ["_stack_size);\n"] - sequence_ [do tell ["ProcParam (wptr, ", ws, ", ", show num, ", "] + sequence_ [do tell [pc, " (wptr, ", ws, ", ", show num, ", "] ra tell [");\n"] - | (num, ra) <- zip [(0 :: Int)..] ras] + | (num, (pc, ra)) <- zip [(0 :: Int)..] ras] return (ws, genName n) --}}} @@ -1663,7 +1672,7 @@ cgenStop m s --}}} --{{{ seq cgenSeq :: A.Structured A.Process -> CGen () -cgenSeq s = call genStructured s doP +cgenSeq s = call genStructured s doP >> return () where doP _ p = call genProcess p --}}} @@ -1681,7 +1690,7 @@ cgenIf m s | justOnly s = do call genStructured s doCplain tell [label, ":;"] where genIfBody :: String -> A.Structured A.Choice -> CGen () - genIfBody label s = call genStructured s doC + genIfBody label s = call genStructured s doC >> return () where doC m (A.Choice m' e p) = do tell ["if("] @@ -1757,18 +1766,26 @@ cgenPar pm s call genExpression count tell [");\n"] - call genStructured s (startP bar) + after <- call genStructured s (startP bar) + mapM_ (call genProcess) after tell ["LightProcBarrierWait (wptr, &", bar, ");\n"] - where - startP :: String -> Meta -> A.Process -> CGen () + startP :: String -> Meta -> A.Process -> CGen A.Process startP bar _ (A.ProcCall _ n as) = do (A.Proc _ _ fs _) <- specTypeOfName n (ws, func) <- cgenProcAlloc n fs as tell ["LightProcStart (wptr, &", bar, ", ", ws, ", "] func tell [");\n"] + return (A.Skip emptyMeta) + -- When we need to receive mobiles back from the processes, we need to perform + -- some actions after all the processes have started, but before we wait on + -- the barrier, so this hack collects up all such receive operations and returns + -- them: + startP bar _ (A.Seq m s) + = call genStructured s (startP bar) >>* (A.Seq m . A.Several m . map (A.Only m)) + startP _ _ p = return p --}}} --{{{ alt cgenAlt :: Bool -> A.Structured A.Alternative -> CGen () @@ -1809,7 +1826,7 @@ cgenAlt isPri s containsTimers (A.Several _ ss) = or $ map containsTimers ss genAltEnable :: String -> A.Structured A.Alternative -> CGen () - genAltEnable id s = call genStructured s doA + genAltEnable id s = call genStructured s doA >> return () where doA _ alt = case alt of @@ -1829,7 +1846,7 @@ cgenAlt isPri s tell [");\n"] genAltDisable :: String -> A.Structured A.Alternative -> CGen () - genAltDisable id s = call genStructured s doA + genAltDisable id s = call genStructured s doA >> return () where doA _ alt = case alt of @@ -1849,7 +1866,7 @@ cgenAlt isPri s tell [");\n"] genAltProcesses :: String -> String -> String -> A.Structured A.Alternative -> CGen () - genAltProcesses id fired label s = call genStructured s doA + genAltProcesses id fired label s = call genStructured s doA >> return () where doA _ alt = case alt of diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index 0a2c7a7..dd6bbea 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -167,11 +167,11 @@ data GenOps = GenOps { genSimpleDyadic :: String -> A.Expression -> A.Expression -> CGen (), genSimpleMonadic :: String -> A.Expression -> CGen (), genSizeSuffix :: String -> CGen (), - genSpec :: A.Specification -> CGen () -> CGen (), + genSpec :: forall b. A.Specification -> CGen b -> CGen b, genSpecMode :: A.SpecMode -> CGen (), -- | Generates a STOP process that uses the given Meta tag and message as its printed message. genStop :: Meta -> String -> CGen (), - genStructured :: forall a. Data a => A.Structured a -> (Meta -> a -> CGen ()) -> CGen (), + genStructured :: forall a b. Data a => A.Structured a -> (Meta -> a -> CGen b) -> CGen [b], genTimerRead :: A.Variable -> A.Variable -> CGen (), genTimerWait :: A.Expression -> CGen (), genTopLevel :: A.AST -> CGen (), diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index c9cb2b7..a285a0e 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -421,7 +421,7 @@ cppgenAlt _ s where --This function is like the enable function in GenerateC, but this one merely builds a list of guards. It does not do anything other than add to the guard list initAltGuards :: String -> A.Structured A.Alternative -> CGen () - initAltGuards guardList s = call genStructured s doA + initAltGuards guardList s = call genStructured s doA >> return () where doA _ alt = case alt of @@ -442,7 +442,7 @@ cppgenAlt _ s -- This is the same as GenerateC for now -- but it's not really reusable -- because it's so closely tied to how ALT is implemented in the backend. genAltProcesses :: String -> String -> String -> A.Structured A.Alternative -> CGen () - genAltProcesses id fired label s = call genStructured s doA + genAltProcesses id fired label s = call genStructured s doA >> return () where doA _ alt = case alt of @@ -776,7 +776,7 @@ cppgenIf m s | justOnly s = do call genStructured s doCplain tell ["}catch(",ifExc,"){}"] where genIfBody :: String -> A.Structured A.Choice -> CGen () - genIfBody ifExc s = call genStructured s doC + genIfBody ifExc s = call genStructured s doC >> return () where doC m (A.Choice m' e p) = do tell ["if("]