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