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