Refactor visible type application.
[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
12 , dsValBinds, dsLit, dsSyntaxExpr ) where
13
14 #include "HsVersions.h"
15
16 import Match
17 import MatchLit
18 import DsBinds
19 import DsGRHSs
20 import DsListComp
21 import DsUtils
22 import DsArrows
23 import DsMonad
24 import Name
25 import NameEnv
26 import FamInstEnv( topNormaliseType )
27 import DsMeta
28 import HsSyn
29
30 import Platform
31 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
32 -- needs to see source types
33 import TcType
34 import TcEvidence
35 import TcRnMonad
36 import TcHsSyn
37 import Type
38 import CoreSyn
39 import CoreUtils
40 import CoreFVs
41 import MkCore
42
43 import DynFlags
44 import CostCentre
45 import Id
46 import Module
47 import VarSet
48 import ConLike
49 import DataCon
50 import TysWiredIn
51 import PrelNames
52 import BasicTypes
53 import Maybes
54 import VarEnv
55 import SrcLoc
56 import Util
57 import Bag
58 import Outputable
59 import FastString
60 import PatSyn
61
62 import IfaceEnv
63 import Data.IORef ( atomicModifyIORef', modifyIORef )
64
65 import Control.Monad
66 import GHC.Fingerprint
67
68 {-
69 ************************************************************************
70 * *
71 dsLocalBinds, dsValBinds
72 * *
73 ************************************************************************
74 -}
75
76 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
77 dsLocalBinds EmptyLocalBinds body = return body
78 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
79 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
80
81 -------------------------
82 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
83 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
84 dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn"
85
86 -------------------------
87 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
88 dsIPBinds (IPBinds ip_binds ev_binds) body
89 = do { ds_binds <- dsTcEvBinds ev_binds
90 ; let inner = mkCoreLets ds_binds body
91 -- The dict bindings may not be in
92 -- dependency order; hence Rec
93 ; foldrM ds_ip_bind inner ip_binds }
94 where
95 ds_ip_bind (L _ (IPBind ~(Right n) e)) body
96 = do e' <- dsLExpr e
97 return (Let (NonRec n e') body)
98
99 -------------------------
100 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
101 -- Special case for bindings which bind unlifted variables
102 -- We need to do a case right away, rather than building
103 -- a tuple and doing selections.
104 -- Silently ignore INLINE and SPECIALISE pragmas...
105 ds_val_bind (NonRecursive, hsbinds) body
106 | [L loc bind] <- bagToList hsbinds,
107 -- Non-recursive, non-overloaded bindings only come in ones
108 -- ToDo: in some bizarre case it's conceivable that there
109 -- could be dict binds in the 'binds'. (See the notes
110 -- below. Then pattern-match would fail. Urk.)
111 unliftedMatchOnly bind
112 = putSrcSpanDs loc (dsUnliftedBind bind body)
113
114 -- Ordinary case for bindings; none should be unlifted
115 ds_val_bind (_is_rec, binds) body
116 = do { (force_vars,prs) <- dsLHsBinds binds
117 ; let body' = foldr seqVar body force_vars
118 ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
119 case prs of
120 [] -> return body
121 _ -> return (Let (Rec prs) body') }
122 -- Use a Rec regardless of is_rec.
123 -- Why? Because it allows the binds to be all
124 -- mixed up, which is what happens in one rare case
125 -- Namely, for an AbsBind with no tyvars and no dicts,
126 -- but which does have dictionary bindings.
127 -- See notes with TcSimplify.inferLoop [NO TYVARS]
128 -- It turned out that wrapping a Rec here was the easiest solution
129 --
130 -- NB The previous case dealt with unlifted bindings, so we
131 -- only have to deal with lifted ones now; so Rec is ok
132
133 ------------------
134 dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
135 dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
136 , abs_exports = exports
137 , abs_ev_binds = ev_binds
138 , abs_binds = lbinds }) body
139 = do { let body1 = foldr bind_export body exports
140 bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
141 ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
142 body1 lbinds
143 ; ds_binds <- dsTcEvBinds_s ev_binds
144 ; return (mkCoreLets ds_binds body2) }
145
146 dsUnliftedBind (AbsBindsSig { abs_tvs = []
147 , abs_ev_vars = []
148 , abs_sig_export = poly
149 , abs_sig_ev_bind = ev_bind
150 , abs_sig_bind = L _ bind }) body
151 = do { ds_binds <- dsTcEvBinds ev_bind
152 ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
153 ; return (mkCoreLets ds_binds body') }
154
155 dsUnliftedBind (FunBind { fun_id = L _ fun
156 , fun_matches = matches
157 , fun_co_fn = co_fn
158 , fun_tick = tick }) body
159 -- Can't be a bang pattern (that looks like a PatBind)
160 -- so must be simply unboxed
161 = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches
162 ; MASSERT( null args ) -- Functions aren't lifted
163 ; MASSERT( isIdHsWrapper co_fn )
164 ; let rhs' = mkOptTickBox tick rhs
165 ; return (bindNonRec fun rhs' body) }
166
167 dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
168 = -- let C x# y# = rhs in body
169 -- ==> case rhs of C x# y# -> body
170 do { rhs <- dsGuarded grhss ty
171 ; let upat = unLoc pat
172 eqn = EqnInfo { eqn_pats = [upat],
173 eqn_rhs = cantFailMatchResult body }
174 ; var <- selectMatchVar upat
175 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
176 ; return (bindNonRec var rhs result) }
177
178 dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
179
180 ----------------------
181 unliftedMatchOnly :: HsBind Id -> Bool
182 unliftedMatchOnly (AbsBinds { abs_binds = lbinds })
183 = anyBag (unliftedMatchOnly . unLoc) lbinds
184 unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind })
185 = unliftedMatchOnly bind
186 unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
187 = isUnliftedType rhs_ty
188 || isUnliftedLPat lpat
189 || any (isUnliftedType . idType) (collectPatBinders lpat)
190 unliftedMatchOnly (FunBind { fun_id = L _ id })
191 = isUnliftedType (idType id)
192 unliftedMatchOnly _ = False -- I hope! Checked immediately by caller in fact
193
194 {-
195 ************************************************************************
196 * *
197 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
198 * *
199 ************************************************************************
200 -}
201
202 dsLExpr :: LHsExpr Id -> DsM CoreExpr
203
204 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
205
206 dsExpr :: HsExpr Id -> DsM CoreExpr
207 dsExpr (HsPar e) = dsLExpr e
208 dsExpr (ExprWithTySigOut e _) = dsLExpr e
209 dsExpr (HsVar (L _ var)) = return (varToCoreExpr var)
210 -- See Note [Desugaring vars]
211 dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
212 dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
213 dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel"
214 dsExpr (HsLit lit) = dsLit lit
215 dsExpr (HsOverLit lit) = dsOverLit lit
216
217 dsExpr (HsWrap co_fn e)
218 = do { e' <- dsExpr e
219 ; wrapped_e <- dsHsWrapper co_fn e'
220 ; dflags <- getDynFlags
221 ; warnAboutIdentities dflags e' (exprType wrapped_e)
222 ; return wrapped_e }
223
224 dsExpr (NegApp expr neg_expr)
225 = do { expr' <- dsLExpr expr
226 ; dsSyntaxExpr neg_expr [expr'] }
227
228 dsExpr (HsLam a_Match)
229 = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
230
231 dsExpr (HsLamCase arg matches)
232 = do { arg_var <- newSysLocalDs arg
233 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
234 ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
235
236 dsExpr e@(HsApp fun arg)
237 = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
238
239 dsExpr (HsAppTypeOut e _)
240 -- ignore type arguments here; they're in the wrappers instead at this point
241 = dsLExpr e
242
243
244 {-
245 Note [Desugaring vars]
246 ~~~~~~~~~~~~~~~~~~~~~~
247 In one situation we can get a *coercion* variable in a HsVar, namely
248 the support method for an equality superclass:
249 class (a~b) => C a b where ...
250 instance (blah) => C (T a) (T b) where ..
251 Then we get
252 $dfCT :: forall ab. blah => C (T a) (T b)
253 $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
254
255 $c$p1C :: forall ab. blah => (T a ~ T b)
256 $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
257
258 That 'g' in the 'in' part is an evidence variable, and when
259 converting to core it must become a CO.
260
261 Operator sections. At first it looks as if we can convert
262 \begin{verbatim}
263 (expr op)
264 \end{verbatim}
265 to
266 \begin{verbatim}
267 \x -> op expr x
268 \end{verbatim}
269
270 But no! expr might be a redex, and we can lose laziness badly this
271 way. Consider
272 \begin{verbatim}
273 map (expr op) xs
274 \end{verbatim}
275 for example. So we convert instead to
276 \begin{verbatim}
277 let y = expr in \x -> op y x
278 \end{verbatim}
279 If \tr{expr} is actually just a variable, say, then the simplifier
280 will sort it out.
281 -}
282
283 dsExpr e@(OpApp e1 op _ e2)
284 = -- for the type of y, we need the type of op's 2nd argument
285 mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
286
287 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
288 = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr
289
290 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
291 dsExpr e@(SectionR op expr) = do
292 core_op <- dsLExpr op
293 -- for the type of x, we need the type of op's 2nd argument
294 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
295 -- See comment with SectionL
296 y_core <- dsLExpr expr
297 x_id <- newSysLocalDs x_ty
298 y_id <- newSysLocalDs y_ty
299 return (bindNonRec y_id y_core $
300 Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
301
302 dsExpr (ExplicitTuple tup_args boxity)
303 = do { let go (lam_vars, args) (L _ (Missing ty))
304 -- For every missing expression, we need
305 -- another lambda in the desugaring.
306 = do { lam_var <- newSysLocalDs ty
307 ; return (lam_var : lam_vars, Var lam_var : args) }
308 go (lam_vars, args) (L _ (Present expr))
309 -- Expressions that are present don't generate
310 -- lambdas, just arguments.
311 = do { core_expr <- dsLExpr expr
312 ; return (lam_vars, core_expr : args) }
313
314 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
315 -- The reverse is because foldM goes left-to-right
316
317 ; return $ mkCoreLams lam_vars $
318 mkCoreTupBoxity boxity args }
319
320 dsExpr (HsSCC _ cc expr@(L loc _)) = do
321 dflags <- getDynFlags
322 if gopt Opt_SccProfilingOn dflags
323 then do
324 mod_name <- getModule
325 count <- goptM Opt_ProfCountEntries
326 uniq <- newUnique
327 Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
328 <$> dsLExpr expr
329 else dsLExpr expr
330
331 dsExpr (HsCoreAnn _ _ expr)
332 = dsLExpr expr
333
334 dsExpr (HsCase discrim matches)
335 = do { core_discrim <- dsLExpr discrim
336 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
337 ; return (bindNonRec discrim_var core_discrim matching_code) }
338
339 -- Pepe: The binds are in scope in the body but NOT in the binding group
340 -- This is to avoid silliness in breakpoints
341 dsExpr (HsLet (L _ binds) body) = do
342 body' <- dsLExpr body
343 dsLocalBinds binds body'
344
345 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
346 -- because the interpretation of `stmts' depends on what sort of thing it is.
347 --
348 dsExpr (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty
349 dsExpr (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts)
350 dsExpr (HsDo DoExpr (L _ stmts) _) = dsDo stmts
351 dsExpr (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts
352 dsExpr (HsDo MDoExpr (L _ stmts) _) = dsDo stmts
353 dsExpr (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts
354
355 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
356 = do { pred <- dsLExpr guard_expr
357 ; b1 <- dsLExpr then_expr
358 ; b2 <- dsLExpr else_expr
359 ; case mb_fun of
360 Just fun -> dsSyntaxExpr fun [pred, b1, b2]
361 Nothing -> return $ mkIfThenElse pred b1 b2 }
362
363 dsExpr (HsMultiIf res_ty alts)
364 | null alts
365 = mkErrorExpr
366
367 | otherwise
368 = do { match_result <- liftM (foldr1 combineMatchResults)
369 (mapM (dsGRHS IfAlt res_ty) alts)
370 ; error_expr <- mkErrorExpr
371 ; extractMatchResult match_result error_expr }
372 where
373 mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
374 (text "multi-way if")
375
376 {-
377 \noindent
378 \underline{\bf Various data construction things}
379 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
380 -}
381
382 dsExpr (ExplicitList elt_ty wit xs)
383 = dsExplicitList elt_ty wit xs
384
385 -- We desugar [:x1, ..., xn:] as
386 -- singletonP x1 +:+ ... +:+ singletonP xn
387 --
388 dsExpr (ExplicitPArr ty []) = do
389 emptyP <- dsDPHBuiltin emptyPVar
390 return (Var emptyP `App` Type ty)
391 dsExpr (ExplicitPArr ty xs) = do
392 singletonP <- dsDPHBuiltin singletonPVar
393 appP <- dsDPHBuiltin appPVar
394 xs' <- mapM dsLExpr xs
395 let unary fn x = mkApps (Var fn) [Type ty, x]
396 binary fn x y = mkApps (Var fn) [Type ty, x, y]
397
398 return . foldr1 (binary appP) $ map (unary singletonP) xs'
399
400 dsExpr (ArithSeq expr witness seq)
401 = case witness of
402 Nothing -> dsArithSeq expr seq
403 Just fl -> do { newArithSeq <- dsArithSeq expr seq
404 ; dsSyntaxExpr 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 = zipTvSubst univ_tvs 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 (substTysUnchecked 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 = mkWpEvVarApps theta_vars <.>
645 dict_req_wrap <.>
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 (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker
735 dsExpr (HsDo {}) = panic "dsExpr:HsDo"
736 dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld"
737
738 ------------------------------
739 dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
740 dsSyntaxExpr (SyntaxExpr { syn_expr = expr
741 , syn_arg_wraps = arg_wraps
742 , syn_res_wrap = res_wrap })
743 arg_exprs
744 = do { args <- zipWithM dsHsWrapper arg_wraps arg_exprs
745 ; fun <- dsExpr expr
746 ; dsHsWrapper res_wrap $ mkApps fun args }
747
748 findField :: [LHsRecField Id arg] -> Name -> [arg]
749 findField rbinds sel
750 = [hsRecFieldArg fld | L _ fld <- rbinds
751 , sel == idName (unLoc $ hsRecFieldId fld) ]
752
753 {-
754 %--------------------------------------------------------------------
755
756 Note [Desugaring explicit lists]
757 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
758 Explicit lists are desugared in a cleverer way to prevent some
759 fruitless allocations. Essentially, whenever we see a list literal
760 [x_1, ..., x_n] we:
761
762 1. Find the tail of the list that can be allocated statically (say
763 [x_k, ..., x_n]) by later stages and ensure we desugar that
764 normally: this makes sure that we don't cause a code size increase
765 by having the cons in that expression fused (see later) and hence
766 being unable to statically allocate any more
767
768 2. For the prefix of the list which cannot be allocated statically,
769 say [x_1, ..., x_(k-1)], we turn it into an expression involving
770 build so that if we find any foldrs over it it will fuse away
771 entirely!
772
773 So in this example we will desugar to:
774 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
775
776 If fusion fails to occur then build will get inlined and (since we
777 defined a RULE for foldr (:) []) we will get back exactly the
778 normal desugaring for an explicit list.
779
780 This optimisation can be worth a lot: up to 25% of the total
781 allocation in some nofib programs. Specifically
782
783 Program Size Allocs Runtime CompTime
784 rewrite +0.0% -26.3% 0.02 -1.8%
785 ansi -0.3% -13.8% 0.00 +0.0%
786 lift +0.0% -8.7% 0.00 -2.3%
787
788 Of course, if rules aren't turned on then there is pretty much no
789 point doing this fancy stuff, and it may even be harmful.
790
791 =======> Note by SLPJ Dec 08.
792
793 I'm unconvinced that we should *ever* generate a build for an explicit
794 list. See the comments in GHC.Base about the foldr/cons rule, which
795 points out that (foldr k z [a,b,c]) may generate *much* less code than
796 (a `k` b `k` c `k` z).
797
798 Furthermore generating builds messes up the LHS of RULES.
799 Example: the foldr/single rule in GHC.Base
800 foldr k z [x] = ...
801 We do not want to generate a build invocation on the LHS of this RULE!
802
803 We fix this by disabling rules in rule LHSs, and testing that
804 flag here; see Note [Desugaring RULE left hand sides] in Desugar
805
806 To test this I've added a (static) flag -fsimple-list-literals, which
807 makes all list literals be generated via the simple route.
808 -}
809
810 dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
811 -> DsM CoreExpr
812 -- See Note [Desugaring explicit lists]
813 dsExplicitList elt_ty Nothing xs
814 = do { dflags <- getDynFlags
815 ; xs' <- mapM dsLExpr xs
816 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
817 ; if gopt Opt_SimpleListLiterals dflags -- -fsimple-list-literals
818 || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
819 -- Don't generate a build if there are no rules to eliminate it!
820 -- See Note [Desugaring RULE left hand sides] in Desugar
821 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
822 then return $ mkListExpr elt_ty xs'
823 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
824 where
825 is_static :: CoreExpr -> Bool
826 is_static e = all is_static_var (varSetElems (exprFreeVars e))
827
828 is_static_var :: Var -> Bool
829 is_static_var v
830 | isId v = isExternalName (idName v) -- Top-level things are given external names
831 | otherwise = False -- Type variables
832
833 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
834 = do { let suffix' = mkListExpr elt_ty suffix
835 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
836 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
837
838 dsExplicitList elt_ty (Just fln) xs
839 = do { list <- dsExplicitList elt_ty Nothing xs
840 ; dflags <- getDynFlags
841 ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
842
843 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
844 spanTail f xs = (reverse rejected, reverse satisfying)
845 where (satisfying, rejected) = span f $ reverse xs
846
847 dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
848 dsArithSeq expr (From from)
849 = App <$> dsExpr expr <*> dsLExpr from
850 dsArithSeq expr (FromTo from to)
851 = do dflags <- getDynFlags
852 warnAboutEmptyEnumerations dflags from Nothing to
853 expr' <- dsExpr expr
854 from' <- dsLExpr from
855 to' <- dsLExpr to
856 return $ mkApps expr' [from', to']
857 dsArithSeq expr (FromThen from thn)
858 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
859 dsArithSeq expr (FromThenTo from thn to)
860 = do dflags <- getDynFlags
861 warnAboutEmptyEnumerations dflags from (Just thn) to
862 expr' <- dsExpr expr
863 from' <- dsLExpr from
864 thn' <- dsLExpr thn
865 to' <- dsLExpr to
866 return $ mkApps expr' [from', thn', to']
867
868 {-
869 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
870 handled in DsListComp). Basically does the translation given in the
871 Haskell 98 report:
872 -}
873
874 dsDo :: [ExprLStmt Id] -> DsM CoreExpr
875 dsDo stmts
876 = goL stmts
877 where
878 goL [] = panic "dsDo"
879 goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
880
881 go _ (LastStmt body _ _) stmts
882 = ASSERT( null stmts ) dsLExpr body
883 -- The 'return' op isn't used for 'do' expressions
884
885 go _ (BodyStmt rhs then_expr _ _) stmts
886 = do { rhs2 <- dsLExpr rhs
887 ; warnDiscardedDoBindings rhs (exprType rhs2)
888 ; rest <- goL stmts
889 ; dsSyntaxExpr then_expr [rhs2, rest] }
890
891 go _ (LetStmt (L _ binds)) stmts
892 = do { rest <- goL stmts
893 ; dsLocalBinds binds rest }
894
895 go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts
896 = do { body <- goL stmts
897 ; rhs' <- dsLExpr rhs
898 ; var <- selectSimpleMatchVarL pat
899 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
900 res1_ty (cantFailMatchResult body)
901 ; match_code <- handle_failure pat match fail_op
902 ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
903
904 go _ (ApplicativeStmt args mb_join body_ty) stmts
905 = do {
906 let
907 (pats, rhss) = unzip (map (do_arg . snd) args)
908
909 do_arg (ApplicativeArgOne pat expr) =
910 (pat, dsLExpr expr)
911 do_arg (ApplicativeArgMany stmts ret pat) =
912 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
913
914 arg_tys = map hsLPatType pats
915
916 ; rhss' <- sequence rhss
917
918 ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
919
920 ; let fun = L noSrcSpan $ HsLam $
921 MG { mg_alts = noLoc [mkSimpleMatch pats body']
922 , mg_arg_tys = arg_tys
923 , mg_res_ty = body_ty
924 , mg_origin = Generated }
925
926 ; fun' <- dsLExpr fun
927 ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
928 ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
929 ; case mb_join of
930 Nothing -> return expr
931 Just join_op -> dsSyntaxExpr 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_bind_ty = bind_ty
937 , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
938 = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
939 where
940 new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
941 mfix_app bind_op
942 noSyntaxExpr -- Tuple cannot fail
943 bind_ty
944
945 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
946 tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
947 rec_tup_pats = map nlVarPat tup_ids
948 later_pats = rec_tup_pats
949 rets = map noLoc rec_rets
950 mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
951 mfix_arg = noLoc $ HsLam
952 (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body]
953 , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
954 , mg_origin = Generated })
955 mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
956 body = noLoc $ HsDo
957 DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
958 ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
959 ret_stmt = noLoc $ mkLastStmt ret_app
960 -- This LastStmt will be desugared with dsDo,
961 -- which ignores the return_op in the LastStmt,
962 -- so we must apply the return_op explicitly
963
964 go _ (ParStmt {}) _ = panic "dsDo ParStmt"
965 go _ (TransStmt {}) _ = panic "dsDo TransStmt"
966
967 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
968 -- In a do expression, pattern-match failure just calls
969 -- the monadic 'fail' rather than throwing an exception
970 handle_failure pat match fail_op
971 | matchCanFail match
972 = do { dflags <- getDynFlags
973 ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
974 ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
975 ; extractMatchResult match fail_expr }
976 | otherwise
977 = extractMatchResult match (error "It can't fail")
978
979 mk_fail_msg :: DynFlags -> Located e -> String
980 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
981 showPpr dflags (getLoc pat)
982
983 {-
984 ************************************************************************
985 * *
986 \subsection{Errors and contexts}
987 * *
988 ************************************************************************
989 -}
990
991 -- Warn about certain types of values discarded in monadic bindings (#3263)
992 warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
993 warnDiscardedDoBindings rhs rhs_ty
994 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
995 = do { warn_unused <- woptM Opt_WarnUnusedDoBind
996 ; warn_wrong <- woptM Opt_WarnWrongDoBind
997 ; when (warn_unused || warn_wrong) $
998 do { fam_inst_envs <- dsGetFamInstEnvs
999 ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
1000
1001 -- Warn about discarding non-() things in 'monadic' binding
1002 ; if warn_unused && not (isUnitTy norm_elt_ty)
1003 then warnDs (Reason Opt_WarnUnusedDoBind)
1004 (badMonadBind rhs elt_ty)
1005 else
1006
1007 -- Warn about discarding m a things in 'monadic' binding of the same type,
1008 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
1009 when warn_wrong $
1010 do { case tcSplitAppTy_maybe norm_elt_ty of
1011 Just (elt_m_ty, _)
1012 | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
1013 -> warnDs (Reason Opt_WarnWrongDoBind)
1014 (badMonadBind rhs elt_ty)
1015 _ -> return () } } }
1016
1017 | otherwise -- RHS does have type of form (m ty), which is weird
1018 = return () -- but at lesat this warning is irrelevant
1019
1020 badMonadBind :: LHsExpr Id -> Type -> SDoc
1021 badMonadBind rhs elt_ty
1022 = vcat [ hang (text "A do-notation statement discarded a result of type")
1023 2 (quotes (ppr elt_ty))
1024 , hang (text "Suppress this warning by saying")
1025 2 (quotes $ text "_ <-" <+> ppr rhs)
1026 ]
1027
1028 {-
1029 ************************************************************************
1030 * *
1031 \subsection{Static pointers}
1032 * *
1033 ************************************************************************
1034 -}
1035
1036 -- | Creates an name for an entry in the Static Pointer Table.
1037 --
1038 -- The name has the form @sptEntry:<N>@ where @<N>@ is generated from a
1039 -- per-module counter.
1040 --
1041 mkSptEntryName :: SrcSpan -> DsM Name
1042 mkSptEntryName loc = do
1043 mod <- getModule
1044 occ <- mkWrapperName "sptEntry"
1045 newGlobalBinder mod occ loc
1046 where
1047 mkWrapperName what
1048 = do dflags <- getDynFlags
1049 thisMod <- getModule
1050 let -- Note [Generating fresh names for ccall wrapper]
1051 -- in compiler/typecheck/TcEnv.hs
1052 wrapperRef = nextWrapperNum dflags
1053 wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
1054 let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
1055 in (extendModuleEnv mod_env thisMod (num+1), num)
1056 return $ mkVarOcc $ what ++ ":" ++ show wrapperNum