2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsUtils]{Utilities for desugaring}
6 This module exports some utility functions of no great interest.
10 CanItFail(..), EquationInfo(..), MatchResult(..),
17 cantFailMatchResult, extractMatchResult,
19 adjustMatchResult, adjustMatchResultDs,
20 mkCoLetsMatchResult, mkGuardedMatchResult,
21 mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
23 mkErrorAppDs, mkNilExpr, mkConsExpr,
24 mkStringLit, mkStringLitFS, mkIntegerLit,
26 mkSelectorBinds, mkTupleExpr, mkTupleSelector,
31 #include "HsVersions.h"
33 import {-# SOURCE #-} Match ( matchSimply )
36 import TcHsSyn ( TypecheckedPat )
37 import DsHsSyn ( outPatType, collectTypedPatBinders )
42 import CoreUtils ( exprType, mkIfThenElse )
43 import PrelInfo ( iRREFUT_PAT_ERROR_ID )
44 import Id ( idType, Id, mkWildId )
45 import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
46 import TyCon ( isNewTyCon, tyConDataCons )
47 import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed,
48 dataConStrictMarks, dataConId, splitProductType_maybe
50 import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
53 import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
54 import TysWiredIn ( nilDataCon, consDataCon,
57 unitDataConId, unitTy,
59 intTy, intDataCon, smallIntegerDataCon,
60 floatTy, floatDataCon,
61 doubleTy, doubleDataCon,
64 import BasicTypes ( Boxity(..) )
65 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
66 import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
67 plusIntegerName, timesIntegerName )
69 import UnicodeUtil ( stringToUtf8 )
74 %************************************************************************
76 \subsection{Tidying lit pats}
78 %************************************************************************
81 tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
82 tidyLitPat (HsChar c) pat = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
83 tidyLitPat lit pat = pat
85 tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
86 tidyNPat (HsString s) _ pat
87 | _LENGTH_ s <= 1 -- Short string literals only
88 = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
89 (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
90 -- The stringTy is the type of the whole pattern, not
91 -- the type to instantiate (:) or [] with!
93 mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
95 tidyNPat lit lit_ty default_pat
96 | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
97 | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
98 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
99 | otherwise = default_pat
102 mk_int (HsInteger i) = HsIntPrim i
104 mk_float (HsInteger i) = HsFloatPrim (fromInteger i)
105 mk_float (HsRat f _) = HsFloatPrim f
107 mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
108 mk_double (HsRat f _) = HsDoublePrim f
112 %************************************************************************
114 \subsection{Building lets}
116 %************************************************************************
118 Use case, not let for unlifted types. The simplifier will turn some
122 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
123 mkDsLet (NonRec bndr rhs) body
124 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
128 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
129 mkDsLets binds body = foldr mkDsLet body binds
133 %************************************************************************
135 \subsection{ Selecting match variables}
137 %************************************************************************
139 We're about to match against some patterns. We want to make some
140 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
141 hand, which should indeed be bound to the pattern as a whole, then use it;
142 otherwise, make one up.
145 selectMatchVar :: TypecheckedPat -> DsM Id
146 selectMatchVar (VarPat var) = returnDs var
147 selectMatchVar (AsPat var pat) = returnDs var
148 selectMatchVar (LazyPat pat) = selectMatchVar pat
149 selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
153 %************************************************************************
155 %* type synonym EquationInfo and access functions for its pieces *
157 %************************************************************************
158 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
160 The ``equation info'' used by @match@ is relatively complicated and
161 worthy of a type synonym and a few handy functions.
166 type EqnSet = UniqSet EqnNo
170 EqnNo -- The number of the equation
172 DsMatchContext -- The context info is used when producing warnings
173 -- about shadowed patterns. It's the context
174 -- of the *first* thing matched in this group.
175 -- Should perhaps be a list of them all!
177 [TypecheckedPat] -- The patterns for an eqn
179 MatchResult -- Encapsulates the guards and bindings
185 CanItFail -- Tells whether the failure expression is used
186 (CoreExpr -> DsM CoreExpr)
187 -- Takes a expression to plug in at the
188 -- failure point(s). The expression should
191 data CanItFail = CanFail | CantFail
193 orFail CantFail CantFail = CantFail
197 Functions on MatchResults
200 cantFailMatchResult :: CoreExpr -> MatchResult
201 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
203 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
204 extractMatchResult (MatchResult CantFail match_fn) fail_expr
205 = match_fn (error "It can't fail!")
207 extractMatchResult (MatchResult CanFail match_fn) fail_expr
208 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
209 match_fn if_it_fails `thenDs` \ body ->
210 returnDs (mkDsLet fail_bind body)
213 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
214 combineMatchResults (MatchResult CanFail body_fn1)
215 (MatchResult can_it_fail2 body_fn2)
216 = MatchResult can_it_fail2 body_fn
218 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
219 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
220 body_fn1 duplicatable_expr `thenDs` \ body1 ->
221 returnDs (Let fail_bind body1)
223 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
227 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
228 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
229 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
230 returnDs (encl_fn body))
232 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
233 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
234 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
238 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
239 mkCoLetsMatchResult binds match_result
240 = adjustMatchResult (mkDsLets binds) match_result
243 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
244 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
245 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
246 returnDs (mkIfThenElse pred_expr body fail))
248 mkCoPrimCaseMatchResult :: Id -- Scrutinee
249 -> [(Literal, MatchResult)] -- Alternatives
251 mkCoPrimCaseMatchResult var match_alts
252 = MatchResult CanFail mk_case
255 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
256 returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
258 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
259 returnDs (LitAlt lit, [], body)
262 mkCoAlgCaseMatchResult :: Id -- Scrutinee
263 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
266 mkCoAlgCaseMatchResult var match_alts
267 | isNewTyCon tycon -- Newtype case; use a let
268 = ASSERT( newtype_sanity )
269 mkCoLetsMatchResult [coercion_bind] match_result
271 | otherwise -- Datatype case; use a case
272 = MatchResult fail_flag mk_case
275 scrut_ty = idType var
276 (tycon, _, _) = splitAlgTyConApp scrut_ty
279 (_, arg_ids, match_result) = head match_alts
280 arg_id = head arg_ids
281 coercion_bind = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id))
284 newtype_sanity = null (tail match_alts) && null (tail arg_ids)
286 -- Stuff for data types
287 data_cons = tyConDataCons tycon
289 match_results = [match_result | (_,_,match_result) <- match_alts]
291 fail_flag | exhaustive_case
292 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
296 wild_var = mkWildId (idType var)
297 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
298 returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
300 mk_alt fail (con, args, MatchResult _ body_fn)
301 = body_fn fail `thenDs` \ body ->
302 rebuildConArgs con args (dataConStrictMarks con) body
303 `thenDs` \ (body', real_args) ->
304 returnDs (DataAlt con, real_args, body')
306 mk_default fail | exhaustive_case = []
307 | otherwise = [(DEFAULT, [], fail)]
309 un_mentioned_constructors
310 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
311 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
314 For each constructor we match on, we might need to re-pack some
315 of the strict fields if they are unpacked in the constructor.
319 :: DataCon -- the con we're matching on
320 -> [Id] -- the source-level args
321 -> [StrictnessMark] -- the strictness annotations (per-arg)
322 -> CoreExpr -- the body
323 -> DsM (CoreExpr, [Id])
325 rebuildConArgs con [] stricts body = returnDs (body, [])
326 rebuildConArgs con (arg:args) stricts body | isTyVar arg
327 = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
328 returnDs (body',arg:args')
329 rebuildConArgs con (arg:args) (str:stricts) body
330 = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
331 case maybeMarkedUnboxed str of
332 Just (pack_con1, _) ->
333 case splitProductType_maybe (idType arg) of
334 Just (_, tycon_args, pack_con, con_arg_tys) ->
335 ASSERT( pack_con == pack_con1 )
336 newSysLocalsDs con_arg_tys `thenDs` \ unpacked_args ->
338 mkDsLet (NonRec arg (mkConApp pack_con
339 (map Type tycon_args ++
340 map Var unpacked_args))) body',
341 unpacked_args ++ real_args
344 _ -> returnDs (body', arg:real_args)
347 %************************************************************************
349 \subsection{Desugarer's versions of some Core functions}
351 %************************************************************************
354 mkErrorAppDs :: Id -- The error function
355 -> Type -- Type to which it should be applied
356 -> String -- The error message string to pass
359 mkErrorAppDs err_id ty msg
360 = getSrcLocDs `thenDs` \ src_loc ->
362 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
364 mkStringLit full_msg `thenDs` \ core_msg ->
365 returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg])
366 -- unUsgTy *required* -- KSW 1999-04-07
370 *************************************************************
372 \subsection{Making literals}
374 %************************************************************************
377 mkIntegerLit :: Integer -> DsM CoreExpr
379 | inIntRange i -- Small enough, so start from an Int
380 = returnDs (mkSmallIntegerLit i)
382 -- Special case for integral literals with a large magnitude:
383 -- They are transformed into an expression involving only smaller
384 -- integral literals. This improves constant folding.
386 | otherwise -- Big, so start from a string
387 = dsLookupGlobalValue plusIntegerName `thenDs` \ plus_id ->
388 dsLookupGlobalValue timesIntegerName `thenDs` \ times_id ->
390 plus a b = Var plus_id `App` a `App` b
391 times a b = Var times_id `App` a `App` b
393 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
394 horner :: Integer -> Integer -> CoreExpr
395 horner b i | abs q <= 1 = if r == 0 || r == i
396 then mkSmallIntegerLit i
397 else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
398 | r == 0 = horner b q `times` mkSmallIntegerLit b
399 | otherwise = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
401 (q,r) = i `quotRem` b
404 returnDs (horner tARGET_MAX_INT i)
406 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
408 mkStringLit :: String -> DsM CoreExpr
409 mkStringLit str = mkStringLitFS (_PK_ str)
411 mkStringLitFS :: FAST_STRING -> DsM CoreExpr
414 = returnDs (mkNilExpr charTy)
418 the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))]
420 returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
423 = dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id ->
424 returnDs (App (Var unpack_id) (Lit (MachStr str)))
427 = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id ->
428 returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
431 chars = _UNPK_INT_ str
432 safeChar c = c >= 1 && c <= 0xFF
436 %************************************************************************
438 \subsection[mkSelectorBind]{Make a selector bind}
440 %************************************************************************
442 This is used in various places to do with lazy patterns.
443 For each binder $b$ in the pattern, we create a binding:
445 b = case v of pat' -> b'
447 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
449 ToDo: making these bindings should really depend on whether there's
450 much work to be done per binding. If the pattern is complex, it
451 should be de-mangled once, into a tuple (and then selected from).
452 Otherwise the demangling can be in-line in the bindings (as here).
454 Boring! Boring! One error message per binder. The above ToDo is
455 even more helpful. Something very similar happens for pattern-bound
459 mkSelectorBinds :: TypecheckedPat -- The pattern
460 -> CoreExpr -- Expression to which the pattern is bound
461 -> DsM [(Id,CoreExpr)]
463 mkSelectorBinds (VarPat v) val_expr
464 = returnDs [(v, val_expr)]
466 mkSelectorBinds pat val_expr
467 | length binders == 1 || is_simple_pat pat
468 = newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
470 -- For the error message we don't use mkErrorAppDs to avoid
471 -- duplicating the string literal each time
472 newSysLocalDs stringTy `thenDs` \ msg_var ->
473 getSrcLocDs `thenDs` \ src_loc ->
475 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
477 mkStringLit full_msg `thenDs` \ core_msg ->
478 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
479 returnDs ( (val_var, val_expr) :
480 (msg_var, core_msg) :
485 = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
486 `thenDs` \ error_expr ->
487 matchSimply val_expr LetMatch pat local_tuple error_expr
488 `thenDs` \ tuple_expr ->
489 newSysLocalDs tuple_ty
490 `thenDs` \ tuple_var ->
493 (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
495 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
497 binders = collectTypedPatBinders pat
498 local_tuple = mkTupleExpr binders
499 tuple_ty = exprType local_tuple
501 mk_bind scrut_var msg_var bndr_var
502 -- (mk_bind sv bv) generates
503 -- bv = case sv of { pat -> bv; other -> error-msg }
504 -- Remember, pat binds bv
505 = matchSimply (Var scrut_var) LetMatch pat
506 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
507 returnDs (bndr_var, rhs_expr)
509 binder_ty = idType bndr_var
510 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
512 is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
513 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
514 is_simple_pat (VarPat _) = True
515 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
516 is_simple_pat other = False
518 is_triv_pat (VarPat v) = True
519 is_triv_pat (WildPat _) = True
520 is_triv_pat other = False
524 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
525 has only one element, it is the identity function. Notice we must
526 throw out any usage annotation on the outside of an Id.
529 mkTupleExpr :: [Id] -> CoreExpr
531 mkTupleExpr [] = Var unitDataConId
532 mkTupleExpr [id] = Var id
533 mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids))
534 (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
538 @mkTupleSelector@ builds a selector which scrutises the given
539 expression and extracts the one name from the list given.
540 If you want the no-shadowing rule to apply, the caller
541 is responsible for making sure that none of these names
544 If there is just one id in the ``tuple'', then the selector is
548 mkTupleSelector :: [Id] -- The tuple args
549 -> Id -- The selected one
550 -> Id -- A variable of the same type as the scrutinee
551 -> CoreExpr -- Scrutinee
554 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
555 = ASSERT(var == should_be_the_same_var)
558 mkTupleSelector vars the_var scrut_var scrut
559 = ASSERT( not (null vars) )
560 Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
564 %************************************************************************
566 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
568 %************************************************************************
570 Call the constructor Ids when building explicit lists, so that they
571 interact well with rules.
574 mkNilExpr :: Type -> CoreExpr
575 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
577 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
578 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
582 %************************************************************************
584 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
586 %************************************************************************
588 Generally, we handle pattern matching failure like this: let-bind a
589 fail-variable, and use that variable if the thing fails:
591 let fail.33 = error "Help"
602 If the case can't fail, then there'll be no mention of @fail.33@, and the
603 simplifier will later discard it.
606 If it can fail in only one way, then the simplifier will inline it.
609 Only if it is used more than once will the let-binding remain.
612 There's a problem when the result of the case expression is of
613 unboxed type. Then the type of @fail.33@ is unboxed too, and
614 there is every chance that someone will change the let into a case:
620 which is of course utterly wrong. Rather than drop the condition that
621 only boxed types can be let-bound, we just turn the fail into a function
622 for the primitive case:
624 let fail.33 :: Void -> Int#
625 fail.33 = \_ -> error "Help"
634 Now @fail.33@ is a function, so it can be let-bound.
637 mkFailurePair :: CoreExpr -- Result type of the whole case expression
638 -> DsM (CoreBind, -- Binds the newly-created fail variable
639 -- to either the expression or \ _ -> expression
640 CoreExpr) -- Either the fail variable, or fail variable
641 -- applied to unit tuple
644 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
645 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
646 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
647 App (Var fail_fun_var) (Var unitDataConId))
650 = newFailLocalDs ty `thenDs` \ fail_var ->
651 returnDs (NonRec fail_var expr, Var fail_var)