From f2352019ab0720ff2ce2dcf3d8097a8322e9c198 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Tue, 3 Jun 2008 14:57:24 +0000 Subject: [PATCH] Implement INITIAL and RESULT abbreviations. This adds the passes to transform INITIAL into the correct form. Fixes #42. --- Makefile.am | 1 + TestMain.hs | 4 + testcases/initial.occ | 2 +- transformations/SimplifyAbbrevs.hs | 123 ++++++++++++++++++- transformations/SimplifyAbbrevsTest.hs | 164 +++++++++++++++++++++++++ 5 files changed, 290 insertions(+), 4 deletions(-) create mode 100644 transformations/SimplifyAbbrevsTest.hs diff --git a/Makefile.am b/Makefile.am index b14854d..569e8f2 100644 --- a/Makefile.am +++ b/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 diff --git a/TestMain.hs b/TestMain.hs index 9d0fab8..f7335c3 100644 --- a/TestMain.hs +++ b/TestMain.hs @@ -44,6 +44,8 @@ with this program. If not, see . -- -- * "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 ] diff --git a/testcases/initial.occ b/testcases/initial.occ index 7f73e0a..3a42233 100644 --- a/testcases/initial.occ +++ b/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' diff --git a/transformations/SimplifyAbbrevs.hs b/transformations/SimplifyAbbrevs.hs index f438f56..4a0c92b 100644 --- a/transformations/SimplifyAbbrevs.hs +++ b/transformations/SimplifyAbbrevs.hs @@ -17,12 +17,21 @@ with this program. If not, see . -} -- | 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 - return + (applyDepthSM doStructured) + 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 diff --git a/transformations/SimplifyAbbrevsTest.hs b/transformations/SimplifyAbbrevsTest.hs new file mode 100644 index 0000000..9e21979 --- /dev/null +++ b/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 . +-} + +-- | 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 + ]