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