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

Changed the ChanEnd constructor to only keep information about its shared-ness, not about the whole channel

Browse Source
This commit is contained in:
Neil Brown 2009-03-23 18:40:28 +00:00
parent e8fec8585b
commit 41805aaacf
8 changed files with 28 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
common/ShowCode.hs
View File

@ -255,11 +255,9 @@ instance ShowOccam A.Type where
= tell [shared, "CHAN", direction, " "] >> showOccamM t = tell [shared, "CHAN", direction, " "] >> showOccamM t
where where
shared shared
= case (A.caWritingShared ca, A.caReadingShared ca) of = case ca of
(A.Unshared, A.Unshared) -> "" A.Unshared -> ""
(A.Shared, A.Unshared) -> "SHARED! " A.Shared -> "SHARED "
(A.Unshared, A.Shared) -> "SHARED? "
(A.Shared, A.Shared) -> "SHARED "
direction direction
= case dir of = case dir of
A.DirInput -> "?" A.DirInput -> "?"
@ -303,8 +301,8 @@ instance ShowRain A.Type where
ao b = if b == A.Shared then "any" else "one" ao b = if b == A.Shared then "any" else "one"
showRainM (A.ChanEnd dir attr t) showRainM (A.ChanEnd dir attr t)
= case dir of = case dir of
A.DirInput -> tell [if A.caReadingShared attr == A.Shared then "shared" else "", " ?"] >> showRainM t A.DirInput -> tell [if attr == A.Shared then "shared" else "", " ?"] >> showRainM t
A.DirOutput -> tell [if A.caWritingShared attr == A.Shared then "shared" else "", " !"] >> showRainM t A.DirOutput -> tell [if attr == A.Shared then "shared" else "", " !"] >> showRainM t
where where
ao :: Bool -> String ao :: Bool -> String
ao b = if b then "any" else "one" ao b = if b then "any" else "one"

13
common/Types.hs
View File

@ -29,7 +29,7 @@ module Types
mulExprs, divExprs mulExprs, divExprs
, addDimensions, applyDimension, removeFixedDimensions, trivialSubscriptType, subscriptType, unsubscriptType , addDimensions, applyDimension, removeFixedDimensions, trivialSubscriptType, subscriptType, unsubscriptType
, applyDirection , applyDirection
, recordFields, recordAttr, protocolItems , recordFields, recordAttr, protocolItems, dirAttr
, leastGeneralSharedTypeRain , leastGeneralSharedTypeRain
@ -133,6 +133,9 @@ recordAttr m (A.Record rec)
_ -> dieP m "not record type" _ -> dieP m "not record type"
recordAttr m _ = dieP m "not record type" recordAttr m _ = dieP m "not record type"
dirAttr :: A.Direction -> A.ChanAttributes -> A.ShareMode
dirAttr A.DirInput = A.caReadingShared
dirAttr A.DirOutput = A.caWritingShared
-- | Get the type of a record field. -- | Get the type of a record field.
typeOfRecordField :: (CSMR m, Die m) => Meta -> A.Type -> A.Name -> m A.Type typeOfRecordField :: (CSMR m, Die m) => Meta -> A.Type -> A.Name -> m A.Type
@ -228,14 +231,14 @@ typeOfVariable (A.DirectedVariable m dir v)
if dir == dir' if dir == dir'
then return t then return t
else dieP m $ "Attempted to reverse direction of a channel-end" else dieP m $ "Attempted to reverse direction of a channel-end"
A.Chan attr innerT -> return $ A.ChanEnd dir attr innerT A.Chan attr innerT -> return $ A.ChanEnd dir (dirAttr dir attr) innerT
A.Array ds (A.Chan attr innerT) A.Array ds (A.Chan attr innerT)
-> return $ A.Array ds (A.ChanEnd dir attr innerT) -> return $ A.Array ds (A.ChanEnd dir (dirAttr dir attr) innerT)
A.Array _ (A.ChanEnd dir' _ _) -> A.Array _ (A.ChanEnd dir' _ _) ->
if dir == dir' if dir == dir'
then return t then return t
else dieP m $ "Attempted to reverse direction of a channel-end" else dieP m $ "Attempted to reverse direction of a channel-end"
A.Infer -> return $ A.ChanEnd dir (A.ChanAttributes A.Unshared A.Unshared) A.Infer A.Infer -> return $ A.ChanEnd dir A.Unshared A.Infer
_ -> diePC m $ formatCode "Direction specified on non-channel variable of type: %" t _ -> diePC m $ formatCode "Direction specified on non-channel variable of type: %" t
-- | Get the abbreviation mode of a variable. -- | Get the abbreviation mode of a variable.
@ -415,7 +418,7 @@ applyDirection :: Die m => Meta -> A.Direction -> A.Type -> m A.Type
applyDirection m dir (A.Array ds t) applyDirection m dir (A.Array ds t)
= applyDirection m dir t >>* A.Array ds = applyDirection m dir t >>* A.Array ds
applyDirection m dir (A.Chan ca t) applyDirection m dir (A.Chan ca t)
= return $ A.ChanEnd dir ca t = return $ A.ChanEnd dir (dirAttr dir ca) t
applyDirection m _ t applyDirection m _ t
= dieP m "Direction specified on non-channel type" = dieP m "Direction specified on non-channel type"

2
data/AST.hs
View File

@ -133,7 +133,7 @@ data Type =
-- | A channel of the specified type. -- | A channel of the specified type.
| Chan ChanAttributes Type | Chan ChanAttributes Type
-- | A channel end of the specified type. -- | A channel end of the specified type.
| ChanEnd Direction ChanAttributes Type | ChanEnd Direction ShareMode Type
-- | A counted input or output. -- | A counted input or output.
-- The first type is that of the count; the second is that of the array. -- The first type is that of the count; the second is that of the array.
-- (For example, @INT::[]BYTE@ would be @A.Counted A.Int (A.Array ...)@). -- (For example, @INT::[]BYTE@ would be @A.Counted A.Int (A.Array ...)@).

17
frontends/OccamTypes.hs
View File

@ -428,14 +428,13 @@ 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.ChanEnd dir (A.ChanAttributes ws rs) innerT -> A.ChanEnd dir sh innerT ->
do -- Check the direction is appropriate do -- Check the direction is appropriate
when (wantDir /= dir) $ dieP m $ "Channel directions do not match" when (wantDir /= dir) $ 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 sh of
(A.Unshared, _, A.DirOutput) -> ok A.Unshared -> ok
(_, A.Unshared, A.DirInput) -> ok A.Shared -> 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 " ++ exp ++ "; found %") t _ -> diePC m $ formatCode ("Expected channel " ++ exp ++ "; found %") t
@ -851,7 +850,7 @@ inferTypes = occamOnlyPass "Infer types"
do dirs <- ask >>= (lift . findDir n) do dirs <- ask >>= (lift . findDir n)
case nub dirs of case nub dirs of
[dir] -> [dir] ->
do let tEnd = A.ChanEnd dir attr innerT do let tEnd = A.ChanEnd dir (dirAttr dir attr) innerT
return (tEnd, A.DirectedVariable m dir v') return (tEnd, A.DirectedVariable m dir v')
_ -> return (vt, v') -- no direction, or two _ -> return (vt, v') -- no direction, or two
(A.Infer, _) -> return (vt, v') (A.Infer, _) -> return (vt, v')
@ -870,7 +869,7 @@ inferTypes = occamOnlyPass "Infer types"
do dirs <- ask >>= (lift . findDir n) do dirs <- ask >>= (lift . findDir n)
case nub dirs of case nub dirs of
[dir] -> [dir] ->
do let tEnd = A.ChanEnd dir attr innerT do let tEnd = A.ChanEnd dir (dirAttr dir attr) innerT
return (tEnd, A.DirectedVariable m dir v') return (tEnd, A.DirectedVariable m dir v')
_ -> return (t', v') -- no direction, or two _ -> return (t', v') -- no direction, or two
_ -> return (t', v') _ -> return (t', v')
@ -904,7 +903,7 @@ inferTypes = occamOnlyPass "Infer types"
A.Array ds (A.Chan attr innerT) -> do A.Array ds (A.Chan attr innerT) -> do
dirs <- ask >>= (lift . findDir n) dirs <- ask >>= (lift . findDir n)
case nub dirs of case nub dirs of
[dir] -> return (A.Array ds $ A.ChanEnd dir attr innerT [dir] -> return (A.Array ds $ A.ChanEnd dir (dirAttr dir attr) innerT
,A.DirectedVariable m dir) ,A.DirectedVariable m dir)
_ -> return (t'', id) _ -> return (t'', id)
_ -> return (t'', id) _ -> return (t'', id)
@ -931,7 +930,7 @@ inferTypes = occamOnlyPass "Infer types"
do dirs <- findDir n body do dirs <- findDir n body
case nub dirs of case nub dirs of
[dir] -> [dir] ->
do let t' = A.ChanEnd dir attr innerT do let t' = A.ChanEnd dir (dirAttr dir attr) innerT
f' = A.Formal am t' n f' = A.Formal am t' n
modifyName n (\nd -> nd {A.ndSpecType = modifyName n (\nd -> nd {A.ndSpecType =
A.Declaration m t'}) A.Declaration m t'})

2
frontends/ParseOccam.hs
View File

@ -1182,7 +1182,7 @@ definition
dir <- direction dir <- direction
sColon sColon
eol eol
return (n, A.ChanEnd dir (A.ChanAttributes A.Unshared A.Unshared) t) return (n, A.ChanEnd dir A.Unshared t)
retypesAbbrev :: OccParser NameSpec retypesAbbrev :: OccParser NameSpec
retypesAbbrev retypesAbbrev

4
frontends/ParseRain.hs
View File

@ -168,8 +168,8 @@ dataType
<|> do {reserved "sint64" ; return A.Int64} <|> do {reserved "sint64" ; return A.Int64}
<|> do {reserved "time" ; return A.Time} <|> do {reserved "time" ; return A.Time}
<|> do {sChannel ; inner <- dataType ; return $ A.Chan (A.ChanAttributes {A.caWritingShared = A.Unshared, A.caReadingShared = A.Unshared}) inner} <|> do {sChannel ; inner <- dataType ; return $ A.Chan (A.ChanAttributes {A.caWritingShared = A.Unshared, A.caReadingShared = A.Unshared}) inner}
<|> do {sIn ; inner <- dataType ; return $ A.ChanEnd A.DirInput (A.ChanAttributes {A.caWritingShared = A.Unshared, A.caReadingShared = A.Unshared}) inner} <|> do {sIn ; inner <- dataType ; return $ A.ChanEnd A.DirInput A.Unshared inner}
<|> do {sOut ; inner <- dataType ; return $ A.ChanEnd A.DirOutput (A.ChanAttributes {A.caWritingShared = A.Unshared, A.caReadingShared = A.Unshared}) inner} <|> do {sOut ; inner <- dataType ; return $ A.ChanEnd A.DirOutput A.Unshared inner}
<|> do {sLeftQ ; inner <- dataType ; sRightQ ; return $ A.List inner} <|> do {sLeftQ ; inner <- dataType ; sRightQ ; return $ A.List inner}
<|> do {(m,n) <- identifier ; return $ A.UserDataType A.Name {A.nameMeta = m, A.nameName = n}} <|> do {(m,n) <- identifier ; return $ A.UserDataType A.Name {A.nameMeta = m, A.nameName = n}}
<?> "data type" <?> "data type"

6
frontends/RainTypes.hs
View File

@ -282,8 +282,7 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput
where where
checkInput :: A.Variable -> A.Variable -> Meta -> a -> RainTypeM () checkInput :: A.Variable -> A.Variable -> Meta -> a -> RainTypeM ()
checkInput chanVar destVar m p checkInput chanVar destVar m p
= astTypeOf destVar >>= markUnify chanVar . A.ChanEnd A.DirInput (A.ChanAttributes = astTypeOf destVar >>= markUnify chanVar . A.ChanEnd A.DirInput A.Unshared
A.Unshared A.Unshared)
checkWait :: RainTypeCheck A.InputMode checkWait :: RainTypeCheck A.InputMode
checkWait (A.InputTimerFor m exp) = markUnify A.Time exp checkWait (A.InputTimerFor m exp) = markUnify A.Time exp
@ -298,8 +297,7 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput
checkInputOutput (A.Input _ _ im@(A.InputTimerAfter {})) = checkWait im checkInputOutput (A.Input _ _ im@(A.InputTimerAfter {})) = checkWait im
checkInputOutput (A.Input _ _ im@(A.InputTimerRead {})) = checkWait im checkInputOutput (A.Input _ _ im@(A.InputTimerRead {})) = checkWait im
checkInputOutput p@(A.Output m chanVar [A.OutExpression m' srcExp]) checkInputOutput p@(A.Output m chanVar [A.OutExpression m' srcExp])
= astTypeOf srcExp >>= markUnify chanVar . A.ChanEnd A.DirOutput (A.ChanAttributes = astTypeOf srcExp >>= markUnify chanVar . A.ChanEnd A.DirOutput A.Unshared
A.Unshared A.Unshared)
checkInputOutput _ = return () checkInputOutput _ = return ()
checkAltInput :: RainTypeCheck A.Alternative checkAltInput :: RainTypeCheck A.Alternative

2
transformations/SimplifyExprs.hs
View File

@ -460,7 +460,7 @@ pullUp pullUpArraysInsideRecords = pass "Pull up definitions"
n) v) innerV (replicate i $ makeConstant m 0) n) v) innerV (replicate i $ makeConstant m 0)
| (d, i) <- zip ds [0..]] | (d, i) <- zip ds [0..]]
spec@(A.Specification _ n _) <- makeNonceIs "dir_array" m spec@(A.Specification _ n _) <- makeNonceIs "dir_array" m
(A.Array ds' $ A.ChanEnd dir attr innerT) A.Abbrev v (A.Array ds' $ A.ChanEnd dir (dirAttr dir attr) innerT) A.Abbrev v
addPulled $ (m, Left spec) addPulled $ (m, Left spec)
return $ A.Variable m n return $ A.Variable m n
_ -> descend v _ -> descend v