Flatten.hs

   1 module Flatten where
   2 import CoreSyn
   3 import Control.Monad
   4 import qualified Var
   5 import qualified Type
   6 import qualified Name
   7 import qualified Maybe
   8 import qualified DataCon
   9 import qualified CoreUtils
  10 import qualified Data.Traversable as Traversable
  11 import qualified Data.Foldable as Foldable
  12 import Control.Applicative
  13 import Outputable ( showSDoc, ppr )
  14 import qualified Control.Monad.State as State
  15
  16 import HsValueMap
  17 import TranslatorTypes
  18 import FlattenTypes
  19
  20 -- Extract the arguments from a data constructor application (that is, the
  21 -- normal args, leaving out the type args).
  22 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
  23 dataConAppArgs dc args =
  24     drop tycount args
  25   where
  26     tycount = length $ DataCon.dataConAllTyVars dc
  27
  28 genSignals ::
  29   Type.Type
  30   -> FlattenState (SignalMap UnnamedSignal)
  31
  32 genSignals ty =
  33   -- First generate a map with the right structure containing the types, and
  34   -- generate signals for each of them.
  35   Traversable.mapM (\ty -> genSignalId SigInternal ty) (mkHsValueMap ty)
  36
  37 -- | Marks a signal as the given SigUse, if its id is in the list of id's
  38 --   given.
  39 markSignal :: SigUse -> [UnnamedSignal] -> (UnnamedSignal, SignalInfo) -> (UnnamedSignal, SignalInfo)
  40 markSignal use ids (id, info) =
  41   (id, info')
  42   where
  43     info' = if id `elem` ids then info { sigUse = use} else info
  44
  45 -- | Flatten a haskell function
  46 flattenFunction ::
  47   HsFunction                      -- ^ The function to flatten
  48   -> CoreBind                     -- ^ The function value
  49   -> FlatFunction                 -- ^ The resulting flat function
  50
  51 flattenFunction _ (Rec _) = error "Recursive binders not supported"
  52 flattenFunction hsfunc bind@(NonRec var expr) =
  53   FlatFunction args res apps conds sigs'
  54   where
  55     init_state        = ([], [], [], 0)
  56     (fres, end_state) = State.runState (flattenExpr [] expr) init_state
  57     (args, res)       = fres
  58     portlist          = concat (map Foldable.toList (res:args))
  59     (apps, conds, sigs, _)  = end_state
  60     sigs'             = fmap (markSignal SigPort portlist) sigs
  61
  62 flattenExpr ::
  63   BindMap
  64   -> CoreExpr
  65   -> FlattenState ([SignalMap UnnamedSignal], (SignalMap UnnamedSignal))
  66
  67 flattenExpr binds lam@(Lam b expr) = do
  68   -- Find the type of the binder
  69   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
  70   -- Create signal names for the binder
  71   defs <- genSignals arg_ty
  72   let binds' = (b, Left defs):binds
  73   (args, res) <- flattenExpr binds' expr
  74   return (defs : args, res)
  75
  76 flattenExpr binds (Var id) =
  77   case bind of
  78     Left sig_use -> return ([], sig_use)
  79     Right _ -> error "Higher order functions not supported."
  80   where
  81     bind = Maybe.fromMaybe
  82       (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
  83       (lookup id binds)
  84
  85 flattenExpr binds app@(App _ _) = do
  86   -- Is this a data constructor application?
  87   case CoreUtils.exprIsConApp_maybe app of
  88     -- Is this a tuple construction?
  89     Just (dc, args) -> if DataCon.isTupleCon dc
  90       then
  91         flattenBuildTupleExpr binds (dataConAppArgs dc args)
  92       else
  93         error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
  94     otherwise ->
  95       -- Normal function application
  96       let ((Var f), args) = collectArgs app in
  97       flattenApplicationExpr binds (CoreUtils.exprType app) f args
  98   where
  99     flattenBuildTupleExpr binds args = do
 100       -- Flatten each of our args
 101       flat_args <- (State.mapM (flattenExpr binds) args)
 102       -- Check and split each of the arguments
 103       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
 104       let res = Tuple arg_ress
 105       return ([], res)
 106
 107     -- | Flatten a normal application expression
 108     flattenApplicationExpr binds ty f args = do
 109       -- Find the function to call
 110       let func = appToHsFunction ty f args
 111       -- Flatten each of our args
 112       flat_args <- (State.mapM (flattenExpr binds) args)
 113       -- Check and split each of the arguments
 114       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
 115       -- Generate signals for our result
 116       res <- genSignals ty
 117       -- Create the function application
 118       let app = FApp {
 119         appFunc = func,
 120         appArgs = arg_ress,
 121         appRes  = res
 122       }
 123       addApp app
 124       return ([], res)
 125     -- | Check a flattened expression to see if it is valid to use as a
 126     --   function argument. The first argument is the original expression for
 127     --   use in the error message.
 128     checkArg arg flat =
 129       let (args, res) = flat in
 130       if not (null args)
 131         then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
 132         else flat
 133
 134 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
 135   (b_args, b_res) <- flattenExpr binds bexpr
 136   if not (null b_args)
 137     then
 138       error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
 139     else
 140       let binds' = (b, Left b_res) : binds in
 141       flattenExpr binds' expr
 142
 143 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
 144
 145 flattenExpr binds expr@(Case (Var v) b _ alts) =
 146   case alts of
 147     [alt] -> flattenSingleAltCaseExpr binds v b alt
 148     otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
 149   where
 150     flattenSingleAltCaseExpr ::
 151       BindMap
 152                                 -- A list of bindings in effect
 153       -> Var.Var                -- The scrutinee
 154       -> CoreBndr               -- The binder to bind the scrutinee to
 155       -> CoreAlt                -- The single alternative
 156       -> FlattenState ( [SignalMap UnnamedSignal], SignalMap UnnamedSignal)
 157                                            -- See expandExpr
 158     flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
 159       if not (DataCon.isTupleCon datacon)
 160         then
 161           error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
 162         else
 163           let
 164             -- Lookup the scrutinee (which must be a variable bound to a tuple) in
 165             -- the existing bindings list and get the portname map for each of
 166             -- it's elements.
 167             Left (Tuple tuple_sigs) = Maybe.fromMaybe
 168               (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
 169               (lookup v binds)
 170             -- TODO include b in the binds list
 171             -- Merge our existing binds with the new binds.
 172             binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
 173           in
 174             -- Expand the expression with the new binds list
 175             flattenExpr binds' expr
 176     flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
 177
 178
 179
 180 flattenExpr _ _ = do
 181   return ([], Tuple [])
 182
 183 appToHsFunction ::
 184   Type.Type       -- ^ The return type
 185   -> Var.Var      -- ^ The function to call
 186   -> [CoreExpr]   -- ^ The function arguments
 187   -> HsFunction   -- ^ The needed HsFunction
 188
 189 appToHsFunction ty f args =
 190   HsFunction hsname hsargs hsres
 191   where
 192     hsname = Name.getOccString f
 193     hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
 194     hsres  = useAsPort (mkHsValueMap ty)
 195
 196 -- | Translates signal id's to SignalInfo for any signals used as state.
 197 findState ::
 198   [(UnnamedSignal, SignalInfo)] -- | A map of id to info
 199   -> UnnamedSignal              -- | The signal id to look at
 200   -> HsValueUse                 -- | How is this signal used?
 201   -> Maybe (Int, SignalInfo)    -- | The state num and SignalInfo, if appropriate
 202
 203 findState sigs id (State num) =
 204   Just (num, Maybe.fromJust $ lookup id sigs)
 205 findState _ _ _ = Nothing
 206
 207
 208 -- | Returns pairs of signals that should be mapped to state in this function.
 209 getOwnStates ::
 210   HsFunction                      -- | The function to look at
 211   -> FlatFunction                 -- | The function to look at
 212   -> [(Int, SignalInfo, SignalInfo)]
 213         -- | The state signals. The first is the state number, the second the
 214         --   signal to assign the current state to, the last is the signal
 215         --   that holds the new state.
 216
 217 getOwnStates hsfunc flatfunc =
 218   [(old_num, old_info, new_info)
 219     | (old_num, old_info) <- args_states
 220     , (new_num, new_info) <- res_states
 221     , old_num == new_num]
 222   where
 223     sigs = flat_sigs flatfunc
 224     -- Translate args and res to lists of (statenum, SignalInfo)
 225     args = zipWith (zipValueMapsWith $ findState sigs) (flat_args flatfunc) (hsFuncArgs hsfunc)
 226     args_states = Maybe.catMaybes $ concat $ map Foldable.toList $ args
 227     res = zipValueMapsWith (findState sigs) (flat_res flatfunc) (hsFuncRes hsfunc)
 228     res_states = Maybe.catMaybes $ Foldable.toList res
 229
 230
 231 -- vim: set ts=8 sw=2 sts=2 expandtab: