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

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

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

27
        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
28
29
30
31

        seqVar,

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

        mkSelectorBinds,

37
        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
38
        mkOptTickBox, mkBinaryTickBox, getUnBangedLPat
39
40
    ) where

41
42
#include "HsVersions.h"

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

45
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
46
import TcHsSyn
47
import TcType( tcSplitTyConApp )
48
49
import CoreSyn
import DsMonad
Gergő Érdi's avatar
Gergő Érdi committed
50
import {-# SOURCE #-} DsExpr ( dsLExpr )
51

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

Gergő Érdi's avatar
Gergő Érdi committed
77
78
import TcEvidence

79
import Control.Monad    ( zipWithM )
sof's avatar
sof committed
80

Austin Seipp's avatar
Austin Seipp committed
81
82
83
{-
************************************************************************
*                                                                      *
84
\subsection{ Selecting match variables}
Austin Seipp's avatar
Austin Seipp committed
85
86
*                                                                      *
************************************************************************
sof's avatar
sof committed
87
88
89
90
91

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
92
-}
sof's avatar
sof committed
93

94
selectSimpleMatchVarL :: LPat Id -> DsM Id
95
selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
96
97
98
99

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

116
selectMatchVar :: Pat Id -> DsM Id
117
118
119
selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
120
121
selectMatchVar (VarPat var)  = return (localiseId (unLoc var))
                                  -- Note [Localise pattern binders]
122
selectMatchVar (AsPat var _) = return (unLoc var)
123
selectMatchVar other_pat     = newSysLocalDs (hsPatType other_pat)
124
                                  -- OK, better make up one...
sof's avatar
sof committed
125

Austin Seipp's avatar
Austin Seipp committed
126
{-
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
Note [Localise pattern binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
146
of is tc003 compiled with the 'hpc' way -- but that only makes it
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
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.

sof's avatar
sof committed
164

Austin Seipp's avatar
Austin Seipp committed
165
166
167
168
169
************************************************************************
*                                                                      *
* type synonym EquationInfo and access functions for its pieces        *
*                                                                      *
************************************************************************
170
171
172
173
\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
174
-}
175

176
firstPat :: EquationInfo -> Pat Id
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
177
firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
178

179
shiftEqns :: [EquationInfo] -> [EquationInfo]
180
181
-- Drop the first pattern in each equation
shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
182

Austin Seipp's avatar
Austin Seipp committed
183
-- Functions on MatchResults
184

185
186
187
188
matchCanFail :: MatchResult -> Bool
matchCanFail (MatchResult CanFail _)  = True
matchCanFail (MatchResult CantFail _) = False

189
alwaysFailMatchResult :: MatchResult
190
alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
191

192
cantFailMatchResult :: CoreExpr -> MatchResult
193
cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
194

195
extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
196
extractMatchResult (MatchResult CantFail match_fn) _
197
  = match_fn (error "It can't fail!")
198

199
200
201
extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
    (fail_bind, if_it_fails) <- mkFailurePair fail_expr
    body <- match_fn if_it_fails
202
    return (mkCoreLet fail_bind body)
203

204
205
206

combineMatchResults :: MatchResult -> MatchResult -> MatchResult
combineMatchResults (MatchResult CanFail      body_fn1)
207
                    (MatchResult can_it_fail2 body_fn2)
208
209
  = MatchResult can_it_fail2 body_fn
  where
210
211
212
213
    body_fn fail = do body2 <- body_fn2 fail
                      (fail_bind, duplicatable_expr) <- mkFailurePair body2
                      body1 <- body_fn1 duplicatable_expr
                      return (Let fail_bind body1)
214

215
combineMatchResults match_result1@(MatchResult CantFail _) _
216
217
  = match_result1

218
adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
219
adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
220
  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
221
222
223

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

226
227
228
wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
wrapBinds [] e = e
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
229

230
wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
231
232
wrapBind new old body   -- NB: this function must deal with term
  | new==old    = body  -- variables, type variables or coercion variables
233
  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
234

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
235
236
seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = Case (Var var) var (exprType body)
237
                        [(DEFAULT, [], body)]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
238

239
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
240
mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
241

242
243
244
245
246
-- (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))
247

248
249
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
250
  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
251
252

mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
253
mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
254
255
  = MatchResult CanFail (\fail -> do body <- body_fn fail
                                     return (mkIfThenElse pred_expr body fail))
256

257
258
259
260
mkCoPrimCaseMatchResult :: Id                        -- Scrutinee
                        -> Type                      -- Type of the case
                        -> [(Literal, MatchResult)]  -- Alternatives
                        -> MatchResult               -- Literals are all unlifted
261
mkCoPrimCaseMatchResult var ty match_alts
262
  = MatchResult CanFail mk_case
263
  where
264
265
266
    mk_case fail = do
        alts <- mapM (mk_alt fail) sorted_alts
        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
267

268
    sorted_alts = sortWith fst match_alts       -- Right order for a Case
269
270
271
272
    mk_alt fail (lit, MatchResult _ body_fn)
       = ASSERT( not (litIsLifted lit) )
         do body <- body_fn fail
            return (LitAlt lit, [], body)
273

Gergő Érdi's avatar
Gergő Érdi committed
274
data CaseAlt a = MkCaseAlt{ alt_pat :: a,
275
                            alt_bndrs :: [Var],
Gergő Érdi's avatar
Gergő Érdi committed
276
277
                            alt_wrapper :: HsWrapper,
                            alt_result :: MatchResult }
278

279
mkCoAlgCaseMatchResult
280
  :: DynFlags
Gergő Érdi's avatar
Gergő Érdi committed
281
282
283
  -> Id                 -- Scrutinee
  -> Type               -- Type of exp
  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
284
  -> MatchResult
285
mkCoAlgCaseMatchResult dflags var ty match_alts
Gergő Érdi's avatar
Gergő Érdi committed
286
  | isNewtype  -- Newtype case; use a let
287
  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
288
    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
289

Gergő Érdi's avatar
Gergő Érdi committed
290
291
292
293
  | isPArrFakeAlts match_alts
  = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts)
  | otherwise
  = mkDataConCase var ty match_alts
294
  where
Gergő Érdi's avatar
Gergő Érdi committed
295
296
    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))

297
298
        -- [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]
299

Gergő Érdi's avatar
Gergő Érdi committed
300
301
302
303
304
    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
305
306
    (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
307
    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
chak's avatar
chak committed
308

Gergő Érdi's avatar
Gergő Érdi committed
309
310
        --- Stuff for parallel arrays
        --
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
        -- Concerning `isPArrFakeAlts':
        --
        --  * it is *not* sufficient to just check the type of the type
        --   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.
        --
Gergő Érdi's avatar
Gergő Érdi committed
327
328
329
330
331

    isPArrFakeAlts :: [CaseAlt DataCon] -> Bool
    isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)
    isPArrFakeAlts (alt:alts) =
      case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of
chak's avatar
chak committed
332
333
        (True , True ) -> True
        (False, False) -> False
334
335
        _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
    isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
Gergő Érdi's avatar
Gergő Érdi committed
336
337
338
339
340
341
342
343
344

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
345
346
    matcher <- dsLExpr $ mkLHsWrap wrapper $
                         nlHsTyApp matcher [getLevity "mkPatSynCase" ty, ty]
Gergő Érdi's avatar
Gergő Érdi committed
347
348
    let MatchResult _ mkCont = match_result
    cont <- mkCoreLams bndrs <$> mkCont fail
349
    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
Gergő Érdi's avatar
Gergő Érdi committed
350
351
352
353
354
  where
    MkCaseAlt{ alt_pat = psyn,
               alt_bndrs = bndrs,
               alt_wrapper = wrapper,
               alt_result = match_result} = alt
355
    (matcher, needs_void_lam) = patSynMatcher psyn
Gergő Érdi's avatar
Gergő Érdi committed
356

357
    -- See Note [Matchers and builders for pattern synonyms] in PatSyns
358
    -- on these extra Void# arguments
359
360
    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
                         | otherwise      = cont
361

Gergő Érdi's avatar
Gergő Érdi committed
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
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
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

--- Stuff for parallel arrays
--
--  * the following is to desugar cases over fake constructors for
--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
--   case
--
mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr
mkPArrCase dflags var ty sorted_alts fail = do
    lengthP <- dsDPHBuiltin lengthPVar
    alt <- unboxAlt
    return (mkWildCase (len lengthP) intTy ty [alt])
  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]
chak's avatar
chak committed
427
    --
Gergő Érdi's avatar
Gergő Érdi committed
428
429
430
431
432
    unboxAlt = do
        l      <- newSysLocalDs intPrimTy
        indexP <- dsDPHBuiltin indexPVar
        alts   <- mapM (mkAlt indexP) sorted_alts
        return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
chak's avatar
chak committed
433
      where
Gergő Érdi's avatar
Gergő Érdi committed
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
        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
    --
    mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do
        body <- bodyFun fail
        return (LitAlt lit, [], mkCoreLets binds body)
      where
        lit   = MachInt $ toInteger (dataConSourceArity (alt_pat alt))
        binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]
        --
        indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]
451

Austin Seipp's avatar
Austin Seipp committed
452
453
454
{-
************************************************************************
*                                                                      *
455
\subsection{Desugarer's versions of some Core functions}
Austin Seipp's avatar
Austin Seipp committed
456
457
458
*                                                                      *
************************************************************************
-}
459

460
461
462
463
mkErrorAppDs :: Id              -- The error function
             -> Type            -- Type to which it should be applied
             -> SDoc            -- The error message string to pass
             -> DsM CoreExpr
464

465
466
mkErrorAppDs err_id ty msg = do
    src_loc <- getSrcSpanDs
Ian Lynagh's avatar
Ian Lynagh committed
467
    dflags <- getDynFlags
468
    let
469
        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
470
471
        core_msg = Lit (mkMachString full_msg)
        -- mkMachString returns a result of type String#
472
    return (mkApps (Var err_id) [Type (getLevity "mkErrorAppDs" ty), Type ty, core_msg])
473

Austin Seipp's avatar
Austin Seipp committed
474
{-
475
476
477
478
479
480
'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 #))

481
The [CoreSyn let/app invariant] means that, other things being equal, because
482
483
484
485
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

486
487
But that is bad for two reasons:
  (a) we now evaluate y before x, and
488
489
490
491
492
  (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
493
Note [Desugaring seq (2)]  cf Trac #2273
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
~~~~~~~~~~~~~~~~~~~~~~~~~
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
521
522
523
524
525
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:
526
527
   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
528
And now all is well.
529
530

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

Note [Desugaring seq (3)] cf Trac #2409
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
535
The isLocalId ensures that we don't turn
536
537
538
        True `seq` e
into
        case True of True { ... }
539
which stupidly tries to bind the datacon 'True'.
Austin Seipp's avatar
Austin Seipp committed
540
-}
541

542
543
mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
544
545
546
547
548
  | 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)]
549
                   _                     -> mkWildValBinder ty1
550

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

553
554
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
555

556
mkCastDs :: CoreExpr -> Coercion -> CoreExpr
557
-- We define a desugarer-specific version of CoreUtils.mkCast,
558
559
560
561
562
563
564
565
566
567
-- 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
568
569
570
{-
************************************************************************
*                                                                      *
571
               Tuples and selector bindings
Austin Seipp's avatar
Austin Seipp committed
572
573
*                                                                      *
************************************************************************
574
575
576

This is used in various places to do with lazy patterns.
For each binder $b$ in the pattern, we create a binding:
577
\begin{verbatim}
578
    b = case v of pat' -> b'
579
580
\end{verbatim}
where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
581
582
583
584
585
586
587
588
589
590

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.

591
592
593
594
595
596
597
Note [mkSelectorBinds]
~~~~~~~~~~~~~~~~~~~~~~
Given   p = e, where p binds x,y
we are going to make EITHER

EITHER (A)   v = e   (where v is fresh)
             x = case v of p -> x
Ian Lynagh's avatar
Ian Lynagh committed
598
             y = case v of p -> y
599
600
601
602
603

OR (B)       t = case e of p -> (x,y)
             x = case t of (x,_) -> x
             y = case t of (_,y) -> y

604
605
606
607
608
609
610
We do (A) when (test: isSingleton binders)
 * The pattern binds only one variable (so we'll only match once)

OR when (test: is_simple_lpat)
 * Matching the pattern is cheap so we don't mind doing it twice.
 * AND the pattern can't fail (else we tiresomely get one
   inexhaustive pattern warning message for each binder
611
612
613
614
615

Otherwise we do (B).  Really (A) is just an optimisation for very common
cases like
     Just x = e
     (p,q) = e
Austin Seipp's avatar
Austin Seipp committed
616
-}
617

618
619
620
621
622
623
624
625
626
mkSelectorBinds :: Bool           -- ^ is strict
                -> [[Tickish Id]] -- ^ ticks to add, possibly
                -> LPat Id        -- ^ The pattern
                -> CoreExpr       -- ^ Expression to which the pattern is bound
                -> DsM (Maybe Id,[(Id,CoreExpr)])
                -- ^ Id the rhs is bound to, for desugaring strict
                -- binds (see Note [Desugar Strict binds] in DsBinds)
                -- and all the desugared binds

627
mkSelectorBinds _ ticks (L _ (VarPat (L _ v))) val_expr
628
629
630
631
632
633
634
635
  = return (Just v
           ,[(v, case ticks of
                    [t] -> mkOptTickBox t val_expr
                    _   -> val_expr)])

mkSelectorBinds is_strict ticks pat val_expr
  | null binders, not is_strict
  = return (Nothing, [])
636
637

  | isSingleton binders || is_simple_lpat pat  -- Case (A)
638
    -- See Note [mkSelectorBinds]
639
640
  = do { let pat_ty = hsLPatType pat
       ; val_var <- newSysLocalDs pat_ty
641
        -- Make up 'v' in Note [mkSelectorBinds]
642
        -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
643
        -- This does not matter after desugaring, but there's a subtle
644
645
646
647
648
649
650
651
652
653
654
        -- 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.

        -- For the error message we make one error-app, to avoid duplication.
655
656
657
        -- But we need it at different types, so we make it polymorphic:
        --     err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah"
       ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat)
658
       ; err_var <- newSysLocalDs (mkInvForAllTys [alphaTyVar] alphaTy)
659
       ; binds   <- zipWithM (mk_bind val_var err_var) ticks' binders
660
661
662
663
       ; return (Just val_var
                ,(val_var, val_expr) :
                 (err_var, Lam alphaTyVar err_app) :
                 binds) }
664

665
666
667
  | otherwise  -- Case (B)
  = do { val_var    <- newSysLocalDs (hsLPatType pat)
       ; tuple_var  <- newSysLocalDs tuple_ty
668
       ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
669
670
       ; tuple_expr <- matchSimply (Var val_var) PatBindRhs pat
                                   local_tuple error_expr
671
       ; let mk_tup_bind tick binder
672
673
674
675
676
677
678
679
680
               = (binder, mkOptTickBox tick $
                          mkTupleSelector local_binders binder
                                          tuple_var (Var tuple_var))
             tup_binds
               | null binders = []
               | otherwise    = (tuple_var, tuple_expr)
                                : zipWith mk_tup_bind ticks' binders
       ; return ( Just val_var
                , (val_var,val_expr) : tup_binds ) }
681
  where
682
    binders       = collectPatBinders pat
683
    ticks'        = ticks ++ repeat []
684
685

    local_binders = map localiseId binders      -- See Note [Localise pattern binders]
686
687
    local_tuple   = mkBigCoreVarTup binders
    tuple_ty      = exprType local_tuple
688

689
    mk_bind scrut_var err_var tick bndr_var = do
690
    -- (mk_bind sv err_var) generates
691
    --          bv = case sv of { pat -> bv; other -> err_var @ type-of-bv }
692
    -- Remember, pat binds bv
693
694
        rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
                                (Var bndr_var) error_expr
695
        return (bndr_var, mkOptTickBox tick rhs_expr)
696
      where
697
        error_expr = Var err_var `App` Type (idType bndr_var)
698

699
700
    is_simple_lpat p = is_simple_pat (unLoc p)

701
    is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
Gergő Érdi's avatar
Gergő Érdi committed
702
703
704
705
    is_simple_pat pat@(ConPatOut{})     = case unLoc (pat_con pat) of
        RealDataCon con -> isProductTyCon (dataConTyCon con)
                           && all is_triv_lpat (hsConPatArgs (pat_args pat))
        PatSynCon _     -> False
706
707
708
    is_simple_pat (VarPat _)                   = True
    is_simple_pat (ParPat p)                   = is_simple_lpat p
    is_simple_pat _                                    = False
709

710
711
    is_triv_lpat p = is_triv_pat (unLoc p)

712
    is_triv_pat (VarPat _)  = True
713
    is_triv_pat (WildPat _) = True
714
    is_triv_pat (ParPat p)  = is_triv_lpat p
715
716
    is_triv_pat _           = False

Austin Seipp's avatar
Austin Seipp committed
717
{-
718
719
720
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.
Austin Seipp's avatar
Austin Seipp committed
721
-}
722
723

mkLHsPatTup :: [LPat Id] -> LPat Id
724
mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
725
mkLHsPatTup [lpat] = lpat
726
727
mkLHsPatTup lpats  = L (getLoc (head lpats)) $
                     mkVanillaTuplePat lpats Boxed
728

729
730
731
732
733
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
734
mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
735

736
-- The Big equivalents for the source tuple expressions
Simon Marlow's avatar
Simon Marlow committed
737
738
mkBigLHsVarTupId :: [Id] -> LHsExpr Id
mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
739

Simon Marlow's avatar
Simon Marlow committed
740
741
mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id
mkBigLHsTupId = mkChunkified mkLHsTupleExpr
742
743

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

Simon Marlow's avatar
Simon Marlow committed
747
748
mkBigLHsPatTupId :: [LPat Id] -> LPat Id
mkBigLHsPatTupId = mkChunkified mkLHsPatTup
749

Austin Seipp's avatar
Austin Seipp committed
750
751
752
{-
************************************************************************
*                                                                      *
753
        Code for pattern-matching and other failures
Austin Seipp's avatar
Austin Seipp committed
754
755
*                                                                      *
************************************************************************
756
757
758
759

Generally, we handle pattern matching failure like this: let-bind a
fail-variable, and use that variable if the thing fails:
\begin{verbatim}
760
761
762
763
764
765
766
        let fail.33 = error "Help"
        in
        case x of
                p1 -> ...
                p2 -> fail.33
                p3 -> fail.33
                p4 -> ...
767
768
769
770
\end{verbatim}
Then
\begin{itemize}
\item
771
If the case can't fail, then there'll be no mention of @fail.33@, and the
772
773
774
775
776
777
778
779
780
781
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
782
unboxed type.  Then the type of @fail.33@ is unboxed too, and
783
784
there is every chance that someone will change the let into a case:
\begin{verbatim}
785
786
        case error "Help" of
          fail.33 -> case ....
787
788
789
\end{verbatim}

which is of course utterly wrong.  Rather than drop the condition that
790
only boxed types can be let-bound, we just turn the fail into a function
791
792
for the primitive case:
\begin{verbatim}
793
794
795
796
797
798
799
800
        let fail.33 :: Void -> Int#
            fail.33 = \_ -> error "Help"
        in
        case x of
                p1 -> ...
                p2 -> fail.33 void
                p3 -> fail.33 void
                p4 -> ...
801
802
\end{verbatim}

803
Now @fail.33@ is a function, so it can be let-bound.
Austin Seipp's avatar
Austin Seipp committed
804
-}
805

806
807
808
809
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#
810
-- See Note [Failure thunks and CPR]
811
mkFailurePair expr
812
813
814
815
816
  = 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)) }
817
  where
818
    ty = exprType expr
819

Austin Seipp's avatar
Austin Seipp committed
820
{-
821
822
823
824
825
826
Note [Failure thunks and CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we make a failure point we ensure that it
does not look like a thunk. Example:

   let fail = \rw -> error "urk"
827
   in case x of
828
829
        [] -> fail realWorld#
        (y:ys) -> case ys of
830
                    [] -> fail realWorld#
831
832
833
834
835
836
837
                    (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.
838
839
840
841
842
843
844


************************************************************************
*                                                                      *
              Ticks
*                                                                      *
********************************************************************* -}
845

846
847
mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox = flip (foldr Tick)
andy@galois.com's avatar
andy@galois.com committed
848
849
850

mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
851
       uq <- newUnique
852
       this_mod <- getModule
853
854
855
856
857
       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
       let
           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
       --
858
859
860
861
       return $ Case e bndr1 boolTy
                       [ (DataAlt falseDataCon, [], falseBox)
                       , (DataAlt trueDataCon,  [], trueBox)
                       ]
862
863
864
865
866
867
868
869
870
871



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


-- | Remove any bang from a pattern and say if it is a strict bind,
-- also make irrefutable patterns ordinary patterns if -XStrict.
--
-- Example:
Simon Peyton Jones's avatar
Simon Peyton Jones committed
872
873
874
875
876
-- ~pat    => False, pat   -- when -XStrict
-- ~pat    => False, ~pat  -- without -XStrict
-- ~(~pat) => False, ~pat  -- when -XStrict
-- pat     => True,  pat   -- when -XStrict
-- !pat    => True,  pat   -- always
877
878
879
880
881
882
883
884
885
getUnBangedLPat :: DynFlags
                -> LPat id  -- ^ Original pattern
                -> (Bool, LPat id) -- is bind strict?, pattern without bangs
getUnBangedLPat dflags (L l (ParPat p))
  = let (is_strict, p') = getUnBangedLPat dflags p
    in (is_strict, L l (ParPat p'))
getUnBangedLPat _ (L _ (BangPat p))
  = (True,p)
getUnBangedLPat dflags (L _ (LazyPat p))
886
  | xopt LangExt.Strict dflags
887
888
  = (False,p)
getUnBangedLPat dflags p
889
  = (xopt LangExt.Strict dflags,p)