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