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
17 import TranslatorTypes
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 =
26 tycount = length $ DataCon.dataConAllTyVars dc
30 -> FlattenState (SignalMap UnnamedSignal)
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)
37 -- | Marks a signal as the given SigUse, if its id is in the list of id's
39 markSignal :: SigUse -> [UnnamedSignal] -> (UnnamedSignal, SignalInfo) -> (UnnamedSignal, SignalInfo)
40 markSignal use ids (id, info) =
43 info' = if id `elem` ids then info { sigUse = use} else info
45 -- | Flatten a haskell function
47 HsFunction -- ^ The function to flatten
48 -> CoreBind -- ^ The function value
49 -> FlatFunction -- ^ The resulting flat function
51 flattenFunction _ (Rec _) = error "Recursive binders not supported"
52 flattenFunction hsfunc bind@(NonRec var expr) =
53 FlatFunction args res apps conds sigs'
55 init_state = ([], [], [], 0)
56 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
58 portlist = concat (map Foldable.toList (res:args))
59 (apps, conds, sigs, _) = end_state
60 sigs' = fmap (markSignal SigPort portlist) sigs
65 -> FlattenState ([SignalMap UnnamedSignal], (SignalMap UnnamedSignal))
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)
76 flattenExpr binds (Var id) =
78 Left sig_use -> return ([], sig_use)
79 Right _ -> error "Higher order functions not supported."
81 bind = Maybe.fromMaybe
82 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
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
91 flattenBuildTupleExpr binds (dataConAppArgs dc args)
93 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
95 -- Normal function application
96 let ((Var f), args) = collectArgs app in
97 flattenApplicationExpr binds (CoreUtils.exprType app) f args
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
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
117 -- Create the function application
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.
129 let (args, res) = flat in
131 then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
134 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
135 (b_args, b_res) <- flattenExpr binds bexpr
138 error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
140 let binds' = (b, Left b_res) : binds in
141 flattenExpr binds' expr
143 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
145 flattenExpr binds expr@(Case (Var v) b _ alts) =
147 [alt] -> flattenSingleAltCaseExpr binds v b alt
148 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
150 flattenSingleAltCaseExpr ::
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)
158 flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
159 if not (DataCon.isTupleCon datacon)
161 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
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
167 Left (Tuple tuple_sigs) = Maybe.fromMaybe
168 (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
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
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)
181 return ([], Tuple [])
184 Type.Type -- ^ The return type
185 -> Var.Var -- ^ The function to call
186 -> [CoreExpr] -- ^ The function arguments
187 -> HsFunction -- ^ The needed HsFunction
189 appToHsFunction ty f args =
190 HsFunction hsname hsargs hsres
192 hsname = Name.getOccString f
193 hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
194 hsres = useAsPort (mkHsValueMap ty)
196 -- vim: set ts=8 sw=2 sts=2 expandtab: