Fixed all the conflicts while merging into the Polyplate branch
This commit is contained in:
Neil Brown
parent
85ed6b8fbe
commit
e61a23855a
28
Main.hs
28
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -330,42 +341,7 @@ declareSizesArray = occamOnlyPass "Declare array-size arrays"
|
|||
_ -> 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
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <http://www.gnu.org/licenses/>.
|
||||
-}
|
||||
|
||||
-- | 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -19,9 +19,9 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
-- | 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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user