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

Simon Marlow's avatar
Simon Marlow committed
5 6

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

9 10
{-# LANGUAGE CPP #-}

11 12
module DsExpr ( dsExpr, dsLExpr, dsLocalBinds
              , 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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
224
dsExpr (NegApp expr neg_expr)
225 226
  = do { expr' <- dsLExpr expr
       ; dsSyntaxExpr neg_expr [expr'] }
227

228
dsExpr (HsLam a_Match)
229
  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
230

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

236
dsExpr e@(HsApp fun arg)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
237 238 239 240
    -- 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
241

242

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

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

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

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

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

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

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

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

316
       ; return $ mkCoreLams lam_vars $
317
                  mkCoreTupBoxity boxity args }
318

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

dsExpr (HsCoreAnn _ _ expr)
331
  = dsLExpr expr
332

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

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

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

354 355 356 357 358
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
359
           Just fun -> dsSyntaxExpr fun [pred, b1, b2]
360
           Nothing  -> return $ mkIfThenElse pred b1 b2 }
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
373
                               (text "multi-way if")
374

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

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

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

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

399 400 401
dsExpr (ArithSeq expr witness seq)
  = case witness of
     Nothing -> dsArithSeq expr seq
402 403
     Just fl -> do { newArithSeq <- dsArithSeq expr seq
                   ; dsSyntaxExpr fl [newArithSeq] }
404 405 406 407 408 409

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
410

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

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

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

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

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

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

520 521 522 523 524 525
             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
526

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

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

533
       ; return (mkCoreApps con_expr' con_args) }
534

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

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

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

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

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

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

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

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

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

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

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

                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
678

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

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

-- Template Haskell stuff

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

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

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

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

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

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

724
-- HsSyn constructs that just shouldn't be here:
725 726 727 728 729 730 731 732
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
733
dsExpr (HsType        {})  = panic "dsExpr:HsType" -- removed by typechecker
734
dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
735
dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
736

737 738 739 740 741
-- Normally handled in HsApp case, but a GHC API user might try to desugar
-- an HsTypeOut, since it is an HsExpr in a typechecked module after all.
-- (Such as ghci itself, in #11456.) So improve the error message slightly.
dsExpr (HsTypeOut {})
  = panic "dsExpr: tried to desugar a naked type application argument (HsTypeOut)"
Alan Zimmerman's avatar
Alan Zimmerman committed
742

743 744 745 746 747 748 749 750 751 752
------------------------------
dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
                         , syn_arg_wraps = arg_wraps
                         , syn_res_wrap  = res_wrap })
             arg_exprs
  = do { args <- zipWithM dsHsWrapper arg_wraps arg_exprs
       ; fun  <- dsExpr expr
       ; dsHsWrapper res_wrap $ mkApps fun args }

753
findField :: [LHsRecField Id arg] -> Name -> [arg]
Adam Gundry's avatar
Adam Gundry committed
754 755 756
findField rbinds sel
  = [hsRecFieldArg fld | L _ fld <- rbinds
                       , sel == idName (unLoc $ hsRecFieldId fld) ]
757

Austin Seipp's avatar
Austin Seipp committed
758
{-
sof's avatar
sof committed
759
%--------------------------------------------------------------------
760

761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776
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
777

778 779
   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
780

781 782
   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
783 784 785 786 787 788 789 790 791
   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%
792 793 794

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.
795 796 797 798

=======>  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
799
list.  See the comments in GHC.Base about the foldr/cons rule, which
800 801 802
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
803
Furthermore generating builds messes up the LHS of RULES.
804 805 806 807
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
808 809 810
We fix this by disabling rules in rule LHSs, and testing that
flag here; see Note [Desugaring RULE left hand sides] in Desugar

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

815
dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
816
               -> DsM CoreExpr