Initial work on supporting INITIAL and RESULT abbreviations.

This fixes the AST, parser and typechecker, and adds a pass to
transform Result back into Abbrev, but doesn't transform Initial yet.
(It actually works for trivial stuff anyway, but it won't do the right
thing for complex types or PROC parameters.)

It appears (to me) to make sense to support INITIAL/RESULT reshaping
and retyping too, so this does.

Refs #42.

LANGUAGE

@@ -20,6 +20,6 @@ CHAN for CHAN OF, and PLACE for PLACE AT.
 
 PLACE IN WORKSPACE and PLACE IN VECSPACE, both currently ignored.
 
-INITIAL variables.
+INITIAL and RESULT abbreviations.
 
 Array constructors.

Makefile.am

@@ -152,6 +152,7 @@ tock_SOURCES_hs += pass/PassList.hs
 tock_SOURCES_hs += pass/Properties.hs
 tock_SOURCES_hs += pass/Traversal.hs
 tock_SOURCES_hs += transformations/ImplicitMobility.hs
+tock_SOURCES_hs += transformations/SimplifyAbbrevs.hs
 tock_SOURCES_hs += transformations/SimplifyComms.hs
 tock_SOURCES_hs += transformations/SimplifyExprs.hs
 tock_SOURCES_hs += transformations/SimplifyProcs.hs

TestMain.hs

@@ -64,7 +64,7 @@ import qualified CommonTest (tests)
 import qualified FlowGraphTest (qcTests)
 import qualified GenerateCTest (tests)
 import qualified OccamPassesTest (tests)
-import qualified OccamTypesTest (tests)
+import qualified OccamTypesTest (ioTests)
 import qualified ParseRainTest (tests)
 import qualified PassTest (tests)
 import qualified PreprocessOccamTest (tests)
@@ -181,7 +181,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options
               ,return FlowGraphTest.qcTests
               ,noqc GenerateCTest.tests
               ,noqc OccamPassesTest.tests
-              ,noqc OccamTypesTest.tests
+              ,noqcButIO OccamTypesTest.ioTests
               ,noqc ParseRainTest.tests
               ,noqc PassTest.tests
               ,noqc PreprocessOccamTest.tests

data/AST.hs

@@ -456,6 +456,10 @@ data AbbrevMode =
   | Abbrev
   -- | An abbreviation by value.
   | ValAbbrev
+  -- | An abbreviation by value that can be modified.
+  | InitialAbbrev
+  -- | An abbreviation by reference that is initially undefined.
+  | ResultAbbrev
   deriving (Show, Eq, Typeable, Data)
 
 -- | Anything that introduces a new name.

frontends/OccamTypes.hs

@@ -311,6 +311,7 @@ checkAbbrev m orig new
     = case (orig, new) of
         (_, A.Original) -> bad
         (A.ValAbbrev, A.ValAbbrev) -> ok
+        (A.ValAbbrev, A.InitialAbbrev) -> ok
         (A.ValAbbrev, _) -> bad
         _ -> ok
   where
@@ -320,7 +321,9 @@ checkAbbrev m orig new
     showAM :: A.AbbrevMode -> String
     showAM A.Original = "an original declaration"
     showAM A.Abbrev = "a reference abbreviation"
-    showAM A.ValAbbrev = "a value abbreviation"
+    showAM A.ValAbbrev = "a VAL abbreviation"
+    showAM A.InitialAbbrev = "an INITIAL abbreviation"
+    showAM A.ResultAbbrev = "a RESULT abbreviation"
 
 -- | Check a list of actuals is the right length for a list of formals.
 checkActualCount :: Meta -> A.Name -> [A.Formal] -> [a] -> PassM ()
@@ -1102,13 +1105,13 @@ checkSpecTypes = checkDepthM doSpecType
     doSpecType (A.Is m am t v)
         =  do tv <- astTypeOf v
               checkType (findMeta v) t tv
-              when (am /= A.Abbrev) $ unexpectedAM m
+              checkRefAM m am
               amv <- abbrevModeOfVariable v
               checkAbbrev m amv am
     doSpecType (A.IsExpr m am t e)
         =  do te <- astTypeOf e
               checkType (findMeta e) t te
-              when (am /= A.ValAbbrev) $ unexpectedAM m
+              checkValAM m am
               checkAbbrev m A.ValAbbrev am
     doSpecType (A.IsChannelArray m rawT cs)
         =  do t <- resolveUserType m rawT
@@ -1159,12 +1162,31 @@ checkSpecTypes = checkDepthM doSpecType
         doFunctionBody rs (Left s) = checkStructured (checkExpressionList rs) s
         -- FIXME: Need to know the name of the function to do this
         doFunctionBody rs (Right p) = dieP m "Cannot check function process body"
-    doSpecType (A.Retypes m _ t v)
+    doSpecType (A.Retypes m am t v)
         =  do fromT <- astTypeOf v
               checkRetypes m fromT t
-    doSpecType (A.RetypesExpr m _ t e)
+              checkRefAM m am
+              amv <- abbrevModeOfVariable v
+              checkAbbrev m amv am
+    doSpecType (A.RetypesExpr m am t e)
         =  do fromT <- astTypeOf e
               checkRetypes m fromT t
+              checkValAM m am
+              checkAbbrev m A.ValAbbrev am
+
+    checkValAM :: Meta -> A.AbbrevMode -> PassM ()
+    checkValAM m am
+        = case am of
+            A.ValAbbrev -> ok
+            A.InitialAbbrev -> ok
+            _ -> unexpectedAM m
+
+    checkRefAM :: Meta -> A.AbbrevMode -> PassM ()
+    checkRefAM m am
+        = case am of
+            A.Abbrev -> ok
+            A.ResultAbbrev -> ok
+            _ -> unexpectedAM m
 
     unexpectedAM :: Check Meta
     unexpectedAM m = dieP m "Unexpected abbreviation mode"

frontends/OccamTypesTest.hs

@@ -19,7 +19,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -- #ignore-exports
 
 -- | Tests for 'OccamTypes'.
-module OccamTypesTest (tests) where
+module OccamTypesTest (ioTests) where
 
 import Control.Monad.State
 import Data.Generics
@@ -29,6 +29,7 @@ import qualified AST as A
 import CompState
 import Metadata
 import qualified OccamTypes
+import TestHarness
 import TestUtils
 
 m :: Meta
@@ -606,7 +607,7 @@ testOccamTypes = TestList
     returnOne = Left $ A.Only m $ A.ExpressionList m [intE]
     returnTwo = Left $ A.Only m $ A.ExpressionList m [intE, intE]
 
-    retypesV = A.Retypes m A.ValAbbrev
+    retypesV = A.Retypes m A.Abbrev
     retypesE = A.RetypesExpr m A.ValAbbrev
     known1 = A.Array [dimension 4] A.Byte
     known2 = A.Array [dimension 2, dimension 2] A.Byte
@@ -616,7 +617,12 @@ testOccamTypes = TestList
 
     --}}}
 
-tests :: Test
+ioTests :: IO Test
-tests = TestLabel "OccamTypesTest" $ TestList
+ioTests = liftM (TestLabel "OccamTypesTest" . TestList) $ sequence $
-    [ testOccamTypes
+    map return
-    ]
+        [ testOccamTypes
+        ]
+    ++ map (automaticTest FrontendOccam)
+        [ "testcases/automatic/initial-result-1.occ.test"
+        , "testcases/automatic/initial-result-2.occ.test"
+        ]

frontends/ParseOccam.hs

@@ -254,6 +254,12 @@ tryVVXX a b c d = try (do { av <- a; bv <- b; c; d; return (av, bv) })
 
 tryVVXV :: OccParser a -> OccParser b -> OccParser c -> OccParser d -> OccParser (a, b, d)
 tryVVXV a b c d = try (do { av <- a; bv <- b; c; dv <- d; return (av, bv, dv) })
+
+tryVVVX :: OccParser a -> OccParser b -> OccParser c -> OccParser d -> OccParser (a, b, c)
+tryVVVX a b c d = try (do { av <- a; bv <- b; cv <- c; d; return (av, bv, cv) })
+
+tryVVVXV :: OccParser a -> OccParser b -> OccParser c -> OccParser d -> OccParser e -> OccParser (a, b, c, e)
+tryVVVXV a b c d e = try (do { av <- a; bv <- b; cv <- c; d; ev <- e; return (av, bv, cv, ev) })
 --}}}
 
 --{{{ subscripts
@@ -949,62 +955,60 @@ declOf spec nt
 
 abbreviation :: OccParser NameSpec
 abbreviation
-    =   valIsAbbrev
+    =   valAbbrev
-    <|> initialIsAbbrev
+    <|> refAbbrev variable VariableName
-    <|> isAbbrev variable VariableName
+    <|> refAbbrev channel ChannelName
-    <|> isAbbrev channel ChannelName
     <|> chanArrayAbbrev
-    <|> isAbbrev timer TimerName
+    <|> refAbbrev timer TimerName
-    <|> isAbbrev port PortName
+    <|> refAbbrev port PortName
     <?> "abbreviation"
 
-valIsAbbrev :: OccParser NameSpec
+maybeInfer :: OccParser A.Type -> OccParser A.Type
-valIsAbbrev
+maybeInfer spec
+    =   try spec
+    <|> return A.Infer
+    <?> "optional specifier"
+
+valAbbrevMode :: OccParser A.AbbrevMode
+valAbbrevMode
+    =   (sVAL     >> return A.ValAbbrev)
+    <|> (sINITIAL >> return A.InitialAbbrev)
+
+valAbbrev :: OccParser NameSpec
+valAbbrev
     =  do m <- md
-          (n, t, e) <- do { n <- tryXVX sVAL newVariableName sIS; e <- expression; sColon; eol; return (n, A.Infer, e) }
+          (am, t, n) <-
-                       <|> do { (s, n) <- tryXVVX sVAL dataSpecifier newVariableName sIS; e <- expression; sColon; eol; return (n, s, e) }
+            tryVVVX valAbbrevMode (maybeInfer dataSpecifier) newVariableName sIS
-          return (A.Specification m n $ A.IsExpr m A.ValAbbrev t e, VariableName)
+          e <- expression
-    <?> "VAL IS abbreviation"
+          sColon
+          eol
+          return (A.Specification m n $ A.IsExpr m am t e, VariableName)
+    <?> "abbreviation by value"
 
-initialIsAbbrev :: OccParser NameSpec
+refAbbrevMode :: OccParser A.AbbrevMode
-initialIsAbbrev
+refAbbrevMode
-    =   do m <- md
+    =   (sRESULT >> return A.ResultAbbrev)
-           (t, n) <- tryXVVX sINITIAL dataSpecifier newVariableName sIS
+    <|> return A.Abbrev
-           e <- expression
-           sColon
-           eol
-           return (A.Specification m n $ A.IsExpr m A.Original t e, VariableName)
-    <?> "INITIAL IS abbreviation"
 
-isAbbrev :: OccParser A.Variable -> NameType -> OccParser NameSpec
+refAbbrev :: OccParser A.Variable -> NameType -> OccParser NameSpec
-isAbbrev oldVar nt
+refAbbrev oldVar nt
-    =   do m <- md
+    =  do m <- md
-           (n, v) <- tryVXV (newName nt) sIS oldVar
+          (am, t, n, v) <-
-           sColon
+            tryVVVXV refAbbrevMode (maybeInfer specifier) (newName nt) sIS oldVar
-           eol
+          sColon
-           return (A.Specification m n $ A.Is m A.Abbrev A.Infer v, nt)
+          eol
-    <|> do m <- md
+          return (A.Specification m n $ A.Is m am t v, nt)
-           (s, n, v) <- tryVVXV specifier (newName nt) sIS oldVar
+    <?> "abbreviation by reference"
-           sColon
-           eol
-           return (A.Specification m n $ A.Is m A.Abbrev s v, nt)
-    <?> "IS abbreviation"
 
 chanArrayAbbrev :: OccParser NameSpec
 chanArrayAbbrev
-    =   do m <- md
+    =  do m <- md
-           (n, cs) <- tryVXXV newChannelName sIS sLeft (sepBy1 channel sComma)
+          (t, n, cs) <-
-           sRight
+            tryVVXV (maybeInfer channelSpecifier) newChannelName (sIS >> sLeft) (sepBy1 channel sComma)
-           sColon
+          sRight
-           eol
+          sColon
-           return (A.Specification m n $ A.IsChannelArray m A.Infer cs, ChannelName)
+          eol
-    <|> do m <- md
+          return (A.Specification m n $ A.IsChannelArray m t cs, ChannelName)
-           (s, n) <- tryVVXX channelSpecifier newChannelName sIS sLeft
-           cs <- sepBy1 channel sComma
-           sRight
-           sColon
-           eol
-           return (A.Specification m n $ A.IsChannelArray m s cs, ChannelName)
     <?> "channel array abbreviation"
 
 specMode :: OccParser () -> OccParser A.SpecMode
@@ -1049,18 +1053,14 @@ definition
     <|> retypesAbbrev
     <?> "definition"
 
-retypesReshapes :: OccParser ()
-retypesReshapes
-    = sRETYPES <|> sRESHAPES
-
 retypesAbbrev :: OccParser NameSpec
 retypesAbbrev
     =   do m <- md
-           (s, n) <- tryVVX dataSpecifier newVariableName retypesReshapes
+           (am, s, n) <- tryVVVX refAbbrevMode dataSpecifier newVariableName retypesReshapes
            v <- variable
            sColon
            eol
-           return (A.Specification m n $ A.Retypes m A.Abbrev s v, VariableName)
+           return (A.Specification m n $ A.Retypes m am s v, VariableName)
     <|> do m <- md
            (s, n) <- tryVVX channelSpecifier newChannelName retypesReshapes
            c <- channel
@@ -1068,12 +1068,16 @@ retypesAbbrev
            eol
            return (A.Specification m n $ A.Retypes m A.Abbrev s c, ChannelName)
     <|> do m <- md
-           (s, n) <- tryXVVX sVAL dataSpecifier newVariableName retypesReshapes
+           (am, s, n) <- tryVVVX valAbbrevMode dataSpecifier newVariableName retypesReshapes
            e <- expression
            sColon
            eol
-           return (A.Specification m n $ A.RetypesExpr m A.ValAbbrev s e, VariableName)
+           return (A.Specification m n $ A.RetypesExpr m am s e, VariableName)
     <?> "RETYPES/RESHAPES abbreviation"
+  where
+    retypesReshapes :: OccParser ()
+    retypesReshapes
+        = sRETYPES <|> sRESHAPES
 
 dataSpecifier :: OccParser A.Type
 dataSpecifier
@@ -1151,11 +1155,13 @@ formalArgSet
 
 formalVariableType :: OccParser (A.AbbrevMode, A.Type)
 formalVariableType
-    =   do sVAL
+    =  do am <-
-           s <- dataSpecifier
+            (sVAL >> return A.ValAbbrev)
-           return (A.ValAbbrev, s)
+            <|> (sINITIAL >> return A.InitialAbbrev)
-    <|> do s <- dataSpecifier
+            <|> (sRESULT >> return A.ResultAbbrev)
-           return (A.Abbrev, s)
+            <|> return A.Abbrev
+          s <- dataSpecifier
+          return (am, s)
     <?> "formal variable type"
 
 valueProcess :: OccParser (A.Structured A.ExpressionList)

pass/PassList.hs

@@ -1,6 +1,6 @@
 {-
 Tock: a compiler for parallel languages
-Copyright (C) 2007  University of Kent
+Copyright (C) 2007, 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
@@ -37,6 +37,7 @@ import OccamPasses
 import Pass
 import qualified Properties as Prop
 import RainPasses
+import SimplifyAbbrevs
 import SimplifyComms
 import SimplifyExprs
 import SimplifyProcs
@@ -55,6 +56,7 @@ commonPasses opts = concat $
   , enablePassesWhen (not . csUsageChecking)
     [pass "Usage checking turned OFF" Prop.agg_namesDone [Prop.parUsageChecked]
       return]
+  , simplifyAbbrevs
   , simplifyComms
   , simplifyExprs
   , simplifyProcs

pass/Properties.hs

@@ -42,6 +42,7 @@ module Properties
   , functionsRemoved
   , functionTypesChecked
   , inferredTypesRecorded
+  , initialRemoved
   , inputCaseRemoved
   , intLiteralsInBounds
   , listsGivenType
@@ -55,6 +56,7 @@ module Properties
   , processTypesChecked
   , rainParDeclarationsPulledUp
   , rangeTransformed
+  , resultRemoved
   , retypesChecked
   , seqInputsFlattened
   , slicesSimplified
@@ -402,3 +404,14 @@ slicesSimplified = Property "slicesSimplified" $
 
 listsGivenType :: Property
 listsGivenType = Property "listsGivenType" checkTODO
+
+initialRemoved :: Property
+initialRemoved
+    = Property "initialRemoved" $
+        checkNull "initialRemoved" . listify (== A.InitialAbbrev)
+
+resultRemoved :: Property
+resultRemoved
+    = Property "resultRemoved" $
+        checkNull "resultRemoved" . listify (== A.ResultAbbrev)
+

testcases/automatic/initial-result-1.occ.test

@@ -0,0 +1,81 @@
+-- This file tests INITIAL and RESULT abbreviations.
+
+PROC main ()
+  INT var:
+  REAL32 var.r:
+  BYTE var.b:
+  VAL INT const IS 42:
+  VAL REAL32 const.r IS 9.8:
+  VAL BYTE const.b IS 'x':
+%%
+  SKIP
+:
+
+%PASS Normal kinds of abbreviations
+  INT abbrev IS var:
+  inferred.abbrev IS var:
+  VAL INT val IS var:
+  VAL inferred.val IS var:
+  VAL INT val.const IS const:
+  VAL inferred.val.const IS const:
+
+%PASS Initial-abbreviate var
+  INITIAL INT init IS var:
+
+%PASS Initial-abbreviate const
+  INITIAL INT init IS const:
+
+%FAIL Initial-abbreviate wrong type
+  INITIAL INT init IS const.r:
+
+%PASS Initial-abbreviate inferred type
+  INITIAL init IS const:
+
+%PASS Result-abbreviate var
+  RESULT INT result IS var:
+
+%FAIL Result-abbreviate const
+  RESULT INT result IS const:
+
+%FAIL Result-abbreviate wrong type
+  RESULT INT result IS var.r:
+
+%PASS Result-abbreviate inferred type from var
+  RESULT result IS var:
+
+%FAIL Result-abbreviate inferred type from const
+  RESULT result IS const:
+
+%PASS Normal kinds of retypings
+  INT32 retyped RETYPES var.r:
+  VAL INT32 val.retypes RETYPES var.r:
+  VAL INT32 val.retypes.const RETYPES const.r:
+
+%FAIL Normal kind of retyping from wrong size var
+  INT32 retyped RETYPES var.b:
+
+%FAIL Normal kind of retyping from wrong size const
+  VAL INT32 retyped RETYPES const.b:
+
+%PASS Initial retyping from var
+  INITIAL INT32 retyped RETYPES var.r:
+
+%PASS Initial retyping from const
+  INITIAL INT32 retyped RETYPES const.r:
+
+%FAIL Initial retyping from wrong size var
+  INITIAL INT32 retyped RETYPES var.b:
+
+%FAIL Initial retyping from wrong size const
+  INITIAL INT32 retyped RETYPES const.b:
+
+%PASS Result retyping from var
+  RESULT INT32 retyped RETYPES var.r:
+
+%FAIL Result retyping from const
+  RESULT INT32 retyped RETYPES const.r:
+
+%FAIL Result retyping from wrong size
+  RESULT INT32 retyped RETYPES var.b:
+
+%

testcases/automatic/initial-result-2.occ.test

@@ -0,0 +1,46 @@
+-- This file tests INITIAL and RESULT formals and actuals.
+
+PROC main ()
+  INT var:
+  REAL32 var.r:
+  VAL INT const IS 42:
+  VAL REAL32 const.r IS 9.8:
+
+  PROC on.init (INITIAL INT init)
+    init := init + 1
+  :
+  PROC on.result (RESULT INT result)
+    result := 42
+  :
+
+%%
+:
+
+%PASS Just the PROCs
+  SKIP
+
+%PASS Initial actual from var
+  on.init (var)
+
+%PASS Initial actual from const
+  on.init (const)
+
+%FAIL Initial actual from wrong type
+  on.init (const.r)
+
+%PASS Result actual from var
+  on.result (var)
+
+%FAIL Result actual from const
+  on.result (const)
+
+%FAIL Result actual from wrong type
+  on.result (var.r)
+
+%FAIL Initial formal in FUNCTION
+  INT FUNCTION function (INITIAL INT arg) IS 42:
+
+%FAIL Result formal in FUNCTION
+  INT FUNCTION function (RESULT INT arg) IS 42:
+
+%

transformations/SimplifyAbbrevs.hs

@@ -0,0 +1,53 @@
+{-
+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/>.
+-}
+
+-- | Simplify abbreviations.
+module SimplifyAbbrevs (simplifyAbbrevs) where
+
+import qualified AST as A
+import Pass
+import qualified Properties as Prop
+import Traversal
+
+simplifyAbbrevs :: [Pass]
+simplifyAbbrevs =
+    [ removeInitial
+    , removeResult
+    ]
+
+-- | Rewrite 'InitialAbbrev' into a variable and an assignment.
+removeInitial :: Pass
+removeInitial
+    = pass "Remove INITIAL abbreviations"
+           []
+           [Prop.initialRemoved]
+           -- FIXME: Implement this
+           return
+
+-- | Rewrite 'ResultAbbrev' into just 'Abbrev'.
+removeResult :: Pass
+removeResult
+    = pass "Remove RESULT abbreviations"
+           []
+           [Prop.resultRemoved]
+           (applyDepthM (return . doAbbrevMode))
+  where
+    doAbbrevMode :: A.AbbrevMode -> A.AbbrevMode
+    doAbbrevMode A.ResultAbbrev = A.Abbrev
+    doAbbrevMode s = s
+