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 UnnamedSignal = Int
  15
  16 -- | A map of a Haskell value to signal ids
  17 type SignalMap sigid = HsValueMap sigid
  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 sigid = FApp {
  77   appFunc :: HsFunction,
  78   appArgs :: [SignalMap sigid],
  79   appRes  :: SignalMap sigid
  80 } deriving (Show, Eq)
  81
  82 -- | A conditional signal definition
  83 data CondDef sigid = CondDef {
  84   cond    :: sigid,
  85   high    :: sigid,
  86   low     :: sigid,
  87   condRes :: sigid
  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 -- | Information on a signal definition
 100 data SignalInfo = SignalInfo {
 101   sigName :: Maybe String,
 102   sigUse  :: SigUse,
 103   sigTy   :: Type.Type
 104 }
 105
 106 -- | A flattened function
 107 data FlatFunction' sigid = FlatFunction {
 108   flat_args   :: [SignalMap sigid],
 109   flat_res    :: SignalMap sigid,
 110   flat_apps   :: [FApp sigid],
 111   flat_conds  :: [CondDef sigid],
 112   flat_sigs   :: [(sigid, SignalInfo)]
 113 }
 114
 115 -- | Lookup a given signal id in a signal map, and return the associated
 116 --   SignalInfo. Errors out if the signal was not found.
 117 signalInfo :: Eq sigid => [(sigid, SignalInfo)] -> sigid -> SignalInfo
 118 signalInfo sigs id = Maybe.fromJust $ lookup id sigs
 119
 120 -- | A flat function that does not have its signals named
 121 type FlatFunction = FlatFunction' UnnamedSignal
 122
 123 -- | A list of binds in effect at a particular point of evaluation
 124 type BindMap = [(
 125   CoreBndr,            -- ^ The bind name
 126   Either               -- ^ The bind value which is either
 127     (SignalMap UnnamedSignal)
 128                        -- ^ a signal
 129     (
 130       HsValueUse,      -- ^ or a HighOrder function
 131       [UnnamedSignal]  -- ^ With these signals already applied to it
 132     )
 133   )]
 134
 135 -- | The state during the flattening of a single function
 136 type FlattenState = State.State ([FApp UnnamedSignal], [CondDef UnnamedSignal], [(UnnamedSignal, SignalInfo)], UnnamedSignal)
 137
 138 -- | Add an application to the current FlattenState
 139 addApp :: (FApp UnnamedSignal) -> FlattenState ()
 140 addApp a = do
 141   (apps, conds, sigs, n) <- State.get
 142   State.put (a:apps, conds, sigs, n)
 143
 144 -- | Add a conditional definition to the current FlattenState
 145 addCondDef :: (CondDef UnnamedSignal) -> FlattenState ()
 146 addCondDef c = do
 147   (apps, conds, sigs, n) <- State.get
 148   State.put (apps, c:conds, sigs, n)
 149
 150 -- | Generates a new signal id, which is unique within the current flattening.
 151 genSignalId :: SigUse -> Type.Type -> FlattenState UnnamedSignal
 152 genSignalId use ty = do
 153   (apps, conds, sigs, n) <- State.get
 154   -- Generate a new numbered but unnamed signal
 155   let s = (n, SignalInfo Nothing use ty)
 156   State.put (apps, conds, s:sigs, n+1)
 157   return n