From 7e7a437a3bddfcc78e78cd0e607ac11058cf3c6f Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Wed, 1 Apr 2009 19:21:40 +0000 Subject: [PATCH] Switched to using a different kind of pragma for occam externals, and munged the names to avoid collisions The separately compiled occam PROCs now use #PRAGMA OCCAMEXTERNAL, which also discards the "= number" thing at the end. These PROCs then need to be processed differently when adding on the sizes (C externals have one size per dimension, occam externals have the normal array of sizes). We also now record which processes were originally at the top-level, and keep their original names (i.e. minus the _u43 suffixes) plus an "occam_" prefix to avoid collisions. --- backends/BackendPasses.hs | 52 +++++++++++++++++++++------------------ backends/GenerateC.hs | 39 ++++++++++++++++++++--------- data/CompState.hs | 10 +++++++- frontends/LexOccam.x | 1 + frontends/OccamPasses.hs | 6 +++-- frontends/ParseOccam.hs | 19 ++++++++------ 6 files changed, 80 insertions(+), 47 deletions(-) diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs index 1f42061..d4c4b93 100644 --- a/backends/BackendPasses.hs +++ b/backends/BackendPasses.hs @@ -234,10 +234,13 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" t' <- recurse t >>= applyPulled popPullContext exts <- getCompState >>* csExternals - exts' <- sequence [do fs' <- transformExternal (findMeta t) fs - return $ (n, fs') - | (n, fs) <- exts] - modify $ \cs -> cs { csExternals = exts' } + exts' <- sequence [do fs' <- transformExternal (findMeta t) extType fs + modifyName (A.Name emptyMeta n) $ \nd -> nd + {A.ndSpecType = A.Proc (findMeta t) + (A.PlainSpec, A.PlainRec) fs' (A.Skip (findMeta t))} + return $ (n, (extType, fs')) + | (n, (extType, fs)) <- exts] + modify $ \cs -> cs { csExternals = exts' } return t' ) where @@ -354,7 +357,7 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" do -- We descend into the scope first, so that all the actuals get -- fixed before the formals: s' <- recurse s - (args', newargs) <- transformFormals False m args + (args', newargs) <- transformFormals Nothing m args sequence_ [defineSizesName m' n (A.Declaration m' t) | A.Formal _ t n <- newargs] -- We descend into the body after the formals have been @@ -368,20 +371,27 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" _ -> descend str doStructured s = descend s - transformExternal :: Meta -> [A.Formal] -> PassM [A.Formal] - transformExternal m args - = do (args', newargs) <- transformFormals True m args + transformExternal :: Meta -> ExternalType -> [A.Formal] -> PassM [A.Formal] + transformExternal m extType args + = do (args', newargs) <- transformFormals (Just extType) m args sequence_ [defineSizesName m n (A.Declaration m t) | A.Formal _ t n <- newargs] return args' - transformFormals :: Bool -> Meta -> [A.Formal] -> PassM ([A.Formal], [A.Formal]) + transformFormals :: Maybe ExternalType -> Meta -> [A.Formal] -> PassM ([A.Formal], [A.Formal]) transformFormals _ _ [] = return ([],[]) transformFormals ext m ((f@(A.Formal am t n)):fs) = case (t, ext) of + -- For externals, we always add extra formals (one per dimension!): + (A.Array ds _, Just ExternalOldStyle) -> + do params <- replicateM (length ds) $ makeNonce "ext_size" + let newfs = map (A.Formal A.ValAbbrev A.Int . A.Name m) params + (rest, moreNew) <- transformFormals ext m fs + return (f : newfs ++ rest, newfs ++ moreNew) + -- For occam PROCs, only bother adding the extra formal if the dimension -- is unknown: - (A.Array ds _, False) + (A.Array ds _, _) | A.UnknownDimension `elem` ds -> do let sizeType = A.Array [makeDimension m $ length ds] A.Int n_sizes <- makeNonce (A.nameName n ++ "_sizes") >>* A.Name m @@ -396,40 +406,34 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays" addSizes (A.nameName n) n_sizes (rest, moreNew) <- transformFormals ext m fs return (f : rest, moreNew) - -- For externals, we always add extra formals: - (A.Array ds _, True) -> - do params <- replicateM (length ds) $ makeNonce "ext_size" - let newfs = map (A.Formal A.ValAbbrev A.Int . A.Name m) params - (rest, moreNew) <- transformFormals ext m fs - return (f : newfs ++ rest, newfs ++ moreNew) _ -> do (rest, new) <- transformFormals ext m fs return (f : rest, new) doProcess :: A.Process -> PassM A.Process doProcess (A.ProcCall m n params) - = do ext <- getCompState >>* csExternals >>* lookup (A.nameName n) >>* isJust + = do ext <- getCompState >>* csExternals >>* lookup (A.nameName n) >>* fmap fst A.Proc _ _ fs _ <- specTypeOfName n concatMapM (transformActual ext) (zip fs params) >>* A.ProcCall m n doProcess p = descend p - transformActual :: Bool -> (A.Formal, A.Actual) -> PassM [A.Actual] + transformActual :: Maybe ExternalType -> (A.Formal, A.Actual) -> PassM [A.Actual] transformActual ext (A.Formal _ t _, a@(A.ActualVariable v)) = transformActualVariable ext t a v transformActual ext (A.Formal _ t _, a@(A.ActualExpression (A.ExprVariable _ v))) = transformActualVariable ext t a v transformActual _ (_, a) = return [a] - transformActualVariable :: Bool -> A.Type -> A.Actual -> A.Variable -> PassM [A.Actual] + transformActualVariable :: Maybe ExternalType -> A.Type -> A.Actual -> A.Variable -> PassM [A.Actual] transformActualVariable ext t a v = case (t, ext) of - -- Note that t is the formal type, not the type of the actual - (A.Array ds _, False) | A.UnknownDimension `elem` ds -> - do sizeV <- sizes v - return [a, A.ActualVariable sizeV] - (A.Array ds _, True) -> + (A.Array ds _, Just ExternalOldStyle) -> let acts = map (sub $ A.VariableSizes m v) [0 .. (length ds - 1)] in return $ a : acts + -- Note that t is the formal type, not the type of the actual + (A.Array ds _, _) | A.UnknownDimension `elem` ds -> + do sizeV <- sizes v + return [a, A.ActualVariable sizeV] _ -> return [a] where sizes v@(A.Variable m n) diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 7aa1fbb..4f14c53 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -172,7 +172,7 @@ cgenTopLevel headerName s sequence_ [tell ["#include \"", usedFile, ".h\"\n"] | usedFile <- Set.toList $ csUsedFiles cs] - sequence_ [tell ["extern int ", nameString n, "_stack_size;\n"] + sequence_ [tell ["extern int "] >> genProcName n >> tell ["_stack_size;\n"] | n <- (Set.toList $ csParProcs cs) ++ [A.Name emptyMeta n | A.NameDef {A.ndName = n @@ -182,7 +182,7 @@ cgenTopLevel headerName s when (csHasMain cs) $ do (tlpName, tlpChans) <- tlpInterface tell ["extern int "] - genName tlpName + genProcName tlpName tell ["_stack_size;\n"] -- Forward declarations of externals: @@ -215,7 +215,7 @@ cgenTopLevel headerName s tell ["\n\ \ "] - genName tlpName + genProcName tlpName tell [" (wptr"] sequence_ [tell [", &", c] | c <- chans] tell [");\n\ @@ -233,7 +233,7 @@ cgenTopLevel headerName s \ tock_init_ccsp (", uses_stdin, ");\n\ \\n\ \ Workspace p = ProcAllocInitial (0, "] - genName tlpName + genProcName tlpName tell ["_stack_size + 512);\n\ \ ProcStartInitial (p, tock_main);\n\ \\n\ @@ -1518,7 +1518,11 @@ prefixComma :: [CGen ()] -> CGen () prefixComma cs = sequence_ [genComma >> c | c <- cs] cgenActuals :: [A.Formal] -> [A.Actual] -> CGen () -cgenActuals fs as = seqComma [call genActual f a | (f, a) <- zip fs as] +cgenActuals fs as + = do when (length fs /= length as) $ + dieP (findMeta (fs, as)) $ "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] cgenActual :: A.Formal -> A.Actual -> CGen () cgenActual f a = seqComma $ realActuals f a id @@ -1539,9 +1543,20 @@ realFormals :: A.Formal -> [(CGen (), CGen ())] realFormals (A.Formal am t n) = [(genCType (A.nameMeta n) t am, genName n)] +genProcName :: A.Name -> CGen () +genProcName n + = do cs <- getCompState + if A.nameName n `elem` csOriginalTopLevelProcs cs + || A.nameName n `elem` map fst (csExternals cs) + then do nd <- lookupName n + genName $ n { A.nameName = "occam_" ++ A.ndOrigName nd } + else 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. +-- 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 :: A.Name -> A.SpecType -> Bool -> CGen () genProcSpec n (A.Proc _ (sm, rm) fs p) forwardDecl = do cs <- getCompState @@ -1564,7 +1579,7 @@ genProcSpec n (A.Proc _ (sm, rm) fs p) forwardDecl = do -- These can't be inlined, since they're only used as function -- pointers. tell ["void "] - genName n + genProcName n tell [" (Workspace wptr)"] genParParams :: CGen () @@ -1581,7 +1596,7 @@ genProcSpec n (A.Proc _ (sm, rm) fs p) forwardDecl genNormalHeader = do call genSpecMode sm tell ["void "] - genName n + genProcName n tell [" (Workspace wptr"] sequence_ [do tell [", "] t @@ -1606,7 +1621,7 @@ cgenProcAlloc n fs as ws <- csmLift $ makeNonce "workspace" tell ["Workspace ", ws, " = TockProcAlloc (wptr, ", show $ length ras, ", "] - genName n + genProcName n tell ["_stack_size);\n"] sequence_ [do tell [pc, " (wptr, ", ws, ", ", show num, ", "] @@ -1614,7 +1629,7 @@ cgenProcAlloc n fs as tell [");\n"] | (num, (pc, ra)) <- zip [(0 :: Int)..] ras] - return (ws, genName n) + return (ws, genProcName n) --}}} --{{{ processes @@ -2018,7 +2033,7 @@ cgenProcCall n as (A.Recursive, _) -> let m = A.nameMeta n in call genPar A.PlainPar $ A.Only m $ A.ProcCall m n as - (_, Just _) | head (A.nameName n) `elem` ['B', 'C'] -> + (_, 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 @@ -2034,7 +2049,7 @@ cgenProcCall n as tell [ [if c == '.' then '_' else c | c <- cs] , ",1,ext_args);}"] - _ -> do genName n + _ -> do genProcName n tell [" (wptr", if null as then "" else ","] (A.Proc _ _ fs _) <- specTypeOfName n call genActuals fs as diff --git a/data/CompState.hs b/data/CompState.hs index 2696b40..9248d59 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -87,6 +87,9 @@ type UnifyValue = TypeExp A.Type data NameAttr = NameShared | NameAliasesPermitted deriving (Typeable, Data, Eq, Show, Ord) +data ExternalType = ExternalOldStyle | ExternalOccam + deriving (Typeable, Data, Eq, Show, Ord) + -- | State necessary for compilation. data CompState = CompState { -- This structure needs to be printable with pshow. @@ -125,7 +128,11 @@ data CompState = CompState { csUnscopedNames :: Map String String, csNameCounter :: Int, csNameAttr :: Map String (Set.Set NameAttr), - csExternals :: [(String, [A.Formal])], + -- A list of all the things that were at the top-level before we pull anything + -- up (and therefore the things that should be visible to other files during + -- separate compilation) + csOriginalTopLevelProcs :: [String], + csExternals :: [(String, (ExternalType, [A.Formal]))], -- Maps an array variable name to the name of its _sizes array: csArraySizes :: Map String A.Name, -- Stores a map of constant sizes arrays declared for that size: @@ -178,6 +185,7 @@ emptyState = CompState { csUnscopedNames = Map.empty, csNameCounter = 0, csNameAttr = Map.empty, + csOriginalTopLevelProcs = [], csExternals = [], csArraySizes = Map.empty, csGlobalSizes = Map.empty, diff --git a/frontends/LexOccam.x b/frontends/LexOccam.x index 6ef4556..bd4ef03 100644 --- a/frontends/LexOccam.x +++ b/frontends/LexOccam.x @@ -110,6 +110,7 @@ occam :- "SHARED" { mkToken Pragma two } "PERMITALIASES" { mkToken Pragma two } "EXTERNAL" $horizSpace* \" { mkToken Pragma four } + "OCCAMEXTERNAL" $horizSpace* \" { mkToken Pragma four } \" $horizSpace* { mkState 0 } @preprocessor { mkToken TokPreprocessor 0 } diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index fa173b0..bcd9c85 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -70,12 +70,14 @@ writeIncFile = occamOnlyPass "Write .inc file" [] [] emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String) emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ _ fs _)) scope) = do thisProc <- sequence ( - [return "#PRAGMA EXTERNAL \"PROC " + [return "#PRAGMA OCCAMEXTERNAL \"PROC " ,showCode n ,return "(" ] ++ intersperse (return ",") (map showCode fs) ++ - [return ") = 42\"" + [return ")\"" ]) >>* concat + modify $ \cs -> cs { csOriginalTopLevelProcs = + A.nameName n : csOriginalTopLevelProcs cs } emitProcsAsExternal scope >>* (thisProc Seq.<|) emitProcsAsExternal (A.Spec _ _ scope) = emitProcsAsExternal scope emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 4f23e08..3858d4b 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -19,7 +19,7 @@ with this program. If not, see . -- | Parse occam code into an AST. module ParseOccam (parseOccamProgram) where -import Control.Monad (liftM) +import Control.Monad (liftM, when) import Control.Monad.State (MonadState, modify, get, put) import Data.List import qualified Data.Map as Map @@ -1356,15 +1356,16 @@ pragma = do Pragma rawP <- genToken isPragma cs <- getCompState prod <- return $ -- Maybe monad: - case + case findIndex isJust [ do Token _ (Pragma firstTok) <- listToMaybe pragToks matchRegex (mkRegex pt) firstTok | pt <- [ "^SHARED.*" , "^PERMITALIASES.*" , "^EXTERNAL.*" + , "^OCCAMEXTERNAL.*" ] ] of - [Just _, _, _] -> do + Just 0 -> do vars <- sepBy1 identifier sComma mapM_ (\var -> do st <- get @@ -1374,7 +1375,7 @@ pragma = do Pragma rawP <- genToken isPragma modify $ \st -> st {csNameAttr = Map.insertWith Set.union n (Set.singleton NameShared) (csNameAttr st)}) vars - [Nothing, Just _, _] -> do + Just 1 -> do vars <- sepBy1 identifier sComma mapM_ (\var -> do st <- get @@ -1384,20 +1385,22 @@ pragma = do Pragma rawP <- genToken isPragma modify $ \st -> st {csNameAttr = Map.insertWith Set.union n (Set.singleton NameAliasesPermitted) (csNameAttr st)}) vars - [Nothing, Nothing, Just _] -> do + Just pragmaType | pragmaType == 2 || pragmaType == 3 -> do m <- md sPROC n <- newProcName fs <- formalList >>* map fst - sEq - integer + when (pragmaType == 2) $ do sEq + integer + return () let on = A.nameName n sp = A.Proc m (A.PlainSpec, A.PlainRec) fs (A.Skip m) nd = A.NameDef m on on sp A.Original A.NamePredefined A.Unplaced + ext = if pragmaType == 2 then ExternalOldStyle else ExternalOccam modify $ \st -> st { csNames = Map.insert on nd (csNames st) , csLocalNames = (on, (n, ProcName)) : csLocalNames st - , csExternals = (on, fs) : csExternals st + , csExternals = (on, (ext, fs)) : csExternals st } _ -> warnP m WarnUnknownPreprocessorDirective $ "Unknown PRAGMA type: " ++ show (listToMaybe pragToks)