2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Utilities for desugaring
8 This module exports some utility functions of no great interest.
11 -- | Utility functions for constructing Core syntax, principally for desugaring
16 MatchResult(..), CanItFail(..),
17 cantFailMatchResult, alwaysFailMatchResult,
18 extractMatchResult, combineMatchResults,
19 adjustMatchResult, adjustMatchResultDs,
20 mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
21 matchCanFail, mkEvalMatchResult,
22 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
25 mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
30 mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
31 mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
35 dsSyntaxTable, lookupEvidence,
37 selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
38 mkTickBox, mkOptTickBox, mkBinaryTickBox
41 #include "HsVersions.h"
43 import {-# SOURCE #-} Match ( matchSimply )
44 import {-# SOURCE #-} DsExpr( dsExpr )
48 import TcType( tcSplitTyConApp )
77 %************************************************************************
81 %************************************************************************
84 dsSyntaxTable :: SyntaxTable Id
85 -> DsM ([CoreBind], -- Auxiliary bindings
86 [(Name,Id)]) -- Maps the standard name to its value
88 dsSyntaxTable rebound_ids = do
89 (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
90 return (concat binds_s, prs)
92 -- The cheapo special case can happen when we
93 -- make an intermediate HsDo when desugaring a RecStmt
94 mk_bind (std_name, HsVar id) = return ([], (std_name, id))
95 mk_bind (std_name, expr) = do
97 id <- newSysLocalDs (exprType rhs)
98 return ([NonRec id rhs], (std_name, id))
100 lookupEvidence :: [(Name, Id)] -> Name -> Id
101 lookupEvidence prs std_name
102 = assocDefault (mk_panic std_name) prs std_name
104 mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
107 %************************************************************************
109 \subsection{ Selecting match variables}
111 %************************************************************************
113 We're about to match against some patterns. We want to make some
114 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
115 hand, which should indeed be bound to the pattern as a whole, then use it;
116 otherwise, make one up.
119 selectSimpleMatchVarL :: LPat Id -> DsM Id
120 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
122 -- (selectMatchVars ps tys) chooses variables of type tys
123 -- to use for matching ps against. If the pattern is a variable,
124 -- we try to use that, to save inventing lots of fresh variables.
126 -- OLD, but interesting note:
127 -- But even if it is a variable, its type might not match. Consider
129 -- T1 :: Int -> T Int
132 -- f :: T a -> a -> Int
133 -- f (T1 i) (x::Int) = x
134 -- f (T2 i) (y::a) = 0
135 -- Then we must not choose (x::Int) as the matching variable!
136 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
138 selectMatchVars :: [Pat Id] -> DsM [Id]
139 selectMatchVars ps = mapM selectMatchVar ps
141 selectMatchVar :: Pat Id -> DsM Id
142 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
143 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
144 selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
145 selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders]
146 selectMatchVar (AsPat var _) = return (unLoc var)
147 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
148 -- OK, better make up one...
151 Note [Localise pattern binders]
152 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
153 Consider module M where
155 After renaming it looks like
159 We don't generalise, since it's a pattern binding, monomorphic, etc,
160 so after desugaring we may get something like
161 M.a = case e of (v:_) ->
162 case v of Just M.a -> M.a
163 Notice the "M.a" in the pattern; after all, it was in the original
164 pattern. However, after optimisation those pattern binders can become
165 let-binders, and then end up floated to top level. They have a
166 different *unique* by then (the simplifier is good about maintaining
167 proper scoping), but it's BAD to have two top-level bindings with the
168 External Name M.a, because that turns into two linker symbols for M.a.
169 It's quite rare for this to actually *happen* -- the only case I know
170 of is tc003 compiled with the 'hpc' way -- but that only makes it
171 all the more annoying.
173 To avoid this, we craftily call 'localiseId' in the desugarer, which
174 simply turns the External Name for the Id into an Internal one, but
175 doesn't change the unique. So the desugarer produces this:
176 M.a{r8} = case e of (v:_) ->
177 case v of Just a{r8} -> M.a{r8}
178 The unique is still 'r8', but the binding site in the pattern
179 is now an Internal Name. Now the simplifier's usual mechanisms
180 will propagate that Name to all the occurrence sites, as well as
181 un-shadowing it, so we'll get
182 M.a{r8} = case e of (v:_) ->
183 case v of Just a{s77} -> a{s77}
184 In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
185 runs on the output of the desugarer, so all is well by the end of
189 %************************************************************************
191 %* type synonym EquationInfo and access functions for its pieces *
193 %************************************************************************
194 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
196 The ``equation info'' used by @match@ is relatively complicated and
197 worthy of a type synonym and a few handy functions.
200 firstPat :: EquationInfo -> Pat Id
201 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
203 shiftEqns :: [EquationInfo] -> [EquationInfo]
204 -- Drop the first pattern in each equation
205 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
208 Functions on MatchResults
211 matchCanFail :: MatchResult -> Bool
212 matchCanFail (MatchResult CanFail _) = True
213 matchCanFail (MatchResult CantFail _) = False
215 alwaysFailMatchResult :: MatchResult
216 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
218 cantFailMatchResult :: CoreExpr -> MatchResult
219 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
221 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
222 extractMatchResult (MatchResult CantFail match_fn) _
223 = match_fn (error "It can't fail!")
225 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
226 (fail_bind, if_it_fails) <- mkFailurePair fail_expr
227 body <- match_fn if_it_fails
228 return (mkCoreLet fail_bind body)
231 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
232 combineMatchResults (MatchResult CanFail body_fn1)
233 (MatchResult can_it_fail2 body_fn2)
234 = MatchResult can_it_fail2 body_fn
236 body_fn fail = do body2 <- body_fn2 fail
237 (fail_bind, duplicatable_expr) <- mkFailurePair body2
238 body1 <- body_fn1 duplicatable_expr
239 return (Let fail_bind body1)
241 combineMatchResults match_result1@(MatchResult CantFail _) _
244 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
245 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
246 = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
248 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
249 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
250 = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
252 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
254 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
256 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
257 wrapBind new old body -- NB: this function must deal with term
258 | new==old = body -- variables, type variables or coercion variables
259 | otherwise = Let (NonRec new (varToCoreExpr old)) body
261 seqVar :: Var -> CoreExpr -> CoreExpr
262 seqVar var body = Case (Var var) var (exprType body)
263 [(DEFAULT, [], body)]
265 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
266 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
268 -- (mkViewMatchResult var' viewExpr var mr) makes the expression
269 -- let var' = viewExpr var in mr
270 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
271 mkViewMatchResult var' viewExpr var =
272 adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
274 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
275 mkEvalMatchResult var ty
276 = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
278 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
279 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
280 = MatchResult CanFail (\fail -> do body <- body_fn fail
281 return (mkIfThenElse pred_expr body fail))
283 mkCoPrimCaseMatchResult :: Id -- Scrutinee
284 -> Type -- Type of the case
285 -> [(Literal, MatchResult)] -- Alternatives
287 mkCoPrimCaseMatchResult var ty match_alts
288 = MatchResult CanFail mk_case
291 alts <- mapM (mk_alt fail) sorted_alts
292 return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
294 sorted_alts = sortWith fst match_alts -- Right order for a Case
295 mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail
296 return (LitAlt lit, [], body)
299 mkCoAlgCaseMatchResult
301 -> Type -- Type of exp
302 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts)
304 mkCoAlgCaseMatchResult var ty match_alts
305 | isNewTyCon tycon -- Newtype case; use a let
306 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
307 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
309 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
310 = MatchResult CanFail mk_parrCase
312 | otherwise -- Datatype case; use a case
313 = MatchResult fail_flag mk_case
315 tycon = dataConTyCon con1
316 -- [Interesting: becuase of GADTs, we can't rely on the type of
317 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
320 (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
321 arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
323 (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
324 -- (not that splitTyConApp does, these days)
325 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
327 -- Stuff for data types
328 data_cons = tyConDataCons tycon
329 match_results = [match_result | (_,_,match_result) <- match_alts]
331 fail_flag | exhaustive_case
332 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
336 sorted_alts = sortWith get_tag match_alts
337 get_tag (con, _, _) = dataConTag con
338 mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
339 return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
341 mk_alt fail (con, args, MatchResult _ body_fn) = do
343 us <- newUniqueSupply
344 return (mkReboxingAlt (uniqsFromSupply us) con args body)
346 mk_default fail | exhaustive_case = []
347 | otherwise = [(DEFAULT, [], fail)]
349 un_mentioned_constructors
350 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
351 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
353 -- Stuff for parallel arrays
355 -- * the following is to desugar cases over fake constructors for
356 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
359 -- Concerning `isPArrFakeAlts':
361 -- * it is *not* sufficient to just check the type of the type
362 -- constructor, as we have to be careful not to confuse the real
363 -- representation of parallel arrays with the fake constructors;
364 -- moreover, a list of alternatives must not mix fake and real
365 -- constructors (this is checked earlier on)
367 -- FIXME: We actually go through the whole list and make sure that
368 -- either all or none of the constructors are fake parallel
369 -- array constructors. This is to spot equations that mix fake
370 -- constructors with the real representation defined in
371 -- `PrelPArr'. It would be nicer to spot this situation
372 -- earlier and raise a proper error message, but it can really
373 -- only happen in `PrelPArr' anyway.
375 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
376 isPArrFakeAlts ((dcon, _, _):alts) =
377 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
378 (True , True ) -> True
379 (False, False) -> False
380 _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
381 isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
383 mk_parrCase fail = do
384 lengthP <- dsLookupDPHId lengthPName
386 return (mkWildCase (len lengthP) intTy ty [alt])
388 elemTy = case splitTyConApp (idType var) of
389 (_, [elemTy]) -> elemTy
391 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
392 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
395 l <- newSysLocalDs intPrimTy
396 indexP <- dsLookupDPHId indexPName
397 alts <- mapM (mkAlt indexP) sorted_alts
398 return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
400 dft = (DEFAULT, [], fail)
402 -- each alternative matches one array length (corresponding to one
403 -- fake array constructor), so the match is on a literal; each
404 -- alternative's body is extended by a local binding for each
405 -- constructor argument, which are bound to array elements starting
408 mkAlt indexP (con, args, MatchResult _ bodyFun) = do
410 return (LitAlt lit, [], mkCoreLets binds body)
412 lit = MachInt $ toInteger (dataConSourceArity con)
413 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
415 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
418 %************************************************************************
420 \subsection{Desugarer's versions of some Core functions}
422 %************************************************************************
425 mkErrorAppDs :: Id -- The error function
426 -> Type -- Type to which it should be applied
427 -> SDoc -- The error message string to pass
430 mkErrorAppDs err_id ty msg = do
431 src_loc <- getSrcSpanDs
433 full_msg = showSDoc (hcat [ppr src_loc, text "|", msg])
434 core_msg = Lit (mkMachString full_msg)
435 -- mkMachString returns a result of type String#
436 return (mkApps (Var err_id) [Type ty, core_msg])
439 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
441 Note [Desugaring seq (1)] cf Trac #1031
442 ~~~~~~~~~~~~~~~~~~~~~~~~~
443 f x y = x `seq` (y `seq` (# x,y #))
445 The [CoreSyn let/app invariant] means that, other things being equal, because
446 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
448 f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
450 But that is bad for two reasons:
451 (a) we now evaluate y before x, and
452 (b) we can't bind v to an unboxed pair
454 Seq is very, very special! So we recognise it right here, and desugar to
455 case x of _ -> case y of _ -> (# x,y #)
457 Note [Desugaring seq (2)] cf Trac #2273
458 ~~~~~~~~~~~~~~~~~~~~~~~~~
460 let chp = case b of { True -> fst x; False -> 0 }
461 in chp `seq` ...chp...
462 Here the seq is designed to plug the space leak of retaining (snd x)
465 If we rely on the ordinary inlining of seq, we'll get
466 let chp = case b of { True -> fst x; False -> 0 }
467 case chp of _ { I# -> ...chp... }
469 But since chp is cheap, and the case is an alluring contet, we'll
470 inline chp into the case scrutinee. Now there is only one use of chp,
471 so we'll inline a second copy. Alas, we've now ruined the purpose of
472 the seq, by re-introducing the space leak:
473 case (case b of {True -> fst x; False -> 0}) of
474 I# _ -> ...case b of {True -> fst x; False -> 0}...
476 We can try to avoid doing this by ensuring that the binder-swap in the
477 case happens, so we get his at an early stage:
478 case chp of chp2 { I# -> ...chp2... }
479 But this is fragile. The real culprit is the source program. Perhaps we
480 should have said explicitly
481 let !chp2 = chp in ...chp2...
483 But that's painful. So the code here does a little hack to make seq
484 more robust: a saturated application of 'seq' is turned *directly* into
485 the case expression, thus:
486 x `seq` e2 ==> case x of x -> e2 -- Note shadowing!
487 e1 `seq` e2 ==> case x of _ -> e2
489 So we desugar our example to:
490 let chp = case b of { True -> fst x; False -> 0 }
491 case chp of chp { I# -> ...chp... }
494 The reason it's a hack is because if you define mySeq=seq, the hack
497 Note [Desugaring seq (3)] cf Trac #2409
498 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
499 The isLocalId ensures that we don't turn
502 case True of True { ... }
503 which stupidly tries to bind the datacon 'True'.
506 mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr
507 mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
508 | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
509 = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
511 case_bndr = case arg1 of
512 Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
513 _ -> mkWildValBinder ty1
515 mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
517 mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
518 mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
522 %************************************************************************
524 \subsection[mkSelectorBind]{Make a selector bind}
526 %************************************************************************
528 This is used in various places to do with lazy patterns.
529 For each binder $b$ in the pattern, we create a binding:
531 b = case v of pat' -> b'
533 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
535 ToDo: making these bindings should really depend on whether there's
536 much work to be done per binding. If the pattern is complex, it
537 should be de-mangled once, into a tuple (and then selected from).
538 Otherwise the demangling can be in-line in the bindings (as here).
540 Boring! Boring! One error message per binder. The above ToDo is
541 even more helpful. Something very similar happens for pattern-bound
545 mkSelectorBinds :: LPat Id -- The pattern
546 -> CoreExpr -- Expression to which the pattern is bound
547 -> DsM [(Id,CoreExpr)]
549 mkSelectorBinds (L _ (VarPat v)) val_expr
550 = return [(v, val_expr)]
552 mkSelectorBinds pat val_expr
553 | isSingleton binders || is_simple_lpat pat = do
554 -- Given p = e, where p binds x,y
555 -- we are going to make
556 -- v = p (where v is fresh)
557 -- x = case v of p -> x
558 -- y = case v of p -> x
561 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
562 -- This does not matter after desugaring, but there's a subtle
563 -- issue with implicit parameters. Consider
565 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
566 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
567 -- does it get that type? So that when we abstract over it we get the
568 -- right top-level type (?i::Int) => ...)
570 -- So to get the type of 'v', use the pattern not the rhs. Often more
572 val_var <- newSysLocalDs (hsLPatType pat)
574 -- For the error message we make one error-app, to avoid duplication.
575 -- But we need it at different types... so we use coerce for that
576 err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat)
577 err_var <- newSysLocalDs unitTy
578 binds <- mapM (mk_bind val_var err_var) binders
579 return ( (val_var, val_expr) :
580 (err_var, err_expr) :
585 error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
586 tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
587 tuple_var <- newSysLocalDs tuple_ty
588 let mk_tup_bind binder
589 = (binder, mkTupleSelector local_binders binder tuple_var (Var tuple_var))
590 return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
592 binders = collectPatBinders pat
593 local_binders = map localiseId binders -- See Note [Localise pattern binders]
594 local_tuple = mkBigCoreVarTup binders
595 tuple_ty = exprType local_tuple
597 mk_bind scrut_var err_var bndr_var = do
598 -- (mk_bind sv err_var) generates
599 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
600 -- Remember, pat binds bv
601 rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
602 (Var bndr_var) error_expr
603 return (bndr_var, rhs_expr)
605 error_expr = mkCoerce co (Var err_var)
606 co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
608 is_simple_lpat p = is_simple_pat (unLoc p)
610 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
611 is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
612 is_simple_pat (VarPat _) = True
613 is_simple_pat (ParPat p) = is_simple_lpat p
614 is_simple_pat _ = False
616 is_triv_lpat p = is_triv_pat (unLoc p)
618 is_triv_pat (VarPat _) = True
619 is_triv_pat (WildPat _) = True
620 is_triv_pat (ParPat p) = is_triv_lpat p
621 is_triv_pat _ = False
625 Creating big tuples and their types for full Haskell expressions.
626 They work over *Ids*, and create tuples replete with their types,
627 which is whey they are not in HsUtils.
630 mkLHsPatTup :: [LPat Id] -> LPat Id
631 mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
632 mkLHsPatTup [lpat] = lpat
633 mkLHsPatTup lpats = L (getLoc (head lpats)) $
634 mkVanillaTuplePat lpats Boxed
636 mkLHsVarPatTup :: [Id] -> LPat Id
637 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
639 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
640 -- A vanilla tuple pattern simply gets its type from its sub-patterns
641 mkVanillaTuplePat pats box
642 = TuplePat pats box (mkTupleTy box (map hsLPatType pats))
644 -- The Big equivalents for the source tuple expressions
645 mkBigLHsVarTup :: [Id] -> LHsExpr Id
646 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
648 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
649 mkBigLHsTup = mkChunkified mkLHsTupleExpr
651 -- The Big equivalents for the source tuple patterns
652 mkBigLHsVarPatTup :: [Id] -> LPat Id
653 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
655 mkBigLHsPatTup :: [LPat Id] -> LPat Id
656 mkBigLHsPatTup = mkChunkified mkLHsPatTup
659 %************************************************************************
661 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
663 %************************************************************************
665 Generally, we handle pattern matching failure like this: let-bind a
666 fail-variable, and use that variable if the thing fails:
668 let fail.33 = error "Help"
679 If the case can't fail, then there'll be no mention of @fail.33@, and the
680 simplifier will later discard it.
683 If it can fail in only one way, then the simplifier will inline it.
686 Only if it is used more than once will the let-binding remain.
689 There's a problem when the result of the case expression is of
690 unboxed type. Then the type of @fail.33@ is unboxed too, and
691 there is every chance that someone will change the let into a case:
697 which is of course utterly wrong. Rather than drop the condition that
698 only boxed types can be let-bound, we just turn the fail into a function
699 for the primitive case:
701 let fail.33 :: Void -> Int#
702 fail.33 = \_ -> error "Help"
711 Now @fail.33@ is a function, so it can be let-bound.
714 mkFailurePair :: CoreExpr -- Result type of the whole case expression
715 -> DsM (CoreBind, -- Binds the newly-created fail variable
716 -- to \ _ -> expression
717 CoreExpr) -- Fail variable applied to realWorld#
718 -- See Note [Failure thunks and CPR]
720 = do { fail_fun_var <- newFailLocalDs (realWorldStatePrimTy `mkFunTy` ty)
721 ; fail_fun_arg <- newSysLocalDs realWorldStatePrimTy
722 ; return (NonRec fail_fun_var (Lam fail_fun_arg expr),
723 App (Var fail_fun_var) (Var realWorldPrimId)) }
728 Note [Failure thunks and CPR]
729 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
730 When we make a failure point we ensure that it
731 does not look like a thunk. Example:
733 let fail = \rw -> error "urk"
735 [] -> fail realWorld#
737 [] -> fail realWorld#
740 Reason: we know that a failure point is always a "join point" and is
741 entered at most once. Adding a dummy 'realWorld' token argument makes
742 it clear that sharing is not an issue. And that in turn makes it more
743 CPR-friendly. This matters a lot: if you don't get it right, you lose
744 the tail call property. For example, see Trac #3403.
747 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
748 mkOptTickBox Nothing e = return e
749 mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
751 mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
752 mkTickBox ix vars e = do
755 let tick | opt_Hpc = mkTickBoxOpId uq mod ix
756 | otherwise = mkBreakPointOpId uq mod ix
758 let occName = mkVarOcc "tick"
759 let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
760 let var = Id.mkLocalId name realWorldStatePrimTy
763 then return (Var tick)
765 let tickVar = Var tick
766 let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
767 let scrutApTy = App tickVar (Type tickType)
768 return (mkApps scrutApTy (map Var vars) :: Expr Id)
769 return $ Case scrut var ty [(DEFAULT,[],e)]
773 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
774 mkBinaryTickBox ixT ixF e = do
776 let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
777 falseBox <- mkTickBox ixF [] $ Var falseDataConId
778 trueBox <- mkTickBox ixT [] $ Var trueDataConId
779 return $ Case e bndr1 boolTy
780 [ (DataAlt falseDataCon, [], falseBox)
781 , (DataAlt trueDataCon, [], trueBox)