ghc/compiler/deSugar/DsUtils.lhs

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