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 )
66 import Util ( isSingleton )
71 %************************************************************************
73 \subsection{Tidying lit pats}
75 %************************************************************************
78 tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat
79 tidyLitPat (HsChar c) pat = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
80 tidyLitPat lit pat = pat
82 tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat
83 tidyNPat (HsString s) _ pat
84 | _LENGTH_ s <= 1 -- Short string literals only
85 = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat])
86 (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s)
87 -- The stringTy is the type of the whole pattern, not
88 -- the type to instantiate (:) or [] with!
90 mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
92 tidyNPat lit lit_ty default_pat
93 | isIntTy lit_ty = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy]
94 | isFloatTy lit_ty = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
95 | isDoubleTy lit_ty = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
96 | otherwise = default_pat
99 mk_int (HsInteger i) = HsIntPrim i
101 mk_float (HsInteger i) = HsFloatPrim (fromInteger i)
102 mk_float (HsRat f _) = HsFloatPrim f
104 mk_double (HsInteger i) = HsDoublePrim (fromInteger i)
105 mk_double (HsRat f _) = HsDoublePrim f
109 %************************************************************************
111 \subsection{Building lets}
113 %************************************************************************
115 Use case, not let for unlifted types. The simplifier will turn some
119 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
120 mkDsLet (NonRec bndr rhs) body
121 | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
125 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
126 mkDsLets binds body = foldr mkDsLet body binds
130 %************************************************************************
132 \subsection{ Selecting match variables}
134 %************************************************************************
136 We're about to match against some patterns. We want to make some
137 @Ids@ to use as match variables. If a pattern has an @Id@ readily at
138 hand, which should indeed be bound to the pattern as a whole, then use it;
139 otherwise, make one up.
142 selectMatchVar :: TypecheckedPat -> DsM Id
143 selectMatchVar (VarPat var) = returnDs var
144 selectMatchVar (AsPat var pat) = returnDs var
145 selectMatchVar (LazyPat pat) = selectMatchVar pat
146 selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
150 %************************************************************************
152 %* type synonym EquationInfo and access functions for its pieces *
154 %************************************************************************
155 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
157 The ``equation info'' used by @match@ is relatively complicated and
158 worthy of a type synonym and a few handy functions.
163 type EqnSet = UniqSet EqnNo
167 EqnNo -- The number of the equation
169 DsMatchContext -- The context info is used when producing warnings
170 -- about shadowed patterns. It's the context
171 -- of the *first* thing matched in this group.
172 -- Should perhaps be a list of them all!
174 [TypecheckedPat] -- The patterns for an eqn
176 MatchResult -- Encapsulates the guards and bindings
182 CanItFail -- Tells whether the failure expression is used
183 (CoreExpr -> DsM CoreExpr)
184 -- Takes a expression to plug in at the
185 -- failure point(s). The expression should
188 data CanItFail = CanFail | CantFail
190 orFail CantFail CantFail = CantFail
194 Functions on MatchResults
197 cantFailMatchResult :: CoreExpr -> MatchResult
198 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
200 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
201 extractMatchResult (MatchResult CantFail match_fn) fail_expr
202 = match_fn (error "It can't fail!")
204 extractMatchResult (MatchResult CanFail match_fn) fail_expr
205 = mkFailurePair fail_expr `thenDs` \ (fail_bind, if_it_fails) ->
206 match_fn if_it_fails `thenDs` \ body ->
207 returnDs (mkDsLet fail_bind body)
210 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
211 combineMatchResults (MatchResult CanFail body_fn1)
212 (MatchResult can_it_fail2 body_fn2)
213 = MatchResult can_it_fail2 body_fn
215 body_fn fail = body_fn2 fail `thenDs` \ body2 ->
216 mkFailurePair body2 `thenDs` \ (fail_bind, duplicatable_expr) ->
217 body_fn1 duplicatable_expr `thenDs` \ body1 ->
218 returnDs (Let fail_bind body1)
220 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
224 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
225 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
226 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
227 returnDs (encl_fn body))
229 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
230 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
231 = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
235 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
236 mkCoLetsMatchResult binds match_result
237 = adjustMatchResult (mkDsLets binds) match_result
240 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
241 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
242 = MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
243 returnDs (mkIfThenElse pred_expr body fail))
245 mkCoPrimCaseMatchResult :: Id -- Scrutinee
246 -> [(Literal, MatchResult)] -- Alternatives
248 mkCoPrimCaseMatchResult var match_alts
249 = MatchResult CanFail mk_case
252 = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
253 returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts))
255 mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
256 returnDs (LitAlt lit, [], body)
259 mkCoAlgCaseMatchResult :: Id -- Scrutinee
260 -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
263 mkCoAlgCaseMatchResult var match_alts
264 | isNewTyCon tycon -- Newtype case; use a let
265 = ASSERT( null (tail match_alts) && null (tail arg_ids) )
266 mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result
268 | otherwise -- Datatype case; use a case
269 = MatchResult fail_flag mk_case
272 scrut_ty = idType var
273 tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here
276 (_, arg_ids, match_result) = head match_alts
277 arg_id = head arg_ids
279 newtype_rhs | isRecursiveTyCon tycon -- Recursive case; need a case
280 = Note (Coerce (idType arg_id) scrut_ty) (Var var)
281 | otherwise -- Normal case (newtype is transparent)
284 -- Stuff for data types
285 data_cons = tyConDataCons tycon
287 match_results = [match_result | (_,_,match_result) <- match_alts]
289 fail_flag | exhaustive_case
290 = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
294 wild_var = mkWildId (idType var)
295 mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts ->
296 returnDs (Case (Var var) wild_var (mk_default fail ++ alts))
298 mk_alt fail (con, args, MatchResult _ body_fn)
299 = body_fn fail `thenDs` \ body ->
300 getUniquesDs `thenDs` \ us ->
302 (binds, real_args) = rebuildConArgs args (dataConStrictMarks con) us
304 returnDs (DataAlt con, real_args, mkDsLets binds 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
315 %************************************************************************
317 \subsection{Desugarer's versions of some Core functions}
319 %************************************************************************
322 mkErrorAppDs :: Id -- The error function
323 -> Type -- Type to which it should be applied
324 -> String -- The error message string to pass
327 mkErrorAppDs err_id ty msg
328 = getSrcLocDs `thenDs` \ src_loc ->
330 full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
332 mkStringLit full_msg `thenDs` \ core_msg ->
333 returnDs (mkApps (Var err_id) [Type ty, core_msg])
337 *************************************************************
339 \subsection{Making literals}
341 %************************************************************************
344 mkIntegerLit :: Integer -> DsM CoreExpr
346 | inIntRange i -- Small enough, so start from an Int
347 = returnDs (mkSmallIntegerLit i)
349 -- Special case for integral literals with a large magnitude:
350 -- They are transformed into an expression involving only smaller
351 -- integral literals. This improves constant folding.
353 | otherwise -- Big, so start from a string
354 = dsLookupGlobalValue plusIntegerName `thenDs` \ plus_id ->
355 dsLookupGlobalValue timesIntegerName `thenDs` \ times_id ->
357 plus a b = Var plus_id `App` a `App` b
358 times a b = Var times_id `App` a `App` b
360 -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
361 horner :: Integer -> Integer -> CoreExpr
362 horner b i | abs q <= 1 = if r == 0 || r == i
363 then mkSmallIntegerLit i
364 else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r)
365 | r == 0 = horner b q `times` mkSmallIntegerLit b
366 | otherwise = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b)
368 (q,r) = i `quotRem` b
371 returnDs (horner tARGET_MAX_INT i)
373 mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i]
375 mkStringLit :: String -> DsM CoreExpr
376 mkStringLit str = mkStringLitFS (_PK_ str)
378 mkStringLitFS :: FAST_STRING -> DsM CoreExpr
381 = returnDs (mkNilExpr charTy)
385 the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_INT_ str))]
387 returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
390 = dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id ->
391 returnDs (App (Var unpack_id) (Lit (MachStr str)))
394 = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id ->
395 returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
398 chars = _UNPK_INT_ str
399 safeChar c = c >= 1 && c <= 0xFF
403 %************************************************************************
405 \subsection[mkSelectorBind]{Make a selector bind}
407 %************************************************************************
409 This is used in various places to do with lazy patterns.
410 For each binder $b$ in the pattern, we create a binding:
412 b = case v of pat' -> b'
414 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
416 ToDo: making these bindings should really depend on whether there's
417 much work to be done per binding. If the pattern is complex, it
418 should be de-mangled once, into a tuple (and then selected from).
419 Otherwise the demangling can be in-line in the bindings (as here).
421 Boring! Boring! One error message per binder. The above ToDo is
422 even more helpful. Something very similar happens for pattern-bound
426 mkSelectorBinds :: TypecheckedPat -- The pattern
427 -> CoreExpr -- Expression to which the pattern is bound
428 -> DsM [(Id,CoreExpr)]
430 mkSelectorBinds (VarPat v) val_expr
431 = returnDs [(v, val_expr)]
433 mkSelectorBinds pat val_expr
434 | isSingleton binders || is_simple_pat pat
435 = newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
437 -- For the error message we don't use mkErrorAppDs to avoid
438 -- duplicating the string literal each time
439 newSysLocalDs stringTy `thenDs` \ msg_var ->
440 getSrcLocDs `thenDs` \ src_loc ->
442 full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
444 mkStringLit full_msg `thenDs` \ core_msg ->
445 mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
446 returnDs ( (val_var, val_expr) :
447 (msg_var, core_msg) :
452 = mkErrorAppDs iRREFUT_PAT_ERROR_ID
453 tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr ->
454 matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr ->
455 newSysLocalDs tuple_ty `thenDs` \ tuple_var ->
458 = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
460 returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
462 binders = collectTypedPatBinders pat
463 local_tuple = mkTupleExpr binders
464 tuple_ty = exprType local_tuple
466 mk_bind scrut_var msg_var bndr_var
467 -- (mk_bind sv bv) generates
468 -- bv = case sv of { pat -> bv; other -> error-msg }
469 -- Remember, pat binds bv
470 = matchSimply (Var scrut_var) PatBindRhs pat
471 (Var bndr_var) error_expr `thenDs` \ rhs_expr ->
472 returnDs (bndr_var, rhs_expr)
474 binder_ty = idType bndr_var
475 error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
477 is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
478 is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
479 is_simple_pat (VarPat _) = True
480 is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
481 is_simple_pat other = False
483 is_triv_pat (VarPat v) = True
484 is_triv_pat (WildPat _) = True
485 is_triv_pat other = False
489 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
490 has only one element, it is the identity function.
493 mkTupleExpr :: [Id] -> CoreExpr
495 mkTupleExpr [] = Var unitDataConId
496 mkTupleExpr [id] = Var id
497 mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids))
498 (map (Type . idType) ids ++ [ Var i | i <- ids ])
502 @mkTupleSelector@ builds a selector which scrutises the given
503 expression and extracts the one name from the list given.
504 If you want the no-shadowing rule to apply, the caller
505 is responsible for making sure that none of these names
508 If there is just one id in the ``tuple'', then the selector is
512 mkTupleSelector :: [Id] -- The tuple args
513 -> Id -- The selected one
514 -> Id -- A variable of the same type as the scrutinee
515 -> CoreExpr -- Scrutinee
518 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
519 = ASSERT(var == should_be_the_same_var)
522 mkTupleSelector vars the_var scrut_var scrut
523 = ASSERT( not (null vars) )
524 Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
528 %************************************************************************
530 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
532 %************************************************************************
534 Call the constructor Ids when building explicit lists, so that they
535 interact well with rules.
538 mkNilExpr :: Type -> CoreExpr
539 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
541 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
542 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
546 %************************************************************************
548 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
550 %************************************************************************
552 Generally, we handle pattern matching failure like this: let-bind a
553 fail-variable, and use that variable if the thing fails:
555 let fail.33 = error "Help"
566 If the case can't fail, then there'll be no mention of @fail.33@, and the
567 simplifier will later discard it.
570 If it can fail in only one way, then the simplifier will inline it.
573 Only if it is used more than once will the let-binding remain.
576 There's a problem when the result of the case expression is of
577 unboxed type. Then the type of @fail.33@ is unboxed too, and
578 there is every chance that someone will change the let into a case:
584 which is of course utterly wrong. Rather than drop the condition that
585 only boxed types can be let-bound, we just turn the fail into a function
586 for the primitive case:
588 let fail.33 :: Void -> Int#
589 fail.33 = \_ -> error "Help"
598 Now @fail.33@ is a function, so it can be let-bound.
601 mkFailurePair :: CoreExpr -- Result type of the whole case expression
602 -> DsM (CoreBind, -- Binds the newly-created fail variable
603 -- to either the expression or \ _ -> expression
604 CoreExpr) -- Either the fail variable, or fail variable
605 -- applied to unit tuple
608 = newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
609 newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
610 returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
611 App (Var fail_fun_var) (Var unitDataConId))
614 = newFailLocalDs ty `thenDs` \ fail_var ->
615 returnDs (NonRec fail_var expr, Var fail_var)