ghc/compiler/deSugar/DsUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[DsUtils]{Utilities for desugaring}
   5
   6 This module exports some utility functions of no great interest.
   7
   8 \begin{code}
   9 module DsUtils (
  10         CanItFail(..), EquationInfo(..), MatchResult(..),
  11         EqnNo, EqnSet,
  12
  13         mkDsLet, mkDsLets,
  14
  15         cantFailMatchResult, extractMatchResult,
  16         combineMatchResults,
  17         adjustMatchResult, adjustMatchResultDs,
  18         mkCoLetsMatchResult, mkGuardedMatchResult,
  19         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
  20
  21         mkErrorAppDs, mkNilExpr, mkConsExpr,
  22
  23         mkSelectorBinds, mkTupleExpr, mkTupleSelector,
  24
  25         selectMatchVar
  26     ) where
  27
  28 #include "HsVersions.h"
  29
  30 import {-# SOURCE #-} Match ( matchSimply )
  31
  32 import HsSyn            ( OutPat(..) )
  33 import TcHsSyn          ( TypecheckedPat )
  34 import DsHsSyn          ( outPatType, collectTypedPatBinders )
  35 import CoreSyn
  36
  37 import DsMonad
  38
  39 import CoreUtils        ( coreExprType )
  40 import PrelInfo         ( iRREFUT_PAT_ERROR_ID )
  41 import Id               ( idType, Id, mkWildId )
  42 import Const            ( Literal(..), Con(..) )
  43 import TyCon            ( isNewTyCon, tyConDataCons )
  44 import DataCon          ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks,
  45                           dataConId, splitProductType_maybe
  46                         )
  47 import Type             ( mkFunTy, isUnLiftedType, splitAlgTyConApp, unUsgTy,
  48                           Type
  49                         )
  50 import TysWiredIn       ( unitDataCon, tupleCon, stringTy, unitTy, unitDataCon,
  51                           nilDataCon, consDataCon
  52                         )
  53 import UniqSet          ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
  54 import Outputable
  55 \end{code}
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{ Building lets}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 Use case, not let for unlifted types.  The simplifier will turn some
  65 back again.
  66
  67 \begin{code}
  68 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
  69 mkDsLet (NonRec bndr rhs) body
  70   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
  71 mkDsLet bind body
  72   = Let bind body
  73
  74 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
  75 mkDsLets binds body = foldr mkDsLet body binds
  76 \end{code}
  77
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection{ Selecting match variables}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 We're about to match against some patterns.  We want to make some
  86 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
  87 hand, which should indeed be bound to the pattern as a whole, then use it;
  88 otherwise, make one up.
  89
  90 \begin{code}
  91 selectMatchVar :: TypecheckedPat -> DsM Id
  92 selectMatchVar (VarPat var)     = returnDs var
  93 selectMatchVar (AsPat var pat)  = returnDs var
  94 selectMatchVar (LazyPat pat)    = selectMatchVar pat
  95 selectMatchVar other_pat        = newSysLocalDs (outPatType other_pat) -- OK, better make up one...
  96 \end{code}
  97
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 %* type synonym EquationInfo and access functions for its pieces        *
 102 %*                                                                      *
 103 %************************************************************************
 104 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
 105
 106 The ``equation info'' used by @match@ is relatively complicated and
 107 worthy of a type synonym and a few handy functions.
 108
 109 \begin{code}
 110
 111 type EqnNo   = Int
 112 type EqnSet  = UniqSet EqnNo
 113
 114 data EquationInfo
 115   = EqnInfo
 116         EqnNo           -- The number of the equation
 117
 118         DsMatchContext  -- The context info is used when producing warnings
 119                         -- about shadowed patterns.  It's the context
 120                         -- of the *first* thing matched in this group.
 121                         -- Should perhaps be a list of them all!
 122
 123         [TypecheckedPat]    -- The patterns for an eqn
 124
 125         MatchResult         -- Encapsulates the guards and bindings
 126 \end{code}
 127
 128 \begin{code}
 129 data MatchResult
 130   = MatchResult
 131         CanItFail       -- Tells whether the failure expression is used
 132         (CoreExpr -> DsM CoreExpr)
 133                         -- Takes a expression to plug in at the
 134                         -- failure point(s). The expression should
 135                         -- be duplicatable!
 136
 137 data CanItFail = CanFail | CantFail
 138
 139 orFail CantFail CantFail = CantFail
 140 orFail _        _        = CanFail
 141 \end{code}
 142
 143 Functions on MatchResults
 144
 145 \begin{code}
 146 cantFailMatchResult :: CoreExpr -> MatchResult
 147 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
 148
 149 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
 150 extractMatchResult (MatchResult CantFail match_fn) fail_expr
 151   = match_fn (error "It can't fail!")
 152
 153 extractMatchResult (MatchResult CanFail match_fn) fail_expr
 154   = mkFailurePair fail_expr             `thenDs` \ (fail_bind, if_it_fails) ->
 155     match_fn if_it_fails                `thenDs` \ body ->
 156     returnDs (mkDsLet fail_bind body)
 157
 158
 159 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
 160 combineMatchResults (MatchResult CanFail      body_fn1)
 161                     (MatchResult can_it_fail2 body_fn2)
 162   = MatchResult can_it_fail2 body_fn
 163   where
 164     body_fn fail = body_fn2 fail                        `thenDs` \ body2 ->
 165                    mkFailurePair body2                  `thenDs` \ (fail_bind, duplicatable_expr) ->
 166                    body_fn1 duplicatable_expr           `thenDs` \ body1 ->
 167                    returnDs (Let fail_bind body1)
 168
 169 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
 170   = match_result1
 171
 172
 173 adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
 174 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
 175   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 176                                       returnDs (encl_fn body))
 177
 178 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
 179 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
 180   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 181                                       encl_fn body)
 182
 183
 184 mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult
 185 mkCoLetsMatchResult binds match_result
 186   = adjustMatchResult (mkDsLets binds) match_result
 187
 188
 189 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
 190 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
 191   = MatchResult CanFail (\fail -> body_fn fail  `thenDs` \ body ->
 192                                   returnDs (mkIfThenElse pred_expr body fail))
 193
 194 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
 195                     -> [(Literal, MatchResult)]         -- Alternatives
 196                     -> MatchResult
 197 mkCoPrimCaseMatchResult var match_alts
 198   = MatchResult CanFail mk_case
 199   where
 200     mk_case fail
 201       = mapDs (mk_alt fail) match_alts          `thenDs` \ alts ->
 202         returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
 203
 204     mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail     `thenDs` \ body ->
 205                                                returnDs (Literal lit, [], body)
 206
 207
 208 mkCoAlgCaseMatchResult :: Id                                    -- Scrutinee
 209                     -> [(DataCon, [CoreBndr], MatchResult)]     -- Alternatives
 210                     -> MatchResult
 211
 212 mkCoAlgCaseMatchResult var match_alts
 213   | isNewTyCon tycon            -- Newtype case; use a let
 214   = ASSERT( newtype_sanity )
 215     mkCoLetsMatchResult [coercion_bind] match_result
 216
 217   | otherwise                   -- Datatype case; use a case
 218   = MatchResult fail_flag mk_case
 219   where
 220         -- Common stuff
 221     scrut_ty = idType var
 222     (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
 223
 224         -- Stuff for newtype
 225     (con_id, arg_ids, match_result) = head match_alts
 226     arg_id                          = head arg_ids
 227     coercion_bind                   = NonRec arg_id
 228                         (Note (Coerce (idType arg_id) scrut_ty) (Var var))
 229     newtype_sanity                  = null (tail match_alts) && null (tail arg_ids)
 230
 231         -- Stuff for data types
 232     data_cons = tyConDataCons tycon
 233
 234     match_results             = [match_result | (_,_,match_result) <- match_alts]
 235
 236     fail_flag | exhaustive_case
 237               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 238               | otherwise
 239               = CanFail
 240
 241     wild_var = mkWildId (idType var)
 242     mk_case fail = mapDs (mk_alt fail) match_alts       `thenDs` \ alts ->
 243                    returnDs (Case (Var var) wild_var (alts ++ mk_default fail))
 244
 245     mk_alt fail (con, args, MatchResult _ body_fn)
 246         = body_fn fail          `thenDs` \ body ->
 247           rebuildConArgs con args (dataConStrictMarks con) body
 248                                 `thenDs` \ (body', real_args) ->
 249           returnDs (DataCon con, real_args, body')
 250
 251     mk_default fail | exhaustive_case = []
 252                     | otherwise       = [(DEFAULT, [], fail)]
 253
 254     un_mentioned_constructors
 255         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
 256     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 257 \end{code}
 258 %
 259 For each constructor we match on, we might need to re-pack some
 260 of the strict fields if they are unpacked in the constructor.
 261 %
 262 \begin{code}
 263 rebuildConArgs
 264   :: DataCon                            -- the con we're matching on
 265   -> [Id]                               -- the source-level args
 266   -> [StrictnessMark]                   -- the strictness annotations (per-arg)
 267   -> CoreExpr                           -- the body
 268   -> DsM (CoreExpr, [Id])
 269
 270 rebuildConArgs con [] stricts body = returnDs (body, [])
 271 rebuildConArgs con (arg:args) stricts body | isTyVar arg
 272   = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
 273     returnDs (body',arg:args')
 274 rebuildConArgs con (arg:args) (str:stricts) body
 275   = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
 276     case maybeMarkedUnboxed str of
 277         Just (pack_con1, _) ->
 278             case splitProductType_maybe (idType arg) of
 279                 Just (_, tycon_args, pack_con, con_arg_tys) ->
 280                     ASSERT( pack_con == pack_con1 )
 281                     newSysLocalsDs con_arg_tys          `thenDs` \ unpacked_args ->
 282                     returnDs (
 283                          mkDsLet (NonRec arg (Con (DataCon pack_con)
 284                                                   (map Type tycon_args ++
 285                                                    map Var  unpacked_args))) body',
 286                          unpacked_args ++ real_args
 287                     )
 288
 289         _ -> returnDs (body', arg:real_args)
 290 \end{code}
 291
 292 %************************************************************************
 293 %*                                                                      *
 294 \subsection{Desugarer's versions of some Core functions}
 295 %*                                                                      *
 296 %************************************************************************
 297
 298 \begin{code}
 299 mkErrorAppDs :: Id              -- The error function
 300              -> Type            -- Type to which it should be applied
 301              -> String          -- The error message string to pass
 302              -> DsM CoreExpr
 303
 304 mkErrorAppDs err_id ty msg
 305   = getSrcLocDs                 `thenDs` \ src_loc ->
 306     let
 307         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 308     in
 309     returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
 310     -- unUsgTy *required* -- KSW 1999-04-07
 311 \end{code}
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 \subsection[mkSelectorBind]{Make a selector bind}
 316 %*                                                                      *
 317 %************************************************************************
 318
 319 This is used in various places to do with lazy patterns.
 320 For each binder $b$ in the pattern, we create a binding:
 321 \begin{verbatim}
 322     b = case v of pat' -> b'
 323 \end{verbatim}
 324 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
 325
 326 ToDo: making these bindings should really depend on whether there's
 327 much work to be done per binding.  If the pattern is complex, it
 328 should be de-mangled once, into a tuple (and then selected from).
 329 Otherwise the demangling can be in-line in the bindings (as here).
 330
 331 Boring!  Boring!  One error message per binder.  The above ToDo is
 332 even more helpful.  Something very similar happens for pattern-bound
 333 expressions.
 334
 335 \begin{code}
 336 mkSelectorBinds :: TypecheckedPat       -- The pattern
 337                 -> CoreExpr             -- Expression to which the pattern is bound
 338                 -> DsM [(Id,CoreExpr)]
 339
 340 mkSelectorBinds (VarPat v) val_expr
 341   = returnDs [(v, val_expr)]
 342
 343 mkSelectorBinds pat val_expr
 344   | length binders == 1 || is_simple_pat pat
 345   = newSysLocalDs (coreExprType val_expr)       `thenDs` \ val_var ->
 346
 347         -- For the error message we don't use mkErrorAppDs to avoid
 348         -- duplicating the string literal each time
 349     newSysLocalDs stringTy                      `thenDs` \ msg_var ->
 350     getSrcLocDs                                 `thenDs` \ src_loc ->
 351     let
 352         full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
 353     in
 354     mapDs (mk_bind val_var msg_var) binders     `thenDs` \ binds ->
 355     returnDs ( (val_var, val_expr) :
 356                (msg_var, mkStringLit full_msg) :
 357                binds )
 358
 359
 360   | otherwise
 361   = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))
 362     `thenDs` \ error_expr ->
 363     matchSimply val_expr LetMatch pat local_tuple error_expr
 364     `thenDs` \ tuple_expr ->
 365     newSysLocalDs tuple_ty
 366     `thenDs` \ tuple_var ->
 367     let
 368         mk_tup_bind binder =
 369           (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
 370     in
 371     returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
 372   where
 373     binders     = collectTypedPatBinders pat
 374     local_tuple = mkTupleExpr binders
 375     tuple_ty    = coreExprType local_tuple
 376
 377     mk_bind scrut_var msg_var bndr_var
 378     -- (mk_bind sv bv) generates
 379     --          bv = case sv of { pat -> bv; other -> error-msg }
 380     -- Remember, pat binds bv
 381       = matchSimply (Var scrut_var) LetMatch pat
 382                     (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
 383         returnDs (bndr_var, rhs_expr)
 384       where
 385         binder_ty = idType bndr_var
 386         error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
 387
 388     is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
 389     is_simple_pat (ConPat _ _ _ _ ps)  = all is_triv_pat ps
 390     is_simple_pat (VarPat _)           = True
 391     is_simple_pat (RecPat _ _ _ _ ps)  = and [is_triv_pat p | (_,p,_) <- ps]
 392     is_simple_pat other                = False
 393
 394     is_triv_pat (VarPat v)  = True
 395     is_triv_pat (WildPat _) = True
 396     is_triv_pat other       = False
 397 \end{code}
 398
 399
 400 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 401 has only one element, it is the identity function.  Notice we must
 402 throw out any usage annotation on the outside of an Id.
 403
 404 \begin{code}
 405 mkTupleExpr :: [Id] -> CoreExpr
 406
 407 mkTupleExpr []   = mkConApp unitDataCon []
 408 mkTupleExpr [id] = Var id
 409 mkTupleExpr ids  = mkConApp (tupleCon (length ids))
 410                             (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
 411 \end{code}
 412
 413
 414 @mkTupleSelector@ builds a selector which scrutises the given
 415 expression and extracts the one name from the list given.
 416 If you want the no-shadowing rule to apply, the caller
 417 is responsible for making sure that none of these names
 418 are in scope.
 419
 420 If there is just one id in the ``tuple'', then the selector is
 421 just the identity.
 422
 423 \begin{code}
 424 mkTupleSelector :: [Id]         -- The tuple args
 425                 -> Id           -- The selected one
 426                 -> Id           -- A variable of the same type as the scrutinee
 427                 -> CoreExpr     -- Scrutinee
 428                 -> CoreExpr
 429
 430 mkTupleSelector [var] should_be_the_same_var scrut_var scrut
 431   = ASSERT(var == should_be_the_same_var)
 432     scrut
 433
 434 mkTupleSelector vars the_var scrut_var scrut
 435   = ASSERT( not (null vars) )
 436     Case scrut scrut_var [(DataCon (tupleCon (length vars)), vars, Var the_var)]
 437 \end{code}
 438
 439
 440 %************************************************************************
 441 %*                                                                      *
 442 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 443 %*                                                                      *
 444 %************************************************************************
 445
 446 Call the constructor Ids when building explicit lists, so that they
 447 interact well with rules.
 448
 449 \begin{code}
 450 mkNilExpr :: Type -> CoreExpr
 451 mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
 452
 453 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
 454 mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
 455 \end{code}
 456
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 Generally, we handle pattern matching failure like this: let-bind a
 465 fail-variable, and use that variable if the thing fails:
 466 \begin{verbatim}
 467         let fail.33 = error "Help"
 468         in
 469         case x of
 470                 p1 -> ...
 471                 p2 -> fail.33
 472                 p3 -> fail.33
 473                 p4 -> ...
 474 \end{verbatim}
 475 Then
 476 \begin{itemize}
 477 \item
 478 If the case can't fail, then there'll be no mention of @fail.33@, and the
 479 simplifier will later discard it.
 480
 481 \item
 482 If it can fail in only one way, then the simplifier will inline it.
 483
 484 \item
 485 Only if it is used more than once will the let-binding remain.
 486 \end{itemize}
 487
 488 There's a problem when the result of the case expression is of
 489 unboxed type.  Then the type of @fail.33@ is unboxed too, and
 490 there is every chance that someone will change the let into a case:
 491 \begin{verbatim}
 492         case error "Help" of
 493           fail.33 -> case ....
 494 \end{verbatim}
 495
 496 which is of course utterly wrong.  Rather than drop the condition that
 497 only boxed types can be let-bound, we just turn the fail into a function
 498 for the primitive case:
 499 \begin{verbatim}
 500         let fail.33 :: Void -> Int#
 501             fail.33 = \_ -> error "Help"
 502         in
 503         case x of
 504                 p1 -> ...
 505                 p2 -> fail.33 void
 506                 p3 -> fail.33 void
 507                 p4 -> ...
 508 \end{verbatim}
 509
 510 Now @fail.33@ is a function, so it can be let-bound.
 511
 512 \begin{code}
 513 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
 514               -> DsM (CoreBind, -- Binds the newly-created fail variable
 515                                 -- to either the expression or \ _ -> expression
 516                       CoreExpr) -- Either the fail variable, or fail variable
 517                                 -- applied to unit tuple
 518 mkFailurePair expr
 519   | isUnLiftedType ty
 520   = newFailLocalDs (unitTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
 521     newSysLocalDs unitTy                        `thenDs` \ fail_fun_arg ->
 522     returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
 523               App (Var fail_fun_var) (mkConApp unitDataCon []))
 524
 525   | otherwise
 526   = newFailLocalDs ty           `thenDs` \ fail_var ->
 527     returnDs (NonRec fail_var expr, Var fail_var)
 528   where
 529     ty = coreExprType expr
 530 \end{code}
 531
 532
 533