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