From 41e6a89a1d9347431e80b895cb74ab5ecc03e9b7 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 11 Feb 2009 19:38:57 +0100 Subject: [PATCH] Move around a bunch of types. Now most types are defined in a separate module, making it easier to prevent circular dependencies. --- Flatten.hs | 168 +-------------------------------------------- FlattenTypes.hs | 138 +++++++++++++++++++++++++++++++++++++ HsValueMap.hs | 56 +++++++++++++++ Pretty.hs | 4 +- Translator.hs | 2 + TranslatorTypes.hs | 3 +- VHDL.hs | 1 - 7 files changed, 204 insertions(+), 168 deletions(-) create mode 100644 FlattenTypes.hs create mode 100644 HsValueMap.hs diff --git a/Flatten.hs b/Flatten.hs index b08ead4..8a23016 100644 --- a/Flatten.hs +++ b/Flatten.hs @@ -4,62 +4,16 @@ import Control.Monad import qualified Var import qualified Type import qualified Name -import qualified TyCon import qualified Maybe -import Data.Traversable import qualified DataCon import qualified CoreUtils import Control.Applicative import Outputable ( showSDoc, ppr ) -import qualified Data.Foldable as Foldable import qualified Control.Monad.State as State --- | A datatype that maps each of the single values in a haskell structure to --- a mapto. The map has the same structure as the haskell type mapped, ie --- nested tuples etc. -data HsValueMap mapto = - Tuple [HsValueMap mapto] - | Single mapto - deriving (Show, Eq, Ord) - -instance Functor HsValueMap where - fmap f (Single s) = Single (f s) - fmap f (Tuple maps) = Tuple (map (fmap f) maps) - -instance Foldable.Foldable HsValueMap where - foldMap f (Single s) = f s - -- The first foldMap folds a list of HsValueMaps, the second foldMap folds - -- each of the HsValueMaps in that list - foldMap f (Tuple maps) = Foldable.foldMap (Foldable.foldMap f) maps - -instance Traversable HsValueMap where - traverse f (Single s) = Single <$> f s - traverse f (Tuple maps) = Tuple <$> (traverse (traverse f) maps) - -data PassState s x = PassState (s -> (s, x)) - -instance Functor (PassState s) where - fmap f (PassState a) = PassState (\s -> let (s', a') = a s in (s', f a')) - -instance Applicative (PassState s) where - pure x = PassState (\s -> (s, x)) - PassState f <*> PassState x = PassState (\s -> let (s', f') = f s; (s'', x') = x s' in (s'', f' x')) - --- | Creates a HsValueMap with the same structure as the given type, using the --- given function for mapping the single types. -mkHsValueMap :: - Type.Type -- ^ The type to map to a HsValueMap - -> HsValueMap Type.Type -- ^ The resulting map and state - -mkHsValueMap ty = - case Type.splitTyConApp_maybe ty of - Just (tycon, args) -> - if (TyCon.isTupleTyCon tycon) - then - Tuple (map mkHsValueMap args) - else - Single ty - Nothing -> Single ty +import HsValueMap +import TranslatorTypes +import FlattenTypes -- Extract the arguments from a data constructor application (that is, the -- normal args, leaving out the type args). @@ -69,122 +23,6 @@ dataConAppArgs dc args = where tycount = length $ DataCon.dataConAllTyVars dc - - -data FlatFunction = FlatFunction { - args :: [SignalDefMap], - res :: SignalUseMap, - --sigs :: [SignalDef], - apps :: [FApp], - conds :: [CondDef] -} deriving (Show, Eq) - -type SignalUseMap = HsValueMap SignalUse -type SignalDefMap = HsValueMap SignalDef - -useMapToDefMap :: SignalUseMap -> SignalDefMap -useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u) - -defMapToUseMap :: SignalDefMap -> SignalUseMap -defMapToUseMap = fmap (\(SignalDef u) -> SignalUse u) - - -type SignalId = Int -data SignalUse = SignalUse { - sigUseId :: SignalId -} deriving (Show, Eq) - -data SignalDef = SignalDef { - sigDefId :: SignalId -} deriving (Show, Eq) - -data FApp = FApp { - appFunc :: HsFunction, - appArgs :: [SignalUseMap], - appRes :: SignalDefMap -} deriving (Show, Eq) - -data CondDef = CondDef { - cond :: SignalUse, - high :: SignalUse, - low :: SignalUse, - condRes :: SignalDef -} deriving (Show, Eq) - --- | How is a given (single) value in a function's type (ie, argument or --- return value) used? -data HsValueUse = - Port -- ^ Use it as a port (input or output) - | State Int -- ^ Use it as state (input or output). The int is used to - -- match input state to output state. - | HighOrder { -- ^ Use it as a high order function input - hoName :: String, -- ^ Which function is passed in? - hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This - -- ^ map should only contain Port and other - -- HighOrder values. - } - deriving (Show, Eq, Ord) - -type HsUseMap = HsValueMap HsValueUse - --- | Builds a HsUseMap with the same structure has the given HsValueMap in --- which all the Single elements are marked as State, with increasing state --- numbers. -useAsState :: HsValueMap a -> HsUseMap -useAsState map = - map' - where - -- Traverse the existing map, resulting in a function that maps an initial - -- state number to the final state number and the new map - PassState f = traverse asState map - -- Run this function to get the new map - (_, map') = f 0 - -- This function maps each element to a State with a unique number, by - -- incrementing the state count. - asState x = PassState (\s -> (s+1, State s)) - --- | Builds a HsUseMap with the same structure has the given HsValueMap in --- which all the Single elements are marked as Port. -useAsPort :: HsValueMap a -> HsUseMap -useAsPort map = fmap (\x -> Port) map - -data HsFunction = HsFunction { - hsFuncName :: String, - hsFuncArgs :: [HsUseMap], - hsFuncRes :: HsUseMap -} deriving (Show, Eq, Ord) - -type BindMap = [( - CoreBndr, -- ^ The bind name - Either -- ^ The bind value which is either - SignalUseMap -- ^ a signal - ( - HsValueUse, -- ^ or a HighOrder function - [SignalUse] -- ^ With these signals already applied to it - ) - )] - -type FlattenState = State.State ([FApp], [CondDef], SignalId) - --- | Add an application to the current FlattenState -addApp :: FApp -> FlattenState () -addApp a = do - (apps, conds, n) <- State.get - State.put (a:apps, conds, n) - --- | Add a conditional definition to the current FlattenState -addCondDef :: CondDef -> FlattenState () -addCondDef c = do - (apps, conds, n) <- State.get - State.put (apps, c:conds, n) - --- | Generates a new signal id, which is unique within the current flattening. -genSignalId :: FlattenState SignalId -genSignalId = do - (apps, conds, n) <- State.get - State.put (apps, conds, n+1) - return n - genSignalUses :: Type.Type -> FlattenState SignalUseMap diff --git a/FlattenTypes.hs b/FlattenTypes.hs new file mode 100644 index 0000000..81088ba --- /dev/null +++ b/FlattenTypes.hs @@ -0,0 +1,138 @@ +module FlattenTypes where + +import Data.Traversable +import qualified Control.Monad.State as State + +import CoreSyn + +import HsValueMap + +-- | A signal identifier +type SignalId = Int + +-- | A use of a signal +data SignalUse = SignalUse { + sigUseId :: SignalId +} deriving (Show, Eq) + +-- | A def of a signal +data SignalDef = SignalDef { + sigDefId :: SignalId +} deriving (Show, Eq) + +-- | A map of a Haskell value to signal uses +type SignalUseMap = HsValueMap SignalUse +-- | A map of a Haskell value to signal defs +type SignalDefMap = HsValueMap SignalDef + +-- | Translate a SignalUseMap to an equivalent SignalDefMap +useMapToDefMap :: SignalUseMap -> SignalDefMap +useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u) + +-- | Translate a SignalDefMap to an equivalent SignalUseMap +defMapToUseMap :: SignalDefMap -> SignalUseMap +defMapToUseMap = fmap (\(SignalDef u) -> SignalUse u) + +-- | How is a given (single) value in a function's type (ie, argument or +-- return value) used? +data HsValueUse = + Port -- ^ Use it as a port (input or output) + | State Int -- ^ Use it as state (input or output). The int is used to + -- match input state to output state. + | HighOrder { -- ^ Use it as a high order function input + hoName :: String, -- ^ Which function is passed in? + hoArgs :: [HsUseMap] -- ^ Which arguments are already applied? This + -- ^ map should only contain Port and other + -- HighOrder values. + } + deriving (Show, Eq, Ord) + +-- | A map from a Haskell value to the use of each single value +type HsUseMap = HsValueMap HsValueUse + +-- | Builds a HsUseMap with the same structure has the given HsValueMap in +-- which all the Single elements are marked as State, with increasing state +-- numbers. +useAsState :: HsValueMap a -> HsUseMap +useAsState map = + map' + where + -- Traverse the existing map, resulting in a function that maps an initial + -- state number to the final state number and the new map + PassState f = traverse asState map + -- Run this function to get the new map + (_, map') = f 0 + -- This function maps each element to a State with a unique number, by + -- incrementing the state count. + asState x = PassState (\s -> (s+1, State s)) + +-- | Builds a HsUseMap with the same structure has the given HsValueMap in +-- which all the Single elements are marked as Port. +useAsPort :: HsValueMap a -> HsUseMap +useAsPort map = fmap (\x -> Port) map + +-- | A Haskell function with a specific signature. The signature defines what +-- use the arguments and return value of the function get. +data HsFunction = HsFunction { + hsFuncName :: String, + hsFuncArgs :: [HsUseMap], + hsFuncRes :: HsUseMap +} deriving (Show, Eq, Ord) + +-- | A flattened function application +data FApp = FApp { + appFunc :: HsFunction, + appArgs :: [SignalUseMap], + appRes :: SignalDefMap +} deriving (Show, Eq) + +-- | A conditional signal definition +data CondDef = CondDef { + cond :: SignalUse, + high :: SignalUse, + low :: SignalUse, + condRes :: SignalDef +} deriving (Show, Eq) + +-- | A flattened function +data FlatFunction = FlatFunction { + args :: [SignalDefMap], + res :: SignalUseMap, + --sigs :: [SignalDef], + apps :: [FApp], + conds :: [CondDef] +} deriving (Show, Eq) + +-- | A list of binds in effect at a particular point of evaluation +type BindMap = [( + CoreBndr, -- ^ The bind name + Either -- ^ The bind value which is either + SignalUseMap -- ^ a signal + ( + HsValueUse, -- ^ or a HighOrder function + [SignalUse] -- ^ With these signals already applied to it + ) + )] + +-- | The state during the flattening of a single function +type FlattenState = State.State ([FApp], [CondDef], SignalId) + +-- | Add an application to the current FlattenState +addApp :: FApp -> FlattenState () +addApp a = do + (apps, conds, n) <- State.get + State.put (a:apps, conds, n) + +-- | Add a conditional definition to the current FlattenState +addCondDef :: CondDef -> FlattenState () +addCondDef c = do + (apps, conds, n) <- State.get + State.put (apps, c:conds, n) + +-- | Generates a new signal id, which is unique within the current flattening. +genSignalId :: FlattenState SignalId +genSignalId = do + (apps, conds, n) <- State.get + State.put (apps, conds, n+1) + return n + diff --git a/HsValueMap.hs b/HsValueMap.hs new file mode 100644 index 0000000..c2407f5 --- /dev/null +++ b/HsValueMap.hs @@ -0,0 +1,56 @@ +-- | This module provides the HsValueMap type, which can structurally map a +-- Haskell value to something else. +module HsValueMap where + +import qualified Type +import qualified TyCon +import Control.Applicative +import Data.Traversable +import Data.Foldable + +-- | A datatype that maps each of the single values in a haskell structure to +-- a mapto. The map has the same structure as the haskell type mapped, ie +-- nested tuples etc. +data HsValueMap mapto = + Tuple [HsValueMap mapto] + | Single mapto + deriving (Show, Eq, Ord) + +instance Functor HsValueMap where + fmap f (Single s) = Single (f s) + fmap f (Tuple maps) = Tuple (map (fmap f) maps) + +instance Foldable HsValueMap where + foldMap f (Single s) = f s + -- The first foldMap folds a list of HsValueMaps, the second foldMap folds + -- each of the HsValueMaps in that list + foldMap f (Tuple maps) = foldMap (foldMap f) maps + +instance Traversable HsValueMap where + traverse f (Single s) = Single <$> f s + traverse f (Tuple maps) = Tuple <$> (traverse (traverse f) maps) + +data PassState s x = PassState (s -> (s, x)) + +instance Functor (PassState s) where + fmap f (PassState a) = PassState (\s -> let (s', a') = a s in (s', f a')) + +instance Applicative (PassState s) where + pure x = PassState (\s -> (s, x)) + PassState f <*> PassState x = PassState (\s -> let (s', f') = f s; (s'', x') = x s' in (s'', f' x')) + +-- | Creates a HsValueMap with the same structure as the given type, using the +-- given function for mapping the single types. +mkHsValueMap :: + Type.Type -- ^ The type to map to a HsValueMap + -> HsValueMap Type.Type -- ^ The resulting map and state + +mkHsValueMap ty = + case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> + if (TyCon.isTupleTyCon tycon) + then + Tuple (map mkHsValueMap args) + else + Single ty + Nothing -> Single ty diff --git a/Pretty.hs b/Pretty.hs index 4136ade..6f88877 100644 --- a/Pretty.hs +++ b/Pretty.hs @@ -6,7 +6,9 @@ import qualified Module import qualified HscTypes import Text.PrettyPrint.HughesPJClass import Outputable ( showSDoc, ppr, Outputable, OutputableBndr) -import Flatten + +import HsValueMap +import FlattenTypes import TranslatorTypes instance Pretty HsFunction where diff --git a/Translator.hs b/Translator.hs index b4301a3..d0738d3 100644 --- a/Translator.hs +++ b/Translator.hs @@ -33,8 +33,10 @@ import qualified ForSyDe.Backend.Ppr import Text.PrettyPrint.HughesPJ (render) import TranslatorTypes +import HsValueMap import Pretty import Flatten +import FlattenTypes import qualified VHDL main = diff --git a/TranslatorTypes.hs b/TranslatorTypes.hs index 8e24541..4ced7de 100644 --- a/TranslatorTypes.hs +++ b/TranslatorTypes.hs @@ -7,7 +7,8 @@ module TranslatorTypes where import qualified Control.Monad.State as State import qualified HscTypes import qualified Data.Map as Map -import Flatten +import FlattenTypes +import HsValueMap -- | A map from a HsFunction identifier to various stuff we collect about a diff --git a/VHDL.hs b/VHDL.hs index ae7dfc9..f1c7500 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -11,7 +11,6 @@ import qualified Maybe import Outputable ( showSDoc, ppr ) import qualified ForSyDe.Backend.VHDL.AST as AST - -- | The VHDL Bit type bit_ty :: AST.TypeMark bit_ty = AST.unsafeVHDLBasicId "Bit" -- 2.30.2