Flatten.hs

   1 module Flatten where
   2 import CoreSyn
   3 import qualified Type
   4 import qualified Name
   5 import qualified TyCon
   6 import qualified Maybe
   7 import qualified DataCon
   8 import qualified CoreUtils
   9 import Outputable ( showSDoc, ppr )
  10 import qualified Control.Monad.State as State
  11
  12 -- | A datatype that maps each of the single values in a haskell structure to
  13 -- a mapto. The map has the same structure as the haskell type mapped, ie
  14 -- nested tuples etc.
  15 data HsValueMap mapto =
  16   Tuple [HsValueMap mapto]
  17   | Single mapto
  18   deriving (Show, Eq)
  19
  20 instance Functor HsValueMap where
  21   fmap f (Single s) = Single (f s)
  22   fmap f (Tuple maps) = Tuple (fmap (fmap f) maps)
  23
  24 -- | Creates a HsValueMap with the same structure as the given type, using the
  25 --   given function for mapping the single types.
  26 mkHsValueMap ::
  27   Type.Type                         -- ^ The type to map to a HsValueMap
  28   -> HsValueMap Type.Type           -- ^ The resulting map and state
  29
  30 mkHsValueMap ty =
  31   case Type.splitTyConApp_maybe ty of
  32     Just (tycon, args) ->
  33       if (TyCon.isTupleTyCon tycon)
  34         then
  35           Tuple (map mkHsValueMap args)
  36         else
  37           Single ty
  38     Nothing -> Single ty
  39
  40 -- Extract the arguments from a data constructor application (that is, the
  41 -- normal args, leaving out the type args).
  42 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
  43 dataConAppArgs dc args =
  44     drop tycount args
  45   where
  46     tycount = length $ DataCon.dataConAllTyVars dc
  47
  48
  49
  50 data FlatFunction = FlatFunction {
  51   args   :: [SignalDefMap],
  52   res    :: SignalUseMap,
  53   --sigs   :: [SignalDef],
  54   apps   :: [FApp],
  55   conds  :: [CondDef]
  56 } deriving (Show, Eq)
  57
  58 type SignalUseMap = HsValueMap SignalUse
  59 type SignalDefMap = HsValueMap SignalDef
  60
  61 useMapToDefMap :: SignalUseMap -> SignalDefMap
  62 useMapToDefMap = fmap (\(SignalUse u) -> SignalDef u)
  63
  64 defMapToUseMap :: SignalDefMap -> SignalUseMap
  65 defMapToUseMap = fmap (\(SignalDef u) -> SignalUse u)
  66
  67
  68 type SignalId = Int
  69 data SignalUse = SignalUse {
  70   sigUseId :: SignalId
  71 } deriving (Show, Eq)
  72
  73 data SignalDef = SignalDef {
  74   sigDefId :: SignalId
  75 } deriving (Show, Eq)
  76
  77 data FApp = FApp {
  78   appFunc :: HsFunction,
  79   appArgs :: [SignalUseMap],
  80   appRes  :: SignalDefMap
  81 } deriving (Show, Eq)
  82
  83 data CondDef = CondDef {
  84   cond    :: SignalUse,
  85   high    :: SignalUse,
  86   low     :: SignalUse,
  87   condRes :: SignalDef
  88 } deriving (Show, Eq)
  89
  90 -- | How is a given (single) value in a function's type (ie, argument or
  91 -- return value) used?
  92 data HsValueUse =
  93   Port           -- ^ Use it as a port (input or output)
  94   | State Int    -- ^ Use it as state (input or output). The int is used to
  95                  --   match input state to output state.
  96   | HighOrder {  -- ^ Use it as a high order function input
  97     hoName :: String,  -- ^ Which function is passed in?
  98     hoArgs :: [HsUseMap]   -- ^ Which arguments are already applied? This
  99                          -- ^ map should only contain Port and other
 100                          --   HighOrder values.
 101   }
 102   deriving (Show, Eq)
 103
 104 type HsUseMap = HsValueMap HsValueUse
 105
 106 data HsFunction = HsFunction {
 107   hsFuncName :: String,
 108   hsFuncArgs :: [HsUseMap],
 109   hsFuncRes  :: HsUseMap
 110 } deriving (Show, Eq)
 111
 112 type BindMap = [(
 113   CoreBndr,            -- ^ The bind name
 114   Either               -- ^ The bind value which is either
 115     SignalUseMap       -- ^ a signal
 116     (
 117       HsValueUse,      -- ^ or a HighOrder function
 118       [SignalUse]      -- ^ With these signals already applied to it
 119     )
 120   )]
 121
 122 type FlattenState = State.State ([FApp], [CondDef], SignalId)
 123
 124 -- | Add an application to the current FlattenState
 125 addApp :: FApp -> FlattenState ()
 126 addApp a = do
 127   (apps, conds, n) <- State.get
 128   State.put (a:apps, conds, n)
 129
 130 -- | Add a conditional definition to the current FlattenState
 131 addCondDef :: CondDef -> FlattenState ()
 132 addCondDef c = do
 133   (apps, conds, n) <- State.get
 134   State.put (apps, c:conds, n)
 135
 136 -- | Generates a new signal id, which is unique within the current flattening.
 137 genSignalId :: FlattenState SignalId
 138 genSignalId = do
 139   (apps, conds, n) <- State.get
 140   State.put (apps, conds, n+1)
 141   return n
 142
 143 genSignalUses ::
 144   Type.Type
 145   -> FlattenState SignalUseMap
 146
 147 genSignalUses ty = do
 148   typeMapToUseMap tymap
 149   where
 150     -- First generate a map with the right structure containing the types
 151     tymap = mkHsValueMap ty
 152
 153 typeMapToUseMap ::
 154   HsValueMap Type.Type
 155   -> FlattenState SignalUseMap
 156
 157 typeMapToUseMap (Single ty) = do
 158   id <- genSignalId
 159   return $ Single (SignalUse id)
 160
 161 typeMapToUseMap (Tuple tymaps) = do
 162   usemaps <- mapM typeMapToUseMap tymaps
 163   return $ Tuple usemaps
 164
 165 -- | Flatten a haskell function
 166 flattenFunction ::
 167   HsFunction                      -- ^ The function to flatten
 168   -> CoreBind                     -- ^ The function value
 169   -> FlatFunction                 -- ^ The resulting flat function
 170
 171 flattenFunction _ (Rec _) = error "Recursive binders not supported"
 172 flattenFunction hsfunc bind@(NonRec var expr) =
 173   FlatFunction args res apps conds
 174   where
 175     init_state        = ([], [], 0)
 176     (fres, end_state) = State.runState (flattenExpr [] expr) init_state
 177     (args, res)       = fres
 178     (apps, conds, _)  = end_state
 179
 180 flattenExpr ::
 181   BindMap
 182   -> CoreExpr
 183   -> FlattenState ([SignalDefMap], SignalUseMap)
 184
 185 flattenExpr binds lam@(Lam b expr) = do
 186   -- Find the type of the binder
 187   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
 188   -- Create signal names for the binder
 189   defs <- genSignalUses arg_ty
 190   let binds' = (b, Left defs):binds
 191   (args, res) <- flattenExpr binds' expr
 192   return ((useMapToDefMap defs) : args, res)
 193
 194 flattenExpr binds (Var id) =
 195   case bind of
 196     Left sig_use -> return ([], sig_use)
 197     Right _ -> error "Higher order functions not supported."
 198   where
 199     bind = Maybe.fromMaybe
 200       (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
 201       (lookup id binds)
 202
 203 flattenExpr binds app@(App _ _) = do
 204   -- Is this a data constructor application?
 205   case CoreUtils.exprIsConApp_maybe app of
 206     -- Is this a tuple construction?
 207     Just (dc, args) -> if DataCon.isTupleCon dc
 208       then
 209         flattenBuildTupleExpr binds (dataConAppArgs dc args)
 210       else
 211         error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
 212     otherwise ->
 213       -- Normal function application
 214       let ((Var f), args) = collectArgs app in
 215       flattenApplicationExpr binds (CoreUtils.exprType app) f args
 216   where
 217     flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app)
 218     flattenApplicationExpr binds ty f args = error $ "Function application not supported: " ++ (showSDoc $ ppr app)
 219
 220 flattenExpr _ _ = do
 221   return ([], Tuple [])
 222
 223
 224 -- vim: set ts=8 sw=2 sts=2 expandtab: