Refactoring on IdInfo and system derived names
[ghc.git] / compiler / deSugar / DsExpr.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Desugaring exporessions.
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
12
13 #include "HsVersions.h"
14
15 import Match
16 import MatchLit
17 import DsBinds
18 import DsGRHSs
19 import DsListComp
20 import DsUtils
21 import DsArrows
22 import DsMonad
23 import Name
24 import NameEnv
25 import FamInstEnv( topNormaliseType )
26 import DsMeta
27 import HsSyn
28
29 import Platform
30 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
31 -- needs to see source types
32 import TcType
33 import TcEvidence
34 import TcRnMonad
35 import TcHsSyn
36 import Type
37 import CoreSyn
38 import CoreUtils
39 import CoreFVs
40 import MkCore
41
42 import DynFlags
43 import CostCentre
44 import Id
45 import Module
46 import VarSet
47 import ConLike
48 import DataCon
49 import TysWiredIn
50 import PrelNames
51 import BasicTypes
52 import Maybes
53 import VarEnv
54 import SrcLoc
55 import Util
56 import Bag
57 import Outputable
58 import FastString
59 import PatSyn
60
61 import IfaceEnv
62 import Data.IORef ( atomicModifyIORef', modifyIORef )
63
64 import Control.Monad
65 import GHC.Fingerprint
66
67 {-
68 ************************************************************************
69 * *
70 dsLocalBinds, dsValBinds
71 * *
72 ************************************************************************
73 -}
74
75 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
76 dsLocalBinds EmptyLocalBinds body = return body
77 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
78 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
79
80 -------------------------
81 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
82 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
83 dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn"
84
85 -------------------------
86 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
87 dsIPBinds (IPBinds ip_binds ev_binds) body
88 = do { ds_binds <- dsTcEvBinds ev_binds
89 ; let inner = mkCoreLets ds_binds body
90 -- The dict bindings may not be in
91 -- dependency order; hence Rec
92 ; 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 -- We need to do a case right away, rather than building
102 -- a tuple and doing selections.
103 -- Silently ignore INLINE and SPECIALISE pragmas...
104 ds_val_bind (NonRecursive, hsbinds) body
105 | [L loc bind] <- bagToList hsbinds,
106 -- Non-recursive, non-overloaded bindings only come in ones
107 -- ToDo: in some bizarre case it's conceivable that there
108 -- could be dict binds in the 'binds'. (See the notes
109 -- below. Then pattern-match would fail. Urk.)
110 unliftedMatchOnly bind
111 = putSrcSpanDs loc (dsUnliftedBind bind body)
112
113 -- Ordinary case for bindings; none should be unlifted
114 ds_val_bind (_is_rec, binds) body
115 = do { (force_vars,prs) <- dsLHsBinds binds
116 ; let body' = foldr seqVar body force_vars
117 ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
118 case prs of
119 [] -> return body
120 _ -> return (Let (Rec prs) body') }
121 -- Use a Rec regardless of is_rec.
122 -- Why? Because it allows the binds to be all
123 -- mixed up, which is what happens in one rare case
124 -- Namely, for an AbsBind with no tyvars and no dicts,
125 -- but which does have dictionary bindings.
126 -- See notes with TcSimplify.inferLoop [NO TYVARS]
127 -- It turned out that wrapping a Rec here was the easiest solution
128 --
129 -- NB The previous case dealt with unlifted bindings, so we
130 -- only have to deal with lifted ones now; so Rec is ok
131
132 ------------------
133 dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
134 dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
135 , abs_exports = exports
136 , 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)
141 body1 lbinds
142 ; ds_binds <- dsTcEvBinds_s ev_binds
143 ; return (mkCoreLets ds_binds body2) }
144
145 dsUnliftedBind (AbsBindsSig { abs_tvs = []
146 , abs_ev_vars = []
147 , abs_sig_export = poly
148 , abs_sig_ev_bind = ev_bind
149 , abs_sig_bind = L _ bind }) body
150 = do { ds_binds <- dsTcEvBinds ev_bind
151 ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
152 ; return (mkCoreLets ds_binds body') }
153
154 dsUnliftedBind (FunBind { fun_id = L _ fun
155 , fun_matches = matches
156 , fun_co_fn = co_fn
157 , fun_tick = tick }) body
158 -- Can't be a bang pattern (that looks like a PatBind)
159 -- so must be simply unboxed
160 = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches
161 ; MASSERT( null args ) -- Functions aren't lifted
162 ; MASSERT( isIdHsWrapper co_fn )
163 ; let rhs' = mkOptTickBox tick rhs
164 ; return (bindNonRec fun rhs' body) }
165
166 dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
167 = -- let C x# y# = rhs in body
168 -- ==> case rhs of C x# y# -> body
169 do { rhs <- dsGuarded grhss ty
170 ; let upat = unLoc pat
171 eqn = EqnInfo { eqn_pats = [upat],
172 eqn_rhs = cantFailMatchResult body }
173 ; var <- selectMatchVar upat
174 ; 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 unliftedMatchOnly :: HsBind Id -> Bool
181 unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
182 = anyBag (unliftedMatchOnly . unLoc) lbinds
183 unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind })
184 = 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
193 {-
194 ************************************************************************
195 * *
196 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
197 * *
198 ************************************************************************
199 -}
200
201 dsLExpr :: LHsExpr Id -> DsM CoreExpr
202
203 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
204
205 dsExpr :: HsExpr Id -> DsM CoreExpr
206 dsExpr (HsPar e) = dsLExpr e
207 dsExpr (ExprWithTySigOut e _) = dsLExpr e
208 dsExpr (HsVar (L _ var)) = return (varToCoreExpr var)
209 -- See Note [Desugaring vars]
210 dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
211 dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
212 dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel"
213 dsExpr (HsLit lit) = dsLit lit
214 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 ; dflags <- getDynFlags
220 ; warnAboutIdentities dflags e' (exprType wrapped_e)
221 ; return wrapped_e }
222
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 ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
233
234 dsExpr e@(HsApp fun arg)
235 -- ignore type arguments here; they're in the wrappers instead at this point
236 | isLHsTypeExpr arg = dsLExpr fun
237 | otherwise = mkCoreAppDs (text "HsApp" <+> ppr e)
238 <$> dsLExpr fun <*> dsLExpr arg
239
240
241 {-
242 Note [Desugaring vars]
243 ~~~~~~~~~~~~~~~~~~~~~~
244 In one situation we can get a *coercion* variable in a HsVar, namely
245 the support method for an equality superclass:
246 class (a~b) => C a b where ...
247 instance (blah) => C (T a) (T b) where ..
248 Then we get
249 $dfCT :: forall ab. blah => C (T a) (T b)
250 $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
251
252 $c$p1C :: forall ab. blah => (T a ~ T b)
253 $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
254
255 That 'g' in the 'in' part is an evidence variable, and when
256 converting to core it must become a CO.
257
258 Operator sections. At first it looks as if we can convert
259 \begin{verbatim}
260 (expr op)
261 \end{verbatim}
262 to
263 \begin{verbatim}
264 \x -> op expr x
265 \end{verbatim}
266
267 But no! expr might be a redex, and we can lose laziness badly this
268 way. Consider
269 \begin{verbatim}
270 map (expr op) xs
271 \end{verbatim}
272 for example. So we convert instead to
273 \begin{verbatim}
274 let y = expr in \x -> op y x
275 \end{verbatim}
276 If \tr{expr} is actually just a variable, say, then the simplifier
277 will sort it out.
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]
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
290 -- for the type of x, we need the type of op's 2nd argument
291 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
292 -- See comment with SectionL
293 y_core <- dsLExpr expr
294 x_id <- newSysLocalDs x_ty
295 y_id <- newSysLocalDs y_ty
296 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 = do { lam_var <- newSysLocalDs ty
304 ; 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 -- lambdas, just arguments.
308 = do { core_expr <- dsLExpr expr
309 ; return (lam_vars, core_expr : args) }
310
311 ; (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
317 dsExpr (HsSCC _ cc expr@(L loc _)) = do
318 dflags <- getDynFlags
319 if gopt Opt_SccProfilingOn dflags
320 then do
321 mod_name <- getModule
322 count <- goptM Opt_ProfCountEntries
323 uniq <- newUnique
324 Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
325 <$> dsLExpr expr
326 else dsLExpr expr
327
328 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 -- Pepe: The binds are in scope in the body but NOT in the binding group
337 -- This is to avoid silliness in breakpoints
338 dsExpr (HsLet (L _ binds) body) = do
339 body' <- dsLExpr body
340 dsLocalBinds binds body'
341
342 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
343 -- because the interpretation of `stmts' depends on what sort of thing it is.
344 --
345 dsExpr (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty
346 dsExpr (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts)
347 dsExpr (HsDo DoExpr (L _ stmts) _) = dsDo stmts
348 dsExpr (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts
349 dsExpr (HsDo MDoExpr (L _ stmts) _) = dsDo stmts
350 dsExpr (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts
351
352 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
353 = do { pred <- dsLExpr guard_expr
354 ; b1 <- dsLExpr then_expr
355 ; b2 <- dsLExpr else_expr
356 ; case mb_fun of
357 Just fun -> do { core_fun <- dsExpr fun
358 ; return (mkCoreApps core_fun [pred,b1,b2]) }
359 Nothing -> return $ mkIfThenElse pred b1 b2 }
360
361 dsExpr (HsMultiIf res_ty alts)
362 | null alts
363 = mkErrorExpr
364
365 | otherwise
366 = do { match_result <- liftM (foldr1 combineMatchResults)
367 (mapM (dsGRHS IfAlt res_ty) alts)
368 ; error_expr <- mkErrorExpr
369 ; extractMatchResult match_result error_expr }
370 where
371 mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
372 (ptext (sLit "multi-way if"))
373
374 {-
375 \noindent
376 \underline{\bf Various data construction things}
377 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
378 -}
379
380 dsExpr (ExplicitList elt_ty wit xs)
381 = dsExplicitList elt_ty wit xs
382
383 -- We desugar [:x1, ..., xn:] as
384 -- singletonP x1 +:+ ... +:+ singletonP xn
385 --
386 dsExpr (ExplicitPArr ty []) = do
387 emptyP <- dsDPHBuiltin emptyPVar
388 return (Var emptyP `App` Type ty)
389 dsExpr (ExplicitPArr ty xs) = do
390 singletonP <- dsDPHBuiltin singletonPVar
391 appP <- dsDPHBuiltin appPVar
392 xs' <- mapM dsLExpr xs
393 let unary fn x = mkApps (Var fn) [Type ty, x]
394 binary fn x y = mkApps (Var fn) [Type ty, x, y]
395
396 return . foldr1 (binary appP) $ map (unary singletonP) xs'
397
398 dsExpr (ArithSeq expr witness seq)
399 = case witness of
400 Nothing -> dsArithSeq expr seq
401 Just fl -> do {
402 ; fl' <- dsExpr fl
403 ; newArithSeq <- dsArithSeq expr seq
404 ; return (App fl' newArithSeq)}
405
406 dsExpr (PArrSeq expr (FromTo from to))
407 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
408
409 dsExpr (PArrSeq expr (FromThenTo from thn to))
410 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
411
412 dsExpr (PArrSeq _ _)
413 = panic "DsExpr.dsExpr: Infinite parallel array!"
414 -- the parser shouldn't have generated it and the renamer and typechecker
415 -- shouldn't have let it through
416
417 {-
418 \noindent
419 \underline{\bf Static Pointers}
420 ~~~~~~~~~~~~~~~
421 \begin{verbatim}
422 g = ... static f ...
423 ==>
424 sptEntry:N = StaticPtr
425 (fingerprintString "pkgKey:module.sptEntry:N")
426 (StaticPtrInfo "current pkg key" "current module" "sptEntry:0")
427 f
428 g = ... sptEntry:N
429 \end{verbatim}
430 -}
431
432 dsExpr (HsStatic expr@(L loc _)) = do
433 expr_ds <- dsLExpr expr
434 let ty = exprType expr_ds
435 n' <- mkSptEntryName loc
436 static_binds_var <- dsGetStaticBindsVar
437
438 staticPtrTyCon <- dsLookupTyCon staticPtrTyConName
439 staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
440 staticPtrDataCon <- dsLookupDataCon staticPtrDataConName
441 fingerprintDataCon <- dsLookupDataCon fingerprintDataConName
442
443 dflags <- getDynFlags
444 let (line, col) = case loc of
445 RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
446 , srcLocCol $ realSrcSpanStart r
447 )
448 _ -> (0, 0)
449 srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
450 [ Type intTy , Type intTy
451 , mkIntExprInt dflags line, mkIntExprInt dflags col
452 ]
453 info <- mkConApp staticPtrInfoDataCon <$>
454 (++[srcLoc]) <$>
455 mapM mkStringExprFS
456 [ unitIdFS $ moduleUnitId $ nameModule n'
457 , moduleNameFS $ moduleName $ nameModule n'
458 , occNameFS $ nameOccName n'
459 ]
460 let tvars = tyCoVarsOfTypeWellScoped ty
461 speTy = ASSERT( all isTyVar tvars ) -- ty is top-level, so this is OK
462 mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
463 speId = mkExportedVanillaId n' speTy
464 fp@(Fingerprint w0 w1) = fingerprintName $ idName speId
465 fp_core = mkConApp fingerprintDataCon
466 [ mkWord64LitWordRep dflags w0
467 , mkWord64LitWordRep dflags w1
468 ]
469 sp = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds]
470 liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :)
471 putSrcSpanDs loc $ return $ mkTyApps (Var speId) (mkTyVarTys tvars)
472
473 where
474
475 -- | Choose either 'Word64#' or 'Word#' to represent the arguments of the
476 -- 'Fingerprint' data constructor.
477 mkWord64LitWordRep dflags
478 | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
479 | otherwise = mkWordLit dflags . toInteger
480
481 fingerprintName :: Name -> Fingerprint
482 fingerprintName n = fingerprintString $ unpackFS $ concatFS
483 [ unitIdFS $ moduleUnitId $ nameModule n
484 , fsLit ":"
485 , moduleNameFS (moduleName $ nameModule n)
486 , fsLit "."
487 , occNameFS $ occName n
488 ]
489
490 {-
491 \noindent
492 \underline{\bf Record construction and update}
493 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
494 For record construction we do this (assuming T has three arguments)
495 \begin{verbatim}
496 T { op2 = e }
497 ==>
498 let err = /\a -> recConErr a
499 T (recConErr t1 "M.hs/230/op1")
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 We also handle @C{}@ as valid construction syntax for an unlabelled
510 constructor @C@, setting all of @C@'s fields to bottom.
511 -}
512
513 dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
514 , rcon_con_like = con_like })
515 = do { con_expr' <- dsExpr con_expr
516 ; let
517 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
518 -- A newtype in the corner should be opaque;
519 -- hence TcType.tcSplitFunTys
520
521 mk_arg (arg_ty, fl)
522 = case findField (rec_flds rbinds) (flSelector fl) of
523 (rhs:rhss) -> ASSERT( null rhss )
524 dsLExpr rhs
525 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
526 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
527
528 labels = conLikeFieldLabels con_like
529
530 ; con_args <- if null labels
531 then mapM unlabelled_bottom arg_tys
532 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
533
534 ; return (mkCoreApps con_expr' con_args) }
535
536 {-
537 Record update is a little harder. Suppose we have the decl:
538 \begin{verbatim}
539 data T = T1 {op1, op2, op3 :: Int}
540 | T2 {op4, op2 :: Int}
541 | T3
542 \end{verbatim}
543 Then we translate as follows:
544 \begin{verbatim}
545 r { op2 = e }
546 ===>
547 let op2 = e in
548 case r of
549 T1 op1 _ op3 -> T1 op1 op2 op3
550 T2 op4 _ -> T2 op4 op2
551 other -> recUpdError "M.hs/230"
552 \end{verbatim}
553 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 might do some argument-evaluation first; and may have to throw away some
556 dictionaries.
557
558 Note [Update for GADTs]
559 ~~~~~~~~~~~~~~~~~~~~~~~
560 Consider
561 data T a b where
562 T1 :: { f1 :: a } -> T a Int
563
564 Then the wrapper function for T1 has type
565 $WT1 :: a -> T a Int
566 But if x::T a b, then
567 x { f1 = v } :: T a b (not T a Int!)
568 So we need to cast (T a Int) to (T a b). Sigh.
569
570 -}
571
572 dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
573 , rupd_cons = cons_to_upd
574 , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
575 , rupd_wrap = dict_req_wrap } )
576 | null fields
577 = dsLExpr record_expr
578 | otherwise
579 = ASSERT2( notNull cons_to_upd, ppr expr )
580
581 do { record_expr' <- dsLExpr record_expr
582 ; field_binds' <- mapM ds_field fields
583 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
584 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
585
586 -- It's important to generate the match with matchWrapper,
587 -- and the right hand sides with applications of the wrapper Id
588 -- so that everything works when we are doing fancy unboxing on the
589 -- constructor aguments.
590 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
591 ; ([discrim_var], matching_code)
592 <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
593 , mg_arg_tys = [in_ty]
594 , mg_res_ty = out_ty, mg_origin = FromSource })
595 -- FromSource is not strictly right, but we
596 -- want incomplete pattern-match warnings
597
598 ; return (add_field_binds field_binds' $
599 bindNonRec discrim_var record_expr' matching_code) }
600 where
601 ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
602 -- Clone the Id in the HsRecField, because its Name is that
603 -- of the record selector, and we must not make that a local binder
604 -- else we shadow other uses of the record selector
605 -- Hence 'lcl_id'. Cf Trac #2735
606 ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
607 ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
608 ; lcl_id <- newSysLocalDs (idType fld_id)
609 ; 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
614 -- Awkwardly, for families, the match goes
615 -- from instance type to family type
616 (in_ty, out_ty) =
617 case (head cons_to_upd) of
618 RealDataCon data_con ->
619 let tycon = dataConTyCon data_con in
620 (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
621 PatSynCon pat_syn ->
622 (patSynInstResTy pat_syn in_inst_tys
623 , patSynInstResTy pat_syn out_inst_tys)
624 mk_alt upd_fld_env con
625 = do { let (univ_tvs, ex_tvs, eq_spec,
626 prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
627 subst = mkTopTCvSubst (univ_tvs `zip` in_inst_tys)
628
629 -- I'm not bothering to clone the ex_tvs
630 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
631 ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
632 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
633 ; let field_labels = conLikeFieldLabels con
634 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
635 field_labels arg_ids
636 mk_val_arg fl pat_arg_id
637 = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
638 -- SAFE: the typechecker will complain if the synonym is
639 -- not bidirectional
640 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
643 -- The order here is because of the order in `TcPatSyn`.
644 wrap = dict_req_wrap <.>
645 mkWpEvVarApps theta_vars <.>
646 mkWpTyApps (mkTyVarTys ex_tvs) <.>
647 mkWpTyApps [ ty
648 | (tv, ty) <- univ_tvs `zip` out_inst_tys
649 , not (tv `elemVarEnv` wrap_subst) ]
650 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
651
652 -- Tediously wrap the application in a cast
653 -- Note [Update for GADTs]
654 wrapped_rhs =
655 case con of
656 RealDataCon data_con ->
657 let
658 wrap_co =
659 mkTcTyConAppCo Nominal
660 (dataConTyCon data_con)
661 [ lookup tv ty
662 | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
663 lookup univ_tv ty =
664 case lookupVarEnv wrap_subst univ_tv of
665 Just co' -> co'
666 Nothing -> mkTcReflCo Nominal ty
667 in if null eq_spec
668 then rhs
669 else mkLHsWrap (mkWpCastN wrap_co) rhs
670 -- eq_spec is always null for a PatSynCon
671 PatSynCon _ -> rhs
672
673 wrap_subst =
674 mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
675 | (spec, eq_var) <- eq_spec `zip` eqs_vars
676 , let tv = eqSpecTyVar spec ]
677
678 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
679
680 pat = noLoc $ ConPatOut { pat_con = noLoc con
681 , pat_tvs = ex_tvs
682 , pat_dicts = eqs_vars ++ theta_vars
683 , pat_binds = emptyTcEvBinds
684 , pat_args = PrefixCon $ map nlVarPat arg_ids
685 , pat_arg_tys = in_inst_tys
686 , pat_wrap = req_wrap }
687 ; return (mkSimpleMatch [pat] wrapped_rhs) }
688
689 -- Here is where we desugar the Template Haskell brackets and escapes
690
691 -- Template Haskell stuff
692
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
700 -- Hpc Support
701
702 dsExpr (HsTick tickish e) = do
703 e' <- dsLExpr e
704 return (Tick tickish e')
705
706 -- There is a problem here. The then and else branches
707 -- have no free variables, so they are open to lifting.
708 -- We need someway of stopping this.
709 -- This will make no difference to binary coverage
710 -- (did you go here: YES or NO), but will effect accurate
711 -- tick counting.
712
713 dsExpr (HsBinTick ixT ixF e) = do
714 e2 <- dsLExpr e
715 do { ASSERT(exprType e2 `eqType` boolTy)
716 mkBinaryTickBox ixT ixF e2
717 }
718
719 dsExpr (HsTickPragma _ _ _ expr) = do
720 dflags <- getDynFlags
721 if gopt Opt_Hpc dflags
722 then panic "dsExpr:HsTickPragma"
723 else dsLExpr expr
724
725 -- HsSyn constructs that just shouldn't be here:
726 dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig"
727 dsExpr (HsBracket {}) = panic "dsExpr:HsBracket"
728 dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp"
729 dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm"
730 dsExpr (EWildPat {}) = panic "dsExpr:EWildPat"
731 dsExpr (EAsPat {}) = panic "dsExpr:EAsPat"
732 dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
733 dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"
734 dsExpr (HsType {}) = panic "dsExpr:HsType" -- removed by typechecker
735 dsExpr (HsTypeOut {}) = panic "dsExpr:HsTypeOut" -- handled in HsApp case
736 dsExpr (HsDo {}) = panic "dsExpr:HsDo"
737 dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld"
738
739
740 findField :: [LHsRecField Id arg] -> Name -> [arg]
741 findField rbinds sel
742 = [hsRecFieldArg fld | L _ fld <- rbinds
743 , sel == idName (unLoc $ hsRecFieldId fld) ]
744
745 {-
746 %--------------------------------------------------------------------
747
748 Note [Desugaring explicit lists]
749 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
750 Explicit lists are desugared in a cleverer way to prevent some
751 fruitless allocations. Essentially, whenever we see a list literal
752 [x_1, ..., x_n] we:
753
754 1. Find the tail of the list that can be allocated statically (say
755 [x_k, ..., x_n]) by later stages and ensure we desugar that
756 normally: this makes sure that we don't cause a code size increase
757 by having the cons in that expression fused (see later) and hence
758 being unable to statically allocate any more
759
760 2. For the prefix of the list which cannot be allocated statically,
761 say [x_1, ..., x_(k-1)], we turn it into an expression involving
762 build so that if we find any foldrs over it it will fuse away
763 entirely!
764
765 So in this example we will desugar to:
766 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
767
768 If fusion fails to occur then build will get inlined and (since we
769 defined a RULE for foldr (:) []) we will get back exactly the
770 normal desugaring for an explicit list.
771
772 This optimisation can be worth a lot: up to 25% of the total
773 allocation in some nofib programs. Specifically
774
775 Program Size Allocs Runtime CompTime
776 rewrite +0.0% -26.3% 0.02 -1.8%
777 ansi -0.3% -13.8% 0.00 +0.0%
778 lift +0.0% -8.7% 0.00 -2.3%
779
780 Of course, if rules aren't turned on then there is pretty much no
781 point doing this fancy stuff, and it may even be harmful.
782
783 =======> Note by SLPJ Dec 08.
784
785 I'm unconvinced that we should *ever* generate a build for an explicit
786 list. See the comments in GHC.Base about the foldr/cons rule, which
787 points out that (foldr k z [a,b,c]) may generate *much* less code than
788 (a `k` b `k` c `k` z).
789
790 Furthermore generating builds messes up the LHS of RULES.
791 Example: the foldr/single rule in GHC.Base
792 foldr k z [x] = ...
793 We do not want to generate a build invocation on the LHS of this RULE!
794
795 We fix this by disabling rules in rule LHSs, and testing that
796 flag here; see Note [Desugaring RULE left hand sides] in Desugar
797
798 To test this I've added a (static) flag -fsimple-list-literals, which
799 makes all list literals be generated via the simple route.
800 -}
801
802 dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
803 -> DsM CoreExpr
804 -- See Note [Desugaring explicit lists]
805 dsExplicitList elt_ty Nothing xs
806 = do { dflags <- getDynFlags
807 ; xs' <- mapM dsLExpr xs
808 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
809 ; if gopt Opt_SimpleListLiterals dflags -- -fsimple-list-literals
810 || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
811 -- Don't generate a build if there are no rules to eliminate it!
812 -- See Note [Desugaring RULE left hand sides] in Desugar
813 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
814 then return $ mkListExpr elt_ty xs'
815 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
816 where
817 is_static :: CoreExpr -> Bool
818 is_static e = all is_static_var (varSetElems (exprFreeVars e))
819
820 is_static_var :: Var -> Bool
821 is_static_var v
822 | isId v = isExternalName (idName v) -- Top-level things are given external names
823 | otherwise = False -- Type variables
824
825 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
826 = do { let suffix' = mkListExpr elt_ty suffix
827 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
828 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
829
830 dsExplicitList elt_ty (Just fln) xs
831 = do { fln' <- dsExpr fln
832 ; list <- dsExplicitList elt_ty Nothing xs
833 ; dflags <- getDynFlags
834 ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) }
835
836 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
837 spanTail f xs = (reverse rejected, reverse satisfying)
838 where (satisfying, rejected) = span f $ reverse xs
839
840 dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
841 dsArithSeq expr (From from)
842 = App <$> dsExpr expr <*> dsLExpr from
843 dsArithSeq expr (FromTo from to)
844 = do dflags <- getDynFlags
845 warnAboutEmptyEnumerations dflags from Nothing to
846 expr' <- dsExpr expr
847 from' <- dsLExpr from
848 to' <- dsLExpr to
849 return $ mkApps expr' [from', to']
850 dsArithSeq expr (FromThen from thn)
851 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
852 dsArithSeq expr (FromThenTo from thn to)
853 = do dflags <- getDynFlags
854 warnAboutEmptyEnumerations dflags from (Just thn) to
855 expr' <- dsExpr expr
856 from' <- dsLExpr from
857 thn' <- dsLExpr thn
858 to' <- dsLExpr to
859 return $ mkApps expr' [from', thn', to']
860
861 {-
862 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
863 handled in DsListComp). Basically does the translation given in the
864 Haskell 98 report:
865 -}
866
867 dsDo :: [ExprLStmt Id] -> DsM CoreExpr
868 dsDo stmts
869 = goL stmts
870 where
871 goL [] = panic "dsDo"
872 goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
873
874 go _ (LastStmt body _ _) stmts
875 = ASSERT( null stmts ) dsLExpr body
876 -- The 'return' op isn't used for 'do' expressions
877
878 go _ (BodyStmt rhs then_expr _ _) stmts
879 = do { rhs2 <- dsLExpr rhs
880 ; warnDiscardedDoBindings rhs (exprType rhs2)
881 ; then_expr2 <- dsExpr then_expr
882 ; rest <- goL stmts
883 ; return (mkApps then_expr2 [rhs2, rest]) }
884
885 go _ (LetStmt (L _ binds)) stmts
886 = do { rest <- goL stmts
887 ; dsLocalBinds binds rest }
888
889 go _ (BindStmt pat rhs bind_op fail_op) stmts
890 = do { body <- goL stmts
891 ; rhs' <- dsLExpr rhs
892 ; bind_op' <- dsExpr bind_op
893 ; var <- selectSimpleMatchVarL pat
894 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
895 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
896 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
897 res1_ty (cantFailMatchResult body)
898 ; match_code <- handle_failure pat match fail_op
899 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
900
901 go _ (ApplicativeStmt args mb_join body_ty) stmts
902 = do {
903 let
904 (pats, rhss) = unzip (map (do_arg . snd) args)
905
906 do_arg (ApplicativeArgOne pat expr) =
907 (pat, dsLExpr expr)
908 do_arg (ApplicativeArgMany stmts ret pat) =
909 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
910
911 arg_tys = map hsLPatType pats
912
913 ; rhss' <- sequence rhss
914 ; ops' <- mapM dsExpr (map fst args)
915
916 ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
917
918 ; let fun = L noSrcSpan $ HsLam $
919 MG { mg_alts = noLoc [mkSimpleMatch pats body']
920 , mg_arg_tys = arg_tys
921 , mg_res_ty = body_ty
922 , mg_origin = Generated }
923
924 ; fun' <- dsLExpr fun
925 ; let mk_ap_call l (op,r) = mkApps op [l,r]
926 expr = foldl mk_ap_call fun' (zip ops' rhss')
927 ; case mb_join of
928 Nothing -> return expr
929 Just join_op ->
930 do { join_op' <- dsExpr join_op
931 ; return (App join_op' expr) } }
932
933 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
934 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
935 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
936 , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
937 = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
938 where
939 new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
940 mfix_app bind_op
941 noSyntaxExpr -- Tuple cannot fail
942
943 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
944 tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
945 rec_tup_pats = map nlVarPat tup_ids
946 later_pats = rec_tup_pats
947 rets = map noLoc rec_rets
948 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
949 mfix_arg = noLoc $ HsLam
950 (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body]
951 , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
952 , mg_origin = Generated })
953 mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
954 body = noLoc $ HsDo
955 DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
956 ret_app = nlHsApp (noLoc return_op) (mkBigLHsTupId rets)
957 ret_stmt = noLoc $ mkLastStmt ret_app
958 -- This LastStmt will be desugared with dsDo,
959 -- which ignores the return_op in the LastStmt,
960 -- so we must apply the return_op explicitly
961
962 go _ (ParStmt {}) _ = panic "dsDo ParStmt"
963 go _ (TransStmt {}) _ = panic "dsDo TransStmt"
964
965 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
966 -- In a do expression, pattern-match failure just calls
967 -- the monadic 'fail' rather than throwing an exception
968 handle_failure pat match fail_op
969 | matchCanFail match
970 = do { fail_op' <- dsExpr fail_op
971 ; dflags <- getDynFlags
972 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
973 ; extractMatchResult match (App fail_op' fail_msg) }
974 | otherwise
975 = extractMatchResult match (error "It can't fail")
976
977 mk_fail_msg :: DynFlags -> Located e -> String
978 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
979 showPpr dflags (getLoc pat)
980
981 {-
982 ************************************************************************
983 * *
984 \subsection{Errors and contexts}
985 * *
986 ************************************************************************
987 -}
988
989 -- Warn about certain types of values discarded in monadic bindings (#3263)
990 warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
991 warnDiscardedDoBindings rhs rhs_ty
992 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
993 = do { warn_unused <- woptM Opt_WarnUnusedDoBind
994 ; warn_wrong <- woptM Opt_WarnWrongDoBind
995 ; when (warn_unused || warn_wrong) $
996 do { fam_inst_envs <- dsGetFamInstEnvs
997 ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
998
999 -- Warn about discarding non-() things in 'monadic' binding
1000 ; if warn_unused && not (isUnitTy norm_elt_ty)
1001 then warnDs (badMonadBind rhs elt_ty
1002 (ptext (sLit "-fno-warn-unused-do-bind")))
1003 else
1004
1005 -- Warn about discarding m a things in 'monadic' binding of the same type,
1006 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
1007 when warn_wrong $
1008 do { case tcSplitAppTy_maybe norm_elt_ty of
1009 Just (elt_m_ty, _)
1010 | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
1011 -> warnDs (badMonadBind rhs elt_ty
1012 (ptext (sLit "-fno-warn-wrong-do-bind")))
1013 _ -> return () } } }
1014
1015 | otherwise -- RHS does have type of form (m ty), which is weird
1016 = return () -- but at lesat this warning is irrelevant
1017
1018 badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc
1019 badMonadBind rhs elt_ty flag_doc
1020 = vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type"))
1021 2 (quotes (ppr elt_ty))
1022 , hang (ptext (sLit "Suppress this warning by saying"))
1023 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
1024 , ptext (sLit "or by using the flag") <+> flag_doc ]
1025
1026 {-
1027 ************************************************************************
1028 * *
1029 \subsection{Static pointers}
1030 * *
1031 ************************************************************************
1032 -}
1033
1034 -- | Creates an name for an entry in the Static Pointer Table.
1035 --
1036 -- The name has the form @sptEntry:<N>@ where @<N>@ is generated from a
1037 -- per-module counter.
1038 --
1039 mkSptEntryName :: SrcSpan -> DsM Name
1040 mkSptEntryName loc = do
1041 mod <- getModule
1042 occ <- mkWrapperName "sptEntry"
1043 newGlobalBinder mod occ loc
1044 where
1045 mkWrapperName what
1046 = do dflags <- getDynFlags
1047 thisMod <- getModule
1048 let -- Note [Generating fresh names for ccall wrapper]
1049 -- in compiler/typecheck/TcEnv.hs
1050 wrapperRef = nextWrapperNum dflags
1051 wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
1052 let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
1053 in (extendModuleEnv mod_env thisMod (num+1), num)
1054 return $ mkVarOcc $ what ++ ":" ++ show wrapperNum