From bdda623d7e371e937ab3d3682d5262b848cc4d2b Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 26 Jan 2008 20:51:11 +0000 Subject: [PATCH] Added types to all the cases where the monomorhpism restriction applied --- backends/GenerateCTest.hs | 4 ++++ common/Errors.hs | 1 + common/FlowGraphTest.hs | 1 + frontends/ParseOccam.hs | 5 ++++- frontends/StructureOccam.hs | 2 ++ transformations/ArrayUsageCheck.hs | 3 +-- transformations/ArrayUsageCheckTest.hs | 10 +++++++++- transformations/Omega.hs | 1 + transformations/PassTest.hs | 2 ++ transformations/RainUsageCheckTest.hs | 1 + transformations/SimplifyComms.hs | 1 + transformations/SimplifyExprs.hs | 1 + transformations/SimplifyProcs.hs | 1 + transformations/SimplifyTypes.hs | 1 + 14 files changed, 30 insertions(+), 4 deletions(-) diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index 2709ed2..6530c3b 100644 --- a/backends/GenerateCTest.hs +++ b/backends/GenerateCTest.hs @@ -337,6 +337,7 @@ testArraySubscript = TestList ] where + stateTrans :: CSM m => m () stateTrans = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [A.Dimension 7,A.Dimension 8,A.Dimension 8] A.Int) m = "\"" ++ show emptyMeta ++ "\"" @@ -398,7 +399,9 @@ testOverArray = TestList $ map testOverArray' "for\\(int ([[:alnum:]_]+)=0;\\2 m () state1 = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [A.Dimension 7] A.Int) + state3 :: CSM m => m () state3 = defineName (simpleName "foo") $ simpleDefDecl "foo" (A.Array [A.Dimension 7, A.Dimension 8, A.Dimension 9] A.Int) testReplicator :: Test @@ -1046,6 +1049,7 @@ testOutput = TestList chan = simpleName "c" chanOut = simpleName "cOut" + state :: CSM m => m () state = do defineName chan $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) $ A.UserProtocol foo) defineName chanOut $ simpleDefDecl "cOut" (A.Chan A.DirOutput (A.ChanAttributes False False) $ A.UserProtocol foo) overOutput ops = ops {genOutput = override2 caret} diff --git a/common/Errors.hs b/common/Errors.hs index 4804110..3be3195 100644 --- a/common/Errors.hs +++ b/common/Errors.hs @@ -61,6 +61,7 @@ dieIO (Just m@(Meta (Just fn) line column),s) = liftIO $ putStrLn "" printError $ (show m) ++ " " ++ s where + contextLines :: Int contextLines = 5 -- start is unit-based, so we need to convert to zero-based getLines :: String -> Int -> Int -> [String] diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index d4fe595..849e0d2 100644 --- a/common/FlowGraphTest.hs +++ b/common/FlowGraphTest.hs @@ -511,6 +511,7 @@ genProcess n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n genGraph :: A.Structured -> FlowGraph Identity () genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) id $ runIdentity $ buildFlowGraph funcs s where + empty :: a -> Identity () empty = const (return ()) funcs = GLF empty empty empty empty empty empty diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 6be7d2a..6976459 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -370,6 +370,7 @@ matchType et rt else bad _ -> if rt == et then return () else bad where + bad :: OccParser () bad = die $ "type mismatch (got " ++ showOccam rt ++ "; expected " ++ showOccam et ++ ")" -- | Check that two lists of types match (for example, for parallel assignment). @@ -1462,7 +1463,9 @@ formalArgSet <|> formalItem (aa channelSpecifier) newChannelName <|> formalItem (aa timerSpecifier) newTimerName <|> formalItem (aa portSpecifier) newPortName - where aa = liftM (\t -> (A.Abbrev, t)) + where + aa :: OccParser A.Type -> OccParser (A.AbbrevMode, A.Type) + aa = liftM (\t -> (A.Abbrev, t)) formalVariableType :: OccParser (A.AbbrevMode, A.Type) formalVariableType diff --git a/frontends/StructureOccam.hs b/frontends/StructureOccam.hs index 868713b..a4b449b 100644 --- a/frontends/StructureOccam.hs +++ b/frontends/StructureOccam.hs @@ -64,6 +64,7 @@ structureOccam ts = analyse 1 firstLine ts (emptyMeta, EndOfLine) _ -> False -- A new line -- look to see what's going on with the indentation. + newLine :: [Token] -> PassM [Token] newLine rest | col == prevCol + 2 = withEOL $ (m, Indent) : rest -- FIXME: If col > prevCol, then look to see if there's a VALOF @@ -76,6 +77,7 @@ structureOccam ts = analyse 1 firstLine ts (emptyMeta, EndOfLine) | otherwise = bad where steps = (prevCol - col) `div` 2 + bad :: PassM [Token] bad = dieP m "Invalid indentation" -- This is actually the position at which the new line starts -- rather than the end of the previous line. diff --git a/transformations/ArrayUsageCheck.hs b/transformations/ArrayUsageCheck.hs index 7a8e1ef..75007de 100644 --- a/transformations/ArrayUsageCheck.hs +++ b/transformations/ArrayUsageCheck.hs @@ -531,7 +531,7 @@ getIneqs (low, high) = concatMap getLH getLH :: EqualityConstraintEquation -> [InequalityConstraintEquation] getLH eq = [eq `addEq` (amap negate low),high `addEq` amap negate eq] - + addEq :: EqualityConstraintEquation -> EqualityConstraintEquation -> EqualityConstraintEquation addEq = arrayZipWith' 0 (+) -- | Given an expression, forms equations (and accompanying additional equation-sets) and returns it @@ -662,4 +662,3 @@ squareEquations (eqs,ineqs) = uncurry transformPair (mkPair $ map $ makeSize (0, where highest = maximum $ 0 : (concatMap indices $ eqs ++ ineqs) - diff --git a/transformations/ArrayUsageCheckTest.hs b/transformations/ArrayUsageCheckTest.hs index a30ace2..1039ccc 100644 --- a/transformations/ArrayUsageCheckTest.hs +++ b/transformations/ArrayUsageCheckTest.hs @@ -187,7 +187,8 @@ makeConsistent eqs ineqs = (map ensure eqs', map ensure ineqs') where eqs' = map (\(Eq e) -> e) eqs ineqs' = map (\(Ineq e) -> e) ineqs - + + ensure :: [(CoeffIndex, Integer)] -> EqualityConstraintEquation ensure = accumArray (+) 0 (0, largestIndex) largestIndex = maximum $ map (maximum . map fst) $ [[(0,0)]] ++ eqs' ++ ineqs' @@ -374,9 +375,13 @@ testMakeEquations = TestList joinMapping :: [VarMap] -> ([HandyEq],[HandyIneq]) -> [(VarMap,[HandyEq],[HandyIneq])] joinMapping vms (eq,ineq) = map (\vm -> (vm,eq,ineq)) vms + i_mapping :: VarMap i_mapping = Map.singleton (Scale 1 $ (variable "i",0)) 1 + ij_mapping :: VarMap ij_mapping = Map.fromList [(Scale 1 $ (variable "i",0),1),(Scale 1 $ (variable "j",0),2)] + i_mod_mapping :: Integer -> VarMap i_mod_mapping n = Map.fromList [(Scale 1 $ (variable "i",0),1),(Modulo (Set.singleton $ Scale 1 $ (variable "i",0)) (Set.singleton $ Const n),2)] + i_mod_j_mapping :: VarMap i_mod_j_mapping = Map.fromList [(Scale 1 $ (variable "i",0),1),(Scale 1 $ (variable "j",0),2), (Modulo (Set.singleton $ Scale 1 $ (variable "i",0)) (Set.singleton $ Scale 1 $ (variable "j",0)),3)] _3i_2j_mod_mapping n = Map.fromList [(Scale 1 $ (variable "i",0),1),(Scale 1 $ (variable "j",0),2), @@ -387,7 +392,9 @@ testMakeEquations = TestList ,(Modulo (Set.fromList [Scale 1 $ (variable "i",0), Const 1]) (Set.singleton $ Const n),3) ] + rep_i_mapping :: VarMap rep_i_mapping = Map.fromList [((Scale 1 (variable "i",0)),1), ((Scale 1 (variable "i",1)),2)] + rep_i_mapping' :: VarMap rep_i_mapping' = Map.fromList [((Scale 1 (variable "i",0)),2), ((Scale 1 (variable "i",1)),1)] both_rep_i = joinMapping [rep_i_mapping, rep_i_mapping'] @@ -507,6 +514,7 @@ testIndexes = TestList isMod var@[(ind,1)] alpha divisor = ([alpha_minus_div_sigma === var], leq [con 0, alpha_minus_div_sigma, con $ divisor - 1]) where alpha_minus_div_sigma = alpha ++ (negate divisor) ** sigma + sigma :: [(Int, Integer)] sigma = [(ind+1,1)] -- | Adds both k and m to the equation! diff --git a/transformations/Omega.hs b/transformations/Omega.hs index d432282..8353bc6 100644 --- a/transformations/Omega.hs +++ b/transformations/Omega.hs @@ -352,6 +352,7 @@ pruneIneq ineq = do let (opps,others) = splitEither $ groupOpposites $ map prune numVariables :: InequalityProblem -> Int numVariables ineq = length (nub $ concatMap findVars ineq) where + findVars :: InequalityConstraintEquation -> [CoeffIndex] findVars = map fst . filter ((/= 0) . snd) . tail . assocs -- | Adds a constant value to an equation: diff --git a/transformations/PassTest.hs b/transformations/PassTest.hs index 77a25e2..6edce8d 100644 --- a/transformations/PassTest.hs +++ b/transformations/PassTest.hs @@ -451,9 +451,11 @@ testInputCase = TestList a0 = simpleName "a0" b2 = simpleName "b2" c1 = simpleName "c1" + defineMyProtocol :: CSM m => m () defineMyProtocol = defineName (simpleName "prot") $ A.NameDef emptyMeta "prot" "prot" A.ProtocolName (A.ProtocolCase emptyMeta [(a0,[]),(b2,[A.Int,A.Int]),(c1,[A.Int])]) A.Original A.Unplaced + defineC :: CSM m => m () defineC = defineName (simpleName "c") $ simpleDefDecl "c" (A.Chan A.DirUnknown (A.ChanAttributes False False) (A.UserProtocol $ simpleName "prot")) specInt s = A.Spec emptyMeta (A.Specification emptyMeta (simpleName s) $ A.Declaration emptyMeta A.Int Nothing) diff --git a/transformations/RainUsageCheckTest.hs b/transformations/RainUsageCheckTest.hs index c220fce..ffba80b 100644 --- a/transformations/RainUsageCheckTest.hs +++ b/transformations/RainUsageCheckTest.hs @@ -66,6 +66,7 @@ a_eq_not_b = A.Assign m [vA] $ A.ExpressionList m [A.Monadic m A.MonadicNot (A.E testGetVarProc :: Test testGetVarProc = TestList (map doTest tests) where + tests :: [(Int,[Var],[Var],[Var],[Var],A.Process)] tests = [ --TODO test channel reads and writes (incl. reads in alts) diff --git a/transformations/SimplifyComms.hs b/transformations/SimplifyComms.hs index 195ac44..f320fc6 100644 --- a/transformations/SimplifyComms.hs +++ b/transformations/SimplifyComms.hs @@ -33,6 +33,7 @@ import Utils simplifyComms :: Pass simplifyComms = runPasses passes where + passes :: [(String, Pass)] passes = [ ("Define temporary variables for outputting expressions", outExprs) ,("Transform ? CASE statements/guards into plain CASE", transformInputCase) diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs index 82883b9..c00d456 100644 --- a/transformations/SimplifyExprs.hs +++ b/transformations/SimplifyExprs.hs @@ -33,6 +33,7 @@ import Types simplifyExprs :: Pass simplifyExprs = runPasses passes where + passes :: [(String, Pass)] passes = [ ("Convert FUNCTIONs to PROCs", functionsToProcs) , ("Convert AFTER to MINUS", removeAfter) diff --git a/transformations/SimplifyProcs.hs b/transformations/SimplifyProcs.hs index 4b0a3c2..fb236da 100644 --- a/transformations/SimplifyProcs.hs +++ b/transformations/SimplifyProcs.hs @@ -31,6 +31,7 @@ import Pass simplifyProcs :: Pass simplifyProcs = runPasses passes where + passes :: [(String, Pass)] passes = [ ("Wrap PAR subprocesses in PROCs", parsToProcs) , ("Remove parallel assignment", removeParAssign) diff --git a/transformations/SimplifyTypes.hs b/transformations/SimplifyTypes.hs index 548f2fe..0f1da96 100644 --- a/transformations/SimplifyTypes.hs +++ b/transformations/SimplifyTypes.hs @@ -29,6 +29,7 @@ import Types simplifyTypes :: Pass simplifyTypes = runPasses passes where + passes :: [(String,Pass)] passes = [ ("Resolve types in AST", resolveNamedTypes) , ("Resolve types in state", rntState)