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 -- | How is a given (single) value in a function's type (ie, argument or
  20 -- return value) used?
  21 data HsValueUse =
  22   Port           -- ^ Use it as a port (input or output)
  23   | State Int    -- ^ Use it as state (input or output). The int is used to
  24                  --   match input state to output state.
  25   | HighOrder {  -- ^ Use it as a high order function input
  26     hoName :: String,  -- ^ Which function is passed in?
  27     hoArgs :: [HsUseMap]   -- ^ Which arguments are already applied? This
  28                          -- ^ map should only contain Port and other
  29                          --   HighOrder values.
  30   }
  31   deriving (Show, Eq, Ord)
  32
  33 -- | Is this HsValueUse a state use?
  34 isStateUse :: HsValueUse -> Bool
  35 isStateUse (State _) = True
  36 isStateUse _         = False
  37
  38 -- | A map from a Haskell value to the use of each single value
  39 type HsUseMap = HsValueMap HsValueUse
  40
  41 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
  42 --   which all the Single elements are marked as State, with increasing state
  43 --   numbers.
  44 useAsState :: HsValueMap a -> HsUseMap
  45 useAsState map =
  46   map'
  47   where
  48     -- Traverse the existing map, resulting in a function that maps an initial
  49     -- state number to the final state number and the new map
  50     PassState f = traverse asState map
  51     -- Run this function to get the new map
  52     (_, map')   = f 0
  53     -- This function maps each element to a State with a unique number, by
  54     -- incrementing the state count.
  55     asState x   = PassState (\s -> (s+1, State s))
  56
  57 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
  58 --   which all the Single elements are marked as Port.
  59 useAsPort :: HsValueMap a -> HsUseMap
  60 useAsPort map = fmap (\x -> Port) map
  61
  62 -- | A Haskell function with a specific signature. The signature defines what
  63 --   use the arguments and return value of the function get.
  64 data HsFunction = HsFunction {
  65   hsFuncName :: String,
  66   hsFuncArgs :: [HsUseMap],
  67   hsFuncRes  :: HsUseMap
  68 } deriving (Show, Eq, Ord)
  69
  70 hasState :: HsFunction -> Bool
  71 hasState hsfunc =
  72   any (Foldable.any isStateUse) (hsFuncArgs hsfunc)
  73   || Foldable.any isStateUse (hsFuncRes hsfunc)
  74
  75 -- | A flattened function application
  76 data FApp = FApp {
  77   appFunc :: HsFunction,
  78   appArgs :: [SignalMap],
  79   appRes  :: SignalMap
  80 } deriving (Show, Eq)
  81
  82 -- | A conditional signal definition
  83 data CondDef = CondDef {
  84   cond    :: SignalId,
  85   high    :: SignalId,
  86   low     :: SignalId,
  87   condRes :: SignalId
  88 } deriving (Show, Eq)
  89
  90 -- | How is a given signal used in the resulting VHDL?
  91 data SigUse =
  92   SigPortIn          -- | Use as an input port
  93   | SigPortOut       -- | Use as an input port
  94   | SigInternal      -- | Use as an internal signal
  95   | SigStateOld Int  -- | Use as the current internal state
  96   | SigStateNew Int  -- | Use as the new internal state
  97   | SigSubState      -- | Do not use, state variable is used in a subcircuit
  98
  99 -- | Is this a port signal use?
 100 isPortSigUse :: SigUse -> Bool
 101 isPortSigUse SigPortIn = True
 102 isPortSigUse SigPortOut = True
 103 isPortSigUse _ = False
 104
 105 -- | Is this a state signal use? Returns false for substate.
 106 isStateSigUse :: SigUse -> Bool
 107 isStateSigUse (SigStateOld _) = True
 108 isStateSigUse (SigStateNew _) = True
 109 isStateSigUse _ = False
 110
 111 -- | Is this an internal signal use?
 112 isInternalSigUse :: SigUse -> Bool
 113 isInternalSigUse SigInternal = True
 114 isInternalSigUse _ = False
 115
 116 -- | Information on a signal definition
 117 data SignalInfo = SignalInfo {
 118   sigName :: Maybe String,
 119   sigUse  :: SigUse,
 120   sigTy   :: Type.Type
 121 }
 122
 123 -- | A flattened function
 124 data FlatFunction = FlatFunction {
 125   flat_args   :: [SignalMap],
 126   flat_res    :: SignalMap,
 127   flat_apps   :: [FApp],
 128   flat_conds  :: [CondDef],
 129   flat_sigs   :: [(SignalId, SignalInfo)]
 130 }
 131
 132 -- | Lookup a given signal id in a signal map, and return the associated
 133 --   SignalInfo. Errors out if the signal was not found.
 134 signalInfo :: [(SignalId, SignalInfo)] -> SignalId -> SignalInfo
 135 signalInfo sigs id = Maybe.fromJust $ lookup id sigs
 136
 137 -- | A list of binds in effect at a particular point of evaluation
 138 type BindMap = [(
 139   CoreBndr,            -- ^ The bind name
 140   Either               -- ^ The bind value which is either
 141     (SignalMap)
 142                        -- ^ a signal
 143     (
 144       HsValueUse,      -- ^ or a HighOrder function
 145       [SignalId]       -- ^ With these signals already applied to it
 146     )
 147   )]
 148
 149 -- | The state during the flattening of a single function
 150 type FlattenState = State.State ([FApp], [CondDef], [(SignalId, SignalInfo)], SignalId)
 151
 152 -- | Add an application to the current FlattenState
 153 addApp :: (FApp) -> FlattenState ()
 154 addApp a = do
 155   (apps, conds, sigs, n) <- State.get
 156   State.put (a:apps, conds, sigs, n)
 157
 158 -- | Add a conditional definition to the current FlattenState
 159 addCondDef :: (CondDef) -> FlattenState ()
 160 addCondDef c = do
 161   (apps, conds, sigs, n) <- State.get
 162   State.put (apps, c:conds, sigs, n)
 163
 164 -- | Generates a new signal id, which is unique within the current flattening.
 165 genSignalId :: SigUse -> Type.Type -> FlattenState SignalId
 166 genSignalId use ty = do
 167   (apps, conds, sigs, n) <- State.get
 168   -- Generate a new numbered but unnamed signal
 169   let s = (n, SignalInfo Nothing use ty)
 170   State.put (apps, conds, s:sigs, n+1)
 171   return n