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