Flatten.hs

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