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