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 (Coerce (CoerceOut con_id)
 205                                                             (idType arg_id)
 206                                                             (Var var))
 207     newtype_sanity                  = null (tail alts) && null (tail arg_ids)
 208
 209         -- Stuff for data types
 210     data_cons = tyConDataCons tycon
 211
 212     un_mentioned_constructors
 213       = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
 214
 215     match_results = [match_result | (_,_,match_result) <- alts]
 216     (MatchResult _ ty1 _ : _) = match_results
 217     can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ <- match_results]
 218
 219     mk_case alts deflt_fn fail_expr
 220       = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
 221       where
 222         final_alts = [ (con, args, body_fn fail_expr)
 223                      | (con, args, MatchResult _ _ body_fn) <- alts
 224                      ]
 225
 226
 227 combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 228 combineMatchResults (MatchResult CanFail      ty1 body_fn1)
 229                     (MatchResult can_it_fail2 ty2 body_fn2)
 230   = mkFailurePair ty1           `thenDs` \ (bind_fn, duplicatable_expr) ->
 231     let
 232         new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr)
 233         new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2)
 234     in
 235     returnDs (MatchResult can_it_fail2 ty1 new_body_fn2)
 236
 237 combineMatchResults match_result1@(MatchResult CantFail ty body_fn1)
 238                                   match_result2
 239   = returnDs match_result1
 240
 241
 242 -- The difference in combineGRHSMatchResults is that there is no
 243 -- need to let-bind to avoid code duplication
 244 combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult
 245 combineGRHSMatchResults (MatchResult CanFail     ty1 body_fn1)
 246                         (MatchResult can_it_fail ty2 body_fn2)
 247   = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)))
 248
 249 combineGRHSMatchResults match_result1 match_result2
 250   =     -- Delegate to avoid duplication of code
 251     combineMatchResults match_result1 match_result2
 252 \end{code}
 253
 254 %************************************************************************
 255 %*                                                                      *
 256 \subsection[dsExprToAtom]{Take an expression and produce an atom}
 257 %*                                                                      *
 258 %************************************************************************
 259
 260 \begin{code}
 261 dsArgToAtom :: DsCoreArg                    -- The argument expression
 262              -> (CoreArg -> DsM CoreExpr)   -- Something taking the argument *atom*,
 263                                             -- and delivering an expression E
 264              -> DsM CoreExpr                -- Either E or let x=arg-expr in E
 265
 266 dsArgToAtom (TyArg    t) continue_with = continue_with (TyArg    t)
 267 dsArgToAtom (LitArg   l) continue_with = continue_with (LitArg   l)
 268 dsArgToAtom (VarArg arg) continue_with = dsExprToAtomGivenTy arg (coreExprType arg) continue_with
 269
 270 dsExprToAtomGivenTy
 271          :: CoreExpr                    -- The argument expression
 272          -> Type                        -- Type of the argument
 273          -> (CoreArg -> DsM CoreExpr)   -- Something taking the argument *atom*,
 274                                         -- and delivering an expression E
 275          -> DsM CoreExpr                -- Either E or let x=arg-expr in E
 276
 277 dsExprToAtomGivenTy (Var v)  arg_ty continue_with = continue_with (VarArg v)
 278 dsExprToAtomGivenTy (Lit v)  arg_ty continue_with = continue_with (LitArg v)
 279 dsExprToAtomGivenTy arg_expr arg_ty continue_with
 280   = newSysLocalDs arg_ty                `thenDs` \ arg_id ->
 281     continue_with (VarArg arg_id)       `thenDs` \ body   ->
 282     returnDs (
 283         if isUnpointedType arg_ty
 284         then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
 285         else Let (NonRec arg_id arg_expr) body
 286     )
 287
 288 dsArgsToAtoms :: [DsCoreArg]
 289                -> ([CoreArg] -> DsM CoreExpr)
 290                -> DsM CoreExpr
 291
 292 dsArgsToAtoms [] continue_with = continue_with []
 293
 294 dsArgsToAtoms (arg:args) continue_with
 295   = dsArgToAtom   arg   $ \ arg_atom  ->
 296     dsArgsToAtoms args $ \ arg_atoms ->
 297     continue_with (arg_atom:arg_atoms)
 298 \end{code}
 299
 300 %************************************************************************
 301 %*                                                                      *
 302 \subsection{Desugarer's versions of some Core functions}
 303 %*                                                                      *
 304 %************************************************************************
 305
 306 \begin{code}
 307 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} Unused
 308
 309 mkAppDs  :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
 310 mkConDs  :: Id       -> [DsCoreArg] -> DsM CoreExpr
 311 mkPrimDs :: PrimOp   -> [DsCoreArg] -> DsM CoreExpr
 312
 313 mkAppDs fun args
 314   = dsArgsToAtoms args $ \ atoms ->
 315     returnDs (mkGenApp fun atoms)
 316
 317 mkConDs con args
 318   = dsArgsToAtoms args $ \ atoms ->
 319     returnDs (Con con atoms)
 320
 321 mkPrimDs op args
 322   = dsArgsToAtoms args $ \ atoms ->
 323     returnDs (Prim op  atoms)
 324 \end{code}
 325
 326 \begin{code}
 327 showForErr :: Outputable a => a -> String               -- Boring but useful
 328 showForErr thing = showSDoc (ppr thing)
 329
 330 mkErrorAppDs :: Id              -- The error function
 331              -> Type            -- Type to which it should be applied
 332              -> String          -- The error message string to pass
 333              -> DsM CoreExpr
 334
 335 mkErrorAppDs err_id ty msg
 336   = getSrcLocDs                 `thenDs` \ src_loc ->
 337     let
 338         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 339         msg_lit  = NoRepStr (_PK_ full_msg)
 340     in
 341     returnDs (mkApp (Var err_id) [ty] [LitArg msg_lit])
 342 \end{code}
 343
 344 %************************************************************************
 345 %*                                                                      *
 346 \subsection[mkSelectorBind]{Make a selector bind}
 347 %*                                                                      *
 348 %************************************************************************
 349
 350 This is used in various places to do with lazy patterns.
 351 For each binder $b$ in the pattern, we create a binding:
 352
 353     b = case v of pat' -> b'
 354
 355 where pat' is pat with each binder b cloned into b'.
 356
 357 ToDo: making these bindings should really depend on whether there's
 358 much work to be done per binding.  If the pattern is complex, it
 359 should be de-mangled once, into a tuple (and then selected from).
 360 Otherwise the demangling can be in-line in the bindings (as here).
 361
 362 Boring!  Boring!  One error message per binder.  The above ToDo is
 363 even more helpful.  Something very similar happens for pattern-bound
 364 expressions.
 365
 366 \begin{code}
 367 mkSelectorBinds :: TypecheckedPat       -- The pattern
 368                 -> CoreExpr             -- Expression to which the pattern is bound
 369                 -> DsM [(Id,CoreExpr)]
 370
 371 mkSelectorBinds (VarPat v) val_expr
 372   = returnDs [(v, val_expr)]
 373
 374 mkSelectorBinds pat val_expr
 375   | length binders == 1 || is_simple_pat pat
 376   = newSysLocalDs (coreExprType val_expr)       `thenDs` \ val_var ->
 377
 378         -- For the error message we don't use mkErrorAppDs to avoid
 379         -- duplicating the string literal each time
 380     newSysLocalDs stringTy                      `thenDs` \ msg_var ->
 381     getSrcLocDs                                 `thenDs` \ src_loc ->
 382     let
 383         full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
 384         msg_lit  = NoRepStr (_PK_ full_msg)
 385     in
 386     mapDs (mk_bind val_var msg_var) binders     `thenDs` \ binds ->
 387     returnDs ( (val_var, val_expr) :
 388                (msg_var, Lit msg_lit) :
 389                binds )
 390
 391
 392   | otherwise
 393   = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))     `thenDs` \ error_expr ->
 394     matchSimply val_expr LetMatch pat tuple_ty local_tuple error_expr   `thenDs` \ tuple_expr ->
 395     newSysLocalDs tuple_ty                                              `thenDs` \ tuple_var ->
 396     let
 397         mk_tup_bind binder = (binder, mkTupleSelector binders binder (Var tuple_var))
 398     in
 399     returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
 400   where
 401     binders     = collectTypedPatBinders pat
 402     local_tuple = mkTupleExpr binders
 403     tuple_ty    = coreExprType local_tuple
 404
 405     mk_bind scrut_var msg_var bndr_var
 406     -- (mk_bind sv bv) generates
 407     --          bv = case sv of { pat -> bv; other -> error-msg }
 408     -- Remember, pat binds bv
 409       = matchSimply (Var scrut_var) LetMatch pat binder_ty
 410                     (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
 411         returnDs (bndr_var, rhs_expr)
 412       where
 413         binder_ty = idType bndr_var
 414         error_expr = mkApp (Var iRREFUT_PAT_ERROR_ID) [binder_ty] [VarArg msg_var]
 415
 416     is_simple_pat (TuplePat ps)        = all is_triv_pat ps
 417     is_simple_pat (ConPat _ _ ps)      = all is_triv_pat ps
 418     is_simple_pat (VarPat _)           = True
 419     is_simple_pat (ConOpPat p1 _ p2 _) = is_triv_pat p1 && is_triv_pat p2
 420     is_simple_pat (RecPat _ _ ps)      = and [is_triv_pat p | (_,p,_) <- ps]
 421     is_simple_pat other                = False
 422
 423     is_triv_pat (VarPat v)  = True
 424     is_triv_pat (WildPat _) = True
 425     is_triv_pat other       = False
 426 \end{code}
 427
 428
 429 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 430 has only one element, it is the identity function.
 431
 432 \begin{code}
 433 mkTupleExpr :: [Id] -> CoreExpr
 434
 435 mkTupleExpr []   = Con unitDataCon []
 436 mkTupleExpr [id] = Var id
 437 mkTupleExpr ids  = mkCon (tupleCon (length ids))
 438                          (map idType ids)
 439                          [ VarArg i | i <- ids ]
 440 \end{code}
 441
 442
 443 @mkTupleSelector@ builds a selector which scrutises the given
 444 expression and extracts the one name from the list given.
 445 If you want the no-shadowing rule to apply, the caller
 446 is responsible for making sure that none of these names
 447 are in scope.
 448
 449 If there is just one id in the ``tuple'', then the selector is
 450 just the identity.
 451
 452 \begin{code}
 453 mkTupleSelector :: [Id]                 -- The tuple args
 454                 -> Id                   -- The selected one
 455                 -> CoreExpr             -- Scrutinee
 456                 -> CoreExpr
 457
 458 mkTupleSelector [var] should_be_the_same_var scrut
 459   = ASSERT(var == should_be_the_same_var)
 460     scrut
 461
 462 mkTupleSelector vars the_var scrut
 463   = ASSERT( not (null vars) )
 464     Case scrut (AlgAlts [(tupleCon (length vars), vars, Var the_var)] NoDefault)
 465 \end{code}
 466
 467
 468 %************************************************************************
 469 %*                                                                      *
 470 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 471 %*                                                                      *
 472 %************************************************************************
 473
 474 Generally, we handle pattern matching failure like this: let-bind a
 475 fail-variable, and use that variable if the thing fails:
 476 \begin{verbatim}
 477         let fail.33 = error "Help"
 478         in
 479         case x of
 480                 p1 -> ...
 481                 p2 -> fail.33
 482                 p3 -> fail.33
 483                 p4 -> ...
 484 \end{verbatim}
 485 Then
 486 \begin{itemize}
 487 \item
 488 If the case can't fail, then there'll be no mention of fail.33, and the
 489 simplifier will later discard it.
 490
 491 \item
 492 If it can fail in only one way, then the simplifier will inline it.
 493
 494 \item
 495 Only if it is used more than once will the let-binding remain.
 496 \end{itemize}
 497
 498 There's a problem when the result of the case expression is of
 499 unboxed type.  Then the type of fail.33 is unboxed too, and
 500 there is every chance that someone will change the let into a case:
 501 \begin{verbatim}
 502         case error "Help" of
 503           fail.33 -> case ....
 504 \end{verbatim}
 505
 506 which is of course utterly wrong.  Rather than drop the condition that
 507 only boxed types can be let-bound, we just turn the fail into a function
 508 for the primitive case:
 509 \begin{verbatim}
 510         let fail.33 :: Void -> Int#
 511             fail.33 = \_ -> error "Help"
 512         in
 513         case x of
 514                 p1 -> ...
 515                 p2 -> fail.33 void
 516                 p3 -> fail.33 void
 517                 p4 -> ...
 518 \end{verbatim}
 519
 520 Now fail.33 is a function, so it can be let-bound.
 521
 522 \begin{code}
 523 mkFailurePair :: Type           -- Result type of the whole case expression
 524               -> DsM (CoreExpr -> CoreBinding,
 525                                 -- Binds the newly-created fail variable
 526                                 -- to either the expression or \ _ -> expression
 527                       CoreExpr) -- Either the fail variable, or fail variable
 528                                 -- applied to unit tuple
 529 mkFailurePair ty
 530   | isUnpointedType ty
 531   = newFailLocalDs (voidTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
 532     newSysLocalDs voidTy                        `thenDs` \ fail_fun_arg ->
 533     returnDs (\ body ->
 534                 NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
 535               App (Var fail_fun_var) (VarArg voidId))
 536
 537   | otherwise
 538   = newFailLocalDs ty           `thenDs` \ fail_var ->
 539     returnDs (\ body -> NonRec fail_var body, Var fail_var)
 540 \end{code}
 541
 542
 543