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