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,
24 mkStringLit, mkStringLitFS,
26 mkSelectorBinds, mkTupleExpr, mkTupleSelector,
31 #include "HsVersions.h"
33 import {-# SOURCE #-} Match ( matchSimply )
36 import TcHsSyn ( TypecheckedPat )
37 import DsHsSyn ( outPatType, collectTypedPatBinders )
42 import CoreUtils ( exprType, mkIfThenElse )
43 import PrelInfo ( iRREFUT_PAT_ERROR_ID )
44 import Id ( idType, Id, mkWildId )
45 import Literal ( Literal(..) )
46 import TyCon ( isNewTyCon, tyConDataCons )
47 import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed,
48 dataConStrictMarks, dataConId, splitProductType_maybe
50 import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
53 import TysPrim ( intPrimTy,
60 import TysWiredIn ( nilDataCon, consDataCon,
63 unitDataConId, unitTy,
66 floatTy, floatDataCon,
67 doubleTy, doubleDataCon,
71 import BasicTypes ( Boxity(..) )
72 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
73 import Unique ( unpackCStringIdKey, unpackCStringUtf8IdKey )
75 import UnicodeUtil ( stringToUtf8 )
80 %************************************************************************
82 \subsection{Tidying lit pats}
84 %************************************************************************
87 tidyLitPat lit lit_ty default_pat
88 | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy]
89 | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
90 | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy]
91 | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy]
92 | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
93 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
95 -- Convert literal patterns like "foo" to 'f':'o':'o':[]
96 | str_lit lit = mk_list lit
98 | otherwise = default_pat
101 mk_int (HsInt i) = HsIntPrim i
102 mk_int l@(HsLitLit s) = l
104 mk_char (HsChar c) = HsCharPrim c
105 mk_char l@(HsLitLit s) = l
107 mk_word l@(HsLitLit s) = l
109 mk_addr l@(HsLitLit s) = l
111 mk_float (HsInt i) = HsFloatPrim (fromInteger i)
112 mk_float (HsFrac f) = HsFloatPrim f
113 mk_float l@(HsLitLit s) = l
115 mk_double (HsInt i) = HsDoublePrim (fromInteger i)
116 mk_double (HsFrac f) = HsDoublePrim f
117 mk_double l@(HsLitLit s) = l
119 null_str_lit (HsString s) = _NULL_ s
120 null_str_lit other_lit = False
122 str_lit (HsString s) = True
125 mk_list (HsString s) = foldr
126 (\c pat -> ConPat consDataCon lit_ty [] [] [mk_char_lit c,pat])
127 (ConPat nilDataCon lit_ty [] [] []) (_UNPK_INT_ s)
129 mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
133 %************************************************************************
135 \subsection{Building lets}
137 %************************************************************************
139 Use case, not let for unlifted types. The simplifier will turn some
143 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
144 mkDsLet (NonRec bndr rhs) body
145 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
149 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
150 mkDsLets binds body = foldr mkDsLet body binds
154 %************************************************************************
156 \subsection{ Selecting match variables}
158 %************************************************************************
160 We're about to match against some patterns. We want to make some
161 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
162 hand, which should indeed be bound to the pattern as a whole, then use it;
163 otherwise, make one up.
166 selectMatchVar :: TypecheckedPat -> DsM Id
167 selectMatchVar (VarPat var) = returnDs var
168 selectMatchVar (AsPat var pat) = returnDs var
169 selectMatchVar (LazyPat pat) = selectMatchVar pat
170 selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
174 %************************************************************************
176 %* type synonym EquationInfo and access functions for its pieces *
178 %************************************************************************
179 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
181 The ``equation info'' used by @match@ is relatively complicated and
182 worthy of a type synonym and a few handy functions.
187 type EqnSet = UniqSet EqnNo
191 EqnNo -- The number of the equation
193 DsMatchContext -- The context info is used when producing warnings
194 -- about shadowed patterns. It's the context
195 -- of the *first* thing matched in this group.
196 -- Should perhaps be a list of them all!
198 [TypecheckedPat] -- The patterns for an eqn
200 MatchResult -- Encapsulates the guards and bindings
206 CanItFail -- Tells whether the failure expression is used
207 (CoreExpr -> DsM CoreExpr)
208 -- Takes a expression to plug in at the
209 -- failure point(s). The expression should
212 data CanItFail = CanFail | CantFail
214 orFail CantFail CantFail = CantFail
218 Functions on MatchResults
221 cantFailMatchResult :: CoreExpr -> MatchResult
222 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
224 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
225 extractMatchResult (MatchResult CantFail match_fn) fail_expr
226 = match_fn (error "It can't fail!")
228 extractMatchResult (MatchResult CanFail match_fn) fail_expr
229 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
230 match_fn if_it_fails `thenDs` \ body ->
231 returnDs (mkDsLet fail_bind body)
234 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
235 combineMatchResults (MatchResult CanFail body_fn1)
236 (MatchResult can_it_fail2 body_fn2)
237 = MatchResult can_it_fail2 body_fn
239 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
240 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
241 body_fn1 duplicatable_expr `thenDs` \ body1 ->
242 returnDs (Let fail_bind body1)
244 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
248 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
249 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
250 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
251 returnDs (encl_fn body))
253 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
254 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
255 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
259 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
260 mkCoLetsMatchResult binds match_result
261 = adjustMatchResult (mkDsLets binds) match_result
264 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
265 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
266 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
267 returnDs (mkIfThenElse pred_expr body fail))
269 mkCoPrimCaseMatchResult :: Id -- Scrutinee
270 -> [(Literal, MatchResult)] -- Alternatives
272 mkCoPrimCaseMatchResult var match_alts
273 = MatchResult CanFail mk_case
276 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
277 returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
279 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
280 returnDs (LitAlt lit, [], body)
283 mkCoAlgCaseMatchResult :: Id -- Scrutinee
284 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
287 mkCoAlgCaseMatchResult var match_alts
288 | isNewTyCon tycon -- Newtype case; use a let
289 = ASSERT( newtype_sanity )
290 mkCoLetsMatchResult [coercion_bind] match_result
292 | otherwise -- Datatype case; use a case
293 = MatchResult fail_flag mk_case
296 scrut_ty = idType var
297 (tycon, _, _) = splitAlgTyConApp scrut_ty
300 (_, arg_ids, match_result) = head match_alts
301 arg_id = head arg_ids
302 coercion_bind = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id))
305 newtype_sanity = null (tail match_alts) && null (tail arg_ids)
307 -- Stuff for data types
308 data_cons = tyConDataCons tycon
310 match_results = [match_result | (_,_,match_result) <- match_alts]
312 fail_flag | exhaustive_case
313 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
317 wild_var = mkWildId (idType var)
318 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
319 returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
321 mk_alt fail (con, args, MatchResult _ body_fn)
322 = body_fn fail `thenDs` \ body ->
323 rebuildConArgs con args (dataConStrictMarks con) body
324 `thenDs` \ (body', real_args) ->
325 returnDs (DataAlt con, real_args, body')
327 mk_default fail | exhaustive_case = []
328 | otherwise = [(DEFAULT, [], fail)]
330 un_mentioned_constructors
331 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
332 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
335 For each constructor we match on, we might need to re-pack some
336 of the strict fields if they are unpacked in the constructor.
340 :: DataCon -- the con we're matching on
341 -> [Id] -- the source-level args
342 -> [StrictnessMark] -- the strictness annotations (per-arg)
343 -> CoreExpr -- the body
344 -> DsM (CoreExpr, [Id])
346 rebuildConArgs con [] stricts body = returnDs (body, [])
347 rebuildConArgs con (arg:args) stricts body | isTyVar arg
348 = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
349 returnDs (body',arg:args')
350 rebuildConArgs con (arg:args) (str:stricts) body
351 = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
352 case maybeMarkedUnboxed str of
353 Just (pack_con1, _) ->
354 case splitProductType_maybe (idType arg) of
355 Just (_, tycon_args, pack_con, con_arg_tys) ->
356 ASSERT( pack_con == pack_con1 )
357 newSysLocalsDs con_arg_tys `thenDs` \ unpacked_args ->
359 mkDsLet (NonRec arg (mkConApp pack_con
360 (map Type tycon_args ++
361 map Var unpacked_args))) body',
362 unpacked_args ++ real_args
365 _ -> returnDs (body', arg:real_args)
368 %************************************************************************
370 \subsection{Desugarer's versions of some Core functions}
372 %************************************************************************
375 mkErrorAppDs :: Id -- The error function
376 -> Type -- Type to which it should be applied
377 -> String -- The error message string to pass
380 mkErrorAppDs err_id ty msg
381 = getSrcLocDs `thenDs` \ src_loc ->
383 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
385 mkStringLit full_msg `thenDs` \ core_msg ->
386 returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg])
387 -- unUsgTy *required* -- KSW 1999-04-07
389 mkStringLit :: String -> DsM CoreExpr
390 mkStringLit str = mkStringLitFS (_PK_ str)
392 mkStringLitFS :: FAST_STRING -> DsM CoreExpr
396 dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id ->
397 returnDs (App (Var unpack_id) (Lit (MachStr str)))
401 dsLookupGlobalValue unpackCStringUtf8IdKey `thenDs` \ unpack_id ->
402 returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
405 chars = _UNPK_INT_ str
406 safeChar c = c >= 1 && c <= 0xFF
409 %************************************************************************
411 \subsection[mkSelectorBind]{Make a selector bind}
413 %************************************************************************
415 This is used in various places to do with lazy patterns.
416 For each binder $b$ in the pattern, we create a binding:
418 b = case v of pat' -> b'
420 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
422 ToDo: making these bindings should really depend on whether there's
423 much work to be done per binding. If the pattern is complex, it
424 should be de-mangled once, into a tuple (and then selected from).
425 Otherwise the demangling can be in-line in the bindings (as here).
427 Boring! Boring! One error message per binder. The above ToDo is
428 even more helpful. Something very similar happens for pattern-bound
432 mkSelectorBinds :: TypecheckedPat -- The pattern
433 -> CoreExpr -- Expression to which the pattern is bound
434 -> DsM [(Id,CoreExpr)]
436 mkSelectorBinds (VarPat v) val_expr
437 = returnDs [(v, val_expr)]
439 mkSelectorBinds pat val_expr
440 | length binders == 1 || is_simple_pat pat
441 = newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
443 -- For the error message we don't use mkErrorAppDs to avoid
444 -- duplicating the string literal each time
445 newSysLocalDs stringTy `thenDs` \ msg_var ->
446 getSrcLocDs `thenDs` \ src_loc ->
448 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
450 mkStringLit full_msg `thenDs` \ core_msg ->
451 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
452 returnDs ( (val_var, val_expr) :
453 (msg_var, core_msg) :
458 = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
459 `thenDs` \ error_expr ->
460 matchSimply val_expr LetMatch pat local_tuple error_expr
461 `thenDs` \ tuple_expr ->
462 newSysLocalDs tuple_ty
463 `thenDs` \ tuple_var ->
466 (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
468 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
470 binders = collectTypedPatBinders pat
471 local_tuple = mkTupleExpr binders
472 tuple_ty = exprType local_tuple
474 mk_bind scrut_var msg_var bndr_var
475 -- (mk_bind sv bv) generates
476 -- bv = case sv of { pat -> bv; other -> error-msg }
477 -- Remember, pat binds bv
478 = matchSimply (Var scrut_var) LetMatch pat
479 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
480 returnDs (bndr_var, rhs_expr)
482 binder_ty = idType bndr_var
483 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
485 is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
486 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
487 is_simple_pat (VarPat _) = True
488 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
489 is_simple_pat other = False
491 is_triv_pat (VarPat v) = True
492 is_triv_pat (WildPat _) = True
493 is_triv_pat other = False
497 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
498 has only one element, it is the identity function. Notice we must
499 throw out any usage annotation on the outside of an Id.
502 mkTupleExpr :: [Id] -> CoreExpr
504 mkTupleExpr [] = Var unitDataConId
505 mkTupleExpr [id] = Var id
506 mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids))
507 (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
511 @mkTupleSelector@ builds a selector which scrutises the given
512 expression and extracts the one name from the list given.
513 If you want the no-shadowing rule to apply, the caller
514 is responsible for making sure that none of these names
517 If there is just one id in the ``tuple'', then the selector is
521 mkTupleSelector :: [Id] -- The tuple args
522 -> Id -- The selected one
523 -> Id -- A variable of the same type as the scrutinee
524 -> CoreExpr -- Scrutinee
527 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
528 = ASSERT(var == should_be_the_same_var)
531 mkTupleSelector vars the_var scrut_var scrut
532 = ASSERT( not (null vars) )
533 Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
537 %************************************************************************
539 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
541 %************************************************************************
543 Call the constructor Ids when building explicit lists, so that they
544 interact well with rules.
547 mkNilExpr :: Type -> CoreExpr
548 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
550 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
551 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
555 %************************************************************************
557 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
559 %************************************************************************
561 Generally, we handle pattern matching failure like this: let-bind a
562 fail-variable, and use that variable if the thing fails:
564 let fail.33 = error "Help"
575 If the case can't fail, then there'll be no mention of @fail.33@, and the
576 simplifier will later discard it.
579 If it can fail in only one way, then the simplifier will inline it.
582 Only if it is used more than once will the let-binding remain.
585 There's a problem when the result of the case expression is of
586 unboxed type. Then the type of @fail.33@ is unboxed too, and
587 there is every chance that someone will change the let into a case:
593 which is of course utterly wrong. Rather than drop the condition that
594 only boxed types can be let-bound, we just turn the fail into a function
595 for the primitive case:
597 let fail.33 :: Void -> Int#
598 fail.33 = \_ -> error "Help"
607 Now @fail.33@ is a function, so it can be let-bound.
610 mkFailurePair :: CoreExpr -- Result type of the whole case expression
611 -> DsM (CoreBind, -- Binds the newly-created fail variable
612 -- to either the expression or \ _ -> expression
613 CoreExpr) -- Either the fail variable, or fail variable
614 -- applied to unit tuple
617 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
618 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
619 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
620 App (Var fail_fun_var) (Var unitDataConId))
623 = newFailLocalDs ty `thenDs` \ fail_var ->
624 returnDs (NonRec fail_var expr, Var fail_var)