DsUtils.lhs 25.6 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Utilities for desugaring
7 8 9 10

This module exports some utility functions of no great interest.

\begin{code}
11
-- | Utility functions for constructing Core syntax, principally for desugaring
12
module DsUtils (
13 14
	EquationInfo(..), 
	firstPat, shiftEqns,
15

16 17 18 19
	MatchResult(..), CanItFail(..), 
	cantFailMatchResult, alwaysFailMatchResult,
	extractMatchResult, combineMatchResults, 
	adjustMatchResult,  adjustMatchResultDs,
20
	mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, 
21
	matchCanFail, mkEvalMatchResult,
22
	mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
23
	wrapBind, wrapBinds,
24

25
	mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
26 27 28 29

        seqVar,

        -- LHs tuples
30
        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
31 32 33 34 35
        mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,

        mkSelectorBinds,

        dsSyntaxTable, lookupEvidence,
36

andy@galois.com's avatar
andy@galois.com committed
37 38
	selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
	mkTickBox, mkOptTickBox, mkBinaryTickBox
39 40
    ) where

41 42
#include "HsVersions.h"

43
import {-# SOURCE #-}	Match ( matchSimply )
44
import {-# SOURCE #-}	DsExpr( dsExpr )
45

46
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
47
import TcHsSyn
48
import TcType( tcSplitTyConApp )
49 50 51
import CoreSyn
import DsMonad

Simon Marlow's avatar
Simon Marlow committed
52
import CoreUtils
53
import MkCore
Simon Marlow's avatar
Simon Marlow committed
54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
import MkId
import Id
import Var
import Name
import Literal
import TyCon
import DataCon
import Type
import Coercion
import TysPrim
import TysWiredIn
import BasicTypes
import UniqSet
import UniqSupply
import PrelNames
sof's avatar
sof committed
69
import Outputable
Simon Marlow's avatar
Simon Marlow committed
70 71 72
import SrcLoc
import Util
import ListSetOps
73
import FastString
74
import StaticFlags
75 76
\end{code}

sof's avatar
sof committed
77

78

79 80 81 82 83 84 85
%************************************************************************
%*									*
		Rebindable syntax
%*									*
%************************************************************************

\begin{code}
86
dsSyntaxTable :: SyntaxTable Id 
87 88 89
	       -> DsM ([CoreBind], 	-- Auxiliary bindings
		       [(Name,Id)])	-- Maps the standard name to its value

90 91
dsSyntaxTable rebound_ids = do
    (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
92 93
    return (concat binds_s, prs)
  where
94 95
        -- The cheapo special case can happen when we 
        -- make an intermediate HsDo when desugaring a RecStmt
96
    mk_bind (std_name, HsVar id) = return ([], (std_name, id))
97 98 99 100
    mk_bind (std_name, expr) = do
           rhs <- dsExpr expr
           id <- newSysLocalDs (exprType rhs)
           return ([NonRec id rhs], (std_name, id))
101

102 103 104
lookupEvidence :: [(Name, Id)] -> Name -> Id
lookupEvidence prs std_name
  = assocDefault (mk_panic std_name) prs std_name
105
  where
Ian Lynagh's avatar
Ian Lynagh committed
106
    mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
107 108
\end{code}

sof's avatar
sof committed
109 110
%************************************************************************
%*									*
111
\subsection{ Selecting match variables}
sof's avatar
sof committed
112 113 114 115 116 117 118 119 120
%*									*
%************************************************************************

We're about to match against some patterns.  We want to make some
@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
hand, which should indeed be bound to the pattern as a whole, then use it;
otherwise, make one up.

\begin{code}
121
selectSimpleMatchVarL :: LPat Id -> DsM Id
122
selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
123 124 125 126

-- (selectMatchVars ps tys) chooses variables of type tys
-- to use for matching ps against.  If the pattern is a variable,
-- we try to use that, to save inventing lots of fresh variables.
127 128 129
--
-- OLD, but interesting note:
--    But even if it is a variable, its type might not match.  Consider
130 131 132 133 134 135 136
--	data T a where
--	  T1 :: Int -> T Int
--	  T2 :: a   -> T a
--
--	f :: T a -> a -> Int
--	f (T1 i) (x::Int) = x
--	f (T2 i) (y::a)   = 0
137 138 139 140 141 142
--    Then we must not choose (x::Int) as the matching variable!
-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat

selectMatchVars :: [Pat Id] -> DsM [Id]
selectMatchVars ps = mapM selectMatchVar ps

143
selectMatchVar :: Pat Id -> DsM Id
144 145 146 147
selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
selectMatchVar (VarPat var)  = return var
148
selectMatchVar (AsPat var _) = return (unLoc var)
149
selectMatchVar other_pat     = newSysLocalDs (hsPatType other_pat)
150
				  -- OK, better make up one...
sof's avatar
sof committed
151 152 153
\end{code}


154 155 156 157 158 159 160 161 162 163 164
%************************************************************************
%*									*
%* type synonym EquationInfo and access functions for its pieces	*
%*									*
%************************************************************************
\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}

The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.

\begin{code}
165
firstPat :: EquationInfo -> Pat Id
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
166
firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
167

168
shiftEqns :: [EquationInfo] -> [EquationInfo]
169 170
-- Drop the first pattern in each equation
shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
171 172
\end{code}

173 174 175
Functions on MatchResults

\begin{code}
176 177 178 179
matchCanFail :: MatchResult -> Bool
matchCanFail (MatchResult CanFail _)  = True
matchCanFail (MatchResult CantFail _) = False

180
alwaysFailMatchResult :: MatchResult
181
alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
182

183
cantFailMatchResult :: CoreExpr -> MatchResult
184
cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
185

186
extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
187
extractMatchResult (MatchResult CantFail match_fn) _
188
  = match_fn (error "It can't fail!")
189

190 191 192
extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
    (fail_bind, if_it_fails) <- mkFailurePair fail_expr
    body <- match_fn if_it_fails
193
    return (mkCoreLet fail_bind body)
194

195 196 197

combineMatchResults :: MatchResult -> MatchResult -> MatchResult
combineMatchResults (MatchResult CanFail      body_fn1)
198
                    (MatchResult can_it_fail2 body_fn2)
199 200
  = MatchResult can_it_fail2 body_fn
  where
201 202 203 204
    body_fn fail = do body2 <- body_fn2 fail
                      (fail_bind, duplicatable_expr) <- mkFailurePair body2
                      body1 <- body_fn1 duplicatable_expr
                      return (Let fail_bind body1)
205

206
combineMatchResults match_result1@(MatchResult CantFail _) _
207 208
  = match_result1

209
adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
210
adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
211
  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
212 213 214

adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
215
  = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
216

217 218 219
wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
wrapBinds [] e = e
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
220

221
wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
222
wrapBind new old body	-- Can deal with term variables *or* type variables
223
  | new==old    = body
224 225
  | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
  | otherwise   = Let (NonRec new (Var old))         body
226

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
227 228 229 230
seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = Case (Var var) var (exprType body)
			[(DEFAULT, [], body)]

231
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
232
mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
233

234 235 236 237
-- (mkViewMatchResult var' viewExpr var mr) makes the expression
-- let var' = viewExpr var in mr
mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
mkViewMatchResult var' viewExpr var = 
238
    adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))
239

240 241 242
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) 
243 244

mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
245
mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
246 247
  = MatchResult CanFail (\fail -> do body <- body_fn fail
                                     return (mkIfThenElse pred_expr body fail))
248 249

mkCoPrimCaseMatchResult :: Id				-- Scrutinee
250
                    -> Type                             -- Type of the case
251 252
		    -> [(Literal, MatchResult)]		-- Alternatives
		    -> MatchResult
253
mkCoPrimCaseMatchResult var ty match_alts
254
  = MatchResult CanFail mk_case
255
  where
256 257 258
    mk_case fail = do
        alts <- mapM (mk_alt fail) sorted_alts
        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
259

260
    sorted_alts = sortWith fst match_alts	-- Right order for a Case
261 262
    mk_alt fail (lit, MatchResult _ body_fn) = do body <- body_fn fail
                                                  return (LitAlt lit, [], body)
263 264


265
mkCoAlgCaseMatchResult :: Id					-- Scrutinee
266
                    -> Type                                     -- Type of exp
267 268
		    -> [(DataCon, [CoreBndr], MatchResult)]	-- Alternatives
		    -> MatchResult
269
mkCoAlgCaseMatchResult var ty match_alts 
270
  | isNewTyCon tycon		-- Newtype case; use a let
271
  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
272
    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
273

chak's avatar
chak committed
274 275 276
  | isPArrFakeAlts match_alts	-- Sugared parallel array; use a literal case 
  = MatchResult CanFail mk_parrCase

277 278
  | otherwise			-- Datatype case; use a case
  = MatchResult fail_flag mk_case
279
  where
280 281 282
    tycon = dataConTyCon con1
	-- [Interesting: becuase of GADTs, we can't rely on the type of 
	--  the scrutinised Id to be sufficiently refined to have a TyCon in it]
283 284

	-- Stuff for newtype
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
285 286
    (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts
    arg_id1 	= ASSERT( notNull arg_ids1 ) head arg_ids1
287
    var_ty      = idType var
288 289
    (tc, ty_args) = tcSplitTyConApp var_ty	-- Don't look through newtypes
    	 	    		    		-- (not that splitTyConApp does, these days)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
290
    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
291
		
292
	-- Stuff for data types
293 294
    data_cons      = tyConDataCons tycon
    match_results  = [match_result | (_,_,match_result) <- match_alts]
295

296 297 298 299
    fail_flag | exhaustive_case
	      = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
	      | otherwise
	      = CanFail
300

301 302
    sorted_alts  = sortWith get_tag match_alts
    get_tag (con, _, _) = dataConTag con
303
    mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
304
                      return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
305

306 307 308 309
    mk_alt fail (con, args, MatchResult _ body_fn) = do
          body <- body_fn fail
          us <- newUniqueSupply
          return (mkReboxingAlt (uniqsFromSupply us) con args body)
310

311 312
    mk_default fail | exhaustive_case = []
		    | otherwise       = [(DEFAULT, [], fail)]
313

314 315 316
    un_mentioned_constructors
        = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
chak's avatar
chak committed
317 318 319

	-- Stuff for parallel arrays
	-- 
320
	--  * the following is to desugar cases over fake constructors for
chak's avatar
chak committed
321 322 323 324 325
	--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
	--   case
	--
	-- Concerning `isPArrFakeAlts':
	--
326
	--  * it is *not* sufficient to just check the type of the type
chak's avatar
chak committed
327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344
	--   constructor, as we have to be careful not to confuse the real
	--   representation of parallel arrays with the fake constructors;
	--   moreover, a list of alternatives must not mix fake and real
	--   constructors (this is checked earlier on)
	--
	-- FIXME: We actually go through the whole list and make sure that
	--	  either all or none of the constructors are fake parallel
	--	  array constructors.  This is to spot equations that mix fake
	--	  constructors with the real representation defined in
	--	  `PrelPArr'.  It would be nicer to spot this situation
	--	  earlier and raise a proper error message, but it can really
	--	  only happen in `PrelPArr' anyway.
	--
    isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
    isPArrFakeAlts ((dcon, _, _):alts) = 
      case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
        (True , True ) -> True
        (False, False) -> False
345 346
        _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
    isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
chak's avatar
chak committed
347
    --
348 349 350
    mk_parrCase fail = do
      lengthP <- dsLookupGlobalId lengthPName
      alt <- unboxAlt
351
      return (mkWildCase (len lengthP) intTy ty [alt])
chak's avatar
chak committed
352 353 354 355 356 357 358
      where
	elemTy      = case splitTyConApp (idType var) of
		        (_, [elemTy]) -> elemTy
		        _	        -> panic panicMsg
        panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
	len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
	--
359 360 361 362
	unboxAlt = do
	  l      <- newSysLocalDs intPrimTy
	  indexP <- dsLookupGlobalId indexPName
	  alts   <- mapM (mkAlt indexP) sorted_alts
363
	  return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
chak's avatar
chak committed
364 365 366 367 368 369 370 371 372
          where
	    dft  = (DEFAULT, [], fail)
	--
	-- each alternative matches one array length (corresponding to one
	-- fake array constructor), so the match is on a literal; each
	-- alternative's body is extended by a local binding for each
	-- constructor argument, which are bound to array elements starting
	-- with the first
	--
373 374
	mkAlt indexP (con, args, MatchResult _ bodyFun) = do
	  body <- bodyFun fail
375
	  return (LitAlt lit, [], mkCoreLets binds body)
chak's avatar
chak committed
376 377 378 379
	  where
	    lit   = MachInt $ toInteger (dataConSourceArity con)
	    binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
	    --
380
	    indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
381
\end{code}
382

383 384
%************************************************************************
%*									*
385
\subsection{Desugarer's versions of some Core functions}
386 387 388 389
%*									*
%************************************************************************

\begin{code}
390 391
mkErrorAppDs :: Id 		-- The error function
	     -> Type		-- Type to which it should be applied
392
	     -> SDoc		-- The error message string to pass
393 394
	     -> DsM CoreExpr

395 396
mkErrorAppDs err_id ty msg = do
    src_loc <- getSrcSpanDs
397
    let
398
        full_msg = showSDoc (hcat [ppr src_loc, text "|", msg])
399 400
        core_msg = Lit (mkMachString full_msg)
        -- mkMachString returns a result of type String#
401
    return (mkApps (Var err_id) [Type ty, core_msg])
402 403
\end{code}

404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482
'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.

Note [Desugaring seq (1)]  cf Trac #1031
~~~~~~~~~~~~~~~~~~~~~~~~~
   f x y = x `seq` (y `seq` (# x,y #))

The [CoreSyn let/app invariant] means that, other things being equal, because 
the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:

   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v

But that is bad for two reasons: 
  (a) we now evaluate y before x, and 
  (b) we can't bind v to an unboxed pair

Seq is very, very special!  So we recognise it right here, and desugar to
        case x of _ -> case y of _ -> (# x,y #)

Note [Desugaring seq (2)]  cf Trac #2231
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   let chp = case b of { True -> fst x; False -> 0 }
   in chp `seq` ...chp...
Here the seq is designed to plug the space leak of retaining (snd x)
for too long.

If we rely on the ordinary inlining of seq, we'll get
   let chp = case b of { True -> fst x; False -> 0 }
   case chp of _ { I# -> ...chp... }

But since chp is cheap, and the case is an alluring contet, we'll
inline chp into the case scrutinee.  Now there is only one use of chp,
so we'll inline a second copy.  Alas, we've now ruined the purpose of
the seq, by re-introducing the space leak:
    case (case b of {True -> fst x; False -> 0}) of
      I# _ -> ...case b of {True -> fst x; False -> 0}...

We can try to avoid doing this by ensuring that the binder-swap in the
case happens, so we get his at an early stage:
   case chp of chp2 { I# -> ...chp2... }
But this is fragile.  The real culprit is the source program.  Perhaps we
should have said explicitly
   let !chp2 = chp in ...chp2...

But that's painful.  So the code here does a little hack to make seq
more robust: a saturated application of 'seq' is turned *directly* into
the case expression. So we desugar to:
   let chp = case b of { True -> fst x; False -> 0 }
   case chp of chp { I# -> ...chp... }
Notice the shadowing of the case binder! And now all is well.

The reason it's a hack is because if you define mySeq=seq, the hack
won't work on mySeq.  

Note [Desugaring seq (3)] cf Trac #2409
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The isLocalId ensures that we don't turn 
        True `seq` e
into
        case True of True { ... }
which stupidly tries to bind the datacon 'True'. 

\begin{code}
mkCoreAppDs  :: CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
  where
    case_bndr = case arg1 of
                   Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
                   _                     -> mkWildBinder ty1

mkCoreAppDs fun arg = mkCoreApp fun arg	 -- The rest is done in MkCore

mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
\end{code}


483 484 485 486 487 488 489 490
%************************************************************************
%*									*
\subsection[mkSelectorBind]{Make a selector bind}
%*									*
%************************************************************************

This is used in various places to do with lazy patterns.
For each binder $b$ in the pattern, we create a binding:
491
\begin{verbatim}
492
    b = case v of pat' -> b'
493 494
\end{verbatim}
where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
495 496 497 498 499 500 501 502 503 504 505

ToDo: making these bindings should really depend on whether there's
much work to be done per binding.  If the pattern is complex, it
should be de-mangled once, into a tuple (and then selected from).
Otherwise the demangling can be in-line in the bindings (as here).

Boring!  Boring!  One error message per binder.  The above ToDo is
even more helpful.  Something very similar happens for pattern-bound
expressions.

\begin{code}
506 507
mkSelectorBinds :: LPat Id	-- The pattern
		-> CoreExpr	-- Expression to which the pattern is bound
508
		-> DsM [(Id,CoreExpr)]
509

510
mkSelectorBinds (L _ (VarPat v)) val_expr
511
  = return [(v, val_expr)]
sof's avatar
sof committed
512 513

mkSelectorBinds pat val_expr
514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536
  | isSingleton binders || is_simple_lpat pat = do
        -- Given   p = e, where p binds x,y
        -- we are going to make
        --      v = p   (where v is fresh)
        --      x = case v of p -> x
        --      y = case v of p -> x

        -- Make up 'v'
        -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
        -- This does not matter after desugaring, but there's a subtle 
        -- issue with implicit parameters. Consider
        --      (x,y) = ?i
        -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
        -- to the desugarer.  (Why opaque?  Because newtypes have to be.  Why
        -- does it get that type?  So that when we abstract over it we get the
        -- right top-level type  (?i::Int) => ...)
        --
        -- So to get the type of 'v', use the pattern not the rhs.  Often more
        -- efficient too.
      val_var <- newSysLocalDs (hsLPatType pat)

        -- For the error message we make one error-app, to avoid duplication.
        -- But we need it at different types... so we use coerce for that
537
      err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID  unitTy (ppr pat)
538 539 540 541 542 543 544 545
      err_var <- newSysLocalDs unitTy
      binds <- mapM (mk_bind val_var err_var) binders
      return ( (val_var, val_expr) : 
               (err_var, err_expr) :
               binds )


  | otherwise = do
546
      error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
547 548 549 550 551 552
      tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
      tuple_var <- newSysLocalDs tuple_ty
      let
          mk_tup_bind binder
            = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
      return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
553
  where
554
    binders     = collectPatBinders pat
555
    local_tuple = mkBigCoreVarTup binders
556
    tuple_ty    = exprType local_tuple
557

558
    mk_bind scrut_var err_var bndr_var = do
559
    -- (mk_bind sv err_var) generates
560
    --          bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
561
    -- Remember, pat binds bv
562 563 564
        rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
                                (Var bndr_var) error_expr
        return (bndr_var, rhs_expr)
565
      where
566 567
        error_expr = mkCoerce co (Var err_var)
        co         = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
568

569 570
    is_simple_lpat p = is_simple_pat (unLoc p)

571
    is_simple_pat (TuplePat ps Boxed _)        = all is_triv_lpat ps
572
    is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
573 574 575
    is_simple_pat (VarPat _)                   = True
    is_simple_pat (ParPat p)                   = is_simple_lpat p
    is_simple_pat _                                    = False
576

577 578
    is_triv_lpat p = is_triv_pat (unLoc p)

579
    is_triv_pat (VarPat _)  = True
580
    is_triv_pat (WildPat _) = True
581
    is_triv_pat (ParPat p)  = is_triv_lpat p
582 583 584 585
    is_triv_pat _           = False

\end{code}

586 587 588
Creating big tuples and their types for full Haskell expressions.
They work over *Ids*, and create tuples replete with their types,
which is whey they are not in HsUtils.
589 590 591

\begin{code}
mkLHsPatTup :: [LPat Id] -> LPat Id
592
mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
593
mkLHsPatTup [lpat] = lpat
594 595
mkLHsPatTup lpats  = L (getLoc (head lpats)) $ 
		     mkVanillaTuplePat lpats Boxed
596

597 598 599 600 601 602 603 604
mkLHsVarPatTup :: [Id] -> LPat Id
mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)

mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box 
  = TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))

605 606 607 608 609
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)

mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
610
mkBigLHsTup = mkChunkified mkLHsTupleExpr
611 612 613 614 615 616

-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [Id] -> LPat Id
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)

mkBigLHsPatTup :: [LPat Id] -> LPat Id
617
mkBigLHsPatTup = mkChunkified mkLHsPatTup
618 619
\end{code}

620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639
%************************************************************************
%*									*
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%*									*
%************************************************************************

Generally, we handle pattern matching failure like this: let-bind a
fail-variable, and use that variable if the thing fails:
\begin{verbatim}
	let fail.33 = error "Help"
	in
	case x of
		p1 -> ...
		p2 -> fail.33
		p3 -> fail.33
		p4 -> ...
\end{verbatim}
Then
\begin{itemize}
\item
640
If the case can't fail, then there'll be no mention of @fail.33@, and the
641 642 643 644 645 646 647 648 649 650
simplifier will later discard it.

\item
If it can fail in only one way, then the simplifier will inline it.

\item
Only if it is used more than once will the let-binding remain.
\end{itemize}

There's a problem when the result of the case expression is of
651
unboxed type.  Then the type of @fail.33@ is unboxed too, and
652 653 654 655 656 657 658
there is every chance that someone will change the let into a case:
\begin{verbatim}
	case error "Help" of
	  fail.33 -> case ....
\end{verbatim}

which is of course utterly wrong.  Rather than drop the condition that
659
only boxed types can be let-bound, we just turn the fail into a function
660 661
for the primitive case:
\begin{verbatim}
662
	let fail.33 :: Void -> Int#
663 664 665 666
	    fail.33 = \_ -> error "Help"
	in
	case x of
		p1 -> ...
667 668
		p2 -> fail.33 void
		p3 -> fail.33 void
669 670 671
		p4 -> ...
\end{verbatim}

672
Now @fail.33@ is a function, so it can be let-bound.
673 674

\begin{code}
675 676
mkFailurePair :: CoreExpr	-- Result type of the whole case expression
	      -> DsM (CoreBind,	-- Binds the newly-created fail variable
677 678 679
				-- to either the expression or \ _ -> expression
		      CoreExpr)	-- Either the fail variable, or fail variable
				-- applied to unit tuple
680
mkFailurePair expr
681 682 683 684 685 686 687 688 689
  | isUnLiftedType ty = do
     fail_fun_var <- newFailLocalDs (unitTy `mkFunTy` ty)
     fail_fun_arg <- newSysLocalDs unitTy
     return (NonRec fail_fun_var (Lam fail_fun_arg expr),
             App (Var fail_fun_var) (Var unitDataConId))

  | otherwise = do
     fail_var <- newFailLocalDs ty
     return (NonRec fail_var expr, Var fail_var)
690
  where
691
    ty = exprType expr
692 693
\end{code}

andy@galois.com's avatar
andy@galois.com committed
694
\begin{code}
695
mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
andy@galois.com's avatar
andy@galois.com committed
696
mkOptTickBox Nothing e   = return e
697
mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e
andy@galois.com's avatar
andy@galois.com committed
698

699 700
mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
mkTickBox ix vars e = do
701
       uq <- newUnique 	
andy@galois.com's avatar
andy@galois.com committed
702
       mod <- getModuleDs
703 704
       let tick | opt_Hpc   = mkTickBoxOpId uq mod ix
                | otherwise = mkBreakPointOpId uq mod ix
705 706
       uq2 <- newUnique 	
       let occName = mkVarOcc "tick"
707
       let name = mkInternalName uq2 occName noSrcSpan   -- use mkSysLocal?
708
       let var  = Id.mkLocalId name realWorldStatePrimTy
709 710 711 712 713
       scrut <- 
          if opt_Hpc 
            then return (Var tick)
            else do
              let tickVar = Var tick
714
              let tickType = mkFunTys (map idType vars) realWorldStatePrimTy 
715
              let scrutApTy = App tickVar (Type tickType)
716
              return (mkApps scrutApTy (map Var vars) :: Expr Id)
717
       return $ Case scrut var ty [(DEFAULT,[],e)]
718 719
  where
     ty = exprType e
andy@galois.com's avatar
andy@galois.com committed
720 721 722

mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
723
       uq <- newUnique 	
Ian Lynagh's avatar
Ian Lynagh committed
724
       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy 
725 726
       falseBox <- mkTickBox ixF [] $ Var falseDataConId
       trueBox  <- mkTickBox ixT [] $ Var trueDataConId
727 728 729 730
       return $ Case e bndr1 boolTy
                       [ (DataAlt falseDataCon, [], falseBox)
                       , (DataAlt trueDataCon,  [], trueBox)
                       ]
731
\end{code}