FlattenTypes.hs

   1 module FlattenTypes where
   2
   3 import Data.Traversable
   4 import qualified Control.Monad.State as State
   5
   6 import CoreSyn
   7 import qualified Type
   8
   9 import HsValueMap
  10
  11 -- | A signal identifier
  12 type UnnamedSignal = Int
  13
  14 -- | A map of a Haskell value to signal ids
  15 type SignalMap sigid = HsValueMap sigid
  16
  17 -- | How is a given (single) value in a function's type (ie, argument or
  18 -- return value) used?
  19 data HsValueUse =
  20   Port           -- ^ Use it as a port (input or output)
  21   | State Int    -- ^ Use it as state (input or output). The int is used to
  22                  --   match input state to output state.
  23   | HighOrder {  -- ^ Use it as a high order function input
  24     hoName :: String,  -- ^ Which function is passed in?
  25     hoArgs :: [HsUseMap]   -- ^ Which arguments are already applied? This
  26                          -- ^ map should only contain Port and other
  27                          --   HighOrder values.
  28   }
  29   deriving (Show, Eq, Ord)
  30
  31 -- | A map from a Haskell value to the use of each single value
  32 type HsUseMap = HsValueMap HsValueUse
  33
  34 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
  35 --   which all the Single elements are marked as State, with increasing state
  36 --   numbers.
  37 useAsState :: HsValueMap a -> HsUseMap
  38 useAsState map =
  39   map'
  40   where
  41     -- Traverse the existing map, resulting in a function that maps an initial
  42     -- state number to the final state number and the new map
  43     PassState f = traverse asState map
  44     -- Run this function to get the new map
  45     (_, map')   = f 0
  46     -- This function maps each element to a State with a unique number, by
  47     -- incrementing the state count.
  48     asState x   = PassState (\s -> (s+1, State s))
  49
  50 -- | Builds a HsUseMap with the same structure has the given HsValueMap in
  51 --   which all the Single elements are marked as Port.
  52 useAsPort :: HsValueMap a -> HsUseMap
  53 useAsPort map = fmap (\x -> Port) map
  54
  55 -- | A Haskell function with a specific signature. The signature defines what
  56 --   use the arguments and return value of the function get.
  57 data HsFunction = HsFunction {
  58   hsFuncName :: String,
  59   hsFuncArgs :: [HsUseMap],
  60   hsFuncRes  :: HsUseMap
  61 } deriving (Show, Eq, Ord)
  62
  63 -- | A flattened function application
  64 data FApp sigid = FApp {
  65   appFunc :: HsFunction,
  66   appArgs :: [SignalMap sigid],
  67   appRes  :: SignalMap sigid
  68 } deriving (Show, Eq)
  69
  70 -- | A conditional signal definition
  71 data CondDef sigid = CondDef {
  72   cond    :: sigid,
  73   high    :: sigid,
  74   low     :: sigid,
  75   condRes :: sigid
  76 } deriving (Show, Eq)
  77
  78 -- | How is a given signal used in the resulting VHDL?
  79 data SigUse =
  80   SigPort         -- | Use as a port
  81   | SigInternal   -- | Use as an internal signal
  82   | SigState      -- | Use as an internal state
  83   | SigSubState   -- | Do not use, state variable is used in a subcircuit
  84
  85 -- | Information on a signal definition
  86 data SignalInfo = SignalInfo {
  87   sigName :: Maybe String,
  88   sigUse  :: SigUse,
  89   sigTy   :: Type.Type
  90 }
  91
  92 -- | A flattened function
  93 data FlatFunction' sigid = FlatFunction {
  94   flat_args   :: [SignalMap sigid],
  95   flat_res    :: SignalMap sigid,
  96   flat_apps   :: [FApp sigid],
  97   flat_conds  :: [CondDef sigid],
  98   flat_sigs   :: [(sigid, SignalInfo)]
  99 }
 100
 101 -- | A flat function that does not have its signals named
 102 type FlatFunction = FlatFunction' UnnamedSignal
 103
 104 -- | A list of binds in effect at a particular point of evaluation
 105 type BindMap = [(
 106   CoreBndr,            -- ^ The bind name
 107   Either               -- ^ The bind value which is either
 108     (SignalMap UnnamedSignal)
 109                        -- ^ a signal
 110     (
 111       HsValueUse,      -- ^ or a HighOrder function
 112       [UnnamedSignal]  -- ^ With these signals already applied to it
 113     )
 114   )]
 115
 116 -- | The state during the flattening of a single function
 117 type FlattenState = State.State ([FApp UnnamedSignal], [CondDef UnnamedSignal], [(UnnamedSignal, SignalInfo)], UnnamedSignal)
 118
 119 -- | Add an application to the current FlattenState
 120 addApp :: (FApp UnnamedSignal) -> FlattenState ()
 121 addApp a = do
 122   (apps, conds, sigs, n) <- State.get
 123   State.put (a:apps, conds, sigs, n)
 124
 125 -- | Add a conditional definition to the current FlattenState
 126 addCondDef :: (CondDef UnnamedSignal) -> FlattenState ()
 127 addCondDef c = do
 128   (apps, conds, sigs, n) <- State.get
 129   State.put (apps, c:conds, sigs, n)
 130
 131 -- | Generates a new signal id, which is unique within the current flattening.
 132 genSignalId :: SigUse -> Type.Type -> FlattenState UnnamedSignal
 133 genSignalId use ty = do
 134   (apps, conds, sigs, n) <- State.get
 135   -- Generate a new numbered but unnamed signal
 136   let s = (n, SignalInfo Nothing use ty)
 137   State.put (apps, conds, s:sigs, n+1)
 138   return n