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, 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,
64 stringTy, isPArrFakeCon )
65 import BasicTypes ( Boxity(..) )
66 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
67 import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
68 import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
69 plusIntegerName, timesIntegerName, smallIntegerDataConName,
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 = mappM (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 = mappM (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 newUniqueSupply `thenDs` \ us ->
337 returnDs (mkReboxingAlt (uniqsFromSupply 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 mappM (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 = dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc ->
454 returnDs (mkSmallIntegerLit integer_dc i)
456 -- Special case for integral literals with a large magnitude:
457 -- They are transformed into an expression involving only smaller
458 -- integral literals. This improves constant folding.
460 | otherwise -- Big, so start from a string
461 = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id ->
462 dsLookupGlobalId timesIntegerName `thenDs` \ times_id ->
463 dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc ->
465 lit i = mkSmallIntegerLit integer_dc i
466 plus a b = Var plus_id `App` a `App` b
467 times a b = Var times_id `App` a `App` b
469 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
470 horner :: Integer -> Integer -> CoreExpr
471 horner b i | abs q <= 1 = if r == 0 || r == i
473 else lit r `plus` lit (i-r)
474 | r == 0 = horner b q `times` lit b
475 | otherwise = lit r `plus` (horner b q `times` lit b)
477 (q,r) = i `quotRem` b
480 returnDs (horner tARGET_MAX_INT i)
482 mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
484 mkStringLit str = mkStringLitFS (mkFastString str)
488 = returnDs (mkNilExpr charTy)
492 the_char = mkCharExpr (headIntFS str)
494 returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
496 | all safeChar int_chars
497 = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id ->
498 returnDs (App (Var unpack_id) (Lit (MachStr str)))
501 = dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id ->
502 returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars)))))
505 int_chars = unpackIntFS str
506 safeChar c = c >= 1 && c <= 0xFF
510 %************************************************************************
512 \subsection[mkSelectorBind]{Make a selector bind}
514 %************************************************************************
516 This is used in various places to do with lazy patterns.
517 For each binder $b$ in the pattern, we create a binding:
519 b = case v of pat' -> b'
521 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
523 ToDo: making these bindings should really depend on whether there's
524 much work to be done per binding. If the pattern is complex, it
525 should be de-mangled once, into a tuple (and then selected from).
526 Otherwise the demangling can be in-line in the bindings (as here).
528 Boring! Boring! One error message per binder. The above ToDo is
529 even more helpful. Something very similar happens for pattern-bound
533 mkSelectorBinds :: TypecheckedPat -- The pattern
534 -> CoreExpr -- Expression to which the pattern is bound
535 -> DsM [(Id,CoreExpr)]
537 mkSelectorBinds (VarPat v) val_expr
538 = returnDs [(v, val_expr)]
540 mkSelectorBinds pat val_expr
541 | isSingleton binders || is_simple_pat pat
542 = -- Given p = e, where p binds x,y
543 -- we are going to make
544 -- v = p (where v is fresh)
545 -- x = case v of p -> x
546 -- y = case v of p -> x
549 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
550 -- This does not matter after desugaring, but there's a subtle
551 -- issue with implicit parameters. Consider
553 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
554 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
555 -- does it get that type? So that when we abstract over it we get the
556 -- right top-level type (?i::Int) => ...)
558 -- So to get the type of 'v', use the pattern not the rhs. Often more
560 newSysLocalDs (hsPatType pat) `thenDs` \ val_var ->
562 -- For the error message we make one error-app, to avoid duplication.
563 -- But we need it at different types... so we use coerce for that
564 mkErrorAppDs iRREFUT_PAT_ERROR_ID
565 unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr ->
566 newSysLocalDs unitTy `thenDs` \ err_var ->
567 mappM (mk_bind val_var err_var) binders `thenDs` \ binds ->
568 returnDs ( (val_var, val_expr) :
569 (err_var, err_expr) :
574 = mkErrorAppDs iRREFUT_PAT_ERROR_ID
575 tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
576 matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr ->
577 newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
580 = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
582 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
584 binders = collectPatBinders pat
585 local_tuple = mkTupleExpr binders
586 tuple_ty = exprType local_tuple
588 mk_bind scrut_var err_var bndr_var
589 -- (mk_bind sv err_var) generates
590 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
591 -- Remember, pat binds bv
592 = matchSimply (Var scrut_var) PatBindRhs pat
593 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
594 returnDs (bndr_var, rhs_expr)
596 error_expr = mkCoerce (idType bndr_var) (Var err_var)
598 is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
599 is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_pat (hsConArgs ps)
600 is_simple_pat (VarPat _) = True
601 is_simple_pat (ParPat p) = is_simple_pat p
602 is_simple_pat other = False
604 is_triv_pat (VarPat v) = True
605 is_triv_pat (WildPat _) = True
606 is_triv_pat (ParPat p) = is_triv_pat p
607 is_triv_pat other = False
611 %************************************************************************
615 %************************************************************************
617 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
619 * If it has only one element, it is the identity function.
621 * If there are more elements than a big tuple can have, it nests
624 Nesting policy. Better a 2-tuple of 10-tuples (3 objects) than
625 a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big.
628 mkTupleExpr :: [Id] -> CoreExpr
629 mkTupleExpr ids = mkBigCoreTup (map Var ids)
631 -- corresponding type
632 mkTupleType :: [Id] -> Type
633 mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
635 mkBigCoreTup :: [CoreExpr] -> CoreExpr
636 mkBigCoreTup = mkBigTuple mkCoreTup
638 mkBigTuple :: ([a] -> a) -> [a] -> a
639 mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
641 -- Each sub-list is short enough to fit in a tuple
642 mk_big_tuple [as] = small_tuple as
643 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
645 chunkify :: [a] -> [[a]]
646 -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
647 -- But there may be more than mAX_TUPLE_SIZE sub-lists
649 | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
650 | otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
654 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
658 @mkTupleSelector@ builds a selector which scrutises the given
659 expression and extracts the one name from the list given.
660 If you want the no-shadowing rule to apply, the caller
661 is responsible for making sure that none of these names
664 If there is just one id in the ``tuple'', then the selector is
667 If it's big, it does nesting
668 mkTupleSelector [a,b,c,d] b v e
670 (p,q) -> case p of p {
672 We use 'tpl' vars for the p,q, since shadowing does not matter.
674 In fact, it's more convenient to generate it innermost first, getting
681 mkTupleSelector :: [Id] -- The tuple args
682 -> Id -- The selected one
683 -> Id -- A variable of the same type as the scrutinee
684 -> CoreExpr -- Scrutinee
687 mkTupleSelector vars the_var scrut_var scrut
688 = mk_tup_sel (chunkify vars) the_var
690 mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
691 mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
692 mk_tup_sel (chunkify tpl_vs) tpl_v
694 tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
695 tpl_vs = mkTemplateLocals tpl_tys
696 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
700 A generalization of @mkTupleSelector@, allowing the body
701 of the case to be an arbitrary expression.
703 If the tuple is big, it is nested:
705 mkTupleCase uniqs [a,b,c,d] body v e
706 = case e of v { (p,q) ->
707 case p of p { (a,b) ->
708 case q of q { (c,d) ->
711 To avoid shadowing, we use uniqs to invent new variables p,q.
713 ToDo: eliminate cases where none of the variables are needed.
717 :: UniqSupply -- for inventing names of intermediate variables
718 -> [Id] -- the tuple args
719 -> CoreExpr -- body of the case
720 -> Id -- a variable of the same type as the scrutinee
721 -> CoreExpr -- scrutinee
724 mkTupleCase uniqs vars body scrut_var scrut
725 = mk_tuple_case uniqs (chunkify vars) body
727 mk_tuple_case us [vars] body
728 = mkSmallTupleCase vars body scrut_var scrut
729 mk_tuple_case us vars_s body
731 (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
733 mk_tuple_case us' (chunkify vars') body'
734 one_tuple_case chunk_vars (us, vs, body)
736 (us1, us2) = splitUniqSupply us
737 scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
738 (mkCoreTupTy (map idType chunk_vars))
739 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
740 in (us2, scrut_var:vs, body')
743 The same, but with a tuple small enough not to need nesting.
747 :: [Id] -- the tuple args
748 -> CoreExpr -- body of the case
749 -> Id -- a variable of the same type as the scrutinee
750 -> CoreExpr -- scrutinee
753 mkSmallTupleCase [var] body _scrut_var scrut
754 = bindNonRec var scrut body
755 mkSmallTupleCase vars body scrut_var scrut
756 = Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
759 %************************************************************************
761 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
763 %************************************************************************
765 Call the constructor Ids when building explicit lists, so that they
766 interact well with rules.
769 mkNilExpr :: Type -> CoreExpr
770 mkNilExpr ty = mkConApp nilDataCon [Type ty]
772 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
773 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
775 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
776 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
779 -- The next three functions make tuple types, constructors and selectors,
780 -- with the rule that a 1-tuple is represented by the thing itselg
781 mkCoreTupTy :: [Type] -> Type
782 mkCoreTupTy [ty] = ty
783 mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
785 mkCoreTup :: [CoreExpr] -> CoreExpr
786 -- Builds exactly the specified tuple.
787 -- No fancy business for big tuples
788 mkCoreTup [] = Var unitDataConId
790 mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
791 (map (Type . exprType) cs ++ cs)
793 mkCoreSel :: [Id] -- The tuple args
794 -> Id -- The selected one
795 -> Id -- A variable of the same type as the scrutinee
796 -> CoreExpr -- Scrutinee
798 -- mkCoreSel [x,y,z] x v e
799 -- ===> case e of v { (x,y,z) -> x
800 mkCoreSel [var] should_be_the_same_var scrut_var scrut
801 = ASSERT(var == should_be_the_same_var)
804 mkCoreSel vars the_var scrut_var scrut
805 = ASSERT( notNull vars )
807 [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
811 %************************************************************************
813 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
815 %************************************************************************
817 Generally, we handle pattern matching failure like this: let-bind a
818 fail-variable, and use that variable if the thing fails:
820 let fail.33 = error "Help"
831 If the case can't fail, then there'll be no mention of @fail.33@, and the
832 simplifier will later discard it.
835 If it can fail in only one way, then the simplifier will inline it.
838 Only if it is used more than once will the let-binding remain.
841 There's a problem when the result of the case expression is of
842 unboxed type. Then the type of @fail.33@ is unboxed too, and
843 there is every chance that someone will change the let into a case:
849 which is of course utterly wrong. Rather than drop the condition that
850 only boxed types can be let-bound, we just turn the fail into a function
851 for the primitive case:
853 let fail.33 :: Void -> Int#
854 fail.33 = \_ -> error "Help"
863 Now @fail.33@ is a function, so it can be let-bound.
866 mkFailurePair :: CoreExpr -- Result type of the whole case expression
867 -> DsM (CoreBind, -- Binds the newly-created fail variable
868 -- to either the expression or \ _ -> expression
869 CoreExpr) -- Either the fail variable, or fail variable
870 -- applied to unit tuple
873 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
874 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
875 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
876 App (Var fail_fun_var) (Var unitDataConId))
879 = newFailLocalDs ty `thenDs` \ fail_var ->
880 returnDs (NonRec fail_var expr, Var fail_var)