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 -- | A flattened function application
  79 data FApp = FApp {
  80   appFunc :: HsFunction,
  81   appArgs :: [SignalMap],
  82   appRes  :: SignalMap
  83 } deriving (Show, Eq)
  84
  85 -- | A conditional signal definition
  86 data CondDef = CondDef {
  87   cond    :: SignalId,
  88   high    :: SignalId,
  89   low     :: SignalId,
  90   condRes :: SignalId
  91 } deriving (Show, Eq)
  92
  93 -- | How is a given signal used in the resulting VHDL?
  94 data SigUse =
  95   SigPortIn          -- | Use as an input port
  96   | SigPortOut       -- | Use as an input port
  97   | SigInternal      -- | Use as an internal signal
  98   | SigStateOld StateId  -- | Use as the current internal state
  99   | SigStateNew StateId  -- | Use as the new internal state
 100   | SigSubState      -- | Do not use, state variable is used in a subcircuit
 101
 102 -- | Is this a port signal use?
 103 isPortSigUse :: SigUse -> Bool
 104 isPortSigUse SigPortIn = True
 105 isPortSigUse SigPortOut = True
 106 isPortSigUse _ = False
 107
 108 -- | Is this a state signal use? Returns false for substate.
 109 isStateSigUse :: SigUse -> Bool
 110 isStateSigUse (SigStateOld _) = True
 111 isStateSigUse (SigStateNew _) = True
 112 isStateSigUse _ = False
 113
 114 -- | Is this an internal signal use?
 115 isInternalSigUse :: SigUse -> Bool
 116 isInternalSigUse SigInternal = True
 117 isInternalSigUse _ = False
 118
 119 -- | Information on a signal definition
 120 data SignalInfo = SignalInfo {
 121   sigName :: Maybe String,
 122   sigUse  :: SigUse,
 123   sigTy   :: Type.Type
 124 }
 125
 126 -- | A flattened function
 127 data FlatFunction = FlatFunction {
 128   flat_args   :: [SignalMap],
 129   flat_res    :: SignalMap,
 130   flat_apps   :: [FApp],
 131   flat_conds  :: [CondDef],
 132   flat_sigs   :: [(SignalId, SignalInfo)]
 133 }
 134
 135 -- | Lookup a given signal id in a signal map, and return the associated
 136 --   SignalInfo. Errors out if the signal was not found.
 137 signalInfo :: [(SignalId, SignalInfo)] -> SignalId -> SignalInfo
 138 signalInfo sigs id = Maybe.fromJust $ lookup id sigs
 139
 140 -- | A list of binds in effect at a particular point of evaluation
 141 type BindMap = [(
 142   CoreBndr,            -- ^ The bind name
 143   Either               -- ^ The bind value which is either
 144     (SignalMap)
 145                        -- ^ a signal
 146     (
 147       HsValueUse,      -- ^ or a HighOrder function
 148       [SignalId]       -- ^ With these signals already applied to it
 149     )
 150   )]
 151
 152 -- | The state during the flattening of a single function
 153 type FlattenState = State.State ([FApp], [CondDef], [(SignalId, SignalInfo)], SignalId)
 154
 155 -- | Add an application to the current FlattenState
 156 addApp :: (FApp) -> FlattenState ()
 157 addApp a = do
 158   (apps, conds, sigs, n) <- State.get
 159   State.put (a:apps, conds, sigs, n)
 160
 161 -- | Add a conditional definition to the current FlattenState
 162 addCondDef :: (CondDef) -> FlattenState ()
 163 addCondDef c = do
 164   (apps, conds, sigs, n) <- State.get
 165   State.put (apps, c:conds, sigs, n)
 166
 167 -- | Generates a new signal id, which is unique within the current flattening.
 168 genSignalId :: SigUse -> Type.Type -> FlattenState SignalId
 169 genSignalId use ty = do
 170   (apps, conds, sigs, n) <- State.get
 171   -- Generate a new numbered but unnamed signal
 172   let s = (n, SignalInfo Nothing use ty)
 173   State.put (apps, conds, s:sigs, n+1)
 174   return n