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