FlattenTypes.hs

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