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.
12 -- The above warning supression flag is a temporary kludge.
13 -- While working on this module you are encouraged to remove it and fix
14 -- any warnings in the module. See
15 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 mkDsLet, mkDsLets, mkDsApp, mkDsApps,
24 MatchResult(..), CanItFail(..),
25 cantFailMatchResult, alwaysFailMatchResult,
26 extractMatchResult, combineMatchResults,
27 adjustMatchResult, adjustMatchResultDs,
28 mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
29 matchCanFail, mkEvalMatchResult,
30 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
33 mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
34 mkIntExpr, mkCharExpr,
35 mkStringExpr, mkStringExprFS, mkIntegerExpr,
37 mkSelectorBinds, mkTupleExpr, mkTupleSelector,
38 mkTupleType, mkTupleCase, mkBigCoreTup,
39 mkCoreTup, mkCoreTupTy, seqVar,
41 dsSyntaxTable, lookupEvidence,
43 selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
44 mkTickBox, mkOptTickBox, mkBinaryTickBox
47 #include "HsVersions.h"
49 import {-# SOURCE #-} Match ( matchSimply )
50 import {-# SOURCE #-} DsExpr( dsExpr )
83 infixl 4 `mkDsApp`, `mkDsApps`
88 %************************************************************************
92 %************************************************************************
95 dsSyntaxTable :: SyntaxTable Id
96 -> DsM ([CoreBind], -- Auxiliary bindings
97 [(Name,Id)]) -- Maps the standard name to its value
99 dsSyntaxTable rebound_ids
100 = mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
101 return (concat binds_s, prs)
103 -- The cheapo special case can happen when we
104 -- make an intermediate HsDo when desugaring a RecStmt
105 mk_bind (std_name, HsVar id) = return ([], (std_name, id))
106 mk_bind (std_name, expr)
107 = dsExpr expr `thenDs` \ rhs ->
108 newSysLocalDs (exprType rhs) `thenDs` \ id ->
109 return ([NonRec id rhs], (std_name, id))
111 lookupEvidence :: [(Name, Id)] -> Name -> Id
112 lookupEvidence prs std_name
113 = assocDefault (mk_panic std_name) prs std_name
115 mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
119 %************************************************************************
121 \subsection{Building lets}
123 %************************************************************************
125 Use case, not let for unlifted types. The simplifier will turn some
129 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
130 mkDsLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant]
131 | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs)
132 = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
136 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
137 mkDsLets binds body = foldr mkDsLet body binds
140 mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr
141 -- Check the invariant that the arg of an App is ok-for-speculation if unlifted
142 -- See CoreSyn Note [CoreSyn let/app invariant]
143 mkDsApp fun (Type ty) = App fun (Type ty)
144 mkDsApp fun arg = mk_val_app fun arg arg_ty res_ty
146 (arg_ty, res_ty) = splitFunTy (exprType fun)
149 mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr
150 -- Slightly more efficient version of (foldl mkDsApp)
152 = go fun (exprType fun) args
154 go fun fun_ty [] = fun
155 go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
156 go fun fun_ty (arg : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
158 (arg_ty, res_ty) = splitFunTy fun_ty
160 mk_val_app fun arg arg_ty res_ty -- See Note [CoreSyn let/app invariant]
161 | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg
162 = App fun arg -- The vastly common case
164 mk_val_app (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 _ res_ty
165 | f == seqId -- Note [Desugaring seq]
166 = Case arg1 (mkWildId ty1) res_ty [(DEFAULT,[],arg2)]
168 mk_val_app fun arg arg_ty res_ty
169 = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))]
171 arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter,
172 -- because 'fun ' should not have a free wild-id
175 Note [Desugaring seq] cf Trac #1031
176 ~~~~~~~~~~~~~~~~~~~~~
177 f x y = x `seq` (y `seq` (# x,y #))
179 The [CoreSyn let/app invariant] means that, other things being equal, because
180 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
182 f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
184 But that is bad for two reasons:
185 (a) we now evaluate y before x, and
186 (b) we can't bind v to an unboxed pair
188 Seq is very, very special! So we recognise it right here, and desugar to
189 case x of _ -> case y of _ -> (# x,y #)
191 The special case would be valid for all calls to 'seq', but it's only *necessary*
192 for ones whose second argument has an unlifted type. So we only catch the latter
193 case here, to avoid unnecessary tests.
196 %************************************************************************
198 \subsection{ Selecting match variables}
200 %************************************************************************
202 We're about to match against some patterns. We want to make some
203 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
204 hand, which should indeed be bound to the pattern as a whole, then use it;
205 otherwise, make one up.
208 selectSimpleMatchVarL :: LPat Id -> DsM Id
209 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
211 -- (selectMatchVars ps tys) chooses variables of type tys
212 -- to use for matching ps against. If the pattern is a variable,
213 -- we try to use that, to save inventing lots of fresh variables.
215 -- OLD, but interesting note:
216 -- But even if it is a variable, its type might not match. Consider
218 -- T1 :: Int -> T Int
221 -- f :: T a -> a -> Int
222 -- f (T1 i) (x::Int) = x
223 -- f (T2 i) (y::a) = 0
224 -- Then we must not choose (x::Int) as the matching variable!
225 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
227 selectMatchVars :: [Pat Id] -> DsM [Id]
228 selectMatchVars ps = mapM selectMatchVar ps
230 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
231 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
232 selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
233 selectMatchVar (VarPat var) = return var
234 selectMatchVar (AsPat var pat) = return (unLoc var)
235 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
236 -- OK, better make up one...
240 %************************************************************************
242 %* type synonym EquationInfo and access functions for its pieces *
244 %************************************************************************
245 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
247 The ``equation info'' used by @match@ is relatively complicated and
248 worthy of a type synonym and a few handy functions.
251 firstPat :: EquationInfo -> Pat Id
252 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
254 shiftEqns :: [EquationInfo] -> [EquationInfo]
255 -- Drop the first pattern in each equation
256 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
259 Functions on MatchResults
262 matchCanFail :: MatchResult -> Bool
263 matchCanFail (MatchResult CanFail _) = True
264 matchCanFail (MatchResult CantFail _) = False
266 alwaysFailMatchResult :: MatchResult
267 alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
269 cantFailMatchResult :: CoreExpr -> MatchResult
270 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
272 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
273 extractMatchResult (MatchResult CantFail match_fn) fail_expr
274 = match_fn (error "It can't fail!")
276 extractMatchResult (MatchResult CanFail match_fn) fail_expr
277 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
278 match_fn if_it_fails `thenDs` \ body ->
279 returnDs (mkDsLet fail_bind body)
282 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
283 combineMatchResults (MatchResult CanFail body_fn1)
284 (MatchResult can_it_fail2 body_fn2)
285 = MatchResult can_it_fail2 body_fn
287 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
288 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
289 body_fn1 duplicatable_expr `thenDs` \ body1 ->
290 returnDs (Let fail_bind body1)
292 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
295 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
296 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
297 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
298 returnDs (encl_fn body))
300 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
301 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
302 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
305 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
307 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
309 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
310 wrapBind new old body
312 | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
313 | otherwise = Let (NonRec new (Var old)) body
315 seqVar :: Var -> CoreExpr -> CoreExpr
316 seqVar var body = Case (Var var) var (exprType body)
317 [(DEFAULT, [], body)]
319 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
320 mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind)
322 -- (mkViewMatchResult var' viewExpr var mr) makes the expression
323 -- let var' = viewExpr var in mr
324 mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
325 mkViewMatchResult var' viewExpr var =
326 adjustMatchResult (mkDsLet (NonRec var' (mkDsApp viewExpr (Var var))))
328 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
329 mkEvalMatchResult var ty
330 = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
332 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
333 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
334 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
335 returnDs (mkIfThenElse pred_expr body fail))
337 mkCoPrimCaseMatchResult :: Id -- Scrutinee
338 -> Type -- Type of the case
339 -> [(Literal, MatchResult)] -- Alternatives
341 mkCoPrimCaseMatchResult var ty match_alts
342 = MatchResult CanFail mk_case
345 = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
346 returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
348 sorted_alts = sortWith fst match_alts -- Right order for a Case
349 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
350 returnDs (LitAlt lit, [], body)
353 mkCoAlgCaseMatchResult :: Id -- Scrutinee
354 -> Type -- Type of exp
355 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
357 mkCoAlgCaseMatchResult var ty match_alts
358 | isNewTyCon tycon -- Newtype case; use a let
359 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
360 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
362 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
363 = MatchResult CanFail mk_parrCase
365 | otherwise -- Datatype case; use a case
366 = MatchResult fail_flag mk_case
368 tycon = dataConTyCon con1
369 -- [Interesting: becuase of GADTs, we can't rely on the type of
370 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
373 (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
374 arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1
376 (tc, ty_args) = splitNewTyConApp var_ty
377 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
379 -- Stuff for data types
380 data_cons = tyConDataCons tycon
381 match_results = [match_result | (_,_,match_result) <- match_alts]
383 fail_flag | exhaustive_case
384 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
388 wild_var = mkWildId (idType var)
389 sorted_alts = sortWith get_tag match_alts
390 get_tag (con, _, _) = dataConTag con
391 mk_case fail = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
392 returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))
394 mk_alt fail (con, args, MatchResult _ body_fn)
395 = body_fn fail `thenDs` \ body ->
396 newUniqueSupply `thenDs` \ us ->
397 returnDs (mkReboxingAlt (uniqsFromSupply us) con args body)
399 mk_default fail | exhaustive_case = []
400 | otherwise = [(DEFAULT, [], fail)]
402 un_mentioned_constructors
403 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
404 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
406 -- Stuff for parallel arrays
408 -- * the following is to desugar cases over fake constructors for
409 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
412 -- Concerning `isPArrFakeAlts':
414 -- * it is *not* sufficient to just check the type of the type
415 -- constructor, as we have to be careful not to confuse the real
416 -- representation of parallel arrays with the fake constructors;
417 -- moreover, a list of alternatives must not mix fake and real
418 -- constructors (this is checked earlier on)
420 -- FIXME: We actually go through the whole list and make sure that
421 -- either all or none of the constructors are fake parallel
422 -- array constructors. This is to spot equations that mix fake
423 -- constructors with the real representation defined in
424 -- `PrelPArr'. It would be nicer to spot this situation
425 -- earlier and raise a proper error message, but it can really
426 -- only happen in `PrelPArr' anyway.
428 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
429 isPArrFakeAlts ((dcon, _, _):alts) =
430 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
431 (True , True ) -> True
432 (False, False) -> False
434 panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
437 dsLookupGlobalId lengthPName `thenDs` \lengthP ->
438 unboxAlt `thenDs` \alt ->
439 returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
441 elemTy = case splitTyConApp (idType var) of
442 (_, [elemTy]) -> elemTy
444 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
445 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
448 newSysLocalDs intPrimTy `thenDs` \l ->
449 dsLookupGlobalId indexPName `thenDs` \indexP ->
450 mappM (mkAlt indexP) sorted_alts `thenDs` \alts ->
451 returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
453 wild = mkWildId intPrimTy
454 dft = (DEFAULT, [], fail)
456 -- each alternative matches one array length (corresponding to one
457 -- fake array constructor), so the match is on a literal; each
458 -- alternative's body is extended by a local binding for each
459 -- constructor argument, which are bound to array elements starting
462 mkAlt indexP (con, args, MatchResult _ bodyFun) =
463 bodyFun fail `thenDs` \body ->
464 returnDs (LitAlt lit, [], mkDsLets binds body)
466 lit = MachInt $ toInteger (dataConSourceArity con)
467 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
469 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
473 %************************************************************************
475 \subsection{Desugarer's versions of some Core functions}
477 %************************************************************************
480 mkErrorAppDs :: Id -- The error function
481 -> Type -- Type to which it should be applied
482 -> String -- The error message string to pass
485 mkErrorAppDs err_id ty msg
486 = getSrcSpanDs `thenDs` \ src_loc ->
488 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
489 core_msg = Lit (mkStringLit full_msg)
490 -- mkStringLit returns a result of type String#
492 returnDs (mkApps (Var err_id) [Type ty, core_msg])
496 *************************************************************
498 \subsection{Making literals}
500 %************************************************************************
503 mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int
504 mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int
505 mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer
506 mkStringExpr :: String -> DsM CoreExpr -- Result :: String
507 mkStringExprFS :: FastString -> DsM CoreExpr -- Result :: String
509 mkIntExpr i = mkConApp intDataCon [mkIntLit i]
510 mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
513 | inIntRange i -- Small enough, so start from an Int
514 = dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc ->
515 returnDs (mkSmallIntegerLit integer_dc i)
517 -- Special case for integral literals with a large magnitude:
518 -- They are transformed into an expression involving only smaller
519 -- integral literals. This improves constant folding.
521 | otherwise -- Big, so start from a string
522 = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id ->
523 dsLookupGlobalId timesIntegerName `thenDs` \ times_id ->
524 dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc ->
526 lit i = mkSmallIntegerLit integer_dc i
527 plus a b = Var plus_id `App` a `App` b
528 times a b = Var times_id `App` a `App` b
530 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
531 horner :: Integer -> Integer -> CoreExpr
532 horner b i | abs q <= 1 = if r == 0 || r == i
534 else lit r `plus` lit (i-r)
535 | r == 0 = horner b q `times` lit b
536 | otherwise = lit r `plus` (horner b q `times` lit b)
538 (q,r) = i `quotRem` b
541 returnDs (horner tARGET_MAX_INT i)
543 mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
545 mkStringExpr str = mkStringExprFS (mkFastString str)
549 = returnDs (mkNilExpr charTy)
553 the_char = mkCharExpr (headFS str)
555 returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
558 = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id ->
559 returnDs (App (Var unpack_id) (Lit (MachStr str)))
562 = dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id ->
563 returnDs (App (Var unpack_id) (Lit (MachStr str)))
567 safeChar c = ord c >= 1 && ord c <= 0x7F
571 %************************************************************************
573 \subsection[mkSelectorBind]{Make a selector bind}
575 %************************************************************************
577 This is used in various places to do with lazy patterns.
578 For each binder $b$ in the pattern, we create a binding:
580 b = case v of pat' -> b'
582 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
584 ToDo: making these bindings should really depend on whether there's
585 much work to be done per binding. If the pattern is complex, it
586 should be de-mangled once, into a tuple (and then selected from).
587 Otherwise the demangling can be in-line in the bindings (as here).
589 Boring! Boring! One error message per binder. The above ToDo is
590 even more helpful. Something very similar happens for pattern-bound
594 mkSelectorBinds :: LPat Id -- The pattern
595 -> CoreExpr -- Expression to which the pattern is bound
596 -> DsM [(Id,CoreExpr)]
598 mkSelectorBinds (L _ (VarPat v)) val_expr
599 = returnDs [(v, val_expr)]
601 mkSelectorBinds pat val_expr
602 | isSingleton binders || is_simple_lpat pat
603 = -- Given p = e, where p binds x,y
604 -- we are going to make
605 -- v = p (where v is fresh)
606 -- x = case v of p -> x
607 -- y = case v of p -> x
610 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
611 -- This does not matter after desugaring, but there's a subtle
612 -- issue with implicit parameters. Consider
614 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
615 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
616 -- does it get that type? So that when we abstract over it we get the
617 -- right top-level type (?i::Int) => ...)
619 -- So to get the type of 'v', use the pattern not the rhs. Often more
621 newSysLocalDs (hsLPatType pat) `thenDs` \ val_var ->
623 -- For the error message we make one error-app, to avoid duplication.
624 -- But we need it at different types... so we use coerce for that
625 mkErrorAppDs iRREFUT_PAT_ERROR_ID
626 unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr ->
627 newSysLocalDs unitTy `thenDs` \ err_var ->
628 mappM (mk_bind val_var err_var) binders `thenDs` \ binds ->
629 returnDs ( (val_var, val_expr) :
630 (err_var, err_expr) :
635 = mkErrorAppDs iRREFUT_PAT_ERROR_ID
636 tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
637 matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr ->
638 newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
641 = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
643 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
645 binders = collectPatBinders pat
646 local_tuple = mkTupleExpr binders
647 tuple_ty = exprType local_tuple
649 mk_bind scrut_var err_var bndr_var
650 -- (mk_bind sv err_var) generates
651 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
652 -- Remember, pat binds bv
653 = matchSimply (Var scrut_var) PatBindRhs pat
654 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
655 returnDs (bndr_var, rhs_expr)
657 error_expr = mkCoerce co (Var err_var)
658 co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
660 is_simple_lpat p = is_simple_pat (unLoc p)
662 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
663 is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
664 is_simple_pat (VarPat _) = True
665 is_simple_pat (ParPat p) = is_simple_lpat p
666 is_simple_pat other = False
668 is_triv_lpat p = is_triv_pat (unLoc p)
670 is_triv_pat (VarPat v) = True
671 is_triv_pat (WildPat _) = True
672 is_triv_pat (ParPat p) = is_triv_lpat p
673 is_triv_pat other = False
677 %************************************************************************
681 %************************************************************************
683 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
685 * If it has only one element, it is the identity function.
687 * If there are more elements than a big tuple can have, it nests
690 Nesting policy. Better a 2-tuple of 10-tuples (3 objects) than
691 a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big.
694 mkTupleExpr :: [Id] -> CoreExpr
695 mkTupleExpr ids = mkBigCoreTup (map Var ids)
697 -- corresponding type
698 mkTupleType :: [Id] -> Type
699 mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
701 mkBigCoreTup :: [CoreExpr] -> CoreExpr
702 mkBigCoreTup = mkBigTuple mkCoreTup
704 mkBigTuple :: ([a] -> a) -> [a] -> a
705 mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
707 -- Each sub-list is short enough to fit in a tuple
708 mk_big_tuple [as] = small_tuple as
709 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
711 chunkify :: [a] -> [[a]]
712 -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
713 -- But there may be more than mAX_TUPLE_SIZE sub-lists
715 | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
716 | otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
720 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
724 @mkTupleSelector@ builds a selector which scrutises the given
725 expression and extracts the one name from the list given.
726 If you want the no-shadowing rule to apply, the caller
727 is responsible for making sure that none of these names
730 If there is just one id in the ``tuple'', then the selector is
733 If it's big, it does nesting
734 mkTupleSelector [a,b,c,d] b v e
736 (p,q) -> case p of p {
738 We use 'tpl' vars for the p,q, since shadowing does not matter.
740 In fact, it's more convenient to generate it innermost first, getting
747 mkTupleSelector :: [Id] -- The tuple args
748 -> Id -- The selected one
749 -> Id -- A variable of the same type as the scrutinee
750 -> CoreExpr -- Scrutinee
753 mkTupleSelector vars the_var scrut_var scrut
754 = mk_tup_sel (chunkify vars) the_var
756 mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
757 mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
758 mk_tup_sel (chunkify tpl_vs) tpl_v
760 tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
761 tpl_vs = mkTemplateLocals tpl_tys
762 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
766 A generalization of @mkTupleSelector@, allowing the body
767 of the case to be an arbitrary expression.
769 If the tuple is big, it is nested:
771 mkTupleCase uniqs [a,b,c,d] body v e
772 = case e of v { (p,q) ->
773 case p of p { (a,b) ->
774 case q of q { (c,d) ->
777 To avoid shadowing, we use uniqs to invent new variables p,q.
779 ToDo: eliminate cases where none of the variables are needed.
783 :: UniqSupply -- for inventing names of intermediate variables
784 -> [Id] -- the tuple args
785 -> CoreExpr -- body of the case
786 -> Id -- a variable of the same type as the scrutinee
787 -> CoreExpr -- scrutinee
790 mkTupleCase uniqs vars body scrut_var scrut
791 = mk_tuple_case uniqs (chunkify vars) body
793 mk_tuple_case us [vars] body
794 = mkSmallTupleCase vars body scrut_var scrut
795 mk_tuple_case us vars_s body
797 (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
799 mk_tuple_case us' (chunkify vars') body'
800 one_tuple_case chunk_vars (us, vs, body)
802 (us1, us2) = splitUniqSupply us
803 scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
804 (mkCoreTupTy (map idType chunk_vars))
805 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
806 in (us2, scrut_var:vs, body')
809 The same, but with a tuple small enough not to need nesting.
813 :: [Id] -- the tuple args
814 -> CoreExpr -- body of the case
815 -> Id -- a variable of the same type as the scrutinee
816 -> CoreExpr -- scrutinee
819 mkSmallTupleCase [var] body _scrut_var scrut
820 = bindNonRec var scrut body
821 mkSmallTupleCase vars body scrut_var scrut
822 -- One branch no refinement?
823 = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
826 %************************************************************************
828 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
830 %************************************************************************
832 Call the constructor Ids when building explicit lists, so that they
833 interact well with rules.
836 mkNilExpr :: Type -> CoreExpr
837 mkNilExpr ty = mkConApp nilDataCon [Type ty]
839 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
840 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
842 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
843 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
846 -- The next three functions make tuple types, constructors and selectors,
847 -- with the rule that a 1-tuple is represented by the thing itselg
848 mkCoreTupTy :: [Type] -> Type
849 mkCoreTupTy [ty] = ty
850 mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
852 mkCoreTup :: [CoreExpr] -> CoreExpr
853 -- Builds exactly the specified tuple.
854 -- No fancy business for big tuples
855 mkCoreTup [] = Var unitDataConId
857 mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
858 (map (Type . exprType) cs ++ cs)
860 mkCoreSel :: [Id] -- The tuple args
861 -> Id -- The selected one
862 -> Id -- A variable of the same type as the scrutinee
863 -> CoreExpr -- Scrutinee
865 -- mkCoreSel [x,y,z] x v e
866 -- ===> case e of v { (x,y,z) -> x
867 mkCoreSel [var] should_be_the_same_var scrut_var scrut
868 = ASSERT(var == should_be_the_same_var)
871 mkCoreSel vars the_var scrut_var scrut
872 = ASSERT( notNull vars )
873 Case scrut scrut_var (idType the_var)
874 [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
877 %************************************************************************
879 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
881 %************************************************************************
883 Generally, we handle pattern matching failure like this: let-bind a
884 fail-variable, and use that variable if the thing fails:
886 let fail.33 = error "Help"
897 If the case can't fail, then there'll be no mention of @fail.33@, and the
898 simplifier will later discard it.
901 If it can fail in only one way, then the simplifier will inline it.
904 Only if it is used more than once will the let-binding remain.
907 There's a problem when the result of the case expression is of
908 unboxed type. Then the type of @fail.33@ is unboxed too, and
909 there is every chance that someone will change the let into a case:
915 which is of course utterly wrong. Rather than drop the condition that
916 only boxed types can be let-bound, we just turn the fail into a function
917 for the primitive case:
919 let fail.33 :: Void -> Int#
920 fail.33 = \_ -> error "Help"
929 Now @fail.33@ is a function, so it can be let-bound.
932 mkFailurePair :: CoreExpr -- Result type of the whole case expression
933 -> DsM (CoreBind, -- Binds the newly-created fail variable
934 -- to either the expression or \ _ -> expression
935 CoreExpr) -- Either the fail variable, or fail variable
936 -- applied to unit tuple
939 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
940 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
941 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
942 App (Var fail_fun_var) (Var unitDataConId))
945 = newFailLocalDs ty `thenDs` \ fail_var ->
946 returnDs (NonRec fail_var expr, Var fail_var)
952 mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
953 mkOptTickBox Nothing e = return e
954 mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
956 mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
957 mkTickBox ix vars e = do
960 let tick | opt_Hpc = mkTickBoxOpId uq mod ix
961 | otherwise = mkBreakPointOpId uq mod ix
963 let occName = mkVarOcc "tick"
964 let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
965 let var = Id.mkLocalId name realWorldStatePrimTy
968 then return (Var tick)
970 let tickVar = Var tick
971 let tickType = mkFunTys (map idType vars) realWorldStatePrimTy
972 let scrutApTy = App tickVar (Type tickType)
973 return (mkApps scrutApTy (map Var vars) :: Expr Id)
974 return $ Case scrut var ty [(DEFAULT,[],e)]
978 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
979 mkBinaryTickBox ixT ixF e = do
983 let bndr1 = mkSysLocal FSLIT("t1") uq boolTy
984 falseBox <- mkTickBox ixF [] $ Var falseDataConId
985 trueBox <- mkTickBox ixT [] $ Var trueDataConId
986 return $ Case e bndr1 boolTy
987 [ (DataAlt falseDataCon, [], falseBox)
988 , (DataAlt trueDataCon, [], trueBox)