From 710be039cb8f103082c1300b3a66474898718e2e Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Fri, 9 May 2008 14:02:13 +0000 Subject: [PATCH] Have the pregen programs figure out the types using generics. Previously they had a list of the types they needed to generate instances for. This patch adds some helper code that can be used to list all the AST.* types in the AST automatically. The result is that we should be able to add new types to the AST without needing to change the generator code. This also means that GenOrdAST is now generating *all* the instances of Ord for the AST; previously the trivial ones were derived by the compiler. --- Makefile.am | 11 ++++--- data/AST.hs | 23 ++++++-------- data/CompState.hs | 1 + pregen/GenOrdAST.hs | 38 ++-------------------- pregen/GenTagAST.hs | 36 ++------------------- pregen/PregenUtils.hs | 74 +++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 98 insertions(+), 85 deletions(-) create mode 100644 pregen/PregenUtils.hs diff --git a/Makefile.am b/Makefile.am index 343f900..294115c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -38,11 +38,11 @@ tocktest$(EXEEXT): $(BUILT_SOURCES) $(tocktest_SOURCES) $(config_sources) @MKDIR_P@ obj ghc $(GHC_OPTS) -o tocktest$(EXEEXT) -main-is TestMain --make TestMain -odir obj -hidir obj -GenTagAST$(EXEEXT): $(GenTagAST_SOURCES) data/AST.hs +GenTagAST$(EXEEXT): $(GenTagAST_SOURCES) @MKDIR_P@ obj ghc $(GHC_OPTS) -o GenTagAST$(EXEEXT) -main-is GenTagAST --make GenTagAST -odir obj -hidir obj -GenOrdAST$(EXEEXT): $(GenOrdAST_SOURCES) data/AST.hs +GenOrdAST$(EXEEXT): $(GenOrdAST_SOURCES) @MKDIR_P@ obj ghc $(GHC_OPTS) -o GenOrdAST$(EXEEXT) -main-is GenOrdAST --make GenOrdAST -odir obj -hidir obj @@ -168,8 +168,11 @@ tocktest_SOURCES += frontends/RainTypesTest.hs tocktest_SOURCES += frontends/StructureOccamTest.hs tocktest_SOURCES += transformations/PassTest.hs -GenTagAST_SOURCES = pregen/GenTagAST.hs -GenOrdAST_SOURCES = pregen/GenOrdAST.hs +pregen_sources = data/AST.hs +pregen_sources += pregen/PregenUtils.hs + +GenTagAST_SOURCES = pregen/GenTagAST.hs $(pregen_sources) +GenOrdAST_SOURCES = pregen/GenOrdAST.hs $(pregen_sources) #The programs to actually build: bin_PROGRAMS = tock diff --git a/data/AST.hs b/data/AST.hs index 2f9ba7a..e0c6e7f 100644 --- a/data/AST.hs +++ b/data/AST.hs @@ -58,10 +58,7 @@ instance Show Name where show n = show $ nameName n instance Eq Name where - (==) a b = nameName a == nameName b - -instance Ord Name where - compare a b = compare (nameName a) (nameName b) + (==) a b = (nameName a) == (nameName b) -- | The definition of a name. data NameDef = NameDef { @@ -89,7 +86,7 @@ data Direction = | DirOutput -- ^ The output end. | DirUnknown -- ^ Either direction; either this is a whole channel, -- or its direction is to be figured out later. - deriving (Show, Eq, Ord, Typeable, Data) + deriving (Show, Eq, Typeable, Data) -- | Attributes of the type of a channel. data ChanAttributes = ChanAttributes { @@ -103,7 +100,7 @@ data ChanAttributes = ChanAttributes { -- reads into something of type Int), and a Rain timer (which reads into something -- of type Time). data TimerType = OccamTimer | RainTimer - deriving (Eq, Show, Ord, Typeable, Data) + deriving (Eq, Show, Typeable, Data) -- | A data or protocol type. -- The two concepts aren't unified in occam, but they are here, because it @@ -180,7 +177,7 @@ data ConversionMode = DefaultConversion | Round | Trunc - deriving (Show, Eq, Ord, Typeable, Data) + deriving (Show, Eq, Typeable, Data) -- | Which ends (or both) of an array dimension to check the subscript against. -- By default, all subscripts in occam have the CheckBoth mode, but @@ -192,7 +189,7 @@ data SubscriptCheck = | CheckLower | CheckUpper | CheckBoth - deriving (Show, Eq, Ord, Typeable, Data) + deriving (Show, Eq, Typeable, Data) -- | A subscript that can be applied to a variable or an expression. data Subscript = @@ -312,7 +309,7 @@ data MonadicOp = | MonadicMinus | MonadicBitNot | MonadicNot - deriving (Show, Eq, Ord, Typeable, Data) + deriving (Show, Eq, Typeable, Data) -- | A dyadic (binary) operator. data DyadicOp = @@ -324,7 +321,7 @@ data DyadicOp = | Eq | NotEq | Less | More | LessEq | MoreEq | After | Concat - deriving (Show, Eq, Ord, Typeable, Data) + deriving (Show, Eq, Typeable, Data) -- | An item in an input. data InputItem = @@ -470,7 +467,7 @@ data AbbrevMode = | Abbrev -- | An abbreviation by value. | ValAbbrev - deriving (Show, Eq, Ord, Typeable, Data) + deriving (Show, Eq, Typeable, Data) -- | Anything that introduces a new name. data Specification = @@ -516,7 +513,7 @@ data SpecType = -- This indicates whether a function is inlined by the compiler. data SpecMode = PlainSpec | InlineSpec - deriving (Show, Eq, Ord, Typeable, Data) + deriving (Show, Eq, Typeable, Data) -- | Formal parameters for @PROC@s and @FUNCTION@s. data Formal = @@ -542,7 +539,7 @@ data ParMode = -- 'Processor' instances inside this indicate which processor each parallel -- process runs on. | PlacedPar - deriving (Show, Eq, Ord, Typeable, Data) + deriving (Show, Eq, Typeable, Data) -- | A process. data Process = diff --git a/data/CompState.hs b/data/CompState.hs index 01c17f1..bb802ca 100644 --- a/data/CompState.hs +++ b/data/CompState.hs @@ -33,6 +33,7 @@ import qualified Data.Set as Set import qualified AST as A import Errors (Die, dieP, ErrorReport, Warn, warnP) import Metadata +import OrdAST () -- | Modes that Tock can run in. data CompMode = ModeFlowGraph | ModeParse | ModeCompile | ModePostC | ModeFull diff --git a/pregen/GenOrdAST.hs b/pregen/GenOrdAST.hs index 53aee84..326ed90 100644 --- a/pregen/GenOrdAST.hs +++ b/pregen/GenOrdAST.hs @@ -27,8 +27,9 @@ import Control.Monad.Writer import Data.Generics import Data.List -import qualified AST as A import Metadata +import PregenUtils +import Utils genHeader :: [String] genHeader = [ @@ -80,42 +81,9 @@ ordFor' typeName x = process $ map processConstr $ dataTypeConstrs $ dataTypeOf ("AST." ++ showConstr c, x, y, z) items :: [String] -items = concat - [ordFor (u :: A.Actual) - ,ordFor (u :: A.Alternative) - ,ordFor (u :: A.ArrayConstr) - ,ordFor (u :: A.ArrayElem) - ,ordFor (u :: A.ChanAttributes) - ,ordFor (u :: A.Choice) - ,ordFor (u :: A.Dimension) - ,ordFor (u :: A.Expression) - ,ordFor (u :: A.ExpressionList) - ,ordFor (u :: A.Formal) - ,ordFor (u :: A.InputItem) - ,ordFor (u :: A.InputMode) - ,ordFor (u :: A.LiteralRepr) - ,ordFor (u :: A.OutputItem) - ,ordFor (u :: A.Option) - ,ordFor (u :: A.Process) - ,ordFor (u :: A.Replicator) - ,ordFor (u :: A.Specification) - ,ordFor (u :: A.SpecType) - ,ordFor (u :: A.Structured A.Process) - ,ordFor (u :: A.Structured A.Choice) - ,ordFor (u :: A.Structured A.Option) - ,ordFor (u :: A.Structured A.Alternative) - ,ordFor (u :: A.Structured A.Variant) - ,ordFor (u :: A.Structured A.ExpressionList) - ,ordFor (u :: A.Structured ()) - ,ordFor (u :: A.Subscript) - ,ordFor (u :: A.Type) - ,ordFor (u :: A.Variable) - ,ordFor (u :: A.Variant) - ] +items = concat [ordFor w | DataBox w <- astTypes] where ordFor x = ordFor' (show $ typeOf x) x - - u = undefined main :: IO () main = putStr $ unlines $ genHeader ++ items diff --git a/pregen/GenTagAST.hs b/pregen/GenTagAST.hs index 3d53f31..b8ff8cd 100644 --- a/pregen/GenTagAST.hs +++ b/pregen/GenTagAST.hs @@ -26,7 +26,8 @@ import Data.Char import Data.Generics import Data.List (intersperse) -import qualified AST as A +import PregenUtils +import Utils genHeader :: [String] genHeader = [ @@ -104,39 +105,8 @@ consParamsFor x = map consParamsFor' (dataTypeConstrs $ dataTypeOf x) cons = gmapQ (show . typeOf) (fromConstr con :: a) items :: [String] -items = concat - [ gen (u :: A.Actual) - , gen (u :: A.Alternative) - , gen (u :: A.ArrayConstr) - , gen (u :: A.ArrayElem) - , gen (u :: A.Choice) - , gen (u :: A.Expression) - , gen (u :: A.ExpressionList) - , gen (u :: A.Formal) - , gen (u :: A.InputItem) - , gen (u :: A.InputMode) - , gen (u :: A.LiteralRepr) - , gen (u :: A.OutputItem) - , gen (u :: A.Option) - , gen (u :: A.Process) - , gen (u :: A.Replicator) - , gen (u :: A.Specification) - , gen (u :: A.SpecType) - , gen (u :: A.Subscript) - , gen (u :: A.Type) - , gen (u :: A.Variable) - , gen (u :: A.Variant) - , gen (u :: A.Structured A.Process) - , gen (u :: A.Structured A.Option) - , gen (u :: A.Structured A.Choice) - , gen (u :: A.Structured A.Variant) - , gen (u :: A.Structured A.Alternative) - , gen (u :: A.Structured A.ExpressionList) - , gen (u :: A.Structured ()) - ] +items = concat [gen w | DataBox w <- astTypes] where - u = undefined - gen w = case typeRepArgs rep of -- A parameterised type (e.g. Structured Process). diff --git a/pregen/PregenUtils.hs b/pregen/PregenUtils.hs new file mode 100644 index 0000000..cfb22ce --- /dev/null +++ b/pregen/PregenUtils.hs @@ -0,0 +1,74 @@ +{- +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 metaprogramming. +module PregenUtils + ( astTypes + ) where + +import Control.Monad.State +import Data.Generics +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import System.IO.Unsafe + +import qualified AST as A +import Utils + +type TypeMap = Map Int (String, DataBox) +type TypeMapM = State TypeMap + +-- | Given a starting value, find all the types that could possibly be inside +-- it. +findTypesIn :: Data t => t -> TypeMap +findTypesIn start = execState (doType start) Map.empty + where + doType :: Data t => t -> TypeMapM () + doType x + = do map <- get + when (not $ key `Map.member` map) $ + do modify $ Map.insert key (reps, DataBox x) + when (isAlgType dtype) $ + mapM_ doConstr $ dataTypeConstrs dtype + where + rep = typeOf x + key = unsafePerformIO $ typeRepKey rep + reps = show rep + dtype = dataTypeOf x + + doConstr :: Constr -> TypeMapM () + doConstr ctr + = sequence_ [doType x' | DataBox x' <- args] + where + args = gmapQ DataBox (asTypeOf (fromConstr ctr) x) + +-- | Reduce a 'TypeMap' to only the types in a particular module. +filterModule :: String -> TypeMap -> TypeMap +filterModule prefix = Map.filter (((prefix ++ ".") `isPrefixOf`) . fst) + +-- | Reduce a 'TypeMap' to a list of 'DataBox'es, sorted by name. +justBoxes :: TypeMap -> [DataBox] +justBoxes = map snd . sortBy cmp . Map.elems + where + cmp (l, _) (r, _) = compare l r + +-- | Witnesses for all the types defined in the 'AST' module. +astTypes :: [DataBox] +astTypes = justBoxes $ filterModule "AST" $ findTypesIn (undefined :: A.AST) +