From 6ee21f76c9c1eee004cee12e1b1862b7888b3a1b Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Mon, 2 Jun 2008 20:41:37 +0000 Subject: [PATCH] Initial work on supporting INITIAL and RESULT abbreviations. This fixes the AST, parser and typechecker, and adds a pass to transform Result back into Abbrev, but doesn't transform Initial yet. (It actually works for trivial stuff anyway, but it won't do the right thing for complex types or PROC parameters.) It appears (to me) to make sense to support INITIAL/RESULT reshaping and retyping too, so this does. Refs #42. --- LANGUAGE | 2 +- Makefile.am | 1 + TestMain.hs | 6 +- data/AST.hs | 4 + frontends/OccamTypes.hs | 32 ++++- frontends/OccamTypesTest.hs | 18 ++- frontends/ParseOccam.hs | 126 +++++++++--------- pass/PassList.hs | 4 +- pass/Properties.hs | 13 ++ testcases/automatic/initial-result-1.occ.test | 81 +++++++++++ testcases/automatic/initial-result-2.occ.test | 46 +++++++ transformations/SimplifyAbbrevs.hs | 53 ++++++++ 12 files changed, 310 insertions(+), 76 deletions(-) create mode 100644 testcases/automatic/initial-result-1.occ.test create mode 100644 testcases/automatic/initial-result-2.occ.test create mode 100644 transformations/SimplifyAbbrevs.hs diff --git a/LANGUAGE b/LANGUAGE index 20d6968..693cd60 100644 --- a/LANGUAGE +++ b/LANGUAGE @@ -20,6 +20,6 @@ CHAN for CHAN OF, and PLACE for PLACE AT. PLACE IN WORKSPACE and PLACE IN VECSPACE, both currently ignored. -INITIAL variables. +INITIAL and RESULT abbreviations. Array constructors. diff --git a/Makefile.am b/Makefile.am index 1794f82..b14854d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -152,6 +152,7 @@ tock_SOURCES_hs += pass/PassList.hs tock_SOURCES_hs += pass/Properties.hs tock_SOURCES_hs += pass/Traversal.hs tock_SOURCES_hs += transformations/ImplicitMobility.hs +tock_SOURCES_hs += transformations/SimplifyAbbrevs.hs tock_SOURCES_hs += transformations/SimplifyComms.hs tock_SOURCES_hs += transformations/SimplifyExprs.hs tock_SOURCES_hs += transformations/SimplifyProcs.hs diff --git a/TestMain.hs b/TestMain.hs index 2a6d6f5..9d0fab8 100644 --- a/TestMain.hs +++ b/TestMain.hs @@ -64,7 +64,7 @@ import qualified CommonTest (tests) import qualified FlowGraphTest (qcTests) import qualified GenerateCTest (tests) import qualified OccamPassesTest (tests) -import qualified OccamTypesTest (tests) +import qualified OccamTypesTest (ioTests) import qualified ParseRainTest (tests) import qualified PassTest (tests) import qualified PreprocessOccamTest (tests) @@ -181,7 +181,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options ,return FlowGraphTest.qcTests ,noqc GenerateCTest.tests ,noqc OccamPassesTest.tests - ,noqc OccamTypesTest.tests + ,noqcButIO OccamTypesTest.ioTests ,noqc ParseRainTest.tests ,noqc PassTest.tests ,noqc PreprocessOccamTest.tests @@ -195,4 +195,4 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options noqc t = return (t,[]) noqcButIO :: IO Test -> IO (Test, [LabelledQuickCheckTest]) - noqcButIO t = t >>* \x -> (x,[]) \ No newline at end of file + noqcButIO t = t >>* \x -> (x,[]) diff --git a/data/AST.hs b/data/AST.hs index b0a0fb7..d94e021 100644 --- a/data/AST.hs +++ b/data/AST.hs @@ -456,6 +456,10 @@ data AbbrevMode = | Abbrev -- | An abbreviation by value. | ValAbbrev + -- | An abbreviation by value that can be modified. + | InitialAbbrev + -- | An abbreviation by reference that is initially undefined. + | ResultAbbrev deriving (Show, Eq, Typeable, Data) -- | Anything that introduces a new name. diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index 54d4e35..689fd63 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -311,6 +311,7 @@ checkAbbrev m orig new = case (orig, new) of (_, A.Original) -> bad (A.ValAbbrev, A.ValAbbrev) -> ok + (A.ValAbbrev, A.InitialAbbrev) -> ok (A.ValAbbrev, _) -> bad _ -> ok where @@ -320,7 +321,9 @@ checkAbbrev m orig new showAM :: A.AbbrevMode -> String showAM A.Original = "an original declaration" showAM A.Abbrev = "a reference abbreviation" - showAM A.ValAbbrev = "a value abbreviation" + showAM A.ValAbbrev = "a VAL abbreviation" + showAM A.InitialAbbrev = "an INITIAL abbreviation" + showAM A.ResultAbbrev = "a RESULT abbreviation" -- | Check a list of actuals is the right length for a list of formals. checkActualCount :: Meta -> A.Name -> [A.Formal] -> [a] -> PassM () @@ -1102,13 +1105,13 @@ checkSpecTypes = checkDepthM doSpecType doSpecType (A.Is m am t v) = do tv <- astTypeOf v checkType (findMeta v) t tv - when (am /= A.Abbrev) $ unexpectedAM m + checkRefAM m am amv <- abbrevModeOfVariable v checkAbbrev m amv am doSpecType (A.IsExpr m am t e) = do te <- astTypeOf e checkType (findMeta e) t te - when (am /= A.ValAbbrev) $ unexpectedAM m + checkValAM m am checkAbbrev m A.ValAbbrev am doSpecType (A.IsChannelArray m rawT cs) = do t <- resolveUserType m rawT @@ -1159,12 +1162,31 @@ checkSpecTypes = checkDepthM doSpecType doFunctionBody rs (Left s) = checkStructured (checkExpressionList rs) s -- FIXME: Need to know the name of the function to do this doFunctionBody rs (Right p) = dieP m "Cannot check function process body" - doSpecType (A.Retypes m _ t v) + doSpecType (A.Retypes m am t v) = do fromT <- astTypeOf v checkRetypes m fromT t - doSpecType (A.RetypesExpr m _ t e) + checkRefAM m am + amv <- abbrevModeOfVariable v + checkAbbrev m amv am + doSpecType (A.RetypesExpr m am t e) = do fromT <- astTypeOf e checkRetypes m fromT t + checkValAM m am + checkAbbrev m A.ValAbbrev am + + checkValAM :: Meta -> A.AbbrevMode -> PassM () + checkValAM m am + = case am of + A.ValAbbrev -> ok + A.InitialAbbrev -> ok + _ -> unexpectedAM m + + checkRefAM :: Meta -> A.AbbrevMode -> PassM () + checkRefAM m am + = case am of + A.Abbrev -> ok + A.ResultAbbrev -> ok + _ -> unexpectedAM m unexpectedAM :: Check Meta unexpectedAM m = dieP m "Unexpected abbreviation mode" diff --git a/frontends/OccamTypesTest.hs b/frontends/OccamTypesTest.hs index b020430..6b02b2b 100644 --- a/frontends/OccamTypesTest.hs +++ b/frontends/OccamTypesTest.hs @@ -19,7 +19,7 @@ with this program. If not, see . -- #ignore-exports -- | Tests for 'OccamTypes'. -module OccamTypesTest (tests) where +module OccamTypesTest (ioTests) where import Control.Monad.State import Data.Generics @@ -29,6 +29,7 @@ import qualified AST as A import CompState import Metadata import qualified OccamTypes +import TestHarness import TestUtils m :: Meta @@ -606,7 +607,7 @@ testOccamTypes = TestList returnOne = Left $ A.Only m $ A.ExpressionList m [intE] returnTwo = Left $ A.Only m $ A.ExpressionList m [intE, intE] - retypesV = A.Retypes m A.ValAbbrev + retypesV = A.Retypes m A.Abbrev retypesE = A.RetypesExpr m A.ValAbbrev known1 = A.Array [dimension 4] A.Byte known2 = A.Array [dimension 2, dimension 2] A.Byte @@ -616,7 +617,12 @@ testOccamTypes = TestList --}}} -tests :: Test -tests = TestLabel "OccamTypesTest" $ TestList - [ testOccamTypes - ] +ioTests :: IO Test +ioTests = liftM (TestLabel "OccamTypesTest" . TestList) $ sequence $ + map return + [ testOccamTypes + ] + ++ map (automaticTest FrontendOccam) + [ "testcases/automatic/initial-result-1.occ.test" + , "testcases/automatic/initial-result-2.occ.test" + ] diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 3fb8a44..9b9af8b 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -254,6 +254,12 @@ tryVVXX a b c d = try (do { av <- a; bv <- b; c; d; return (av, bv) }) tryVVXV :: OccParser a -> OccParser b -> OccParser c -> OccParser d -> OccParser (a, b, d) tryVVXV a b c d = try (do { av <- a; bv <- b; c; dv <- d; return (av, bv, dv) }) + +tryVVVX :: OccParser a -> OccParser b -> OccParser c -> OccParser d -> OccParser (a, b, c) +tryVVVX a b c d = try (do { av <- a; bv <- b; cv <- c; d; return (av, bv, cv) }) + +tryVVVXV :: OccParser a -> OccParser b -> OccParser c -> OccParser d -> OccParser e -> OccParser (a, b, c, e) +tryVVVXV a b c d e = try (do { av <- a; bv <- b; cv <- c; d; ev <- e; return (av, bv, cv, ev) }) --}}} --{{{ subscripts @@ -949,62 +955,60 @@ declOf spec nt abbreviation :: OccParser NameSpec abbreviation - = valIsAbbrev - <|> initialIsAbbrev - <|> isAbbrev variable VariableName - <|> isAbbrev channel ChannelName + = valAbbrev + <|> refAbbrev variable VariableName + <|> refAbbrev channel ChannelName <|> chanArrayAbbrev - <|> isAbbrev timer TimerName - <|> isAbbrev port PortName + <|> refAbbrev timer TimerName + <|> refAbbrev port PortName "abbreviation" -valIsAbbrev :: OccParser NameSpec -valIsAbbrev +maybeInfer :: OccParser A.Type -> OccParser A.Type +maybeInfer spec + = try spec + <|> return A.Infer + "optional specifier" + +valAbbrevMode :: OccParser A.AbbrevMode +valAbbrevMode + = (sVAL >> return A.ValAbbrev) + <|> (sINITIAL >> return A.InitialAbbrev) + +valAbbrev :: OccParser NameSpec +valAbbrev = do m <- md - (n, t, e) <- do { n <- tryXVX sVAL newVariableName sIS; e <- expression; sColon; eol; return (n, A.Infer, e) } - <|> do { (s, n) <- tryXVVX sVAL dataSpecifier newVariableName sIS; e <- expression; sColon; eol; return (n, s, e) } - return (A.Specification m n $ A.IsExpr m A.ValAbbrev t e, VariableName) - "VAL IS abbreviation" + (am, t, n) <- + tryVVVX valAbbrevMode (maybeInfer dataSpecifier) newVariableName sIS + e <- expression + sColon + eol + return (A.Specification m n $ A.IsExpr m am t e, VariableName) + "abbreviation by value" -initialIsAbbrev :: OccParser NameSpec -initialIsAbbrev - = do m <- md - (t, n) <- tryXVVX sINITIAL dataSpecifier newVariableName sIS - e <- expression - sColon - eol - return (A.Specification m n $ A.IsExpr m A.Original t e, VariableName) - "INITIAL IS abbreviation" +refAbbrevMode :: OccParser A.AbbrevMode +refAbbrevMode + = (sRESULT >> return A.ResultAbbrev) + <|> return A.Abbrev -isAbbrev :: OccParser A.Variable -> NameType -> OccParser NameSpec -isAbbrev oldVar nt - = do m <- md - (n, v) <- tryVXV (newName nt) sIS oldVar - sColon - eol - return (A.Specification m n $ A.Is m A.Abbrev A.Infer v, nt) - <|> do m <- md - (s, n, v) <- tryVVXV specifier (newName nt) sIS oldVar - sColon - eol - return (A.Specification m n $ A.Is m A.Abbrev s v, nt) - "IS abbreviation" +refAbbrev :: OccParser A.Variable -> NameType -> OccParser NameSpec +refAbbrev oldVar nt + = do m <- md + (am, t, n, v) <- + tryVVVXV refAbbrevMode (maybeInfer specifier) (newName nt) sIS oldVar + sColon + eol + return (A.Specification m n $ A.Is m am t v, nt) + "abbreviation by reference" chanArrayAbbrev :: OccParser NameSpec chanArrayAbbrev - = do m <- md - (n, cs) <- tryVXXV newChannelName sIS sLeft (sepBy1 channel sComma) - sRight - sColon - eol - return (A.Specification m n $ A.IsChannelArray m A.Infer cs, ChannelName) - <|> do m <- md - (s, n) <- tryVVXX channelSpecifier newChannelName sIS sLeft - cs <- sepBy1 channel sComma - sRight - sColon - eol - return (A.Specification m n $ A.IsChannelArray m s cs, ChannelName) + = do m <- md + (t, n, cs) <- + tryVVXV (maybeInfer channelSpecifier) newChannelName (sIS >> sLeft) (sepBy1 channel sComma) + sRight + sColon + eol + return (A.Specification m n $ A.IsChannelArray m t cs, ChannelName) "channel array abbreviation" specMode :: OccParser () -> OccParser A.SpecMode @@ -1049,18 +1053,14 @@ definition <|> retypesAbbrev "definition" -retypesReshapes :: OccParser () -retypesReshapes - = sRETYPES <|> sRESHAPES - retypesAbbrev :: OccParser NameSpec retypesAbbrev = do m <- md - (s, n) <- tryVVX dataSpecifier newVariableName retypesReshapes + (am, s, n) <- tryVVVX refAbbrevMode dataSpecifier newVariableName retypesReshapes v <- variable sColon eol - return (A.Specification m n $ A.Retypes m A.Abbrev s v, VariableName) + return (A.Specification m n $ A.Retypes m am s v, VariableName) <|> do m <- md (s, n) <- tryVVX channelSpecifier newChannelName retypesReshapes c <- channel @@ -1068,12 +1068,16 @@ retypesAbbrev eol return (A.Specification m n $ A.Retypes m A.Abbrev s c, ChannelName) <|> do m <- md - (s, n) <- tryXVVX sVAL dataSpecifier newVariableName retypesReshapes + (am, s, n) <- tryVVVX valAbbrevMode dataSpecifier newVariableName retypesReshapes e <- expression sColon eol - return (A.Specification m n $ A.RetypesExpr m A.ValAbbrev s e, VariableName) + return (A.Specification m n $ A.RetypesExpr m am s e, VariableName) "RETYPES/RESHAPES abbreviation" + where + retypesReshapes :: OccParser () + retypesReshapes + = sRETYPES <|> sRESHAPES dataSpecifier :: OccParser A.Type dataSpecifier @@ -1151,11 +1155,13 @@ formalArgSet formalVariableType :: OccParser (A.AbbrevMode, A.Type) formalVariableType - = do sVAL - s <- dataSpecifier - return (A.ValAbbrev, s) - <|> do s <- dataSpecifier - return (A.Abbrev, s) + = do am <- + (sVAL >> return A.ValAbbrev) + <|> (sINITIAL >> return A.InitialAbbrev) + <|> (sRESULT >> return A.ResultAbbrev) + <|> return A.Abbrev + s <- dataSpecifier + return (am, s) "formal variable type" valueProcess :: OccParser (A.Structured A.ExpressionList) diff --git a/pass/PassList.hs b/pass/PassList.hs index ead6f6e..83c1df9 100644 --- a/pass/PassList.hs +++ b/pass/PassList.hs @@ -1,6 +1,6 @@ {- Tock: a compiler for parallel languages -Copyright (C) 2007 University of Kent +Copyright (C) 2007, 2008 University of Kent This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -37,6 +37,7 @@ import OccamPasses import Pass import qualified Properties as Prop import RainPasses +import SimplifyAbbrevs import SimplifyComms import SimplifyExprs import SimplifyProcs @@ -55,6 +56,7 @@ commonPasses opts = concat $ , enablePassesWhen (not . csUsageChecking) [pass "Usage checking turned OFF" Prop.agg_namesDone [Prop.parUsageChecked] return] + , simplifyAbbrevs , simplifyComms , simplifyExprs , simplifyProcs diff --git a/pass/Properties.hs b/pass/Properties.hs index 855225e..fc44d75 100644 --- a/pass/Properties.hs +++ b/pass/Properties.hs @@ -42,6 +42,7 @@ module Properties , functionsRemoved , functionTypesChecked , inferredTypesRecorded + , initialRemoved , inputCaseRemoved , intLiteralsInBounds , listsGivenType @@ -55,6 +56,7 @@ module Properties , processTypesChecked , rainParDeclarationsPulledUp , rangeTransformed + , resultRemoved , retypesChecked , seqInputsFlattened , slicesSimplified @@ -402,3 +404,14 @@ slicesSimplified = Property "slicesSimplified" $ listsGivenType :: Property listsGivenType = Property "listsGivenType" checkTODO + +initialRemoved :: Property +initialRemoved + = Property "initialRemoved" $ + checkNull "initialRemoved" . listify (== A.InitialAbbrev) + +resultRemoved :: Property +resultRemoved + = Property "resultRemoved" $ + checkNull "resultRemoved" . listify (== A.ResultAbbrev) + diff --git a/testcases/automatic/initial-result-1.occ.test b/testcases/automatic/initial-result-1.occ.test new file mode 100644 index 0000000..30ed432 --- /dev/null +++ b/testcases/automatic/initial-result-1.occ.test @@ -0,0 +1,81 @@ +-- This file tests INITIAL and RESULT abbreviations. + +PROC main () + INT var: + REAL32 var.r: + BYTE var.b: + VAL INT const IS 42: + VAL REAL32 const.r IS 9.8: + VAL BYTE const.b IS 'x': +%% + SKIP +: + +%PASS Normal kinds of abbreviations + INT abbrev IS var: + inferred.abbrev IS var: + VAL INT val IS var: + VAL inferred.val IS var: + VAL INT val.const IS const: + VAL inferred.val.const IS const: + +%PASS Initial-abbreviate var + INITIAL INT init IS var: + +%PASS Initial-abbreviate const + INITIAL INT init IS const: + +%FAIL Initial-abbreviate wrong type + INITIAL INT init IS const.r: + +%PASS Initial-abbreviate inferred type + INITIAL init IS const: + +%PASS Result-abbreviate var + RESULT INT result IS var: + +%FAIL Result-abbreviate const + RESULT INT result IS const: + +%FAIL Result-abbreviate wrong type + RESULT INT result IS var.r: + +%PASS Result-abbreviate inferred type from var + RESULT result IS var: + +%FAIL Result-abbreviate inferred type from const + RESULT result IS const: + +%PASS Normal kinds of retypings + INT32 retyped RETYPES var.r: + VAL INT32 val.retypes RETYPES var.r: + VAL INT32 val.retypes.const RETYPES const.r: + +%FAIL Normal kind of retyping from wrong size var + INT32 retyped RETYPES var.b: + +%FAIL Normal kind of retyping from wrong size const + VAL INT32 retyped RETYPES const.b: + +%PASS Initial retyping from var + INITIAL INT32 retyped RETYPES var.r: + +%PASS Initial retyping from const + INITIAL INT32 retyped RETYPES const.r: + +%FAIL Initial retyping from wrong size var + INITIAL INT32 retyped RETYPES var.b: + +%FAIL Initial retyping from wrong size const + INITIAL INT32 retyped RETYPES const.b: + +%PASS Result retyping from var + RESULT INT32 retyped RETYPES var.r: + +%FAIL Result retyping from const + RESULT INT32 retyped RETYPES const.r: + +%FAIL Result retyping from wrong size + RESULT INT32 retyped RETYPES var.b: + +% diff --git a/testcases/automatic/initial-result-2.occ.test b/testcases/automatic/initial-result-2.occ.test new file mode 100644 index 0000000..87d2be6 --- /dev/null +++ b/testcases/automatic/initial-result-2.occ.test @@ -0,0 +1,46 @@ +-- This file tests INITIAL and RESULT formals and actuals. + +PROC main () + INT var: + REAL32 var.r: + VAL INT const IS 42: + VAL REAL32 const.r IS 9.8: + + PROC on.init (INITIAL INT init) + init := init + 1 + : + PROC on.result (RESULT INT result) + result := 42 + : + +%% +: + +%PASS Just the PROCs + SKIP + +%PASS Initial actual from var + on.init (var) + +%PASS Initial actual from const + on.init (const) + +%FAIL Initial actual from wrong type + on.init (const.r) + +%PASS Result actual from var + on.result (var) + +%FAIL Result actual from const + on.result (const) + +%FAIL Result actual from wrong type + on.result (var.r) + +%FAIL Initial formal in FUNCTION + INT FUNCTION function (INITIAL INT arg) IS 42: + +%FAIL Result formal in FUNCTION + INT FUNCTION function (RESULT INT arg) IS 42: + +% diff --git a/transformations/SimplifyAbbrevs.hs b/transformations/SimplifyAbbrevs.hs new file mode 100644 index 0000000..f438f56 --- /dev/null +++ b/transformations/SimplifyAbbrevs.hs @@ -0,0 +1,53 @@ +{- +Tock: a compiler for parallel languages +Copyright (C) 2008 University of Kent + +This program is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation, either version 2 of the License, or (at your +option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License along +with this program. If not, see . +-} + +-- | Simplify abbreviations. +module SimplifyAbbrevs (simplifyAbbrevs) where + +import qualified AST as A +import Pass +import qualified Properties as Prop +import Traversal + +simplifyAbbrevs :: [Pass] +simplifyAbbrevs = + [ removeInitial + , removeResult + ] + +-- | Rewrite 'InitialAbbrev' into a variable and an assignment. +removeInitial :: Pass +removeInitial + = pass "Remove INITIAL abbreviations" + [] + [Prop.initialRemoved] + -- FIXME: Implement this + return + +-- | Rewrite 'ResultAbbrev' into just 'Abbrev'. +removeResult :: Pass +removeResult + = pass "Remove RESULT abbreviations" + [] + [Prop.resultRemoved] + (applyDepthM (return . doAbbrevMode)) + where + doAbbrevMode :: A.AbbrevMode -> A.AbbrevMode + doAbbrevMode A.ResultAbbrev = A.Abbrev + doAbbrevMode s = s +