From 01f763373dff705d2e19ed1d0745eca92c64b2d4 Mon Sep 17 00:00:00 2001
From: Neil Brown <neil@twistedsquare.com>
Date: Sat, 15 Sep 2007 09:36:50 +0000
Subject: [PATCH] Rain: added a new pass for folding constants
---
TestMain.hs | 2 ++
common/TestUtil.hs | 27 +++++++++++++++++
frontends/ParseRainTest.hs | 17 -----------
frontends/RainPasses.hs | 22 ++------------
frontends/RainPassesTest.hs | 1 +
frontends/RainTypes.hs | 60 +++++++++++++++++++++++++++++++++++++
frontends/RainTypesTest.hs | 36 ++++++++++++++++++++++
7 files changed, 128 insertions(+), 37 deletions(-)
create mode 100644 frontends/RainTypes.hs
create mode 100644 frontends/RainTypesTest.hs
diff --git a/TestMain.hs b/TestMain.hs
index b2d7f9a..ea89069 100644
--- a/TestMain.hs
+++ b/TestMain.hs
@@ -31,6 +31,7 @@ module TestMain () where
import qualified ParseRainTest (tests)
import qualified RainPassesTest (tests)
+import qualified RainTypesTest (tests)
import qualified UsageCheckTest (tests)
import qualified PassTest (tests)
import qualified CommonTest (tests)
@@ -43,6 +44,7 @@ main = do runTestTT $ TestList
,CommonTest.tests
,ParseRainTest.tests
,RainPassesTest.tests
+ ,RainTypesTest.tests
,UsageCheckTest.tests
]
return ()
diff --git a/common/TestUtil.hs b/common/TestUtil.hs
index 2327ef2..20b3c3d 100644
--- a/common/TestUtil.hs
+++ b/common/TestUtil.hs
@@ -319,3 +319,30 @@ assertVarDef prefix state varName varDef
= case (Map.lookup varName (csNames state)) of
Nothing -> assertFailure $ prefix ++ " variable was not recorded: " ++ varName
Just actVarDef -> assertPatternMatch (prefix ++ " variable definition not as expected for " ++ varName) varDef actVarDef
+
+
+data ExprHelper =
+ Dy ExprHelper A.DyadicOp ExprHelper
+ | Mon A.MonadicOp ExprHelper
+ | Cast A.Type ExprHelper
+ | Var String
+ | DirVar A.Direction String
+ | Lit A.Expression
+
+buildExprPattern :: ExprHelper -> Pattern
+buildExprPattern (Dy lhs op rhs) = tag4 A.Dyadic DontCare op (buildExprPattern lhs) (buildExprPattern rhs)
+buildExprPattern (Mon op rhs) = tag3 A.Monadic DontCare op (buildExprPattern rhs)
+buildExprPattern (Cast ty rhs) = tag4 A.Conversion DontCare A.DefaultConversion (stopCaringPattern m $ mkPattern ty) (buildExprPattern rhs)
+buildExprPattern (Var n) = tag2 A.ExprVariable DontCare $ variablePattern n
+buildExprPattern (DirVar dir n) = tag2 A.ExprVariable DontCare $ (stopCaringPattern m $ tag3 A.DirectedVariable DontCare dir $ variablePattern n)
+buildExprPattern (Lit e) = (stopCaringPattern m) $ mkPattern e
+
+buildExpr :: ExprHelper -> A.Expression
+buildExpr (Dy lhs op rhs) = A.Dyadic m op (buildExpr lhs) (buildExpr rhs)
+buildExpr (Mon op rhs) = A.Monadic m op (buildExpr rhs)
+buildExpr (Cast ty rhs) = A.Conversion m A.DefaultConversion ty (buildExpr rhs)
+buildExpr (Var n) = A.ExprVariable m $ variable n
+buildExpr (DirVar dir n) = A.ExprVariable m $ (A.DirectedVariable m dir $ variable n)
+buildExpr (Lit e) = e
+
+
diff --git a/frontends/ParseRainTest.hs b/frontends/ParseRainTest.hs
index 975c033..56d2687 100644
--- a/frontends/ParseRainTest.hs
+++ b/frontends/ParseRainTest.hs
@@ -67,23 +67,6 @@ emptyBlock :: A.Process
emptyBlock = A.Seq m $ A.Several m []
-data ExprHelper =
- Dy ExprHelper A.DyadicOp ExprHelper
- | Mon A.MonadicOp ExprHelper
- | Cast A.Type ExprHelper
- | Var String
- | DirVar A.Direction String
- | Lit A.Expression
-
-buildExprPattern :: ExprHelper -> Pattern
-buildExprPattern (Dy lhs op rhs) = tag4 A.Dyadic DontCare op (buildExprPattern lhs) (buildExprPattern rhs)
-buildExprPattern (Mon op rhs) = tag3 A.Monadic DontCare op (buildExprPattern rhs)
-buildExprPattern (Cast ty rhs) = tag4 A.Conversion DontCare A.DefaultConversion (stopCaringPattern m $ mkPattern ty) (buildExprPattern rhs)
-buildExprPattern (Var n) = tag2 A.ExprVariable DontCare $ variablePattern n
-buildExprPattern (DirVar dir n) = tag2 A.ExprVariable DontCare $ (stopCaringPattern m $ tag3 A.DirectedVariable DontCare dir $ variablePattern n)
-buildExprPattern (Lit e) = (stopCaringPattern m) $ mkPattern e
-
-
--You are allowed to chain arithmetic operators without brackets, but not comparison operators
-- (the meaning of "b == c == d" is obscure enough to be dangerous, even if it passes the type checker)
--All arithmetic operators bind at the same level, which is a closer binding than all comparison operators.
diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs
index 3da7773..f0cdc26 100644
--- a/frontends/RainPasses.hs
+++ b/frontends/RainPasses.hs
@@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along
with this program. If not, see <http://www.gnu.org/licenses/>.
-}
--- | A module containing all the Rain-specific passes that must be run on the parsed Rain AST before it can be fed into the shared passes.
+-- | A module containing all the misc Rain-specific passes that must be run on the parsed Rain AST before it can be fed into the shared passes.
module RainPasses where
import TestUtil
@@ -32,6 +32,7 @@ import Errors
import Metadata
import Pattern
import TreeUtil
+import RainTypes
-- | An ordered list of the Rain-specific passes to be run.
rainPasses :: [(String,Pass)]
@@ -124,25 +125,6 @@ replaceNameName ::
-> A.Name -- ^ The new name, with the 'A.nameName' field replaced if it matched.
replaceNameName find replace n = if (A.nameName n) == find then n {A.nameName = replace} else n
--- | A pass that records inferred types. Currently the only place where types are inferred is in seqeach\/pareach loops.
-recordInfNameTypes :: Data t => t -> PassM t
-recordInfNameTypes = everywhereM (mkM recordInfNameTypes')
- where
- recordInfNameTypes' :: A.Replicator -> PassM A.Replicator
- recordInfNameTypes' input@(A.ForEach m n e)
- = do arrType <- typeOfExpression e
- innerT <- case arrType of
- A.Array (_:innerDims) t ->
- return $ case innerDims of
- [] -> t
- _ -> A.Array innerDims t
- _ -> dieP m "Cannot do a foreach loop over a non-array type (or array with zero dimensions)"
- defineName n A.NameDef {A.ndMeta = m, A.ndName = A.nameName n, A.ndOrigName = A.nameName n,
- A.ndNameType = A.VariableName, A.ndType = (A.Declaration m innerT),
- A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
- return input
- recordInfNameTypes' r = return r
-
-- | A pass that finds and tags the main process, and also mangles its name (to avoid problems in the C\/C++ backends with having a function called main).
findMain :: Data t => t -> PassM t
--Because findMain runs after uniquifyAndResolveVars, the types of all the process will have been recorded
diff --git a/frontends/RainPassesTest.hs b/frontends/RainPassesTest.hs
index ee04f81..da2d09d 100644
--- a/frontends/RainPassesTest.hs
+++ b/frontends/RainPassesTest.hs
@@ -28,6 +28,7 @@ import TestUtil
import Pattern
import TreeUtil
import RainPasses
+import RainTypes
import CompState
import Control.Monad.Error (runErrorT)
import Control.Monad.Identity
diff --git a/frontends/RainTypes.hs b/frontends/RainTypes.hs
new file mode 100644
index 0000000..443dbea
--- /dev/null
+++ b/frontends/RainTypes.hs
@@ -0,0 +1,60 @@
+{-
+Tock: a compiler for parallel languages
+Copyright (C) 2007 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 <http://www.gnu.org/licenses/>.
+-}
+
+module RainTypes where
+
+import TestUtil
+import qualified AST as A
+import Pass
+import Data.Generics
+import EvalConstants
+import Errors
+import Types
+import Control.Monad.State
+import CompState
+
+
+-- | A pass that records inferred types. Currently the only place where types are inferred is in seqeach\/pareach loops.
+recordInfNameTypes :: Data t => t -> PassM t
+recordInfNameTypes = everywhereM (mkM recordInfNameTypes')
+ where
+ recordInfNameTypes' :: A.Replicator -> PassM A.Replicator
+ recordInfNameTypes' input@(A.ForEach m n e)
+ = do arrType <- typeOfExpression e
+ innerT <- case arrType of
+ A.Array (_:innerDims) t ->
+ return $ case innerDims of
+ [] -> t
+ _ -> A.Array innerDims t
+ _ -> dieP m "Cannot do a foreach loop over a non-array type (or array with zero dimensions)"
+ defineName n A.NameDef {A.ndMeta = m, A.ndName = A.nameName n, A.ndOrigName = A.nameName n,
+ A.ndNameType = A.VariableName, A.ndType = (A.Declaration m innerT),
+ A.ndAbbrevMode = A.Original, A.ndPlacement = A.Unplaced}
+ return input
+ recordInfNameTypes' r = return r
+
+-- | Folds all constants.
+constantFoldPass :: Data t => t -> PassM t
+constantFoldPass = doGeneric `extM` doExpression
+ where
+ doGeneric :: Data t => t -> PassM t
+ doGeneric = makeGeneric constantFoldPass
+
+ doExpression :: A.Expression -> PassM A.Expression
+ doExpression = (liftM (\(x,_,_) -> x)) . constantFold
+
diff --git a/frontends/RainTypesTest.hs b/frontends/RainTypesTest.hs
new file mode 100644
index 0000000..f521033
--- /dev/null
+++ b/frontends/RainTypesTest.hs
@@ -0,0 +1,36 @@
+{-
+Tock: a compiler for parallel languages
+Copyright (C) 2007 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 <http://www.gnu.org/licenses/>.
+-}
+
+module RainTypesTest where
+
+import Test.HUnit
+import TestUtil
+import RainTypes
+import TreeUtil
+
+constantFoldTest :: Test
+constantFoldTest = TestList
+ [
+ TestCase $ assertPatternMatch "constantFoldTest 0" (buildExprPattern $ Var "x") (buildExpr $ Var "x")
+ ]
+
+tests :: Test
+tests = TestList
+ [
+ constantFoldTest
+ ]