Add a pass for folding constants in occam.

The existing constant-folding code in the parser is still there, since it needs
to know whether things are constant, and A.Dimension expects an Int.

However, this pass is useful because it does a better job of constant folding
than the parser would on its own: it can fold subexpressions of expressions
that are as a whole not constant.

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

TestMain.hs

@@ -28,6 +28,8 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 --
 -- * "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

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)

frontends/OccamPasses.hs

@@ -17,24 +17,55 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
 -- | 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

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 <http://www.gnu.org/licenses/>.
+-}
+
+-- #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
+    ]