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 %************************************************************************
60 \subsection{ Building lets}
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 \subsection{ 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
228 (Note (Coerce (idType arg_id) scrut_ty) (Var var))
229 newtype_sanity = null (tail match_alts) && null (tail arg_ids)
231 -- Stuff for data types
232 data_cons = tyConDataCons tycon
234 match_results = [match_result | (_,_,match_result) <- match_alts]
236 fail_flag | exhaustive_case
237 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
241 wild_var = mkWildId (idType var)
242 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
243 returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
245 mk_alt fail (con, args, MatchResult _ body_fn)
246 = body_fn fail `thenDs` \ body ->
247 rebuildConArgs con args (dataConStrictMarks con) body
248 `thenDs` \ (body', real_args) ->
249 returnDs (DataCon con, real_args, body')
251 mk_default fail | exhaustive_case = []
252 | otherwise = [(DEFAULT, [], fail)]
254 un_mentioned_constructors
255 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
256 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
259 For each constructor we match on, we might need to re-pack some
260 of the strict fields if they are unpacked in the constructor.
264 :: DataCon -- the con we're matching on
265 -> [Id] -- the source-level args
266 -> [StrictnessMark] -- the strictness annotations (per-arg)
267 -> CoreExpr -- the body
268 -> DsM (CoreExpr, [Id])
270 rebuildConArgs con [] stricts body = returnDs (body, [])
271 rebuildConArgs con (arg:args) stricts body | isTyVar arg
272 = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
273 returnDs (body',arg:args')
274 rebuildConArgs con (arg:args) (str:stricts) body
275 = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
276 case maybeMarkedUnboxed str of
277 Just (pack_con, tys) ->
278 let id_tys = dataConArgTys pack_con ty_args in
279 newSysLocalsDs id_tys `thenDs` \ unpacked_args ->
281 mkDsLet (NonRec arg (Con (DataCon pack_con)
283 map Var unpacked_args))) body',
284 unpacked_args ++ real_args
286 _ -> returnDs (body', arg:real_args)
288 where ty_args = case splitAlgTyConApp (idType arg) of { (_,args,_) -> args }
291 %************************************************************************
293 \subsection{Desugarer's versions of some Core functions}
295 %************************************************************************
298 mkErrorAppDs :: Id -- The error function
299 -> Type -- Type to which it should be applied
300 -> String -- The error message string to pass
303 mkErrorAppDs err_id ty msg
304 = getSrcLocDs `thenDs` \ src_loc ->
306 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
308 returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
309 -- unUsgTy *required* -- KSW 1999-04-07
312 %************************************************************************
314 \subsection[mkSelectorBind]{Make a selector bind}
316 %************************************************************************
318 This is used in various places to do with lazy patterns.
319 For each binder $b$ in the pattern, we create a binding:
321 b = case v of pat' -> b'
323 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
325 ToDo: making these bindings should really depend on whether there's
326 much work to be done per binding. If the pattern is complex, it
327 should be de-mangled once, into a tuple (and then selected from).
328 Otherwise the demangling can be in-line in the bindings (as here).
330 Boring! Boring! One error message per binder. The above ToDo is
331 even more helpful. Something very similar happens for pattern-bound
335 mkSelectorBinds :: TypecheckedPat -- The pattern
336 -> CoreExpr -- Expression to which the pattern is bound
337 -> DsM [(Id,CoreExpr)]
339 mkSelectorBinds (VarPat v) val_expr
340 = returnDs [(v, val_expr)]
342 mkSelectorBinds pat val_expr
343 | length binders == 1 || is_simple_pat pat
344 = newSysLocalDs (coreExprType val_expr) `thenDs` \ val_var ->
346 -- For the error message we don't use mkErrorAppDs to avoid
347 -- duplicating the string literal each time
348 newSysLocalDs stringTy `thenDs` \ msg_var ->
349 getSrcLocDs `thenDs` \ src_loc ->
351 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
353 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
354 returnDs ( (val_var, val_expr) :
355 (msg_var, mkStringLit full_msg) :
360 = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
361 `thenDs` \ error_expr ->
362 matchSimply val_expr LetMatch pat local_tuple error_expr
363 `thenDs` \ tuple_expr ->
364 newSysLocalDs tuple_ty
365 `thenDs` \ tuple_var ->
368 (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
370 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
372 binders = collectTypedPatBinders pat
373 local_tuple = mkTupleExpr binders
374 tuple_ty = coreExprType local_tuple
376 mk_bind scrut_var msg_var bndr_var
377 -- (mk_bind sv bv) generates
378 -- bv = case sv of { pat -> bv; other -> error-msg }
379 -- Remember, pat binds bv
380 = matchSimply (Var scrut_var) LetMatch pat
381 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
382 returnDs (bndr_var, rhs_expr)
384 binder_ty = idType bndr_var
385 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
387 is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
388 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
389 is_simple_pat (VarPat _) = True
390 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
391 is_simple_pat other = False
393 is_triv_pat (VarPat v) = True
394 is_triv_pat (WildPat _) = True
395 is_triv_pat other = False
399 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
400 has only one element, it is the identity function. Notice we must
401 throw out any usage annotation on the outside of an Id.
404 mkTupleExpr :: [Id] -> CoreExpr
406 mkTupleExpr [] = mkConApp unitDataCon []
407 mkTupleExpr [id] = Var id
408 mkTupleExpr ids = mkConApp (tupleCon (length ids))
409 (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
413 @mkTupleSelector@ builds a selector which scrutises the given
414 expression and extracts the one name from the list given.
415 If you want the no-shadowing rule to apply, the caller
416 is responsible for making sure that none of these names
419 If there is just one id in the ``tuple'', then the selector is
423 mkTupleSelector :: [Id] -- The tuple args
424 -> Id -- The selected one
425 -> Id -- A variable of the same type as the scrutinee
426 -> CoreExpr -- Scrutinee
429 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
430 = ASSERT(var == should_be_the_same_var)
433 mkTupleSelector vars the_var scrut_var scrut
434 = ASSERT( not (null vars) )
435 Case scrut scrut_var [(DataCon (tupleCon (length vars)), vars, Var the_var)]
439 %************************************************************************
441 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
443 %************************************************************************
445 Call the constructor Ids when building explicit lists, so that they
446 interact well with rules.
449 mkNilExpr :: Type -> CoreExpr
450 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
452 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
453 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
457 %************************************************************************
459 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
461 %************************************************************************
463 Generally, we handle pattern matching failure like this: let-bind a
464 fail-variable, and use that variable if the thing fails:
466 let fail.33 = error "Help"
477 If the case can't fail, then there'll be no mention of @fail.33@, and the
478 simplifier will later discard it.
481 If it can fail in only one way, then the simplifier will inline it.
484 Only if it is used more than once will the let-binding remain.
487 There's a problem when the result of the case expression is of
488 unboxed type. Then the type of @fail.33@ is unboxed too, and
489 there is every chance that someone will change the let into a case:
495 which is of course utterly wrong. Rather than drop the condition that
496 only boxed types can be let-bound, we just turn the fail into a function
497 for the primitive case:
499 let fail.33 :: Void -> Int#
500 fail.33 = \_ -> error "Help"
509 Now @fail.33@ is a function, so it can be let-bound.
512 mkFailurePair :: CoreExpr -- Result type of the whole case expression
513 -> DsM (CoreBind, -- Binds the newly-created fail variable
514 -- to either the expression or \ _ -> expression
515 CoreExpr) -- Either the fail variable, or fail variable
516 -- applied to unit tuple
519 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
520 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
521 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
522 App (Var fail_fun_var) (mkConApp unitDataCon []))
525 = newFailLocalDs ty `thenDs` \ fail_var ->
526 returnDs (NonRec fail_var expr, Var fail_var)
528 ty = coreExprType expr