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