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.
15 mkDsLet, mkDsLets, mkDsApp, mkDsApps,
17 MatchResult(..), CanItFail(..),
18 cantFailMatchResult, alwaysFailMatchResult,
19 extractMatchResult, combineMatchResults,
20 adjustMatchResult, adjustMatchResultDs,
21 mkCoLetMatchResult, mkGuardedMatchResult,
22 matchCanFail, mkEvalMatchResult,
23 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
26 mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
27 mkIntExpr, mkCharExpr,
28 mkStringExpr, mkStringExprFS, mkIntegerExpr,
30 mkSelectorBinds, mkTupleExpr, mkTupleSelector,
31 mkTupleType, mkTupleCase, mkBigCoreTup,
32 mkCoreTup, mkCoreTupTy, seqVar,
34 dsSyntaxTable, lookupEvidence,
36 selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
37 mkTickBox, mkOptTickBox, mkBinaryTickBox
40 #include "HsVersions.h"
42 import {-# SOURCE #-} Match ( matchSimply )
43 import {-# SOURCE #-} DsExpr( dsExpr )
79 infixl 4 `mkDsApp`, `mkDsApps`
84 %************************************************************************
88 %************************************************************************
91 dsSyntaxTable :: SyntaxTable Id
92 -> DsM ([CoreBind], -- Auxiliary bindings
93 [(Name,Id)]) -- Maps the standard name to its value
95 dsSyntaxTable rebound_ids
96 = mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
97 return (concat binds_s, prs)
99 -- The cheapo special case can happen when we
100 -- make an intermediate HsDo when desugaring a RecStmt
101 mk_bind (std_name, HsVar id) = return ([], (std_name, id))
102 mk_bind (std_name, expr)
103 = dsExpr expr `thenDs` \ rhs ->
104 newSysLocalDs (exprType rhs) `thenDs` \ id ->
105 return ([NonRec id rhs], (std_name, id))
107 lookupEvidence :: [(Name, Id)] -> Name -> Id
108 lookupEvidence prs std_name
109 = assocDefault (mk_panic std_name) prs std_name
111 mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
115 %************************************************************************
117 \subsection{Building lets}
119 %************************************************************************
121 Use case, not let for unlifted types. The simplifier will turn some
125 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
126 mkDsLet (NonRec bndr rhs) body
127 | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs)
128 = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
132 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
133 mkDsLets binds body = foldr mkDsLet body binds
136 mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr
137 -- Check the invariant that the arg of an App is ok-for-speculation if unlifted
138 -- See CoreSyn Note [CoreSyn let/app invariant]
139 mkDsApp fun (Type ty) = App fun (Type ty)
140 mkDsApp fun arg = mk_val_app fun arg arg_ty res_ty
142 (arg_ty, res_ty) = splitFunTy (exprType fun)
145 mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr
146 -- Slightly more efficient version of (foldl mkDsApp)
148 = go fun (exprType fun) args
150 go fun fun_ty [] = fun
151 go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
152 go fun fun_ty (arg : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
154 (arg_ty, res_ty) = splitFunTy fun_ty
156 mk_val_app fun arg arg_ty res_ty
157 | isUnLiftedType arg_ty && not (exprOkForSpeculation arg)
158 = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
159 | otherwise -- The common case
162 arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter,
163 -- because 'fun ' should not have a free wild-id
167 %************************************************************************
169 \subsection{ Selecting match variables}
171 %************************************************************************
173 We're about to match against some patterns. We want to make some
174 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
175 hand, which should indeed be bound to the pattern as a whole, then use it;
176 otherwise, make one up.
179 selectSimpleMatchVarL :: LPat Id -> DsM Id
180 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
182 -- (selectMatchVars ps tys) chooses variables of type tys
183 -- to use for matching ps against. If the pattern is a variable,
184 -- we try to use that, to save inventing lots of fresh variables.
186 -- OLD, but interesting note:
187 -- But even if it is a variable, its type might not match. Consider
189 -- T1 :: Int -> T Int
192 -- f :: T a -> a -> Int
193 -- f (T1 i) (x::Int) = x
194 -- f (T2 i) (y::a) = 0
195 -- Then we must not choose (x::Int) as the matching variable!
196 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
198 selectMatchVars :: [Pat Id] -> DsM [Id]
199 selectMatchVars ps = mapM selectMatchVar ps
201 selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
202 selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
203 selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
204 selectMatchVar (VarPat var) = return var
205 selectMatchVar (AsPat var pat) = return (unLoc var)
206 selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
207 -- OK, better make up one...
211 %************************************************************************
213 %* type synonym EquationInfo and access functions for its pieces *
215 %************************************************************************
216 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
218 The ``equation info'' used by @match@ is relatively complicated and
219 worthy of a type synonym and a few handy functions.
222 firstPat :: EquationInfo -> Pat Id
223 firstPat eqn = head (eqn_pats eqn)
225 shiftEqns :: [EquationInfo] -> [EquationInfo]
226 -- Drop the first pattern in each equation
227 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
230 Functions on MatchResults
233 matchCanFail :: MatchResult -> Bool
234 matchCanFail (MatchResult CanFail _) = True
235 matchCanFail (MatchResult CantFail _) = False
237 alwaysFailMatchResult :: MatchResult
238 alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
240 cantFailMatchResult :: CoreExpr -> MatchResult
241 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
243 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
244 extractMatchResult (MatchResult CantFail match_fn) fail_expr
245 = match_fn (error "It can't fail!")
247 extractMatchResult (MatchResult CanFail match_fn) fail_expr
248 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
249 match_fn if_it_fails `thenDs` \ body ->
250 returnDs (mkDsLet fail_bind body)
253 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
254 combineMatchResults (MatchResult CanFail body_fn1)
255 (MatchResult can_it_fail2 body_fn2)
256 = MatchResult can_it_fail2 body_fn
258 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
259 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
260 body_fn1 duplicatable_expr `thenDs` \ body1 ->
261 returnDs (Let fail_bind body1)
263 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
266 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
267 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
268 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
269 returnDs (encl_fn body))
271 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
272 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
273 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
276 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
278 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
280 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
281 wrapBind new old body
283 | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
284 | otherwise = Let (NonRec new (Var old)) body
286 seqVar :: Var -> CoreExpr -> CoreExpr
287 seqVar var body = Case (Var var) var (exprType body)
288 [(DEFAULT, [], body)]
290 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
291 mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind)
293 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
294 mkEvalMatchResult var ty
295 = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
297 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
298 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
299 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
300 returnDs (mkIfThenElse pred_expr body fail))
302 mkCoPrimCaseMatchResult :: Id -- Scrutinee
303 -> Type -- Type of the case
304 -> [(Literal, MatchResult)] -- Alternatives
306 mkCoPrimCaseMatchResult var ty match_alts
307 = MatchResult CanFail mk_case
310 = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
311 returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
313 sorted_alts = sortWith fst match_alts -- Right order for a Case
314 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
315 returnDs (LitAlt lit, [], body)
318 mkCoAlgCaseMatchResult :: Id -- Scrutinee
319 -> Type -- Type of exp
320 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
322 mkCoAlgCaseMatchResult var ty match_alts
323 | isNewTyCon tycon -- Newtype case; use a let
324 = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
325 mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
327 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case
328 = MatchResult CanFail mk_parrCase
330 | otherwise -- Datatype case; use a case
331 = MatchResult fail_flag mk_case
333 tycon = dataConTyCon con1
334 -- [Interesting: becuase of GADTs, we can't rely on the type of
335 -- the scrutinised Id to be sufficiently refined to have a TyCon in it]
338 (con1, arg_ids1, match_result1) = head match_alts
339 arg_id1 = head arg_ids1
341 (tc, ty_args) = splitNewTyConApp var_ty
342 newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
344 -- Stuff for data types
345 data_cons = tyConDataCons tycon
346 match_results = [match_result | (_,_,match_result) <- match_alts]
348 fail_flag | exhaustive_case
349 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
353 wild_var = mkWildId (idType var)
354 sorted_alts = sortWith get_tag match_alts
355 get_tag (con, _, _) = dataConTag con
356 mk_case fail = mappM (mk_alt fail) sorted_alts `thenDs` \ alts ->
357 returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))
359 mk_alt fail (con, args, MatchResult _ body_fn)
360 = body_fn fail `thenDs` \ body ->
361 newUniqueSupply `thenDs` \ us ->
362 returnDs (mkReboxingAlt (uniqsFromSupply us) con args body)
364 mk_default fail | exhaustive_case = []
365 | otherwise = [(DEFAULT, [], fail)]
367 un_mentioned_constructors
368 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
369 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
371 -- Stuff for parallel arrays
373 -- * the following is to desugar cases over fake constructors for
374 -- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
377 -- Concerning `isPArrFakeAlts':
379 -- * it is *not* sufficient to just check the type of the type
380 -- constructor, as we have to be careful not to confuse the real
381 -- representation of parallel arrays with the fake constructors;
382 -- moreover, a list of alternatives must not mix fake and real
383 -- constructors (this is checked earlier on)
385 -- FIXME: We actually go through the whole list and make sure that
386 -- either all or none of the constructors are fake parallel
387 -- array constructors. This is to spot equations that mix fake
388 -- constructors with the real representation defined in
389 -- `PrelPArr'. It would be nicer to spot this situation
390 -- earlier and raise a proper error message, but it can really
391 -- only happen in `PrelPArr' anyway.
393 isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon
394 isPArrFakeAlts ((dcon, _, _):alts) =
395 case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
396 (True , True ) -> True
397 (False, False) -> False
399 panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
402 dsLookupGlobalId lengthPName `thenDs` \lengthP ->
403 unboxAlt `thenDs` \alt ->
404 returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
406 elemTy = case splitTyConApp (idType var) of
407 (_, [elemTy]) -> elemTy
409 panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
410 len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
413 newSysLocalDs intPrimTy `thenDs` \l ->
414 dsLookupGlobalId indexPName `thenDs` \indexP ->
415 mappM (mkAlt indexP) sorted_alts `thenDs` \alts ->
416 returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
418 wild = mkWildId intPrimTy
419 dft = (DEFAULT, [], fail)
421 -- each alternative matches one array length (corresponding to one
422 -- fake array constructor), so the match is on a literal; each
423 -- alternative's body is extended by a local binding for each
424 -- constructor argument, which are bound to array elements starting
427 mkAlt indexP (con, args, MatchResult _ bodyFun) =
428 bodyFun fail `thenDs` \body ->
429 returnDs (LitAlt lit, [], mkDsLets binds body)
431 lit = MachInt $ toInteger (dataConSourceArity con)
432 binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
434 indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
438 %************************************************************************
440 \subsection{Desugarer's versions of some Core functions}
442 %************************************************************************
445 mkErrorAppDs :: Id -- The error function
446 -> Type -- Type to which it should be applied
447 -> String -- The error message string to pass
450 mkErrorAppDs err_id ty msg
451 = getSrcSpanDs `thenDs` \ src_loc ->
453 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
454 core_msg = Lit (mkStringLit full_msg)
455 -- mkStringLit returns a result of type String#
457 returnDs (mkApps (Var err_id) [Type ty, core_msg])
461 *************************************************************
463 \subsection{Making literals}
465 %************************************************************************
468 mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int
469 mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int
470 mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer
471 mkStringExpr :: String -> DsM CoreExpr -- Result :: String
472 mkStringExprFS :: FastString -> DsM CoreExpr -- Result :: String
474 mkIntExpr i = mkConApp intDataCon [mkIntLit i]
475 mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
478 | inIntRange i -- Small enough, so start from an Int
479 = dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc ->
480 returnDs (mkSmallIntegerLit integer_dc i)
482 -- Special case for integral literals with a large magnitude:
483 -- They are transformed into an expression involving only smaller
484 -- integral literals. This improves constant folding.
486 | otherwise -- Big, so start from a string
487 = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id ->
488 dsLookupGlobalId timesIntegerName `thenDs` \ times_id ->
489 dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc ->
491 lit i = mkSmallIntegerLit integer_dc i
492 plus a b = Var plus_id `App` a `App` b
493 times a b = Var times_id `App` a `App` b
495 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
496 horner :: Integer -> Integer -> CoreExpr
497 horner b i | abs q <= 1 = if r == 0 || r == i
499 else lit r `plus` lit (i-r)
500 | r == 0 = horner b q `times` lit b
501 | otherwise = lit r `plus` (horner b q `times` lit b)
503 (q,r) = i `quotRem` b
506 returnDs (horner tARGET_MAX_INT i)
508 mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
510 mkStringExpr str = mkStringExprFS (mkFastString str)
514 = returnDs (mkNilExpr charTy)
518 the_char = mkCharExpr (headFS str)
520 returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
523 = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id ->
524 returnDs (App (Var unpack_id) (Lit (MachStr str)))
527 = dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id ->
528 returnDs (App (Var unpack_id) (Lit (MachStr str)))
532 safeChar c = ord c >= 1 && ord c <= 0x7F
536 %************************************************************************
538 \subsection[mkSelectorBind]{Make a selector bind}
540 %************************************************************************
542 This is used in various places to do with lazy patterns.
543 For each binder $b$ in the pattern, we create a binding:
545 b = case v of pat' -> b'
547 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
549 ToDo: making these bindings should really depend on whether there's
550 much work to be done per binding. If the pattern is complex, it
551 should be de-mangled once, into a tuple (and then selected from).
552 Otherwise the demangling can be in-line in the bindings (as here).
554 Boring! Boring! One error message per binder. The above ToDo is
555 even more helpful. Something very similar happens for pattern-bound
559 mkSelectorBinds :: LPat Id -- The pattern
560 -> CoreExpr -- Expression to which the pattern is bound
561 -> DsM [(Id,CoreExpr)]
563 mkSelectorBinds (L _ (VarPat v)) val_expr
564 = returnDs [(v, val_expr)]
566 mkSelectorBinds pat val_expr
567 | isSingleton binders || is_simple_lpat pat
568 = -- Given p = e, where p binds x,y
569 -- we are going to make
570 -- v = p (where v is fresh)
571 -- x = case v of p -> x
572 -- y = case v of p -> x
575 -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
576 -- This does not matter after desugaring, but there's a subtle
577 -- issue with implicit parameters. Consider
579 -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
580 -- to the desugarer. (Why opaque? Because newtypes have to be. Why
581 -- does it get that type? So that when we abstract over it we get the
582 -- right top-level type (?i::Int) => ...)
584 -- So to get the type of 'v', use the pattern not the rhs. Often more
586 newSysLocalDs (hsLPatType pat) `thenDs` \ val_var ->
588 -- For the error message we make one error-app, to avoid duplication.
589 -- But we need it at different types... so we use coerce for that
590 mkErrorAppDs iRREFUT_PAT_ERROR_ID
591 unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr ->
592 newSysLocalDs unitTy `thenDs` \ err_var ->
593 mappM (mk_bind val_var err_var) binders `thenDs` \ binds ->
594 returnDs ( (val_var, val_expr) :
595 (err_var, err_expr) :
600 = mkErrorAppDs iRREFUT_PAT_ERROR_ID
601 tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
602 matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr ->
603 newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
606 = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
608 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
610 binders = collectPatBinders pat
611 local_tuple = mkTupleExpr binders
612 tuple_ty = exprType local_tuple
614 mk_bind scrut_var err_var bndr_var
615 -- (mk_bind sv err_var) generates
616 -- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
617 -- Remember, pat binds bv
618 = matchSimply (Var scrut_var) PatBindRhs pat
619 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
620 returnDs (bndr_var, rhs_expr)
622 error_expr = mkCoerce co (Var err_var)
623 co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
625 is_simple_lpat p = is_simple_pat (unLoc p)
627 is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
628 is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConArgs ps)
629 is_simple_pat (VarPat _) = True
630 is_simple_pat (ParPat p) = is_simple_lpat p
631 is_simple_pat other = False
633 is_triv_lpat p = is_triv_pat (unLoc p)
635 is_triv_pat (VarPat v) = True
636 is_triv_pat (WildPat _) = True
637 is_triv_pat (ParPat p) = is_triv_lpat p
638 is_triv_pat other = False
642 %************************************************************************
646 %************************************************************************
648 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
650 * If it has only one element, it is the identity function.
652 * If there are more elements than a big tuple can have, it nests
655 Nesting policy. Better a 2-tuple of 10-tuples (3 objects) than
656 a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big.
659 mkTupleExpr :: [Id] -> CoreExpr
660 mkTupleExpr ids = mkBigCoreTup (map Var ids)
662 -- corresponding type
663 mkTupleType :: [Id] -> Type
664 mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
666 mkBigCoreTup :: [CoreExpr] -> CoreExpr
667 mkBigCoreTup = mkBigTuple mkCoreTup
669 mkBigTuple :: ([a] -> a) -> [a] -> a
670 mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
672 -- Each sub-list is short enough to fit in a tuple
673 mk_big_tuple [as] = small_tuple as
674 mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
676 chunkify :: [a] -> [[a]]
677 -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
678 -- But there may be more than mAX_TUPLE_SIZE sub-lists
680 | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
681 | otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
685 split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
689 @mkTupleSelector@ builds a selector which scrutises the given
690 expression and extracts the one name from the list given.
691 If you want the no-shadowing rule to apply, the caller
692 is responsible for making sure that none of these names
695 If there is just one id in the ``tuple'', then the selector is
698 If it's big, it does nesting
699 mkTupleSelector [a,b,c,d] b v e
701 (p,q) -> case p of p {
703 We use 'tpl' vars for the p,q, since shadowing does not matter.
705 In fact, it's more convenient to generate it innermost first, getting
712 mkTupleSelector :: [Id] -- The tuple args
713 -> Id -- The selected one
714 -> Id -- A variable of the same type as the scrutinee
715 -> CoreExpr -- Scrutinee
718 mkTupleSelector vars the_var scrut_var scrut
719 = mk_tup_sel (chunkify vars) the_var
721 mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
722 mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
723 mk_tup_sel (chunkify tpl_vs) tpl_v
725 tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
726 tpl_vs = mkTemplateLocals tpl_tys
727 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
731 A generalization of @mkTupleSelector@, allowing the body
732 of the case to be an arbitrary expression.
734 If the tuple is big, it is nested:
736 mkTupleCase uniqs [a,b,c,d] body v e
737 = case e of v { (p,q) ->
738 case p of p { (a,b) ->
739 case q of q { (c,d) ->
742 To avoid shadowing, we use uniqs to invent new variables p,q.
744 ToDo: eliminate cases where none of the variables are needed.
748 :: UniqSupply -- for inventing names of intermediate variables
749 -> [Id] -- the tuple args
750 -> CoreExpr -- body of the case
751 -> Id -- a variable of the same type as the scrutinee
752 -> CoreExpr -- scrutinee
755 mkTupleCase uniqs vars body scrut_var scrut
756 = mk_tuple_case uniqs (chunkify vars) body
758 mk_tuple_case us [vars] body
759 = mkSmallTupleCase vars body scrut_var scrut
760 mk_tuple_case us vars_s body
762 (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
764 mk_tuple_case us' (chunkify vars') body'
765 one_tuple_case chunk_vars (us, vs, body)
767 (us1, us2) = splitUniqSupply us
768 scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
769 (mkCoreTupTy (map idType chunk_vars))
770 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
771 in (us2, scrut_var:vs, body')
774 The same, but with a tuple small enough not to need nesting.
778 :: [Id] -- the tuple args
779 -> CoreExpr -- body of the case
780 -> Id -- a variable of the same type as the scrutinee
781 -> CoreExpr -- scrutinee
784 mkSmallTupleCase [var] body _scrut_var scrut
785 = bindNonRec var scrut body
786 mkSmallTupleCase vars body scrut_var scrut
787 -- One branch no refinement?
788 = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
791 %************************************************************************
793 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
795 %************************************************************************
797 Call the constructor Ids when building explicit lists, so that they
798 interact well with rules.
801 mkNilExpr :: Type -> CoreExpr
802 mkNilExpr ty = mkConApp nilDataCon [Type ty]
804 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
805 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
807 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
808 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
811 -- The next three functions make tuple types, constructors and selectors,
812 -- with the rule that a 1-tuple is represented by the thing itselg
813 mkCoreTupTy :: [Type] -> Type
814 mkCoreTupTy [ty] = ty
815 mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
817 mkCoreTup :: [CoreExpr] -> CoreExpr
818 -- Builds exactly the specified tuple.
819 -- No fancy business for big tuples
820 mkCoreTup [] = Var unitDataConId
822 mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
823 (map (Type . exprType) cs ++ cs)
825 mkCoreSel :: [Id] -- The tuple args
826 -> Id -- The selected one
827 -> Id -- A variable of the same type as the scrutinee
828 -> CoreExpr -- Scrutinee
830 -- mkCoreSel [x,y,z] x v e
831 -- ===> case e of v { (x,y,z) -> x
832 mkCoreSel [var] should_be_the_same_var scrut_var scrut
833 = ASSERT(var == should_be_the_same_var)
836 mkCoreSel vars the_var scrut_var scrut
837 = ASSERT( notNull vars )
838 Case scrut scrut_var (idType the_var)
839 [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
842 %************************************************************************
844 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
846 %************************************************************************
848 Generally, we handle pattern matching failure like this: let-bind a
849 fail-variable, and use that variable if the thing fails:
851 let fail.33 = error "Help"
862 If the case can't fail, then there'll be no mention of @fail.33@, and the
863 simplifier will later discard it.
866 If it can fail in only one way, then the simplifier will inline it.
869 Only if it is used more than once will the let-binding remain.
872 There's a problem when the result of the case expression is of
873 unboxed type. Then the type of @fail.33@ is unboxed too, and
874 there is every chance that someone will change the let into a case:
880 which is of course utterly wrong. Rather than drop the condition that
881 only boxed types can be let-bound, we just turn the fail into a function
882 for the primitive case:
884 let fail.33 :: Void -> Int#
885 fail.33 = \_ -> error "Help"
894 Now @fail.33@ is a function, so it can be let-bound.
897 mkFailurePair :: CoreExpr -- Result type of the whole case expression
898 -> DsM (CoreBind, -- Binds the newly-created fail variable
899 -- to either the expression or \ _ -> expression
900 CoreExpr) -- Either the fail variable, or fail variable
901 -- applied to unit tuple
904 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
905 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
906 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
907 App (Var fail_fun_var) (Var unitDataConId))
910 = newFailLocalDs ty `thenDs` \ fail_var ->
911 returnDs (NonRec fail_var expr, Var fail_var)
917 mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr
918 mkOptTickBox Nothing e = return e
919 mkOptTickBox (Just ix) e = mkTickBox ix e
921 mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
925 let tick = mkTickBoxOpId uq mod ix
927 let occName = mkVarOcc "tick"
928 let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal?
929 let var = Id.mkLocalId name realWorldStatePrimTy
930 return $ Case (Var tick)
937 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
938 mkBinaryTickBox ixT ixF e = do
942 let bndr1 = mkSysLocal FSLIT("t1") uq boolTy
943 falseBox <- mkTickBox ixF $ Var falseDataConId
944 trueBox <- mkTickBox ixT $ Var trueDataConId
945 return $ Case e bndr1 boolTy
946 [ (DataAlt falseDataCon, [], falseBox)
947 , (DataAlt trueDataCon, [], trueBox)