DsExpr.hs 40.8 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 )
Simon Marlow's avatar
Simon Marlow committed
26
import DsMeta
27
import HsSyn
28

Facundo Domínguez's avatar
Facundo Domínguez committed
29
import Platform
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 CoreFVs
40
import MkCore
Simon Marlow's avatar
Simon Marlow committed
41

42
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
43 44
import CostCentre
import Id
45
import Module
46
import VarSet
Gergő Érdi's avatar
Gergő Érdi committed
47
import ConLike
Simon Marlow's avatar
Simon Marlow committed
48 49
import DataCon
import TysWiredIn
Facundo Domínguez's avatar
Facundo Domínguez committed
50
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
51
import BasicTypes
52
import Maybes
53
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
54 55 56
import SrcLoc
import Util
import Bag
57
import Outputable
58
import FastString
Matthew Pickering's avatar
Matthew Pickering committed
59
import PatSyn
60

61
import IfaceEnv
62
import Data.IORef       ( atomicModifyIORef', modifyIORef )
Facundo Domínguez's avatar
Facundo Domínguez committed
63

64
import Control.Monad
Facundo Domínguez's avatar
Facundo Domínguez committed
65
import GHC.Fingerprint
66

Austin Seipp's avatar
Austin Seipp committed
67 68 69
{-
************************************************************************
*                                                                      *
70
                dsLocalBinds, dsValBinds
Austin Seipp's avatar
Austin Seipp committed
71 72 73
*                                                                      *
************************************************************************
-}
74

75
dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
76
dsLocalBinds EmptyLocalBinds    body = return body
77 78 79 80 81
dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body

-------------------------
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
82
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
Simon Peyton Jones's avatar
Simon Peyton Jones committed
83
dsValBinds (ValBindsIn {})       _    = panic "dsValBinds ValBindsIn"
84 85

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

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

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

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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
145 146 147 148 149 150 151 152 153
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') }

154 155 156 157 158 159
dsUnliftedBind (FunBind { fun_id = L _ fun
                        , 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
160
  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches
161 162
       ; MASSERT( null args ) -- Functions aren't lifted
       ; MASSERT( isIdHsWrapper co_fn )
163
       ; let rhs' = mkOptTickBox tick rhs
164 165
       ; return (bindNonRec fun rhs' body) }

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

177
dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
178 179

----------------------
180 181 182
unliftedMatchOnly :: HsBind Id -> Bool
unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
  = anyBag (unliftedMatchOnly . unLoc) lbinds
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
183 184
unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind })
  = unliftedMatchOnly bind
185
unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
186
  =  isUnLiftedType rhs_ty
187
  || isUnliftedLPat lpat
188
  || any (isUnLiftedType . idType) (collectPatBinders lpat)
189
unliftedMatchOnly (FunBind { fun_id = L _ id })
190
  = isUnLiftedType (idType id)
191
unliftedMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
192

Austin Seipp's avatar
Austin Seipp committed
193 194 195
{-
************************************************************************
*                                                                      *
196
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
Austin Seipp's avatar
Austin Seipp committed
197 198 199
*                                                                      *
************************************************************************
-}
200

201
dsLExpr :: LHsExpr Id -> DsM CoreExpr
mnislaih's avatar
mnislaih committed
202

203 204 205
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e

dsExpr :: HsExpr Id -> DsM CoreExpr
206
dsExpr (HsPar e)              = dsLExpr e
207
dsExpr (ExprWithTySigOut e _) = dsLExpr e
208 209
dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)
                                -- See Note [Desugaring vars]
210
dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
211
dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
Adam Gundry's avatar
Adam Gundry committed
212
dsExpr (HsOverLabel _)        = panic "dsExpr: HsOverLabel"
213 214
dsExpr (HsLit lit)            = dsLit lit
dsExpr (HsOverLit lit)        = dsOverLit lit
215 216

dsExpr (HsWrap co_fn e)
217
  = do { e' <- dsExpr e
218
       ; wrapped_e <- dsHsWrapper co_fn e'
219 220
       ; dflags <- getDynFlags
       ; warnAboutIdentities dflags e' (exprType wrapped_e)
221
       ; return wrapped_e }
222

Austin Seipp's avatar
Austin Seipp committed
223
dsExpr (NegApp expr neg_expr)
224
  = App <$> dsExpr neg_expr <*> dsLExpr expr
225

226
dsExpr (HsLam a_Match)
227
  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
228

229
dsExpr (HsLamCase arg matches)
230
  = do { arg_var <- newSysLocalDs arg
231
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
232 233
       ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }

234
dsExpr e@(HsApp fun arg)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
235 236 237 238
    -- ignore type arguments here; they're in the wrappers instead at this point
  | isLHsTypeExpr arg = dsLExpr fun
  | otherwise         = mkCoreAppDs (text "HsApp" <+> ppr e)
                        <$> dsLExpr fun <*>  dsLExpr arg
239

240

Austin Seipp's avatar
Austin Seipp committed
241
{-
Simon Peyton Jones's avatar
Simon Peyton Jones committed
242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
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
257

258 259
Operator sections.  At first it looks as if we can convert
\begin{verbatim}
260
        (expr op)
261
\end{verbatim}
262
to
263
\begin{verbatim}
264
        \x -> op expr x
265 266 267 268 269
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
270
        map (expr op) xs
271 272 273
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
274
        let y = expr in \x -> op y x
275 276 277
\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
278
-}
279

280
dsExpr e@(OpApp e1 op _ e2)
281
  = -- for the type of y, we need the type of op's 2nd argument
282
    mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
Austin Seipp's avatar
Austin Seipp committed
283

284
dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
285
  = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr
286

287
-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
288
dsExpr e@(SectionR op expr) = do
289
    core_op <- dsLExpr op
sof's avatar
sof committed
290
    -- for the type of x, we need the type of op's 2nd argument
291 292 293 294 295 296
    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 $
297
            Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
298

299
dsExpr (ExplicitTuple tup_args boxity)
300
  = do { let go (lam_vars, args) (L _ (Missing ty))
301
                    -- For every missing expression, we need
302
                    -- another lambda in the desugaring.
303 304
               = do { lam_var <- newSysLocalDs ty
                    ; return (lam_var : lam_vars, Var lam_var : args) }
305
             go (lam_vars, args) (L _ (Present expr))
306
                    -- Expressions that are present don't generate
307 308 309 310 311
                    -- lambdas, just arguments.
               = do { core_expr <- dsLExpr expr
                    ; return (lam_vars, core_expr : args) }

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

314
       ; return $ mkCoreLams lam_vars $
315
                  mkCoreTupBoxity boxity args }
316

Alan Zimmerman's avatar
Alan Zimmerman committed
317 318 319 320 321 322 323
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
324
        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
Alan Zimmerman's avatar
Alan Zimmerman committed
325 326 327 328
               <$> dsLExpr expr
      else dsLExpr expr

dsExpr (HsCoreAnn _ _ expr)
329
  = dsLExpr expr
330

331
dsExpr (HsCase discrim matches)
332
  = do { core_discrim <- dsLExpr discrim
333
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
334
       ; return (bindNonRec discrim_var core_discrim matching_code) }
335

336 337
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
338
dsExpr (HsLet (L _ binds) body) = do
339
    body' <- dsLExpr body
340
    dsLocalBinds binds body'
341

chak's avatar
chak committed
342 343 344
-- 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.
--
345 346 347 348 349 350
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
351

352 353 354 355 356 357 358 359
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 }
360 361 362 363 364 365 366 367 368 369 370 371 372

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"))
373

Austin Seipp's avatar
Austin Seipp committed
374
{-
375 376
\noindent
\underline{\bf Various data construction things}
Austin Seipp's avatar
Austin Seipp committed
377 378 379 380
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}

dsExpr (ExplicitList elt_ty wit xs)
381
  = dsExplicitList elt_ty wit xs
382

383 384
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
385
--
386
dsExpr (ExplicitPArr ty []) = do
387
    emptyP <- dsDPHBuiltin emptyPVar
388
    return (Var emptyP `App` Type ty)
389
dsExpr (ExplicitPArr ty xs) = do
390 391
    singletonP <- dsDPHBuiltin singletonPVar
    appP       <- dsDPHBuiltin appPVar
392
    xs'        <- mapM dsLExpr xs
393 394 395
    let unary  fn x   = mkApps (Var fn) [Type ty, x]
        binary fn x y = mkApps (Var fn) [Type ty, x, y]

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

398 399 400
dsExpr (ArithSeq expr witness seq)
  = case witness of
     Nothing -> dsArithSeq expr seq
Austin Seipp's avatar
Austin Seipp committed
401
     Just fl -> do {
402 403 404
       ; fl' <- dsExpr fl
       ; newArithSeq <- dsArithSeq expr seq
       ; return (App fl' newArithSeq)}
405 406 407 408 409 410

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
411

412
dsExpr (PArrSeq _ _)
chak's avatar
chak committed
413 414 415
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
416

Facundo Domínguez's avatar
Facundo Domínguez committed
417 418 419 420 421 422 423 424
{-
\noindent
\underline{\bf Static Pointers}
               ~~~~~~~~~~~~~~~
\begin{verbatim}
    g = ... static f ...
==>
    sptEntry:N = StaticPtr
425 426
        (fingerprintString "pkgKey:module.sptEntry:N")
        (StaticPtrInfo "current pkg key" "current module" "sptEntry:0")
Facundo Domínguez's avatar
Facundo Domínguez committed
427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448
        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)
449
        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
Facundo Domínguez's avatar
Facundo Domínguez committed
450 451 452 453 454 455
                     [ Type intTy              , Type intTy
                     , mkIntExprInt dflags line, mkIntExprInt dflags col
                     ]
    info <- mkConApp staticPtrInfoDataCon <$>
            (++[srcLoc]) <$>
            mapM mkStringExprFS
456
                 [ unitIdFS $ moduleUnitId $ nameModule n'
Facundo Domínguez's avatar
Facundo Domínguez committed
457 458 459
                 , moduleNameFS $ moduleName $ nameModule n'
                 , occNameFS    $ nameOccName n'
                 ]
460 461 462
    let tvars = tyCoVarsOfTypeWellScoped ty
        speTy = ASSERT( all isTyVar tvars )  -- ty is top-level, so this is OK
                mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
463
        speId = mkExportedVanillaId n' speTy
Facundo Domínguez's avatar
Facundo Domínguez committed
464 465 466 467 468 469 470
        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)) :)
471
    putSrcSpanDs loc $ return $ mkTyApps (Var speId) (mkTyVarTys tvars)
Facundo Domínguez's avatar
Facundo Domínguez committed
472 473 474 475 476 477 478 479 480 481 482

  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
483
        [ unitIdFS $ moduleUnitId $ nameModule n
Facundo Domínguez's avatar
Facundo Domínguez committed
484 485 486 487 488 489
        , fsLit ":"
        , moduleNameFS (moduleName $ nameModule n)
        , fsLit "."
        , occNameFS $ occName n
        ]

Austin Seipp's avatar
Austin Seipp committed
490
{-
491 492
\noindent
\underline{\bf Record construction and update}
Austin Seipp's avatar
Austin Seipp committed
493
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
494
For record construction we do this (assuming T has three arguments)
495
\begin{verbatim}
496
        T { op2 = e }
497
==>
Austin Seipp's avatar
Austin Seipp committed
498
        let err = /\a -> recConErr a
499
        T (recConErr t1 "M.hs/230/op1")
Austin Seipp's avatar
Austin Seipp committed
500
          e
501
          (recConErr t1 "M.hs/230/op3")
502
\end{verbatim}
503
@recConErr@ then converts its argument string into a proper message
504
before printing it as
505
\begin{verbatim}
506
        M.hs, line 230: missing field op1 was evaluated
507
\end{verbatim}
508

509 510
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
511
-}
512

513 514 515 516 517 518 519
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
520

521 522 523 524 525 526
             mk_arg (arg_ty, fl)
               = case findField (rec_flds rbinds) (flSelector fl) of
                   (rhs:rhss) -> ASSERT( null rhss )
                                 dsLExpr rhs
                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
527

528
             labels = conLikeFieldLabels con_like
Austin Seipp's avatar
Austin Seipp committed
529

530 531 532
       ; 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
533

534
       ; return (mkCoreApps con_expr' con_args) }
535

Austin Seipp's avatar
Austin Seipp committed
536
{-
537
Record update is a little harder. Suppose we have the decl:
538
\begin{verbatim}
539 540 541
        data T = T1 {op1, op2, op3 :: Int}
               | T2 {op4, op2 :: Int}
               | T3
542
\end{verbatim}
543
Then we translate as follows:
544
\begin{verbatim}
545
        r { op2 = e }
546
===>
547 548 549 550
        let op2 = e in
        case r of
          T1 op1 _ op3 -> T1 op1 op2 op3
          T2 op4 _     -> T2 op4 op2
551
          other        -> recUpdError "M.hs/230"
552 553
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
554
RHSs, and do not generate a Core constructor application directly, because the constructor
555 556 557
might do some argument-evaluation first; and may have to throw away some
dictionaries.

558 559
Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
560
Consider
561
   data T a b where
562
     T1 :: { f1 :: a } -> T a Int
563

Austin Seipp's avatar
Austin Seipp committed
564
Then the wrapper function for T1 has type
565 566 567 568
   $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.
569

Austin Seipp's avatar
Austin Seipp committed
570
-}
571

572 573 574 575
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 } )
576
  | null fields
577
  = dsLExpr record_expr
578
  | otherwise
579
  = ASSERT2( notNull cons_to_upd, ppr expr )
580

581 582 583 584 585 586 587 588 589 590
    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
591
        ; ([discrim_var], matching_code)
592 593 594 595 596
                <- 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
597 598 599

        ; return (add_field_binds field_binds' $
                  bindNonRec discrim_var record_expr' matching_code) }
600
  where
Adam Gundry's avatar
Adam Gundry committed
601
    ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
602
      -- Clone the Id in the HsRecField, because its Name is that
Adam Gundry's avatar
Adam Gundry committed
603
      -- of the record selector, and we must not make that a local binder
604 605
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf Trac #2735
606
    ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
Adam Gundry's avatar
Adam Gundry committed
607
                                  ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
608 609
                                  ; lcl_id <- newSysLocalDs (idType fld_id)
                                  ; return (idName fld_id, lcl_id, rhs) }
610 611

    add_field_binds [] expr = expr
612
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
613

Austin Seipp's avatar
Austin Seipp committed
614
        -- Awkwardly, for families, the match goes
615
        -- from instance type to family type
Matthew Pickering's avatar
Matthew Pickering committed
616 617 618 619 620 621 622 623
    (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 ->
          (patSynInstResTy pat_syn in_inst_tys
          , patSynInstResTy pat_syn out_inst_tys)
624
    mk_alt upd_fld_env con
Austin Seipp's avatar
Austin Seipp committed
625
      = do { let (univ_tvs, ex_tvs, eq_spec,
Matthew Pickering's avatar
Matthew Pickering committed
626
                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
627
                 subst = mkTopTCvSubst (univ_tvs `zip` in_inst_tys)
628 629 630

                -- 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
631
           ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
632
           ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
633 634 635
           ; let field_labels = conLikeFieldLabels con
                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                         field_labels arg_ids
Adam Gundry's avatar
Adam Gundry committed
636 637
                 mk_val_arg fl pat_arg_id
                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
Matthew Pickering's avatar
Matthew Pickering committed
638 639 640
                 -- SAFE: the typechecker will complain if the synonym is
                 -- not bidirectional
                 wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con)
641
                 inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id))
642
                        -- Reconstruct with the WrapId so that unpacking happens
Matthew Pickering's avatar
Matthew Pickering committed
643
                 -- The order here is because of the order in `TcPatSyn`.
644 645 646 647 648 649
                 wrap = dict_req_wrap                                           <.>
                        mkWpEvVarApps theta_vars                                <.>
                        mkWpTyApps    (mkTyVarTys ex_tvs)                       <.>
                        mkWpTyApps    [ ty
                                      | (tv, ty) <- univ_tvs `zip` out_inst_tys
                                      , not (tv `elemVarEnv` wrap_subst) ]
650 651 652 653
                 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
654 655 656 657 658 659 660 661 662 663 664 665 666 667 668
                 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
669
                             else mkLHsWrap (mkWpCastN wrap_co) rhs
Matthew Pickering's avatar
Matthew Pickering committed
670 671 672 673 674
                    -- eq_spec is always null for a PatSynCon
                    PatSynCon _ -> rhs

                 wrap_subst =
                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
675 676
                           | (spec, eq_var) <- eq_spec `zip` eqs_vars
                           , let tv = eqSpecTyVar spec ]
Matthew Pickering's avatar
Matthew Pickering committed
677 678

                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
679

Matthew Pickering's avatar
Matthew Pickering committed
680
                 pat = noLoc $ ConPatOut { pat_con = noLoc con
Gergő Érdi's avatar
Gergő Érdi committed
681
                                         , pat_tvs = ex_tvs
682 683 684
                                         , pat_dicts = eqs_vars ++ theta_vars
                                         , pat_binds = emptyTcEvBinds
                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
685
                                         , pat_arg_tys = in_inst_tys
Matthew Pickering's avatar
Matthew Pickering committed
686
                                         , pat_wrap = req_wrap }
687
           ; return (mkSimpleMatch [pat] wrapped_rhs) }
688

Austin Seipp's avatar
Austin Seipp committed
689
-- Here is where we desugar the Template Haskell brackets and escapes
690 691 692

-- Template Haskell stuff

gmainland's avatar
gmainland committed
693
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
694
dsExpr (HsTcBracketOut x ps) = dsBracket x ps
695
dsExpr (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)
696

697
-- Arrow notation extension
698
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
699

Austin Seipp's avatar
Austin Seipp committed
700
-- Hpc Support
andy@galois.com's avatar
andy@galois.com committed
701

702
dsExpr (HsTick tickish e) = do
andy@galois.com's avatar
andy@galois.com committed
703
  e' <- dsLExpr e
704
  return (Tick tickish e')
andy@galois.com's avatar
andy@galois.com committed
705 706 707 708 709 710 711 712 713 714

-- 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
715
  do { ASSERT(exprType e2 `eqType` boolTy)
andy@galois.com's avatar
andy@galois.com committed
716 717
       mkBinaryTickBox ixT ixF e2
     }
718

719
dsExpr (HsTickPragma _ _ _ expr) = do
Alan Zimmerman's avatar
Alan Zimmerman committed
720 721 722 723 724
  dflags <- getDynFlags
  if gopt Opt_Hpc dflags
    then panic "dsExpr:HsTickPragma"
    else dsLExpr expr

725
-- HsSyn constructs that just shouldn't be here:
726 727 728 729 730 731 732 733
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"
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
734 735
dsExpr (HsType        {})  = panic "dsExpr:HsType" -- removed by typechecker
dsExpr (HsTypeOut     {})  = panic "dsExpr:HsTypeOut" -- handled in HsApp case
736
dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
737
dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
738

Alan Zimmerman's avatar
Alan Zimmerman committed
739

740
findField :: [LHsRecField Id arg] -> Name -> [arg]
Adam Gundry's avatar
Adam Gundry committed
741 742 743
findField rbinds sel
  = [hsRecFieldArg fld | L _ fld <- rbinds
                       , sel == idName (unLoc $ hsRecFieldId fld) ]
744

Austin Seipp's avatar
Austin Seipp committed
745
{-
sof's avatar
sof committed
746
%--------------------------------------------------------------------
747

748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763
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
764

765 766
   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
767

768 769
   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
770 771 772 773 774 775 776 777 778
   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%
779 780 781

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.
782 783 784 785

=======>  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
786
list.  See the comments in GHC.Base about the foldr/cons rule, which
787 788 789
points out that (foldr