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