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, outPatType, collectTypedPatBinders )
41 import CoreUtils ( exprType, mkIfThenElse )
42 import PrelInfo ( iRREFUT_PAT_ERROR_ID )
43 import MkId ( rebuildConArgs )
44 import Id ( idType, Id, mkWildId )
45 import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
46 import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon )
47 import DataCon ( DataCon, dataConStrictMarks, dataConId )
48 import Type ( mkFunTy, isUnLiftedType, Type )
49 import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
50 import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
51 import TysWiredIn ( nilDataCon, consDataCon,
53 unitDataConId, unitTy,
55 intDataCon, smallIntegerDataCon,
60 import BasicTypes ( Boxity(..) )
61 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
62 import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
63 plusIntegerName, timesIntegerName )
65 import UnicodeUtil ( stringToUtf8 )
70 %************************************************************************
72 \subsection{Tidying lit pats}
74 %************************************************************************
77 tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
78 tidyLitPat (HsChar c) pat = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
79 tidyLitPat lit pat = pat
81 tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
82 tidyNPat (HsString s) _ pat
83 | _LENGTH_ s <= 1 -- Short string literals only
84 = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
85 (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
86 -- The stringTy is the type of the whole pattern, not
87 -- the type to instantiate (:) or [] with!
89 mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
91 tidyNPat lit lit_ty default_pat
92 | isIntTy lit_ty = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
93 | isFloatTy lit_ty = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
94 | isDoubleTy lit_ty = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
95 | otherwise = default_pat
98 mk_int (HsInteger i) = HsIntPrim i
100 mk_float (HsInteger i) = HsFloatPrim (fromInteger i)
101 mk_float (HsRat f _) = HsFloatPrim f
103 mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
104 mk_double (HsRat f _) = HsDoublePrim f
108 %************************************************************************
110 \subsection{Building lets}
112 %************************************************************************
114 Use case, not let for unlifted types. The simplifier will turn some
118 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
119 mkDsLet (NonRec bndr rhs) body
120 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
124 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
125 mkDsLets binds body = foldr mkDsLet body binds
129 %************************************************************************
131 \subsection{ Selecting match variables}
133 %************************************************************************
135 We're about to match against some patterns. We want to make some
136 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
137 hand, which should indeed be bound to the pattern as a whole, then use it;
138 otherwise, make one up.
141 selectMatchVar :: TypecheckedPat -> DsM Id
142 selectMatchVar (VarPat var) = returnDs var
143 selectMatchVar (AsPat var pat) = returnDs var
144 selectMatchVar (LazyPat pat) = selectMatchVar pat
145 selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
149 %************************************************************************
151 %* type synonym EquationInfo and access functions for its pieces *
153 %************************************************************************
154 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
156 The ``equation info'' used by @match@ is relatively complicated and
157 worthy of a type synonym and a few handy functions.
162 type EqnSet = UniqSet EqnNo
166 EqnNo -- The number of the equation
168 DsMatchContext -- The context info is used when producing warnings
169 -- about shadowed patterns. It's the context
170 -- of the *first* thing matched in this group.
171 -- Should perhaps be a list of them all!
173 [TypecheckedPat] -- The patterns for an eqn
175 MatchResult -- Encapsulates the guards and bindings
181 CanItFail -- Tells whether the failure expression is used
182 (CoreExpr -> DsM CoreExpr)
183 -- Takes a expression to plug in at the
184 -- failure point(s). The expression should
187 data CanItFail = CanFail | CantFail
189 orFail CantFail CantFail = CantFail
193 Functions on MatchResults
196 cantFailMatchResult :: CoreExpr -> MatchResult
197 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
199 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
200 extractMatchResult (MatchResult CantFail match_fn) fail_expr
201 = match_fn (error "It can't fail!")
203 extractMatchResult (MatchResult CanFail match_fn) fail_expr
204 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
205 match_fn if_it_fails `thenDs` \ body ->
206 returnDs (mkDsLet fail_bind body)
209 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
210 combineMatchResults (MatchResult CanFail body_fn1)
211 (MatchResult can_it_fail2 body_fn2)
212 = MatchResult can_it_fail2 body_fn
214 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
215 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
216 body_fn1 duplicatable_expr `thenDs` \ body1 ->
217 returnDs (Let fail_bind body1)
219 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
223 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
224 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
225 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
226 returnDs (encl_fn body))
228 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
229 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
230 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
234 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
235 mkCoLetsMatchResult binds match_result
236 = adjustMatchResult (mkDsLets binds) match_result
239 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
240 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
241 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
242 returnDs (mkIfThenElse pred_expr body fail))
244 mkCoPrimCaseMatchResult :: Id -- Scrutinee
245 -> [(Literal, MatchResult)] -- Alternatives
247 mkCoPrimCaseMatchResult var match_alts
248 = MatchResult CanFail mk_case
251 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
252 returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts))
254 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
255 returnDs (LitAlt lit, [], body)
258 mkCoAlgCaseMatchResult :: Id -- Scrutinee
259 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
262 mkCoAlgCaseMatchResult var match_alts
263 | isNewTyCon tycon -- Newtype case; use a let
264 = ASSERT( null (tail match_alts) && null (tail arg_ids) )
265 mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result
267 | otherwise -- Datatype case; use a case
268 = MatchResult fail_flag mk_case
271 scrut_ty = idType var
272 tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here
275 (_, arg_ids, match_result) = head match_alts
276 arg_id = head arg_ids
278 newtype_rhs | isRecursiveTyCon tycon -- Recursive case; need a case
279 = Note (Coerce (idType arg_id) scrut_ty) (Var var)
280 | otherwise -- Normal case (newtype is transparent)
283 -- Stuff for data types
284 data_cons = tyConDataCons tycon
286 match_results = [match_result | (_,_,match_result) <- match_alts]
288 fail_flag | exhaustive_case
289 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
293 wild_var = mkWildId (idType var)
294 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
295 returnDs (Case (Var var) wild_var (mk_default fail ++ alts))
297 mk_alt fail (con, args, MatchResult _ body_fn)
298 = body_fn fail `thenDs` \ body ->
299 getUniquesDs `thenDs` \ us ->
301 (binds, real_args) = rebuildConArgs args (dataConStrictMarks con) us
303 returnDs (DataAlt con, real_args, mkDsLets binds body)
305 mk_default fail | exhaustive_case = []
306 | otherwise = [(DEFAULT, [], fail)]
308 un_mentioned_constructors
309 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
310 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
314 %************************************************************************
316 \subsection{Desugarer's versions of some Core functions}
318 %************************************************************************
321 mkErrorAppDs :: Id -- The error function
322 -> Type -- Type to which it should be applied
323 -> String -- The error message string to pass
326 mkErrorAppDs err_id ty msg
327 = getSrcLocDs `thenDs` \ src_loc ->
329 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
331 mkStringLit full_msg `thenDs` \ core_msg ->
332 returnDs (mkApps (Var err_id) [Type ty, core_msg])
336 *************************************************************
338 \subsection{Making literals}
340 %************************************************************************
343 mkIntegerLit :: Integer -> DsM CoreExpr
345 | inIntRange i -- Small enough, so start from an Int
346 = returnDs (mkSmallIntegerLit i)
348 -- Special case for integral literals with a large magnitude:
349 -- They are transformed into an expression involving only smaller
350 -- integral literals. This improves constant folding.
352 | otherwise -- Big, so start from a string
353 = dsLookupGlobalValue plusIntegerName `thenDs` \ plus_id ->
354 dsLookupGlobalValue timesIntegerName `thenDs` \ times_id ->
356 plus a b = Var plus_id `App` a `App` b
357 times a b = Var times_id `App` a `App` b
359 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
360 horner :: Integer -> Integer -> CoreExpr
361 horner b i | abs q <= 1 = if r == 0 || r == i
362 then mkSmallIntegerLit i
363 else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
364 | r == 0 = horner b q `times` mkSmallIntegerLit b
365 | otherwise = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
367 (q,r) = i `quotRem` b
370 returnDs (horner tARGET_MAX_INT i)
372 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
374 mkStringLit :: String -> DsM CoreExpr
375 mkStringLit str = mkStringLitFS (_PK_ str)
377 mkStringLitFS :: FAST_STRING -> DsM CoreExpr
380 = returnDs (mkNilExpr charTy)
384 the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))]
386 returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
389 = dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id ->
390 returnDs (App (Var unpack_id) (Lit (MachStr str)))
393 = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id ->
394 returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
397 chars = _UNPK_INT_ str
398 safeChar c = c >= 1 && c <= 0xFF
402 %************************************************************************
404 \subsection[mkSelectorBind]{Make a selector bind}
406 %************************************************************************
408 This is used in various places to do with lazy patterns.
409 For each binder $b$ in the pattern, we create a binding:
411 b = case v of pat' -> b'
413 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
415 ToDo: making these bindings should really depend on whether there's
416 much work to be done per binding. If the pattern is complex, it
417 should be de-mangled once, into a tuple (and then selected from).
418 Otherwise the demangling can be in-line in the bindings (as here).
420 Boring! Boring! One error message per binder. The above ToDo is
421 even more helpful. Something very similar happens for pattern-bound
425 mkSelectorBinds :: TypecheckedPat -- The pattern
426 -> CoreExpr -- Expression to which the pattern is bound
427 -> DsM [(Id,CoreExpr)]
429 mkSelectorBinds (VarPat v) val_expr
430 = returnDs [(v, val_expr)]
432 mkSelectorBinds pat val_expr
433 | length binders == 1 || is_simple_pat pat
434 = newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
436 -- For the error message we don't use mkErrorAppDs to avoid
437 -- duplicating the string literal each time
438 newSysLocalDs stringTy `thenDs` \ msg_var ->
439 getSrcLocDs `thenDs` \ src_loc ->
441 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
443 mkStringLit full_msg `thenDs` \ core_msg ->
444 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
445 returnDs ( (val_var, val_expr) :
446 (msg_var, core_msg) :
451 = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
452 `thenDs` \ error_expr ->
453 matchSimply val_expr PatBindRhs pat local_tuple error_expr
454 `thenDs` \ tuple_expr ->
455 newSysLocalDs tuple_ty
456 `thenDs` \ tuple_var ->
459 (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
461 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
463 binders = collectTypedPatBinders pat
464 local_tuple = mkTupleExpr binders
465 tuple_ty = exprType local_tuple
467 mk_bind scrut_var msg_var bndr_var
468 -- (mk_bind sv bv) generates
469 -- bv = case sv of { pat -> bv; other -> error-msg }
470 -- Remember, pat binds bv
471 = matchSimply (Var scrut_var) PatBindRhs pat
472 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
473 returnDs (bndr_var, rhs_expr)
475 binder_ty = idType bndr_var
476 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
478 is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
479 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
480 is_simple_pat (VarPat _) = True
481 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
482 is_simple_pat other = False
484 is_triv_pat (VarPat v) = True
485 is_triv_pat (WildPat _) = True
486 is_triv_pat other = False
490 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
491 has only one element, it is the identity function.
494 mkTupleExpr :: [Id] -> CoreExpr
496 mkTupleExpr [] = Var unitDataConId
497 mkTupleExpr [id] = Var id
498 mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids))
499 (map (Type . idType) ids ++ [ Var i | i <- ids ])
503 @mkTupleSelector@ builds a selector which scrutises the given
504 expression and extracts the one name from the list given.
505 If you want the no-shadowing rule to apply, the caller
506 is responsible for making sure that none of these names
509 If there is just one id in the ``tuple'', then the selector is
513 mkTupleSelector :: [Id] -- The tuple args
514 -> Id -- The selected one
515 -> Id -- A variable of the same type as the scrutinee
516 -> CoreExpr -- Scrutinee
519 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
520 = ASSERT(var == should_be_the_same_var)
523 mkTupleSelector vars the_var scrut_var scrut
524 = ASSERT( not (null vars) )
525 Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
529 %************************************************************************
531 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
533 %************************************************************************
535 Call the constructor Ids when building explicit lists, so that they
536 interact well with rules.
539 mkNilExpr :: Type -> CoreExpr
540 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
542 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
543 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
547 %************************************************************************
549 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
551 %************************************************************************
553 Generally, we handle pattern matching failure like this: let-bind a
554 fail-variable, and use that variable if the thing fails:
556 let fail.33 = error "Help"
567 If the case can't fail, then there'll be no mention of @fail.33@, and the
568 simplifier will later discard it.
571 If it can fail in only one way, then the simplifier will inline it.
574 Only if it is used more than once will the let-binding remain.
577 There's a problem when the result of the case expression is of
578 unboxed type. Then the type of @fail.33@ is unboxed too, and
579 there is every chance that someone will change the let into a case:
585 which is of course utterly wrong. Rather than drop the condition that
586 only boxed types can be let-bound, we just turn the fail into a function
587 for the primitive case:
589 let fail.33 :: Void -> Int#
590 fail.33 = \_ -> error "Help"
599 Now @fail.33@ is a function, so it can be let-bound.
602 mkFailurePair :: CoreExpr -- Result type of the whole case expression
603 -> DsM (CoreBind, -- Binds the newly-created fail variable
604 -- to either the expression or \ _ -> expression
605 CoreExpr) -- Either the fail variable, or fail variable
606 -- applied to unit tuple
609 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
610 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
611 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
612 App (Var fail_fun_var) (Var unitDataConId))
615 = newFailLocalDs ty `thenDs` \ fail_var ->
616 returnDs (NonRec fail_var expr, Var fail_var)