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

Simon Marlow's avatar
Simon Marlow committed
5 6

Desugaring exporessions.
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

Richard Eisenberg's avatar
Richard Eisenberg committed
9
{-# LANGUAGE CPP, MultiWayIf #-}
10

Richard Eisenberg's avatar
Richard Eisenberg committed
11
module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
12
              , dsValBinds, dsLit, dsSyntaxExpr ) where
13

14
#include "HsVersions.h"
mnislaih's avatar
mnislaih committed
15

Simon Marlow's avatar
Simon Marlow committed
16 17 18 19 20 21 22
import Match
import MatchLit
import DsBinds
import DsGRHSs
import DsListComp
import DsUtils
import DsArrows
23
import DsMonad
24
import Name
25
import NameEnv
26
import FamInstEnv( topNormaliseType )
Simon Marlow's avatar
Simon Marlow committed
27
import DsMeta
28
import HsSyn
29 30

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
Simon Marlow's avatar
Simon Marlow committed
31 32
--     needs to see source types
import TcType
33
import TcEvidence
34
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
35
import TcHsSyn
Simon Marlow's avatar
Simon Marlow committed
36
import Type
37
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
38
import CoreUtils
39
import MkCore
Simon Marlow's avatar
Simon Marlow committed
40

41
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
42 43
import CostCentre
import Id
Richard Eisenberg's avatar
Richard Eisenberg committed
44
import MkId
45
import Module
cactus's avatar
cactus committed
46
import ConLike
Simon Marlow's avatar
Simon Marlow committed
47 48
import DataCon
import TysWiredIn
Facundo Domínguez's avatar
Facundo Domínguez committed
49
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
50
import BasicTypes
51
import Maybes
52
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
53 54 55
import SrcLoc
import Util
import Bag
56
import Outputable
Matthew Pickering's avatar
Matthew Pickering committed
57
import PatSyn
58 59

import Control.Monad
60

Austin Seipp's avatar
Austin Seipp committed
61 62 63
{-
************************************************************************
*                                                                      *
64
                dsLocalBinds, dsValBinds
Austin Seipp's avatar
Austin Seipp committed
65 66 67
*                                                                      *
************************************************************************
-}
68

Richard Eisenberg's avatar
Richard Eisenberg committed
69 70 71 72 73
dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
dsLocalBinds (L _   EmptyLocalBinds)    body = return body
dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
                                               dsValBinds binds body
dsLocalBinds (L _ (HsIPBinds binds))    body = dsIPBinds  binds body
74 75

-------------------------
Richard Eisenberg's avatar
Richard Eisenberg committed
76
-- caller sets location
77
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
78
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
Simon Peyton Jones's avatar
Simon Peyton Jones committed
79
dsValBinds (ValBindsIn {})       _    = panic "dsValBinds ValBindsIn"
80 81

-------------------------
82
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
83
dsIPBinds (IPBinds ip_binds ev_binds) body
84 85
  = do  { ds_binds <- dsTcEvBinds ev_binds
        ; let inner = mkCoreLets ds_binds body
Austin Seipp's avatar
Austin Seipp committed
86
                -- The dict bindings may not be in
87 88
                -- dependency order; hence Rec
        ; foldrM ds_ip_bind inner ip_binds }
89
  where
90
    ds_ip_bind (L _ (IPBind ~(Right n) e)) body
91
      = do e' <- dsLExpr e
92
           return (Let (NonRec n e') body)
93

94
-------------------------
Richard Eisenberg's avatar
Richard Eisenberg committed
95
-- caller sets location
96
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
97
-- Special case for bindings which bind unlifted variables
98 99
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
100
-- Silently ignore INLINE and SPECIALISE pragmas...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
101
ds_val_bind (NonRecursive, hsbinds) body
Richard Eisenberg's avatar
Richard Eisenberg committed
102
  | [L loc bind] <- bagToList hsbinds
103 104 105 106
        -- Non-recursive, non-overloaded bindings only come in ones
        -- ToDo: in some bizarre case it's conceivable that there
        --       could be dict binds in the 'binds'.  (See the notes
        --       below.  Then pattern-match would fail.  Urk.)
Richard Eisenberg's avatar
Richard Eisenberg committed
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
  , isUnliftedHsBind bind
  = putSrcSpanDs loc $
     -- see Note [Strict binds checks] in DsBinds
    if is_polymorphic bind
    then errDsCoreExpr (poly_bind_err bind)
            -- data Ptr a = Ptr Addr#
            -- f x = let p@(Ptr y) = ... in ...
            -- Here the binding for 'p' is polymorphic, but does
            -- not mix with an unlifted binding for 'y'.  You should
            -- use a bang pattern.  Trac #6078.

    else do { when (looksLazyPatBind bind) $
              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
        -- Complain about a binding that looks lazy
        --    e.g.    let I# y = x in ...
        -- Remember, in checkStrictBinds we are going to do strict
        -- matching, so (for software engineering reasons) we insist
        -- that the strictness is manifest on each binding
        -- However, lone (unboxed) variables are ok


            ; dsUnliftedBind bind body }
  where
    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
                     = not (null tvs && null evs)
    is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })
                     = not (null tvs && null evs)
    is_polymorphic _ = False

    unlifted_must_be_bang bind
      = hang (text "Pattern bindings containing unlifted types should use" $$
              text "an outermost bang pattern:")
           2 (ppr bind)

    poly_bind_err bind
      = hang (text "You can't mix polymorphic and unlifted bindings:")
           2 (ppr bind) $$
        text "Probable fix: add a type signature"

ds_val_bind (is_rec, binds) _body
  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in DsBinds
  = ASSERT( isRec is_rec )
    errDsCoreExpr $
    hang (text "Recursive bindings for unlifted types aren't allowed:")
       2 (vcat (map ppr (bagToList binds)))
152

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
153
-- Ordinary case for bindings; none should be unlifted
Richard Eisenberg's avatar
Richard Eisenberg committed
154 155 156 157 158
ds_val_bind (is_rec, binds) body
  = do  { MASSERT( isRec is_rec || isSingletonBag binds )
               -- we should never produce a non-recursive list of multiple binds

        ; (force_vars,prs) <- dsLHsBinds binds
159
        ; let body' = foldr seqVar body force_vars
Richard Eisenberg's avatar
Richard Eisenberg committed
160
        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
161
          case prs of
162
            [] -> return body
163
            _  -> return (Let (Rec prs) body') }
Austin Seipp's avatar
Austin Seipp committed
164
        -- Use a Rec regardless of is_rec.
165 166 167 168 169 170 171 172 173
        -- Why? Because it allows the binds to be all
        -- mixed up, which is what happens in one rare case
        -- Namely, for an AbsBind with no tyvars and no dicts,
        --         but which does have dictionary bindings.
        -- See notes with TcSimplify.inferLoop [NO TYVARS]
        -- It turned out that wrapping a Rec here was the easiest solution
        --
        -- NB The previous case dealt with unlifted bindings, so we
        --    only have to deal with lifted ones now; so Rec is ok
174

175
------------------
176 177
dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
178 179
               , abs_exports = exports
               , abs_ev_binds = ev_binds
180
               , abs_binds = lbinds }) body
181
  = do { let body1 = foldr bind_export body exports
182
             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
183
       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
Austin Seipp's avatar
Austin Seipp committed
184
                            body1 lbinds
185
       ; ds_binds <- dsTcEvBinds_s ev_binds
186
       ; return (mkCoreLets ds_binds body2) }
187

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
188 189 190 191 192 193 194 195 196
dsUnliftedBind (AbsBindsSig { abs_tvs         = []
                            , abs_ev_vars     = []
                            , abs_sig_export  = poly
                            , abs_sig_ev_bind = ev_bind
                            , abs_sig_bind    = L _ bind }) body
  = do { ds_binds <- dsTcEvBinds ev_bind
       ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
       ; return (mkCoreLets ds_binds body') }

197
dsUnliftedBind (FunBind { fun_id = L l fun
198 199 200 201 202
                        , fun_matches = matches
                        , fun_co_fn = co_fn
                        , fun_tick = tick }) body
               -- Can't be a bang pattern (that looks like a PatBind)
               -- so must be simply unboxed
203 204
  = do { (args, rhs) <- matchWrapper (FunRhs (L l $ idName fun) Prefix)
                                     Nothing matches
205 206
       ; MASSERT( null args ) -- Functions aren't lifted
       ; MASSERT( isIdHsWrapper co_fn )
207
       ; let rhs' = mkOptTickBox tick rhs
208 209
       ; return (bindNonRec fun rhs' body) }

210
dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
211 212
  =     -- let C x# y# = rhs in body
        -- ==> case rhs of C x# y# -> body
213 214
    do { rhs <- dsGuarded grhss ty
       ; let upat = unLoc pat
Austin Seipp's avatar
Austin Seipp committed
215
             eqn = EqnInfo { eqn_pats = [upat],
216 217 218
                             eqn_rhs = cantFailMatchResult body }
       ; var    <- selectMatchVar upat
       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
219
       ; return (bindNonRec var rhs result) }
220

221
dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
222

Austin Seipp's avatar
Austin Seipp committed
223 224 225
{-
************************************************************************
*                                                                      *
226
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
Austin Seipp's avatar
Austin Seipp committed
227 228 229
*                                                                      *
************************************************************************
-}
230

231
dsLExpr :: LHsExpr Id -> DsM CoreExpr
mnislaih's avatar
mnislaih committed
232

Richard Eisenberg's avatar
Richard Eisenberg committed
233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
dsLExpr (L loc e)
  = putSrcSpanDs loc $
    do { core_expr <- dsExpr e
   -- uncomment this check to test the hsExprType function in TcHsSyn
   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e
   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$
   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
       ; return core_expr }

-- | Variant of 'dsLExpr' that ensures that the result is not levity
-- polymorphic. This should be used when the resulting expression will
-- be an argument to some other function.
-- See Note [Levity polymorphism checking] in DsMonad
-- See Note [Levity polymorphism invariants] in CoreSyn
dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr
dsLExprNoLP (L loc e)
  = putSrcSpanDs loc $
    do { e' <- dsExpr e
       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
       ; return e' }
253 254

dsExpr :: HsExpr Id -> DsM CoreExpr
255
dsExpr (HsPar e)              = dsLExpr e
256
dsExpr (ExprWithTySigOut e _) = dsLExpr e
257 258
dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)
                                -- See Note [Desugaring vars]
259
dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
Richard Eisenberg's avatar
Richard Eisenberg committed
260
dsExpr (HsConLikeOut con)     = return (dsConLike con)
261
dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
262
dsExpr (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
263 264
dsExpr (HsLit lit)            = dsLit lit
dsExpr (HsOverLit lit)        = dsOverLit lit
265 266

dsExpr (HsWrap co_fn e)
267
  = do { e' <- dsExpr e
Simon Peyton Jones's avatar
Simon Peyton Jones committed
268
       ; wrap' <- dsHsWrapper co_fn
269
       ; dflags <- getDynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
270
       ; let wrapped_e = wrap' e'
271
       ; warnAboutIdentities dflags e' (exprType wrapped_e)
272
       ; return wrapped_e }
273

274 275 276 277 278 279 280 281 282
dsExpr (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral src i })))
                neg_expr)
  = do { expr' <- putSrcSpanDs loc $ do
          { dflags <- getDynFlags
          ; warnAboutOverflowedLiterals dflags
                                        (lit { ol_val = HsIntegral src (-i) })
          ; dsOverLit' dflags lit }
       ; dsSyntaxExpr neg_expr [expr'] }

Austin Seipp's avatar
Austin Seipp committed
283
dsExpr (NegApp expr neg_expr)
284 285
  = do { expr' <- dsLExpr expr
       ; dsSyntaxExpr neg_expr [expr'] }
286

287
dsExpr (HsLam a_Match)
288
  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
289

Simon Peyton Jones's avatar
Simon Peyton Jones committed
290 291 292
dsExpr (HsLamCase matches)
  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
       ; return $ Lam discrim_var matching_code }
293

294
dsExpr e@(HsApp fun arg)
Richard Eisenberg's avatar
Richard Eisenberg committed
295
  = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExprNoLP arg
296 297

dsExpr (HsAppTypeOut e _)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
298
    -- ignore type arguments here; they're in the wrappers instead at this point
299
  = dsLExpr e
300

301

Austin Seipp's avatar
Austin Seipp committed
302
{-
Simon Peyton Jones's avatar
Simon Peyton Jones committed
303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
Note [Desugaring vars]
~~~~~~~~~~~~~~~~~~~~~~
In one situation we can get a *coercion* variable in a HsVar, namely
the support method for an equality superclass:
   class (a~b) => C a b where ...
   instance (blah) => C (T a) (T b) where ..
Then we get
   $dfCT :: forall ab. blah => C (T a) (T b)
   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)

   $c$p1C :: forall ab. blah => (T a ~ T b)
   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g

That 'g' in the 'in' part is an evidence variable, and when
converting to core it must become a CO.
Austin Seipp's avatar
Austin Seipp committed
318

319 320
Operator sections.  At first it looks as if we can convert
\begin{verbatim}
321
        (expr op)
322
\end{verbatim}
323
to
324
\begin{verbatim}
325
        \x -> op expr x
326 327 328 329 330
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
331
        map (expr op) xs
332 333 334
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
335
        let y = expr in \x -> op y x
336 337 338
\end{verbatim}
If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.
Austin Seipp's avatar
Austin Seipp committed
339
-}
340

341
dsExpr e@(OpApp e1 op _ e2)
342
  = -- for the type of y, we need the type of op's 2nd argument
Richard Eisenberg's avatar
Richard Eisenberg committed
343
    mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExprNoLP [e1, e2]
Austin Seipp's avatar
Austin Seipp committed
344

345
dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
Richard Eisenberg's avatar
Richard Eisenberg committed
346
  = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExprNoLP expr
347

348
-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
349
dsExpr e@(SectionR op expr) = do
350
    core_op <- dsLExpr op
sof's avatar
sof committed
351
    -- for the type of x, we need the type of op's 2nd argument
352 353 354
    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
        -- See comment with SectionL
    y_core <- dsLExpr expr
Richard Eisenberg's avatar
Richard Eisenberg committed
355 356
    x_id <- newSysLocalDsNoLP x_ty
    y_id <- newSysLocalDsNoLP y_ty
357
    return (bindNonRec y_id y_core $
358
            Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
359

360
dsExpr (ExplicitTuple tup_args boxity)
361
  = do { let go (lam_vars, args) (L _ (Missing ty))
362
                    -- For every missing expression, we need
363
                    -- another lambda in the desugaring.
Richard Eisenberg's avatar
Richard Eisenberg committed
364
               = do { lam_var <- newSysLocalDsNoLP ty
365
                    ; return (lam_var : lam_vars, Var lam_var : args) }
366
             go (lam_vars, args) (L _ (Present expr))
367
                    -- Expressions that are present don't generate
368 369 370 371 372
                    -- lambdas, just arguments.
               = do { core_expr <- dsLExpr expr
                    ; return (lam_vars, core_expr : args) }

       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
373
                -- The reverse is because foldM goes left-to-right
374

375
       ; return $ mkCoreLams lam_vars $
376
                  mkCoreTupBoxity boxity args }
377

378 379 380 381 382 383 384
dsExpr (ExplicitSum alt arity expr types)
  = do { core_expr <- dsLExpr expr
       ; return $ mkCoreConApps (sumDataCon alt arity)
                                (map (Type . getRuntimeRep "dsExpr ExplicitSum") types ++
                                 map Type types ++
                                 [core_expr]) }

Alan Zimmerman's avatar
Alan Zimmerman committed
385 386 387 388 389 390 391
dsExpr (HsSCC _ cc expr@(L loc _)) = do
    dflags <- getDynFlags
    if gopt Opt_SccProfilingOn dflags
      then do
        mod_name <- getModule
        count <- goptM Opt_ProfCountEntries
        uniq <- newUnique
392
        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
Alan Zimmerman's avatar
Alan Zimmerman committed
393 394 395 396
               <$> dsLExpr expr
      else dsLExpr expr

dsExpr (HsCoreAnn _ _ expr)
397
  = dsLExpr expr
398

399
dsExpr (HsCase discrim matches)
400
  = do { core_discrim <- dsLExpr discrim
401
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
402
       ; return (bindNonRec discrim_var core_discrim matching_code) }
403

404 405
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
Richard Eisenberg's avatar
Richard Eisenberg committed
406
dsExpr (HsLet binds body) = do
407
    body' <- dsLExpr body
408
    dsLocalBinds binds body'
409

chak's avatar
chak committed
410 411 412
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
413 414 415 416 417 418
dsExpr (HsDo ListComp     (L _ stmts) res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp     (L _ stmts) _)      = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr       (L _ stmts) _)      = dsDo stmts
dsExpr (HsDo GhciStmtCtxt (L _ stmts) _)      = dsDo stmts
dsExpr (HsDo MDoExpr      (L _ stmts) _)      = dsDo stmts
dsExpr (HsDo MonadComp    (L _ stmts) _)      = dsMonadComp stmts
419

420 421 422 423 424
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
  = do { pred <- dsLExpr guard_expr
       ; b1 <- dsLExpr then_expr
       ; b2 <- dsLExpr else_expr
       ; case mb_fun of
425
           Just fun -> dsSyntaxExpr fun [pred, b1, b2]
426
           Nothing  -> return $ mkIfThenElse pred b1 b2 }
427 428 429 430 431 432 433 434 435 436 437 438

dsExpr (HsMultiIf res_ty alts)
  | null alts
  = mkErrorExpr

  | otherwise
  = do { match_result <- liftM (foldr1 combineMatchResults)
                               (mapM (dsGRHS IfAlt res_ty) alts)
       ; error_expr   <- mkErrorExpr
       ; extractMatchResult match_result error_expr }
  where
    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
439
                               (text "multi-way if")
440

Austin Seipp's avatar
Austin Seipp committed
441
{-
442 443
\noindent
\underline{\bf Various data construction things}
Austin Seipp's avatar
Austin Seipp committed
444 445 446 447
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}

dsExpr (ExplicitList elt_ty wit xs)
448
  = dsExplicitList elt_ty wit xs
449

450 451
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
452
--
453
dsExpr (ExplicitPArr ty []) = do
454
    emptyP <- dsDPHBuiltin emptyPVar
455
    return (Var emptyP `App` Type ty)
456
dsExpr (ExplicitPArr ty xs) = do
457 458
    singletonP <- dsDPHBuiltin singletonPVar
    appP       <- dsDPHBuiltin appPVar
Richard Eisenberg's avatar
Richard Eisenberg committed
459
    xs'        <- mapM dsLExprNoLP xs
460 461 462
    let unary  fn x   = mkApps (Var fn) [Type ty, x]
        binary fn x y = mkApps (Var fn) [Type ty, x, y]

463
    return . foldr1 (binary appP) $ map (unary singletonP) xs'
chak's avatar
chak committed
464

465 466 467
dsExpr (ArithSeq expr witness seq)
  = case witness of
     Nothing -> dsArithSeq expr seq
468 469
     Just fl -> do { newArithSeq <- dsArithSeq expr seq
                   ; dsSyntaxExpr fl [newArithSeq] }
470 471

dsExpr (PArrSeq expr (FromTo from to))
Richard Eisenberg's avatar
Richard Eisenberg committed
472
  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]
473 474

dsExpr (PArrSeq expr (FromThenTo from thn to))
Richard Eisenberg's avatar
Richard Eisenberg committed
475
  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]
chak's avatar
chak committed
476

477
dsExpr (PArrSeq _ _)
chak's avatar
chak committed
478 479 480
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
481

Facundo Domínguez's avatar
Facundo Domínguez committed
482
{-
483 484 485
Static Pointers
~~~~~~~~~~~~~~~

486 487
See Note [Grand plan for static forms] in StaticPtrTable for an overview.

Facundo Domínguez's avatar
Facundo Domínguez committed
488 489
    g = ... static f ...
==>
490
    g = ... makeStatic loc f ...
Facundo Domínguez's avatar
Facundo Domínguez committed
491 492
-}

493
dsExpr (HsStatic _ expr@(L loc _)) = do
Richard Eisenberg's avatar
Richard Eisenberg committed
494
    expr_ds <- dsLExprNoLP expr
Facundo Domínguez's avatar
Facundo Domínguez committed
495
    let ty = exprType expr_ds
496
    makeStaticId <- dsLookupGlobalId makeStaticName
Facundo Domínguez's avatar
Facundo Domínguez committed
497 498 499 500 501 502 503

    dflags <- getDynFlags
    let (line, col) = case loc of
           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
                            , srcLocCol  $ realSrcSpanStart r
                            )
           _             -> (0, 0)
504
        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
Facundo Domínguez's avatar
Facundo Domínguez committed
505 506 507
                     [ Type intTy              , Type intTy
                     , mkIntExprInt dflags line, mkIntExprInt dflags col
                     ]
508

509 510
    putSrcSpanDs loc $ return $
      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
511

Austin Seipp's avatar
Austin Seipp committed
512
{-
513 514
\noindent
\underline{\bf Record construction and update}
Austin Seipp's avatar
Austin Seipp committed
515
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
516
For record construction we do this (assuming T has three arguments)
517
\begin{verbatim}
518
        T { op2 = e }
519
==>
Austin Seipp's avatar
Austin Seipp committed
520
        let err = /\a -> recConErr a
521
        T (recConErr t1 "M.hs/230/op1")
Austin Seipp's avatar
Austin Seipp committed
522
          e
523
          (recConErr t1 "M.hs/230/op3")
524
\end{verbatim}
525
@recConErr@ then converts its argument string into a proper message
526
before printing it as
527
\begin{verbatim}
528
        M.hs, line 230: missing field op1 was evaluated
529
\end{verbatim}
530

531 532
We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
Austin Seipp's avatar
Austin Seipp committed
533
-}
534

535 536 537 538 539 540 541
dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
                  , rcon_con_like = con_like })
  = do { con_expr' <- dsExpr con_expr
       ; let
             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
             -- A newtype in the corner should be opaque;
             -- hence TcType.tcSplitFunTys
542

543 544 545
             mk_arg (arg_ty, fl)
               = case findField (rec_flds rbinds) (flSelector fl) of
                   (rhs:rhss) -> ASSERT( null rhss )
Richard Eisenberg's avatar
Richard Eisenberg committed
546
                                 dsLExprNoLP rhs
547 548
                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
549

550
             labels = conLikeFieldLabels con_like
Austin Seipp's avatar
Austin Seipp committed
551

552 553 554
       ; con_args <- if null labels
                     then mapM unlabelled_bottom arg_tys
                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
Austin Seipp's avatar
Austin Seipp committed
555

556
       ; return (mkCoreApps con_expr' con_args) }
557

Austin Seipp's avatar
Austin Seipp committed
558
{-
559
Record update is a little harder. Suppose we have the decl:
560
\begin{verbatim}
561 562 563
        data T = T1 {op1, op2, op3 :: Int}
               | T2 {op4, op2 :: Int}
               | T3
564
\end{verbatim}
565
Then we translate as follows:
566
\begin{verbatim}
567
        r { op2 = e }
568
===>
569 570 571 572
        let op2 = e in
        case r of
          T1 op1 _ op3 -> T1 op1 op2 op3
          T2 op4 _     -> T2 op4 op2
573
          other        -> recUpdError "M.hs/230"
574 575
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
576
RHSs, and do not generate a Core constructor application directly, because the constructor
577 578 579
might do some argument-evaluation first; and may have to throw away some
dictionaries.

580 581
Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
582
Consider
583
   data T a b where
584
     T1 :: { f1 :: a } -> T a Int
585

Austin Seipp's avatar
Austin Seipp committed
586
Then the wrapper function for T1 has type
587 588 589 590
   $WT1 :: a -> T a Int
But if x::T a b, then
   x { f1 = v } :: T a b   (not T a Int!)
So we need to cast (T a Int) to (T a b).  Sigh.
591

Austin Seipp's avatar
Austin Seipp committed
592
-}
593

594 595 596 597
dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                       , rupd_cons = cons_to_upd
                       , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
                       , rupd_wrap = dict_req_wrap } )
598
  | null fields
599
  = dsLExpr record_expr
600
  | otherwise
601
  = ASSERT2( notNull cons_to_upd, ppr expr )
602

603 604 605 606 607 608 609 610
    do  { record_expr' <- dsLExpr record_expr
        ; field_binds' <- mapM ds_field fields
        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']

        -- It's important to generate the match with matchWrapper,
        -- and the right hand sides with applications of the wrapper Id
        -- so that everything works when we are doing fancy unboxing on the
Gabor Greif's avatar
Gabor Greif committed
611
        -- constructor arguments.
612
        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
613
        ; ([discrim_var], matching_code)
614 615 616 617 618
                <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
                                                   , mg_arg_tys = [in_ty]
                                                   , mg_res_ty = out_ty, mg_origin = FromSource })
                                                   -- FromSource is not strictly right, but we
                                                   -- want incomplete pattern-match warnings
619 620 621

        ; return (add_field_binds field_binds' $
                  bindNonRec discrim_var record_expr' matching_code) }
622
  where
Adam Gundry's avatar
Adam Gundry committed
623
    ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
624
      -- Clone the Id in the HsRecField, because its Name is that
Adam Gundry's avatar
Adam Gundry committed
625
      -- of the record selector, and we must not make that a local binder
626 627
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf Trac #2735
628
    ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
Adam Gundry's avatar
Adam Gundry committed
629
                                  ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
630 631
                                  ; lcl_id <- newSysLocalDs (idType fld_id)
                                  ; return (idName fld_id, lcl_id, rhs) }
632 633

    add_field_binds [] expr = expr
634
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
635

Austin Seipp's avatar
Austin Seipp committed
636
        -- Awkwardly, for families, the match goes
637
        -- from instance type to family type
Matthew Pickering's avatar
Matthew Pickering committed
638 639 640 641 642 643
    (in_ty, out_ty) =
      case (head cons_to_upd) of
        RealDataCon data_con ->
          let tycon = dataConTyCon data_con in
          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
        PatSynCon pat_syn ->
644
          ( patSynInstResTy pat_syn in_inst_tys
Matthew Pickering's avatar
Matthew Pickering committed
645
          , patSynInstResTy pat_syn out_inst_tys)
646
    mk_alt upd_fld_env con
Austin Seipp's avatar
Austin Seipp committed
647
      = do { let (univ_tvs, ex_tvs, eq_spec,
Matthew Pickering's avatar
Matthew Pickering committed
648
                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
649
                 subst = zipTvSubst univ_tvs in_inst_tys
650 651 652

                -- I'm not bothering to clone the ex_tvs
           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
Matthew Pickering's avatar
Matthew Pickering committed
653
           ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
654
           ; arg_ids    <- newSysLocalsDs (substTysUnchecked subst arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
655 656 657
           ; let field_labels = conLikeFieldLabels con
                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                         field_labels arg_ids
Adam Gundry's avatar
Adam Gundry committed
658 659
                 mk_val_arg fl pat_arg_id
                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
Richard Eisenberg's avatar
Richard Eisenberg committed
660 661

                 inst_con = noLoc $ HsWrap wrap (HsConLikeOut con)
662
                        -- Reconstruct with the WrapId so that unpacking happens
Matthew Pickering's avatar
Matthew Pickering committed
663
                 -- The order here is because of the order in `TcPatSyn`.
664 665
                 wrap = mkWpEvVarApps theta_vars                                <.>
                        dict_req_wrap                                           <.>
666 667 668 669
                        mkWpTyApps    (mkTyVarTys ex_tvs)                       <.>
                        mkWpTyApps    [ ty
                                      | (tv, ty) <- univ_tvs `zip` out_inst_tys
                                      , not (tv `elemVarEnv` wrap_subst) ]
670 671 672 673
                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args

                        -- Tediously wrap the application in a cast
                        -- Note [Update for GADTs]
Matthew Pickering's avatar
Matthew Pickering committed
674 675 676 677 678 679 680 681 682 683 684 685 686 687 688
                 wrapped_rhs =
                  case con of
                    RealDataCon data_con ->
                      let
                        wrap_co =
                          mkTcTyConAppCo Nominal
                            (dataConTyCon data_con)
                            [ lookup tv ty
                              | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
                        lookup univ_tv ty =
                          case lookupVarEnv wrap_subst univ_tv of
                            Just co' -> co'
                            Nothing  -> mkTcReflCo Nominal ty
                        in if null eq_spec
                             then rhs
689
                             else mkLHsWrap (mkWpCastN wrap_co) rhs
Matthew Pickering's avatar
Matthew Pickering committed
690 691 692 693 694
                    -- eq_spec is always null for a PatSynCon
                    PatSynCon _ -> rhs

                 wrap_subst =
                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
695 696
                           | (spec, eq_var) <- eq_spec `zip` eqs_vars
                           , let tv = eqSpecTyVar spec ]
Matthew Pickering's avatar
Matthew Pickering committed
697 698

                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
699

Matthew Pickering's avatar
Matthew Pickering committed
700
                 pat = noLoc $ ConPatOut { pat_con = noLoc con
cactus's avatar
cactus committed
701
                                         , pat_tvs = ex_tvs
702 703 704
                                         , pat_dicts = eqs_vars ++ theta_vars
                                         , pat_binds = emptyTcEvBinds
                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
705
                                         , pat_arg_tys = in_inst_tys
Matthew Pickering's avatar
Matthew Pickering committed
706
                                         , pat_wrap = req_wrap }
707
           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
708

Austin Seipp's avatar
Austin Seipp committed
709
-- Here is where we desugar the Template Haskell brackets and escapes
710 711 712

-- Template Haskell stuff

gmainland's avatar
gmainland committed
713
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
714
dsExpr (HsTcBracketOut x ps) = dsBracket x ps
715
dsExpr (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)
716

717
-- Arrow notation extension
718
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
719

Austin Seipp's avatar
Austin Seipp committed
720
-- Hpc Support
andy@galois.com's avatar
andy@galois.com committed
721

722
dsExpr (HsTick tickish e) = do
andy@galois.com's avatar
andy@galois.com committed
723
  e' <- dsLExpr e
724
  return (Tick tickish e')
andy@galois.com's avatar
andy@galois.com committed
725 726 727 728 729 730 731 732 733 734

-- There is a problem here. The then and else branches
-- have no free variables, so they are open to lifting.
-- We need someway of stopping this.
-- This will make no difference to binary coverage
-- (did you go here: YES or NO), but will effect accurate
-- tick counting.

dsExpr (HsBinTick ixT ixF e) = do
  e2 <- dsLExpr e
735
  do { ASSERT(exprType e2 `eqType` boolTy)
andy@galois.com's avatar
andy@galois.com committed
736 737
       mkBinaryTickBox ixT ixF e2
     }
738

739
dsExpr (HsTickPragma _ _ _ expr) = do
Alan Zimmerman's avatar
Alan Zimmerman committed
740 741 742 743 744
  dflags <- getDynFlags
  if gopt Opt_Hpc dflags
    then panic "dsExpr:HsTickPragma"
    else dsLExpr expr

745
-- HsSyn constructs that just shouldn't be here:
746 747 748 749 750 751 752 753
dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"
dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"
dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"
dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"
dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
754
dsExpr (HsAppType     {})  = panic "dsExpr:HsAppType" -- removed by typechecker
755
dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
756
dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
757

758 759 760 761 762 763
------------------------------
dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
                         , syn_arg_wraps = arg_wraps
                         , syn_res_wrap  = res_wrap })
             arg_exprs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
764 765 766 767
  = do { fun            <- dsExpr expr
       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
       ; core_res_wrap  <- dsHsWrapper res_wrap
       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
Richard Eisenberg's avatar
Richard Eisenberg committed
768
       ; zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
769
       ; return (core_res_wrap (mkApps fun wrapped_args)) }
Richard Eisenberg's avatar
Richard Eisenberg committed
770 771
  where
    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
772

773
findField :: [LHsRecField Id arg] -> Name -> [arg]
Adam Gundry's avatar
Adam Gundry committed
774 775 776
findField rbinds sel
  = [hsRecFieldArg fld | L _ fld <- rbinds
                       , sel == idName (unLoc $ hsRecFieldId fld) ]
777

Austin Seipp's avatar
Austin Seipp committed
778
{-
sof's avatar
sof committed
779
%--------------------------------------------------------------------
780

781 782 783 784
Note [Desugaring explicit lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Explicit lists are desugared in a cleverer way to prevent some
fruitless allocations.  Essentially, whenever we see a list literal
785 786
[x_1, ..., x_n] we generate the corresponding expression in terms of
build:
787

788 789
Explicit lists (literals) are desugared to allow build/foldr fusion when
beneficial. This is a bit of a trade-off,
790

791 792
 * build/foldr fusion can generate far larger code than the corresponding
   cons-chain (e.g. see #11707)
Austin Seipp's avatar
Austin Seipp committed
793

794 795 796
 * even when it doesn't produce more code, build can still fail to fuse,
   requiring that the simplifier do more work to bring the expression
   back into cons-chain form; this costs compile time
Austin Seipp's avatar
Austin Seipp committed
797

798 799
 * when it works, fusion can be a significant win. Allocations are reduced
   by up to 25% in some nofib programs. Specifically,
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
800 801 802 803 804

        Program           Size    Allocs   Runtime  CompTime
        rewrite          +0.0%    -26.3%      0.02     -1.8%
           ansi          -0.3%    -13.8%      0.00     +0.0%
           lift          +0.0%     -8.7%      0.00     -2.3%
805

806 807 808 809 810 811 812 813 814 815 816
At the moment we use a simple heuristic to determine whether build will be
fruitful: for small lists we assume the benefits of fusion will be worthwhile;
for long lists we assume that the benefits will be outweighted by the cost of
code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
won't work at all if rewrite rules are disabled, so we don't use the build-based
desugaring in this case.

We used to have a more complex heuristic which would try to break the list into
"static" and "dynamic" parts and only build-desugar the dynamic part.
Unfortunately, determining "static-ness" reliably is a bit tricky and the
heuristic at times produced surprising behavior (see #11710) so it was dropped.
Austin Seipp's avatar
Austin Seipp committed
817
-}
818

819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837
{- | The longest list length which we will desugar using @build@.

This is essentially a magic number and its setting is unfortunate rather
arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
is to avoid deforesting large static data into large(r) code. Ideally we'd
want a smaller threshold with larger consumers and vice-versa, but we have no
way of knowing what will be consuming our list in the desugaring impossible to
set generally correctly.

The effect of reducing this number will be that 'build' fusion is applied
less often. From a runtime performance perspective, applying 'build' more
liberally on "moderately" sized lists should rarely hurt and will often it can
only expose further optimization opportunities; if no fusion is possible it will
eventually get rule-rewritten back to a list). We do, however, pay in compile
time.
-}
maxBuildLength :: Int
maxBuildLength = 32

838
dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
839
               -> DsM CoreExpr
840
-- See Note [Desugaring explicit lists]
841
dsExplicitList elt_ty Nothing xs
842
  = do { dflags <- getDynFlags
Richard Eisenberg's avatar
Richard Eisenberg committed
843
       ; xs' <- mapM dsLExprNoLP xs
844
       ; if length xs' > maxBuildLength
845
                -- Don't generate builds if the list is very long.
846 847
         || length xs' == 0
                -- Don't generate builds when the [] constructor will do
ian@well-typed.com's avatar
ian@well-typed.com committed
848
         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
849 850
                -- Don't generate a build if there are no rules to eliminate it!
                -- See Note [Desugaring RULE left hand sides] in Desugar