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