FlattenTypes.hs

   1 module FlattenTypes where
   2
   3 import qualified Maybe
   4 import Data.Traversable
   5 import qualified Data.Foldable as Foldable
   6 import qualified Control.Monad.Trans.State as State
   7
   8 import CoreSyn
   9 import qualified Type
  10
  11 import HsValueMap
  12 import CoreShow
  13
  14 -- | A signal identifier
  15 type SignalId = Int
  16
  17 -- | A map of a Haskell value to signal ids
  18 type SignalMap = HsValueMap SignalId
  19
  20 -- | A state identifier
  21 type StateId = Int
  22
  23 -- | How is a given (single) value in a function's type (ie, argument or
  24 --   return value) used?
  25 data HsValueUse =
  26   Port           -- ^ Use it as a port (input or output)
  27   | State StateId -- ^ Use it as state (input or output). The int is used to
  28                  --   match input state to output state.
  29   | HighOrder {  -- ^ Use it as a high order function input
  30     hoName :: String,  -- ^ Which function is passed in?
  31     hoArgs :: [HsUseMap]   -- ^ Which arguments are already applied? This
  32                          -- ^ map should only contain Port and other
  33                          --   HighOrder values.
  34   }
  35   deriving (Show, Eq, Ord)
  36
  37 -- | Is this HsValueUse a state use?
  38 isStateUse :: HsValueUse -> Bool
  39 isStateUse (State _) = True
  40 isStateUse _         = False
  41
  42 -- | A map from a Haskell value to the use of each single value
  43 type HsUseMap = HsValueMap HsValueUse
  44
  45 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
  46 --   which all the Single elements are marked as State, with increasing state
  47 --   numbers.
  48 useAsState :: HsValueMap a -> HsUseMap
  49 useAsState map =
  50   map'
  51   where
  52     -- Traverse the existing map, resulting in a function that maps an initial
  53     -- state number to the final state number and the new map
  54     PassState f = traverse asState map
  55     -- Run this function to get the new map
  56     (_, map')   = f 0
  57     -- This function maps each element to a State with a unique number, by
  58     -- incrementing the state count.
  59     asState x   = PassState (\s -> (s+1, State s))
  60
  61 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
  62 --   which all the Single elements are marked as Port.
  63 useAsPort :: HsValueMap a -> HsUseMap
  64 useAsPort map = fmap (\x -> Port) map
  65
  66 -- | A Haskell function with a specific signature. The signature defines what
  67 --   use the arguments and return value of the function get.
  68 data HsFunction = HsFunction {
  69   hsFuncName :: String,
  70   hsFuncArgs :: [HsUseMap],
  71   hsFuncRes  :: HsUseMap
  72 } deriving (Show, Eq, Ord)
  73
  74 hasState :: HsFunction -> Bool
  75 hasState hsfunc =
  76   any (Foldable.any isStateUse) (hsFuncArgs hsfunc)
  77   || Foldable.any isStateUse (hsFuncRes hsfunc)
  78
  79 -- | Something that defines a signal
  80 data SigDef =
  81   -- | A flattened function application
  82   FApp {
  83     appFunc :: HsFunction,
  84     appArgs :: [SignalMap],
  85     appRes  :: SignalMap
  86   }
  87   -- | A conditional signal definition
  88   | CondDef {
  89     cond    :: SignalId,
  90     high    :: SignalId,
  91     low     :: SignalId,
  92     condRes :: SignalId
  93   }
  94   -- | Unconditional signal definition
  95   | UncondDef {
  96     defSrc :: Either SignalId SignalExpr,
  97     defDst :: SignalId
  98   } deriving (Show, Eq)
  99
 100 -- | Is the given SigDef a FApp?
 101 is_FApp :: SigDef -> Bool
 102 is_FApp d = case d of
 103   (FApp _ _ _) -> True
 104   _ -> False
 105
 106 -- | Which signals are used by the given SigDef?
 107 sigDefUses :: SigDef -> [SignalId]
 108 sigDefUses (UncondDef (Left id) _) = [id]
 109 sigDefUses (UncondDef (Right expr) _) = sigExprUses expr
 110 sigDefUses (CondDef cond true false _) = [cond, true, false]
 111 sigDefUses (FApp _ args _) = concat $ map Foldable.toList args
 112
 113 -- | An expression on signals
 114 data SignalExpr =
 115   EqLit SignalId String -- ^ Is the given signal equal to the given (VHDL) literal
 116   | Literal String (Maybe Type.Type)-- ^ A literal value, with an optional type to cast to
 117   | Eq SignalId SignalId -- ^ A comparison between to signals
 118   deriving (Show, Eq)
 119
 120 -- Instantiate Eq for Type, so we can derive Eq for SignalExpr.
 121 instance Eq Type.Type where
 122   (==) = Type.coreEqType
 123
 124 -- | Which signals are used by the given SignalExpr?
 125 sigExprUses :: SignalExpr -> [SignalId]
 126 sigExprUses (EqLit id _) = [id]
 127 sigExprUses (Literal _ _) = []
 128 sigExprUses (Eq a b) = [a, b]
 129
 130 -- Returns the function used by the given SigDef, if any
 131 usedHsFunc :: SigDef -> Maybe HsFunction
 132 usedHsFunc (FApp hsfunc _ _) = Just hsfunc
 133 usedHsFunc _ = Nothing
 134
 135 -- | How is a given signal used in the resulting VHDL?
 136 data SigUse =
 137   SigPortIn          -- | Use as an input port
 138   | SigPortOut       -- | Use as an input port
 139   | SigInternal      -- | Use as an internal signal
 140   | SigStateOld StateId  -- | Use as the current internal state
 141   | SigStateNew StateId  -- | Use as the new internal state
 142   | SigSubState      -- | Do not use, state variable is used in a subcircuit
 143   deriving (Show)
 144
 145 -- | Is this a port signal use?
 146 isPortSigUse :: SigUse -> Bool
 147 isPortSigUse SigPortIn = True
 148 isPortSigUse SigPortOut = True
 149 isPortSigUse _ = False
 150
 151 -- | Is this a state signal use? Returns false for substate.
 152 isStateSigUse :: SigUse -> Bool
 153 isStateSigUse (SigStateOld _) = True
 154 isStateSigUse (SigStateNew _) = True
 155 isStateSigUse _ = False
 156
 157 -- | Is this an internal signal use?
 158 isInternalSigUse :: SigUse -> Bool
 159 isInternalSigUse SigInternal = True
 160 isInternalSigUse _ = False
 161
 162 oldStateId :: SigUse -> Maybe StateId
 163 oldStateId (SigStateOld id) = Just id
 164 oldStateId _ = Nothing
 165
 166 newStateId :: SigUse -> Maybe StateId
 167 newStateId (SigStateNew id) = Just id
 168 newStateId _ = Nothing
 169
 170 -- | Information on a signal definition
 171 data SignalInfo = SignalInfo {
 172   sigName :: Maybe String,
 173   sigUse  :: SigUse,
 174   sigTy   :: Type.Type,
 175   nameHints :: [String]
 176 } deriving (Show)
 177
 178 -- | A flattened function
 179 data FlatFunction = FlatFunction {
 180   flat_args   :: [SignalMap],
 181   flat_res    :: SignalMap,
 182   flat_defs   :: [SigDef],
 183   flat_sigs   :: [(SignalId, SignalInfo)]
 184 } deriving (Show)
 185
 186 -- | Lookup a given signal id in a signal map, and return the associated
 187 --   SignalInfo. Errors out if the signal was not found.
 188 signalInfo :: [(SignalId, SignalInfo)] -> SignalId -> SignalInfo
 189 signalInfo sigs id = Maybe.fromJust $ lookup id sigs
 190
 191 -- | A list of binds in effect at a particular point of evaluation
 192 type BindMap = [(
 193   CoreBndr,            -- ^ The bind name
 194   BindValue            -- ^ The value bound to it
 195   )]
 196
 197 type BindValue =
 198   Either               -- ^ The bind value which is either
 199     (SignalMap)
 200                        -- ^ a signal
 201     (
 202       HsValueUse,      -- ^ or a HighOrder function
 203       [SignalId]       -- ^ With these signals already applied to it
 204     )
 205
 206 -- | The state during the flattening of a single function
 207 type FlattenState = State.State ([SigDef], [(SignalId, SignalInfo)], SignalId)
 208
 209 -- | Add an application to the current FlattenState
 210 addDef :: SigDef -> FlattenState ()
 211 addDef d = do
 212   (defs, sigs, n) <- State.get
 213   State.put (d:defs, sigs, n)
 214
 215 -- | Generates a new signal id, which is unique within the current flattening.
 216 genSignalId :: SigUse -> Type.Type -> FlattenState SignalId
 217 genSignalId use ty = do
 218   (defs, sigs, n) <- State.get
 219   -- Generate a new numbered but unnamed signal
 220   let s = (n, SignalInfo Nothing use ty [])
 221   State.put (defs, s:sigs, n+1)
 222   return n
 223
 224 -- | Add a name hint to the given signal
 225 addNameHint :: String -> SignalId -> FlattenState ()
 226 addNameHint hint id = do
 227   info <- getSignalInfo id
 228   let hints = nameHints info
 229   if hint `elem` hints
 230     then do
 231       return ()
 232     else do
 233       let hints' = (hint:hints)
 234       setSignalInfo id (info {nameHints = hints'})
 235
 236 -- | Returns the SignalInfo for the given signal. Errors if the signal is not
 237 --   known in the session.
 238 getSignalInfo :: SignalId -> FlattenState SignalInfo
 239 getSignalInfo id = do
 240   (defs, sigs, n) <- State.get
 241   return $ signalInfo sigs id
 242
 243 setSignalInfo :: SignalId -> SignalInfo -> FlattenState ()
 244 setSignalInfo id' info' = do
 245   (defs, sigs, n) <- State.get
 246   let sigs' = map (\(id, info) -> (id, if id == id' then info' else info)) sigs
 247   State.put (defs, sigs', n)
 248
 249 -- vim: set ts=8 sw=2 sts=2 expandtab: