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