diff --git a/Makefile.am b/Makefile.am index b87dffe..f20dd92 100644 --- a/Makefile.am +++ b/Makefile.am @@ -164,6 +164,7 @@ tocktest_SOURCES += common/TestFramework.hs tocktest_SOURCES += common/TestHarness.hs tocktest_SOURCES += common/TestUtils.hs tocktest_SOURCES += flow/FlowGraphTest.hs +tocktest_SOURCES += frontends/OccamPassesTest.hs tocktest_SOURCES += frontends/ParseRainTest.hs tocktest_SOURCES += frontends/PreprocessOccamTest.hs tocktest_SOURCES += frontends/RainPassesTest.hs diff --git a/TestMain.hs b/TestMain.hs index 37172f5..54250cb 100644 --- a/TestMain.hs +++ b/TestMain.hs @@ -28,6 +28,8 @@ with this program. If not, see . -- -- * "GenerateCTest" -- +-- * "OccamPassesTest" +-- -- * "ParseRainTest" -- -- * "PassTest" @@ -56,6 +58,7 @@ import qualified BackendPassesTest (qcTests) import qualified CommonTest (tests) import qualified FlowGraphTest (qcTests) import qualified GenerateCTest (tests) +import qualified OccamPassesTest (tests) import qualified ParseRainTest (tests) import qualified PassTest (tests) import qualified PreprocessOccamTest (tests) @@ -170,6 +173,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options ,noqc CommonTest.tests ,return FlowGraphTest.qcTests ,noqc GenerateCTest.tests + ,noqc OccamPassesTest.tests ,noqc ParseRainTest.tests ,noqc PassTest.tests ,noqc PreprocessOccamTest.tests diff --git a/data/CompState.hs b/data/CompState.hs index 286e832..e74dda8 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -168,6 +168,13 @@ defineName :: CSM m => A.Name -> A.NameDef -> m () defineName n nd = modify $ (\ps -> ps { csNames = Map.insert (A.nameName n) nd (csNames ps) }) +-- | Modify the definition of a name. +modifyName :: CSM m => A.Name -> (A.NameDef -> A.NameDef) -> m () +modifyName n f + = modify $ (\ps -> ps { csNames = modifyName $ csNames ps }) + where + modifyName = Map.adjust f (A.nameName n) + -- | 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) diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs index f49ea5b..7269da1 100644 --- a/frontends/OccamPasses.hs +++ b/frontends/OccamPasses.hs @@ -17,24 +17,55 @@ with this program. If not, see . -} -- | The occam-specific frontend passes. -module OccamPasses (occamPasses) where +module OccamPasses (occamPasses, foldConstants) where import Data.Generics +import qualified AST as A import CompState +import EvalConstants import Pass import qualified Properties as Prop -- | Occam-specific frontend passes. occamPasses :: [Pass] occamPasses = makePassesDep' ((== FrontendOccam) . csFrontend) - [ ("Dummy occam pass", dummyOccamPass, + [ ("Fold constants", foldConstants, [], - Prop.agg_namesDone ++ [Prop.constantsFolded, Prop.expressionTypesChecked, + [Prop.constantsFolded]) + , ("Dummy occam pass", dummyOccamPass, + [], + Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.inferredTypesRecorded, Prop.mainTagged, Prop.processTypesChecked]) ] +-- | Fold constant expressions. +foldConstants :: Data t => t -> PassM t +foldConstants = doGeneric `extM` doSpecification `extM` doExpression + where + doGeneric :: Data t => t -> PassM t + doGeneric = makeGeneric foldConstants + + -- When an expression is abbreviated, try to fold it, and update its + -- definition so that it can be used when folding later expressions. + doSpecification :: A.Specification -> PassM A.Specification + doSpecification s@(A.Specification m n (A.IsExpr m' am t e)) + = do e' <- doExpression e + let st' = A.IsExpr m' am t e' + modifyName n (\nd -> nd { A.ndType = st' }) + return $ A.Specification m n st' + doSpecification s = doGeneric s + + -- For all other expressions, just try to fold them. + -- We recurse into the expression first so that we fold subexpressions of + -- non-constant expressions too. + doExpression :: A.Expression -> PassM A.Expression + doExpression e + = do e' <- doGeneric e + (e'', _, _) <- constantFold e' + return e'' + -- | A dummy pass for things that haven't been separated out into passes yet. dummyOccamPass :: Data t => t -> PassM t dummyOccamPass = return diff --git a/frontends/OccamPassesTest.hs b/frontends/OccamPassesTest.hs new file mode 100644 index 0000000..1fad9a6 --- /dev/null +++ b/frontends/OccamPassesTest.hs @@ -0,0 +1,114 @@ +{- +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 . +-} + +-- #ignore-exports + +-- | Tests for 'OccamPasses'. + +module OccamPassesTest (tests) where + +import Control.Monad.State +import Data.Generics +import Test.HUnit hiding (State) + +import qualified AST as A +import CompState +import Metadata +import qualified OccamPasses +import TestUtils + +m :: Meta +m = emptyMeta + +-- | Test 'OccamPasses.foldConstants'. +testFoldConstants :: Test +testFoldConstants = TestList + [ + -- Trivial stuff + testSame 0 one + , testSame 1 var + + -- Things that shouldn't fold + , testSame 10 (add var one) + , testSame 11 (add one var) + , testSame 12 (add var (add one var)) + , testSame 13 (add one (add var one)) + , testSame 14 (add var (add one var)) + + -- Things that should fold + , test 20 (add one one) two + , test 21 (add one (add one one)) three + , test 22 (add (add one one) one) three + , test 23 (add one two) three + , test 24 (add one (add one (add one one))) four + , test 25 (add (add one (add one one)) one) four + , test 26 (add (add (add one one) one) one) four + + -- Folding subexpressions of a non-constant expression + , test 30 (add var (add one one)) (add var two) + , test 31 (add (add one one) var) (add two var) + , test 32 (add var (add var (add one one))) (add var (add var two)) + + -- Folding existing constant variables + , test 40 const two + , test 41 (add const (add one one)) four + , test 42 (add (add one one) const) four + , test 43 (add const (add const (add one one))) six + , test 44 (add var const) (add var two) + , test 45 (add const var) (add two var) + , test 46 (add const const) four + , test 47 (add const (add var one)) (add two (add var one)) + , test 48 (add var (add const one)) (add var three) + ] + where + test :: Data a => Int -> a -> a -> Test + test n orig exp = TestCase $ testPass ("testFoldConstants" ++ show n) + exp (OccamPasses.foldConstants orig) + startState + + startState :: State CompState () + startState = defineConst "const" A.Int two + + defineConst :: String -> A.Type -> A.Expression -> State CompState () + defineConst s t e = defineName (simpleName s) $ + A.NameDef { + A.ndMeta = m, + A.ndName = "const", + A.ndOrigName = "const", + A.ndNameType = A.VariableName, + A.ndType = A.IsExpr m A.ValAbbrev t e, + A.ndAbbrevMode = A.ValAbbrev, + A.ndPlacement = A.Unplaced + } + + testSame :: Int -> A.Expression -> Test + testSame n orig = test n orig orig + + add e f = A.Dyadic m A.Add e f + var = exprVariable "var" + const = exprVariable "const" + one = intLiteral 1 + two = intLiteral 2 + three = intLiteral 3 + four = intLiteral 4 + six = intLiteral 6 + +tests :: Test +tests = TestLabel "OccamPassesTest" $ TestList + [ testFoldConstants + ]