Implement INITIAL and RESULT abbreviations.
This adds the passes to transform INITIAL into the correct form. Fixes #42.
This commit is contained in:
Adam Sampson
parent
6ee21f76c9
commit
f2352019ab
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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
|
||||
|
|
|
|||
164
transformations/SimplifyAbbrevsTest.hs
Normal file
164
transformations/SimplifyAbbrevsTest.hs
Normal file
|
|
@ -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
|
||||
]
|
||||
Loading…
Reference in New Issue
Block a user