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
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)

39
backends/GenerateC.hs
View File

@ -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

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 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,

1
frontends/LexOccam.x
View File

@ -110,6 +110,7 @@ occam :-
<five> "SHARED" { mkToken Pragma two }
<five> "PERMITALIASES" { mkToken Pragma two }
<five> "EXTERNAL" $horizSpace* \" { mkToken Pragma four }
<five> "OCCAMEXTERNAL" $horizSpace* \" { mkToken Pragma four }
<four> \" $horizSpace* { mkState 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.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

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.
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)