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