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