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