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