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
16 import TranslatorTypes
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 =
25 tycount = length $ DataCon.dataConAllTyVars dc
29 -> FlattenState (SignalMap UnnamedSignal)
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)
36 -- | Flatten a haskell function
38 HsFunction -- ^ The function to flatten
39 -> CoreBind -- ^ The function value
40 -> FlatFunction -- ^ The resulting flat function
42 flattenFunction _ (Rec _) = error "Recursive binders not supported"
43 flattenFunction hsfunc bind@(NonRec var expr) =
44 FlatFunction args res apps conds sigs
46 init_state = ([], [], [], 0)
47 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
49 (apps, conds, sigs, _) = end_state
54 -> FlattenState ([SignalMap UnnamedSignal], (SignalMap UnnamedSignal))
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)
65 flattenExpr binds (Var id) =
67 Left sig_use -> return ([], sig_use)
68 Right _ -> error "Higher order functions not supported."
70 bind = Maybe.fromMaybe
71 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
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
80 flattenBuildTupleExpr binds (dataConAppArgs dc args)
82 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
84 -- Normal function application
85 let ((Var f), args) = collectArgs app in
86 flattenApplicationExpr binds (CoreUtils.exprType app) f args
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
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
106 -- Create the function application
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.
118 let (args, res) = flat in
120 then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
123 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
124 (b_args, b_res) <- flattenExpr binds bexpr
127 error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
129 let binds' = (b, Left b_res) : binds in
130 flattenExpr binds' expr
132 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
134 flattenExpr binds expr@(Case (Var v) b _ alts) =
136 [alt] -> flattenSingleAltCaseExpr binds v b alt
137 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
139 flattenSingleAltCaseExpr ::
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)
147 flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
148 if not (DataCon.isTupleCon datacon)
150 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
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
156 Left (Tuple tuple_sigs) = Maybe.fromMaybe
157 (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
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
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)
170 return ([], Tuple [])
173 Type.Type -- ^ The return type
174 -> Var.Var -- ^ The function to call
175 -> [CoreExpr] -- ^ The function arguments
176 -> HsFunction -- ^ The needed HsFunction
178 appToHsFunction ty f args =
179 HsFunction hsname hsargs hsres
181 hsname = Name.getOccString f
182 hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
183 hsres = useAsPort (mkHsValueMap ty)
185 -- vim: set ts=8 sw=2 sts=2 expandtab: