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.
16 mkDsLet, mkDsLets, mkDsApp, mkDsApps,
18 MatchResult(..), CanItFail(..),
19 cantFailMatchResult, alwaysFailMatchResult,
20 extractMatchResult, combineMatchResults,
21 adjustMatchResult, adjustMatchResultDs,
22 mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
23 matchCanFail, mkEvalMatchResult,
24 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
27 mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
28 mkIntExpr, mkCharExpr,
29 mkStringExpr, mkStringExprFS, mkIntegerExpr,
30 mkBuildExpr, mkFoldrExpr,
35 mkCoreVarTup, mkCoreTup, mkCoreVarTupTy, mkCoreTupTy,
36 mkBigCoreVarTup, mkBigCoreTup, mkBigCoreVarTupTy, mkBigCoreTupTy,
39 mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup,
40 mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
43 mkSelectorBinds, mkTupleSelector,
44 mkSmallTupleCase, mkTupleCase,
46 dsSyntaxTable, lookupEvidence,
48 selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
49 mkTickBox, mkOptTickBox, mkBinaryTickBox
52 #include "HsVersions.h"
54 import {-# SOURCE #-} Match ( matchSimply )
55 import {-# SOURCE #-} DsExpr( dsExpr )
88 infixl 4 `mkDsApp`, `mkDsApps`
93 %************************************************************************
97 %************************************************************************
100 dsSyntaxTable :: SyntaxTable Id
101 -> DsM ([CoreBind], -- Auxiliary bindings
102 [(Name,Id)]) -- Maps the standard name to its value
104 dsSyntaxTable rebound_ids = do
105 (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
106 return (concat binds_s, prs)
108 -- The cheapo special case can happen when we
109 -- make an intermediate HsDo when desugaring a RecStmt
110 mk_bind (std_name, HsVar id) = return ([], (std_name, id))
111 mk_bind (std_name, expr) = do
113 id <- newSysLocalDs (exprType rhs)
114 return ([NonRec id rhs], (std_name, id))
116 lookupEvidence :: [(Name, Id)] -> Name -> Id
117 lookupEvidence prs std_name
118 = assocDefault (mk_panic std_name) prs std_name
120 mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
124 %************************************************************************
126 \subsection{Building lets}
128 %************************************************************************
130 Use case, not let for unlifted types. The simplifier will turn some
134 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
135 mkDsLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant]
136 | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs)
137 = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
141 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
142 mkDsLets binds body = foldr mkDsLet body binds
145 mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr
146 -- Check the invariant that the arg of an App is ok-for-speculation if unlifted
147 -- See CoreSyn Note [CoreSyn let/app invariant]
148 mkDsApp fun (Type ty) = App fun (Type ty)
149 mkDsApp fun arg = mk_val_app fun arg arg_ty res_ty
151 (arg_ty, res_ty) = splitFunTy (exprType fun)
154 mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr
155 -- Slightly more efficient version of (foldl mkDsApp)
157 = go fun (exprType fun) args
160 go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
161 go fun fun_ty (arg : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
163 (arg_ty, res_ty) = splitFunTy fun_ty
165 mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
166 mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty
167 | f == seqId -- Note [Desugaring seq (1), (2)]
168 = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)]
170 case_bndr = case arg1 of
171 Var v1 -> v1 -- Note [Desugaring seq (2)]
174 mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant]
175 | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg
176 = App fun arg -- The vastly common case
178 mk_val_app fun arg arg_ty res_ty
179 = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))]
181 arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter,
182 -- because 'fun ' should not have a free wild-id
185 Note [Desugaring seq (1)] cf Trac #1031
186 ~~~~~~~~~~~~~~~~~~~~~~~~~
187 f x y = x `seq` (y `seq` (# x,y #))
189 The [CoreSyn let/app invariant] means that, other things being equal, because
190 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
192 f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
194 But that is bad for two reasons:
195 (a) we now evaluate y before x, and
196 (b) we can't bind v to an unboxed pair
198 Seq is very, very special! So we recognise it right here, and desugar to
199 case x of _ -> case y of _ -> (# x,y #)
201 Note [Desugaring seq (2)] cf Trac #2231
202 ~~~~~~~~~~~~~~~~~~~~~~~~~
204 let chp = case b of { True -> fst x; False -> 0 }
205 in chp `seq` ...chp...
206 Here the seq is designed to plug the space leak of retaining (snd x)
209 If we rely on the ordinary inlining of seq, we'll get
210 let chp = case b of { True -> fst x; False -> 0 }
211 case chp of _ { I# -> ...chp... }
213 But since chp is cheap, and the case is an alluring contet, we'll
214 inline chp into the case scrutinee. Now there is only one use of chp,
215 so we'll inline a second copy. Alas, we've now ruined the purpose of
216 the seq, by re-introducing the space leak:
217 case (case b of {True -> fst x; False -> 0}) of
218 I# _ -> ...case b of {True -> fst x; False -> 0}...
220 We can try to avoid doing this by ensuring that the binder-swap in the
221 case happens, so we get his at an early stage:
222 case chp of chp2 { I# -> ...chp2... }
223 But this is fragile. The real culprit is the source program. Perhpas we
224 should have said explicitly
225 let !chp2 = chp in ...chp2...
227 But that's painful. So the code here does a little hack to make seq
228 more robust: a saturated application of 'seq' is turned *directly* into
229 the case expression. So we desugar to:
230 let chp = case b of { True -> fst x; False -> 0 }
231 case chp of chp { I# -> ...chp... }
232 Notice the shadowing of the case binder! And now all is well.
234 The reason it's a hack is because if you define mySeq=seq, the hack
237 %************************************************************************
239 \subsection{ Selecting match variables}
241 %************************************************************************
243 We're about to match against some patterns. We want to make some
244 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
245 hand, which should indeed be bound to the pattern as a whole, then use it;
246 otherwise, make one up.
249 selectSimpleMatchVarL :: LPat Id -> DsM Id
250 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
252 -- (selectMatchVars ps tys) chooses variables of type tys
253 -- to use for matching ps against. If the pattern is a variable,
254 -- we try to use that, to save inventing lots of fresh variables.
256 -- OLD, but interesting note:
257 -- But even if it is a variable, its type might not match. Consider
259 -- T1 :: Int -> T Int
262 -- f :: T a -> a -> Int
263 -- f (T1 i) (x::Int) = x
264 -- f (T2 i) (y::a) = 0
265 -- Then we must not choose (x::Int) as the matching variable!
266 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
268 selectMatchVars :: [Pat Id] -> DsM [Id]
269 selectMatchVars ps = mapM selectMatchVar ps
271 selectMatchVar :: Pat Id -> DsM Id
272 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
273 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
274 selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
275 selectMatchVar (VarPat var) = return var
276 selectMatchVar (AsPat var _) = return (unLoc var)
277 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
278 -- OK, better make up one...
282 %************************************************************************
284 %* type synonym EquationInfo and access functions for its pieces *
286 %************************************************************************
287 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
289 The ``equation info'' used by @match@ is relatively complicated and
290 worthy of a type synonym and a few handy functions.
293 firstPat :: EquationInfo -> Pat Id
294 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
296 shiftEqns :: [EquationInfo] -> [EquationInfo]
297 -- Drop the first pattern in each equation
298 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
301 Functions on MatchResults
304 matchCanFail :: MatchResult -> Bool
305 matchCanFail (MatchResult CanFail _) = True
306 matchCanFail (MatchResult CantFail _) = False
308 alwaysFailMatchResult :: MatchResult
309 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
311 cantFailMatchResult :: CoreExpr -> MatchResult
312 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
314 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
315 extractMatchResult (MatchResult CantFail match_fn) _
316 = match_fn (error "It can't fail!")
318 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
319 (fail_bind, if_it_fails) <- mkFailurePair fail_expr
320 body <- match_fn if_it_fails
321 return (mkDsLet fail_bind body)
324 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
325 combineMatchResults (MatchResult CanFail body_fn1)
326 (MatchResult can_it_fail2 body_fn2)
327 = MatchResult can_it_fail2 body_fn
329 body_fn fail = do body2 <- body_fn2 fail
330 (fail_bind, duplicatable_expr) <- mkFailurePair body2
331 body1 <- body_fn1 duplicatable_expr
332 return (Let fail_bind body1)
334 combineMatchResults match_result1@(MatchResult CantFail _) _
337 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
338 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
339 = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
341 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
342 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
343 = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
345 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
347 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
349 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
350 wrapBind new old body -- Can deal with term variables *or* type variables
352 | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
353 | otherwise = Let (NonRec new (Var old)) body
355 seqVar :: Var -> CoreExpr -> CoreExpr
356 seqVar var body = Case (Var var) var (exprType body)
357 [(DEFAULT, [], body)]
359 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
360 mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind)
362 -- (mkViewMatchResult var' viewExpr var mr) makes the expression
363 -- let var' = viewExpr var in mr
364 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
365 mkViewMatchResult var' viewExpr var =
366 adjustMatchResult (mkDsLet (NonRec var' (mkDsApp viewExpr (Var var))))
368 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
369 mkEvalMatchResult var ty
370 = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
372 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
373 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
374 = MatchResult CanFail (\fail -> do body <- body_fn fail
375 return (mkIfThenElse pred_expr body fail))
377 mkCoPrimCaseMatchResult :: Id -- Scrutinee
378 -> Type -- Type of the case
379 -> [(Literal, MatchResult)] -- Alternatives
381 mkCoPrimCaseMatchResult var ty match_alts
382 = MatchResult CanFail mk_case
385 alts <- mapM (mk_alt fail) sorted_alts
386 return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
388 sorted_alts = sortWith fst match_alts -- Right order for a Case
389 mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail
390 return (LitAlt lit, [], body)
393 mkCoAlgCaseMatchResult :: Id -- Scrutinee
394 -> Type -- Type of exp
395 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
397 mkCoAlgCaseMatchResult var ty match_alts
398 | isNewTyCon tycon -- Newtype case; use a let
399 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
400 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
402 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
403 = MatchResult CanFail mk_parrCase
405 | otherwise -- Datatype case; use a case
406 = MatchResult fail_flag mk_case
408 tycon = dataConTyCon con1
409 -- [Interesting: becuase of GADTs, we can't rely on the type of
410 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
413 (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
414 arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
416 (tc, ty_args) = splitNewTyConApp var_ty
417 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
419 -- Stuff for data types
420 data_cons = tyConDataCons tycon
421 match_results = [match_result | (_,_,match_result) <- match_alts]
423 fail_flag | exhaustive_case
424 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
428 wild_var = mkWildId (idType var)
429 sorted_alts = sortWith get_tag match_alts
430 get_tag (con, _, _) = dataConTag con
431 mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
432 return (Case (Var var) wild_var ty (mk_default fail ++ alts))
434 mk_alt fail (con, args, MatchResult _ body_fn) = do
436 us <- newUniqueSupply
437 return (mkReboxingAlt (uniqsFromSupply us) con args body)
439 mk_default fail | exhaustive_case = []
440 | otherwise = [(DEFAULT, [], fail)]
442 un_mentioned_constructors
443 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
444 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
446 -- Stuff for parallel arrays
448 -- * the following is to desugar cases over fake constructors for
449 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
452 -- Concerning `isPArrFakeAlts':
454 -- * it is *not* sufficient to just check the type of the type
455 -- constructor, as we have to be careful not to confuse the real
456 -- representation of parallel arrays with the fake constructors;
457 -- moreover, a list of alternatives must not mix fake and real
458 -- constructors (this is checked earlier on)
460 -- FIXME: We actually go through the whole list and make sure that
461 -- either all or none of the constructors are fake parallel
462 -- array constructors. This is to spot equations that mix fake
463 -- constructors with the real representation defined in
464 -- `PrelPArr'. It would be nicer to spot this situation
465 -- earlier and raise a proper error message, but it can really
466 -- only happen in `PrelPArr' anyway.
468 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
469 isPArrFakeAlts ((dcon, _, _):alts) =
470 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
471 (True , True ) -> True
472 (False, False) -> False
473 _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
474 isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
476 mk_parrCase fail = do
477 lengthP <- dsLookupGlobalId lengthPName
479 return (Case (len lengthP) (mkWildId intTy) ty [alt])
481 elemTy = case splitTyConApp (idType var) of
482 (_, [elemTy]) -> elemTy
484 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
485 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
488 l <- newSysLocalDs intPrimTy
489 indexP <- dsLookupGlobalId indexPName
490 alts <- mapM (mkAlt indexP) sorted_alts
491 return (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
493 wild = mkWildId intPrimTy
494 dft = (DEFAULT, [], fail)
496 -- each alternative matches one array length (corresponding to one
497 -- fake array constructor), so the match is on a literal; each
498 -- alternative's body is extended by a local binding for each
499 -- constructor argument, which are bound to array elements starting
502 mkAlt indexP (con, args, MatchResult _ bodyFun) = do
504 return (LitAlt lit, [], mkDsLets binds body)
506 lit = MachInt $ toInteger (dataConSourceArity con)
507 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
509 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
513 %************************************************************************
515 \subsection{Desugarer's versions of some Core functions}
517 %************************************************************************
520 mkErrorAppDs :: Id -- The error function
521 -> Type -- Type to which it should be applied
522 -> String -- The error message string to pass
525 mkErrorAppDs err_id ty msg = do
526 src_loc <- getSrcSpanDs
528 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
529 core_msg = Lit (mkStringLit full_msg)
530 -- mkStringLit returns a result of type String#
531 return (mkApps (Var err_id) [Type ty, core_msg])
535 *************************************************************
537 \subsection{Making literals}
539 %************************************************************************
542 mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int
543 mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int
544 mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer
545 mkStringExpr :: String -> DsM CoreExpr -- Result :: String
546 mkStringExprFS :: FastString -> DsM CoreExpr -- Result :: String
548 mkIntExpr i = mkConApp intDataCon [mkIntLit i]
549 mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
552 | inIntRange i -- Small enough, so start from an Int
553 = do integer_id <- dsLookupGlobalId smallIntegerName
554 return (mkSmallIntegerLit integer_id i)
556 -- Special case for integral literals with a large magnitude:
557 -- They are transformed into an expression involving only smaller
558 -- integral literals. This improves constant folding.
560 | otherwise = do -- Big, so start from a string
561 plus_id <- dsLookupGlobalId plusIntegerName
562 times_id <- dsLookupGlobalId timesIntegerName
563 integer_id <- dsLookupGlobalId smallIntegerName
565 lit i = mkSmallIntegerLit integer_id i
566 plus a b = Var plus_id `App` a `App` b
567 times a b = Var times_id `App` a `App` b
569 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
570 horner :: Integer -> Integer -> CoreExpr
571 horner b i | abs q <= 1 = if r == 0 || r == i
573 else lit r `plus` lit (i-r)
574 | r == 0 = horner b q `times` lit b
575 | otherwise = lit r `plus` (horner b q `times` lit b)
577 (q,r) = i `quotRem` b
579 return (horner tARGET_MAX_INT i)
581 mkSmallIntegerLit :: Id -> Integer -> CoreExpr
582 mkSmallIntegerLit small_integer i = mkApps (Var small_integer) [mkIntLit i]
584 mkStringExpr str = mkStringExprFS (mkFastString str)
588 = return (mkNilExpr charTy)
591 = do let the_char = mkCharExpr (headFS str)
592 return (mkConsExpr charTy the_char (mkNilExpr charTy))
595 = do unpack_id <- dsLookupGlobalId unpackCStringName
596 return (App (Var unpack_id) (Lit (MachStr str)))
599 = do unpack_id <- dsLookupGlobalId unpackCStringUtf8Name
600 return (App (Var unpack_id) (Lit (MachStr str)))
604 safeChar c = ord c >= 1 && ord c <= 0x7F
608 %************************************************************************
610 \subsection[mkSelectorBind]{Make a selector bind}
612 %************************************************************************
614 This is used in various places to do with lazy patterns.
615 For each binder $b$ in the pattern, we create a binding:
617 b = case v of pat' -> b'
619 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
621 ToDo: making these bindings should really depend on whether there's
622 much work to be done per binding. If the pattern is complex, it
623 should be de-mangled once, into a tuple (and then selected from).
624 Otherwise the demangling can be in-line in the bindings (as here).
626 Boring! Boring! One error message per binder. The above ToDo is
627 even more helpful. Something very similar happens for pattern-bound
631 mkSelectorBinds :: LPat Id -- The pattern
632 -> CoreExpr -- Expression to which the pattern is bound
633 -> DsM [(Id,CoreExpr)]
635 mkSelectorBinds (L _ (VarPat v)) val_expr
636 = return [(v, val_expr)]
638 mkSelectorBinds pat val_expr
639 | isSingleton binders || is_simple_lpat pat = do
640 -- Given p = e, where p binds x,y
641 -- we are going to make
642 -- v = p (where v is fresh)
643 -- x = case v of p -> x
644 -- y = case v of p -> x
647 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
648 -- This does not matter after desugaring, but there's a subtle
649 -- issue with implicit parameters. Consider
651 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
652 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
653 -- does it get that type? So that when we abstract over it we get the
654 -- right top-level type (?i::Int) => ...)
656 -- So to get the type of 'v', use the pattern not the rhs. Often more
658 val_var <- newSysLocalDs (hsLPatType pat)
660 -- For the error message we make one error-app, to avoid duplication.
661 -- But we need it at different types... so we use coerce for that
662 err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat))
663 err_var <- newSysLocalDs unitTy
664 binds <- mapM (mk_bind val_var err_var) binders
665 return ( (val_var, val_expr) :
666 (err_var, err_expr) :
671 error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
672 tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
673 tuple_var <- newSysLocalDs tuple_ty
676 = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
677 return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
679 binders = collectPatBinders pat
680 local_tuple = mkBigCoreVarTup binders
681 tuple_ty = exprType local_tuple
683 mk_bind scrut_var err_var bndr_var = do
684 -- (mk_bind sv err_var) generates
685 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
686 -- Remember, pat binds bv
687 rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
688 (Var bndr_var) error_expr
689 return (bndr_var, rhs_expr)
691 error_expr = mkCoerce co (Var err_var)
692 co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
694 is_simple_lpat p = is_simple_pat (unLoc p)
696 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
697 is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
698 is_simple_pat (VarPat _) = True
699 is_simple_pat (ParPat p) = is_simple_lpat p
700 is_simple_pat _ = False
702 is_triv_lpat p = is_triv_pat (unLoc p)
704 is_triv_pat (VarPat _) = True
705 is_triv_pat (WildPat _) = True
706 is_triv_pat (ParPat p) = is_triv_lpat p
707 is_triv_pat _ = False
711 %************************************************************************
715 %************************************************************************
717 Nesting policy. Better a 2-tuple of 10-tuples (3 objects) than
718 a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big.
722 mkBigTuple :: ([a] -> a) -> [a] -> a
723 mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
725 -- Each sub-list is short enough to fit in a tuple
726 mk_big_tuple [as] = small_tuple as
727 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
729 chunkify :: [a] -> [[a]]
730 -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
731 -- But there may be more than mAX_TUPLE_SIZE sub-lists
733 | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
734 | otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
738 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
742 Creating tuples and their types for Core expressions
744 @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
746 * If it has only one element, it is the identity function.
748 * If there are more elements than a big tuple can have, it nests
753 -- Small tuples: build exactly the specified tuple
754 mkCoreVarTup :: [Id] -> CoreExpr
755 mkCoreVarTup ids = mkCoreTup (map Var ids)
757 mkCoreVarTupTy :: [Id] -> Type
758 mkCoreVarTupTy ids = mkCoreTupTy (map idType ids)
761 mkCoreTup :: [CoreExpr] -> CoreExpr
762 mkCoreTup [] = Var unitDataConId
764 mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
765 (map (Type . exprType) cs ++ cs)
767 mkCoreTupTy :: [Type] -> Type
768 mkCoreTupTy [ty] = ty
769 mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
774 mkBigCoreVarTup :: [Id] -> CoreExpr
775 mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
777 mkBigCoreVarTupTy :: [Id] -> Type
778 mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
781 mkBigCoreTup :: [CoreExpr] -> CoreExpr
782 mkBigCoreTup = mkBigTuple mkCoreTup
784 mkBigCoreTupTy :: [Type] -> Type
785 mkBigCoreTupTy = mkBigTuple mkCoreTupTy
789 Creating tuples and their types for full Haskell expressions
793 -- Smart constructors for source tuple expressions
794 mkLHsVarTup :: [Id] -> LHsExpr Id
795 mkLHsVarTup ids = mkLHsTup (map nlHsVar ids)
797 mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
798 mkLHsTup [] = nlHsVar unitDataConId
799 mkLHsTup [lexp] = lexp
800 mkLHsTup lexps = L (getLoc (head lexps)) $
801 ExplicitTuple lexps Boxed
803 -- Smart constructors for source tuple patterns
804 mkLHsVarPatTup :: [Id] -> LPat Id
805 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
807 mkLHsPatTup :: [LPat Id] -> LPat Id
808 mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
809 mkLHsPatTup [lpat] = lpat
810 mkLHsPatTup lpats = L (getLoc (head lpats)) $
811 mkVanillaTuplePat lpats Boxed
813 -- The Big equivalents for the source tuple expressions
814 mkBigLHsVarTup :: [Id] -> LHsExpr Id
815 mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
817 mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
818 mkBigLHsTup = mkBigTuple mkLHsTup
821 -- The Big equivalents for the source tuple patterns
822 mkBigLHsVarPatTup :: [Id] -> LPat Id
823 mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
825 mkBigLHsPatTup :: [LPat Id] -> LPat Id
826 mkBigLHsPatTup = mkBigTuple mkLHsPatTup
830 @mkTupleSelector@ builds a selector which scrutises the given
831 expression and extracts the one name from the list given.
832 If you want the no-shadowing rule to apply, the caller
833 is responsible for making sure that none of these names
836 If there is just one id in the ``tuple'', then the selector is
839 If it's big, it does nesting
840 mkTupleSelector [a,b,c,d] b v e
842 (p,q) -> case p of p {
844 We use 'tpl' vars for the p,q, since shadowing does not matter.
846 In fact, it's more convenient to generate it innermost first, getting
853 mkTupleSelector :: [Id] -- The tuple args
854 -> Id -- The selected one
855 -> Id -- A variable of the same type as the scrutinee
856 -> CoreExpr -- Scrutinee
859 mkTupleSelector vars the_var scrut_var scrut
860 = mk_tup_sel (chunkify vars) the_var
862 mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
863 mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
864 mk_tup_sel (chunkify tpl_vs) tpl_v
866 tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
867 tpl_vs = mkTemplateLocals tpl_tys
868 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
872 A generalization of @mkTupleSelector@, allowing the body
873 of the case to be an arbitrary expression.
875 If the tuple is big, it is nested:
877 mkTupleCase uniqs [a,b,c,d] body v e
878 = case e of v { (p,q) ->
879 case p of p { (a,b) ->
880 case q of q { (c,d) ->
883 To avoid shadowing, we use uniqs to invent new variables p,q.
885 ToDo: eliminate cases where none of the variables are needed.
889 :: UniqSupply -- for inventing names of intermediate variables
890 -> [Id] -- the tuple args
891 -> CoreExpr -- body of the case
892 -> Id -- a variable of the same type as the scrutinee
893 -> CoreExpr -- scrutinee
896 mkTupleCase uniqs vars body scrut_var scrut
897 = mk_tuple_case uniqs (chunkify vars) body
899 -- This is the case where don't need any nesting
900 mk_tuple_case _ [vars] body
901 = mkSmallTupleCase vars body scrut_var scrut
903 -- This is the case where we must make nest tuples at least once
904 mk_tuple_case us vars_s body
905 = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
906 in mk_tuple_case us' (chunkify vars') body'
908 one_tuple_case chunk_vars (us, vs, body)
909 = let (us1, us2) = splitUniqSupply us
910 scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1)
911 (mkCoreTupTy (map idType chunk_vars))
912 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
913 in (us2, scrut_var:vs, body')
916 The same, but with a tuple small enough not to need nesting.
920 :: [Id] -- the tuple args
921 -> CoreExpr -- body of the case
922 -> Id -- a variable of the same type as the scrutinee
923 -> CoreExpr -- scrutinee
926 mkSmallTupleCase [var] body _scrut_var scrut
927 = bindNonRec var scrut body
928 mkSmallTupleCase vars body scrut_var scrut
929 -- One branch no refinement?
930 = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
933 %************************************************************************
935 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
937 %************************************************************************
939 Call the constructor Ids when building explicit lists, so that they
940 interact well with rules.
943 mkNilExpr :: Type -> CoreExpr
944 mkNilExpr ty = mkConApp nilDataCon [Type ty]
946 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
947 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
949 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
950 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
952 mkFoldrExpr :: PostTcType -> PostTcType -> CoreExpr -> CoreExpr -> CoreExpr -> DsM CoreExpr
953 mkFoldrExpr elt_ty result_ty c n list = do
954 foldr_id <- dsLookupGlobalId foldrName
955 return (Var foldr_id `App` Type elt_ty
961 mkBuildExpr :: Type -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr
962 mkBuildExpr elt_ty mk_build_inside = do
963 [n_tyvar] <- newTyVarsDs [alphaTyVar]
964 let n_ty = mkTyVarTy n_tyvar
965 c_ty = mkFunTys [elt_ty, n_ty] n_ty
966 [c, n] <- newSysLocalsDs [c_ty, n_ty]
968 build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
970 build_id <- dsLookupGlobalId buildName
971 return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
973 mkCoreSel :: [Id] -- The tuple args
974 -> Id -- The selected one
975 -> Id -- A variable of the same type as the scrutinee
976 -> CoreExpr -- Scrutinee
979 -- mkCoreSel [x] x v e
981 mkCoreSel [var] should_be_the_same_var _ scrut
982 = ASSERT(var == should_be_the_same_var)
985 -- mkCoreSel [x,y,z] x v e
986 -- ===> case e of v { (x,y,z) -> x
987 mkCoreSel vars the_var scrut_var scrut
988 = ASSERT( notNull vars )
989 Case scrut scrut_var (idType the_var)
990 [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
993 %************************************************************************
995 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
997 %************************************************************************
999 Generally, we handle pattern matching failure like this: let-bind a
1000 fail-variable, and use that variable if the thing fails:
1002 let fail.33 = error "Help"
1013 If the case can't fail, then there'll be no mention of @fail.33@, and the
1014 simplifier will later discard it.
1017 If it can fail in only one way, then the simplifier will inline it.
1020 Only if it is used more than once will the let-binding remain.
1023 There's a problem when the result of the case expression is of
1024 unboxed type. Then the type of @fail.33@ is unboxed too, and
1025 there is every chance that someone will change the let into a case:
1027 case error "Help" of
1028 fail.33 -> case ....
1031 which is of course utterly wrong. Rather than drop the condition that
1032 only boxed types can be let-bound, we just turn the fail into a function
1033 for the primitive case:
1035 let fail.33 :: Void -> Int#
1036 fail.33 = \_ -> error "Help"
1045 Now @fail.33@ is a function, so it can be let-bound.
1048 mkFailurePair :: CoreExpr -- Result type of the whole case expression
1049 -> DsM (CoreBind, -- Binds the newly-created fail variable
1050 -- to either the expression or \ _ -> expression
1051 CoreExpr) -- Either the fail variable, or fail variable
1052 -- applied to unit tuple
1054 | isUnLiftedType ty = do
1055 fail_fun_var <- newFailLocalDs (unitTy `mkFunTy` ty)
1056 fail_fun_arg <- newSysLocalDs unitTy
1057 return (NonRec fail_fun_var (Lam fail_fun_arg expr),
1058 App (Var fail_fun_var) (Var unitDataConId))
1061 fail_var <- newFailLocalDs ty
1062 return (NonRec fail_var expr, Var fail_var)
1068 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
1069 mkOptTickBox Nothing e = return e
1070 mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
1072 mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
1073 mkTickBox ix vars e = do
1076 let tick | opt_Hpc = mkTickBoxOpId uq mod ix
1077 | otherwise = mkBreakPointOpId uq mod ix
1079 let occName = mkVarOcc "tick"
1080 let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
1081 let var = Id.mkLocalId name realWorldStatePrimTy
1084 then return (Var tick)
1086 let tickVar = Var tick
1087 let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
1088 let scrutApTy = App tickVar (Type tickType)
1089 return (mkApps scrutApTy (map Var vars) :: Expr Id)
1090 return $ Case scrut var ty [(DEFAULT,[],e)]
1094 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
1095 mkBinaryTickBox ixT ixF e = do
1097 let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
1098 falseBox <- mkTickBox ixF [] $ Var falseDataConId
1099 trueBox <- mkTickBox ixT [] $ Var trueDataConId
1100 return $ Case e bndr1 boolTy
1101 [ (DataAlt falseDataCon, [], falseBox)
1102 , (DataAlt trueDataCon, [], trueBox)