Flatten.hs

   1 module Flatten where
   2 import CoreSyn
   3 import qualified Control.Monad.State as State
   4
   5 -- | A datatype that maps each of the single values in a haskell structure to
   6 -- a mapto. The map has the same structure as the haskell type mapped, ie
   7 -- nested tuples etc.
   8 data HsValueMap mapto =
   9   Tuple [HsValueMap mapto]
  10   | Single mapto
  11   | Unused
  12   deriving (Show, Eq)
  13
  14 data FlatFunction = FlatFunction {
  15   args   :: [SignalDefMap],
  16   res    :: SignalUseMap,
  17   --sigs   :: [SignalDef],
  18   apps   :: [App],
  19   conds  :: [CondDef]
  20 } deriving (Show, Eq)
  21
  22 type SignalUseMap = HsValueMap SignalUse
  23 type SignalDefMap = HsValueMap SignalDef
  24
  25 type SignalId = Int
  26 data SignalUse = SignalUse {
  27   sigUseId :: SignalId
  28 } deriving (Show, Eq)
  29
  30 data SignalDef = SignalDef {
  31   sigDefId :: SignalId
  32 } deriving (Show, Eq)
  33
  34 data App = App {
  35   appFunc :: HsFunction,
  36   appArgs :: [SignalUseMap],
  37   appRes  :: SignalDefMap
  38 } deriving (Show, Eq)
  39
  40 data CondDef = CondDef {
  41   cond    :: SignalUse,
  42   high    :: SignalUse,
  43   low     :: SignalUse,
  44   condRes :: SignalDef
  45 } deriving (Show, Eq)
  46
  47 -- | How is a given (single) value in a function's type (ie, argument or
  48 -- return value) used?
  49 data HsValueUse =
  50   Port           -- ^ Use it as a port (input or output)
  51   | State Int    -- ^ Use it as state (input or output). The int is used to
  52                  --   match input state to output state.
  53   | HighOrder {  -- ^ Use it as a high order function input
  54     hoName :: String,  -- ^ Which function is passed in?
  55     hoArgs :: [HsUseMap]   -- ^ Which arguments are already applied? This
  56                          -- ^ map should only contain Port and other
  57                          --   HighOrder values.
  58   }
  59   deriving (Show, Eq)
  60
  61 type HsUseMap = HsValueMap HsValueUse
  62
  63 data HsFunction = HsFunction {
  64   hsFuncName :: String,
  65   hsFuncArgs :: [HsUseMap],
  66   hsFuncRes  :: HsUseMap
  67 } deriving (Show, Eq)
  68
  69 type BindMap = [(
  70   String,              -- ^ The bind name
  71   Either               -- ^ The bind value which is either
  72     SignalUse          -- ^ a signal
  73     (
  74       HsValueUse,      -- ^ or a HighOrder function
  75       [SignalUse]      -- ^ With these signals already applied to it
  76     )
  77   )]
  78
  79 type FlattenState = State.State ([App], [CondDef], SignalId)
  80
  81 -- | Add an application to the current FlattenState
  82 addApp :: App -> FlattenState ()
  83 addApp a = do
  84   (apps, conds, n) <- State.get
  85   State.put (a:apps, conds, n)
  86
  87 -- | Add a conditional definition to the current FlattenState
  88 addCondDef :: CondDef -> FlattenState ()
  89 addCondDef c = do
  90   (apps, conds, n) <- State.get
  91   State.put (apps, c:conds, n)
  92
  93 -- | Generates a new signal id, which is unique within the current flattening.
  94 genSignalId :: FlattenState SignalId
  95 genSignalId = do
  96   (apps, conds, n) <- State.get
  97   State.put (apps, conds, n+1)
  98   return n
  99
 100 -- | Flatten a haskell function
 101 flattenFunction ::
 102   HsFunction                      -- ^ The function to flatten
 103   -> CoreBind                     -- ^ The function value
 104   -> FlatFunction                 -- ^ The resulting flat function
 105
 106 flattenFunction _ (Rec _) = error "Recursive binders not supported"
 107 flattenFunction hsfunc bind@(NonRec var expr) =
 108   FlatFunction args res apps conds
 109   where
 110     init_state        = ([], [], 0)
 111     (fres, end_state) = State.runState (flattenExpr [] expr) init_state
 112     (args, res)       = fres
 113     (apps, conds, _)  = end_state
 114
 115 flattenExpr ::
 116   BindMap
 117   -> CoreExpr
 118   -> FlattenState ([SignalDefMap], SignalUseMap)
 119
 120
 121 flattenExpr _ _ = do
 122   return ([], Tuple [])
 123
 124
 125
 126
 127 -- vim: set ts=8 sw=2 sts=2 expandtab: