From 7764ed9326cc2a249c79ec3d05f3d4256c6d2b0d Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 15 Nov 2008 19:29:56 +0000 Subject: [PATCH] Added a module for easily knocking up fragments of occam code to test, but need to remove some of the extravagance in the design (including an unnecessary monad) --- Makefile.am | 1 + common/OccamEDSL.hs | 231 ++++++++++++++++++++++++++++++++++++ common/TestUtils.hs | 9 +- transformations/PassTest.hs | 16 +++ transformations/Unnest.hs | 2 +- 5 files changed, 253 insertions(+), 6 deletions(-) create mode 100644 common/OccamEDSL.hs diff --git a/Makefile.am b/Makefile.am index 8eebaae..d043b91 100644 --- a/Makefile.am +++ b/Makefile.am @@ -169,6 +169,7 @@ tocktest_SOURCES += backends/GenerateCTest.hs tocktest_SOURCES += checks/ArrayUsageCheckTest.hs tocktest_SOURCES += checks/UsageCheckTest.hs tocktest_SOURCES += common/CommonTest.hs +tocktest_SOURCES += common/OccamEDSL.hs tocktest_SOURCES += common/TestFramework.hs tocktest_SOURCES += common/TestHarness.hs tocktest_SOURCES += common/TestUtils.hs diff --git a/common/OccamEDSL.hs b/common/OccamEDSL.hs new file mode 100644 index 0000000..1ae669a --- /dev/null +++ b/common/OccamEDSL.hs @@ -0,0 +1,231 @@ +{- +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 . +-} + +module OccamEDSL (ExpInp, ExpInpT, oSEQ, oPAR, oPROC, oSKIP, oINT, + a, b, c, x, y, z, (*?), (*!), (*:=), decl, oempty, OccamStructuredM, testOccamPass) where + +import Control.Monad.State +import Data.Generics +import Test.HUnit hiding (State) + +import qualified AST as A +import CompState +import Metadata +import Pass +import TestUtils +import Utils + +-- The rough rules for converting occam to pseudo-occam are to stick a lower-case +-- o on the front of keywords, turn colons into dollars, put an asterisk before +-- every operator, empty items into oempty +-- and stick decl on the front of declarations (and indent the scope) and add a do after SEQ and PAR. +-- Other things to remember: +-- * The variables must each be used once, since their declaration is added to +-- the state +-- * Scope is more explicit in this, so you must indent for a variable's scope +-- +-- The following: +-- +-- PROC foo (INT a) +-- : +-- +-- PROC bar () +-- INT y: +-- SEQ +-- BYTE x: +-- x := 3 +-- BYTE z: +-- PAR +-- y := 0 +-- z := 2 +-- y := 1 +-- : +-- +-- becomes: +-- +-- sPROC "foo" [(oINT, a)] +-- oempty +-- $ +-- sPROC "bar" [] ( +-- decl oINT y $ +-- oSEQ $ do +-- decl oBYTE x $ +-- x *:= 3 +-- decl oBYTE z $ +-- sPAR $ do +-- y *:= 0 +-- z *:= 2 +-- y *:= 1 +-- $ +-- oempty + +-- This is an item that allows the expected and input values to be manipulated +-- together, or separately +data ExpInp a = ExpInp a a + +data Monad m => ExpInpT m a = ExpInpT { + fstExpInpT :: m a, + sndExpInpT :: m a } + +instance MonadTrans ExpInpT where + lift m = ExpInpT m m + +instance Monad m => Monad (ExpInpT m) where + return x = ExpInpT (return x) (return x) + (>>=) (ExpInpT x y) f + = ExpInpT (x >>= (fstExpInpT . f)) (y >>= (sndExpInpT . f)) + +runExpInpT :: Monad m => ExpInpT m a -> m (ExpInp a) +runExpInpT (ExpInpT mx my) = do + x <- mx + y <- my + return $ ExpInp x y + +liftExpInp :: Monad m => ExpInp a -> ExpInpT m a +liftExpInp (ExpInp x y) = ExpInpT (return x) (return y) + +instance Functor ExpInp where + fmap f (ExpInp x y) = ExpInp (f x) (f y) + +instance Monad ExpInp where + return x = ExpInp x x + (>>=) (ExpInp x y) f = ExpInp (let ExpInp x' _ = f x in x') + (let ExpInp _ y' = f y in y') + + +newtype OccamStructuredM a b = OccamStructuredM (State (ExpInp CompState, [ExpInp (A.Structured a)]) b) + deriving (Monad) + +instance MonadState s (ExpInpT (State s)) where + get = ExpInpT get get + put x = ExpInpT (put x) (put x) + +instance CSMR (ExpInpT (State CompState)) where + getCompState = get + +type O a = ExpInpT (State CompState) a + +termFunc :: Data a => Maybe (A.Structured a) -> A.Structured a +termFunc (Just s) = s +termFunc Nothing = A.Several emptyMeta [] + +oSEQ, oPAR :: OccamStructuredM A.Process () -> O A.Process +oSEQ = liftM (A.Seq emptyMeta . A.Several emptyMeta) . getStruct +oPAR = liftM (A.Par emptyMeta A.PlainPar . A.Several emptyMeta) . getStruct + +getStruct :: OccamStructuredM a () -> O [A.Structured a] +getStruct (OccamStructuredM m) = ExpInpT + (do s <- get + let (ExpInp s' _, es) = execState m (ExpInp s undefined, []) + put s' + return [x | ExpInp x _ <- es]) + (do s <- get + let (ExpInp _ s', es) = execState m (ExpInp undefined s, []) + put s' + return [x | ExpInp x _ <- es]) + +recordLine :: O (A.Structured a) -> OccamStructuredM a () +recordLine (ExpInpT mx my) = OccamStructuredM $ modify $ \(ExpInp sx sy, ls) -> + let (lx, sx') = runState mx sx + (ly, sy') = runState my sy + in (ExpInp sx' sy', ls ++ [ExpInp lx ly]) + +singlify :: Data a => [A.Structured a] -> A.Structured a +singlify [s] = s +singlify ss = A.Several emptyMeta ss + + +oPROC :: Data a => String -> [(A.Type, A.Variable)] -> O A.Process -> OccamStructuredM a () + -> OccamStructuredM a () +oPROC str params body scope = recordLine $ do + p <- body + s <- getStruct scope + defineProc str [(A.nameName name, A.Original, t) | (t, A.Variable _ name) <- params] + return $ A.Spec emptyMeta (A.Specification emptyMeta (simpleName str) $ + A.Proc emptyMeta A.PlainSpec formals p + ) (singlify s) + where + formals = [A.Formal A.Original t n | (t, A.Variable _ n) <- params] + +oSKIP :: O A.Process +oSKIP = return $ A.Skip emptyMeta + +oINT :: ExpInp A.Type +oINT = return A.Int + +a,b,c,x,y,z :: ExpInp A.Variable +a = return $ variable "a" +b = return $ variable "b" +c = return $ variable "c" +x = return $ variable "x" +y = return $ variable "y" +z = return $ variable "z" + +(*?) :: ExpInp A.Variable -> ExpInp A.Variable -> OccamStructuredM A.Process () +(*?) bch bdest = recordLine $ do + ch <- liftExpInp bch + dest <- liftExpInp bdest + return $ A.Only emptyMeta $ A.Input emptyMeta ch (A.InputSimple emptyMeta [A.InVariable emptyMeta dest]) +(*!), (*:=) :: CanBeExpression e => ExpInp A.Variable -> ExpInp e -> OccamStructuredM + A.Process () +(*!) bch bsrc = recordLine $ do + ch <- liftExpInp bch + src <- liftExpInp bsrc >>* expr + return $ A.Only emptyMeta $ A.Output emptyMeta ch [A.OutExpression emptyMeta + src] +(*:=) bdest bsrc = recordLine $ do + dest <- liftExpInp bdest + src <- liftExpInp bsrc >>* expr + return $ A.Only emptyMeta $ A.Assign emptyMeta [dest] (A.ExpressionList emptyMeta + [src]) + + +decl :: Data a => ExpInp A.Type -> ExpInp A.Variable -> OccamStructuredM a () -> + OccamStructuredM a () +decl bty bvar scope = recordLine $ do + ty <- liftExpInp bty + (A.Variable _ name) <- liftExpInp bvar + defineVariable (A.nameName name) ty + s <- getStruct scope + return $ A.Spec emptyMeta (A.Specification emptyMeta name $ A.Declaration emptyMeta ty) + (singlify s) + + +class CanBeExpression a where + expr :: a -> A.Expression + +instance CanBeExpression A.Variable where + expr = A.ExprVariable emptyMeta + +instance CanBeExpression A.Expression where + expr = id + +instance CanBeExpression Int where + expr = A.Literal emptyMeta A.Int . A.IntLiteral emptyMeta . show + +oempty :: OccamStructuredM a () +oempty = return () + +testOccamPass :: String -> OccamStructuredM () () -> Pass -> Test +testOccamPass str code pass + = let ExpInpT expm inpm = liftM singlify $ getStruct code + (exp, expS) = runState expm emptyState + (inp, inpS) = runState inpm emptyState + in TestCase $ testPassWithStateCheck str exp pass inp (put inpS) (assertEqual + str (csNames expS) . csNames) +--TODO could get fancy with the Metas, and near-predict them diff --git a/common/TestUtils.hs b/common/TestUtils.hs index e75cc4e..339a38b 100644 --- a/common/TestUtils.hs +++ b/common/TestUtils.hs @@ -302,8 +302,7 @@ simpleDefPattern n am sp = tag6 A.NameDef DontCare n n sp am A.Unplaced --{{{ defining things -- | Define something in the initial state. -defineThing :: String -> A.SpecType -> A.AbbrevMode - -> State CompState () +defineThing :: CSM m => String -> A.SpecType -> A.AbbrevMode -> m () defineThing s st am = defineName (simpleName s) $ A.NameDef { A.ndMeta = emptyMeta, @@ -326,12 +325,12 @@ defineIs s t v = defineThing s (A.Is emptyMeta A.Abbrev t v) A.Abbrev -- | Define something original. -defineOriginal :: String -> A.Type -> State CompState () +defineOriginal :: CSM m => String -> A.Type -> m () defineOriginal s t = defineThing s (A.Declaration emptyMeta t) A.Original -- | Define a variable. -defineVariable :: String -> A.Type -> State CompState () +defineVariable :: CSM m => String -> A.Type -> m () defineVariable = defineOriginal -- | Define a channel. @@ -365,7 +364,7 @@ defineFunction s rs as fs = [A.Formal A.ValAbbrev t (simpleName s) | (s, t) <- as] -- | Define a proc. -defineProc :: String -> [(String, A.AbbrevMode, A.Type)] -> State CompState () +defineProc :: CSM m => String -> [(String, A.AbbrevMode, A.Type)] -> m () defineProc s as = defineThing s st A.Original where diff --git a/transformations/PassTest.hs b/transformations/PassTest.hs index d6e4d06..df13d26 100644 --- a/transformations/PassTest.hs +++ b/transformations/PassTest.hs @@ -27,12 +27,14 @@ import Test.HUnit hiding (State) import qualified AST as A import CompState import Metadata +import OccamEDSL import Pattern import SimplifyComms import SimplifyExprs import TagAST import TestUtils import TreeUtils +import Unnest import Utils m :: Meta @@ -613,6 +615,19 @@ testPullRepCounts = TestList "i") $ A.Rep emptyMeta (A.For emptyMeta (intLiteral 0) (intLiteral 5))) $ A.Several emptyMeta []) +testRemoveNesting :: Test +testRemoveNesting = TestList + [ + test "Blank PROC" $ + oPROC "foo" [] ( + oSKIP + ) oempty + ] + where + test :: String -> OccamStructuredM () () -> Test + test name x = testOccamPass name x removeNesting + + --Returns the list of tests: tests :: Test tests = TestLabel "PassTest" $ TestList @@ -625,6 +640,7 @@ tests = TestLabel "PassTest" $ TestList ,testInputCase ,testOutExprs ,testPullRepCounts + ,testRemoveNesting ,testTransformConstr0 ,testTransformProtocolInput ] diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs index c2069a1..faaca3b 100644 --- a/transformations/Unnest.hs +++ b/transformations/Unnest.hs @@ -17,7 +17,7 @@ with this program. If not, see . -} -- | Flatten nested declarations. -module Unnest (unnest) where +module Unnest (unnest, removeNesting) where import Control.Monad.Identity import Control.Monad.State