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

Fixed the occam type-checker to work with the new channel-ends, adding direction specifiers where necessary

Browse Source 
In actual parameters (checking against the formal type), abbreviations (checking against the inferred/specified destination type), and inputs (including inside ALTs) and outputs, direction specifiers are automatically added where needed.  With all the other changes, this seems to compile all the occam 2 cgtests, and cgtest87 (which tests directions) as well as Adam's tests so I'm fairly confident that it was the right thing to do.
This commit is contained in:
Neil Brown 2009-01-20 17:30:17 +00:00
parent 4d692c8897
commit a416f7dac9
1 changed files with 74 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
frontends/OccamTypes.hs
View File

@ -77,12 +77,6 @@ areValidDimensions (d1:ds1) (d2:ds2)
else return False else return False
areValidDimensions _ _ = return False areValidDimensions _ _ = return False
-- | Check that the second direction can be used in a context where the first
-- is expected.
isValidDirection :: A.Direction -> A.Direction -> Bool
isValidDirection _ A.DirUnknown = True
isValidDirection ed rd = ed == rd
-- | Check that a type we've inferred matches the type we expected. -- | Check that a type we've inferred matches the type we expected.
checkType :: Meta -> A.Type -> A.Type -> PassM () checkType :: Meta -> A.Type -> A.Type -> PassM ()
checkType m et rt checkType m et rt
@ -93,10 +87,6 @@ checkType m et rt
if valid if valid
then checkType m t t' then checkType m t t'
else bad else bad
(A.Chan dir ca t, A.Chan dir' ca' t') ->
if isValidDirection dir dir' && (ca == ca')
then checkType m t t'
else bad
_ -> _ ->
do same <- sameType rt et do same <- sameType rt et
when (not same) $ bad when (not same) $ bad
@ -430,24 +420,21 @@ checkChannel wantDir c
= do -- Check it's a channel. = do -- Check it's a channel.
t <- astTypeOf c >>= resolveUserType m t <- astTypeOf c >>= resolveUserType m
case t of case t of
A.Chan dir (A.ChanAttributes ws rs) innerT -> A.ChanEnd dir (A.ChanAttributes ws rs) innerT ->
do -- Check the direction is appropriate do -- Check the direction is appropriate
case (wantDir, dir) of when (wantDir /= dir) $ dieP m $ "Channel directions do not match"
(A.DirUnknown, _) -> ok
(_, A.DirUnknown) -> ok
(a, b) -> when (a /= b) $
dieP m $ "Channel directions do not match"
-- Check it's not shared in the direction we're using. -- Check it's not shared in the direction we're using.
case (ws, rs, wantDir) of case (ws, rs, wantDir) of
(False, _, A.DirOutput) -> ok (False, _, A.DirOutput) -> ok
(_, False, A.DirInput) -> ok (_, False, A.DirInput) -> ok
(_, _, A.DirUnknown) -> ok
_ -> dieP m $ "Shared channel must be claimed before use" _ -> dieP m $ "Shared channel must be claimed before use"
return innerT return innerT
_ -> diePC m $ formatCode "Expected channel; found %" t _ -> diePC m $ formatCode ("Expected channel " ++ exp ++ "; found %") t
where where
exp = case wantDir of
A.DirInput -> "input-end"
A.DirOutput -> "output-end"
m = findMeta c m = findMeta c
-- | Check that a variable is a timer. -- | Check that a variable is a timer.
@ -700,12 +687,15 @@ inferTypes = occamOnlyPass "Infer types"
doFunctionCall :: Meta -> A.Name -> Transform [A.Expression] doFunctionCall :: Meta -> A.Name -> Transform [A.Expression]
doFunctionCall m n es doFunctionCall m n es
= do (_, fs) <- checkFunction m n = do (_, fs) <- checkFunction m n
doActuals m n fs es doActuals m n fs (error "Cannot direct channels passed to FUNCTIONs") es
doActuals :: Data a => Meta -> A.Name -> [A.Formal] -> Transform [a] doActuals :: Data a => Meta -> A.Name -> [A.Formal] -> (Meta -> A.Direction -> Transform a)
doActuals m n fs as -> Transform [a]
doActuals m n fs applyDir as
= do checkActualCount m n fs as = do checkActualCount m n fs as
sequence [inTypeContext (Just t) $ recurse a sequence [case t of
A.ChanEnd dir _ _ -> recurse a >>= applyDir m dir
_ -> inTypeContext (Just t) $ recurse a
| (A.Formal _ t _, a) <- zip fs as] | (A.Formal _ t _, a) <- zip fs as]
doDimension :: Transform A.Dimension doDimension :: Transform A.Dimension
@ -740,7 +730,19 @@ inferTypes = occamOnlyPass "Infer types"
A.ForEach _ _ -> noTypeContext $ descend rep A.ForEach _ _ -> noTypeContext $ descend rep
doAlternative :: Transform A.Alternative doAlternative :: Transform A.Alternative
doAlternative a = inTypeContext (Just A.Bool) $ descend a doAlternative (A.Alternative m pre v im p)
= do pre' <- inTypeContext (Just A.Bool) $ recurse pre
v' <- recurse v >>= case im of
A.InputSimple {} -> makeEnd m A.DirInput
A.InputCase {} -> makeEnd m A.DirInput
_ -> return
im' <- recurse im
p' <- recurse p
return $ A.Alternative m pre' v' im' p'
doAlternative (A.AlternativeSkip m pre p)
= do pre' <- inTypeContext (Just A.Bool) $ recurse pre
p' <- recurse p
return $ A.AlternativeSkip m pre' p'
doInputMode :: Transform A.InputMode doInputMode :: Transform A.InputMode
doInputMode im = inTypeContext (Just A.Int) $ descend im doInputMode im = inTypeContext (Just A.Int) $ descend im
@ -761,10 +763,16 @@ inferTypes = occamOnlyPass "Infer types"
do am' <- recurse am do am' <- recurse am
t' <- recurse t t' <- recurse t
v' <- inTypeContext (Just t') $ recurse v v' <- inTypeContext (Just t') $ recurse v
t'' <- case t' of (t'', v'') <- case t' of
A.Infer -> astTypeOf v' A.Infer -> do r <- astTypeOf v'
_ -> return t' return (r, v')
return $ A.Is m am' t'' v' A.ChanEnd dir _ _ -> do v'' <- makeEnd m dir v'
return (t', v'')
A.Array _ (A.ChanEnd dir _ _) ->
do v'' <- makeEnd m dir v'
return (t', v'')
_ -> return (t', v')
return $ A.Is m am' t'' v''
A.IsExpr m am t e -> A.IsExpr m am t e ->
do am' <- recurse am do am' <- recurse am
t' <- recurse t t' <- recurse t
@ -777,7 +785,11 @@ inferTypes = occamOnlyPass "Infer types"
-- No expressions in this -- but we may need to infer the type -- No expressions in this -- but we may need to infer the type
-- of the variable if it's something like "cs IS [c]:". -- of the variable if it's something like "cs IS [c]:".
do t' <- recurse t do t' <- recurse t
vs' <- mapM recurse vs vs' <- mapM recurse vs >>= case t' of
A.Infer -> return
A.Array _ (A.Chan {}) -> return
A.Array _ (A.ChanEnd dir _ _) -> mapM (makeEnd m dir)
_ -> const $ dieP m "Cannot coerce non-channels into channels"
let dim = makeDimension m $ length vs' let dim = makeDimension m $ length vs'
t'' <- case (t', vs') of t'' <- case (t', vs') of
(A.Infer, (v:_)) -> (A.Infer, (v:_)) ->
@ -813,6 +825,17 @@ inferTypes = occamOnlyPass "Infer types"
= do el' <- doExpressionList ts el = do el' <- doExpressionList ts el
return $ A.Only m el' return $ A.Only m el'
makeEnd :: Meta -> A.Direction -> Transform A.Variable
makeEnd m dir v
= do t <- astTypeOf v
case t of
A.ChanEnd {} -> return v
A.Chan {} -> return $ A.DirectedVariable m dir v
A.Array _ (A.ChanEnd {}) -> return v
A.Array _ (A.Chan {}) -> return $ A.DirectedVariable m dir v
_ -> dieP m "Cannot infer direction for things that are not a channel or channel-end"
doProcess :: Transform A.Process doProcess :: Transform A.Process
doProcess p doProcess p
= case p of = case p of
@ -822,7 +845,7 @@ inferTypes = occamOnlyPass "Infer types"
el' <- doExpressionList ts el el' <- doExpressionList ts el
return $ A.Assign m vs' el' return $ A.Assign m vs' el'
A.Output m v ois -> A.Output m v ois ->
do v' <- recurse v do v' <- recurse v >>= makeEnd m A.DirOutput
-- At this point we must resolve the "c ! x" ambiguity: -- At this point we must resolve the "c ! x" ambiguity:
-- we definitely know what c is, and we must know what x is -- we definitely know what c is, and we must know what x is
-- before trying to infer its type. -- before trying to infer its type.
@ -839,7 +862,7 @@ inferTypes = occamOnlyPass "Infer types"
else do ois' <- doOutputItems m v' Nothing ois else do ois' <- doOutputItems m v' Nothing ois
return $ A.Output m v' ois' return $ A.Output m v' ois'
A.OutputCase m v tag ois -> A.OutputCase m v tag ois ->
do v' <- recurse v do v' <- recurse v >>= makeEnd m A.DirOutput
ois' <- doOutputItems m v' (Just tag) ois ois' <- doOutputItems m v' (Just tag) ois
return $ A.OutputCase m v' tag ois' return $ A.OutputCase m v' tag ois'
A.If _ _ -> inTypeContext (Just A.Bool) $ descend p A.If _ _ -> inTypeContext (Just A.Bool) $ descend p
@ -852,9 +875,18 @@ inferTypes = occamOnlyPass "Infer types"
A.Processor _ _ _ -> inTypeContext (Just A.Int) $ descend p A.Processor _ _ _ -> inTypeContext (Just A.Int) $ descend p
A.ProcCall m n as -> A.ProcCall m n as ->
do fs <- checkProc m n do fs <- checkProc m n
as' <- doActuals m n fs as as' <- doActuals m n fs (\m dir (A.ActualVariable v) -> liftM
A.ActualVariable $ makeEnd m dir v) as
return $ A.ProcCall m n as' return $ A.ProcCall m n as'
A.IntrinsicProcCall _ _ _ -> noTypeContext $ descend p A.IntrinsicProcCall _ _ _ -> noTypeContext $ descend p
A.Input m v im@(A.InputSimple {})
-> do im' <- recurse im
v' <- recurse v >>= makeEnd m A.DirInput
return $ A.Input m v' im'
A.Input m v im@(A.InputCase {})
-> do im' <- recurse im
v' <- recurse v >>= makeEnd m A.DirInput
return $ A.Input m v' im'
_ -> descend p _ -> descend p
where where
-- | Does a channel carry a tagged protocol? -- | Does a channel carry a tagged protocol?
@ -1039,12 +1071,14 @@ checkVariables = checkDepthM doVariable
doVariable (A.DirectedVariable m dir v) doVariable (A.DirectedVariable m dir v)
= do t <- astTypeOf v >>= resolveUserType m = do t <- astTypeOf v >>= resolveUserType m
case t of case t of
A.Chan oldDir _ _ -> checkDir oldDir A.ChanEnd oldDir _ _ -> checkDir oldDir
A.Array _ (A.Chan oldDir _ _) -> checkDir oldDir A.Chan _ _ -> ok
_ -> dieP m $ "Direction specified on non-channel variable" A.Array _ (A.ChanEnd oldDir _ _) -> checkDir oldDir
A.Array _ (A.Chan _ _) -> ok
_ -> diePC m $ formatCode "Direction specified on non-channel variable of type: %" t
where where
checkDir oldDir checkDir oldDir
= if isValidDirection dir oldDir = if dir == oldDir
then ok then ok
else dieP m "Direction specified does not match existing direction" else dieP m "Direction specified does not match existing direction"
doVariable (A.DerefVariable m v) doVariable (A.DerefVariable m v)
@ -1131,8 +1165,11 @@ checkSpecTypes = checkDepthM doSpecType
checkAbbrev m A.ValAbbrev am checkAbbrev m A.ValAbbrev am
doSpecType (A.IsChannelArray m rawT cs) doSpecType (A.IsChannelArray m rawT cs)
= do t <- resolveUserType m rawT = do t <- resolveUserType m rawT
let isChan (A.Chan {}) = True
isChan (A.ChanEnd {}) = True
isChan _ = False
case t of case t of
A.Array [d] et@(A.Chan _ _ _) -> A.Array [d] et | isChan et ->
do sequence_ [do rt <- astTypeOf c do sequence_ [do rt <- astTypeOf c
checkType (findMeta c) et rt checkType (findMeta c) et rt
am <- abbrevModeOfVariable c am <- abbrevModeOfVariable c