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 MkId ( rebuildConArgs )
45 import Id ( idType, Id, mkWildId )
46 import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
47 import TyCon ( isNewTyCon, tyConDataCons )
48 import DataCon ( DataCon, dataConStrictMarks, dataConId )
49 import Type ( mkFunTy, isUnLiftedType, splitAlgTyConApp,
52 import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
53 import TysWiredIn ( nilDataCon, consDataCon,
56 unitDataConId, unitTy,
58 intTy, intDataCon, smallIntegerDataCon,
59 floatTy, floatDataCon,
60 doubleTy, doubleDataCon,
63 import BasicTypes ( Boxity(..) )
64 import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
65 import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
66 plusIntegerName, timesIntegerName )
68 import UnicodeUtil ( stringToUtf8 )
73 %************************************************************************
75 \subsection{Tidying lit pats}
77 %************************************************************************
80 tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
81 tidyLitPat (HsChar c) pat = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
82 tidyLitPat lit pat = pat
84 tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
85 tidyNPat (HsString s) _ pat
86 | _LENGTH_ s <= 1 -- Short string literals only
87 = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
88 (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
89 -- The stringTy is the type of the whole pattern, not
90 -- the type to instantiate (:) or [] with!
92 mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
94 tidyNPat lit lit_ty default_pat
95 | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
96 | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
97 | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
98 | otherwise = default_pat
101 mk_int (HsInteger i) = HsIntPrim i
103 mk_float (HsInteger i) = HsFloatPrim (fromInteger i)
104 mk_float (HsRat f _) = HsFloatPrim f
106 mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
107 mk_double (HsRat f _) = HsDoublePrim f
111 %************************************************************************
113 \subsection{Building lets}
115 %************************************************************************
117 Use case, not let for unlifted types. The simplifier will turn some
121 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
122 mkDsLet (NonRec bndr rhs) body
123 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
127 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
128 mkDsLets binds body = foldr mkDsLet body binds
132 %************************************************************************
134 \subsection{ Selecting match variables}
136 %************************************************************************
138 We're about to match against some patterns. We want to make some
139 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
140 hand, which should indeed be bound to the pattern as a whole, then use it;
141 otherwise, make one up.
144 selectMatchVar :: TypecheckedPat -> DsM Id
145 selectMatchVar (VarPat var) = returnDs var
146 selectMatchVar (AsPat var pat) = returnDs var
147 selectMatchVar (LazyPat pat) = selectMatchVar pat
148 selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
152 %************************************************************************
154 %* type synonym EquationInfo and access functions for its pieces *
156 %************************************************************************
157 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
159 The ``equation info'' used by @match@ is relatively complicated and
160 worthy of a type synonym and a few handy functions.
165 type EqnSet = UniqSet EqnNo
169 EqnNo -- The number of the equation
171 DsMatchContext -- The context info is used when producing warnings
172 -- about shadowed patterns. It's the context
173 -- of the *first* thing matched in this group.
174 -- Should perhaps be a list of them all!
176 [TypecheckedPat] -- The patterns for an eqn
178 MatchResult -- Encapsulates the guards and bindings
184 CanItFail -- Tells whether the failure expression is used
185 (CoreExpr -> DsM CoreExpr)
186 -- Takes a expression to plug in at the
187 -- failure point(s). The expression should
190 data CanItFail = CanFail | CantFail
192 orFail CantFail CantFail = CantFail
196 Functions on MatchResults
199 cantFailMatchResult :: CoreExpr -> MatchResult
200 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
202 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
203 extractMatchResult (MatchResult CantFail match_fn) fail_expr
204 = match_fn (error "It can't fail!")
206 extractMatchResult (MatchResult CanFail match_fn) fail_expr
207 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
208 match_fn if_it_fails `thenDs` \ body ->
209 returnDs (mkDsLet fail_bind body)
212 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
213 combineMatchResults (MatchResult CanFail body_fn1)
214 (MatchResult can_it_fail2 body_fn2)
215 = MatchResult can_it_fail2 body_fn
217 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
218 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
219 body_fn1 duplicatable_expr `thenDs` \ body1 ->
220 returnDs (Let fail_bind body1)
222 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
226 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
227 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
228 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
229 returnDs (encl_fn body))
231 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
232 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
233 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
237 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
238 mkCoLetsMatchResult binds match_result
239 = adjustMatchResult (mkDsLets binds) match_result
242 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
243 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
244 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
245 returnDs (mkIfThenElse pred_expr body fail))
247 mkCoPrimCaseMatchResult :: Id -- Scrutinee
248 -> [(Literal, MatchResult)] -- Alternatives
250 mkCoPrimCaseMatchResult var match_alts
251 = MatchResult CanFail mk_case
254 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
255 returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
257 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
258 returnDs (LitAlt lit, [], body)
261 mkCoAlgCaseMatchResult :: Id -- Scrutinee
262 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
265 mkCoAlgCaseMatchResult var match_alts
266 | isNewTyCon tycon -- Newtype case; use a let
267 = ASSERT( newtype_sanity )
268 mkCoLetsMatchResult [coercion_bind] match_result
270 | otherwise -- Datatype case; use a case
271 = MatchResult fail_flag mk_case
274 scrut_ty = idType var
275 (tycon, _, _) = splitAlgTyConApp scrut_ty
278 (_, arg_ids, match_result) = head match_alts
279 arg_id = head arg_ids
280 coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id)
283 newtype_sanity = null (tail match_alts) && null (tail arg_ids)
285 -- Stuff for data types
286 data_cons = tyConDataCons tycon
288 match_results = [match_result | (_,_,match_result) <- match_alts]
290 fail_flag | exhaustive_case
291 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
295 wild_var = mkWildId (idType var)
296 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
297 returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
299 mk_alt fail (con, args, MatchResult _ body_fn)
300 = body_fn fail `thenDs` \ body ->
301 getUniquesDs `thenDs` \ us ->
303 (binds, real_args) = rebuildConArgs args (dataConStrictMarks con) us
305 returnDs (DataAlt con, real_args, mkDsLets binds body)
307 mk_default fail | exhaustive_case = []
308 | otherwise = [(DEFAULT, [], fail)]
310 un_mentioned_constructors
311 = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
312 exhaustive_case = isEmptyUniqSet un_mentioned_constructors
316 %************************************************************************
318 \subsection{Desugarer's versions of some Core functions}
320 %************************************************************************
323 mkErrorAppDs :: Id -- The error function
324 -> Type -- Type to which it should be applied
325 -> String -- The error message string to pass
328 mkErrorAppDs err_id ty msg
329 = getSrcLocDs `thenDs` \ src_loc ->
331 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
333 mkStringLit full_msg `thenDs` \ core_msg ->
334 returnDs (mkApps (Var err_id) [Type ty, core_msg])
338 *************************************************************
340 \subsection{Making literals}
342 %************************************************************************
345 mkIntegerLit :: Integer -> DsM CoreExpr
347 | inIntRange i -- Small enough, so start from an Int
348 = returnDs (mkSmallIntegerLit i)
350 -- Special case for integral literals with a large magnitude:
351 -- They are transformed into an expression involving only smaller
352 -- integral literals. This improves constant folding.
354 | otherwise -- Big, so start from a string
355 = dsLookupGlobalValue plusIntegerName `thenDs` \ plus_id ->
356 dsLookupGlobalValue timesIntegerName `thenDs` \ times_id ->
358 plus a b = Var plus_id `App` a `App` b
359 times a b = Var times_id `App` a `App` b
361 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
362 horner :: Integer -> Integer -> CoreExpr
363 horner b i | abs q <= 1 = if r == 0 || r == i
364 then mkSmallIntegerLit i
365 else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
366 | r == 0 = horner b q `times` mkSmallIntegerLit b
367 | otherwise = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
369 (q,r) = i `quotRem` b
372 returnDs (horner tARGET_MAX_INT i)
374 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
376 mkStringLit :: String -> DsM CoreExpr
377 mkStringLit str = mkStringLitFS (_PK_ str)
379 mkStringLitFS :: FAST_STRING -> DsM CoreExpr
382 = returnDs (mkNilExpr charTy)
386 the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))]
388 returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
391 = dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id ->
392 returnDs (App (Var unpack_id) (Lit (MachStr str)))
395 = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id ->
396 returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
399 chars = _UNPK_INT_ str
400 safeChar c = c >= 1 && c <= 0xFF
404 %************************************************************************
406 \subsection[mkSelectorBind]{Make a selector bind}
408 %************************************************************************
410 This is used in various places to do with lazy patterns.
411 For each binder $b$ in the pattern, we create a binding:
413 b = case v of pat' -> b'
415 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
417 ToDo: making these bindings should really depend on whether there's
418 much work to be done per binding. If the pattern is complex, it
419 should be de-mangled once, into a tuple (and then selected from).
420 Otherwise the demangling can be in-line in the bindings (as here).
422 Boring! Boring! One error message per binder. The above ToDo is
423 even more helpful. Something very similar happens for pattern-bound
427 mkSelectorBinds :: TypecheckedPat -- The pattern
428 -> CoreExpr -- Expression to which the pattern is bound
429 -> DsM [(Id,CoreExpr)]
431 mkSelectorBinds (VarPat v) val_expr
432 = returnDs [(v, val_expr)]
434 mkSelectorBinds pat val_expr
435 | length binders == 1 || is_simple_pat pat
436 = newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
438 -- For the error message we don't use mkErrorAppDs to avoid
439 -- duplicating the string literal each time
440 newSysLocalDs stringTy `thenDs` \ msg_var ->
441 getSrcLocDs `thenDs` \ src_loc ->
443 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
445 mkStringLit full_msg `thenDs` \ core_msg ->
446 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
447 returnDs ( (val_var, val_expr) :
448 (msg_var, core_msg) :
453 = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
454 `thenDs` \ error_expr ->
455 matchSimply val_expr PatBindRhs pat local_tuple error_expr
456 `thenDs` \ tuple_expr ->
457 newSysLocalDs tuple_ty
458 `thenDs` \ tuple_var ->
461 (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
463 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
465 binders = collectTypedPatBinders pat
466 local_tuple = mkTupleExpr binders
467 tuple_ty = exprType local_tuple
469 mk_bind scrut_var msg_var bndr_var
470 -- (mk_bind sv bv) generates
471 -- bv = case sv of { pat -> bv; other -> error-msg }
472 -- Remember, pat binds bv
473 = matchSimply (Var scrut_var) PatBindRhs pat
474 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
475 returnDs (bndr_var, rhs_expr)
477 binder_ty = idType bndr_var
478 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
480 is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
481 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
482 is_simple_pat (VarPat _) = True
483 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
484 is_simple_pat other = False
486 is_triv_pat (VarPat v) = True
487 is_triv_pat (WildPat _) = True
488 is_triv_pat other = False
492 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
493 has only one element, it is the identity function.
496 mkTupleExpr :: [Id] -> CoreExpr
498 mkTupleExpr [] = Var unitDataConId
499 mkTupleExpr [id] = Var id
500 mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids))
501 (map (Type . idType) ids ++ [ Var i | i <- ids ])
505 @mkTupleSelector@ builds a selector which scrutises the given
506 expression and extracts the one name from the list given.
507 If you want the no-shadowing rule to apply, the caller
508 is responsible for making sure that none of these names
511 If there is just one id in the ``tuple'', then the selector is
515 mkTupleSelector :: [Id] -- The tuple args
516 -> Id -- The selected one
517 -> Id -- A variable of the same type as the scrutinee
518 -> CoreExpr -- Scrutinee
521 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
522 = ASSERT(var == should_be_the_same_var)
525 mkTupleSelector vars the_var scrut_var scrut
526 = ASSERT( not (null vars) )
527 Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
531 %************************************************************************
533 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
535 %************************************************************************
537 Call the constructor Ids when building explicit lists, so that they
538 interact well with rules.
541 mkNilExpr :: Type -> CoreExpr
542 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
544 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
545 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
549 %************************************************************************
551 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
553 %************************************************************************
555 Generally, we handle pattern matching failure like this: let-bind a
556 fail-variable, and use that variable if the thing fails:
558 let fail.33 = error "Help"
569 If the case can't fail, then there'll be no mention of @fail.33@, and the
570 simplifier will later discard it.
573 If it can fail in only one way, then the simplifier will inline it.
576 Only if it is used more than once will the let-binding remain.
579 There's a problem when the result of the case expression is of
580 unboxed type. Then the type of @fail.33@ is unboxed too, and
581 there is every chance that someone will change the let into a case:
587 which is of course utterly wrong. Rather than drop the condition that
588 only boxed types can be let-bound, we just turn the fail into a function
589 for the primitive case:
591 let fail.33 :: Void -> Int#
592 fail.33 = \_ -> error "Help"
601 Now @fail.33@ is a function, so it can be let-bound.
604 mkFailurePair :: CoreExpr -- Result type of the whole case expression
605 -> DsM (CoreBind, -- Binds the newly-created fail variable
606 -- to either the expression or \ _ -> expression
607 CoreExpr) -- Either the fail variable, or fail variable
608 -- applied to unit tuple
611 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
612 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
613 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
614 App (Var fail_fun_var) (Var unitDataConId))
617 = newFailLocalDs ty `thenDs` \ fail_var ->
618 returnDs (NonRec fail_var expr, Var fail_var)