2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsUtils]{Utilities for desugaring}
6 This module exports some utility functions of no great interest.
10 CanItFail(..), EquationInfo(..), MatchResult(..),
15 cantFailMatchResult, extractMatchResult,
17 adjustMatchResult, adjustMatchResultDs,
18 mkCoLetsMatchResult, mkGuardedMatchResult,
19 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
21 mkErrorAppDs, mkNilExpr, mkConsExpr,
23 mkSelectorBinds, mkTupleExpr, mkTupleSelector,
28 #include "HsVersions.h"
30 import {-# SOURCE #-} Match ( matchSimply )
32 import HsSyn ( OutPat(..) )
33 import TcHsSyn ( TypecheckedPat )
34 import DsHsSyn ( outPatType, collectTypedPatBinders )
39 import CoreUtils ( coreExprType )
40 import PrelInfo ( iRREFUT_PAT_ERROR_ID )
41 import Id ( idType, Id, mkWildId )
42 import Const ( Literal(..), Con(..) )
43 import TyCon ( isNewTyCon, tyConDataCons )
44 import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks,
45 dataConArgTys, dataConId
47 import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
50 import TysWiredIn ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon,
51 nilDataCon, consDataCon
53 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
58 %************************************************************************
62 %************************************************************************
64 Use case, not let for unlifted types. The simplifier will turn some
68 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
69 mkDsLet (NonRec bndr rhs) body
70 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
74 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
75 mkDsLets binds body = foldr mkDsLet body binds
79 %************************************************************************
81 %* Selecting match variables
83 %************************************************************************
85 We're about to match against some patterns. We want to make some
86 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
87 hand, which should indeed be bound to the pattern as a whole, then use it;
88 otherwise, make one up.
91 selectMatchVar :: TypecheckedPat -> DsM Id
92 selectMatchVar (VarPat var) = returnDs var
93 selectMatchVar (AsPat var pat) = returnDs var
94 selectMatchVar (LazyPat pat) = selectMatchVar pat
95 selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
99 %************************************************************************
101 %* type synonym EquationInfo and access functions for its pieces *
103 %************************************************************************
104 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
106 The ``equation info'' used by @match@ is relatively complicated and
107 worthy of a type synonym and a few handy functions.
112 type EqnSet = UniqSet EqnNo
116 EqnNo -- The number of the equation
118 DsMatchContext -- The context info is used when producing warnings
119 -- about shadowed patterns. It's the context
120 -- of the *first* thing matched in this group.
121 -- Should perhaps be a list of them all!
123 [TypecheckedPat] -- The patterns for an eqn
125 MatchResult -- Encapsulates the guards and bindings
131 CanItFail -- Tells whether the failure expression is used
132 (CoreExpr -> DsM CoreExpr)
133 -- Takes a expression to plug in at the
134 -- failure point(s). The expression should
137 data CanItFail = CanFail | CantFail
139 orFail CantFail CantFail = CantFail
143 Functions on MatchResults
146 cantFailMatchResult :: CoreExpr -> MatchResult
147 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
149 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
150 extractMatchResult (MatchResult CantFail match_fn) fail_expr
151 = match_fn (error "It can't fail!")
153 extractMatchResult (MatchResult CanFail match_fn) fail_expr
154 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
155 match_fn if_it_fails `thenDs` \ body ->
156 returnDs (mkDsLet fail_bind body)
159 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
160 combineMatchResults (MatchResult CanFail body_fn1)
161 (MatchResult can_it_fail2 body_fn2)
162 = MatchResult can_it_fail2 body_fn
164 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
165 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
166 body_fn1 duplicatable_expr `thenDs` \ body1 ->
167 returnDs (Let fail_bind body1)
169 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
173 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
174 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
175 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
176 returnDs (encl_fn body))
178 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
179 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
180 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
184 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
185 mkCoLetsMatchResult binds match_result
186 = adjustMatchResult (mkDsLets binds) match_result
189 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
190 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
191 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
192 returnDs (mkIfThenElse pred_expr body fail))
194 mkCoPrimCaseMatchResult :: Id -- Scrutinee
195 -> [(Literal, MatchResult)] -- Alternatives
197 mkCoPrimCaseMatchResult var match_alts
198 = MatchResult CanFail mk_case
201 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
202 returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
204 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
205 returnDs (Literal lit, [], body)
208 mkCoAlgCaseMatchResult :: Id -- Scrutinee
209 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
212 mkCoAlgCaseMatchResult var match_alts
213 | isNewTyCon tycon -- Newtype case; use a let
214 = ASSERT( newtype_sanity )
215 mkCoLetsMatchResult [coercion_bind] match_result
217 | otherwise -- Datatype case; use a case
218 = MatchResult fail_flag mk_case
221 scrut_ty = idType var
222 (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
225 (con_id, arg_ids, match_result) = head match_alts
226 arg_id = head arg_ids
227 coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id) scrut_ty) (Var var))
228 newtype_sanity = null (tail match_alts) && null (tail arg_ids)
230 -- Stuff for data types
231 data_cons = tyConDataCons tycon
233 match_results = [match_result | (_,_,match_result) <- match_alts]
235 fail_flag | exhaustive_case
236 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
240 wild_var = mkWildId (idType var)
241 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
242 returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
244 mk_alt fail (con, args, MatchResult _ body_fn)
245 = body_fn fail `thenDs` \ body ->
246 rebuildConArgs con args (dataConStrictMarks con) body
247 `thenDs` \ (body', real_args) ->
248 returnDs (DataCon con, real_args, body')
250 mk_default fail | exhaustive_case = []
251 | otherwise = [(DEFAULT, [], fail)]
253 un_mentioned_constructors
254 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
255 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
257 -- for each constructor we match on, we might need to re-pack some
258 -- of the strict fields if they are unpacked in the constructor.
261 :: DataCon -- the con we're matching on
262 -> [Id] -- the source-level args
263 -> [StrictnessMark] -- the strictness annotations (per-arg)
264 -> CoreExpr -- the body
265 -> DsM (CoreExpr, [Id])
267 rebuildConArgs con [] stricts body = returnDs (body, [])
268 rebuildConArgs con (arg:args) stricts body | isTyVar arg
269 = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
270 returnDs (body',arg:args')
271 rebuildConArgs con (arg:args) (str:stricts) body
272 = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
273 case maybeMarkedUnboxed str of
274 Just (pack_con, tys) ->
275 let id_tys = dataConArgTys pack_con ty_args in
276 newSysLocalsDs id_tys `thenDs` \ unpacked_args ->
278 mkDsLet (NonRec arg (Con (DataCon pack_con)
280 map Var unpacked_args))) body',
281 unpacked_args ++ real_args
283 _ -> returnDs (body', arg:real_args)
285 where ty_args = case splitAlgTyConApp (idType arg) of { (_,args,_) -> args }
288 %************************************************************************
290 \subsection{Desugarer's versions of some Core functions}
292 %************************************************************************
295 mkErrorAppDs :: Id -- The error function
296 -> Type -- Type to which it should be applied
297 -> String -- The error message string to pass
300 mkErrorAppDs err_id ty msg
301 = getSrcLocDs `thenDs` \ src_loc ->
303 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
305 returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
306 -- unUsgTy *required* -- KSW 1999-04-07
309 %************************************************************************
311 \subsection[mkSelectorBind]{Make a selector bind}
313 %************************************************************************
315 This is used in various places to do with lazy patterns.
316 For each binder $b$ in the pattern, we create a binding:
318 b = case v of pat' -> b'
320 where pat' is pat with each binder b cloned into b'.
322 ToDo: making these bindings should really depend on whether there's
323 much work to be done per binding. If the pattern is complex, it
324 should be de-mangled once, into a tuple (and then selected from).
325 Otherwise the demangling can be in-line in the bindings (as here).
327 Boring! Boring! One error message per binder. The above ToDo is
328 even more helpful. Something very similar happens for pattern-bound
332 mkSelectorBinds :: TypecheckedPat -- The pattern
333 -> CoreExpr -- Expression to which the pattern is bound
334 -> DsM [(Id,CoreExpr)]
336 mkSelectorBinds (VarPat v) val_expr
337 = returnDs [(v, val_expr)]
339 mkSelectorBinds pat val_expr
340 | length binders == 1 || is_simple_pat pat
341 = newSysLocalDs (coreExprType val_expr) `thenDs` \ val_var ->
343 -- For the error message we don't use mkErrorAppDs to avoid
344 -- duplicating the string literal each time
345 newSysLocalDs stringTy `thenDs` \ msg_var ->
346 getSrcLocDs `thenDs` \ src_loc ->
348 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
350 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
351 returnDs ( (val_var, val_expr) :
352 (msg_var, mkStringLit full_msg) :
357 = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
358 matchSimply val_expr LetMatch pat local_tuple error_expr `thenDs` \ tuple_expr ->
359 newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
361 mk_tup_bind binder = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
363 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
365 binders = collectTypedPatBinders pat
366 local_tuple = mkTupleExpr binders
367 tuple_ty = coreExprType local_tuple
369 mk_bind scrut_var msg_var bndr_var
370 -- (mk_bind sv bv) generates
371 -- bv = case sv of { pat -> bv; other -> error-msg }
372 -- Remember, pat binds bv
373 = matchSimply (Var scrut_var) LetMatch pat
374 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
375 returnDs (bndr_var, rhs_expr)
377 binder_ty = idType bndr_var
378 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
380 is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
381 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
382 is_simple_pat (VarPat _) = True
383 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
384 is_simple_pat other = False
386 is_triv_pat (VarPat v) = True
387 is_triv_pat (WildPat _) = True
388 is_triv_pat other = False
392 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
393 has only one element, it is the identity function. Notice we must
394 throw out any usage annotation on the outside of an Id.
397 mkTupleExpr :: [Id] -> CoreExpr
399 mkTupleExpr [] = mkConApp unitDataCon []
400 mkTupleExpr [id] = Var id
401 mkTupleExpr ids = mkConApp (tupleCon (length ids))
402 (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
406 @mkTupleSelector@ builds a selector which scrutises the given
407 expression and extracts the one name from the list given.
408 If you want the no-shadowing rule to apply, the caller
409 is responsible for making sure that none of these names
412 If there is just one id in the ``tuple'', then the selector is
416 mkTupleSelector :: [Id] -- The tuple args
417 -> Id -- The selected one
418 -> Id -- A variable of the same type as the scrutinee
419 -> CoreExpr -- Scrutinee
422 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
423 = ASSERT(var == should_be_the_same_var)
426 mkTupleSelector vars the_var scrut_var scrut
427 = ASSERT( not (null vars) )
428 Case scrut scrut_var [(DataCon (tupleCon (length vars)), vars, Var the_var)]
432 %************************************************************************
434 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
436 %************************************************************************
438 Call the constructor Ids when building explicit lists, so that they
439 interact well with rules.
442 mkNilExpr :: Type -> CoreExpr
443 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
445 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
446 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
450 %************************************************************************
452 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
454 %************************************************************************
456 Generally, we handle pattern matching failure like this: let-bind a
457 fail-variable, and use that variable if the thing fails:
459 let fail.33 = error "Help"
470 If the case can't fail, then there'll be no mention of fail.33, and the
471 simplifier will later discard it.
474 If it can fail in only one way, then the simplifier will inline it.
477 Only if it is used more than once will the let-binding remain.
480 There's a problem when the result of the case expression is of
481 unboxed type. Then the type of fail.33 is unboxed too, and
482 there is every chance that someone will change the let into a case:
488 which is of course utterly wrong. Rather than drop the condition that
489 only boxed types can be let-bound, we just turn the fail into a function
490 for the primitive case:
492 let fail.33 :: Void -> Int#
493 fail.33 = \_ -> error "Help"
502 Now fail.33 is a function, so it can be let-bound.
505 mkFailurePair :: CoreExpr -- Result type of the whole case expression
506 -> DsM (CoreBind, -- Binds the newly-created fail variable
507 -- to either the expression or \ _ -> expression
508 CoreExpr) -- Either the fail variable, or fail variable
509 -- applied to unit tuple
512 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
513 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
514 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
515 App (Var fail_fun_var) (mkConApp unitDataCon []))
518 = newFailLocalDs ty `thenDs` \ fail_var ->
519 returnDs (NonRec fail_var expr, Var fail_var)
521 ty = coreExprType expr