ghc/compiler/deSugar/DsUtils.lhs

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