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("]