From 229f2197af0c48f4538553dd82be7fe1a8ffcc09 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Thu, 9 Apr 2009 11:13:37 +0000 Subject: [PATCH] Turned findMeta into a member of a FindMeta type-class --- backends/GenerateC.hs | 10 +++-- checks/CheckFramework.hs | 4 +- checks/UsageCheckUtils.hs | 2 +- common/Types.hs | 10 ++--- data/CompState.hs | 69 +++++++++++++++++++++++++++++++- data/Metadata.hs | 7 ---- flow/FlowGraph.hs | 1 + frontends/OccamTypes.hs | 4 +- frontends/RainTypes.hs | 35 +++++++++------- frontends/TypeUnification.hs | 10 ++++- frontends/UnifyType.hs | 1 + pass/Properties.hs | 21 ++++++---- transformations/SimplifyComms.hs | 2 +- 13 files changed, 130 insertions(+), 46 deletions(-) diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index fe878e6..979e2d7 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -1504,9 +1504,13 @@ prefixComma cs = sequence_ [genComma >> c | c <- cs] cgenActuals :: [A.Formal] -> [A.Actual] -> CGen () cgenActuals fs as = do when (length fs /= length as) $ - dieP (findMeta (fs, as)) $ "Mismatch in numbers of parameters in backend: " + dieP m $ "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] + where + m | null fs && null as = emptyMeta + | null fs = findMeta $ head as + | otherwise = findMeta $ head fs cgenActual :: A.Formal -> A.Actual -> CGen () cgenActual f a = seqComma $ realActuals f a id @@ -1616,7 +1620,7 @@ cgenProcess p = case p of A.Assign m vs es -> call genAssign m vs es A.Input m c im -> call genInput c im A.Output m c ois -> - do Left ts <- protocolItems c + do Left ts <- protocolItems m c call genOutput c $ zip ts ois A.OutputCase m c t ois -> call genOutputCase c t ois A.Skip m -> tell ["/* skip */\n"] @@ -1767,7 +1771,7 @@ cgenOutputCase c tag ois tell ["_"] genName proto tell [");"] - Right ps <- protocolItems c + Right ps <- protocolItems (findMeta c) c let ts = fromMaybe (error "genOutputCase unknown tag") $ lookup tag ps call genOutput c $ zip ts ois diff --git a/checks/CheckFramework.hs b/checks/CheckFramework.hs index b08750e..3c546e6 100644 --- a/checks/CheckFramework.hs +++ b/checks/CheckFramework.hs @@ -408,7 +408,7 @@ applyAccum (accEmpty, accOneF, accJoinF) typeKeysGiven = applyAccum' applyAccum' :: (forall a. Data a => TransFuncAcc acc a) -> (forall b. Data b => (b, Route b A.AST) -> StateT acc (RestartT CheckOptM) b) applyAccum' f (x, route) - = do when (findMeta x /= emptyMeta) $ lift . lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta x} + = do when (findMeta_Data x /= emptyMeta) $ lift . lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta_Data x} (x', acc) <- lift $ flip runStateT accEmpty (gmapMForRoute typeSet (extF wrap) x) r <- f' (x', route, acc) modify (`accJoinF` acc) @@ -427,7 +427,7 @@ applyAccum (accEmpty, accOneF, accJoinF) typeKeysGiven = applyAccum' applyTopDown :: TypeSet -> (forall a. Data a => TransFunc a) -> (forall b. Data b => (b, Route b A.AST) -> RestartT CheckOptM b) applyTopDown typeSet f (x, route) - = do when (findMeta x /= emptyMeta) $ lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta x} + = do when (findMeta_Data x /= emptyMeta) $ lift . CheckOptM $ modify $ \d -> d {lastValidMeta = findMeta_Data x} z <- f' (x, route) gmapMForRoute typeSet (\(y, route') -> applyTopDown typeSet f (y, route @-> route')) z where diff --git a/checks/UsageCheckUtils.hs b/checks/UsageCheckUtils.hs index e78452c..41c1e9b 100644 --- a/checks/UsageCheckUtils.hs +++ b/checks/UsageCheckUtils.hs @@ -39,7 +39,7 @@ import Types import Utils newtype Var = Var A.Variable - deriving (ASTTypeable, Data, Ord, Show, ShowOccam, ShowRain, Typeable) + deriving (ASTTypeable, Data, FindMeta, Ord, Show, ShowOccam, ShowRain, Typeable) instance Eq Var where a == b = EQ == compare a b diff --git a/common/Types.hs b/common/Types.hs index 043dfae..e96674e 100644 --- a/common/Types.hs +++ b/common/Types.hs @@ -35,7 +35,7 @@ module Types , leastGeneralSharedTypeRain - , ASTTypeable(..) + , ASTTypeable(..), findMeta ) where import Control.Monad.State @@ -337,13 +337,13 @@ returnTypesOfIntrinsic m s -- | Get the items in a channel's protocol (for typechecking). -- Returns Left if it's a simple protocol, Right if it's tagged. -protocolItems :: (ASTTypeable a, Data a, CSMR m, Die m) => a -> m (Either [A.Type] [(A.Name, [A.Type])]) -protocolItems v +protocolItems :: (ASTTypeable a, Data a, CSMR m, Die m) => Meta -> a -> m (Either [A.Type] [(A.Name, [A.Type])]) +protocolItems m v = do chanT <- astTypeOf v t <- case chanT of A.Chan _ t -> return t A.ChanEnd _ _ t -> return t - _ -> dieP (findMeta v) $ "Expected a channel variable, but this is of type: " ++ show chanT + _ -> dieP m $ "Expected a channel variable, but this is of type: " ++ show chanT case t of A.UserProtocol proto -> do st <- specTypeOfName proto @@ -481,8 +481,6 @@ isSafeConversion src dest = (src' == dest') || ((src' == A.Bool || isIntegerType ] - - -- | Works out the least-general type that all given types can be upcast to. Does not work with A.Int (as this function is expected only to be used by Rain) -- As you would expect from the name, this function specifically follows the conversion rules for Rain. leastGeneralSharedTypeRain :: [A.Type] -> Maybe A.Type diff --git a/data/CompState.hs b/data/CompState.hs index 3185dc5..0b63bc7 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -265,7 +265,7 @@ modifyName n f -- | Find the definition of a name. lookupName :: (CSMR m, Die m) => A.Name -> m A.NameDef -lookupName n = lookupNameOrError n (dieP (findMeta n) $ "cannot find name " ++ A.nameName n) +lookupName n = lookupNameOrError n (dieP (A.nameMeta n) $ "cannot find name " ++ A.nameName n) nameSource :: (CSMR m, Die m) => A.Name -> m A.NameSource nameSource n = lookupName n >>* A.ndNameSource @@ -483,3 +483,70 @@ searchFile m filename case r of Just h -> return (h, fn) Nothing -> openOneOf all fns + +class FindMeta a where + findMeta :: a -> Meta + +instance FindMeta Meta where + findMeta = id + +instance FindMeta A.Name where + findMeta = A.nameMeta + +-- Should stop being lazy, and put these as pattern matches: +findMeta_Data :: Data a => a -> Meta +findMeta_Data = head . listify (const True) + +instance FindMeta A.Expression where + findMeta = findMeta_Data + +instance FindMeta A.LiteralRepr where + findMeta = findMeta_Data + +instance FindMeta A.Subscript where + findMeta = findMeta_Data + +instance FindMeta A.Process where + findMeta = findMeta_Data + +instance FindMeta A.Variable where + findMeta (A.Variable m _) = m + findMeta (A.SubscriptedVariable m _ _) = m + findMeta (A.DirectedVariable m _ _) = m + findMeta (A.DerefVariable m _) = m + findMeta (A.VariableSizes m _) = m + +instance FindMeta A.SpecType where + findMeta = findMeta_Data + +instance FindMeta A.ExpressionList where + findMeta = findMeta_Data + +instance FindMeta A.Alternative where + findMeta = findMeta_Data + +instance FindMeta A.InputMode where + findMeta = findMeta_Data + +instance Data a => FindMeta (A.Structured a) where + findMeta = findMeta_Data + +instance FindMeta A.Actual where + findMeta (A.ActualVariable v) = findMeta v + findMeta (A.ActualExpression e) = findMeta e + findMeta (A.ActualClaim v) = findMeta v + findMeta (A.ActualChannelArray []) = emptyMeta + findMeta (A.ActualChannelArray (v:_)) = findMeta v + +instance FindMeta A.Replicator where + findMeta (A.For m _ _ _) = m + findMeta (A.ForEach m _) = m + +instance FindMeta A.Specification where + findMeta (A.Specification m _ _) = m + +instance FindMeta A.Formal where + findMeta (A.Formal _ _ n) = findMeta n + +instance FindMeta A.NameDef where + findMeta = A.ndMeta diff --git a/data/Metadata.hs b/data/Metadata.hs index 76a46fa..9a859e4 100644 --- a/data/Metadata.hs +++ b/data/Metadata.hs @@ -84,10 +84,3 @@ unpackMeta s metaRE = mkRegex "^(.*)//pos:([0-9]*):([0-9]*):(.*)//(.*)$" getInt s = case readDec s of [(v, "")] -> v --- | Find the first Meta value in some part of the AST. --- Return 'emptyMeta' if it couldn't find one. -findMeta :: Data t => t -> Meta -findMeta e - = case listify (const True :: Meta -> Bool) e of - (m:_) -> m - [] -> emptyMeta diff --git a/flow/FlowGraph.hs b/flow/FlowGraph.hs index c4994af..8e50150 100644 --- a/flow/FlowGraph.hs +++ b/flow/FlowGraph.hs @@ -51,6 +51,7 @@ import Data.Graph.Inductive hiding (run) import Data.Maybe import qualified AST as A +import CompState import GenericUtils import Metadata import FlowUtils diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index bf950e0..ae47f97 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -812,7 +812,7 @@ inferTypes = occamOnlyPass "Infer types" doInputMode :: A.Variable -> Transform A.InputMode doInputMode v (A.InputSimple m iis) - = do ts <- protocolItems v >>* either id (const []) + = do ts <- protocolItems m v >>* either id (const []) iis' <- sequence [inTypeContext (Just t) $ recurse ii | (t, ii) <- zip ts iis] return $ A.InputSimple m iis' @@ -825,7 +825,7 @@ inferTypes = occamOnlyPass "Infer types" doVariant (A.Variant m n iis p) = do ctx <- getTypeContext ets <- case ctx of - Just x -> protocolItems x + Just x -> protocolItems m x Nothing -> dieP m "Could not deduce protocol" case ets of Left {} -> dieP m "Simple protocol expected during input CASE" diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs index f83db98..c795ff9 100644 --- a/frontends/RainTypes.hs +++ b/frontends/RainTypes.hs @@ -39,6 +39,13 @@ import TypeUnification import UnifyType import Utils +-- This is a bit of a hack for this file: +data M = M Meta A.Type deriving (Typeable, Data) +instance ASTTypeable M where + astTypeOf (M m t) = return t +instance FindMeta M where + findMeta (M m t) = m + data RainTypeState = RainTypeState { csUnifyLookup :: Map.Map UnifyIndex UnifyValue, csUnifyPairs :: [(UnifyValue, UnifyValue)] @@ -102,7 +109,7 @@ typeToTypeExp _ (A.UnknownNumLitType m id n) return v typeToTypeExp m t = return $ OperType m (show t) (const t) [] -markUnify :: (ASTTypeable a, ASTTypeable b, Data a, Data b) => a -> b -> RainTypeM () +markUnify :: (ASTTypeable a, ASTTypeable b, FindMeta a, FindMeta b, Data a, Data b) => a -> b -> RainTypeM () markUnify x y = do tx <- astTypeOf x ty <- astTypeOf y @@ -167,8 +174,8 @@ markReplicators :: RainTypePassType markReplicators = checkDepthM mark where mark :: RainTypeCheck A.Specification - mark (A.Specification _ n (A.Rep _ (A.ForEach _m e))) - = astTypeOf n >>= \t -> markUnify (A.List t) e + mark (A.Specification m n (A.Rep _ (A.ForEach _m e))) + = astTypeOf n >>= \t -> markUnify (M m $ A.List t) e mark _ = return () -- | Folds all constants. @@ -222,8 +229,8 @@ markExpressionTypes = checkDepthM checkExpression checkExpression :: RainTypeCheck A.Expression -- checkExpression (A.Dyadic _ _ lhs rhs) -- = markUnify lhs rhs - checkExpression (A.Literal _ t (A.ArrayListLiteral _ es)) - = checkListElems (markUnify t) es + checkExpression (A.Literal m t (A.ArrayListLiteral m' es)) + = checkListElems (markUnify (M m t) . M m') es checkExpression _ = return () checkListElems :: RainTypeCheck A.Type -> RainTypeCheck (A.Structured A.Expression) @@ -247,7 +254,7 @@ markAssignmentTypes = checkDepthM checkAssignment A.Variable _ n -> do st <- specTypeOfName n case st of - A.Function _ _ [t] _ _ -> markUnify t e + A.Function m _ [t] _ _ -> markUnify (M m t) e _ -> markUnify v e _ -> markUnify v e checkAssignment (A.Assign m _ _) = dieInternal (Just m,"Rain checker found occam-style assignment") @@ -259,12 +266,12 @@ markConditionalTypes = checkDepthM2 checkWhile checkIf where checkWhile :: RainTypeCheck A.Process checkWhile w@(A.While m exp _) - = markUnify exp A.Bool + = markUnify exp (M m A.Bool) checkWhile _ = return () checkIf :: RainTypeCheck A.Choice checkIf c@(A.Choice m exp _) - = markUnify exp A.Bool + = markUnify exp (M m A.Bool) -- | Marks types in poison statements markPoisonTypes :: RainTypePassType @@ -273,7 +280,7 @@ markPoisonTypes = checkDepthM checkPoison checkPoison :: RainTypeCheck A.Process checkPoison (A.InjectPoison m ch) = do u <- lift getUniqueIdentifer - markUnify ch $ A.UnknownVarType (A.TypeRequirements True) $ Right (m, u) + markUnify ch (M m $ A.UnknownVarType (A.TypeRequirements True) $ Right (m, u)) checkPoison _ = return () -- | Checks the types in inputs and outputs, including inputs in alts @@ -282,12 +289,12 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput where checkInput :: A.Variable -> A.Variable -> Meta -> a -> RainTypeM () checkInput chanVar destVar m p - = astTypeOf destVar >>= markUnify chanVar . A.ChanEnd A.DirInput A.Unshared + = astTypeOf destVar >>= markUnify chanVar . M (findMeta destVar) . A.ChanEnd A.DirInput A.Unshared checkWait :: RainTypeCheck A.InputMode - checkWait (A.InputTimerFor m exp) = markUnify A.Time exp - checkWait (A.InputTimerAfter m exp) = markUnify A.Time exp - checkWait (A.InputTimerRead m (A.InVariable _ v)) = markUnify A.Time v + checkWait (A.InputTimerFor m exp) = markUnify (M m A.Time) exp + checkWait (A.InputTimerAfter m exp) = markUnify (M m A.Time) exp + checkWait (A.InputTimerRead m (A.InVariable m' v)) = markUnify (M m A.Time) v checkWait _ = return () checkInputOutput :: RainTypeCheck A.Process @@ -297,7 +304,7 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput checkInputOutput (A.Input _ _ im@(A.InputTimerAfter {})) = checkWait im checkInputOutput (A.Input _ _ im@(A.InputTimerRead {})) = checkWait im checkInputOutput p@(A.Output m chanVar [A.OutExpression m' srcExp]) - = astTypeOf srcExp >>= markUnify chanVar . A.ChanEnd A.DirOutput A.Unshared + = astTypeOf srcExp >>= markUnify chanVar . M m' . A.ChanEnd A.DirOutput A.Unshared checkInputOutput _ = return () checkAltInput :: RainTypeCheck A.Alternative diff --git a/frontends/TypeUnification.hs b/frontends/TypeUnification.hs index 7578d7b..05d3d0c 100644 --- a/frontends/TypeUnification.hs +++ b/frontends/TypeUnification.hs @@ -27,6 +27,7 @@ import Data.Maybe import Data.IORef import qualified AST as A +import CompState import Errors import Metadata import Pass @@ -34,6 +35,13 @@ import ShowCode import UnifyType import Utils +instance Typeable a => FindMeta (TypeExp a) where + findMeta (MutVar m _) = m + findMeta (GenVar m _) = m + findMeta (NumLit m _) = m + findMeta (OperType m _ _ _) = m + + foldCon :: ([A.Type] -> A.Type) -> [Either String A.Type] -> Either String A.Type foldCon con es = case splitEither es of ([],ts) -> Right $ con ts @@ -210,7 +218,7 @@ unifyType te1 te2 where unifyArgs (x:xs) (y:ys) = unifyType x y >> unifyArgs xs ys unifyArgs [] [] = return () - unifyArgs xs ys = dieP (findMeta (xs,ys)) "different lengths" + unifyArgs xs ys = dieP (findMeta $ head (xs ++ ys)) "different lengths" instantiate :: Typeable a => [TypeExp a] -> TypeExp a -> TypeExp a instantiate ts x = case x of diff --git a/frontends/UnifyType.hs b/frontends/UnifyType.hs index 692d697..d777ff0 100644 --- a/frontends/UnifyType.hs +++ b/frontends/UnifyType.hs @@ -33,3 +33,4 @@ data Typeable a => TypeExp a | NumLit Meta (IORef (Either [(Meta, Integer)] A.Type)) | OperType Meta String ([A.Type] -> A.Type) [ TypeExp a ] deriving (Typeable, Data) + diff --git a/pass/Properties.hs b/pass/Properties.hs index fae8534..d05be71 100644 --- a/pass/Properties.hs +++ b/pass/Properties.hs @@ -128,9 +128,14 @@ getDeclaredNames = everything (++) ([] `mkQ` find) find (A.Specification _ n (A.Declaration {})) = [n] find _ = [] -checkNull :: (Data a, Die m) => String -> [a] -> m () +checkNull :: (Data a, FindMeta a, Die m) => String -> [a] -> m () checkNull _ [] = return () -checkNull s xs = dieP (findMeta xs) $ "Property check " ++ show s ++ " failed: " ++ pshow xs +checkNull s xs = dieP (findMeta $ head xs) $ "Property check " ++ show s ++ " failed: " ++ pshow xs + +checkNull' :: (Data a, Die m) => String -> [a] -> m () +checkNull' _ [] = return () +checkNull' s xs = dieP emptyMeta $ "Property check " ++ show s ++ " failed: " ++ pshow xs + isNonceOrUnique :: String -> Bool isNonceOrUnique nm = isJust $ matchRegex (mkRegex ".*_[a-z][0-9]+$") nm @@ -141,7 +146,7 @@ declaredNamesResolved = Property "declaredNamesResolved" $ noInt :: Property noInt = Property "noInt" $ - checkNull "noInt" . listify (== A.Int) + checkNull' "noInt" . listify (== A.Int) declarationTypesRecorded :: Property declarationTypesRecorded = Property "declarationTypesRecorded" $ \t -> @@ -232,7 +237,7 @@ rainParDeclarationsPulledUp = Property "rainParDeclarationsPulledUp" checkTODO inferredTypesRecorded :: Property inferredTypesRecorded = Property "inferredTypesRecorded" $ - checkNull "inferredTypesRecorded" . listify findInfer + checkNull' "inferredTypesRecorded" . listify findInfer where findInfer :: A.Type -> Bool findInfer A.Infer = True @@ -247,11 +252,11 @@ findUDT _ = False typesResolvedInAST :: Property typesResolvedInAST = Property "typesResolvedInAST" $ - checkNull "typesResolvedInAST" . listify findUDT + checkNull' "typesResolvedInAST" . listify findUDT typesResolvedInState :: Property typesResolvedInState = Property "typesResolvedInState" $ - \t -> checkNull "typesResolvedInState" . listify findUDT =<< getCompState + \t -> checkNull' "typesResolvedInState" . listify findUDT =<< getCompState checkAllExprVariable :: Die m => [A.Expression] -> m () checkAllExprVariable = mapM_ check @@ -407,12 +412,12 @@ listsGivenType = Property "listsGivenType" checkTODO initialRemoved :: Property initialRemoved = Property "initialRemoved" $ - checkNull "initialRemoved" . listify (== A.InitialAbbrev) + checkNull' "initialRemoved" . listify (== A.InitialAbbrev) resultRemoved :: Property resultRemoved = Property "resultRemoved" $ - checkNull "resultRemoved" . listify (== A.ResultAbbrev) + checkNull' "resultRemoved" . listify (== A.ResultAbbrev) directionsRemoved :: Property directionsRemoved diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index 8971294..c9c165c 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -158,7 +158,7 @@ transformInputCase = pass "Transform ? CASE statements/guards into plain CASE" doStructuredV chanVar = transformOnly transform where transform m (A.Variant m' n iis p) - = do (Right items) <- protocolItems chanVar + = do (Right items) <- protocolItems m' chanVar let (Just idx) = elemIndex n (fst $ unzip items) return $ A.Only m $ A.Option m' [makeConstant m' idx] $ if length iis == 0