DsExpr.hs 37.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

9 10
{-# LANGUAGE CPP #-}

11
module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
12

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

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

#ifdef GHCI
28
        -- Template Haskell stuff iff bootstrapped
Simon Marlow's avatar
Simon Marlow committed
29
import DsMeta
30 31
#endif

32
import HsSyn
33

Facundo Domínguez's avatar
Facundo Domínguez committed
34
import Platform
35
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
Simon Marlow's avatar
Simon Marlow committed
36 37
--     needs to see source types
import TcType
Joachim Breitner's avatar
Joachim Breitner committed
38
import Coercion ( Role(..) )
39
import TcEvidence
40
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
41
import Type
42
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
43
import CoreUtils
44
import CoreFVs
45
import MkCore
Simon Marlow's avatar
Simon Marlow committed
46

47
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
48 49
import CostCentre
import Id
50
import Module
51
import VarSet
52
import VarEnv
Gergő Érdi's avatar
Gergő Érdi committed
53
import ConLike
Simon Marlow's avatar
Simon Marlow committed
54 55
import DataCon
import TysWiredIn
Facundo Domínguez's avatar
Facundo Domínguez committed
56
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
57
import BasicTypes
58
import Maybes
Simon Marlow's avatar
Simon Marlow committed
59 60 61
import SrcLoc
import Util
import Bag
62
import Outputable
63
import FastString
64

Facundo Domínguez's avatar
Facundo Domínguez committed
65 66 67
import IdInfo
import Data.IORef       ( atomicModifyIORef, modifyIORef )

68
import Control.Monad
Facundo Domínguez's avatar
Facundo Domínguez committed
69
import GHC.Fingerprint
70

Austin Seipp's avatar
Austin Seipp committed
71 72 73
{-
************************************************************************
*                                                                      *
74
                dsLocalBinds, dsValBinds
Austin Seipp's avatar
Austin Seipp committed
75 76 77
*                                                                      *
************************************************************************
-}
78

79
dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
80
dsLocalBinds EmptyLocalBinds    body = return body
81 82 83 84 85
dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body

-------------------------
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
86
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
87
dsValBinds (ValBindsIn  _     _) _    = panic "dsValBinds ValBindsIn"
88 89

-------------------------
90
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
91
dsIPBinds (IPBinds ip_binds ev_binds) body
92 93
  = do  { ds_binds <- dsTcEvBinds ev_binds
        ; let inner = mkCoreLets ds_binds body
Austin Seipp's avatar
Austin Seipp committed
94
                -- The dict bindings may not be in
95 96
                -- dependency order; hence Rec
        ; foldrM ds_ip_bind inner ip_binds }
97
  where
98
    ds_ip_bind (L _ (IPBind ~(Right n) e)) body
99
      = do e' <- dsLExpr e
100
           return (Let (NonRec n e') body)
101

102 103
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
104
-- Special case for bindings which bind unlifted variables
105 106
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
107
-- Silently ignore INLINE and SPECIALISE pragmas...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
108
ds_val_bind (NonRecursive, hsbinds) body
109
  | [L loc bind] <- bagToList hsbinds,
110 111 112 113
        -- 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.)
114 115
    strictMatchOnly bind
  = putSrcSpanDs loc (dsStrictBind bind body)
116

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
117
-- Ordinary case for bindings; none should be unlifted
118
ds_val_bind (_is_rec, binds) body
119 120 121
  = do  { prs <- dsLHsBinds binds
        ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
          case prs of
122 123
            [] -> return body
            _  -> return (Let (Rec prs) body) }
Austin Seipp's avatar
Austin Seipp committed
124
        -- Use a Rec regardless of is_rec.
125 126 127 128 129 130 131 132 133
        -- 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
134

135 136 137 138 139
------------------
dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
               , abs_exports = exports
               , abs_ev_binds = ev_binds
140
               , abs_binds = lbinds }) body
141
  = do { let body1 = foldr bind_export body exports
142
             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
143
       ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
Austin Seipp's avatar
Austin Seipp committed
144
                            body1 lbinds
145
       ; ds_binds <- dsTcEvBinds_s ev_binds
146
       ; return (mkCoreLets ds_binds body2) }
147

Austin Seipp's avatar
Austin Seipp committed
148
dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
149 150 151
                      , fun_tick = tick, fun_infix = inf }) body
                -- Can't be a bang pattern (that looks like a PatBind)
                -- so must be simply unboxed
152 153 154
  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
       ; MASSERT( null args ) -- Functions aren't lifted
       ; MASSERT( isIdHsWrapper co_fn )
155
       ; let rhs' = mkOptTickBox tick rhs
156 157 158
       ; return (bindNonRec fun rhs' body) }

dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
159 160
  =     -- let C x# y# = rhs in body
        -- ==> case rhs of C x# y# -> body
161 162
    do { rhs <- dsGuarded grhss ty
       ; let upat = unLoc pat
Austin Seipp's avatar
Austin Seipp committed
163
             eqn = EqnInfo { eqn_pats = [upat],
164 165 166
                             eqn_rhs = cantFailMatchResult body }
       ; var    <- selectMatchVar upat
       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
167
       ; return (bindNonRec var rhs result) }
168 169 170 171 172

dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)

----------------------
strictMatchOnly :: HsBind Id -> Bool
173 174
strictMatchOnly (AbsBinds { abs_binds = lbinds })
  = anyBag (strictMatchOnly . unLoc) lbinds
175 176 177
strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
  =  isUnLiftedType rhs_ty
  || isStrictLPat lpat
178 179 180 181
  || any (isUnLiftedType . idType) (collectPatBinders lpat)
strictMatchOnly (FunBind { fun_id = L _ id })
  = isUnLiftedType (idType id)
strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
182

Austin Seipp's avatar
Austin Seipp committed
183 184 185
{-
************************************************************************
*                                                                      *
186
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
Austin Seipp's avatar
Austin Seipp committed
187 188 189
*                                                                      *
************************************************************************
-}
190

191
dsLExpr :: LHsExpr Id -> DsM CoreExpr
mnislaih's avatar
mnislaih committed
192

193 194 195
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e

dsExpr :: HsExpr Id -> DsM CoreExpr
196
dsExpr (HsPar e)              = dsLExpr e
197
dsExpr (ExprWithTySigOut e _) = dsLExpr e
198
dsExpr (HsVar var)            = return (varToCoreExpr var)   -- See Note [Desugaring vars]
199
dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
200 201
dsExpr (HsLit lit)            = dsLit lit
dsExpr (HsOverLit lit)        = dsOverLit lit
202 203

dsExpr (HsWrap co_fn e)
204
  = do { e' <- dsExpr e
205
       ; wrapped_e <- dsHsWrapper co_fn e'
206 207
       ; dflags <- getDynFlags
       ; warnAboutIdentities dflags e' (exprType wrapped_e)
208
       ; return wrapped_e }
209

Austin Seipp's avatar
Austin Seipp committed
210
dsExpr (NegApp expr neg_expr)
211
  = App <$> dsExpr neg_expr <*> dsLExpr expr
212

213
dsExpr (HsLam a_Match)
214
  = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
215

216
dsExpr (HsLamCase arg matches)
217 218 219 220
  = do { arg_var <- newSysLocalDs arg
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
       ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }

221
dsExpr (HsApp fun arg)
222
  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
223

224
dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
225

Austin Seipp's avatar
Austin Seipp committed
226
{-
Simon Peyton Jones's avatar
Simon Peyton Jones committed
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
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
242

243 244
Operator sections.  At first it looks as if we can convert
\begin{verbatim}
245
        (expr op)
246
\end{verbatim}
247
to
248
\begin{verbatim}
249
        \x -> op expr x
250 251 252 253 254
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
255
        map (expr op) xs
256 257 258
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
259
        let y = expr in \x -> op y x
260 261 262
\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
263
-}
264

sof's avatar
sof committed
265
dsExpr (OpApp e1 op _ e2)
266
  = -- for the type of y, we need the type of op's 2nd argument
267
    mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
Austin Seipp's avatar
Austin Seipp committed
268

269
dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
270
  = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
271

272
-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
273 274
dsExpr (SectionR op expr) = do
    core_op <- dsLExpr op
sof's avatar
sof committed
275
    -- for the type of x, we need the type of op's 2nd argument
276 277 278 279 280 281
    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
        -- See comment with SectionL
    y_core <- dsLExpr expr
    x_id <- newSysLocalDs x_ty
    y_id <- newSysLocalDs y_ty
    return (bindNonRec y_id y_core $
282
            Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
283

284
dsExpr (ExplicitTuple tup_args boxity)
285
  = do { let go (lam_vars, args) (L _ (Missing ty))
286
                    -- For every missing expression, we need
287
                    -- another lambda in the desugaring.
288 289
               = do { lam_var <- newSysLocalDs ty
                    ; return (lam_var : lam_vars, Var lam_var : args) }
290
             go (lam_vars, args) (L _ (Present expr))
291
                    -- Expressions that are present don't generate
292 293 294 295 296
                    -- lambdas, just arguments.
               = do { core_expr <- dsLExpr expr
                    ; return (lam_vars, core_expr : args) }

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

299 300 301
       ; return $ mkCoreLams lam_vars $
                  mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args))
                                (map (Type . exprType) args ++ args) }
302

Alan Zimmerman's avatar
Alan Zimmerman committed
303 304 305 306 307 308 309 310 311 312 313 314
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
        Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True)
               <$> dsLExpr expr
      else dsLExpr expr

dsExpr (HsCoreAnn _ _ expr)
315
  = dsLExpr expr
316

317
dsExpr (HsCase discrim matches)
318 319
  = do { core_discrim <- dsLExpr discrim
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
320
       ; return (bindNonRec discrim_var core_discrim matching_code) }
321

322 323
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
324 325
dsExpr (HsLet binds body) = do
    body' <- dsLExpr body
326
    dsLocalBinds binds body'
327

chak's avatar
chak committed
328 329 330
-- 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.
--
331 332
dsExpr (HsDo ListComp     stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp     stmts _)      = dsPArrComp (map unLoc stmts)
Austin Seipp's avatar
Austin Seipp committed
333 334 335
dsExpr (HsDo DoExpr       stmts _)      = dsDo stmts
dsExpr (HsDo GhciStmtCtxt stmts _)      = dsDo stmts
dsExpr (HsDo MDoExpr      stmts _)      = dsDo stmts
336
dsExpr (HsDo MonadComp    stmts _)      = dsMonadComp stmts
337

338 339 340 341 342 343 344 345
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
           Just fun -> do { core_fun <- dsExpr fun
                          ; return (mkCoreApps core_fun [pred,b1,b2]) }
           Nothing  -> return $ mkIfThenElse pred b1 b2 }
346 347 348 349 350 351 352 353 354 355 356 357 358

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
                               (ptext (sLit "multi-way if"))
359

Austin Seipp's avatar
Austin Seipp committed
360
{-
361 362
\noindent
\underline{\bf Various data construction things}
Austin Seipp's avatar
Austin Seipp committed
363 364 365 366
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}

dsExpr (ExplicitList elt_ty wit xs)
367
  = dsExplicitList elt_ty wit xs
368

369 370
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
371
--
372
dsExpr (ExplicitPArr ty []) = do
373
    emptyP <- dsDPHBuiltin emptyPVar
374
    return (Var emptyP `App` Type ty)
375
dsExpr (ExplicitPArr ty xs) = do
376 377
    singletonP <- dsDPHBuiltin singletonPVar
    appP       <- dsDPHBuiltin appPVar
378 379 380 381 382
    xs'        <- mapM dsLExpr xs
    return . foldr1 (binary appP) $ map (unary singletonP) xs'
  where
    unary  fn x   = mkApps (Var fn) [Type ty, x]
    binary fn x y = mkApps (Var fn) [Type ty, x, y]
chak's avatar
chak committed
383

384 385 386
dsExpr (ArithSeq expr witness seq)
  = case witness of
     Nothing -> dsArithSeq expr seq
Austin Seipp's avatar
Austin Seipp committed
387
     Just fl -> do {
388 389 390
       ; fl' <- dsExpr fl
       ; newArithSeq <- dsArithSeq expr seq
       ; return (App fl' newArithSeq)}
391 392 393 394 395 396

dsExpr (PArrSeq expr (FromTo from to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]

dsExpr (PArrSeq expr (FromThenTo from thn to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
chak's avatar
chak committed
397

398
dsExpr (PArrSeq _ _)
chak's avatar
chak committed
399 400 401
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
402

Facundo Domínguez's avatar
Facundo Domínguez committed
403 404 405 406 407 408 409 410
{-
\noindent
\underline{\bf Static Pointers}
               ~~~~~~~~~~~~~~~
\begin{verbatim}
    g = ... static f ...
==>
    sptEntry:N = StaticPtr
411 412
        (fingerprintString "pkgKey:module.sptEntry:N")
        (StaticPtrInfo "current pkg key" "current module" "sptEntry:0")
Facundo Domínguez's avatar
Facundo Domínguez committed
413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 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 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474
        f
    g = ... sptEntry:N
\end{verbatim}
-}

dsExpr (HsStatic expr@(L loc _)) = do
    expr_ds <- dsLExpr expr
    let ty = exprType expr_ds
    n' <- mkSptEntryName loc
    static_binds_var <- dsGetStaticBindsVar

    staticPtrTyCon       <- dsLookupTyCon   staticPtrTyConName
    staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
    staticPtrDataCon     <- dsLookupDataCon staticPtrDataConName
    fingerprintDataCon   <- dsLookupDataCon fingerprintDataConName

    dflags <- getDynFlags
    let (line, col) = case loc of
           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
                            , srcLocCol  $ realSrcSpanStart r
                            )
           _             -> (0, 0)
        srcLoc = mkCoreConApps (tupleCon BoxedTuple 2)
                     [ Type intTy              , Type intTy
                     , mkIntExprInt dflags line, mkIntExprInt dflags col
                     ]
    info <- mkConApp staticPtrInfoDataCon <$>
            (++[srcLoc]) <$>
            mapM mkStringExprFS
                 [ packageKeyFS $ modulePackageKey $ nameModule n'
                 , moduleNameFS $ moduleName $ nameModule n'
                 , occNameFS    $ nameOccName n'
                 ]
    let tvars = varSetElems $ tyVarsOfType ty
        speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
        speId = mkExportedLocalId VanillaId n' speTy
        fp@(Fingerprint w0 w1) = fingerprintName $ idName speId
        fp_core = mkConApp fingerprintDataCon
                    [ mkWord64LitWordRep dflags w0
                    , mkWord64LitWordRep dflags w1
                    ]
        sp    = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds]
    liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :)
    putSrcSpanDs loc $ return $ mkTyApps (Var speId) (map mkTyVarTy tvars)

  where

    -- | Choose either 'Word64#' or 'Word#' to represent the arguments of the
    -- 'Fingerprint' data constructor.
    mkWord64LitWordRep dflags
      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
      | otherwise = mkWordLit dflags . toInteger

    fingerprintName :: Name -> Fingerprint
    fingerprintName n = fingerprintString $ unpackFS $ concatFS
        [ packageKeyFS $ modulePackageKey $ nameModule n
        , fsLit ":"
        , moduleNameFS (moduleName $ nameModule n)
        , fsLit "."
        , occNameFS $ occName n
        ]

Austin Seipp's avatar
Austin Seipp committed
475
{-
476 477
\noindent
\underline{\bf Record construction and update}
Austin Seipp's avatar
Austin Seipp committed
478
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
479
For record construction we do this (assuming T has three arguments)
480
\begin{verbatim}
481
        T { op2 = e }
482
==>
Austin Seipp's avatar
Austin Seipp committed
483 484 485
        let err = /\a -> recConErr a
        T (recConErr t1 "M.lhs/230/op1")
          e
486
          (recConErr t1 "M.lhs/230/op3")
487 488
\end{verbatim}
@recConErr@ then converts its arugment string into a proper message
489
before printing it as
490
\begin{verbatim}
491
        M.lhs, line 230: missing field op1 was evaluated
492
\end{verbatim}
493

494 495
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
496
-}
497

498 499
dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
    con_expr' <- dsExpr con_expr
500
    let
501
        (arg_tys, _) = tcSplitFunTys (exprType con_expr')
Austin Seipp's avatar
Austin Seipp committed
502
        -- A newtype in the corner should be opaque;
503 504 505 506 507 508
        -- hence TcType.tcSplitFunTys

        mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
          = case findField (rec_flds rbinds) lbl of
              (rhs:rhss) -> ASSERT( null rhss )
                            dsLExpr rhs
509
              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
510
        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
511 512 513

        labels = dataConFieldLabels (idDataCon data_con_id)
        -- The data_con_id is guaranteed to be the wrapper id of the constructor
Austin Seipp's avatar
Austin Seipp committed
514

515 516 517
    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
518

519
    return (mkCoreApps con_expr' con_args)
520

Austin Seipp's avatar
Austin Seipp committed
521
{-
522
Record update is a little harder. Suppose we have the decl:
523
\begin{verbatim}
524 525 526
        data T = T1 {op1, op2, op3 :: Int}
               | T2 {op4, op2 :: Int}
               | T3
527
\end{verbatim}
528
Then we translate as follows:
529
\begin{verbatim}
530
        r { op2 = e }
531
===>
532 533 534 535 536
        let op2 = e in
        case r of
          T1 op1 _ op3 -> T1 op1 op2 op3
          T2 op4 _     -> T2 op4 op2
          other        -> recUpdError "M.lhs/230"
537 538
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
539
RHSs, and do not generate a Core constructor application directly, because the constructor
540 541 542
might do some argument-evaluation first; and may have to throw away some
dictionaries.

543 544
Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
545
Consider
546 547 548
   data T a b where
     T1 { f1 :: a } :: T a Int

Austin Seipp's avatar
Austin Seipp committed
549
Then the wrapper function for T1 has type
550 551 552 553
   $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.
Austin Seipp's avatar
Austin Seipp committed
554
-}
555

556
dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
557
                       cons_to_upd in_inst_tys out_inst_tys)
558
  | null fields
559
  = dsLExpr record_expr
560
  | otherwise
561
  = ASSERT2( notNull cons_to_upd, ppr expr )
562

563 564 565 566 567 568 569 570 571 572
    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
        -- constructor aguments.
        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
573 574 575 576 577
        ; ([discrim_var], matching_code)
                <- matchWrapper RecUpd (MG { mg_alts = 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
578 579 580

        ; return (add_field_binds field_binds' $
                  bindNonRec discrim_var record_expr' matching_code) }
581
  where
582
    ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
583 584 585 586
      -- Clone the Id in the HsRecField, because its Name is that
      -- of the record selector, and we must not make that a lcoal binder
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf Trac #2735
587 588 589 590
    ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
                                  ; let fld_id = unLoc (hsRecFieldId rec_field)
                                  ; lcl_id <- newSysLocalDs (idType fld_id)
                                  ; return (idName fld_id, lcl_id, rhs) }
591 592

    add_field_binds [] expr = expr
593
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
594

Austin Seipp's avatar
Austin Seipp committed
595
        -- Awkwardly, for families, the match goes
596
        -- from instance type to family type
597 598
    tycon     = dataConTyCon (head cons_to_upd)
    in_ty     = mkTyConApp tycon in_inst_tys
599
    out_ty    = mkFamilyTyConApp tycon out_inst_tys
600

601
    mk_alt upd_fld_env con
Austin Seipp's avatar
Austin Seipp committed
602
      = do { let (univ_tvs, ex_tvs, eq_spec,
603 604 605 606 607 608 609 610 611
                  theta, arg_tys, _) = dataConFullSig con
                 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)

                -- I'm not bothering to clone the ex_tvs
           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
           ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
           ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
           ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                         (dataConFieldLabels con) arg_ids
Austin Seipp's avatar
Austin Seipp committed
612
                 mk_val_arg field_name pat_arg_id
613
                     = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
614 615 616 617 618 619 620 621 622 623
                 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
                        -- Reconstruct with the WrapId so that unpacking happens
                 wrap = mkWpEvVarApps theta_vars          <.>
                        mkWpTyApps    (mkTyVarTys ex_tvs) <.>
                        mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
                                       , not (tv `elemVarEnv` wrap_subst) ]
                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args

                        -- Tediously wrap the application in a cast
                        -- Note [Update for GADTs]
Joachim Breitner's avatar
Joachim Breitner committed
624
                 wrap_co = mkTcTyConAppCo Nominal tycon
batterseapower's avatar
batterseapower committed
625
                                [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
626 627
                 lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
                                        Just co' -> co'
Joachim Breitner's avatar
Joachim Breitner committed
628
                                        Nothing  -> mkTcReflCo Nominal ty
629
                 wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
630 631
                                       | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]

Gergő Érdi's avatar
Gergő Érdi committed
632 633
                 pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con)
                                         , pat_tvs = ex_tvs
634 635 636
                                         , pat_dicts = eqs_vars ++ theta_vars
                                         , pat_binds = emptyTcEvBinds
                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
637
                                         , pat_arg_tys = in_inst_tys
Gergő Érdi's avatar
Gergő Érdi committed
638
                                         , pat_wrap = idHsWrapper }
batterseapower's avatar
batterseapower committed
639
           ; let wrapped_rhs | null eq_spec = rhs
Joachim Breitner's avatar
Joachim Breitner committed
640
                             | otherwise    = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
641
           ; return (mkSimpleMatch [pat] wrapped_rhs) }
642

Austin Seipp's avatar
Austin Seipp committed
643
-- Here is where we desugar the Template Haskell brackets and escapes
644 645 646

-- Template Haskell stuff

gmainland's avatar
gmainland committed
647
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
Ian Lynagh's avatar
Ian Lynagh committed
648
#ifdef GHCI
649
dsExpr (HsTcBracketOut x ps) = dsBracket x ps
Ian Lynagh's avatar
Ian Lynagh committed
650
#else
651
dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"
652
#endif
653
dsExpr (HsSpliceE _ s)      = pprPanic "dsExpr:splice" (ppr s)
654

655
-- Arrow notation extension
656
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
657

Austin Seipp's avatar
Austin Seipp committed
658
-- Hpc Support
andy@galois.com's avatar
andy@galois.com committed
659

660
dsExpr (HsTick tickish e) = do
andy@galois.com's avatar
andy@galois.com committed
661
  e' <- dsLExpr e
662
  return (Tick tickish e')
andy@galois.com's avatar
andy@galois.com committed
663 664 665 666 667 668 669 670 671 672

-- 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
673
  do { ASSERT(exprType e2 `eqType` boolTy)
andy@galois.com's avatar
andy@galois.com committed
674 675
       mkBinaryTickBox ixT ixF e2
     }
676

Alan Zimmerman's avatar
Alan Zimmerman committed
677 678 679 680 681 682
dsExpr (HsTickPragma _ _ expr) = do
  dflags <- getDynFlags
  if gopt Opt_Hpc dflags
    then panic "dsExpr:HsTickPragma"
    else dsLExpr expr

683
-- HsSyn constructs that just shouldn't be here:
684 685 686 687 688 689 690 691 692 693 694
dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
dsExpr (HsQuasiQuoteE {})  = panic "dsExpr:HsQuasiQuoteE"
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"
dsExpr (HsType        {})  = panic "dsExpr:HsType"
dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
695

696

Alan Zimmerman's avatar
Alan Zimmerman committed
697

698
findField :: [LHsRecField Id arg] -> Name -> [arg]
Austin Seipp's avatar
Austin Seipp committed
699
findField rbinds lbl
700
  = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds
701
         , lbl == idName (unLoc id) ]
702

Austin Seipp's avatar
Austin Seipp committed
703
{-
sof's avatar
sof committed
704
%--------------------------------------------------------------------
705

706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721
Note [Desugaring explicit lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Explicit lists are desugared in a cleverer way to prevent some
fruitless allocations.  Essentially, whenever we see a list literal
[x_1, ..., x_n] we:

1. Find the tail of the list that can be allocated statically (say
   [x_k, ..., x_n]) by later stages and ensure we desugar that
   normally: this makes sure that we don't cause a code size increase
   by having the cons in that expression fused (see later) and hence
   being unable to statically allocate any more

2. For the prefix of the list which cannot be allocated statically,
   say [x_1, ..., x_(k-1)], we turn it into an expression involving
   build so that if we find any foldrs over it it will fuse away
   entirely!
Austin Seipp's avatar
Austin Seipp committed
722

723 724
   So in this example we will desugar to:
   build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
Austin Seipp's avatar
Austin Seipp committed
725

726 727
   If fusion fails to occur then build will get inlined and (since we
   defined a RULE for foldr (:) []) we will get back exactly the
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
728 729 730 731 732 733 734 735 736
   normal desugaring for an explicit list.

This optimisation can be worth a lot: up to 25% of the total
allocation in some nofib programs. Specifically

        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%
737 738 739

Of course, if rules aren't turned on then there is pretty much no
point doing this fancy stuff, and it may even be harmful.
740 741 742 743

=======>  Note by SLPJ Dec 08.

I'm unconvinced that we should *ever* generate a build for an explicit
Austin Seipp's avatar
Austin Seipp committed
744
list.  See the comments in GHC.Base about the foldr/cons rule, which
745 746 747
points out that (foldr k z [a,b,c]) may generate *much* less code than
(a `k` b `k` c `k` z).

Austin Seipp's avatar
Austin Seipp committed
748
Furthermore generating builds messes up the LHS of RULES.
749 750 751 752
Example: the foldr/single rule in GHC.Base
   foldr k z [x] = ...
We do not want to generate a build invocation on the LHS of this RULE!

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
753 754 755
We fix this by disabling rules in rule LHSs, and testing that
flag here; see Note [Desugaring RULE left hand sides] in Desugar

756
To test this I've added a (static) flag -fsimple-list-literals, which
Austin Seipp's avatar
Austin Seipp committed
757 758
makes all list literals be generated via the simple route.
-}
759

760 761
dsExplicitList :: PostTc Id Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
               -> DsM CoreExpr
762
-- See Note [Desugaring explicit lists]
763
dsExplicitList elt_ty Nothing xs
764
  = do { dflags <- getDynFlags
765 766
       ; xs' <- mapM dsLExpr xs
       ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
ian@well-typed.com's avatar
ian@well-typed.com committed
767 768
       ; if gopt Opt_SimpleListLiterals dflags        -- -fsimple-list-literals
         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
769 770
                -- Don't generate a build if there are no rules to eliminate it!
                -- See Note [Desugaring RULE left hand sides] in Desugar
771 772 773
         || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
         then return $ mkListExpr elt_ty xs'
         else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
774
  where
775 776 777 778
    is_static :: CoreExpr -> Bool
    is_static e = all is_static_var (varSetElems (exprFreeVars e))

    is_static_var :: Var -> Bool
Austin Seipp's avatar
Austin Seipp committed
779
    is_static_var v
780 781 782 783 784 785 786
      | isId v = isExternalName (idName v)  -- Top-level things are given external names
      | otherwise = False                   -- Type variables

    mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
      = do { let suffix' = mkListExpr elt_ty suffix
           ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
           ; return (foldr (App . App (Var c)) folded_suffix prefix) }
787

788 789 790 791 792
dsExplicitList elt_ty (Just fln) xs
  = do { fln' <- dsExpr fln
       ; list <- dsExplicitList elt_ty Nothing xs
       ; dflags <- getDynFlags
       ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) }
Austin Seipp's avatar
Austin Seipp committed
793

794 795 796
spanTail :: (a -> Bool) -> [a] -> ([a], [a])
spanTail f xs = (reverse rejected, reverse satisfying)
    where (satisfying, rejected) = span f $ reverse xs
Austin Seipp's avatar
Austin Seipp committed
797

798 799 800 801
dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
dsArithSeq expr (From from)
  = App <$> dsExpr expr <*> dsLExpr from
dsArithSeq expr (FromTo from to)
802 803 804
  = do dflags <- getDynFlags
       warnAboutEmptyEnumerations dflags from Nothing to
       expr' <- dsExpr expr
805 806 807
       from' <- dsLExpr from
       to'   <- dsLExpr to
       return $ mkApps expr' [from', to']
808 809 810
dsArithSeq expr (FromThen from thn)
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
dsArithSeq expr (FromThenTo from thn to)
811 812 813
  = do dflags <- getDynFlags
       warnAboutEmptyEnumerations dflags from (Just thn) to
       expr' <- dsExpr expr
814 815 816 817
       from' <- dsLExpr from
       thn'  <- dsLExpr thn
       to'   <- dsLExpr to
       return $ mkApps expr' [from', thn', to']
818

Austin Seipp's avatar
Austin Seipp committed
819
{-