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 :: Id -- Scrutinee
300 -> Type -- Type of exp
301 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
303 mkCoAlgCaseMatchResult var ty match_alts
304 | isNewTyCon tycon -- Newtype case; use a let
305 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
306 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
308 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
309 = MatchResult CanFail mk_parrCase
311 | otherwise -- Datatype case; use a case
312 = MatchResult fail_flag mk_case
314 tycon = dataConTyCon con1
315 -- [Interesting: becuase of GADTs, we can't rely on the type of
316 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
319 (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
320 arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
322 (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
323 -- (not that splitTyConApp does, these days)
324 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
326 -- Stuff for data types
327 data_cons = tyConDataCons tycon
328 match_results = [match_result | (_,_,match_result) <- match_alts]
330 fail_flag | exhaustive_case
331 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
335 sorted_alts = sortWith get_tag match_alts
336 get_tag (con, _, _) = dataConTag con
337 mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
338 return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
340 mk_alt fail (con, args, MatchResult _ body_fn) = do
342 us <- newUniqueSupply
343 return (mkReboxingAlt (uniqsFromSupply us) con args body)
345 mk_default fail | exhaustive_case = []
346 | otherwise = [(DEFAULT, [], fail)]
348 un_mentioned_constructors
349 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
350 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
352 -- Stuff for parallel arrays
354 -- * the following is to desugar cases over fake constructors for
355 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
358 -- Concerning `isPArrFakeAlts':
360 -- * it is *not* sufficient to just check the type of the type
361 -- constructor, as we have to be careful not to confuse the real
362 -- representation of parallel arrays with the fake constructors;
363 -- moreover, a list of alternatives must not mix fake and real
364 -- constructors (this is checked earlier on)
366 -- FIXME: We actually go through the whole list and make sure that
367 -- either all or none of the constructors are fake parallel
368 -- array constructors. This is to spot equations that mix fake
369 -- constructors with the real representation defined in
370 -- `PrelPArr'. It would be nicer to spot this situation
371 -- earlier and raise a proper error message, but it can really
372 -- only happen in `PrelPArr' anyway.
374 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
375 isPArrFakeAlts ((dcon, _, _):alts) =
376 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
377 (True , True ) -> True
378 (False, False) -> False
379 _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
380 isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
382 mk_parrCase fail = do
383 lengthP <- dsLookupDPHId lengthPName
385 return (mkWildCase (len lengthP) intTy ty [alt])
387 elemTy = case splitTyConApp (idType var) of
388 (_, [elemTy]) -> elemTy
390 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
391 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
394 l <- newSysLocalDs intPrimTy
395 indexP <- dsLookupDPHId indexPName
396 alts <- mapM (mkAlt indexP) sorted_alts
397 return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
399 dft = (DEFAULT, [], fail)
401 -- each alternative matches one array length (corresponding to one
402 -- fake array constructor), so the match is on a literal; each
403 -- alternative's body is extended by a local binding for each
404 -- constructor argument, which are bound to array elements starting
407 mkAlt indexP (con, args, MatchResult _ bodyFun) = do
409 return (LitAlt lit, [], mkCoreLets binds body)
411 lit = MachInt $ toInteger (dataConSourceArity con)
412 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
414 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
417 %************************************************************************
419 \subsection{Desugarer's versions of some Core functions}
421 %************************************************************************
424 mkErrorAppDs :: Id -- The error function
425 -> Type -- Type to which it should be applied
426 -> SDoc -- The error message string to pass
429 mkErrorAppDs err_id ty msg = do
430 src_loc <- getSrcSpanDs
432 full_msg = showSDoc (hcat [ppr src_loc, text "|", msg])
433 core_msg = Lit (mkMachString full_msg)
434 -- mkMachString returns a result of type String#
435 return (mkApps (Var err_id) [Type ty, core_msg])
438 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
440 Note [Desugaring seq (1)] cf Trac #1031
441 ~~~~~~~~~~~~~~~~~~~~~~~~~
442 f x y = x `seq` (y `seq` (# x,y #))
444 The [CoreSyn let/app invariant] means that, other things being equal, because
445 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
447 f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
449 But that is bad for two reasons:
450 (a) we now evaluate y before x, and
451 (b) we can't bind v to an unboxed pair
453 Seq is very, very special! So we recognise it right here, and desugar to
454 case x of _ -> case y of _ -> (# x,y #)
456 Note [Desugaring seq (2)] cf Trac #2273
457 ~~~~~~~~~~~~~~~~~~~~~~~~~
459 let chp = case b of { True -> fst x; False -> 0 }
460 in chp `seq` ...chp...
461 Here the seq is designed to plug the space leak of retaining (snd x)
464 If we rely on the ordinary inlining of seq, we'll get
465 let chp = case b of { True -> fst x; False -> 0 }
466 case chp of _ { I# -> ...chp... }
468 But since chp is cheap, and the case is an alluring contet, we'll
469 inline chp into the case scrutinee. Now there is only one use of chp,
470 so we'll inline a second copy. Alas, we've now ruined the purpose of
471 the seq, by re-introducing the space leak:
472 case (case b of {True -> fst x; False -> 0}) of
473 I# _ -> ...case b of {True -> fst x; False -> 0}...
475 We can try to avoid doing this by ensuring that the binder-swap in the
476 case happens, so we get his at an early stage:
477 case chp of chp2 { I# -> ...chp2... }
478 But this is fragile. The real culprit is the source program. Perhaps we
479 should have said explicitly
480 let !chp2 = chp in ...chp2...
482 But that's painful. So the code here does a little hack to make seq
483 more robust: a saturated application of 'seq' is turned *directly* into
484 the case expression, thus:
485 x `seq` e2 ==> case x of x -> e2 -- Note shadowing!
486 e1 `seq` e2 ==> case x of _ -> e2
488 So we desugar our example to:
489 let chp = case b of { True -> fst x; False -> 0 }
490 case chp of chp { I# -> ...chp... }
493 The reason it's a hack is because if you define mySeq=seq, the hack
496 Note [Desugaring seq (3)] cf Trac #2409
497 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
498 The isLocalId ensures that we don't turn
501 case True of True { ... }
502 which stupidly tries to bind the datacon 'True'.
505 mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr
506 mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
507 | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
508 = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
510 case_bndr = case arg1 of
511 Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
512 _ -> mkWildValBinder ty1
514 mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
516 mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
517 mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
521 %************************************************************************
523 \subsection[mkSelectorBind]{Make a selector bind}
525 %************************************************************************
527 This is used in various places to do with lazy patterns.
528 For each binder $b$ in the pattern, we create a binding:
530 b = case v of pat' -> b'
532 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
534 ToDo: making these bindings should really depend on whether there's
535 much work to be done per binding. If the pattern is complex, it
536 should be de-mangled once, into a tuple (and then selected from).
537 Otherwise the demangling can be in-line in the bindings (as here).
539 Boring! Boring! One error message per binder. The above ToDo is
540 even more helpful. Something very similar happens for pattern-bound
544 mkSelectorBinds :: LPat Id -- The pattern
545 -> CoreExpr -- Expression to which the pattern is bound
546 -> DsM [(Id,CoreExpr)]
548 mkSelectorBinds (L _ (VarPat v)) val_expr
549 = return [(v, val_expr)]
551 mkSelectorBinds pat val_expr
552 | isSingleton binders || is_simple_lpat pat = do
553 -- Given p = e, where p binds x,y
554 -- we are going to make
555 -- v = p (where v is fresh)
556 -- x = case v of p -> x
557 -- y = case v of p -> x
560 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
561 -- This does not matter after desugaring, but there's a subtle
562 -- issue with implicit parameters. Consider
564 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
565 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
566 -- does it get that type? So that when we abstract over it we get the
567 -- right top-level type (?i::Int) => ...)
569 -- So to get the type of 'v', use the pattern not the rhs. Often more
571 val_var <- newSysLocalDs (hsLPatType pat)
573 -- For the error message we make one error-app, to avoid duplication.
574 -- But we need it at different types... so we use coerce for that
575 err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat)
576 err_var <- newSysLocalDs unitTy
577 binds <- mapM (mk_bind val_var err_var) binders
578 return ( (val_var, val_expr) :
579 (err_var, err_expr) :
584 error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
585 tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
586 tuple_var <- newSysLocalDs tuple_ty
587 let mk_tup_bind binder
588 = (binder, mkTupleSelector local_binders binder tuple_var (Var tuple_var))
589 return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
591 binders = collectPatBinders pat
592 local_binders = map localiseId binders -- See Note [Localise pattern binders]
593 local_tuple = mkBigCoreVarTup binders
594 tuple_ty = exprType local_tuple
596 mk_bind scrut_var err_var bndr_var = do
597 -- (mk_bind sv err_var) generates
598 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
599 -- Remember, pat binds bv
600 rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
601 (Var bndr_var) error_expr
602 return (bndr_var, rhs_expr)
604 error_expr = mkCoerce co (Var err_var)
605 co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
607 is_simple_lpat p = is_simple_pat (unLoc p)
609 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
610 is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
611 is_simple_pat (VarPat _) = True
612 is_simple_pat (ParPat p) = is_simple_lpat p
613 is_simple_pat _ = False
615 is_triv_lpat p = is_triv_pat (unLoc p)
617 is_triv_pat (VarPat _) = True
618 is_triv_pat (WildPat _) = True
619 is_triv_pat (ParPat p) = is_triv_lpat p
620 is_triv_pat _ = False
624 Creating big tuples and their types for full Haskell expressions.
625 They work over *Ids*, and create tuples replete with their types,
626 which is whey they are not in HsUtils.
629 mkLHsPatTup :: [LPat Id] -> LPat Id
630 mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
631 mkLHsPatTup [lpat] = lpat
632 mkLHsPatTup lpats = L (getLoc (head lpats)) $
633 mkVanillaTuplePat lpats Boxed
635 mkLHsVarPatTup :: [Id] -> LPat Id
636 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
638 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
639 -- A vanilla tuple pattern simply gets its type from its sub-patterns
640 mkVanillaTuplePat pats box
641 = TuplePat pats box (mkTupleTy box (map hsLPatType pats))
643 -- The Big equivalents for the source tuple expressions
644 mkBigLHsVarTup :: [Id] -> LHsExpr Id
645 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
647 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
648 mkBigLHsTup = mkChunkified mkLHsTupleExpr
650 -- The Big equivalents for the source tuple patterns
651 mkBigLHsVarPatTup :: [Id] -> LPat Id
652 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
654 mkBigLHsPatTup :: [LPat Id] -> LPat Id
655 mkBigLHsPatTup = mkChunkified mkLHsPatTup
658 %************************************************************************
660 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
662 %************************************************************************
664 Generally, we handle pattern matching failure like this: let-bind a
665 fail-variable, and use that variable if the thing fails:
667 let fail.33 = error "Help"
678 If the case can't fail, then there'll be no mention of @fail.33@, and the
679 simplifier will later discard it.
682 If it can fail in only one way, then the simplifier will inline it.
685 Only if it is used more than once will the let-binding remain.
688 There's a problem when the result of the case expression is of
689 unboxed type. Then the type of @fail.33@ is unboxed too, and
690 there is every chance that someone will change the let into a case:
696 which is of course utterly wrong. Rather than drop the condition that
697 only boxed types can be let-bound, we just turn the fail into a function
698 for the primitive case:
700 let fail.33 :: Void -> Int#
701 fail.33 = \_ -> error "Help"
710 Now @fail.33@ is a function, so it can be let-bound.
713 mkFailurePair :: CoreExpr -- Result type of the whole case expression
714 -> DsM (CoreBind, -- Binds the newly-created fail variable
715 -- to \ _ -> expression
716 CoreExpr) -- Fail variable applied to realWorld#
717 -- See Note [Failure thunks and CPR]
719 = do { fail_fun_var <- newFailLocalDs (realWorldStatePrimTy `mkFunTy` ty)
720 ; fail_fun_arg <- newSysLocalDs realWorldStatePrimTy
721 ; return (NonRec fail_fun_var (Lam fail_fun_arg expr),
722 App (Var fail_fun_var) (Var realWorldPrimId)) }
727 Note [Failure thunks and CPR]
728 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
729 When we make a failure point we ensure that it
730 does not look like a thunk. Example:
732 let fail = \rw -> error "urk"
734 [] -> fail realWorld#
736 [] -> fail realWorld#
739 Reason: we know that a failure point is always a "join point" and is
740 entered at most once. Adding a dummy 'realWorld' token argument makes
741 it clear that sharing is not an issue. And that in turn makes it more
742 CPR-friendly. This matters a lot: if you don't get it right, you lose
743 the tail call property. For example, see Trac #3403.
746 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
747 mkOptTickBox Nothing e = return e
748 mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
750 mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
751 mkTickBox ix vars e = do
754 let tick | opt_Hpc = mkTickBoxOpId uq mod ix
755 | otherwise = mkBreakPointOpId uq mod ix
757 let occName = mkVarOcc "tick"
758 let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
759 let var = Id.mkLocalId name realWorldStatePrimTy
762 then return (Var tick)
764 let tickVar = Var tick
765 let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
766 let scrutApTy = App tickVar (Type tickType)
767 return (mkApps scrutApTy (map Var vars) :: Expr Id)
768 return $ Case scrut var ty [(DEFAULT,[],e)]
772 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
773 mkBinaryTickBox ixT ixF e = do
775 let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
776 falseBox <- mkTickBox ixF [] $ Var falseDataConId
777 trueBox <- mkTickBox ixT [] $ Var trueDataConId
778 return $ Case e bndr1 boolTy
779 [ (DataAlt falseDataCon, [], falseBox)
780 , (DataAlt trueDataCon, [], trueBox)