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
15 import TranslatorTypes
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 =
24 tycount = length $ DataCon.dataConAllTyVars dc
28 -> FlattenState (SignalMap UnnamedSignal)
33 -- First generate a map with the right structure containing the types
34 tymap = mkHsValueMap ty
38 -> FlattenState (SignalMap UnnamedSignal)
40 typeMapToUseMap (Single ty) = do
44 typeMapToUseMap (Tuple tymaps) = do
45 usemaps <- State.mapM typeMapToUseMap tymaps
46 return $ Tuple usemaps
48 -- | Flatten a haskell function
50 HsFunction -- ^ The function to flatten
51 -> CoreBind -- ^ The function value
52 -> FlatFunction -- ^ The resulting flat function
54 flattenFunction _ (Rec _) = error "Recursive binders not supported"
55 flattenFunction hsfunc bind@(NonRec var expr) =
56 FlatFunction args res apps conds sigs
58 init_state = ([], [], [], 0)
59 (fres, end_state) = State.runState (flattenExpr [] expr) init_state
61 (apps, conds, sigs, _) = end_state
66 -> FlattenState ([SignalMap UnnamedSignal], (SignalMap UnnamedSignal))
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)
77 flattenExpr binds (Var id) =
79 Left sig_use -> return ([], sig_use)
80 Right _ -> error "Higher order functions not supported."
82 bind = Maybe.fromMaybe
83 (error $ "Argument " ++ Name.getOccString id ++ "is unknown")
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
92 flattenBuildTupleExpr binds (dataConAppArgs dc args)
94 error $ "Data constructors other than tuples not supported: " ++ (showSDoc $ ppr app)
96 -- Normal function application
97 let ((Var f), args) = collectArgs app in
98 flattenApplicationExpr binds (CoreUtils.exprType app) f args
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
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
118 -- Create the function application
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.
130 let (args, res) = flat in
132 then error $ "Passing lambda expression or function as a function argument not supported: " ++ (showSDoc $ ppr arg)
135 flattenExpr binds l@(Let (NonRec b bexpr) expr) = do
136 (b_args, b_res) <- flattenExpr binds bexpr
139 error $ "Higher order functions not supported in let expression: " ++ (showSDoc $ ppr l)
141 let binds' = (b, Left b_res) : binds in
142 flattenExpr binds' expr
144 flattenExpr binds l@(Let (Rec _) _) = error $ "Recursive let definitions not supported: " ++ (showSDoc $ ppr l)
146 flattenExpr binds expr@(Case (Var v) b _ alts) =
148 [alt] -> flattenSingleAltCaseExpr binds v b alt
149 otherwise -> error $ "Multiple alternative case expression not supported: " ++ (showSDoc $ ppr expr)
151 flattenSingleAltCaseExpr ::
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)
159 flattenSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
160 if not (DataCon.isTupleCon datacon)
162 error $ "Dataconstructors other than tuple constructors not supported in case pattern of alternative: " ++ (showSDoc $ ppr alt)
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
168 Left (Tuple tuple_sigs) = Maybe.fromMaybe
169 (error $ "Case expression uses unknown scrutinee " ++ Name.getOccString v)
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
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)
182 return ([], Tuple [])
185 Type.Type -- ^ The return type
186 -> Var.Var -- ^ The function to call
187 -> [CoreExpr] -- ^ The function arguments
188 -> HsFunction -- ^ The needed HsFunction
190 appToHsFunction ty f args =
191 HsFunction hsname hsargs hsres
193 hsname = Name.getOccString f
194 hsargs = map (useAsPort . mkHsValueMap . CoreUtils.exprType) args
195 hsres = useAsPort (mkHsValueMap ty)
197 -- vim: set ts=8 sw=2 sts=2 expandtab: