DsUtils.hs 36.1 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 #-}
Ian Lynagh's avatar
Ian Lynagh committed
14

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

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

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

        seqVar,

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

        mkSelectorBinds,

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

44
45
#include "HsVersions.h"

46
47
import GhcPrelude

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

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

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

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

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

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

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
98
-}
sof's avatar
sof committed
99

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

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

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

124
selectMatchVar :: Pat GhcTc -> DsM Id
125
-- Postcondition: the returned Id has an Internal Name
126
127
128
129
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))
130
                                  -- Note [Localise pattern binders]
131
132
selectMatchVar (AsPat _ var _) = return (unLoc var)
selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)
133
                                  -- OK, better make up one...
sof's avatar
sof committed
134

135
136
{- Note [Localise pattern binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
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
154
of is tc003 compiled with the 'hpc' way -- but that only makes it
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
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.

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

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

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

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

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

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

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

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

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

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

213
214
215

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

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

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

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

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

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

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

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

251
252
253
254
255
-- (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))
256

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

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

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

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

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

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

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

303
304
        -- [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]
305

Gergő Érdi's avatar
Gergő Érdi committed
306
307
308
309
310
    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
311
312
    (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
313
    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
chak's avatar
chak committed
314

Gergő Érdi's avatar
Gergő Érdi committed
315
316
317
318
319
320
321
322
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
323
    matcher <- dsLExpr $ mkLHsWrap wrapper $
324
                         nlHsTyApp matcher [getRuntimeRep ty, ty]
Gergő Érdi's avatar
Gergő Érdi committed
325
326
    let MatchResult _ mkCont = match_result
    cont <- mkCoreLams bndrs <$> mkCont fail
327
    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
Gergő Érdi's avatar
Gergő Érdi committed
328
329
330
331
332
  where
    MkCaseAlt{ alt_pat = psyn,
               alt_bndrs = bndrs,
               alt_wrapper = wrapper,
               alt_result = match_result} = alt
333
    (matcher, needs_void_lam) = patSynMatcher psyn
Gergő Érdi's avatar
Gergő Érdi committed
334

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

Gergő Érdi's avatar
Gergő Érdi committed
340
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
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
388
389
390
{-
************************************************************************
*                                                                      *
391
\subsection{Desugarer's versions of some Core functions}
Austin Seipp's avatar
Austin Seipp committed
392
393
394
*                                                                      *
************************************************************************
-}
395

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

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

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

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

422
423
But that is bad for two reasons:
  (a) we now evaluate y before x, and
424
425
426
427
428
  (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
429
Note [Desugaring seq (2)]  cf Trac #2273
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
~~~~~~~~~~~~~~~~~~~~~~~~~
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
457
458
459
460
461
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:
462
463
   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
464
And now all is well.
465
466

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

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

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

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

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

495
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
496
-- We define a desugarer-specific version of CoreUtils.mkCast,
497
498
499
500
501
502
503
504
505
506
-- 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
507
508
509
{-
************************************************************************
*                                                                      *
510
               Tuples and selector bindings
Austin Seipp's avatar
Austin Seipp committed
511
512
*                                                                      *
************************************************************************
513
514
515

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

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.

530
531
Note [mkSelectorBinds]
~~~~~~~~~~~~~~~~~~~~~~
532
533
534
535
536
537
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.

538
539
540
541
542
543
------ 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.
544

545
------ Special case (B) -------
546
547
548
549
550
551
552
553
554
555
556
  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

557
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
------ 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 ----------
589
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
  *   !(_, (_, 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
660
-}
661

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

670
mkSelectorBinds ticks pat val_expr
671
  | L _ (VarPat _ (L _ v)) <- pat'     -- Special case (A)
672
673
674
675
  = 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
676
       ; val_var <- newSysLocalDsNoLP pat_ty
677

678
       ; let mk_bind tick bndr_var
679
680
               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
               -- Remember, 'pat' binds 'bv'
681
               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
682
683
684
685
686
687
688
689
                                       (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) }

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

693
  | otherwise                          -- General case (C)
694
  = do { tuple_var  <- newSysLocalDs tuple_ty
695
       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
696
       ; tuple_expr <- matchSimply val_expr PatBindRhs pat
697
                                   local_tuple error_expr
698
       ; let mk_tup_bind tick binder
699
               = (binder, mkOptTickBox tick $
700
701
702
703
                          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) }
704
  where
705
706
707
708
709
    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'
710
    ticks'  = ticks ++ repeat []
711
712

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

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

722
723
is_flat_prod_lpat :: LPat a -> Bool
is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
724

725
is_flat_prod_pat :: Pat a -> Bool
726
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
is_flat_prod_pat (ConPatOut { pat_con  = L _ pcon, pat_args = ps})
729
730
731
732
  | RealDataCon con <- pcon
  , isProductTyCon (dataConTyCon con)
  = all is_triv_lpat (hsConPatArgs ps)
is_flat_prod_pat _ = False
733

734
735
is_triv_lpat :: LPat a -> Bool
is_triv_lpat p = is_triv_pat (unLoc p)
736

737
is_triv_pat :: Pat a -> Bool
738
739
740
741
is_triv_pat (VarPat {})  = True
is_triv_pat (WildPat{})  = True
is_triv_pat (ParPat _ p) = is_triv_lpat p
is_triv_pat _            = False
742

743
744
745
746
747
748
749
750

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

752
mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
753
mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
754
mkLHsPatTup [lpat] = lpat
755
756
mkLHsPatTup lpats  = L (getLoc (head lpats)) $
                     mkVanillaTuplePat lpats Boxed
757

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

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

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

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

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

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

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

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

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

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

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
842
-}
843

844
845
846
847
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#
848
-- See Note [Failure thunks and CPR]
849
mkFailurePair expr
850
851
852
853
854
  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)
       ; 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)) }
855
  where
856
    ty = exprType expr
857

Austin Seipp's avatar
Austin Seipp committed
858
{-
859
860
Note [Failure thunks and CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
lukemaurer's avatar
lukemaurer committed
861
862
863
864
865
(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.)

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

   let fail = \rw -> error "urk"
870
   in case x of
871
872
        [] -> fail realWorld#
        (y:ys) -> case ys of
873
                    [] -> fail realWorld#
874
875
876
877
878
879
880
                    (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.
881
882
883
884
885
886
887


************************************************************************
*                                                                      *
              Ticks
*                                                                      *
********************************************************************* -}
888

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

mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
894
       uq <- newUnique
895
       this_mod <- getModule
896
897
898
899
900
       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
       let
           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
       --
901
902
903
904
       return $ Case e bndr1 boolTy
                       [ (DataAlt falseDataCon, [], falseBox)
                       , (DataAlt trueDataCon,  [], trueBox)
                       ]
ase's avatar
ase committed
905
906
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
{- 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
-}


940
-- | Use -XStrict to add a ! or remove a ~
941
-- See Note [decideBangHood]
942
decideBangHood :: DynFlags
943
944
               -> LPat GhcTc  -- ^ Original pattern
               -> LPat GhcTc  -- Pattern with bang if necessary
945
decideBangHood dflags lpat
946
947
948
  | not (xopt LangExt.Strict dflags)
  = lpat
  | otherwise   --  -XStrict
949
950
951
952
  = go lpat
  where
    go lp@(L l p)
      = case p of
953
954
955
956
           ParPat x p    -> L l (ParPat x (go p))
           LazyPat _ lp' -> lp'
           BangPat _ _   -> lp
           _             -> L l (BangPat noExt lp)
Ben Gamari's avatar
Ben Gamari committed
957
958

-- | Unconditionally make a 'Pat' strict.
959
960
addBang :: LPat GhcTc -- ^ Original pattern
        -> LPat GhcTc -- ^ Banged pattern
Ben Gamari's avatar
Ben Gamari committed
961
962
963
964
addBang = go
  where
    go lp@(L l p)
      = case p of
965
966
967
968
969
           ParPat x p    -> L l (ParPat x (go p))
           LazyPat _ lp' -> L l (BangPat noExt lp')
                                  -- Should we bring the extension value over?
           BangPat _ _   -> lp
           _             -> L l (BangPat noExt lp)
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998

isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)

-- Returns Just {..} if we're sure that the expression is True
-- I.e.   * 'True' datacon
--        * 'otherwise' Id
--        * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
isTrueLHsExpr (L _ (HsVar _ (L _ v))) |  v `hasKey` otherwiseIdKey
                                      || v `hasKey` getUnique trueDataConId
                                              = Just return
        -- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (L _ (HsConLikeOut _ con))
  | con `hasKey` getUnique trueDataCon = Just return
isTrueLHsExpr (L _ (HsTick _ tickish e))
    | Just ticks <- isTrueLHsExpr e
    = Just (\x -> do wrapped <- ticks x
                     return (Tick tickish wrapped))
   -- This encodes that the result is constant True for Hpc tick purposes;
   -- which is specifically what isTrueLHsExpr is trying to find out.
isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
    | Just ticks <- isTrueLHsExpr e
    = Just (\x -> do e <- ticks x
                     this_mod <- getModule
                     return (Tick (HpcTick this_mod ixT) e))

isTrueLHsExpr (L _ (HsPar _ e))         = isTrueLHsExpr e
isTrueLHsExpr _                       = Nothing