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   name :: Maybe String
  81 } deriving (Eq, Show)
  82
  83 -- | A flattened function
  84 data FlatFunction' sigid = FlatFunction {
  85   args   :: [SignalMap sigid],
  86   res    :: SignalMap sigid,
  87   apps   :: [FApp sigid],
  88   conds  :: [CondDef sigid],
  89   sigs   :: [Signal sigid]
  90 } deriving (Show, Eq)
  91
  92 -- | A flat function that does not have its signals named
  93 type FlatFunction = FlatFunction' UnnamedSignal
  94
  95 -- | A list of binds in effect at a particular point of evaluation
  96 type BindMap = [(
  97   CoreBndr,            -- ^ The bind name
  98   Either               -- ^ The bind value which is either
  99     (SignalMap UnnamedSignal)
 100                        -- ^ a signal
 101     (
 102       HsValueUse,      -- ^ or a HighOrder function
 103       [UnnamedSignal]  -- ^ With these signals already applied to it
 104     )
 105   )]
 106
 107 -- | The state during the flattening of a single function
 108 type FlattenState = State.State ([FApp UnnamedSignal], [CondDef UnnamedSignal], [Signal UnnamedSignal], UnnamedSignal)
 109
 110 -- | Add an application to the current FlattenState
 111 addApp :: (FApp UnnamedSignal) -> FlattenState ()
 112 addApp a = do
 113   (apps, conds, sigs, n) <- State.get
 114   State.put (a:apps, conds, sigs, n)
 115
 116 -- | Add a conditional definition to the current FlattenState
 117 addCondDef :: (CondDef UnnamedSignal) -> FlattenState ()
 118 addCondDef c = do
 119   (apps, conds, sigs, n) <- State.get
 120   State.put (apps, c:conds, sigs, n)
 121
 122 -- | Generates a new signal id, which is unique within the current flattening.
 123 genSignalId :: FlattenState UnnamedSignal
 124 genSignalId = do
 125   (apps, conds, sigs, n) <- State.get
 126   -- Generate a new numbered but unnamed signal
 127   let s = Signal n Nothing
 128   State.put (apps, conds, s:sigs, n+1)
 129   return n