Implement INITIAL and RESULT abbreviations.

This adds the passes to transform INITIAL into the correct form.

Fixes #42.

Makefile.am

@@ -181,6 +181,7 @@ tocktest_SOURCES += frontends/RainPassesTest.hs
 tocktest_SOURCES += frontends/RainTypesTest.hs
 tocktest_SOURCES += frontends/StructureOccamTest.hs
 tocktest_SOURCES += transformations/PassTest.hs
+tocktest_SOURCES += transformations/SimplifyAbbrevsTest.hs
 
 pregen_sources = data/AST.hs
 pregen_sources += pregen/PregenUtils.hs

TestMain.hs

@@ -44,6 +44,8 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 --
 -- * "RainTypesTest"
 --
+-- * "SimplifyAbbrevsTest"
+--
 -- * "StructureOccamTest"
 --
 -- * "UsageCheckTest"
@@ -70,6 +72,7 @@ import qualified PassTest (tests)
 import qualified PreprocessOccamTest (tests)
 import qualified RainPassesTest (tests)
 import qualified RainTypesTest (ioTests)
+import qualified SimplifyAbbrevsTest (tests)
 import qualified StructureOccamTest (tests)
 import qualified UsageCheckTest (tests)
 import TestUtils
@@ -187,6 +190,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options
               ,noqc PreprocessOccamTest.tests
               ,noqc RainPassesTest.tests
               ,noqcButIO RainTypesTest.ioTests
+              ,noqc SimplifyAbbrevsTest.tests
               ,noqc StructureOccamTest.tests
               ,noqc UsageCheckTest.tests
             ]

testcases/initial.occ

@@ -1,6 +1,6 @@
 PROC P ()
   INITIAL INT x IS 1234:
-  INITIAL []BYTE cs IS "hello, world":
+  INITIAL [12]BYTE cs IS "hello, world":
   SEQ
     SEQ i = 0 FOR SIZE cs
       cs[i] := 'A'

transformations/SimplifyAbbrevs.hs

@@ -17,12 +17,21 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
 -- | Simplify abbreviations.
-module SimplifyAbbrevs (simplifyAbbrevs) where
+module SimplifyAbbrevs (
+    simplifyAbbrevs
+  , removeInitial
+  , removeResult
+  ) where
+
+import Data.Generics
 
 import qualified AST as A
+import CompState
+import Metadata
 import Pass
 import qualified Properties as Prop
 import Traversal
+import Utils
 
 simplifyAbbrevs :: [Pass]
 simplifyAbbrevs =
@@ -36,8 +45,116 @@ removeInitial
     = pass "Remove INITIAL abbreviations"
            []
            [Prop.initialRemoved]
-           -- FIXME: Implement this
+           (applyDepthSM doStructured)
-           return
+  where
+    doStructured :: Data t => A.Structured t -> PassM (A.Structured t)
+    doStructured (A.Spec m spec s) = doSpec m spec s
+    doStructured s = return s
+
+    -- FIXME: When we add mobile support, we'll need to make a decision between
+    -- ValAbbrev and Abbrev based on whether the type in question is mobile.
+
+    doSpec :: forall t. Data t =>
+              Meta -> A.Specification
+              -> A.Structured t -> PassM (A.Structured t)
+    doSpec m spec@(A.Specification m' n st) inner
+        = case st of
+            -- INITIAL abbreviation
+            --
+            --   INITIAL INT foo IS bar:
+            --   inner
+            -- ->
+            --   INT foo:
+            --   PROCTHEN
+            --     foo := bar
+            --     inner
+            A.IsExpr m'' A.InitialAbbrev t e ->
+              return $ declareAssign n t e inner
+
+            -- INITIAL retyping
+            --
+            --   INITIAL INT foo RETYPES bar:
+            --   inner
+            -- ->
+            --   VAL INT temp RETYPES bar:
+            --   INT foo:
+            --   PROCTHEN
+            --     foo := temp
+            --     inner
+            A.RetypesExpr m'' A.InitialAbbrev t e ->
+               do temp <- defineNonce m' "initial_retypes_expr" st A.ValAbbrev
+                  let e = A.ExprVariable m' (specVar temp)
+                  return $ A.Spec m temp $
+                             declareAssign n t e inner
+
+            -- PROC -- look for INITIAL formals
+            --
+            --   PROC foo (INITIAL INT bar)
+            --     process
+            --   :
+            --   inner
+            -- ->
+            --   PROC foo (VAL INT temp)
+            --     SEQ
+            --       INT bar:
+            --       PROCTHEN
+            --         bar := temp
+            --         process
+            --   :
+            --   inner
+            A.Proc m'' sm fs p ->
+               do -- Find the INITIAL formals, and note their positions.
+                  let (positions, fromFS)
+                        = unzip [(i, f)
+                                 | (i, f@(A.Formal A.InitialAbbrev _ _))
+                                     <- zip [0 ..] fs]
+
+                  -- Define names for new formals.
+                  temps <- sequence [defineNonce m'
+                                                 "initial_formal"
+                                                 (A.Declaration m' t)
+                                                 A.ValAbbrev
+                                     | A.Formal _ t _ <- fromFS]
+
+                  -- Replace the old formals with new ValAbbrevs.
+                  let fs' = foldl (\fs (A.Specification _ n _,
+                                        A.Formal _ t _,
+                                        pos) ->
+                                    replaceAt pos
+                                              (A.Formal A.ValAbbrev t n)
+                                              fs
+                                  )
+                                  fs (zip3 temps fromFS positions)
+
+                  -- Wrap the inner process to declare the old names as
+                  -- variables and copy the right values into them.
+                  -- (We reverse the list so the first formal is outermost.)
+                  let p' = foldl (\p (temp, A.Formal _ t n) ->
+                                    let e = A.ExprVariable m' (specVar temp) in
+                                    A.Seq m' (declareAssign n t e $
+                                                A.Only m' p))
+                                 p (reverse $ zip temps fromFS)
+
+                  let spec' = A.Specification m' n (A.Proc m'' sm fs' p')
+                  return $ A.Spec m spec' inner
+
+            _ -> leave
+      where
+        leave :: PassM (A.Structured t)
+        leave = return $ A.Spec m spec inner
+
+        declareAssign :: Data s =>
+                      A.Name -> A.Type -> A.Expression
+                      -> A.Structured s -> A.Structured s
+        declareAssign n t e s
+            = A.Spec m (A.Specification m' n $ A.Declaration m' t) $
+                A.ProcThen m' (A.Assign m'
+                                        [A.Variable m' n]
+                                        (A.ExpressionList m' [e])) $
+                  s
+
+        specVar :: A.Specification -> A.Variable
+        specVar (A.Specification m n _) = A.Variable m n
 
 -- | Rewrite 'ResultAbbrev' into just 'Abbrev'.
 removeResult :: Pass

transformations/SimplifyAbbrevsTest.hs

@@ -0,0 +1,164 @@
+{-
+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/>.
+-}
+
+-- | Tests for 'SimplifyAbbrevs'.
+module SimplifyAbbrevsTest (tests) where
+
+import Control.Monad.State
+import Data.Generics
+import Test.HUnit hiding (State)
+
+import CompState
+import qualified AST as A
+import Metadata
+import Pattern
+import SimplifyAbbrevs
+import TagAST
+import TestUtils
+import TreeUtils
+
+m :: Meta
+m = emptyMeta
+
+setupState :: State CompState ()
+setupState
+    = return ()
+
+testRemoveInitial :: Test
+testRemoveInitial = TestLabel "testRemoveInitial" $ TestList
+  [ -- Nothing to do
+    ok    0 inner
+            inner
+
+    -- INITIAL abbreviation
+  , ok   10 (spec foo (A.IsExpr m A.InitialAbbrev A.Int exp)
+              inner)
+            (mDeclareAssign foo A.Int exp inner)
+
+    -- INITIAL retyping
+  , ok   20 (spec foo (A.RetypesExpr m A.InitialAbbrev A.Int exp)
+              inner)
+            (mSpec mTemp (A.RetypesExpr m A.InitialAbbrev A.Int exp)
+              (mDeclareAssign foo A.Int mTempE inner))
+
+    -- INITIAL formal
+  , ok   30 (spec foo (A.Proc m
+                              A.PlainSpec
+                              [A.Formal A.InitialAbbrev A.Int bar]
+                              skip)
+              inner)
+            (mSpec foo (mProc A.PlainSpec
+                              [mFormal' A.ValAbbrev A.Int mTemp]
+                              (mSeq
+                                (mDeclareAssign bar A.Int mTempE
+                                  (A.Only m skip))))
+              inner)
+
+    -- Two INITIAL formals and a regular VAL formal
+  , ok   40 (spec foo (A.Proc m
+                              A.PlainSpec
+                              [ A.Formal A.InitialAbbrev A.Int bar
+                              , A.Formal A.ValAbbrev     A.Int baz
+                              , A.Formal A.InitialAbbrev A.Int quux
+                              ]
+                              skip)
+              inner)
+            (mSpec foo (mProc A.PlainSpec
+                              [ mFormal' A.ValAbbrev A.Int mTemp
+                              , mFormal' A.ValAbbrev A.Int baz
+                              , mFormal' A.ValAbbrev A.Int mTemp2
+                              ]
+                              (mSeq
+                                (mDeclareAssign bar A.Int mTempE
+                                  (mOnlyP
+                                    (mSeq
+                                      (mDeclareAssign quux A.Int mTempE2
+                                        (A.Only m skip)))))))
+              inner)
+  ]
+  where
+    ok :: (Data a, Data b) => Int -> a -> b -> Test
+    ok n inp exp = TestCase $ testPass ("testRemoveInitial" ++ show n)
+                                       exp removeInitial inp setupState
+
+    skip = A.Skip m
+    inner = A.Only m skip
+    spec n st s = A.Spec m (A.Specification m n st) s
+    mSpec :: (Data a, Data b, Data c) => a -> b -> c -> Pattern
+    mSpec n st s = mSpecP (tag3 A.Specification m n st) s
+    foo = simpleName "foo"
+    bar = simpleName "bar"
+    barV = A.Variable m bar
+    baz = simpleName "baz"
+    quux = simpleName "quux"
+    exp = A.ExprVariable m barV
+    mTemp :: Pattern
+    mTemp = Named "temp" DontCare
+    mTempV :: Pattern
+    mTempV = mVariable mTemp
+    mTempE :: Pattern
+    mTempE = mExprVariable mTempV
+    mTemp2 :: Pattern
+    mTemp2 = Named "temp2" DontCare
+    mTempV2 :: Pattern
+    mTempV2 = mVariable mTemp2
+    mTempE2 :: Pattern
+    mTempE2 = mExprVariable mTempV2
+    mAssign :: (Data a, Data b) => a -> b -> Pattern
+    mAssign v e = tag3 A.Assign m [v] (tag2 A.ExpressionList m [e])
+
+    mDeclareAssign :: (Data a, Data b, Data c, Data d) =>
+                      a -> b -> c -> d -> Pattern
+    mDeclareAssign n t e s
+        = mSpec n (mDeclaration t) $
+            mProcThenP (mAssign (mVariable n) e) $
+              s
+
+testRemoveResult :: Test
+testRemoveResult = TestLabel "testRemoveResult" $ TestList
+  [ -- Nothing to do
+    ok    0 inner
+            inner
+
+    -- RESULT abbreviation
+  , ok   10 (spec foo (A.Is m A.ResultAbbrev A.Int barV) inner)
+            (spec foo (A.Is m A.Abbrev       A.Int barV) inner)
+
+    -- RESULT retyping
+  , ok   20 (spec foo (A.Retypes m A.ResultAbbrev A.Int barV) inner)
+            (spec foo (A.Retypes m A.Abbrev       A.Int barV) inner)
+
+    -- RESULT formal
+  , ok   30 (A.Formal A.ResultAbbrev A.Int foo)
+            (A.Formal A.Abbrev       A.Int foo)
+  ]
+  where
+    ok :: (Data a, Data b) => Int -> a -> b -> Test
+    ok n inp exp = TestCase $ testPass ("testRemoveResult" ++ show n)
+                                       exp removeResult inp setupState
+
+    inner = A.Only m (A.Skip m)
+    spec n st s = A.Spec m (A.Specification m n st) s
+    foo = simpleName "foo"
+    barV = A.Variable m $ simpleName "bar"
+
+tests :: Test
+tests = TestLabel "SimplifyAbbrevsTest" $ TestList
+    [ testRemoveInitial
+    , testRemoveResult
+    ]