DsUtils.hs 36.3 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

Utilities for desugaring
7 8

This module exports some utility functions of no great interest.
Austin Seipp's avatar
Austin Seipp committed
9
-}
10

11
{-# LANGUAGE CPP #-}
12 13
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
14
{-# LANGUAGE ViewPatterns #-}
Ian Lynagh's avatar
Ian Lynagh committed
15

16
-- | Utility functions for constructing Core syntax, principally for desugaring
17
module DsUtils (
18 19
        EquationInfo(..),
        firstPat, shiftEqns,
20

21 22 23 24 25 26 27 28
        MatchResult(..), CanItFail(..), CaseAlt(..),
        cantFailMatchResult, alwaysFailMatchResult,
        extractMatchResult, combineMatchResults,
        adjustMatchResult,  adjustMatchResultDs,
        mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
        matchCanFail, mkEvalMatchResult,
        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
        wrapBind, wrapBinds,
29

30
        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
31 32 33 34

        seqVar,

        -- LHs tuples
35
        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
Simon Marlow's avatar
Simon Marlow committed
36
        mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
37 38 39

        mkSelectorBinds,

40
        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
41 42
        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
        isTrueLHsExpr
43 44
    ) where

45 46
#include "HsVersions.h"

47 48
import GhcPrelude

49 50
import {-# SOURCE #-} Match  ( matchSimply )
import {-# SOURCE #-} DsExpr ( dsLExpr )
51

52
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
53
import TcHsSyn
54
import TcType( tcSplitTyConApp )
55 56 57
import CoreSyn
import DsMonad

Simon Marlow's avatar
Simon Marlow committed
58
import CoreUtils
59
import MkCore
Simon Marlow's avatar
Simon Marlow committed
60 61 62 63 64
import MkId
import Id
import Literal
import TyCon
import DataCon
Gergő Érdi's avatar
Gergő Érdi committed
65
import PatSyn
Simon Marlow's avatar
Simon Marlow committed
66
import Type
67
import Coercion
Simon Marlow's avatar
Simon Marlow committed
68 69 70
import TysPrim
import TysWiredIn
import BasicTypes
71
import ConLike
Simon Marlow's avatar
Simon Marlow committed
72 73
import UniqSet
import UniqSupply
74
import Module
Simon Marlow's avatar
Simon Marlow committed
75
import PrelNames
76
import Name( isInternalName )
sof's avatar
sof committed
77
import Outputable
Simon Marlow's avatar
Simon Marlow committed
78 79
import SrcLoc
import Util
Ian Lynagh's avatar
Ian Lynagh committed
80
import DynFlags
81
import FastString
82
import qualified GHC.LanguageExtensions as LangExt
83

Gergő Érdi's avatar
Gergő Érdi committed
84 85
import TcEvidence

86
import Control.Monad    ( zipWithM )
sof's avatar
sof committed
87

Austin Seipp's avatar
Austin Seipp committed
88 89 90
{-
************************************************************************
*                                                                      *
91
\subsection{ Selecting match variables}
Austin Seipp's avatar
Austin Seipp committed
92 93
*                                                                      *
************************************************************************
sof's avatar
sof committed
94 95 96 97 98

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.
Austin Seipp's avatar
Austin Seipp committed
99
-}
sof's avatar
sof committed
100

101
selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
102
-- Postcondition: the returned Id has an Internal Name
103
selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
104 105 106 107

-- (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.
108 109 110
--
-- OLD, but interesting note:
--    But even if it is a variable, its type might not match.  Consider
111 112 113
--      data T a where
--        T1 :: Int -> T Int
--        T2 :: a   -> T a
114
--
115 116 117
--      f :: T a -> a -> Int
--      f (T1 i) (x::Int) = x
--      f (T2 i) (y::a)   = 0
118 119 120
--    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

121
selectMatchVars :: [Pat GhcTc] -> DsM [Id]
122
-- Postcondition: the returned Ids have Internal Names
123 124
selectMatchVars ps = mapM selectMatchVar ps

125
selectMatchVar :: Pat GhcTc -> DsM Id
126
-- Postcondition: the returned Id has an Internal Name
127 128 129 130
selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat _ pat)  = selectMatchVar (unLoc pat)
selectMatchVar (VarPat _ var)  = return (localiseId (unLoc var))
131
                                  -- Note [Localise pattern binders]
132 133
selectMatchVar (AsPat _ var _) = return (unLoc var)
selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)
134
                                  -- OK, better make up one...
sof's avatar
sof committed
135

136 137
{- Note [Localise pattern binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
Consider     module M where
               [Just a] = e
After renaming it looks like
             module M where
               [Just M.a] = e

We don't generalise, since it's a pattern binding, monomorphic, etc,
so after desugaring we may get something like
             M.a = case e of (v:_) ->
                   case v of Just M.a -> M.a
Notice the "M.a" in the pattern; after all, it was in the original
pattern.  However, after optimisation those pattern binders can become
let-binders, and then end up floated to top level.  They have a
different *unique* by then (the simplifier is good about maintaining
proper scoping), but it's BAD to have two top-level bindings with the
External Name M.a, because that turns into two linker symbols for M.a.
It's quite rare for this to actually *happen* -- the only case I know
155
of is tc003 compiled with the 'hpc' way -- but that only makes it
156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
all the more annoying.

To avoid this, we craftily call 'localiseId' in the desugarer, which
simply turns the External Name for the Id into an Internal one, but
doesn't change the unique.  So the desugarer produces this:
             M.a{r8} = case e of (v:_) ->
                       case v of Just a{r8} -> M.a{r8}
The unique is still 'r8', but the binding site in the pattern
is now an Internal Name.  Now the simplifier's usual mechanisms
will propagate that Name to all the occurrence sites, as well as
un-shadowing it, so we'll get
             M.a{r8} = case e of (v:_) ->
                       case v of Just a{s77} -> a{s77}
In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
runs on the output of the desugarer, so all is well by the end of
the desugaring pass.

173
See also Note [MatchIds] in Match.hs
sof's avatar
sof committed
174

Austin Seipp's avatar
Austin Seipp committed
175 176 177 178 179
************************************************************************
*                                                                      *
* type synonym EquationInfo and access functions for its pieces        *
*                                                                      *
************************************************************************
180 181 182 183
\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.
Austin Seipp's avatar
Austin Seipp committed
184
-}
185

186
firstPat :: EquationInfo -> Pat GhcTc
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
187
firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
188

189
shiftEqns :: [EquationInfo] -> [EquationInfo]
190 191
-- Drop the first pattern in each equation
shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
192

Austin Seipp's avatar
Austin Seipp committed
193
-- Functions on MatchResults
194

195 196 197 198
matchCanFail :: MatchResult -> Bool
matchCanFail (MatchResult CanFail _)  = True
matchCanFail (MatchResult CantFail _) = False

199
alwaysFailMatchResult :: MatchResult
200
alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
201

202
cantFailMatchResult :: CoreExpr -> MatchResult
203
cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
204

205
extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
206
extractMatchResult (MatchResult CantFail match_fn) _
207
  = match_fn (error "It can't fail!")
208

209 210 211
extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
    (fail_bind, if_it_fails) <- mkFailurePair fail_expr
    body <- match_fn if_it_fails
212
    return (mkCoreLet fail_bind body)
213

214 215 216

combineMatchResults :: MatchResult -> MatchResult -> MatchResult
combineMatchResults (MatchResult CanFail      body_fn1)
217
                    (MatchResult can_it_fail2 body_fn2)
218 219
  = MatchResult can_it_fail2 body_fn
  where
220 221 222 223
    body_fn fail = do body2 <- body_fn2 fail
                      (fail_bind, duplicatable_expr) <- mkFailurePair body2
                      body1 <- body_fn1 duplicatable_expr
                      return (Let fail_bind body1)
224

225
combineMatchResults match_result1@(MatchResult CantFail _) _
226 227
  = match_result1

228
adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
229
adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
230
  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
231 232 233

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

236 237 238
wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
wrapBinds [] e = e
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
239

240
wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
241 242
wrapBind new old body   -- NB: this function must deal with term
  | new==old    = body  -- variables, type variables or coercion variables
243
  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
244

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
245 246
seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = Case (Var var) var (exprType body)
247
                        [(DEFAULT, [], body)]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
248

249
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
250
mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
251

252 253 254 255 256
-- (mkViewMatchResult var' viewExpr mr) makes the expression
-- let var' = viewExpr in mr
mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
mkViewMatchResult var' viewExpr =
    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
257

258 259
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
260
  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
261 262

mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
263
mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
264 265
  = MatchResult CanFail (\fail -> do body <- body_fn fail
                                     return (mkIfThenElse pred_expr body fail))
266

267
mkCoPrimCaseMatchResult :: Id                  -- Scrutinee
268 269 270
                        -> Type                      -- Type of the case
                        -> [(Literal, MatchResult)]  -- Alternatives
                        -> MatchResult               -- Literals are all unlifted
271
mkCoPrimCaseMatchResult var ty match_alts
272
  = MatchResult CanFail mk_case
273
  where
274 275 276
    mk_case fail = do
        alts <- mapM (mk_alt fail) sorted_alts
        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
277

278
    sorted_alts = sortWith fst match_alts       -- Right order for a Case
279 280 281 282
    mk_alt fail (lit, MatchResult _ body_fn)
       = ASSERT( not (litIsLifted lit) )
         do body <- body_fn fail
            return (LitAlt lit, [], body)
283

Gergő Érdi's avatar
Gergő Érdi committed
284
data CaseAlt a = MkCaseAlt{ alt_pat :: a,
285
                            alt_bndrs :: [Var],
Gergő Érdi's avatar
Gergő Érdi committed
286 287
                            alt_wrapper :: HsWrapper,
                            alt_result :: MatchResult }
288

289
mkCoAlgCaseMatchResult
290
  :: Id                 -- Scrutinee
Gergő Érdi's avatar
Gergő Érdi committed
291 292
  -> Type               -- Type of exp
  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
293
  -> MatchResult
294
mkCoAlgCaseMatchResult var ty match_alts
Gergő Érdi's avatar
Gergő Érdi committed
295
  | isNewtype  -- Newtype case; use a let
296
  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
297
    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
298

Gergő Érdi's avatar
Gergő Érdi committed
299 300
  | otherwise
  = mkDataConCase var ty match_alts
301
  where
Gergő Érdi's avatar
Gergő Érdi committed
302 303
    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))

304 305
        -- [Interesting: because of GADTs, we can't rely on the type of
        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
306

Gergő Érdi's avatar
Gergő Érdi committed
307 308 309 310 311
    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }
      = ASSERT( notNull match_alts ) head match_alts
    -- Stuff for newtype
    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1
    var_ty        = idType var
312 313
    (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
314
    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
chak's avatar
chak committed
315

Gergő Érdi's avatar
Gergő Érdi committed
316 317 318 319 320 321 322 323
mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt

sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
sort_alts = sortWith (dataConTag . alt_pat)

mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase var ty alt fail = do
324
    matcher <- dsLExpr $ mkLHsWrap wrapper $
325
                         nlHsTyApp matcher [getRuntimeRep ty, ty]
Gergő Érdi's avatar
Gergő Érdi committed
326 327
    let MatchResult _ mkCont = match_result
    cont <- mkCoreLams bndrs <$> mkCont fail
328
    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
Gergő Érdi's avatar
Gergő Érdi committed
329 330 331 332 333
  where
    MkCaseAlt{ alt_pat = psyn,
               alt_bndrs = bndrs,
               alt_wrapper = wrapper,
               alt_result = match_result} = alt
334
    (matcher, needs_void_lam) = patSynMatcher psyn
Gergő Érdi's avatar
Gergő Érdi committed
335

336
    -- See Note [Matchers and builders for pattern synonyms] in PatSyns
337
    -- on these extra Void# arguments
338 339
    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
                         | otherwise      = cont
340

Gergő Érdi's avatar
Gergő Érdi committed
341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388
mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
  where
    con1          = alt_pat alt1
    tycon         = dataConTyCon con1
    data_cons     = tyConDataCons tycon
    match_results = map alt_result alts

    sorted_alts :: [CaseAlt DataCon]
    sorted_alts  = sort_alts alts

    var_ty       = idType var
    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
                                          -- (not that splitTyConApp does, these days)

    mk_case :: CoreExpr -> DsM CoreExpr
    mk_case fail = do
        alts <- mapM (mk_alt fail) sorted_alts
        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)

    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
    mk_alt fail MkCaseAlt{ alt_pat = con,
                           alt_bndrs = args,
                           alt_result = MatchResult _ body_fn }
      = do { body <- body_fn fail
           ; case dataConBoxer con of {
                Nothing -> return (DataAlt con, args, body) ;
                Just (DCB boxer) ->
        do { us <- newUniqueSupply
           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
           ; return (DataAlt con, rep_ids, mkLets binds body) } } }

    mk_default :: CoreExpr -> [CoreAlt]
    mk_default fail | exhaustive_case = []
                    | otherwise       = [(DEFAULT, [], fail)]

    fail_flag :: CanItFail
    fail_flag | exhaustive_case
              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
              | otherwise
              = CanFail

    mentioned_constructors = mkUniqSet $ map alt_pat alts
    un_mentioned_constructors
        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
    exhaustive_case = isEmptyUniqSet un_mentioned_constructors

Austin Seipp's avatar
Austin Seipp committed
389 390 391
{-
************************************************************************
*                                                                      *
392
\subsection{Desugarer's versions of some Core functions}
Austin Seipp's avatar
Austin Seipp committed
393 394 395
*                                                                      *
************************************************************************
-}
396

397 398 399 400
mkErrorAppDs :: Id              -- The error function
             -> Type            -- Type to which it should be applied
             -> SDoc            -- The error message string to pass
             -> DsM CoreExpr
401

402 403
mkErrorAppDs err_id ty msg = do
    src_loc <- getSrcSpanDs
Ian Lynagh's avatar
Ian Lynagh committed
404
    dflags <- getDynFlags
405
    let
406
        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
Sylvain Henry's avatar
Sylvain Henry committed
407 408
        core_msg = Lit (mkLitString full_msg)
        -- mkLitString returns a result of type String#
409
    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
410

Austin Seipp's avatar
Austin Seipp committed
411
{-
412 413 414 415 416 417
'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 #))

418
The [CoreSyn let/app invariant] means that, other things being equal, because
419 420 421 422
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

423 424
But that is bad for two reasons:
  (a) we now evaluate y before x, and
425 426 427 428 429
  (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 #)

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
430
Note [Desugaring seq (2)]  cf Trac #2273
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
~~~~~~~~~~~~~~~~~~~~~~~~~
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
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
458 459 460 461 462
the case expression, thus:
   x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
   e1 `seq` e2 ==> case x of _ -> e2

So we desugar our example to:
463 464
   let chp = case b of { True -> fst x; False -> 0 }
   case chp of chp { I# -> ...chp... }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
465
And now all is well.
466 467

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

Note [Desugaring seq (3)] cf Trac #2409
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
472
The isLocalId ensures that we don't turn
473 474 475
        True `seq` e
into
        case True of True { ... }
476
which stupidly tries to bind the datacon 'True'.
Austin Seipp's avatar
Austin Seipp committed
477
-}
478

479
-- NB: Make sure the argument is not levity polymorphic
480 481
mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
482 483 484 485
  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
  where
    case_bndr = case arg1 of
486 487 488
                   Var v1 | isInternalName (idName v1)
                          -> v1        -- Note [Desugaring seq (2) and (3)]
                   _      -> mkWildValBinder ty1
489

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

492
-- NB: No argument can be levity polymorphic
493
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
494
mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
495

496
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
497
-- We define a desugarer-specific version of CoreUtils.mkCast,
498 499 500 501 502 503 504 505 506 507
-- because in the immediate output of the desugarer, we can have
-- apparently-mis-matched coercions:  E.g.
--     let a = b
--     in (x :: a) |> (co :: b ~ Int)
-- Lint know about type-bindings for let and does not complain
-- So here we do not make the assertion checks that we make in
-- CoreUtils.mkCast; and we do less peephole optimisation too
mkCastDs e co | isReflCo co = e
              | otherwise   = Cast e co

Austin Seipp's avatar
Austin Seipp committed
508 509 510
{-
************************************************************************
*                                                                      *
511
               Tuples and selector bindings
Austin Seipp's avatar
Austin Seipp committed
512 513
*                                                                      *
************************************************************************
514 515 516

This is used in various places to do with lazy patterns.
For each binder $b$ in the pattern, we create a binding:
517
\begin{verbatim}
518
    b = case v of pat' -> b'
519 520
\end{verbatim}
where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
521 522 523 524 525 526 527 528 529 530

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.

531 532
Note [mkSelectorBinds]
~~~~~~~~~~~~~~~~~~~~~~
533 534 535 536 537 538
mkSelectorBinds is used to desugar a pattern binding {p = e},
in a binding group:
  let { ...; p = e; ... } in body
where p binds x,y (this list of binders can be empty).
There are two cases.

539 540 541 542 543 544
------ Special case (A) -------
  For a pattern that is just a variable,
     let !x = e in body
  ==>
     let x = e in x `seq` body
  So we return the binding, with 'x' as the variable to seq.
545

546
------ Special case (B) -------
547 548 549 550 551 552 553 554 555 556 557
  For a pattern that is essentially just a tuple:
      * A product type, so cannot fail
      * Only one level, so that
          - generating multiple matches is fine
          - seq'ing it evaluates the same as matching it
  Then instead we generate
       { v = e
       ; x = case v of p -> x
       ; y = case v of p -> y }
  with 'v' as the variable to force

558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589
------ General case (C) -------
  In the general case we generate these bindings:
       let { ...; p = e; ... } in body
  ==>
       let { t = case e of p -> (x,y)
           ; x = case t of (x,y) -> x
           ; y = case t of (x,y) -> y }
       in t `seq` body

  Note that we return 't' as the variable to force if the pattern
  is strict (i.e. with -XStrict or an outermost-bang-pattern)

  Note that (A) /includes/ the situation where

   * The pattern binds exactly one variable
        let !(Just (Just x) = e in body
     ==>
       let { t = case e of Just (Just v) -> Unit v
           ; v = case t of Unit v -> v }
       in t `seq` body
    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
    Note that forcing 't' makes the pattern match happen,
    but does not force 'v'.

  * The pattern binds no variables
        let !(True,False) = e in body
    ==>
        let t = case e of (True,False) -> ()
        in t `seq` body


------ Examples ----------
590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660
  *   !(_, (_, a)) = e
    ==>
      t = case e of (_, (_, a)) -> Unit a
      a = case t of Unit a -> a

    Note that
     - Forcing 't' will force the pattern to match fully;
       e.g. will diverge if (snd e) is bottom
     - But 'a' itself is not forced; it is wrapped in a one-tuple
       (see Note [One-tuples] in TysWiredIn)

  *   !(Just x) = e
    ==>
      t = case e of Just x -> Unit x
      x = case t of Unit x -> x

    Again, forcing 't' will fail if 'e' yields Nothing.

Note that even though this is rather general, the special cases
work out well:

* One binder, not -XStrict:

    let Just (Just v) = e in body
  ==>
    let t = case e of Just (Just v) -> Unit v
        v = case t of Unit v -> v
    in body
  ==>
    let v = case (case e of Just (Just v) -> Unit v) of
              Unit v -> v
    in body
  ==>
    let v = case e of Just (Just v) -> v
    in body

* Non-recursive, -XStrict
     let p = e in body
  ==>
     let { t = case e of p -> (x,y)
         ; x = case t of (x,y) -> x
         ; y = case t of (x,y) -> x }
     in t `seq` body
  ==> {inline seq, float x,y bindings inwards}
     let t = case e of p -> (x,y) in
     case t of t' ->
     let { x = case t' of (x,y) -> x
         ; y = case t' of (x,y) -> x } in
     body
  ==> {inline t, do case of case}
     case e of p ->
     let t = (x,y) in
     let { x = case t' of (x,y) -> x
         ; y = case t' of (x,y) -> x } in
     body
  ==> {case-cancellation, drop dead code}
     case e of p -> body

* Special case (B) is there to avoid fruitlessly taking the tuple
  apart and rebuilding it. For example, consider
     { K x y = e }
  where K is a product constructor.  Then general case (A) does:
     { t = case e of K x y -> (x,y)
     ; x = case t of (x,y) -> x
     ; y = case t of (x,y) -> y }
  In the lazy case we can't optimise out this fruitless taking apart
  and rebuilding.  Instead (B) builds
     { v = e
     ; x = case v of K x y -> x
     ; y = case v of K x y -> y }
  which is better.
Austin Seipp's avatar
Austin Seipp committed
661
-}
662

663
mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
664
                -> LPat GhcTc     -- ^ The pattern
665
                -> CoreExpr       -- ^ Expression to which the pattern is bound
666
                -> DsM (Id,[(Id,CoreExpr)])
667 668 669 670
                -- ^ Id the rhs is bound to, for desugaring strict
                -- binds (see Note [Desugar Strict binds] in DsBinds)
                -- and all the desugared binds

671
mkSelectorBinds ticks pat val_expr
672
  | (dL->L _ (VarPat _ (dL->L _ v))) <- pat'     -- Special case (A)
673 674 675 676
  = return (v, [(v, val_expr)])

  | is_flat_prod_lpat pat'           -- Special case (B)
  = do { let pat_ty = hsLPatType pat'
Richard Eisenberg's avatar
Richard Eisenberg committed
677
       ; val_var <- newSysLocalDsNoLP pat_ty
678

679
       ; let mk_bind tick bndr_var
680 681
               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
               -- Remember, 'pat' binds 'bv'
682
               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
683 684 685 686 687 688 689 690
                                       (Var bndr_var)
                                       (Var bndr_var)  -- Neat hack
                      -- Neat hack: since 'pat' can't fail, the
                      -- "fail-expr" passed to matchSimply is not
                      -- used. But it /is/ used for its type, and for
                      -- that bndr_var is just the ticket.
                    ; return (bndr_var, mkOptTickBox tick rhs_expr) }

691
       ; binds <- zipWithM mk_bind ticks' binders
692 693
       ; return ( val_var, (val_var, val_expr) : binds) }

694
  | otherwise                          -- General case (C)
695
  = do { tuple_var  <- newSysLocalDs tuple_ty
696
       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
697
       ; tuple_expr <- matchSimply val_expr PatBindRhs pat
698
                                   local_tuple error_expr
699
       ; let mk_tup_bind tick binder
700
               = (binder, mkOptTickBox tick $
701 702 703 704
                          mkTupleSelector1 local_binders binder
                                           tuple_var (Var tuple_var))
             tup_binds = zipWith mk_tup_bind ticks' binders
       ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
705
  where
706 707 708 709 710
    pat' = strip_bangs pat
           -- Strip the bangs before looking for case (A) or (B)
           -- The incoming pattern may well have a bang on it

    binders = collectPatBinders pat'
711
    ticks'  = ticks ++ repeat []
712 713

    local_binders = map localiseId binders      -- See Note [Localise pattern binders]
714
    local_tuple   = mkBigCoreVarTup1 binders
715
    tuple_ty      = exprType local_tuple
716

717
strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
718
-- Remove outermost bangs and parens
719 720 721
strip_bangs (dL->L _ (ParPat _ p))  = strip_bangs p
strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p
strip_bangs lp                      = lp
722

723 724
is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
is_flat_prod_lpat = is_flat_prod_pat . unLoc
725

726
is_flat_prod_pat :: Pat (GhcPass p) -> Bool
727 728
is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p
is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
729 730
is_flat_prod_pat (ConPatOut { pat_con  = (dL->L _ pcon)
                            , pat_args = ps})
731 732 733 734
  | RealDataCon con <- pcon
  , isProductTyCon (dataConTyCon con)
  = all is_triv_lpat (hsConPatArgs ps)
is_flat_prod_pat _ = False
735

736 737
is_triv_lpat :: LPat (GhcPass p) -> Bool
is_triv_lpat = is_triv_pat . unLoc
738

739
is_triv_pat :: Pat (GhcPass p) -> Bool
740 741 742 743
is_triv_pat (VarPat {})  = True
is_triv_pat (WildPat{})  = True
is_triv_pat (ParPat _ p) = is_triv_lpat p
is_triv_pat _            = False
744

745 746 747 748 749 750 751 752

{- *********************************************************************
*                                                                      *
  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.
*                                                                      *
********************************************************************* -}
753

754
mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
755
mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
756
mkLHsPatTup [lpat] = lpat
757
mkLHsPatTup lpats  = cL (getLoc (head lpats)) $
758
                     mkVanillaTuplePat lpats Boxed
759

760
mkLHsVarPatTup :: [Id] -> LPat GhcTc
761 762
mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)

763
mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
764
-- A vanilla tuple pattern simply gets its type from its sub-patterns
765
mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
766

767
-- The Big equivalents for the source tuple expressions
768
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
Simon Marlow's avatar
Simon Marlow committed
769
mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
770

771
mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
Simon Marlow's avatar
Simon Marlow committed
772
mkBigLHsTupId = mkChunkified mkLHsTupleExpr
773 774

-- The Big equivalents for the source tuple patterns
775
mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
Simon Marlow's avatar
Simon Marlow committed
776
mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
777

778
mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
Simon Marlow's avatar
Simon Marlow committed
779
mkBigLHsPatTupId = mkChunkified mkLHsPatTup
780

Austin Seipp's avatar
Austin Seipp committed
781 782 783
{-
************************************************************************
*                                                                      *
784
        Code for pattern-matching and other failures
Austin Seipp's avatar
Austin Seipp committed
785 786
*                                                                      *
************************************************************************
787 788 789 790

Generally, we handle pattern matching failure like this: let-bind a
fail-variable, and use that variable if the thing fails:
\begin{verbatim}
791 792 793 794 795 796 797
        let fail.33 = error "Help"
        in
        case x of
                p1 -> ...
                p2 -> fail.33
                p3 -> fail.33
                p4 -> ...
798 799 800 801
\end{verbatim}
Then
\begin{itemize}
\item
802
If the case can't fail, then there'll be no mention of @fail.33@, and the
803 804 805 806 807 808 809 810 811 812
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
813
unboxed type.  Then the type of @fail.33@ is unboxed too, and
814 815
there is every chance that someone will change the let into a case:
\begin{verbatim}
816 817
        case error "Help" of
          fail.33 -> case ....
818 819 820
\end{verbatim}

which is of course utterly wrong.  Rather than drop the condition that
821
only boxed types can be let-bound, we just turn the fail into a function
822 823
for the primitive case:
\begin{verbatim}
824 825 826 827 828 829 830 831
        let fail.33 :: Void -> Int#
            fail.33 = \_ -> error "Help"
        in
        case x of
                p1 -> ...
                p2 -> fail.33 void
                p3 -> fail.33 void
                p4 -> ...
832 833
\end{verbatim}

834
Now @fail.33@ is a function, so it can be let-bound.
lukemaurer's avatar
lukemaurer committed
835 836 837 838 839 840 841 842 843

We would *like* to use join points here; in fact, these "fail variables" are
paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
CPS functions - i.e. they take "join points" as parameters. It's not impossible
to imagine extending our type system to allow passing join points around (very
carefully), but we certainly don't support it now.

99.99% of the time, the fail variables wind up as join points in short order
anyway, and the Void# doesn't do much harm.
Austin Seipp's avatar
Austin Seipp committed
844
-}
845

846 847 848 849
mkFailurePair :: CoreExpr       -- Result type of the whole case expression
              -> DsM (CoreBind, -- Binds the newly-created fail variable
                                -- to \ _ -> expression
                      CoreExpr) -- Fail variable applied to realWorld#
850
-- See Note [Failure thunks and CPR]
851
mkFailurePair expr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
852
  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty)
853 854 855 856
       ; fail_fun_arg <- newSysLocalDs voidPrimTy
       ; let real_arg = setOneShotLambda fail_fun_arg
       ; return (NonRec fail_fun_var (Lam real_arg expr),
                 App (Var fail_fun_var) (Var voidPrimId)) }
857
  where
858
    ty = exprType expr
859

Austin Seipp's avatar
Austin Seipp committed
860
{-
861 862
Note [Failure thunks and CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
lukemaurer's avatar
lukemaurer committed
863 864 865 866 867
(This note predates join points as formal entities (hence the quotation marks).
We can't use actual join points here (see above); if we did, this would also
solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
join points] in WorkWrap.)

868 869 870 871
When we make a failure point we ensure that it
does not look like a thunk. Example:

   let fail = \rw -> error "urk"
872
   in case x of
873 874
        [] -> fail realWorld#
        (y:ys) -> case ys of
875
                    [] -> fail realWorld#
876 877 878 879 880 881 882
                    (z:zs) -> (y,z)

Reason: we know that a failure point is always a "join point" and is
entered at most once.  Adding a dummy 'realWorld' token argument makes
it clear that sharing is not an issue.  And that in turn makes it more
CPR-friendly.  This matters a lot: if you don't get it right, you lose
the tail call property.  For example, see Trac #3403.
883 884 885 886 887 888 889


************************************************************************
*                                                                      *
              Ticks
*                                                                      *
********************************************************************* -}
890

891 892
mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox = flip (foldr Tick)
andy@galois.com's avatar
andy@galois.com committed
893 894 895

mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
896
       uq <- newUnique
897
       this_mod <- getModule
898 899 900 901 902
       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
       let
           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
       --
903 904 905 906
       return $ Case e bndr1 boolTy
                       [ (DataAlt falseDataCon, [], falseBox)
                       , (DataAlt trueDataCon,  [], trueBox)
                       ]
907 908 909 910 911



-- *******************************************************************

912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941
{- Note [decideBangHood]
~~~~~~~~~~~~~~~~~~~~~~~~
With -XStrict we may make /outermost/ patterns more strict.
E.g.
       let (Just x) = e in ...
          ==>
       let !(Just x) = e in ...
and
       f x = e
          ==>
       f !x = e

This adjustment is done by decideBangHood,

  * Just before constructing an EqnInfo, in Match
      (matchWrapper and matchSinglePat)

  * When desugaring a pattern-binding in DsBinds.dsHsBind

Note that it is /not/ done recursively.  See the -XStrict
spec in the user manual.

Specifically:
   ~pat    => pat    -- when -XStrict (even if pat = ~pat')
   !pat    => !pat   -- always
   pat     => !pat   -- when -XStrict
   pat     => pat    -- otherwise
-}


942
-- | Use -XStrict to add a ! or remove a ~
943
-- See Note [decideBangHood]
944
decideBangHood :: DynFlags
945 946
               -> LPat GhcTc  -- ^ Original pattern
               -> LPat GhcTc  -- Pattern with bang if necessary