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