Rain: added a new pass for folding constants

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 ()

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
+
+

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.

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

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

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
+

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
+ ]