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