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