FlattenTypes.hs

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