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