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, mkListExpr,
24 mkIntExpr, mkCharExpr,
25 mkStringLit, mkStringLitFS, mkIntegerExpr,
27 mkSelectorBinds, mkTupleExpr, mkTupleSelector,
28 mkTupleType, mkTupleCase, mkBigCoreTup,
29 mkCoreTup, mkCoreSel, mkCoreTupTy,
31 dsReboundNames, lookupReboundName,
36 #include "HsVersions.h"
38 import {-# SOURCE #-} Match ( matchSimply )
39 import {-# SOURCE #-} DsExpr( dsExpr )
42 import TcHsSyn ( TypecheckedPat, hsPatType )
44 import Constants ( mAX_TUPLE_SIZE )
47 import CoreUtils ( exprType, mkIfThenElse, mkCoerce, bindNonRec )
48 import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
49 import Id ( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
51 import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
52 import TyCon ( isNewTyCon, tyConDataCons )
53 import DataCon ( DataCon, dataConSourceArity )
54 import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp )
55 import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
56 import TysPrim ( intPrimTy )
57 import TysWiredIn ( nilDataCon, consDataCon,
59 unitDataConId, unitTy,
61 intTy, intDataCon, smallIntegerDataCon,
64 stringTy, isPArrFakeCon )
65 import BasicTypes ( Boxity(..) )
66 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
67 import UniqSupply ( splitUniqSupply, uniqFromSupply )
68 import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
69 plusIntegerName, timesIntegerName,
70 lengthPName, indexPName )
72 import UnicodeUtil ( intsToUtf8, stringToUtf8 )
73 import Util ( isSingleton, notNull, zipEqual )
74 import ListSetOps ( assocDefault )
80 %************************************************************************
84 %************************************************************************
87 dsReboundNames :: ReboundNames Id
88 -> DsM ([CoreBind], -- Auxiliary bindings
89 [(Name,Id)]) -- Maps the standard name to its value
91 dsReboundNames rebound_ids
92 = mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
93 return (concat binds_s, prs)
95 -- The cheapo special case can happen when we
96 -- make an intermediate HsDo when desugaring a RecStmt
97 mk_bind (std_name, HsVar id) = return ([], (std_name, id))
98 mk_bind (std_name, expr) = dsExpr expr `thenDs` \ rhs ->
99 newSysLocalDs (exprType rhs) `thenDs` \ id ->
100 return ([NonRec id rhs], (std_name, id))
102 lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr
103 lookupReboundName prs std_name
104 = Var (assocDefault (mk_panic std_name) prs std_name)
106 mk_panic std_name = pprPanic "dsReboundNames" (ptext SLIT("Not found:") <+> ppr std_name)
110 %************************************************************************
112 \subsection{Tidying lit pats}
114 %************************************************************************
117 tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
118 tidyLitPat (HsChar c) pat = mkCharLitPat c
119 tidyLitPat lit pat = pat
121 tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
122 tidyNPat (HsString s) _ pat
123 | lengthFS s <= 1 -- Short string literals only
124 = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy)
125 (mkNilPat stringTy) (unpackIntFS s)
126 -- The stringTy is the type of the whole pattern, not
127 -- the type to instantiate (:) or [] with!
130 tidyNPat lit lit_ty default_pat
131 | isIntTy lit_ty = mkPrefixConPat intDataCon [LitPat (mk_int lit)] lit_ty
132 | isFloatTy lit_ty = mkPrefixConPat floatDataCon [LitPat (mk_float lit)] lit_ty
133 | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [LitPat (mk_double lit)] lit_ty
134 | otherwise = default_pat
137 mk_int (HsInteger i) = HsIntPrim i
139 mk_float (HsInteger i) = HsFloatPrim (fromInteger i)
140 mk_float (HsRat f _) = HsFloatPrim f
142 mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
143 mk_double (HsRat f _) = HsDoublePrim f
147 %************************************************************************
149 \subsection{Building lets}
151 %************************************************************************
153 Use case, not let for unlifted types. The simplifier will turn some
157 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
158 mkDsLet (NonRec bndr rhs) body
159 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
163 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
164 mkDsLets binds body = foldr mkDsLet body binds
168 %************************************************************************
170 \subsection{ Selecting match variables}
172 %************************************************************************
174 We're about to match against some patterns. We want to make some
175 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
176 hand, which should indeed be bound to the pattern as a whole, then use it;
177 otherwise, make one up.
180 selectMatchVar :: TypecheckedPat -> DsM Id
181 selectMatchVar (VarPat var) = returnDs var
182 selectMatchVar (AsPat var pat) = returnDs var
183 selectMatchVar (LazyPat pat) = selectMatchVar pat
184 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) -- OK, better make up one...
188 %************************************************************************
190 %* type synonym EquationInfo and access functions for its pieces *
192 %************************************************************************
193 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
195 The ``equation info'' used by @match@ is relatively complicated and
196 worthy of a type synonym and a few handy functions.
201 type EqnSet = UniqSet EqnNo
205 EqnNo -- The number of the equation
207 DsMatchContext -- The context info is used when producing warnings
208 -- about shadowed patterns. It's the context
209 -- of the *first* thing matched in this group.
210 -- Should perhaps be a list of them all!
212 [TypecheckedPat] -- The patterns for an eqn
214 MatchResult -- Encapsulates the guards and bindings
220 CanItFail -- Tells whether the failure expression is used
221 (CoreExpr -> DsM CoreExpr)
222 -- Takes a expression to plug in at the
223 -- failure point(s). The expression should
226 data CanItFail = CanFail | CantFail
228 orFail CantFail CantFail = CantFail
232 Functions on MatchResults
235 cantFailMatchResult :: CoreExpr -> MatchResult
236 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
238 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
239 extractMatchResult (MatchResult CantFail match_fn) fail_expr
240 = match_fn (error "It can't fail!")
242 extractMatchResult (MatchResult CanFail match_fn) fail_expr
243 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
244 match_fn if_it_fails `thenDs` \ body ->
245 returnDs (mkDsLet fail_bind body)
248 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
249 combineMatchResults (MatchResult CanFail body_fn1)
250 (MatchResult can_it_fail2 body_fn2)
251 = MatchResult can_it_fail2 body_fn
253 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
254 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
255 body_fn1 duplicatable_expr `thenDs` \ body1 ->
256 returnDs (Let fail_bind body1)
258 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
262 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
263 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
264 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
265 returnDs (encl_fn body))
267 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
268 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
269 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
273 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
274 mkCoLetsMatchResult binds match_result
275 = adjustMatchResult (mkDsLets binds) match_result
278 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
279 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
280 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
281 returnDs (mkIfThenElse pred_expr body fail))
283 mkCoPrimCaseMatchResult :: Id -- Scrutinee
284 -> [(Literal, MatchResult)] -- Alternatives
286 mkCoPrimCaseMatchResult var match_alts
287 = MatchResult CanFail mk_case
290 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
291 returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts))
293 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
294 returnDs (LitAlt lit, [], body)
297 mkCoAlgCaseMatchResult :: Id -- Scrutinee
298 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
301 mkCoAlgCaseMatchResult var match_alts
302 | isNewTyCon tycon -- Newtype case; use a let
303 = ASSERT( null (tail match_alts) && null (tail arg_ids) )
304 mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result
306 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
307 = MatchResult CanFail mk_parrCase
309 | otherwise -- Datatype case; use a case
310 = MatchResult fail_flag mk_case
313 scrut_ty = idType var
314 tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here
317 (_, arg_ids, match_result) = head match_alts
318 arg_id = head arg_ids
319 newtype_rhs = mkNewTypeBody tycon (idType arg_id) (Var var)
321 -- Stuff for data types
322 data_cons = tyConDataCons tycon
323 match_results = [match_result | (_,_,match_result) <- match_alts]
325 fail_flag | exhaustive_case
326 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
330 wild_var = mkWildId (idType var)
331 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
332 returnDs (Case (Var var) wild_var (mk_default fail ++ alts))
334 mk_alt fail (con, args, MatchResult _ body_fn)
335 = body_fn fail `thenDs` \ body ->
336 getUniquesDs `thenDs` \ us ->
337 returnDs (mkReboxingAlt us con args body)
339 mk_default fail | exhaustive_case = []
340 | otherwise = [(DEFAULT, [], fail)]
342 un_mentioned_constructors
343 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
344 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
346 -- Stuff for parallel arrays
348 -- * the following is to desugar cases over fake constructors for
349 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
352 -- Concerning `isPArrFakeAlts':
354 -- * it is *not* sufficient to just check the type of the type
355 -- constructor, as we have to be careful not to confuse the real
356 -- representation of parallel arrays with the fake constructors;
357 -- moreover, a list of alternatives must not mix fake and real
358 -- constructors (this is checked earlier on)
360 -- FIXME: We actually go through the whole list and make sure that
361 -- either all or none of the constructors are fake parallel
362 -- array constructors. This is to spot equations that mix fake
363 -- constructors with the real representation defined in
364 -- `PrelPArr'. It would be nicer to spot this situation
365 -- earlier and raise a proper error message, but it can really
366 -- only happen in `PrelPArr' anyway.
368 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
369 isPArrFakeAlts ((dcon, _, _):alts) =
370 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
371 (True , True ) -> True
372 (False, False) -> False
374 panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
377 dsLookupGlobalId lengthPName `thenDs` \lengthP ->
378 unboxAlt `thenDs` \alt ->
379 returnDs (Case (len lengthP) (mkWildId intTy) [alt])
381 elemTy = case splitTyConApp (idType var) of
382 (_, [elemTy]) -> elemTy
384 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
385 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
388 newSysLocalDs intPrimTy `thenDs` \l ->
389 dsLookupGlobalId indexPName `thenDs` \indexP ->
390 mapDs (mkAlt indexP) match_alts `thenDs` \alts ->
391 returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts)))
393 wild = mkWildId intPrimTy
394 dft = (DEFAULT, [], fail)
396 -- each alternative matches one array length (corresponding to one
397 -- fake array constructor), so the match is on a literal; each
398 -- alternative's body is extended by a local binding for each
399 -- constructor argument, which are bound to array elements starting
402 mkAlt indexP (con, args, MatchResult _ bodyFun) =
403 bodyFun fail `thenDs` \body ->
404 returnDs (LitAlt lit, [], mkDsLets binds body)
406 lit = MachInt $ toInteger (dataConSourceArity con)
407 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
409 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
413 %************************************************************************
415 \subsection{Desugarer's versions of some Core functions}
417 %************************************************************************
420 mkErrorAppDs :: Id -- The error function
421 -> Type -- Type to which it should be applied
422 -> String -- The error message string to pass
425 mkErrorAppDs err_id ty msg
426 = getSrcLocDs `thenDs` \ src_loc ->
428 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
429 core_msg = Lit (MachStr (mkFastString (stringToUtf8 full_msg)))
431 returnDs (mkApps (Var err_id) [Type ty, core_msg])
435 *************************************************************
437 \subsection{Making literals}
439 %************************************************************************
442 mkCharExpr :: Int -> CoreExpr -- Returns C# c :: Int
443 mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int
444 mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer
445 mkStringLit :: String -> DsM CoreExpr -- Result :: String
446 mkStringLitFS :: FastString -> DsM CoreExpr -- Result :: String
448 mkIntExpr i = mkConApp intDataCon [mkIntLit i]
449 mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
452 | inIntRange i -- Small enough, so start from an Int
453 = returnDs (mkSmallIntegerLit i)
455 -- Special case for integral literals with a large magnitude:
456 -- They are transformed into an expression involving only smaller
457 -- integral literals. This improves constant folding.
459 | otherwise -- Big, so start from a string
460 = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id ->
461 dsLookupGlobalId timesIntegerName `thenDs` \ times_id ->
463 plus a b = Var plus_id `App` a `App` b
464 times a b = Var times_id `App` a `App` b
466 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
467 horner :: Integer -> Integer -> CoreExpr
468 horner b i | abs q <= 1 = if r == 0 || r == i
469 then mkSmallIntegerLit i
470 else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
471 | r == 0 = horner b q `times` mkSmallIntegerLit b
472 | otherwise = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
474 (q,r) = i `quotRem` b
477 returnDs (horner tARGET_MAX_INT i)
479 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
481 mkStringLit str = mkStringLitFS (mkFastString str)
485 = returnDs (mkNilExpr charTy)
489 the_char = mkCharExpr (headIntFS str)
491 returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
493 | all safeChar int_chars
494 = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id ->
495 returnDs (App (Var unpack_id) (Lit (MachStr str)))
498 = dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id ->
499 returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars)))))
502 int_chars = unpackIntFS str
503 safeChar c = c >= 1 && c <= 0xFF
507 %************************************************************************
509 \subsection[mkSelectorBind]{Make a selector bind}
511 %************************************************************************
513 This is used in various places to do with lazy patterns.
514 For each binder $b$ in the pattern, we create a binding:
516 b = case v of pat' -> b'
518 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
520 ToDo: making these bindings should really depend on whether there's
521 much work to be done per binding. If the pattern is complex, it
522 should be de-mangled once, into a tuple (and then selected from).
523 Otherwise the demangling can be in-line in the bindings (as here).
525 Boring! Boring! One error message per binder. The above ToDo is
526 even more helpful. Something very similar happens for pattern-bound
530 mkSelectorBinds :: TypecheckedPat -- The pattern
531 -> CoreExpr -- Expression to which the pattern is bound
532 -> DsM [(Id,CoreExpr)]
534 mkSelectorBinds (VarPat v) val_expr
535 = returnDs [(v, val_expr)]
537 mkSelectorBinds pat val_expr
538 | isSingleton binders || is_simple_pat pat
539 = -- Given p = e, where p binds x,y
540 -- we are going to make
541 -- v = p (where v is fresh)
542 -- x = case v of p -> x
543 -- y = case v of p -> x
546 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
547 -- This does not matter after desugaring, but there's a subtle
548 -- issue with implicit parameters. Consider
550 -- Then, ?i is given type {?i :: Int}, a SourceType, which is opaque
551 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
552 -- does it get that type? So that when we abstract over it we get the
553 -- right top-level type (?i::Int) => ...)
555 -- So to get the type of 'v', use the pattern not the rhs. Often more
557 newSysLocalDs (hsPatType pat) `thenDs` \ val_var ->
559 -- For the error message we make one error-app, to avoid duplication.
560 -- But we need it at different types... so we use coerce for that
561 mkErrorAppDs iRREFUT_PAT_ERROR_ID
562 unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr ->
563 newSysLocalDs unitTy `thenDs` \ err_var ->
564 mapDs (mk_bind val_var err_var) binders `thenDs` \ binds ->
565 returnDs ( (val_var, val_expr) :
566 (err_var, err_expr) :
571 = mkErrorAppDs iRREFUT_PAT_ERROR_ID
572 tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
573 matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr ->
574 newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
577 = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
579 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
581 binders = collectPatBinders pat
582 local_tuple = mkTupleExpr binders
583 tuple_ty = exprType local_tuple
585 mk_bind scrut_var err_var bndr_var
586 -- (mk_bind sv err_var) generates
587 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
588 -- Remember, pat binds bv
589 = matchSimply (Var scrut_var) PatBindRhs pat
590 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
591 returnDs (bndr_var, rhs_expr)
593 error_expr = mkCoerce (idType bndr_var) (Var err_var)
595 is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
596 is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_pat (hsConArgs ps)
597 is_simple_pat (VarPat _) = True
598 is_simple_pat (ParPat p) = is_simple_pat p
599 is_simple_pat other = False
601 is_triv_pat (VarPat v) = True
602 is_triv_pat (WildPat _) = True
603 is_triv_pat (ParPat p) = is_triv_pat p
604 is_triv_pat other = False
608 %************************************************************************
612 %************************************************************************
614 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
616 * If it has only one element, it is the identity function.
618 * If there are more elements than a big tuple can have, it nests
621 Nesting policy. Better a 2-tuple of 10-tuples (3 objects) than
622 a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big.
625 mkTupleExpr :: [Id] -> CoreExpr
626 mkTupleExpr ids = mkBigCoreTup (map Var ids)
628 -- corresponding type
629 mkTupleType :: [Id] -> Type
630 mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
632 mkBigCoreTup :: [CoreExpr] -> CoreExpr
633 mkBigCoreTup = mkBigTuple mkCoreTup
635 mkBigTuple :: ([a] -> a) -> [a] -> a
636 mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
638 -- Each sub-list is short enough to fit in a tuple
639 mk_big_tuple [as] = small_tuple as
640 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
642 chunkify :: [a] -> [[a]]
643 -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
644 -- But there may be more than mAX_TUPLE_SIZE sub-lists
646 | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
647 | otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
651 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
655 @mkTupleSelector@ builds a selector which scrutises the given
656 expression and extracts the one name from the list given.
657 If you want the no-shadowing rule to apply, the caller
658 is responsible for making sure that none of these names
661 If there is just one id in the ``tuple'', then the selector is
664 If it's big, it does nesting
665 mkTupleSelector [a,b,c,d] b v e
667 (p,q) -> case p of p {
669 We use 'tpl' vars for the p,q, since shadowing does not matter.
671 In fact, it's more convenient to generate it innermost first, getting
678 mkTupleSelector :: [Id] -- The tuple args
679 -> Id -- The selected one
680 -> Id -- A variable of the same type as the scrutinee
681 -> CoreExpr -- Scrutinee
684 mkTupleSelector vars the_var scrut_var scrut
685 = mk_tup_sel (chunkify vars) the_var
687 mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
688 mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
689 mk_tup_sel (chunkify tpl_vs) tpl_v
691 tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
692 tpl_vs = mkTemplateLocals tpl_tys
693 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
697 A generalization of @mkTupleSelector@, allowing the body
698 of the case to be an arbitrary expression.
700 If the tuple is big, it is nested:
702 mkTupleCase uniqs [a,b,c,d] body v e
703 = case e of v { (p,q) ->
704 case p of p { (a,b) ->
705 case q of q { (c,d) ->
708 To avoid shadowing, we use uniqs to invent new variables p,q.
710 ToDo: eliminate cases where none of the variables are needed.
714 :: UniqSupply -- for inventing names of intermediate variables
715 -> [Id] -- the tuple args
716 -> CoreExpr -- body of the case
717 -> Id -- a variable of the same type as the scrutinee
718 -> CoreExpr -- scrutinee
721 mkTupleCase uniqs vars body scrut_var scrut
722 = mk_tuple_case uniqs (chunkify vars) body
724 mk_tuple_case us [vars] body
725 = mkSmallTupleCase vars body scrut_var scrut
726 mk_tuple_case us vars_s body
728 (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
730 mk_tuple_case us' (chunkify vars') body'
731 one_tuple_case chunk_vars (us, vs, body)
733 (us1, us2) = splitUniqSupply us
734 scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
735 (mkCoreTupTy (map idType chunk_vars))
736 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
737 in (us2, scrut_var:vs, body')
740 The same, but with a tuple small enough not to need nesting.
744 :: [Id] -- the tuple args
745 -> CoreExpr -- body of the case
746 -> Id -- a variable of the same type as the scrutinee
747 -> CoreExpr -- scrutinee
750 mkSmallTupleCase [var] body _scrut_var scrut
751 = bindNonRec var scrut body
752 mkSmallTupleCase vars body scrut_var scrut
753 = Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
756 %************************************************************************
758 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
760 %************************************************************************
762 Call the constructor Ids when building explicit lists, so that they
763 interact well with rules.
766 mkNilExpr :: Type -> CoreExpr
767 mkNilExpr ty = mkConApp nilDataCon [Type ty]
769 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
770 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
772 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
773 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
776 -- The next three functions make tuple types, constructors and selectors,
777 -- with the rule that a 1-tuple is represented by the thing itselg
778 mkCoreTupTy :: [Type] -> Type
779 mkCoreTupTy [ty] = ty
780 mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
782 mkCoreTup :: [CoreExpr] -> CoreExpr
783 -- Builds exactly the specified tuple.
784 -- No fancy business for big tuples
785 mkCoreTup [] = Var unitDataConId
787 mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
788 (map (Type . exprType) cs ++ cs)
790 mkCoreSel :: [Id] -- The tuple args
791 -> Id -- The selected one
792 -> Id -- A variable of the same type as the scrutinee
793 -> CoreExpr -- Scrutinee
795 -- mkCoreSel [x,y,z] x v e
796 -- ===> case e of v { (x,y,z) -> x
797 mkCoreSel [var] should_be_the_same_var scrut_var scrut
798 = ASSERT(var == should_be_the_same_var)
801 mkCoreSel vars the_var scrut_var scrut
802 = ASSERT( notNull vars )
804 [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
808 %************************************************************************
810 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
812 %************************************************************************
814 Generally, we handle pattern matching failure like this: let-bind a
815 fail-variable, and use that variable if the thing fails:
817 let fail.33 = error "Help"
828 If the case can't fail, then there'll be no mention of @fail.33@, and the
829 simplifier will later discard it.
832 If it can fail in only one way, then the simplifier will inline it.
835 Only if it is used more than once will the let-binding remain.
838 There's a problem when the result of the case expression is of
839 unboxed type. Then the type of @fail.33@ is unboxed too, and
840 there is every chance that someone will change the let into a case:
846 which is of course utterly wrong. Rather than drop the condition that
847 only boxed types can be let-bound, we just turn the fail into a function
848 for the primitive case:
850 let fail.33 :: Void -> Int#
851 fail.33 = \_ -> error "Help"
860 Now @fail.33@ is a function, so it can be let-bound.
863 mkFailurePair :: CoreExpr -- Result type of the whole case expression
864 -> DsM (CoreBind, -- Binds the newly-created fail variable
865 -- to either the expression or \ _ -> expression
866 CoreExpr) -- Either the fail variable, or fail variable
867 -- applied to unit tuple
870 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
871 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
872 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
873 App (Var fail_fun_var) (Var unitDataConId))
876 = newFailLocalDs ty `thenDs` \ fail_var ->
877 returnDs (NonRec fail_var expr, Var fail_var)