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