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 Control.Applicative
  11 import Outputable ( showSDoc, ppr )
  12 import qualified Control.Monad.State as State
  13
  14 import HsValueMap
  15 import TranslatorTypes
  16 import FlattenTypes
  17
  18 -- Extract the arguments from a data constructor application (that is, the
  19 -- normal args, leaving out the type args).
  20 dataConAppArgs :: DataCon.DataCon -> [CoreExpr] -> [CoreExpr]
  21 dataConAppArgs dc args =
  22     drop tycount args
  23   where
  24     tycount = length $ DataCon.dataConAllTyVars dc
  25
  26 genSignals ::
  27   Type.Type
  28   -> FlattenState (SignalMap UnnamedSignal)
  29
  30 genSignals ty = do
  31   typeMapToUseMap tymap
  32   where
  33     -- First generate a map with the right structure containing the types
  34     tymap = mkHsValueMap ty
  35
  36 typeMapToUseMap ::
  37   HsValueMap Type.Type
  38   -> FlattenState (SignalMap UnnamedSignal)
  39
  40 typeMapToUseMap (Single ty) = do
  41   id <- genSignalId
  42   return $ Single id
  43
  44 typeMapToUseMap (Tuple tymaps) = do
  45   usemaps <- State.mapM typeMapToUseMap tymaps
  46   return $ Tuple usemaps
  47
  48 -- | Flatten a haskell function
  49 flattenFunction ::
  50   HsFunction                      -- ^ The function to flatten
  51   -> CoreBind                     -- ^ The function value
  52   -> FlatFunction                 -- ^ The resulting flat function
  53
  54 flattenFunction _ (Rec _) = error "Recursive binders not supported"
  55 flattenFunction hsfunc bind@(NonRec var expr) =
  56   FlatFunction args res apps conds []
  57   where
  58     init_state        = ([], [], 0)
  59     (fres, end_state) = State.runState (flattenExpr [] expr) init_state
  60     (args, res)       = fres
  61     (apps, conds, _)  = end_state
  62
  63 flattenExpr ::
  64   BindMap
  65   -> CoreExpr
  66   -> FlattenState ([SignalMap UnnamedSignal], (SignalMap UnnamedSignal))
  67
  68 flattenExpr binds lam@(Lam b expr) = do
  69   -- Find the type of the binder
  70   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
  71   -- Create signal names for the binder
  72   defs <- genSignals arg_ty
  73   let binds' = (b, Left defs):binds
  74   (args, res) <- flattenExpr binds' expr
  75   return (defs : args, res)
  76
  77 flattenExpr binds (Var id) =
  78   case bind of
  79     Left sig_use -> return ([], sig_use)
  80     Right _ -> error "Higher order functions not supported."
  81   where
  82     bind = Maybe.fromMaybe
  83       (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
  84       (lookup id binds)
  85
  86 flattenExpr binds app@(App _ _) = do
  87   -- Is this a data constructor application?
  88   case CoreUtils.exprIsConApp_maybe app of
  89     -- Is this a tuple construction?
  90     Just (dc, args) -> if DataCon.isTupleCon dc
  91       then
  92         flattenBuildTupleExpr binds (dataConAppArgs dc args)
  93       else
  94         error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
  95     otherwise ->
  96       -- Normal function application
  97       let ((Var f), args) = collectArgs app in
  98       flattenApplicationExpr binds (CoreUtils.exprType app) f args
  99   where
 100     flattenBuildTupleExpr binds args = do
 101       -- Flatten each of our args
 102       flat_args <- (State.mapM (flattenExpr binds) args)
 103       -- Check and split each of the arguments
 104       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
 105       let res = Tuple arg_ress
 106       return ([], res)
 107
 108     -- | Flatten a normal application expression
 109     flattenApplicationExpr binds ty f args = do
 110       -- Find the function to call
 111       let func = appToHsFunction ty f args
 112       -- Flatten each of our args
 113       flat_args <- (State.mapM (flattenExpr binds) args)
 114       -- Check and split each of the arguments
 115       let (_, arg_ress) = unzip (zipWith checkArg args flat_args)
 116       -- Generate signals for our result
 117       res <- genSignals ty
 118       -- Create the function application
 119       let app = FApp {
 120         appFunc = func,
 121         appArgs = arg_ress,
 122         appRes  = res
 123       }
 124       addApp app
 125       return ([], res)
 126     -- | Check a flattened expression to see if it is valid to use as a
 127     --   function argument. The first argument is the original expression for
 128     --   use in the error message.
 129     checkArg arg flat =
 130       let (args, res) = flat in
 131       if not (null args)
 132         then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
 133         else flat
 134
 135 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
 136   (b_args, b_res) <- flattenExpr binds bexpr
 137   if not (null b_args)
 138     then
 139       error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
 140     else
 141       let binds' = (b, Left b_res) : binds in
 142       flattenExpr binds' expr
 143
 144 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
 145
 146 flattenExpr binds expr@(Case (Var v) b _ alts) =
 147   case alts of
 148     [alt] -> flattenSingleAltCaseExpr binds v b alt
 149     otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
 150   where
 151     flattenSingleAltCaseExpr ::
 152       BindMap
 153                                 -- A list of bindings in effect
 154       -> Var.Var                -- The scrutinee
 155       -> CoreBndr               -- The binder to bind the scrutinee to
 156       -> CoreAlt                -- The single alternative
 157       -> FlattenState ( [SignalMap UnnamedSignal], SignalMap UnnamedSignal)
 158                                            -- See expandExpr
 159     flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
 160       if not (DataCon.isTupleCon datacon)
 161         then
 162           error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
 163         else
 164           let
 165             -- Lookup the scrutinee (which must be a variable bound to a tuple) in
 166             -- the existing bindings list and get the portname map for each of
 167             -- it's elements.
 168             Left (Tuple tuple_sigs) = Maybe.fromMaybe
 169               (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
 170               (lookup v binds)
 171             -- TODO include b in the binds list
 172             -- Merge our existing binds with the new binds.
 173             binds' = (zip bind_vars (map Left tuple_sigs)) ++ binds
 174           in
 175             -- Expand the expression with the new binds list
 176             flattenExpr binds' expr
 177     flattenSingleAltCaseExpr _ _ _ alt = error $ "Case patterns other than data constructors not supported in case alternative: " ++ (showSDoc $ ppr alt)
 178
 179
 180
 181 flattenExpr _ _ = do
 182   return ([], Tuple [])
 183
 184 appToHsFunction ::
 185   Type.Type       -- ^ The return type
 186   -> Var.Var      -- ^ The function to call
 187   -> [CoreExpr]   -- ^ The function arguments
 188   -> HsFunction   -- ^ The needed HsFunction
 189
 190 appToHsFunction ty f args =
 191   HsFunction hsname hsargs hsres
 192   where
 193     hsname = Name.getOccString f
 194     hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
 195     hsres  = useAsPort (mkHsValueMap ty)
 196
 197 -- vim: set ts=8 sw=2 sts=2 expandtab: