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