suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Switched to using a different kind of pragma for occam externals, and munged the names to avoid collisions

Browse Source 
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.
This commit is contained in:
Neil Brown 2009-04-01 19:21:40 +00:00
parent 5bf1ffa785
commit 7e7a437a3b
6 changed files with 80 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
backends/BackendPasses.hs
View File

@ -234,10 +234,13 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
t' <- recurse t >>= applyPulled t' <- recurse t >>= applyPulled
popPullContext popPullContext
exts <- getCompState >>* csExternals exts <- getCompState >>* csExternals
exts' <- sequence [do fs' <- transformExternal (findMeta t) fs exts' <- sequence [do fs' <- transformExternal (findMeta t) extType fs
return $ (n, fs') modifyName (A.Name emptyMeta n) $ \nd -> nd
| (n, fs) <- exts] {A.ndSpecType = A.Proc (findMeta t)
modify $ \cs -> cs { csExternals = exts' } (A.PlainSpec, A.PlainRec) fs' (A.Skip (findMeta t))}
return $ (n, (extType, fs'))
| (n, (extType, fs)) <- exts]
modify $ \cs -> cs { csExternals = exts' }
return t' return t'
) )
where where
@ -354,7 +357,7 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
do -- We descend into the scope first, so that all the actuals get do -- We descend into the scope first, so that all the actuals get
-- fixed before the formals: -- fixed before the formals:
s' <- recurse s s' <- recurse s
(args', newargs) <- transformFormals False m args (args', newargs) <- transformFormals Nothing m args
sequence_ [defineSizesName m' n (A.Declaration m' t) sequence_ [defineSizesName m' n (A.Declaration m' t)
| A.Formal _ t n <- newargs] | A.Formal _ t n <- newargs]
-- We descend into the body after the formals have been -- We descend into the body after the formals have been
@ -368,20 +371,27 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
_ -> descend str _ -> descend str
doStructured s = descend s doStructured s = descend s
transformExternal :: Meta -> [A.Formal] -> PassM [A.Formal] transformExternal :: Meta -> ExternalType -> [A.Formal] -> PassM [A.Formal]
transformExternal m args transformExternal m extType args
= do (args', newargs) <- transformFormals True m args = do (args', newargs) <- transformFormals (Just extType) m args
sequence_ [defineSizesName m n (A.Declaration m t) sequence_ [defineSizesName m n (A.Declaration m t)
| A.Formal _ t n <- newargs] | A.Formal _ t n <- newargs]
return args' 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 _ _ [] = return ([],[])
transformFormals ext m ((f@(A.Formal am t n)):fs) transformFormals ext m ((f@(A.Formal am t n)):fs)
= case (t, ext) of = 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 -- For occam PROCs, only bother adding the extra formal if the dimension
-- is unknown: -- is unknown:
(A.Array ds _, False) (A.Array ds _, _)
| A.UnknownDimension `elem` ds -> | A.UnknownDimension `elem` ds ->
do let sizeType = A.Array [makeDimension m $ length ds] A.Int do let sizeType = A.Array [makeDimension m $ length ds] A.Int
n_sizes <- makeNonce (A.nameName n ++ "_sizes") >>* A.Name m 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 addSizes (A.nameName n) n_sizes
(rest, moreNew) <- transformFormals ext m fs (rest, moreNew) <- transformFormals ext m fs
return (f : rest, moreNew) 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 _ -> do (rest, new) <- transformFormals ext m fs
return (f : rest, new) return (f : rest, new)
doProcess :: A.Process -> PassM A.Process doProcess :: A.Process -> PassM A.Process
doProcess (A.ProcCall m n params) 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 A.Proc _ _ fs _ <- specTypeOfName n
concatMapM (transformActual ext) (zip fs params) >>* A.ProcCall m n concatMapM (transformActual ext) (zip fs params) >>* A.ProcCall m n
doProcess p = descend p 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)) transformActual ext (A.Formal _ t _, a@(A.ActualVariable v))
= transformActualVariable ext t a v = transformActualVariable ext t a v
transformActual ext (A.Formal _ t _, a@(A.ActualExpression (A.ExprVariable _ v))) transformActual ext (A.Formal _ t _, a@(A.ActualExpression (A.ExprVariable _ v)))
= transformActualVariable ext t a v = transformActualVariable ext t a v
transformActual _ (_, a) = return [a] 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 transformActualVariable ext t a v
= case (t, ext) of = case (t, ext) of
-- Note that t is the formal type, not the type of the actual (A.Array ds _, Just ExternalOldStyle) ->
(A.Array ds _, False) | A.UnknownDimension `elem` ds ->
do sizeV <- sizes v
return [a, A.ActualVariable sizeV]
(A.Array ds _, True) ->
let acts = map (sub $ A.VariableSizes m v) [0 .. (length ds - 1)] let acts = map (sub $ A.VariableSizes m v) [0 .. (length ds - 1)]
in return $ a : acts 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] _ -> return [a]
where where
sizes v@(A.Variable m n) sizes v@(A.Variable m n)

39
backends/GenerateC.hs
View File

@ -172,7 +172,7 @@ cgenTopLevel headerName s
sequence_ [tell ["#include \"", usedFile, ".h\"\n"] sequence_ [tell ["#include \"", usedFile, ".h\"\n"]
| usedFile <- Set.toList $ csUsedFiles cs] | 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) | n <- (Set.toList $ csParProcs cs)
++ [A.Name emptyMeta n | A.NameDef ++ [A.Name emptyMeta n | A.NameDef
{A.ndName = n {A.ndName = n
@ -182,7 +182,7 @@ cgenTopLevel headerName s
when (csHasMain cs) $ do when (csHasMain cs) $ do
(tlpName, tlpChans) <- tlpInterface (tlpName, tlpChans) <- tlpInterface
tell ["extern int "] tell ["extern int "]
genName tlpName genProcName tlpName
tell ["_stack_size;\n"] tell ["_stack_size;\n"]
-- Forward declarations of externals: -- Forward declarations of externals:
@ -215,7 +215,7 @@ cgenTopLevel headerName s
tell ["\n\ tell ["\n\
\ "] \ "]
genName tlpName genProcName tlpName
tell [" (wptr"] tell [" (wptr"]
sequence_ [tell [", &", c] | c <- chans] sequence_ [tell [", &", c] | c <- chans]
tell [");\n\ tell [");\n\
@ -233,7 +233,7 @@ cgenTopLevel headerName s
\ tock_init_ccsp (", uses_stdin, ");\n\ \ tock_init_ccsp (", uses_stdin, ");\n\
\\n\ \\n\
\ Workspace p = ProcAllocInitial (0, "] \ Workspace p = ProcAllocInitial (0, "]
genName tlpName genProcName tlpName
tell ["_stack_size + 512);\n\ tell ["_stack_size + 512);\n\
\ ProcStartInitial (p, tock_main);\n\ \ ProcStartInitial (p, tock_main);\n\
\\n\ \\n\
@ -1518,7 +1518,11 @@ prefixComma :: [CGen ()] -> CGen ()
prefixComma cs = sequence_ [genComma >> c | c <- cs] prefixComma cs = sequence_ [genComma >> c | c <- cs]
cgenActuals :: [A.Formal] -> [A.Actual] -> CGen () 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 :: A.Formal -> A.Actual -> CGen ()
cgenActual f a = seqComma $ realActuals f a id cgenActual f a = seqComma $ realActuals f a id
@ -1539,9 +1543,20 @@ realFormals :: A.Formal -> [(CGen (), CGen ())]
realFormals (A.Formal am t n) realFormals (A.Formal am t n)
= [(genCType (A.nameMeta n) t am, genName 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. -- | Generate a Proc specification, which maps to a C function.
-- This will use ProcGetParam if the Proc is in csParProcs, or the normal C -- 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 :: A.Name -> A.SpecType -> Bool -> CGen ()
genProcSpec n (A.Proc _ (sm, rm) fs p) forwardDecl genProcSpec n (A.Proc _ (sm, rm) fs p) forwardDecl
= do cs <- getCompState = 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 = do -- These can't be inlined, since they're only used as function
-- pointers. -- pointers.
tell ["void "] tell ["void "]
genName n genProcName n
tell [" (Workspace wptr)"] tell [" (Workspace wptr)"]
genParParams :: CGen () genParParams :: CGen ()
@ -1581,7 +1596,7 @@ genProcSpec n (A.Proc _ (sm, rm) fs p) forwardDecl
genNormalHeader genNormalHeader
= do call genSpecMode sm = do call genSpecMode sm
tell ["void "] tell ["void "]
genName n genProcName n
tell [" (Workspace wptr"] tell [" (Workspace wptr"]
sequence_ [do tell [", "] sequence_ [do tell [", "]
t t
@ -1606,7 +1621,7 @@ cgenProcAlloc n fs as
ws <- csmLift $ makeNonce "workspace" ws <- csmLift $ makeNonce "workspace"
tell ["Workspace ", ws, " = TockProcAlloc (wptr, ", show $ length ras, ", "] tell ["Workspace ", ws, " = TockProcAlloc (wptr, ", show $ length ras, ", "]
genName n genProcName n
tell ["_stack_size);\n"] tell ["_stack_size);\n"]
sequence_ [do tell [pc, " (wptr, ", ws, ", ", show num, ", "] sequence_ [do tell [pc, " (wptr, ", ws, ", ", show num, ", "]
@ -1614,7 +1629,7 @@ cgenProcAlloc n fs as
tell [");\n"] tell [");\n"]
| (num, (pc, ra)) <- zip [(0 :: Int)..] ras] | (num, (pc, ra)) <- zip [(0 :: Int)..] ras]
return (ws, genName n) return (ws, genProcName n)
--}}} --}}}
--{{{ processes --{{{ processes
@ -2018,7 +2033,7 @@ cgenProcCall n as
(A.Recursive, _) -> (A.Recursive, _) ->
let m = A.nameMeta n let m = A.nameMeta n
in call genPar A.PlainPar $ A.Only m $ A.ProcCall m n as 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 do let (c:cs) = A.nameName n
tell ["{int ext_args[] = {"] tell ["{int ext_args[] = {"]
-- We don't use the formals in csExternals because they won't -- 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] tell [ [if c == '.' then '_' else c | c <- cs]
, ",1,ext_args);}"] , ",1,ext_args);}"]
_ -> do genName n _ -> do genProcName n
tell [" (wptr", if null as then "" else ","] tell [" (wptr", if null as then "" else ","]
(A.Proc _ _ fs _) <- specTypeOfName n (A.Proc _ _ fs _) <- specTypeOfName n
call genActuals fs as call genActuals fs as

10
data/CompState.hs
View File

@ -87,6 +87,9 @@ type UnifyValue = TypeExp A.Type
data NameAttr = NameShared | NameAliasesPermitted deriving (Typeable, Data, Eq, Show, Ord) data NameAttr = NameShared | NameAliasesPermitted deriving (Typeable, Data, Eq, Show, Ord)
data ExternalType = ExternalOldStyle | ExternalOccam
deriving (Typeable, Data, Eq, Show, Ord)
-- | State necessary for compilation. -- | State necessary for compilation.
data CompState = CompState { data CompState = CompState {
-- This structure needs to be printable with pshow. -- This structure needs to be printable with pshow.
@ -125,7 +128,11 @@ data CompState = CompState {
csUnscopedNames :: Map String String, csUnscopedNames :: Map String String,
csNameCounter :: Int, csNameCounter :: Int,
csNameAttr :: Map String (Set.Set NameAttr), 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: -- Maps an array variable name to the name of its _sizes array:
csArraySizes :: Map String A.Name, csArraySizes :: Map String A.Name,
-- Stores a map of constant sizes arrays declared for that size: -- Stores a map of constant sizes arrays declared for that size:
@ -178,6 +185,7 @@ emptyState = CompState {
csUnscopedNames = Map.empty, csUnscopedNames = Map.empty,
csNameCounter = 0, csNameCounter = 0,
csNameAttr = Map.empty, csNameAttr = Map.empty,
csOriginalTopLevelProcs = [],
csExternals = [], csExternals = [],
csArraySizes = Map.empty, csArraySizes = Map.empty,
csGlobalSizes = Map.empty, csGlobalSizes = Map.empty,

1
frontends/LexOccam.x
View File

@ -110,6 +110,7 @@ occam :-
<five> "SHARED" { mkToken Pragma two } <five> "SHARED" { mkToken Pragma two }
<five> "PERMITALIASES" { mkToken Pragma two } <five> "PERMITALIASES" { mkToken Pragma two }
<five> "EXTERNAL" $horizSpace* \" { mkToken Pragma four } <five> "EXTERNAL" $horizSpace* \" { mkToken Pragma four }
<five> "OCCAMEXTERNAL" $horizSpace* \" { mkToken Pragma four }
<four> \" $horizSpace* { mkState 0 } <four> \" $horizSpace* { mkState 0 }
<one> @preprocessor { mkToken TokPreprocessor 0 } <one> @preprocessor { mkToken TokPreprocessor 0 }

6
frontends/OccamPasses.hs
View File

@ -70,12 +70,14 @@ writeIncFile = occamOnlyPass "Write .inc file" [] []
emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String) emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String)
emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ _ fs _)) scope) emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ _ fs _)) scope)
= do thisProc <- sequence ( = do thisProc <- sequence (
[return "#PRAGMA EXTERNAL \"PROC " [return "#PRAGMA OCCAMEXTERNAL \"PROC "
,showCode n ,showCode n
,return "(" ,return "("
] ++ intersperse (return ",") (map showCode fs) ++ ] ++ intersperse (return ",") (map showCode fs) ++
[return ") = 42\"" [return ")\""
]) >>* concat ]) >>* concat
modify $ \cs -> cs { csOriginalTopLevelProcs =
A.nameName n : csOriginalTopLevelProcs cs }
emitProcsAsExternal scope >>* (thisProc Seq.<|) emitProcsAsExternal scope >>* (thisProc Seq.<|)
emitProcsAsExternal (A.Spec _ _ scope) = emitProcsAsExternal scope emitProcsAsExternal (A.Spec _ _ scope) = emitProcsAsExternal scope
emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope

19
frontends/ParseOccam.hs
View File

@ -19,7 +19,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- | Parse occam code into an AST. -- | Parse occam code into an AST.
module ParseOccam (parseOccamProgram) where module ParseOccam (parseOccamProgram) where
import Control.Monad (liftM) import Control.Monad (liftM, when)
import Control.Monad.State (MonadState, modify, get, put) import Control.Monad.State (MonadState, modify, get, put)
import Data.List import Data.List
import qualified Data.Map as Map import qualified Data.Map as Map
@ -1356,15 +1356,16 @@ pragma = do Pragma rawP <- genToken isPragma
cs <- getCompState cs <- getCompState
prod <- return $ prod <- return $
-- Maybe monad: -- Maybe monad:
case case findIndex isJust
[ do Token _ (Pragma firstTok) <- listToMaybe pragToks [ do Token _ (Pragma firstTok) <- listToMaybe pragToks
matchRegex (mkRegex pt) firstTok matchRegex (mkRegex pt) firstTok
| pt <- [ "^SHARED.*" | pt <- [ "^SHARED.*"
, "^PERMITALIASES.*" , "^PERMITALIASES.*"
, "^EXTERNAL.*" , "^EXTERNAL.*"
, "^OCCAMEXTERNAL.*"
] ]
] of ] of
[Just _, _, _] -> do Just 0 -> do
vars <- sepBy1 identifier sComma vars <- sepBy1 identifier sComma
mapM_ (\var -> mapM_ (\var ->
do st <- get do st <- get
@ -1374,7 +1375,7 @@ pragma = do Pragma rawP <- genToken isPragma
modify $ \st -> st {csNameAttr = Map.insertWith Set.union modify $ \st -> st {csNameAttr = Map.insertWith Set.union
n (Set.singleton NameShared) (csNameAttr st)}) n (Set.singleton NameShared) (csNameAttr st)})
vars vars
[Nothing, Just _, _] -> do Just 1 -> do
vars <- sepBy1 identifier sComma vars <- sepBy1 identifier sComma
mapM_ (\var -> mapM_ (\var ->
do st <- get do st <- get
@ -1384,20 +1385,22 @@ pragma = do Pragma rawP <- genToken isPragma
modify $ \st -> st {csNameAttr = Map.insertWith Set.union modify $ \st -> st {csNameAttr = Map.insertWith Set.union
n (Set.singleton NameAliasesPermitted) (csNameAttr st)}) n (Set.singleton NameAliasesPermitted) (csNameAttr st)})
vars vars
[Nothing, Nothing, Just _] -> do Just pragmaType | pragmaType == 2 || pragmaType == 3 -> do
m <- md m <- md
sPROC sPROC
n <- newProcName n <- newProcName
fs <- formalList >>* map fst fs <- formalList >>* map fst
sEq when (pragmaType == 2) $ do sEq
integer integer
return ()
let on = A.nameName n let on = A.nameName n
sp = A.Proc m (A.PlainSpec, A.PlainRec) fs (A.Skip m) 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 nd = A.NameDef m on on sp A.Original A.NamePredefined A.Unplaced
ext = if pragmaType == 2 then ExternalOldStyle else ExternalOccam
modify $ \st -> st modify $ \st -> st
{ csNames = Map.insert on nd (csNames st) { csNames = Map.insert on nd (csNames st)
, csLocalNames = (on, (n, ProcName)) : csLocalNames st , csLocalNames = (on, (n, ProcName)) : csLocalNames st
, csExternals = (on, fs) : csExternals st , csExternals = (on, (ext, fs)) : csExternals st
} }
_ -> warnP m WarnUnknownPreprocessorDirective $ _ -> warnP m WarnUnknownPreprocessorDirective $
"Unknown PRAGMA type: " ++ show (listToMaybe pragToks) "Unknown PRAGMA type: " ++ show (listToMaybe pragToks)