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