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 )
79 %************************************************************************
83 %************************************************************************
86 dsSyntaxTable :: SyntaxTable Id
87 -> DsM ([CoreBind], -- Auxiliary bindings
88 [(Name,Id)]) -- Maps the standard name to its value
90 dsSyntaxTable rebound_ids = do
91 (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
92 return (concat binds_s, prs)
94 -- The cheapo special case can happen when we
95 -- make an intermediate HsDo when desugaring a RecStmt
96 mk_bind (std_name, HsVar id) = return ([], (std_name, id))
97 mk_bind (std_name, expr) = do
99 id <- newSysLocalDs (exprType rhs)
100 return ([NonRec id rhs], (std_name, id))
102 lookupEvidence :: [(Name, Id)] -> Name -> Id
103 lookupEvidence prs std_name
104 = assocDefault (mk_panic std_name) prs std_name
106 mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
109 %************************************************************************
111 \subsection{ Selecting match variables}
113 %************************************************************************
115 We're about to match against some patterns. We want to make some
116 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
117 hand, which should indeed be bound to the pattern as a whole, then use it;
118 otherwise, make one up.
121 selectSimpleMatchVarL :: LPat Id -> DsM Id
122 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
124 -- (selectMatchVars ps tys) chooses variables of type tys
125 -- to use for matching ps against. If the pattern is a variable,
126 -- we try to use that, to save inventing lots of fresh variables.
128 -- OLD, but interesting note:
129 -- But even if it is a variable, its type might not match. Consider
131 -- T1 :: Int -> T Int
134 -- f :: T a -> a -> Int
135 -- f (T1 i) (x::Int) = x
136 -- f (T2 i) (y::a) = 0
137 -- Then we must not choose (x::Int) as the matching variable!
138 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
140 selectMatchVars :: [Pat Id] -> DsM [Id]
141 selectMatchVars ps = mapM selectMatchVar ps
143 selectMatchVar :: Pat Id -> DsM Id
144 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
145 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
146 selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
147 selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders]
148 selectMatchVar (AsPat var _) = return (unLoc var)
149 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
150 -- OK, better make up one...
153 Note [Localise pattern binders]
154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
155 Consider module M where
157 After renaming it looks like
161 We don't generalise, since it's a pattern binding, monomorphic, etc,
162 so after desugaring we may get something like
163 M.a = case e of (v:_) ->
164 case v of Just M.a -> M.a
165 Notice the "M.a" in the pattern; after all, it was in the original
166 pattern. However, after optimisation those pattern binders can become
167 let-binders, and then end up floated to top level. They have a
168 different *unique* by then (the simplifier is good about maintaining
169 proper scoping), but it's BAD to have two top-level bindings with the
170 External Name M.a, because that turns into two linker symbols for M.a.
171 It's quite rare for this to actually *happen* -- the only case I know
172 of is tc003 compiled with the 'hpc' way -- but that only makes it
173 all the more annoying.
175 To avoid this, we craftily call 'localiseId' in the desugarer, which
176 simply turns the External Name for the Id into an Internal one, but
177 doesn't change the unique. So the desugarer produces this:
178 M.a{r8} = case e of (v:_) ->
179 case v of Just a{r8} -> M.a{r8}
180 The unique is still 'r8', but the binding site in the pattern
181 is now an Internal Name. Now the simplifier's usual mechanisms
182 will propagate that Name to all the occurrence sites, as well as
183 un-shadowing it, so we'll get
184 M.a{r8} = case e of (v:_) ->
185 case v of Just a{s77} -> a{s77}
186 In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
187 runs on the output of the desugarer, so all is well by the end of
191 %************************************************************************
193 %* type synonym EquationInfo and access functions for its pieces *
195 %************************************************************************
196 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
198 The ``equation info'' used by @match@ is relatively complicated and
199 worthy of a type synonym and a few handy functions.
202 firstPat :: EquationInfo -> Pat Id
203 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
205 shiftEqns :: [EquationInfo] -> [EquationInfo]
206 -- Drop the first pattern in each equation
207 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
210 Functions on MatchResults
213 matchCanFail :: MatchResult -> Bool
214 matchCanFail (MatchResult CanFail _) = True
215 matchCanFail (MatchResult CantFail _) = False
217 alwaysFailMatchResult :: MatchResult
218 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
220 cantFailMatchResult :: CoreExpr -> MatchResult
221 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
223 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
224 extractMatchResult (MatchResult CantFail match_fn) _
225 = match_fn (error "It can't fail!")
227 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
228 (fail_bind, if_it_fails) <- mkFailurePair fail_expr
229 body <- match_fn if_it_fails
230 return (mkCoreLet fail_bind body)
233 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
234 combineMatchResults (MatchResult CanFail body_fn1)
235 (MatchResult can_it_fail2 body_fn2)
236 = MatchResult can_it_fail2 body_fn
238 body_fn fail = do body2 <- body_fn2 fail
239 (fail_bind, duplicatable_expr) <- mkFailurePair body2
240 body1 <- body_fn1 duplicatable_expr
241 return (Let fail_bind body1)
243 combineMatchResults match_result1@(MatchResult CantFail _) _
246 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
247 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
248 = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
250 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
251 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
252 = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
254 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
256 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
258 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
259 wrapBind new old body -- Can deal with term variables *or* type variables
261 | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body
262 | otherwise = Let (NonRec new (Var old)) body
264 seqVar :: Var -> CoreExpr -> CoreExpr
265 seqVar var body = Case (Var var) var (exprType body)
266 [(DEFAULT, [], body)]
268 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
269 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
271 -- (mkViewMatchResult var' viewExpr var mr) makes the expression
272 -- let var' = viewExpr var in mr
273 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
274 mkViewMatchResult var' viewExpr var =
275 adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
277 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
278 mkEvalMatchResult var ty
279 = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
281 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
282 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
283 = MatchResult CanFail (\fail -> do body <- body_fn fail
284 return (mkIfThenElse pred_expr body fail))
286 mkCoPrimCaseMatchResult :: Id -- Scrutinee
287 -> Type -- Type of the case
288 -> [(Literal, MatchResult)] -- Alternatives
290 mkCoPrimCaseMatchResult var ty match_alts
291 = MatchResult CanFail mk_case
294 alts <- mapM (mk_alt fail) sorted_alts
295 return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
297 sorted_alts = sortWith fst match_alts -- Right order for a Case
298 mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail
299 return (LitAlt lit, [], body)
302 mkCoAlgCaseMatchResult :: Id -- Scrutinee
303 -> Type -- Type of exp
304 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
306 mkCoAlgCaseMatchResult var ty match_alts
307 | isNewTyCon tycon -- Newtype case; use a let
308 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
309 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
311 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
312 = MatchResult CanFail mk_parrCase
314 | otherwise -- Datatype case; use a case
315 = MatchResult fail_flag mk_case
317 tycon = dataConTyCon con1
318 -- [Interesting: becuase of GADTs, we can't rely on the type of
319 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
322 (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
323 arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
325 (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
326 -- (not that splitTyConApp does, these days)
327 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
329 -- Stuff for data types
330 data_cons = tyConDataCons tycon
331 match_results = [match_result | (_,_,match_result) <- match_alts]
333 fail_flag | exhaustive_case
334 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
338 sorted_alts = sortWith get_tag match_alts
339 get_tag (con, _, _) = dataConTag con
340 mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
341 return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
343 mk_alt fail (con, args, MatchResult _ body_fn) = do
345 us <- newUniqueSupply
346 return (mkReboxingAlt (uniqsFromSupply us) con args body)
348 mk_default fail | exhaustive_case = []
349 | otherwise = [(DEFAULT, [], fail)]
351 un_mentioned_constructors
352 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
353 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
355 -- Stuff for parallel arrays
357 -- * the following is to desugar cases over fake constructors for
358 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
361 -- Concerning `isPArrFakeAlts':
363 -- * it is *not* sufficient to just check the type of the type
364 -- constructor, as we have to be careful not to confuse the real
365 -- representation of parallel arrays with the fake constructors;
366 -- moreover, a list of alternatives must not mix fake and real
367 -- constructors (this is checked earlier on)
369 -- FIXME: We actually go through the whole list and make sure that
370 -- either all or none of the constructors are fake parallel
371 -- array constructors. This is to spot equations that mix fake
372 -- constructors with the real representation defined in
373 -- `PrelPArr'. It would be nicer to spot this situation
374 -- earlier and raise a proper error message, but it can really
375 -- only happen in `PrelPArr' anyway.
377 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
378 isPArrFakeAlts ((dcon, _, _):alts) =
379 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
380 (True , True ) -> True
381 (False, False) -> False
382 _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
383 isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
385 mk_parrCase fail = do
386 lengthP <- dsLookupDPHId lengthPName
388 return (mkWildCase (len lengthP) intTy ty [alt])
390 elemTy = case splitTyConApp (idType var) of
391 (_, [elemTy]) -> elemTy
393 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
394 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
397 l <- newSysLocalDs intPrimTy
398 indexP <- dsLookupDPHId indexPName
399 alts <- mapM (mkAlt indexP) sorted_alts
400 return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
402 dft = (DEFAULT, [], fail)
404 -- each alternative matches one array length (corresponding to one
405 -- fake array constructor), so the match is on a literal; each
406 -- alternative's body is extended by a local binding for each
407 -- constructor argument, which are bound to array elements starting
410 mkAlt indexP (con, args, MatchResult _ bodyFun) = do
412 return (LitAlt lit, [], mkCoreLets binds body)
414 lit = MachInt $ toInteger (dataConSourceArity con)
415 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
417 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
420 %************************************************************************
422 \subsection{Desugarer's versions of some Core functions}
424 %************************************************************************
427 mkErrorAppDs :: Id -- The error function
428 -> Type -- Type to which it should be applied
429 -> SDoc -- The error message string to pass
432 mkErrorAppDs err_id ty msg = do
433 src_loc <- getSrcSpanDs
435 full_msg = showSDoc (hcat [ppr src_loc, text "|", msg])
436 core_msg = Lit (mkMachString full_msg)
437 -- mkMachString returns a result of type String#
438 return (mkApps (Var err_id) [Type ty, core_msg])
441 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
443 Note [Desugaring seq (1)] cf Trac #1031
444 ~~~~~~~~~~~~~~~~~~~~~~~~~
445 f x y = x `seq` (y `seq` (# x,y #))
447 The [CoreSyn let/app invariant] means that, other things being equal, because
448 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
450 f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
452 But that is bad for two reasons:
453 (a) we now evaluate y before x, and
454 (b) we can't bind v to an unboxed pair
456 Seq is very, very special! So we recognise it right here, and desugar to
457 case x of _ -> case y of _ -> (# x,y #)
459 Note [Desugaring seq (2)] cf Trac #2273
460 ~~~~~~~~~~~~~~~~~~~~~~~~~
462 let chp = case b of { True -> fst x; False -> 0 }
463 in chp `seq` ...chp...
464 Here the seq is designed to plug the space leak of retaining (snd x)
467 If we rely on the ordinary inlining of seq, we'll get
468 let chp = case b of { True -> fst x; False -> 0 }
469 case chp of _ { I# -> ...chp... }
471 But since chp is cheap, and the case is an alluring contet, we'll
472 inline chp into the case scrutinee. Now there is only one use of chp,
473 so we'll inline a second copy. Alas, we've now ruined the purpose of
474 the seq, by re-introducing the space leak:
475 case (case b of {True -> fst x; False -> 0}) of
476 I# _ -> ...case b of {True -> fst x; False -> 0}...
478 We can try to avoid doing this by ensuring that the binder-swap in the
479 case happens, so we get his at an early stage:
480 case chp of chp2 { I# -> ...chp2... }
481 But this is fragile. The real culprit is the source program. Perhaps we
482 should have said explicitly
483 let !chp2 = chp in ...chp2...
485 But that's painful. So the code here does a little hack to make seq
486 more robust: a saturated application of 'seq' is turned *directly* into
487 the case expression, thus:
488 x `seq` e2 ==> case x of x -> e2 -- Note shadowing!
489 e1 `seq` e2 ==> case x of _ -> e2
491 So we desugar our example to:
492 let chp = case b of { True -> fst x; False -> 0 }
493 case chp of chp { I# -> ...chp... }
496 The reason it's a hack is because if you define mySeq=seq, the hack
499 Note [Desugaring seq (3)] cf Trac #2409
500 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
501 The isLocalId ensures that we don't turn
504 case True of True { ... }
505 which stupidly tries to bind the datacon 'True'.
508 mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr
509 mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
510 | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]
511 = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
513 case_bndr = case arg1 of
514 Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
515 _ -> mkWildValBinder ty1
517 mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
519 mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
520 mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
524 %************************************************************************
526 \subsection[mkSelectorBind]{Make a selector bind}
528 %************************************************************************
530 This is used in various places to do with lazy patterns.
531 For each binder $b$ in the pattern, we create a binding:
533 b = case v of pat' -> b'
535 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
537 ToDo: making these bindings should really depend on whether there's
538 much work to be done per binding. If the pattern is complex, it
539 should be de-mangled once, into a tuple (and then selected from).
540 Otherwise the demangling can be in-line in the bindings (as here).
542 Boring! Boring! One error message per binder. The above ToDo is
543 even more helpful. Something very similar happens for pattern-bound
547 mkSelectorBinds :: LPat Id -- The pattern
548 -> CoreExpr -- Expression to which the pattern is bound
549 -> DsM [(Id,CoreExpr)]
551 mkSelectorBinds (L _ (VarPat v)) val_expr
552 = return [(v, val_expr)]
554 mkSelectorBinds pat val_expr
555 | isSingleton binders || is_simple_lpat pat = do
556 -- Given p = e, where p binds x,y
557 -- we are going to make
558 -- v = p (where v is fresh)
559 -- x = case v of p -> x
560 -- y = case v of p -> x
563 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
564 -- This does not matter after desugaring, but there's a subtle
565 -- issue with implicit parameters. Consider
567 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
568 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
569 -- does it get that type? So that when we abstract over it we get the
570 -- right top-level type (?i::Int) => ...)
572 -- So to get the type of 'v', use the pattern not the rhs. Often more
574 val_var <- newSysLocalDs (hsLPatType pat)
576 -- For the error message we make one error-app, to avoid duplication.
577 -- But we need it at different types... so we use coerce for that
578 err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat)
579 err_var <- newSysLocalDs unitTy
580 binds <- mapM (mk_bind val_var err_var) binders
581 return ( (val_var, val_expr) :
582 (err_var, err_expr) :
587 error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
588 tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
589 tuple_var <- newSysLocalDs tuple_ty
590 let mk_tup_bind binder
591 = (binder, mkTupleSelector local_binders binder tuple_var (Var tuple_var))
592 return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
594 binders = collectPatBinders pat
595 local_binders = map localiseId binders -- See Note [Localise pattern binders]
596 local_tuple = mkBigCoreVarTup binders
597 tuple_ty = exprType local_tuple
599 mk_bind scrut_var err_var bndr_var = do
600 -- (mk_bind sv err_var) generates
601 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
602 -- Remember, pat binds bv
603 rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
604 (Var bndr_var) error_expr
605 return (bndr_var, rhs_expr)
607 error_expr = mkCoerce co (Var err_var)
608 co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
610 is_simple_lpat p = is_simple_pat (unLoc p)
612 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
613 is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
614 is_simple_pat (VarPat _) = True
615 is_simple_pat (ParPat p) = is_simple_lpat p
616 is_simple_pat _ = False
618 is_triv_lpat p = is_triv_pat (unLoc p)
620 is_triv_pat (VarPat _) = True
621 is_triv_pat (WildPat _) = True
622 is_triv_pat (ParPat p) = is_triv_lpat p
623 is_triv_pat _ = False
627 Creating big tuples and their types for full Haskell expressions.
628 They work over *Ids*, and create tuples replete with their types,
629 which is whey they are not in HsUtils.
632 mkLHsPatTup :: [LPat Id] -> LPat Id
633 mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
634 mkLHsPatTup [lpat] = lpat
635 mkLHsPatTup lpats = L (getLoc (head lpats)) $
636 mkVanillaTuplePat lpats Boxed
638 mkLHsVarPatTup :: [Id] -> LPat Id
639 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
641 mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
642 -- A vanilla tuple pattern simply gets its type from its sub-patterns
643 mkVanillaTuplePat pats box
644 = TuplePat pats box (mkTupleTy box (map hsLPatType pats))
646 -- The Big equivalents for the source tuple expressions
647 mkBigLHsVarTup :: [Id] -> LHsExpr Id
648 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
650 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
651 mkBigLHsTup = mkChunkified mkLHsTupleExpr
653 -- The Big equivalents for the source tuple patterns
654 mkBigLHsVarPatTup :: [Id] -> LPat Id
655 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
657 mkBigLHsPatTup :: [LPat Id] -> LPat Id
658 mkBigLHsPatTup = mkChunkified mkLHsPatTup
661 %************************************************************************
663 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
665 %************************************************************************
667 Generally, we handle pattern matching failure like this: let-bind a
668 fail-variable, and use that variable if the thing fails:
670 let fail.33 = error "Help"
681 If the case can't fail, then there'll be no mention of @fail.33@, and the
682 simplifier will later discard it.
685 If it can fail in only one way, then the simplifier will inline it.
688 Only if it is used more than once will the let-binding remain.
691 There's a problem when the result of the case expression is of
692 unboxed type. Then the type of @fail.33@ is unboxed too, and
693 there is every chance that someone will change the let into a case:
699 which is of course utterly wrong. Rather than drop the condition that
700 only boxed types can be let-bound, we just turn the fail into a function
701 for the primitive case:
703 let fail.33 :: Void -> Int#
704 fail.33 = \_ -> error "Help"
713 Now @fail.33@ is a function, so it can be let-bound.
716 mkFailurePair :: CoreExpr -- Result type of the whole case expression
717 -> DsM (CoreBind, -- Binds the newly-created fail variable
718 -- to \ _ -> expression
719 CoreExpr) -- Fail variable applied to realWorld#
720 -- See Note [Failure thunks and CPR]
722 = do { fail_fun_var <- newFailLocalDs (realWorldStatePrimTy `mkFunTy` ty)
723 ; fail_fun_arg <- newSysLocalDs realWorldStatePrimTy
724 ; return (NonRec fail_fun_var (Lam fail_fun_arg expr),
725 App (Var fail_fun_var) (Var realWorldPrimId)) }
730 Note [Failure thunks and CPR]
731 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
732 When we make a failure point we ensure that it
733 does not look like a thunk. Example:
735 let fail = \rw -> error "urk"
737 [] -> fail realWorld#
739 [] -> fail realWorld#
742 Reason: we know that a failure point is always a "join point" and is
743 entered at most once. Adding a dummy 'realWorld' token argument makes
744 it clear that sharing is not an issue. And that in turn makes it more
745 CPR-friendly. This matters a lot: if you don't get it right, you lose
746 the tail call property. For example, see Trac #3403.
749 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
750 mkOptTickBox Nothing e = return e
751 mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
753 mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
754 mkTickBox ix vars e = do
757 let tick | opt_Hpc = mkTickBoxOpId uq mod ix
758 | otherwise = mkBreakPointOpId uq mod ix
760 let occName = mkVarOcc "tick"
761 let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
762 let var = Id.mkLocalId name realWorldStatePrimTy
765 then return (Var tick)
767 let tickVar = Var tick
768 let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
769 let scrutApTy = App tickVar (Type tickType)
770 return (mkApps scrutApTy (map Var vars) :: Expr Id)
771 return $ Case scrut var ty [(DEFAULT,[],e)]
775 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
776 mkBinaryTickBox ixT ixF e = do
778 let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
779 falseBox <- mkTickBox ixF [] $ Var falseDataConId
780 trueBox <- mkTickBox ixT [] $ Var trueDataConId
781 return $ Case e bndr1 boolTy
782 [ (DataAlt falseDataCon, [], falseBox)
783 , (DataAlt trueDataCon, [], trueBox)