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(..),
17 cantFailMatchResult, extractMatchResult,
19 adjustMatchResult, adjustMatchResultDs,
20 mkCoLetsMatchResult, mkGuardedMatchResult,
21 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
23 mkErrorAppDs, mkNilExpr, mkConsExpr,
25 mkSelectorBinds, mkTupleExpr, mkTupleSelector,
30 #include "HsVersions.h"
32 import {-# SOURCE #-} Match ( matchSimply )
35 import TcHsSyn ( TypecheckedPat )
36 import DsHsSyn ( outPatType, collectTypedPatBinders )
41 import CoreUtils ( exprType, mkIfThenElse )
42 import PrelInfo ( iRREFUT_PAT_ERROR_ID )
43 import Id ( idType, Id, mkWildId )
44 import Literal ( Literal )
45 import TyCon ( isNewTyCon, tyConDataCons )
46 import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed,
47 dataConStrictMarks, dataConId, splitProductType_maybe
49 import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
52 import TysPrim ( intPrimTy,
59 import TysWiredIn ( nilDataCon, consDataCon,
62 unitDataConId, unitTy,
65 floatTy, floatDataCon,
66 doubleTy, doubleDataCon,
70 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
76 %************************************************************************
78 \subsection{Tidying lit pats}
80 %************************************************************************
83 tidyLitPat lit lit_ty default_pat
84 | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy]
85 | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
86 | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy]
87 | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy]
88 | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
89 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
91 -- Convert the literal pattern "" to the constructor pattern [].
92 | null_str_lit lit = ConPat nilDataCon lit_ty [] [] []
93 -- Similar special case for "x"
94 | one_str_lit lit = ConPat consDataCon lit_ty [] []
95 [mk_first_char_lit lit, ConPat nilDataCon lit_ty [] [] []]
97 | otherwise = default_pat
100 mk_int (HsInt i) = HsIntPrim i
101 mk_int l@(HsLitLit s) = l
103 mk_char (HsChar c) = HsCharPrim c
104 mk_char l@(HsLitLit s) = l
106 mk_word l@(HsLitLit s) = l
108 mk_addr l@(HsLitLit s) = l
110 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
111 mk_float (HsFrac f) = HsFloatPrim f
112 mk_float l@(HsLitLit s) = l
114 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
115 mk_double (HsFrac f) = HsDoublePrim f
116 mk_double l@(HsLitLit s) = l
118 null_str_lit (HsString s) = _NULL_ s
119 null_str_lit other_lit = False
121 one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
122 one_str_lit other_lit = False
123 mk_first_char_lit (HsString s) = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim (_HEAD_ s)) charPrimTy]
127 %************************************************************************
129 \subsection{Building lets}
131 %************************************************************************
133 Use case, not let for unlifted types. The simplifier will turn some
137 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
138 mkDsLet (NonRec bndr rhs) body
139 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
143 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
144 mkDsLets binds body = foldr mkDsLet body binds
148 %************************************************************************
150 \subsection{ Selecting match variables}
152 %************************************************************************
154 We're about to match against some patterns. We want to make some
155 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
156 hand, which should indeed be bound to the pattern as a whole, then use it;
157 otherwise, make one up.
160 selectMatchVar :: TypecheckedPat -> DsM Id
161 selectMatchVar (VarPat var) = returnDs var
162 selectMatchVar (AsPat var pat) = returnDs var
163 selectMatchVar (LazyPat pat) = selectMatchVar pat
164 selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
168 %************************************************************************
170 %* type synonym EquationInfo and access functions for its pieces *
172 %************************************************************************
173 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
175 The ``equation info'' used by @match@ is relatively complicated and
176 worthy of a type synonym and a few handy functions.
181 type EqnSet = UniqSet EqnNo
185 EqnNo -- The number of the equation
187 DsMatchContext -- The context info is used when producing warnings
188 -- about shadowed patterns. It's the context
189 -- of the *first* thing matched in this group.
190 -- Should perhaps be a list of them all!
192 [TypecheckedPat] -- The patterns for an eqn
194 MatchResult -- Encapsulates the guards and bindings
200 CanItFail -- Tells whether the failure expression is used
201 (CoreExpr -> DsM CoreExpr)
202 -- Takes a expression to plug in at the
203 -- failure point(s). The expression should
206 data CanItFail = CanFail | CantFail
208 orFail CantFail CantFail = CantFail
212 Functions on MatchResults
215 cantFailMatchResult :: CoreExpr -> MatchResult
216 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
218 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
219 extractMatchResult (MatchResult CantFail match_fn) fail_expr
220 = match_fn (error "It can't fail!")
222 extractMatchResult (MatchResult CanFail match_fn) fail_expr
223 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
224 match_fn if_it_fails `thenDs` \ body ->
225 returnDs (mkDsLet fail_bind body)
228 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
229 combineMatchResults (MatchResult CanFail body_fn1)
230 (MatchResult can_it_fail2 body_fn2)
231 = MatchResult can_it_fail2 body_fn
233 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
234 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
235 body_fn1 duplicatable_expr `thenDs` \ body1 ->
236 returnDs (Let fail_bind body1)
238 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
242 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
243 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
244 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
245 returnDs (encl_fn body))
247 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
248 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
249 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
253 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
254 mkCoLetsMatchResult binds match_result
255 = adjustMatchResult (mkDsLets binds) match_result
258 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
259 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
260 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
261 returnDs (mkIfThenElse pred_expr body fail))
263 mkCoPrimCaseMatchResult :: Id -- Scrutinee
264 -> [(Literal, MatchResult)] -- Alternatives
266 mkCoPrimCaseMatchResult var match_alts
267 = MatchResult CanFail mk_case
270 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
271 returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
273 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
274 returnDs (LitAlt lit, [], body)
277 mkCoAlgCaseMatchResult :: Id -- Scrutinee
278 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
281 mkCoAlgCaseMatchResult var match_alts
282 | isNewTyCon tycon -- Newtype case; use a let
283 = ASSERT( newtype_sanity )
284 mkCoLetsMatchResult [coercion_bind] match_result
286 | otherwise -- Datatype case; use a case
287 = MatchResult fail_flag mk_case
290 scrut_ty = idType var
291 (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
294 (con_id, arg_ids, match_result) = head match_alts
295 arg_id = head arg_ids
296 coercion_bind = NonRec arg_id
297 (Note (Coerce (unUsgTy (idType arg_id)) (unUsgTy scrut_ty)) (Var var))
298 newtype_sanity = null (tail match_alts) && null (tail arg_ids)
300 -- Stuff for data types
301 data_cons = tyConDataCons tycon
303 match_results = [match_result | (_,_,match_result) <- match_alts]
305 fail_flag | exhaustive_case
306 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
310 wild_var = mkWildId (idType var)
311 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
312 returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
314 mk_alt fail (con, args, MatchResult _ body_fn)
315 = body_fn fail `thenDs` \ body ->
316 rebuildConArgs con args (dataConStrictMarks con) body
317 `thenDs` \ (body', real_args) ->
318 returnDs (DataAlt con, real_args, body')
320 mk_default fail | exhaustive_case = []
321 | otherwise = [(DEFAULT, [], fail)]
323 un_mentioned_constructors
324 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
325 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
328 For each constructor we match on, we might need to re-pack some
329 of the strict fields if they are unpacked in the constructor.
333 :: DataCon -- the con we're matching on
334 -> [Id] -- the source-level args
335 -> [StrictnessMark] -- the strictness annotations (per-arg)
336 -> CoreExpr -- the body
337 -> DsM (CoreExpr, [Id])
339 rebuildConArgs con [] stricts body = returnDs (body, [])
340 rebuildConArgs con (arg:args) stricts body | isTyVar arg
341 = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
342 returnDs (body',arg:args')
343 rebuildConArgs con (arg:args) (str:stricts) body
344 = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
345 case maybeMarkedUnboxed str of
346 Just (pack_con1, _) ->
347 case splitProductType_maybe (idType arg) of
348 Just (_, tycon_args, pack_con, con_arg_tys) ->
349 ASSERT( pack_con == pack_con1 )
350 newSysLocalsDs con_arg_tys `thenDs` \ unpacked_args ->
352 mkDsLet (NonRec arg (mkConApp pack_con
353 (map Type tycon_args ++
354 map Var unpacked_args))) body',
355 unpacked_args ++ real_args
358 _ -> returnDs (body', arg:real_args)
361 %************************************************************************
363 \subsection{Desugarer's versions of some Core functions}
365 %************************************************************************
368 mkErrorAppDs :: Id -- The error function
369 -> Type -- Type to which it should be applied
370 -> String -- The error message string to pass
373 mkErrorAppDs err_id ty msg
374 = getSrcLocDs `thenDs` \ src_loc ->
376 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
378 returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
379 -- unUsgTy *required* -- KSW 1999-04-07
382 %************************************************************************
384 \subsection[mkSelectorBind]{Make a selector bind}
386 %************************************************************************
388 This is used in various places to do with lazy patterns.
389 For each binder $b$ in the pattern, we create a binding:
391 b = case v of pat' -> b'
393 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
395 ToDo: making these bindings should really depend on whether there's
396 much work to be done per binding. If the pattern is complex, it
397 should be de-mangled once, into a tuple (and then selected from).
398 Otherwise the demangling can be in-line in the bindings (as here).
400 Boring! Boring! One error message per binder. The above ToDo is
401 even more helpful. Something very similar happens for pattern-bound
405 mkSelectorBinds :: TypecheckedPat -- The pattern
406 -> CoreExpr -- Expression to which the pattern is bound
407 -> DsM [(Id,CoreExpr)]
409 mkSelectorBinds (VarPat v) val_expr
410 = returnDs [(v, val_expr)]
412 mkSelectorBinds pat val_expr
413 | length binders == 1 || is_simple_pat pat
414 = newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
416 -- For the error message we don't use mkErrorAppDs to avoid
417 -- duplicating the string literal each time
418 newSysLocalDs stringTy `thenDs` \ msg_var ->
419 getSrcLocDs `thenDs` \ src_loc ->
421 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
423 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
424 returnDs ( (val_var, val_expr) :
425 (msg_var, mkStringLit full_msg) :
430 = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
431 `thenDs` \ error_expr ->
432 matchSimply val_expr LetMatch pat local_tuple error_expr
433 `thenDs` \ tuple_expr ->
434 newSysLocalDs tuple_ty
435 `thenDs` \ tuple_var ->
438 (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
440 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
442 binders = collectTypedPatBinders pat
443 local_tuple = mkTupleExpr binders
444 tuple_ty = exprType local_tuple
446 mk_bind scrut_var msg_var bndr_var
447 -- (mk_bind sv bv) generates
448 -- bv = case sv of { pat -> bv; other -> error-msg }
449 -- Remember, pat binds bv
450 = matchSimply (Var scrut_var) LetMatch pat
451 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
452 returnDs (bndr_var, rhs_expr)
454 binder_ty = idType bndr_var
455 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
457 is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
458 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
459 is_simple_pat (VarPat _) = True
460 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
461 is_simple_pat other = False
463 is_triv_pat (VarPat v) = True
464 is_triv_pat (WildPat _) = True
465 is_triv_pat other = False
469 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
470 has only one element, it is the identity function. Notice we must
471 throw out any usage annotation on the outside of an Id.
474 mkTupleExpr :: [Id] -> CoreExpr
476 mkTupleExpr [] = Var unitDataConId
477 mkTupleExpr [id] = Var id
478 mkTupleExpr ids = mkConApp (tupleCon (length ids))
479 (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
483 @mkTupleSelector@ builds a selector which scrutises the given
484 expression and extracts the one name from the list given.
485 If you want the no-shadowing rule to apply, the caller
486 is responsible for making sure that none of these names
489 If there is just one id in the ``tuple'', then the selector is
493 mkTupleSelector :: [Id] -- The tuple args
494 -> Id -- The selected one
495 -> Id -- A variable of the same type as the scrutinee
496 -> CoreExpr -- Scrutinee
499 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
500 = ASSERT(var == should_be_the_same_var)
503 mkTupleSelector vars the_var scrut_var scrut
504 = ASSERT( not (null vars) )
505 Case scrut scrut_var [(DataAlt (tupleCon (length vars)), vars, Var the_var)]
509 %************************************************************************
511 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
513 %************************************************************************
515 Call the constructor Ids when building explicit lists, so that they
516 interact well with rules.
519 mkNilExpr :: Type -> CoreExpr
520 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
522 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
523 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
527 %************************************************************************
529 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
531 %************************************************************************
533 Generally, we handle pattern matching failure like this: let-bind a
534 fail-variable, and use that variable if the thing fails:
536 let fail.33 = error "Help"
547 If the case can't fail, then there'll be no mention of @fail.33@, and the
548 simplifier will later discard it.
551 If it can fail in only one way, then the simplifier will inline it.
554 Only if it is used more than once will the let-binding remain.
557 There's a problem when the result of the case expression is of
558 unboxed type. Then the type of @fail.33@ is unboxed too, and
559 there is every chance that someone will change the let into a case:
565 which is of course utterly wrong. Rather than drop the condition that
566 only boxed types can be let-bound, we just turn the fail into a function
567 for the primitive case:
569 let fail.33 :: Void -> Int#
570 fail.33 = \_ -> error "Help"
579 Now @fail.33@ is a function, so it can be let-bound.
582 mkFailurePair :: CoreExpr -- Result type of the whole case expression
583 -> DsM (CoreBind, -- Binds the newly-created fail variable
584 -- to either the expression or \ _ -> expression
585 CoreExpr) -- Either the fail variable, or fail variable
586 -- applied to unit tuple
589 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
590 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
591 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
592 App (Var fail_fun_var) (Var unitDataConId))
595 = newFailLocalDs ty `thenDs` \ fail_var ->
596 returnDs (NonRec fail_var expr, Var fail_var)