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