diff --git a/Main.hs b/Main.hs
index 7c6a085..4df1eea 100644
--- a/Main.hs
+++ b/Main.hs
@@ -276,10 +276,12 @@ compileFull inputFile moutputFile
("-", Nothing) -> dieReport (Nothing, "Must specify an output file when using full-compile mode")
(file, _) -> return file
- let extension = case csBackend optsPS of
- BackendC -> ".c"
- BackendCPPCSP -> ".cpp"
- _ -> ""
+ let (cExtension, hExtension)
+ = case csBackend optsPS of
+ BackendC -> (".tock.c", ".tock.h")
+ BackendCPPCSP -> (".tock.cpp", ".tock.hpp")
+ BackendCHP -> (".hs", error "CHP backend")
+ _ -> ("", "")
-- Translate input file to C/C++
let cFile = outputFile ++ cExtension
@@ -330,9 +332,17 @@ compileFull inputFile moutputFile
-- For C++, just compile the source file directly into a binary
BackendCPPCSP ->
- exec $ cxxCommand cFile outputFile
- (csCompilerFlags optsPS ++ " " ++ csCompilerLinkFlags optsPS)
+ do cs <- lift getCompState
+ if csHasMain optsPS
+ then let otherOFiles = [usedFile ++ ".tock.o"
+ | usedFile <- Set.toList $ csUsedFiles cs]
+ in exec $ cxxCommand cFile outputFile
+ (concat (intersperse " " otherOFiles) ++ " " ++ csCompilerFlags optsPS ++ " " ++ csCompilerLinkFlags optsPS)
+ else exec $ cxxCommand cFile (outputFile ++ ".tock.o")
+ ("-c " ++ csCompilerFlags optsPS)
+ BackendCHP ->
+ exec $ hCommand cFile outputFile
_ -> dieReport (Nothing, "Cannot use specified backend: "
++ show (csBackend optsPS)
++ " with full-compile mode")
@@ -477,8 +487,10 @@ compile mode fn (outHandles@(outHandle, _), headerName)
let generator :: A.AST -> PassM ()
generator
= case csBackend optsPS of
- BackendC -> generateC outHandle
- BackendCPPCSP -> generateCPPCSP outHandle
+ BackendC -> generateC outHandles headerName
+ BackendCHP -> generateCHP outHandle
+ BackendCPPCSP -> generateCPPCSP outHandles headerName
+
BackendDumpAST -> liftIO . hPutStr outHandle . pshow
BackendSource -> (liftIO . hPutStr outHandle) <.< showCode
generator ast2
diff --git a/backends/BackendPasses.hs b/backends/BackendPasses.hs
index 8ff74c0..cd4e4d8 100644
--- a/backends/BackendPasses.hs
+++ b/backends/BackendPasses.hs
@@ -21,7 +21,8 @@ module BackendPasses (backendPasses, transformWaitFor, declareSizesArray) where
import Control.Monad.Error
import Control.Monad.State
-import Data.Generics
+import Data.Generics (Data)
+import Data.Generics.Polyplate
import Data.List
import qualified Data.Map as Map
import Data.Maybe
@@ -39,8 +40,8 @@ import Traversal
import Types
import Utils
-squashArrays :: [Pass]
-squashArrays =
+backendPasses :: [Pass A.AST]
+backendPasses =
-- Note that removeDirections is only for C, whereas removeUnneededDirections
-- is for all backends
[ removeDirectionsForC
@@ -59,8 +60,8 @@ prereq = Prop.agg_namesDone ++ Prop.agg_typesDone ++ Prop.agg_functionsGone ++ [
-- | Remove all variable directions for the C backend.
-- They're unimportant in occam code once the directions have been checked,
-- and this somewhat simplifies the work of the later passes.
-removeDirections :: Pass
-removeDirections
+removeDirectionsForC :: PassOn A.Variable
+removeDirectionsForC
= occamAndCOnlyPass "Remove variable directions"
prereq
[Prop.directionsRemoved]
@@ -193,20 +194,28 @@ findVarSizes skip (A.VariableSizes m v)
mn <- getSizes m (A.VariableSizes m v) es
return (mn, fmap (A.Variable m) mn, es)
+type DeclSizeOps = (ExtOpMSP BaseOp) `ExtOpMP` A.Process
-- | Declares a _sizes array for every array, statically sized or dynamically sized.
-- For each record type it declares a _sizes array too.
-declareSizesArray :: PassOnStruct
+declareSizesArray :: PassASTOnOps DeclSizeOps
declareSizesArray = occamOnlyPass "Declare array-size arrays"
(prereq ++ [Prop.slicesSimplified, Prop.arrayConstructorsRemoved])
[Prop.arraySizesDeclared]
- (applyDepthSM doStructured)
+ (passOnlyOnAST "declareSizesArray"
+ (\t -> do pushPullContext
+ t' <- recurse t >>= applyPulled
+ popPullContext
+ return t'
+ ))
where
- ops :: OpsM PassM
- ops = baseOp `extOpS` doStructured `extOp` doProcess
- recurse, descend :: Data a => Transform a
- recurse = makeRecurse ops
- descend = makeDescend ops
+ ops :: DeclSizeOps
+ ops = baseOp `extOpMS` (ops, doStructured) `extOpM` doProcess
+
+ recurse :: RecurseM PassM DeclSizeOps
+ recurse = makeRecurseM ops
+ descend :: DescendM PassM DeclSizeOps
+ descend = makeDescendM ops
defineSizesName :: Meta -> A.Name -> A.SpecType -> PassM ()
defineSizesName m n spec
@@ -289,7 +298,9 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
lit = A.ArrayListLiteral m $ A.Several m $ map (A.Only m) es
t = A.Array [A.Dimension $ makeConstant m (length es)] A.Int
- doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
+ doStructured :: (Data a, PolyplateM (A.Structured a) DeclSizeOps () PassM
+ , PolyplateM (A.Structured a) () DeclSizeOps PassM)
+ => Transform (A.Structured a)
doStructured str@(A.Spec m sp@(A.Specification m' n spec) s)
= do t <- typeOfSpec spec
case (spec, t) of
@@ -329,43 +340,8 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
return $ A.Spec m (A.Specification m n newspec) s'
_ -> descend str
doStructured s = descend s
-
- transformExternal :: Meta -> ExternalType -> [A.Formal] -> PassM [A.Formal]
- transformExternal m extType args
- = do (args', newargs) <- transformFormals (Just extType) m args
- sequence_ [defineSizesName m n (A.Declaration m t)
- | A.Formal _ t n <- newargs]
- return args'
-
--- | A pass for adding _sizes parameters to PROC arguments
--- TODO in future, only add _sizes for variable-sized parameters
-addSizesFormalParameters :: Pass
-addSizesFormalParameters = occamOnlyPass "Add array-size arrays to PROC headers"
- (prereq ++ [Prop.arraySizesDeclared])
- []
- (applyDepthM doSpecification)
- where
- doSpecification :: Bool -> A.Specification -> PassM A.Specification
- doSpecification ext (A.Specification m n (A.Proc m' sm args body))
- = do (args', newargs) <- transformFormals ext m args
- let newspec = A.Proc m' sm args' body
- modify (\cs -> cs {csNames = Map.adjust (\nd -> nd { A.ndSpecType = newspec }) (A.nameName n) (csNames cs)})
- mapM_ (recordArg m') newargs
- return $ A.Specification m n newspec
- doSpecification _ st = return st
- recordArg :: Meta -> A.Formal -> PassM ()
- recordArg m (A.Formal am t n)
- = defineName n $ A.NameDef {
- A.ndMeta = m
- ,A.ndName = A.nameName n
- ,A.ndOrigName = A.nameName n
- ,A.ndSpecType = A.Declaration m t
- ,A.ndAbbrevMode = A.ValAbbrev
- ,A.ndNameSource = A.NameNonce
- ,A.ndPlacement = A.Unplaced}
-
- transformFormals :: Bool -> Meta -> [A.Formal] -> PassM ([A.Formal], [A.Formal])
+ transformFormals :: Maybe ExternalType -> Meta -> [A.Formal] -> PassM ([A.Formal], [A.Formal])
transformFormals _ _ [] = return ([],[])
transformFormals ext m ((f@(A.Formal am t n)):fs)
= case (t, ext) of
@@ -396,13 +372,6 @@ addSizesFormalParameters = occamOnlyPass "Add array-size arrays to PROC headers"
_ -> do (rest, new) <- transformFormals ext m fs
return (f : rest, new)
--- | A pass for adding _sizes parameters to actuals in PROC calls
-addSizesActualParameters :: Pass
-addSizesActualParameters = occamOnlyPass "Add array-size arrays to PROC calls"
- (prereq ++ [Prop.arraySizesDeclared])
- []
- (applyDepthM doProcess)
- where
doProcess :: A.Process -> PassM A.Process
doProcess (A.ProcCall m n params)
= do ext <- getCompState >>* csExternals >>* lookup (A.nameName n)
@@ -462,12 +431,12 @@ simplifySlices = occamOnlyPass "Simplify array slices"
-- | Finds all processes that have a MOBILE parameter passed in Abbrev mode, and
-- add the communication back at the end of the process.
-mobileReturn :: Pass
+{-
+mobileReturn :: PassOnOps (ExtOpMSP BaseOp `ExtOpMP` A.Process)
mobileReturn = cOnlyPass "Add MOBILE returns" [] [] recurse
where
- ops = baseOp `extOpS` doStructured `extOp` doProcess
+ ops = baseOp `extOpMS` doStructured `extOpM` doProcess
- descend, recurse :: Data a => Transform a
descend = makeDescend ops
recurse = makeRecurse ops
@@ -542,3 +511,4 @@ mobileReturn = cOnlyPass "Add MOBILE returns" [] [] recurse
modifyName n (\nd -> nd {A.ndSpecType = newSpec})
return $ A.Spec msp (A.Specification m n newSpec) scope'
doStructured s = descend s
+-}
diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs
index d45f22b..187c002 100644
--- a/backends/GenerateC.hs
+++ b/backends/GenerateC.hs
@@ -912,6 +912,7 @@ cgenArraySubscript check v es
-- smart C compiler should be able to work it out...
genPlainSub :: (Int -> CGen ()) -> [(Meta, CGen ())] -> [Int] -> [CGen ()]
genPlainSub _ [] _ = []
+ genPlainSub _ (_:_) [] = [dieP (findMeta v) "Fewer subscripts than dimensions in genPlainSub"]
genPlainSub genDim ((m,e):es) (sub:subs)
= gen : genPlainSub genDim es subs
where
diff --git a/backends/GenerateCHP.hs b/backends/GenerateCHP.hs
index 2a38186..b2fcc6f 100644
--- a/backends/GenerateCHP.hs
+++ b/backends/GenerateCHP.hs
@@ -44,6 +44,7 @@ import Control.Monad.Trans
import Data.Char
import Data.Generics
import Data.List
+import Data.Maybe
import System.IO
import Text.Printf
@@ -143,7 +144,7 @@ genSpec (A.Specification _ n (A.Proc _ _ params body))
genName n
sequence [genName pn >> tell [" "] | A.Formal _ _ pn <- params]
tell ["= "]
- withIndent $ genProcess body
+ withIndent $ genProcess (fromJust body)
where
doFormalAndArrow :: A.Formal -> CGen ()
doFormalAndArrow (A.Formal _ t _)
@@ -155,6 +156,7 @@ genSpec (A.Specification _ n (A.Declaration _ t))
tell ["\n"]
genName n
tell [" = error \"Variable ", A.nameName n, " used uninitialised\"\n"]
+{-
genSpec (A.Specification _ n (A.IsExpr _ _ t e))
= do genName n
tell [" :: "]
@@ -164,6 +166,7 @@ genSpec (A.Specification _ n (A.IsExpr _ _ t e))
tell [" = "]
genExpression e
tell ["\n"]
+-}
genSpec _ = genMissing "genSpec" >> tell ["\n"]
genProcess :: A.Process -> CGen ()
diff --git a/common/EvalLiterals.hs b/common/EvalLiterals.hs
index d447085..f4ee0ac 100644
--- a/common/EvalLiterals.hs
+++ b/common/EvalLiterals.hs
@@ -184,13 +184,9 @@ evalByteLiteral m _ _ = throwError (Just m, "Bad BYTE literal")
-- | Resolve a datatype into its underlying type -- i.e. if it's a named data
-- type, then return the underlying real type. This will recurse.
underlyingType :: forall m. (CSMR m, Die m) => Meta -> A.Type -> m A.Type
-underlyingType m = applyDepthM doType
- where
- doType :: A.Type -> m A.Type
- -- This is fairly subtle: after resolving a user type, we have to recurse
- -- on the resulting type.
- doType t@(A.UserDataType _) = resolveUserType m t >>= underlyingType m
- doType t = return t
+underlyingType m = applyTopDownM (resolveUserType m)
+ -- After resolving a user type, we have to recurse
+ -- on the resulting type, so we must use a top-down transformation.
-- | Like underlyingType, but only do the "outer layer": if you give this a
-- user type that's an array of user types, then you'll get back an array of
@@ -202,3 +198,4 @@ resolveUserType m (A.UserDataType n)
A.DataType _ t -> resolveUserType m t
_ -> dieP m $ "Not a type name: " ++ show n
resolveUserType _ t = return t
+
diff --git a/common/GenericUtils.hs b/common/GenericUtils.hs
deleted file mode 100644
index 21148e9..0000000
--- a/common/GenericUtils.hs
+++ /dev/null
@@ -1,245 +0,0 @@
-{-
-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 .
--}
-
--- | Utilities for generic operations.
---
--- This code was inspired by Neil Mitchell's Uniplate library.
--- 'typeContains' is faster than PlateData's equivalent at the cost of some
--- flexibility: it'll only work for types that it knows about (which can be
--- added to in the definition of 'contains').
-module GenericUtils (
- TypeKey, typeKey
- , TypeSet, makeTypeSet
- , containsTypes
- , gmapMFor
- , gmapMForRoute
- , routeModify, routeGet, routeSet, Route(..), (@->), routeIdentity, routeId, routeList
- , route22, route23, route33, route34, route44, route45, route55
- ) where
-
-import Control.Monad.Identity
-import Control.Monad.State
-import Data.Generics
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as IntSet
-import Data.List
-import Data.Typeable
-import System.IO.Unsafe
-
-import qualified AST as A
-import Data.Generics.Polyplate.Route
-import TreeUtils
-import Utils
-
--- | A type identifier.
-type TypeKey = Int
-
--- | Given a witness for a type, return its 'TypeKey'.
-typeKey :: Typeable a => a -> TypeKey
-typeKey x = unsafePerformIO $ typeRepKey $ typeOf x
-
--- | Given a witness for a type, return witnesses for all the types that its
--- constructors take.
-constrArgTypes :: (Data a, Typeable a) => a -> [DataBox]
-constrArgTypes x = if isAlgType dtype then concatMap f constrs else []
- where
- f constr = gmapQ DataBox (asTypeOf (fromConstr constr) x)
- constrs = dataTypeConstrs dtype
- dtype = dataTypeOf x
-
--- | Given a witness for a type, return a map from type keys to witnesses for
--- all the types it contains recursively.
-containedTypes :: (Data a, Typeable a) => a -> IntMap DataBox
-containedTypes start = containedTypes' (DataBox start) IntMap.empty
- where
- containedTypes' :: DataBox -> IntMap DataBox -> IntMap DataBox
- containedTypes' box@(DataBox thisType) seen
- = if thisKey `IntMap.member` seen
- then seen
- else foldl (\s t -> containedTypes' t s)
- (IntMap.insert thisKey box seen)
- (constrArgTypes thisType)
- where
- thisKey = typeKey thisType
-
--- | A map from type keys to the other type keys reachable from them.
-type ContainsMap = IntMap IntSet
-
--- | A map of reachable types.
--- At the moment this only knows about types reachable from the AST.
-contains :: ContainsMap
-contains = IntMap.fromList [(typeKey t,
- IntMap.keysSet $ containedTypes t)
- | DataBox t <- IntMap.elems allTypes]
- where
- allTypes = containedTypes (undefined :: A.AST)
-
--- | Does a value contain any of the listed types?
--- (A value always contains its own type.)
-containsTypes :: Data t => t -> [TypeKey] -> Bool
-containsTypes x targets
- = or $ map containsType targets
- where
- start :: TypeKey
- start = typeKey x
-
- containsType :: TypeKey -> Bool
- containsType target
- | start == target = True
- | otherwise = case IntMap.lookup start contains of
- Just set -> target `IntSet.member` set
- Nothing -> True -- can't tell, so it might be
-
--- | A decision about what to do when we find a particular type during a
--- generic operation.
-data TypeDecision =
- -- | This is one of the types we're looking for.
- Hit
- -- | This isn't one of the types we're looking for, but it might contain one
- -- of them.
- | Through
- -- | This isn't one of the types we're looking for, and there's no need to
- -- look inside it.
- | Miss
-
--- | A set of type information for use by 'gmapMFor'.
-type TypeSet = IntMap TypeDecision
-
--- | Make a 'TypeSet' from a list of 'TypeKey's.
-makeTypeSet :: [TypeKey] -> TypeSet
-makeTypeSet targets
- = IntMap.fromList [(tk, decide tk)
- | tk <- IntMap.keys contains]
- where
- decide :: TypeKey -> TypeDecision
- decide tk
- | tk `elem` targets = Hit
- | tk `IntSet.member` allThrough = Through
- | otherwise = Miss
-
- allThrough :: IntSet
- allThrough
- = IntSet.fromList $ filter containsThis $ IntMap.keys contains
- where
- containsThis tk
- = case IntMap.lookup tk contains of
- Just set -> or $ map (`IntSet.member` set) targets
- Nothing -> False
-
--- | Type-smart generic mapM.
--- This is like 'gmapM', but it only applies the function to arguments that
--- could contain any of the target types.
-gmapMFor :: (Monad m, Data t) =>
- TypeSet -- ^ Target types
- -> (forall s. Data s => s -> m s) -- ^ Function to apply
- -> (t -> m t) -- ^ Generic operation
-gmapMFor typeset f = gmapM (each f)
- where
- each :: (Monad m, Data t) =>
- (forall s. Data s => s -> m s) -> (t -> m t)
- each f x
- = case IntMap.lookup (typeKey x) typeset of
- Just Hit -> f x
- Just Through -> gmapM (each f) x
- Just Miss -> return x
- Nothing -> return x
-
-
--- | Acts just like gmapMFor, except that it also tells you the route to the node
--- that your generic function is being applied to.
-gmapMForRoute :: forall m t. (Monad m, Data t) =>
- TypeSet ->
- (forall s. Data s => (s, Route s t) -> m s)
- -> (t -> m t)
-gmapMForRoute typeset f = gmapMWithRoute (each f)
- where
- each :: Data u => (forall s. Data s => (s, Route s t) -> m s)
- -> ((u, Route u t) -> m u)
- each f (x, route)
- = case IntMap.lookup (typeKey x) typeset of
- Just Hit -> f (x, route)
- Just Through -> gmapMWithRoute (\(y, route') -> each f (y, route @-> route')) x
- Just Miss -> return x
- Nothing -> return x
-
--- A helper for gmapMForRoute that maps over the direct children and supplies routes
-gmapMWithRoute :: forall a m. (Monad m, Data a) => (forall b. Data b => (b, Route
- b a) -> m b) -> a -> m a
-gmapMWithRoute f = gmapFuncs [GM {unGM = f' n} | n <- [0..]]
- where
- f' :: Int -> (forall b. Data b => b -> m b)
- f' n x = f (x, makeRoute' n)
-
--- Given a number, makes a route function for that child:
-makeRoute' :: (Data s, Data t) => Int -> Route s t
-makeRoute' target = makeRoute [target] (\f -> gmapFuncs [mkM' (if n == target then f else return) | n <- [0..]])
-
-decomp22 :: (Monad m, Data a, Typeable a0, Typeable a1) => (a0 -> a1 -> a) -> (a1 -> m a1) -> (a -> m a)
-decomp22 con f1 = decomp2 con return f1
-
-decomp23 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => (a0 -> a1 -> a2 -> a) -> (a1 -> m a1) -> (a -> m a)
-decomp23 con f1 = decomp3 con return f1 return
-
-decomp33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => (a0 -> a1 -> a2 -> a) -> (a2 -> m a2) -> (a -> m a)
-decomp33 con f2 = decomp3 con return return f2
-
-decomp34 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
- (a0 -> a1 -> a2 -> a3 -> a) -> (a2 -> m a2) -> (a -> m a)
-decomp34 con f2 = decomp4 con return return f2 return
-
-decomp44 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
- (a0 -> a1 -> a2 -> a3 -> a) -> (a3 -> m a3) -> (a -> m a)
-decomp44 con f3 = decomp4 con return return return f3
-
-decomp45 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
- (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a3 -> m a3) -> (a -> m a)
-decomp45 con f3 = decomp5 con return return return f3 return
-
-decomp55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
- (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a4 -> m a4) -> (a -> m a)
-decomp55 con f4 = decomp5 con return return return return f4
-
-route22 :: (Data a, Typeable a0, Typeable a1) => Route a b -> (a0 -> a1 -> a) -> Route a1 b
-route22 route con = route @-> makeRoute [1] (decomp22 con)
-
-route23 :: (Data a, Typeable a0, Typeable a1, Typeable a2) => Route a b -> (a0 -> a1 -> a2 -> a) -> Route a1 b
-route23 route con = route @-> makeRoute [1] (decomp23 con)
-
-route33 :: (Data a, Typeable a0, Typeable a1, Typeable a2) => Route a b -> (a0 -> a1 -> a2 -> a) -> Route a2 b
-route33 route con = route @-> makeRoute [2] (decomp33 con)
-
-route34 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
- Route a b -> (a0 -> a1 -> a2 -> a3 -> a) -> Route a2 b
-route34 route con = route @-> makeRoute [2] (decomp34 con)
-
-route44 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) =>
- Route a b -> (a0 -> a1 -> a2 -> a3 -> a) -> Route a3 b
-route44 route con = route @-> makeRoute [3] (decomp44 con)
-
-route45 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
- Route a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> Route a3 b
-route45 route con = route @-> makeRoute [3] (decomp45 con)
-
-route55 :: (Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) =>
- Route a b -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> Route a4 b
-route55 route con = route @-> makeRoute [4] (decomp55 con)
-
--- TODO we should be able to provide versions of these that do not need to know
--- the constructor or the arity
diff --git a/common/Types.hs b/common/Types.hs
index 74137ea..3060699 100644
--- a/common/Types.hs
+++ b/common/Types.hs
@@ -363,28 +363,6 @@ abbrevModeOfSpec s
A.RetypesExpr _ am _ _ -> am
_ -> A.Original
--- | Resolve a datatype into its underlying type -- i.e. if it's a named data
--- type, then return the underlying real type. This will recurse.
-underlyingType :: forall m. (CSMR m, Die m) => Meta -> A.Type -> m A.Type
-underlyingType m = applyDepthM doType
- where
- doType :: A.Type -> m A.Type
- -- This is fairly subtle: after resolving a user type, we have to recurse
- -- on the resulting type.
- doType t@(A.UserDataType _) = resolveUserType m t >>= underlyingType m
- doType t = return t
-
--- | Like underlyingType, but only do the "outer layer": if you give this a
--- user type that's an array of user types, then you'll get back an array of
--- user types.
-resolveUserType :: (CSMR m, Die m) => Meta -> A.Type -> m A.Type
-resolveUserType m (A.UserDataType n)
- = do st <- specTypeOfName n
- case st of
- A.DataType _ t -> resolveUserType m t
- _ -> dieP m $ "Not a type name: " ++ show n
-resolveUserType _ t = return t
-
-- | Add array dimensions to a type; if it's already an array it'll just add
-- the new dimensions to the existing array.
addDimensions :: [A.Dimension] -> A.Type -> A.Type
diff --git a/common/Utils.hs b/common/Utils.hs
index 56b725e..bc4ea6a 100644
--- a/common/Utils.hs
+++ b/common/Utils.hs
@@ -376,5 +376,47 @@ eitherToMaybe = either (const Nothing) Just
labelMapWithNodeId :: DynGraph gr => (Node -> a -> b) -> gr a c -> gr b c
labelMapWithNodeId f = gmap (\(x,n,l,y) -> (x,n,f n l,y))
+-- This is quite inefficient, but I can't see an easier way:
+labelMapWithNodeIdM :: (DynGraph gr, Monad m) => (Node -> a -> m b) -> gr a c -> m (gr b c)
+labelMapWithNodeIdM f gr
+ = let unsequencedMap = ufold (\(x, n, l, y) -> Map.insert n (f n l)) Map.empty gr
+ in do mp <- T.sequence unsequencedMap
+ return $ gmap (\(x,n,l,y) -> (x,n,fromJust $ Map.lookup n mp,y)) gr
+
+-- | Does a reverse lookup in a Map (looks up the key for a value).
reverseLookup :: (Ord k, Eq v) => v -> Map.Map k v -> Maybe k
reverseLookup x m = lookup x $ map revPair $ Map.toList m
+
+-- Where you have a wrapper for an inner monadic action, but you want to apply
+-- this to an action that has state wrapped around it:
+liftWrapStateT :: Monad m => (forall b. m b -> m b) -> StateT s m a -> StateT s m a
+liftWrapStateT wrap m
+ = do st <- get
+ (x, st') <- lift $ wrap (runStateT m st)
+ put st'
+ return x
+
+-- The foldM equivalent of foldl1:
+foldM1 :: Monad m => (a -> a -> m a) -> [a] -> m a
+foldM1 f (x:xs) = foldM f x xs
+foldM1 _ [] = fail "Empty list in foldM1"
+
+-- | A shortcut for concat and intersperse.
+-- For example, @joinWith " " names@ is the same as @concat (intersperse " "
+-- names)@
+joinWith :: [a] -> [[a]] -> [a]
+joinWith x = concat . intersperse x
+
+-- | Replaces all instances of the given sub-pattern with a replacement in a larger
+-- list
+replace :: Eq a => ([a],[a]) -> [a] -> [a]
+replace ([],_) big = big
+replace (find, repl) big
+ = let (ignore, poss) = span (/= head find) big in
+ if null poss
+ then big
+ else ignore ++
+ if find `isPrefixOf` poss
+ then repl ++ replace (find, repl) (drop (length find) poss)
+ else head poss : replace (find, repl) (tail poss)
+
diff --git a/flow/FlowUtils.hs b/flow/FlowUtils.hs
index 3e86be5..a6dc333 100644
--- a/flow/FlowUtils.hs
+++ b/flow/FlowUtils.hs
@@ -303,6 +303,8 @@ joinPairs m mod nodes
= do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge (ESeq Nothing) s e) nodes
return (fst (head nodes), snd (last nodes))
+decomp11 :: (Monad m, Data a, Typeable a0) => (a0 -> a) -> (a0 -> m a0) -> (a -> m a)
+decomp11 con f1 = decomp1 con f1
decomp22 :: (Monad m, Data a, Typeable a0, Typeable a1) => (a0 -> a1 -> a) -> (a1 -> m a1) -> (a -> m a)
decomp22 con f1 = decomp2 con return f1
@@ -329,6 +331,9 @@ decomp55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3
(a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a4 -> m a4) -> (a -> m a)
decomp55 con f4 = decomp5 con return return return return f4
+route11 :: (Data a, Typeable a0) => Route a b -> (a0 -> a) -> Route a0 b
+route11 route con = route @-> makeRoute [0] (decomp11 con)
+
route22 :: (Data a, Typeable a0, Typeable a1) => Route a b -> (a0 -> a1 -> a) -> Route a1 b
route22 route con = route @-> makeRoute [1] (decomp22 con)
diff --git a/frontends/OccamPasses.hs b/frontends/OccamPasses.hs
index d8f0917..9a72ebb 100644
--- a/frontends/OccamPasses.hs
+++ b/frontends/OccamPasses.hs
@@ -28,6 +28,7 @@ import System.IO
import qualified AST as A
import CompState
+import Errors
import EvalConstants
import EvalLiterals
import GenerateC -- For nameString
@@ -55,7 +56,7 @@ occamPasses =
, pushUpDirections
]
-writeIncFile :: Pass
+writeIncFile :: Pass A.AST
writeIncFile = occamOnlyPass "Write .inc file" [] []
(passOnlyOnAST "writeIncFile" (\t ->
do out <- getCompState >>* csOutputIncFile
@@ -113,20 +114,22 @@ fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"
where
doExpression :: A.Expression -> PassM A.Expression
doExpression (A.Literal m prevT lit@(A.ArrayListLiteral _ expr))
- = do prevT' <- underlyingType m prevT
- t' <- doExpr [] (getDims prevT') expr
+ = do dims <- getDims prevT
+ t' <- doExpr [] dims expr
return $ A.Literal m t' lit
where
- getDims :: A.Type -> [A.Dimension]
- getDims (A.Array ds _) = ds
- getDims t = error $ "Cannot deduce dimensions of array constructor: " ++ show t
+ getDims :: A.Type -> PassM [A.Dimension]
+ getDims (A.Array ds _) = return ds
+ getDims t@(A.UserDataType {}) = resolveUserType m t >>= getDims
+ getDims t = dieP m $ "Cannot deduce dimensions of array constructor: " ++ show t
- innerType :: A.Type -> A.Type
- innerType (A.Array _ t) = t
- innerType t = error $ "Cannot deduce dimensions of array constructor: " ++ show t
+ innerType :: A.Type -> PassM A.Type
+ innerType (A.Array _ t) = return t
+ innerType t@(A.UserDataType {}) = resolveUserType m t >>= innerType
+ innerType t = dieP m $ "Cannot deduce dimensions of array constructor: " ++ show t
doExpr :: [A.Dimension] -> [A.Dimension] -> A.Structured A.Expression -> PassM A.Type
- doExpr prev (d:_) (A.Several m []) = return $ A.Array (prev ++ [d]) $ innerType prevT
+ doExpr prev (d:_) (A.Several m []) = innerType prevT >>* A.Array (prev ++ [d])
doExpr prev (d:dims) (A.Several m ss@(s:_))
= doExpr (prev ++ [d]) dims s
doExpr prev _ (A.Only _ e)
@@ -191,17 +194,18 @@ foldConstants = occamOnlyPass "Fold constants"
return s
-- | Check that things that must be constant are.
-checkConstants :: PassOn2 A.Dimension A.Option
+checkConstants :: PassOn2 A.Type A.Option
checkConstants = occamOnlyPass "Check mandatory constants"
[Prop.constantsFolded, Prop.arrayConstructorTypesDone]
[Prop.constantsChecked]
- (applyDepthM2 doDimension doOption)
+ recurse
where
- ops = baseOp `extOp` doType `extOp` doOption
+ ops = baseOp `extOpM` doType `extOpM` doOption
- descend, recurse :: Data a => a -> PassM a
- descend = makeDescend ops
- recurse = makeRecurse ops
+ descend :: DescendM PassM (BaseOp `ExtOpMP` A.Type `ExtOpMP` A.Option)
+ descend = makeDescendM ops
+ recurse :: RecurseM PassM (BaseOp `ExtOpMP` A.Type `ExtOpMP` A.Option)
+ recurse = makeRecurseM ops
doType :: A.Type -> PassM A.Type
-- Avoid checking that mobile dimensions are constant:
diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs
index 7d60d0c..528a60b 100644
--- a/frontends/OccamTypes.hs
+++ b/frontends/OccamTypes.hs
@@ -646,7 +646,6 @@ type InferTypeOps
`ExtOpMP` A.Subscript
`ExtOpMP` A.Replicator
`ExtOpMP` A.Alternative
- `ExtOpMP` A.InputMode
`ExtOpMP` A.Process
`ExtOpMP` A.Variable
@@ -766,12 +765,23 @@ inferTypes = occamOnlyPass "Infer types"
where
direct = error "Cannot direct channels passed to FUNCTIONs"
- doActuals :: Data a => Meta -> A.Name -> [A.Formal] -> Transform [a]
- doActuals m n fs as
+ opsMatch (opA, _, tsA) (opB, _, tsB) = (opA == opB) && (tsA `typesEqForOp` tsB)
+
+ typesEqForOp :: [A.Type] -> [A.Type] -> Bool
+ typesEqForOp tsA tsB = (length tsA == length tsB) && (and $ zipWith typeEqForOp tsA tsB)
+
+ typeEqForOp :: A.Type -> A.Type -> Bool
+ typeEqForOp (A.Array ds t) (A.Array ds' t')
+ = (length ds == length ds') && typeEqForOp t t'
+ typeEqForOp t t' = t == t'
+
+ doActuals :: (PolyplateM a InferTypeOps () PassM, Data a) => Meta -> A.Name -> [A.Formal] ->
+ (Meta -> A.Direction -> Transform a) -> Transform [a]
+ doActuals m n fs applyDir as
= do checkActualCount m n fs as
sequence [doActual m applyDir t a | (A.Formal _ t _, a) <- zip fs as]
- doActual :: Data a => Meta -> (Meta -> A.Direction -> Transform a) -> A.Type -> Transform a
+ doActual :: (PolyplateM a InferTypeOps () PassM, Data a) => Meta -> (Meta -> A.Direction -> Transform a) -> A.Type -> Transform a
doActual m applyDir (A.ChanEnd dir _ _) a = recurse a >>= applyDir m dir
doActual m _ t a = inTypeContext (Just t) $ recurse a
@@ -1014,7 +1024,6 @@ inferTypes = occamOnlyPass "Infer types"
`extOpM` descend
`extOpM` descend
`extOpM` descend
- `extOpM` descend
`extOpM` (doVariable r)
descend :: DescendM PassM InferTypeOps
descend = makeDescendM ops
diff --git a/frontends/RainPasses.hs b/frontends/RainPasses.hs
index d943a26..208cad2 100644
--- a/frontends/RainPasses.hs
+++ b/frontends/RainPasses.hs
@@ -202,23 +202,21 @@ transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges int
A.For eachMeta begin newCount (makeConstant eachMeta 1)
doSpec s = return s
--- | A pass that changes all the Rain range constructor expressions into the more general array constructor expressions
---
--- TODO make sure when the range has a bad order that an empty list is
--- returned
-transformRangeRep :: Pass
+transformRangeRep :: PassOn A.Expression
transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into more general array constructors"
(Prop.agg_typesDone ++ [Prop.eachRangeTransformed])
[Prop.rangeTransformed]
- (applyDepthM doExpression)
+ (applyBottomUpM doExpression)
where
doExpression :: A.Expression -> PassM A.Expression
- doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
- = do A.Specification _ rep _ <- makeNonceVariable "rep_constr" m A.Int A.ValAbbrev
- let count = addOne $ subExprs end begin
- return $ A.ExprConstr m $ A.RepConstr m t rep
- (A.For m begin count $ makeConstant m 1)
- (A.ExprVariable m $ A.Variable m rep)
+ doExpression (A.Literal m t (A.RangeLiteral m' begin end))
+ = do count <- subExprs end begin >>= addOne
+ let rep = A.Rep m' $ A.For m' begin count $ makeConstant m 1
+ spec@(A.Specification _ repN _) <- defineNonce m' "rep_constr"
+ rep A.ValAbbrev
+ return $ A.Literal m t $ A.ArrayListLiteral m' $
+ A.Spec m' spec $ A.Only m' $
+ (A.ExprVariable m' $ A.Variable m' repN)
doExpression e = return e
-- TODO this is almost certainly better figured out from the CFG
diff --git a/pass/PassList.hs b/pass/PassList.hs
index 11e53d6..b601a72 100644
--- a/pass/PassList.hs
+++ b/pass/PassList.hs
@@ -68,8 +68,8 @@ commonPasses opts = concat $
, enablePassesWhen csUsageChecking
[abbrevCheckPass]
, backendPasses
- , [pass "Removing unused variables" [] []
- (passOnlyOnAST "checkUnusedVar" (runChecks checkUnusedVar))]
+-- , [pass "Removing unused variables" [] []
+-- (passOnlyOnAST "checkUnusedVar" (runChecks checkUnusedVar))]
]
filterPasses :: CompState -> [Pass t] -> [Pass t]
diff --git a/pass/Traversal.hs b/pass/Traversal.hs
index 356d42e..f443c88 100644
--- a/pass/Traversal.hs
+++ b/pass/Traversal.hs
@@ -19,9 +19,9 @@ with this program. If not, see .
-- | Traversal strategies over the AST and other data types. This is now mainly
-- a collection of extra Tock-specific utilities that go on top of Polyplate
module Traversal (
- TransformM, Transform, TransformStructured
+ TransformM, Transform, TransformStructured, TransformStructured'
, CheckM, Check
- , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct
+ , ExtOpMP, ExtOpMS, ExtOpMSP, extOpMS, PassOnStruct, PassASTOnStruct
, applyBottomUpMS
, module Data.Generics.Polyplate
, module Data.Generics.Polyplate.Schemes
@@ -66,6 +66,7 @@ type ExtOpMS m opT =
type ExtOpMSP opT = ExtOpMS PassM opT
type PassOnStruct = PassOnOps (ExtOpMSP BaseOp)
+type PassASTOnStruct = PassASTOnOps (ExtOpMSP BaseOp)
extOpMS :: forall m opT op0T.
(PolyplateM (A.Structured ()) () op0T m,
@@ -109,3 +110,7 @@ applyBottomUpMS f = makeRecurseM ops
type TransformStructured ops
= (PolyplateM (A.Structured t) () ops PassM, Data t) => Transform (A.Structured t)
+
+type TransformStructured' ops
+ = (PolyplateM (A.Structured t) () ops PassM
+ ,PolyplateM (A.Structured t) ops () PassM , Data t) => Transform (A.Structured t)
diff --git a/pregen/GenNavAST.hs b/pregen/GenNavAST.hs
index e74d762..08bf12f 100644
--- a/pregen/GenNavAST.hs
+++ b/pregen/GenNavAST.hs
@@ -29,128 +29,6 @@ import qualified AST
import qualified CompState
import qualified Errors
-header :: [String]
-header
- = [ "{-# OPTIONS_GHC -Werror -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds -fwarn-incomplete-patterns #-}"
- , "-- | Type class and instances for transformations upon the AST."
- , "--"
- , "-- This was inspired by Neil Mitchell's Biplate class."
- , "--"
- , "-- NOTE: This file is auto-generated by the GenNavAST program, "
- , "-- and should not be edited directly."
- , ""
- , "module NavAST where"
- , ""
- , "import qualified AST"
- , "import qualified Metadata"
- , ""
- , "class Monad m => Polyplate m o o0 t where"
- , " transformM :: o -> o0 -> Bool -> t -> m t"
- , ""
- ]
-
--- | Instances for a particular data type (i.e. where that data type is the
--- last argument to 'Polyplate').
-instancesFrom :: forall t. Data t => t -> [String]
-instancesFrom w
- = baseInst ++
- concat [otherInst c | DataBox c <- justBoxes $ astTypeMap]
- where
- wName = show $ typeOf w
- wKey = typeKey w
- wDType = dataTypeOf w
- wCtrs = if isAlgType wDType then dataTypeConstrs wDType else []
-
- -- The module prefix of this type, so we can use it in constructor names.
- modPrefix
- = if '.' `elem` (takeWhile (\c -> isAlphaNum c || c == '.') wName)
- then takeWhile (/= '.') wName ++ "."
- else ""
-
- ctrArgs ctr
- = gmapQ DataBox (fromConstr ctr :: t)
- ctrArgTypes ctr
- = [show $ typeOf w | DataBox w <- ctrArgs ctr]
-
- -- | An instance that describes what to do when we have no transformations
- -- left to apply.
- baseInst :: [String]
- baseInst
- = [ "instance (" ++ concat (intersperse ", " context) ++ ") =>"
- , " Polyplate m () o0 (" ++ wName ++ ") where"
- ] ++
- (if isAlgType wDType
- -- An algebraic type: apply to each child if we're following.
- then [" transformM () _ False v = return v"] ++
- (concatMap constrCase wCtrs)
- -- A primitive type: just return it.
- else [" transformM () _ _ v = return v"]) ++
- [""]
-
- -- | Class context for 'baseInst'.
- -- We need an instance of Polyplate for each of the types contained within
- -- this type, so we can recurse into them.
- context :: [String]
- context
- = ["Monad m"] ++
- ["Polyplate m o0 o0 (" ++ argType ++ ")"
- | argType <- nub $ sort $ concatMap ctrArgTypes wCtrs]
-
- -- | A 'transformM' case for a particular constructor of this (algebraic)
- -- data type: pull the value apart, apply 'transformM' to each part of it,
- -- then stick it back together.
- constrCase :: Constr -> [String]
- constrCase ctr
- = [ " transformM () " ++ (if argNums == [] then "_" else "ops") ++
- " True (" ++ ctrInput ++ ")"
- , " = do"
- ] ++
- [ " r" ++ show i ++ " <- transformM ops ops False a" ++ show i
- | i <- argNums] ++
- [ " return (" ++ ctrResult ++ ")"
- ]
- where
- (isTuple, argNums)
- -- FIXME: Should work for 3+-tuples too
- | ctrS == "(,)" = (True, [0 .. 1])
- | otherwise = (False, [0 .. ((length $ ctrArgs ctr) - 1)])
- ctrS = show ctr
- ctrName = modPrefix ++ ctrS
- makeCtr vs
- = if isTuple
- then "(" ++ (concat $ intersperse ", " vs) ++ ")"
- else ctrName ++ concatMap (" " ++) vs
- ctrInput = makeCtr ["a" ++ show i | i <- argNums]
- ctrResult = makeCtr ["r" ++ show i | i <- argNums]
-
- containedKeys = Set.fromList [typeKey c
- | DataBox c <- justBoxes $ findTypesIn w]
-
- -- | An instance that describes how to apply -- or not apply -- a
- -- transformation.
- otherInst c
- = [ "instance (Monad m, Polyplate m r o0 (" ++ wName ++ ")) =>"
- , " Polyplate m ((" ++ cName ++ ") -> m (" ++ cName ++ "), r)"
- , " o0 (" ++ wName ++ ") where"
- , impl
- , ""
- ]
- where
- cName = show $ typeOf c
- cKey = typeKey c
- impl
- -- This type matches the transformation: apply it.
- | wKey == cKey
- = " transformM (f, _) _ _ v = f v"
- -- This type might contain the type that the transformation acts
- -- upon: set the flag to say we need to recurse into it.
- | cKey `Set.member` containedKeys
- = " transformM (_, rest) ops _ v = transformM rest ops True v"
- -- This type can't contain the transformed type; just move on to the
- -- next transformation.
- | otherwise
- = " transformM (_, rest) ops b v = transformM rest ops b v"
-
main :: IO ()
main = do
[instFileName, spineInstFileName] <- getArgs
@@ -182,7 +60,7 @@ main = do
header isSpine moduleName =
["{-# OPTIONS_GHC -fallow-overlapping-instances -fwarn-overlapping-patterns -fwarn-unused-matches -fwarn-unused-binds #-}"
,"-- | This module is auto-generated by Polyplate. DO NOT EDIT."
- ,"module " ++ moduleName ++ " where"
+ ,"module " ++ moduleName ++ " () where"
,""
,"import Data.Generics.Polyplate"
,if isSpine then "" else "import Data.Generics.Polyplate.Route"
diff --git a/transformations/ImplicitMobility.hs b/transformations/ImplicitMobility.hs
index f13d89d..59c7eb1 100644
--- a/transformations/ImplicitMobility.hs
+++ b/transformations/ImplicitMobility.hs
@@ -29,11 +29,13 @@ import qualified Data.Set as Set
import qualified Data.Traversable as T
import qualified AST as A
+import CompState
+import Data.Generics.Polyplate.Route
import Errors
import FlowAlgorithms
import FlowGraph
import FlowUtils
-import GenericUtils
+import Intrinsics
import Metadata
import Pass
import ShowCode
@@ -198,15 +200,18 @@ implicitMobility
printMoveCopyDecisions decs
effectMoveCopyDecisions g decs t)
-mobiliseArrays :: Pass
+mobiliseArrays :: PassASTOnStruct
mobiliseArrays = pass "Make all arrays mobile" [] [] recurse
where
- ops = baseOp `extOpS` doStructured
- recurse, descend :: Data t => Transform t
- recurse = makeRecurse ops
- descend = makeDescend ops
+ ops :: ExtOpMSP BaseOp
+ ops = baseOp `extOpMS` (ops, doStructured)
- doStructured :: Data t => Transform (A.Structured t)
+ recurse :: RecurseM PassM (ExtOpMSP BaseOp)
+ recurse = makeRecurseM ops
+ descend :: DescendM PassM (ExtOpMSP BaseOp)
+ descend = makeDescendM ops
+
+ doStructured :: TransformStructured' (ExtOpMSP BaseOp)
doStructured s@(A.Spec m (A.Specification m' n (A.Declaration m'' t@(A.Array ds
innerT))) scope)
= case innerT of
@@ -301,13 +306,15 @@ instance Dereferenceable A.Actual where
deref m (A.ActualVariable v) = fmap A.ActualVariable $ deref m v
deref m (A.ActualExpression e) = fmap A.ActualExpression $ deref m e
-inferDeref :: Pass
+inferDeref :: PassOn2 A.Process A.Variable
inferDeref = pass "Infer mobile dereferences" [] [] recurse
where
- ops = baseOp `extOp` doProcess `extOp` doVariable
- recurse, descend :: Data t => Transform t
- recurse = makeRecurse ops
- descend = makeDescend ops
+ ops = baseOp `extOpM` doProcess `extOpM` doVariable
+
+ recurse :: RecurseM PassM (TwoOpM PassM A.Process A.Variable)
+ recurse = makeRecurseM ops
+ descend :: DescendM PassM (TwoOpM PassM A.Process A.Variable)
+ descend = makeDescendM ops
unify :: (Dereferenceable a, ASTTypeable a, ShowOccam a, ShowRain a) => Meta
-> A.Type -> a -> PassM a
diff --git a/transformations/SimplifyAbbrevs.hs b/transformations/SimplifyAbbrevs.hs
index 736d210..4211a58 100644
--- a/transformations/SimplifyAbbrevs.hs
+++ b/transformations/SimplifyAbbrevs.hs
@@ -183,14 +183,22 @@ updateAbbrevsInState
= pass "Update INITIAL and RESULT abbreviations in state"
[Prop.initialRemoved, Prop.resultRemoved]
[]
- (\v -> get >>= applyDepthM (return . doAbbrevMode) >>= put >> return v)
+ (\v -> modify (applyBottomUp doAbbrevMode) >> return v)
where
doAbbrevMode :: A.AbbrevMode -> A.AbbrevMode
doAbbrevMode A.InitialAbbrev = A.Original
doAbbrevMode A.ResultAbbrev = A.Abbrev
doAbbrevMode s = s
-abbrevCheckPass :: Pass
+type AbbrevCheckM = StateT [Map.Map Var Bool] PassM
+type ExtAbbM a b = ExtOpM AbbrevCheckM a b
+type AbbrevCheckOps
+ = ExtOpMS AbbrevCheckM BaseOp
+ `ExtAbbM` A.Variable
+ `ExtAbbM` A.Process
+ `ExtAbbM` A.InputItem
+
+abbrevCheckPass :: (PolyplateM t AbbrevCheckOps () AbbrevCheckM, PolyplateM t () AbbrevCheckOps AbbrevCheckM) => Pass t
abbrevCheckPass
= pass "Abbreviation checking" [] []
({-passOnlyOnAST "abbrevCheck" $ -} flip evalStateT [Map.empty] . recurse)
diff --git a/transformations/SimplifyExprs.hs b/transformations/SimplifyExprs.hs
index 446b35f..c4cfff0 100644
--- a/transformations/SimplifyExprs.hs
+++ b/transformations/SimplifyExprs.hs
@@ -56,7 +56,7 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs"
(Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.parUsageChecked,
Prop.functionTypesChecked])
[Prop.functionsRemoved]
- (applyDepthM doSpecification)
+ (applyBottomUpM doSpecification)
where
doSpecification :: A.Specification -> PassM A.Specification
doSpecification (A.Specification m n (A.Function mf smrm rts fs evp))
@@ -106,11 +106,11 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs"
-- | Convert AFTER expressions to the equivalent using MINUS (which is how the
-- occam 3 manual defines AFTER).
-removeAfter :: PassOn A.Expression
+removeAfter :: PassOn2 A.Expression A.ExpressionList
removeAfter = pass "Convert AFTER to MINUS"
[Prop.expressionTypesChecked]
[Prop.afterRemoved]
- (applyDepthM doExpression)
+ (applyBottomUpM2 doExpression doExpressionList)
where
doFunctionCall :: (Meta -> A.Name -> [A.Expression] -> a)
-> Meta -> A.Name -> [A.Expression] -> PassM a
@@ -191,14 +191,11 @@ expandArrayLiterals = pass "Expand array literals"
-- TODO for simplification, we could avoid pulling up replication counts that are known to be constants
--
-- TODO we should also pull up the step counts
-pullRepCounts :: PassOn2 (A.Structured A.Process) (A.Structured A.Alternative)
+pullRepCounts :: PassOn A.Process
pullRepCounts = pass "Pull up replicator counts for SEQs, PARs and ALTs"
(Prop.agg_namesDone ++ Prop.agg_typesDone)
[]
- (applyDepthM2
- (pullRepCount :: A.Structured A.Process -> PassM (A.Structured A.Process))
- (pullRepCount :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative))
- )
+ (applyBottomUpM pullRepCountProc)
where
pullRepCountStr :: Data a => Bool -> A.Structured a
-> StateT (A.Structured A.Process -> A.Structured A.Process)
diff --git a/transformations/SimplifyTypes.hs b/transformations/SimplifyTypes.hs
index 7e8a983..42c9a90 100644
--- a/transformations/SimplifyTypes.hs
+++ b/transformations/SimplifyTypes.hs
@@ -46,12 +46,9 @@ resolveNamedTypes
(Prop.agg_namesDone
++ [Prop.expressionTypesChecked, Prop.processTypesChecked])
[Prop.typesResolvedInAST, Prop.typesResolvedInState]
- (\t -> do get >>= resolve >>= flatten >>= onCsNames (flatten <.< resolve) >>= put
- resolve t >>= flatten)
+ (\t -> do get >>= resolve >>= put
+ resolve t)
where
- resolve :: PassType
- resolve = applyDepthM doType
- where
- doType :: A.Type -> PassM A.Type
- doType t@(A.UserDataType _) = underlyingType emptyMeta t
- doType t = return t
+ resolve :: PassTypeOn A.Type
+ resolve = applyTopDownM (underlyingType emptyMeta)
+
diff --git a/transformations/Unnest.hs b/transformations/Unnest.hs
index 6e92465..a9ba75f 100644
--- a/transformations/Unnest.hs
+++ b/transformations/Unnest.hs
@@ -77,12 +77,23 @@ freeNamesIn = doGeneric
doSpecType st = doGeneric st
-- | Replace names.
-replaceNames :: Data t => [(A.Name, A.Name)] -> t -> t
-replaceNames map v = runIdentity $ applyDepthM doName v
+--
+-- This has to have extra cleverness due to a really nasty bug. Array types can
+-- have expressions as dimensions, and those expressions can contain free names
+-- which are being replaced. This is fine, but when that happens we need to update
+-- CompState so that the type has the replaced name, not the old name.
+replaceNames :: PolyplateM t (TwoOpM PassM A.Name A.Specification) () PassM => [(A.Name, A.Name)] -> t -> PassM t
+replaceNames map = recurse
where
smap = Map.fromList [(A.nameName f, t) | (f, t) <- map]
- doName :: A.Name -> Identity A.Name
+ ops :: TwoOpM PassM A.Name A.Specification
+ ops = baseOp `extOpM` doName `extOpM` doSpecification
+
+ recurse :: RecurseM PassM (TwoOpM PassM A.Name A.Specification)
+ recurse = makeRecurseM ops
+
+ doName :: Transform A.Name
doName n = return $ Map.findWithDefault n (A.nameName n) smap
doSpecification :: Transform A.Specification
@@ -192,7 +203,7 @@ removeNesting = pass "Pull nested definitions to top level"
[Prop.nestedPulled]
(passOnlyOnAST "removeNesting" $ \s ->
do pushPullContext
- s' <- (makeRecurse ops) s >>= applyPulled
+ s' <- recurse s >>= applyPulled
popPullContext
return s')
where