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 type SignalId = Int
  65 data SignalUse = SignalUse {
  66   sigUseId :: SignalId
  67 } deriving (Show, Eq)
  68
  69 data SignalDef = SignalDef {
  70   sigDefId :: SignalId
  71 } deriving (Show, Eq)
  72
  73 data FApp = FApp {
  74   appFunc :: HsFunction,
  75   appArgs :: [SignalUseMap],
  76   appRes  :: SignalDefMap
  77 } deriving (Show, Eq)
  78
  79 data CondDef = CondDef {
  80   cond    :: SignalUse,
  81   high    :: SignalUse,
  82   low     :: SignalUse,
  83   condRes :: SignalDef
  84 } deriving (Show, Eq)
  85
  86 -- | How is a given (single) value in a function's type (ie, argument or
  87 -- return value) used?
  88 data HsValueUse =
  89   Port           -- ^ Use it as a port (input or output)
  90   | State Int    -- ^ Use it as state (input or output). The int is used to
  91                  --   match input state to output state.
  92   | HighOrder {  -- ^ Use it as a high order function input
  93     hoName :: String,  -- ^ Which function is passed in?
  94     hoArgs :: [HsUseMap]   -- ^ Which arguments are already applied? This
  95                          -- ^ map should only contain Port and other
  96                          --   HighOrder values.
  97   }
  98   deriving (Show, Eq)
  99
 100 type HsUseMap = HsValueMap HsValueUse
 101
 102 data HsFunction = HsFunction {
 103   hsFuncName :: String,
 104   hsFuncArgs :: [HsUseMap],
 105   hsFuncRes  :: HsUseMap
 106 } deriving (Show, Eq)
 107
 108 type BindMap = [(
 109   CoreBndr,            -- ^ The bind name
 110   Either               -- ^ The bind value which is either
 111     SignalUseMap       -- ^ a signal
 112     (
 113       HsValueUse,      -- ^ or a HighOrder function
 114       [SignalUse]      -- ^ With these signals already applied to it
 115     )
 116   )]
 117
 118 type FlattenState = State.State ([FApp], [CondDef], SignalId)
 119
 120 -- | Add an application to the current FlattenState
 121 addApp :: FApp -> FlattenState ()
 122 addApp a = do
 123   (apps, conds, n) <- State.get
 124   State.put (a:apps, conds, n)
 125
 126 -- | Add a conditional definition to the current FlattenState
 127 addCondDef :: CondDef -> FlattenState ()
 128 addCondDef c = do
 129   (apps, conds, n) <- State.get
 130   State.put (apps, c:conds, n)
 131
 132 -- | Generates a new signal id, which is unique within the current flattening.
 133 genSignalId :: FlattenState SignalId
 134 genSignalId = do
 135   (apps, conds, n) <- State.get
 136   State.put (apps, conds, n+1)
 137   return n
 138
 139 genSignalUses ::
 140   Type.Type
 141   -> FlattenState SignalUseMap
 142
 143 genSignalUses ty = do
 144   typeMapToUseMap tymap
 145   where
 146     -- First generate a map with the right structure containing the types
 147     tymap = mkHsValueMap ty
 148
 149 typeMapToUseMap ::
 150   HsValueMap Type.Type
 151   -> FlattenState SignalUseMap
 152
 153 typeMapToUseMap (Single ty) = do
 154   id <- genSignalId
 155   return $ Single (SignalUse id)
 156
 157 typeMapToUseMap (Tuple tymaps) = do
 158   usemaps <- mapM typeMapToUseMap tymaps
 159   return $ Tuple usemaps
 160
 161 -- | Flatten a haskell function
 162 flattenFunction ::
 163   HsFunction                      -- ^ The function to flatten
 164   -> CoreBind                     -- ^ The function value
 165   -> FlatFunction                 -- ^ The resulting flat function
 166
 167 flattenFunction _ (Rec _) = error "Recursive binders not supported"
 168 flattenFunction hsfunc bind@(NonRec var expr) =
 169   FlatFunction args res apps conds
 170   where
 171     init_state        = ([], [], 0)
 172     (fres, end_state) = State.runState (flattenExpr [] expr) init_state
 173     (args, res)       = fres
 174     (apps, conds, _)  = end_state
 175
 176 flattenExpr ::
 177   BindMap
 178   -> CoreExpr
 179   -> FlattenState ([SignalDefMap], SignalUseMap)
 180
 181 flattenExpr binds lam@(Lam b expr) = do
 182   -- Find the type of the binder
 183   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
 184   -- Create signal names for the binder
 185   defs <- genSignalUses arg_ty
 186   let binds' = (b, Left defs):binds
 187   (args, res) <- flattenExpr binds' expr
 188   return ((useMapToDefMap defs) : args, res)
 189
 190 flattenExpr binds (Var id) =
 191   case bind of
 192     Left sig_use -> return ([], sig_use)
 193     Right _ -> error "Higher order functions not supported."
 194   where
 195     bind = Maybe.fromMaybe
 196       (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
 197       (lookup id binds)
 198
 199 flattenExpr binds app@(App _ _) = do
 200   -- Is this a data constructor application?
 201   case CoreUtils.exprIsConApp_maybe app of
 202     -- Is this a tuple construction?
 203     Just (dc, args) -> if DataCon.isTupleCon dc
 204       then
 205         flattenBuildTupleExpr binds (dataConAppArgs dc args)
 206       else
 207         error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
 208     otherwise ->
 209       -- Normal function application
 210       let ((Var f), args) = collectArgs app in
 211       flattenApplicationExpr binds (CoreUtils.exprType app) f args
 212   where
 213     flattenBuildTupleExpr = error $ "Tuple construction not supported: " ++ (showSDoc $ ppr app)
 214     flattenApplicationExpr binds ty f args = error $ "Function application not supported: " ++ (showSDoc $ ppr app)
 215
 216 flattenExpr _ _ = do
 217   return ([], Tuple [])
 218
 219
 220 -- vim: set ts=8 sw=2 sts=2 expandtab: