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
cactus's avatar
cactus 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

cactus's avatar
cactus 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

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

288
mkCoAlgCaseMatchResult
289
  :: Id                 -- Scrutinee
cactus's avatar
cactus committed
290 291
  -> Type               -- Type of exp
  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
292
  -> MatchResult
293
mkCoAlgCaseMatchResult var ty match_alts
cactus's avatar
cactus 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

cactus's avatar
cactus committed
298 299
  | otherwise
  = mkDataConCase var ty match_alts
300
  where
cactus's avatar
cactus 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

cactus's avatar
cactus 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

cactus's avatar
cactus 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]
cactus's avatar
cactus 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]
cactus's avatar
cactus 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
cactus's avatar
cactus 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

cactus's avatar
cactus 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])
406 407
        core_msg = Lit (mkMachString full_msg)
        -- mkMachString 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 493
mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
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
664
                -> CoreExpr       -- ^ Expression to which the pattern is bound
665
                -> DsM (Id,[(Id,CoreExpr)])
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)
                       ]
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