2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Desugaring exporessions.
9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
18 #include "HsVersions.h"
32 -- Template Haskell stuff iff bootstrapped
38 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
39 -- needs to see source types
69 %************************************************************************
71 dsLocalBinds, dsValBinds
73 %************************************************************************
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
81 -------------------------
82 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
83 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
85 -------------------------
86 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
87 dsIPBinds (IPBinds ip_binds ev_binds) body
88 = do { ds_ev_binds <- dsTcEvBinds ev_binds
89 ; let inner = wrapDsEvBinds ds_ev_binds body
90 -- The dict bindings may not be in
91 -- dependency order; hence Rec
92 ; foldrM ds_ip_bind inner ip_binds }
94 ds_ip_bind (L _ (IPBind n e)) body
96 return (Let (NonRec (ipNameName n) e') body)
98 -------------------------
99 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
100 -- Special case for bindings which bind unlifted variables
101 -- We need to do a case right away, rather than building
102 -- a tuple and doing selections.
103 -- Silently ignore INLINE and SPECIALISE pragmas...
104 ds_val_bind (NonRecursive, hsbinds) body
105 | [L loc bind] <- bagToList hsbinds,
106 -- Non-recursive, non-overloaded bindings only come in ones
107 -- ToDo: in some bizarre case it's conceivable that there
108 -- could be dict binds in the 'binds'. (See the notes
109 -- below. Then pattern-match would fail. Urk.)
111 = putSrcSpanDs loc (dsStrictBind bind body)
113 -- Ordinary case for bindings; none should be unlifted
114 ds_val_bind (_is_rec, binds) body
115 = do { prs <- dsLHsBinds binds
116 ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
119 _ -> return (Let (Rec prs) body) }
120 -- Use a Rec regardless of is_rec.
121 -- Why? Because it allows the binds to be all
122 -- mixed up, which is what happens in one rare case
123 -- Namely, for an AbsBind with no tyvars and no dicts,
124 -- but which does have dictionary bindings.
125 -- See notes with TcSimplify.inferLoop [NO TYVARS]
126 -- It turned out that wrapping a Rec here was the easiest solution
128 -- NB The previous case dealt with unlifted bindings, so we
129 -- only have to deal with lifted ones now; so Rec is ok
132 dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
133 dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
134 , abs_exports = exports
135 , abs_ev_binds = ev_binds
136 , abs_binds = binds }) body
137 = do { ds_ev_binds <- dsTcEvBinds ev_binds
138 ; let body1 = foldr bind_export body exports
139 bind_export (_, g, l, _) b = bindNonRec g (Var l) b
140 ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
142 ; return (wrapDsEvBinds ds_ev_binds body2) }
144 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
145 , fun_tick = tick, fun_infix = inf }) body
146 -- Can't be a bang pattern (that looks like a PatBind)
147 -- so must be simply unboxed
148 = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
149 ; MASSERT( null args ) -- Functions aren't lifted
150 ; MASSERT( isIdHsWrapper co_fn )
151 ; rhs' <- mkOptTickBox tick rhs
152 ; return (bindNonRec fun rhs' body) }
154 dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
155 = -- let C x# y# = rhs in body
156 -- ==> case rhs of C x# y# -> body
157 do { rhs <- dsGuarded grhss ty
158 ; let upat = unLoc pat
159 eqn = EqnInfo { eqn_pats = [upat],
160 eqn_rhs = cantFailMatchResult body }
161 ; var <- selectMatchVar upat
162 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
163 ; return (scrungleMatch var rhs result) }
165 dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
167 ----------------------
168 strictMatchOnly :: HsBind Id -> Bool
169 strictMatchOnly (AbsBinds { abs_binds = binds })
170 = anyBag (strictMatchOnly . unLoc) binds
171 strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
172 = isUnboxedTupleType ty
174 || any (isUnLiftedType . idType) (collectPatBinders lpat)
175 strictMatchOnly (FunBind { fun_id = L _ id })
176 = isUnLiftedType (idType id)
177 strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact
179 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
180 -- Returns something like (let var = scrut in body)
181 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
182 -- Special case to handle unboxed tuple patterns; they can't appear nested
184 -- case e of (# p1, p2 #) -> rhs
186 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
188 -- let x = e in case x of ....
190 -- But there may be a big
191 -- let fail = ... in case e of ...
192 -- wrapping the whole case, which complicates matters slightly
193 -- It all seems a bit fragile. Test is dsrun013.
195 scrungleMatch var scrut body
196 | isUnboxedTupleType (idType var) = scrungle body
197 | otherwise = bindNonRec var scrut body
199 scrungle (Case (Var x) bndr ty alts)
200 | x == var = Case scrut bndr ty alts
201 scrungle (Let binds body) = Let binds (scrungle body)
202 scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
206 %************************************************************************
208 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
210 %************************************************************************
213 dsLExpr :: LHsExpr Id -> DsM CoreExpr
215 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
217 dsExpr :: HsExpr Id -> DsM CoreExpr
218 dsExpr (HsPar e) = dsLExpr e
220 dsExpr (HsHetMetBrak c e) =
221 do { e' <- dsExpr (unLoc e)
222 ; brak <- dsLookupGlobalId hetmet_brak_name
223 ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] }
224 dsExpr (HsHetMetEsc c t e) =
225 do { e' <- dsExpr (unLoc e)
226 ; esc <- dsLookupGlobalId hetmet_esc_name
227 ; return $ mkApps (Var esc) [ (Type c), (Type t), e'] }
228 dsExpr (HsKappa a_Match) =
229 do { e' <- dsExpr (HsLam a_Match)
230 ; let ([ua],bc) = tcSplitFunTys (exprType e')
231 ; let (_,[_,a]) = tcSplitAppTys ua
232 ; let (_,[b,c]) = tcSplitAppTys bc
233 ; kap <- dsLookupGlobalId hetmet_kappa_name
234 ; return $ mkApps (Var kap) [ (Type a), (Type b), (Type c), e'] }
235 dsExpr (HsKappaApp e1 e2) =
236 do { e1' <- dsExpr (unLoc e1)
237 ; e2' <- dsExpr (unLoc e2)
238 ; let (_,[_ ,a]) = tcSplitAppTys $ exprType e2'
239 ; let (_,[ab,c]) = tcSplitAppTys $ exprType e1'
240 ; let (_,[a,b]) = tcSplitAppTys $ ab
241 ; kap_app <- dsLookupGlobalId hetmet_kappa_app_name
242 ; return $ mkApps (Var kap_app) [ (Type a), (Type b), (Type c), e1', e2'] }
243 dsExpr (HsHetMetCSP c e) = do { e' <- dsExpr (unLoc e)
244 ; csp <- dsLookupGlobalId hetmet_csp_name
245 ; return $ mkApps (Var csp) [ (Type c), (Type $ exprType e'), e'] }
246 dsExpr (ExprWithTySigOut e _) = dsLExpr e
247 dsExpr (HsVar var) = return (Var var)
248 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
249 dsExpr (HsLit lit) = dsLit lit
250 dsExpr (HsOverLit lit) = dsOverLit lit
252 dsExpr (HsWrap co_fn e)
253 = do { co_fn' <- dsHsWrapper co_fn
255 ; warn_id <- doptDs Opt_WarnIdentities
256 ; when warn_id $ warnAboutIdentities e' co_fn'
257 ; return (co_fn' e') }
259 dsExpr (NegApp expr neg_expr)
260 = App <$> dsExpr neg_expr <*> dsLExpr expr
262 dsExpr (HsLam a_Match)
263 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
265 dsExpr (HsApp fun arg)
266 = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
270 Operator sections. At first it looks as if we can convert
279 But no! expr might be a redex, and we can lose laziness badly this
284 for example. So we convert instead to
286 let y = expr in \x -> op y x
288 If \tr{expr} is actually just a variable, say, then the simplifier
292 dsExpr (OpApp e1 op _ e2)
293 = -- for the type of y, we need the type of op's 2nd argument
294 mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
296 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
297 = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
299 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
300 dsExpr (SectionR op expr) = do
301 core_op <- dsLExpr op
302 -- for the type of x, we need the type of op's 2nd argument
303 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
304 -- See comment with SectionL
305 y_core <- dsLExpr expr
306 x_id <- newSysLocalDs x_ty
307 y_id <- newSysLocalDs y_ty
308 return (bindNonRec y_id y_core $
309 Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
311 dsExpr (ExplicitTuple tup_args boxity)
312 = do { let go (lam_vars, args) (Missing ty)
313 -- For every missing expression, we need
314 -- another lambda in the desugaring.
315 = do { lam_var <- newSysLocalDs ty
316 ; return (lam_var : lam_vars, Var lam_var : args) }
317 go (lam_vars, args) (Present expr)
318 -- Expressions that are present don't generate
319 -- lambdas, just arguments.
320 = do { core_expr <- dsLExpr expr
321 ; return (lam_vars, core_expr : args) }
323 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
324 -- The reverse is because foldM goes left-to-right
326 ; return $ mkCoreLams lam_vars $
327 mkConApp (tupleCon boxity (length tup_args))
328 (map (Type . exprType) args ++ args) }
330 dsExpr (HsSCC cc expr) = do
331 mod_name <- getModuleDs
332 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
334 dsExpr (HsCoreAnn fs expr)
335 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
337 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
338 | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
339 = -- So desugar empty HsCase to error call
340 mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
343 = do { core_discrim <- dsLExpr discrim
344 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
345 ; return (scrungleMatch discrim_var core_discrim matching_code) }
347 -- Pepe: The binds are in scope in the body but NOT in the binding group
348 -- This is to avoid silliness in breakpoints
349 dsExpr (HsLet binds body) = do
350 body' <- dsLExpr body
351 dsLocalBinds binds body'
353 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
354 -- because the interpretation of `stmts' depends on what sort of thing it is.
356 dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
357 dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
358 dsExpr (HsDo DoExpr stmts _) = dsDo stmts
359 dsExpr (HsDo GhciStmt stmts _) = dsDo stmts
360 dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
361 dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
363 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
364 = do { pred <- dsLExpr guard_expr
365 ; b1 <- dsLExpr then_expr
366 ; b2 <- dsLExpr else_expr
368 Just fun -> do { core_fun <- dsExpr fun
369 ; return (mkCoreApps core_fun [pred,b1,b2]) }
370 Nothing -> return $ mkIfThenElse pred b1 b2 }
375 \underline{\bf Various data construction things}
376 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
378 dsExpr (ExplicitList elt_ty xs)
379 = dsExplicitList elt_ty xs
381 -- We desugar [:x1, ..., xn:] as
382 -- singletonP x1 +:+ ... +:+ singletonP xn
384 dsExpr (ExplicitPArr ty []) = do
385 emptyP <- dsLookupDPHId emptyPName
386 return (Var emptyP `App` Type ty)
387 dsExpr (ExplicitPArr ty xs) = do
388 singletonP <- dsLookupDPHId singletonPName
389 appP <- dsLookupDPHId appPName
390 xs' <- mapM dsLExpr xs
391 return . foldr1 (binary appP) $ map (unary singletonP) xs'
393 unary fn x = mkApps (Var fn) [Type ty, x]
394 binary fn x y = mkApps (Var fn) [Type ty, x, y]
396 dsExpr (ArithSeq expr (From from))
397 = App <$> dsExpr expr <*> dsLExpr from
399 dsExpr (ArithSeq expr (FromTo from to))
400 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
402 dsExpr (ArithSeq expr (FromThen from thn))
403 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
405 dsExpr (ArithSeq expr (FromThenTo from thn to))
406 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
408 dsExpr (PArrSeq expr (FromTo from to))
409 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
411 dsExpr (PArrSeq expr (FromThenTo from thn to))
412 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
415 = panic "DsExpr.dsExpr: Infinite parallel array!"
416 -- the parser shouldn't have generated it and the renamer and typechecker
417 -- shouldn't have let it through
421 \underline{\bf Record construction and update}
422 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
423 For record construction we do this (assuming T has three arguments)
427 let err = /\a -> recConErr a
428 T (recConErr t1 "M.lhs/230/op1")
430 (recConErr t1 "M.lhs/230/op3")
432 @recConErr@ then converts its arugment string into a proper message
433 before printing it as
435 M.lhs, line 230: missing field op1 was evaluated
438 We also handle @C{}@ as valid construction syntax for an unlabelled
439 constructor @C@, setting all of @C@'s fields to bottom.
442 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
443 con_expr' <- dsExpr con_expr
445 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
446 -- A newtype in the corner should be opaque;
447 -- hence TcType.tcSplitFunTys
449 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
450 = case findField (rec_flds rbinds) lbl of
451 (rhs:rhss) -> ASSERT( null rhss )
453 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
454 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
456 labels = dataConFieldLabels (idDataCon data_con_id)
457 -- The data_con_id is guaranteed to be the wrapper id of the constructor
459 con_args <- if null labels
460 then mapM unlabelled_bottom arg_tys
461 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
463 return (mkApps con_expr' con_args)
466 Record update is a little harder. Suppose we have the decl:
468 data T = T1 {op1, op2, op3 :: Int}
469 | T2 {op4, op2 :: Int}
472 Then we translate as follows:
478 T1 op1 _ op3 -> T1 op1 op2 op3
479 T2 op4 _ -> T2 op4 op2
480 other -> recUpdError "M.lhs/230"
482 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
483 RHSs, and do not generate a Core constructor application directly, because the constructor
484 might do some argument-evaluation first; and may have to throw away some
487 Note [Update for GADTs]
488 ~~~~~~~~~~~~~~~~~~~~~~~
491 T1 { f1 :: a } :: T a Int
493 Then the wrapper function for T1 has type
495 But if x::T a b, then
496 x { f1 = v } :: T a b (not T a Int!)
497 So we need to cast (T a Int) to (T a b). Sigh.
500 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
501 cons_to_upd in_inst_tys out_inst_tys)
503 = dsLExpr record_expr
505 = ASSERT2( notNull cons_to_upd, ppr expr )
507 do { record_expr' <- dsLExpr record_expr
508 ; field_binds' <- mapM ds_field fields
509 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
510 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
512 -- It's important to generate the match with matchWrapper,
513 -- and the right hand sides with applications of the wrapper Id
514 -- so that everything works when we are doing fancy unboxing on the
515 -- constructor aguments.
516 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
517 ; ([discrim_var], matching_code)
518 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
520 ; return (add_field_binds field_binds' $
521 bindNonRec discrim_var record_expr' matching_code) }
523 ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
524 -- Clone the Id in the HsRecField, because its Name is that
525 -- of the record selector, and we must not make that a lcoal binder
526 -- else we shadow other uses of the record selector
527 -- Hence 'lcl_id'. Cf Trac #2735
528 ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
529 ; let fld_id = unLoc (hsRecFieldId rec_field)
530 ; lcl_id <- newSysLocalDs (idType fld_id)
531 ; return (idName fld_id, lcl_id, rhs) }
533 add_field_binds [] expr = expr
534 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
536 -- Awkwardly, for families, the match goes
537 -- from instance type to family type
538 tycon = dataConTyCon (head cons_to_upd)
539 in_ty = mkTyConApp tycon in_inst_tys
540 in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
542 mk_alt upd_fld_env con
543 = do { let (univ_tvs, ex_tvs, eq_spec,
544 theta, arg_tys, _) = dataConFullSig con
545 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
547 -- I'm not bothering to clone the ex_tvs
548 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
549 ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
550 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
551 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
552 (dataConFieldLabels con) arg_ids
553 mk_val_arg field_name pat_arg_id
554 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
555 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
556 -- Reconstruct with the WrapId so that unpacking happens
557 wrap = mkWpEvVarApps theta_vars `WpCompose`
558 mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
559 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
560 , not (tv `elemVarEnv` wrap_subst) ]
561 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
563 -- Tediously wrap the application in a cast
564 -- Note [Update for GADTs]
565 wrapped_rhs | null eq_spec = rhs
566 | otherwise = mkLHsWrap (WpCast wrap_co) rhs
567 wrap_co = mkTyConAppCo tycon [ lookup tv ty
568 | (tv,ty) <- univ_tvs `zip` out_inst_tys]
569 lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
571 Nothing -> mkReflCo ty
572 wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var))
573 | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
575 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
576 , pat_dicts = eqs_vars ++ theta_vars
577 , pat_binds = emptyTcEvBinds
578 , pat_args = PrefixCon $ map nlVarPat arg_ids
580 ; return (mkSimpleMatch [pat] wrapped_rhs) }
584 Here is where we desugar the Template Haskell brackets and escapes
587 -- Template Haskell stuff
589 #ifdef GHCI /* Only if bootstrapping */
590 dsExpr (HsBracketOut x ps) = dsBracket x ps
591 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
594 -- Arrow notation extension
595 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
601 dsExpr (HsTick ix vars e) = do
605 -- There is a problem here. The then and else branches
606 -- have no free variables, so they are open to lifting.
607 -- We need someway of stopping this.
608 -- This will make no difference to binary coverage
609 -- (did you go here: YES or NO), but will effect accurate
612 dsExpr (HsBinTick ixT ixF e) = do
614 do { ASSERT(exprType e2 `eqType` boolTy)
615 mkBinaryTickBox ixT ixF e2
621 -- HsSyn constructs that just shouldn't be here:
622 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
625 findField :: [HsRecField Id arg] -> Name -> [arg]
627 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
628 , lbl == idName (unLoc id) ]
631 %--------------------------------------------------------------------
633 Note [Desugaring explicit lists]
634 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
635 Explicit lists are desugared in a cleverer way to prevent some
636 fruitless allocations. Essentially, whenever we see a list literal
639 1. Find the tail of the list that can be allocated statically (say
640 [x_k, ..., x_n]) by later stages and ensure we desugar that
641 normally: this makes sure that we don't cause a code size increase
642 by having the cons in that expression fused (see later) and hence
643 being unable to statically allocate any more
645 2. For the prefix of the list which cannot be allocated statically,
646 say [x_1, ..., x_(k-1)], we turn it into an expression involving
647 build so that if we find any foldrs over it it will fuse away
650 So in this example we will desugar to:
651 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
653 If fusion fails to occur then build will get inlined and (since we
654 defined a RULE for foldr (:) []) we will get back exactly the
655 normal desugaring for an explicit list.
657 This optimisation can be worth a lot: up to 25% of the total
658 allocation in some nofib programs. Specifically
660 Program Size Allocs Runtime CompTime
661 rewrite +0.0% -26.3% 0.02 -1.8%
662 ansi -0.3% -13.8% 0.00 +0.0%
663 lift +0.0% -8.7% 0.00 -2.3%
665 Of course, if rules aren't turned on then there is pretty much no
666 point doing this fancy stuff, and it may even be harmful.
668 =======> Note by SLPJ Dec 08.
670 I'm unconvinced that we should *ever* generate a build for an explicit
671 list. See the comments in GHC.Base about the foldr/cons rule, which
672 points out that (foldr k z [a,b,c]) may generate *much* less code than
673 (a `k` b `k` c `k` z).
675 Furthermore generating builds messes up the LHS of RULES.
676 Example: the foldr/single rule in GHC.Base
678 We do not want to generate a build invocation on the LHS of this RULE!
680 We fix this by disabling rules in rule LHSs, and testing that
681 flag here; see Note [Desugaring RULE left hand sides] in Desugar
683 To test this I've added a (static) flag -fsimple-list-literals, which
684 makes all list literals be generated via the simple route.
688 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
689 -- See Note [Desugaring explicit lists]
690 dsExplicitList elt_ty xs
691 = do { dflags <- getDOptsDs
692 ; xs' <- mapM dsLExpr xs
693 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
694 ; if opt_SimpleListLiterals -- -fsimple-list-literals
695 || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
696 -- Don't generate a build if there are no rules to eliminate it!
697 -- See Note [Desugaring RULE left hand sides] in Desugar
698 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
699 then return $ mkListExpr elt_ty xs'
700 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
702 is_static :: CoreExpr -> Bool
703 is_static e = all is_static_var (varSetElems (exprFreeVars e))
705 is_static_var :: Var -> Bool
707 | isId v = isExternalName (idName v) -- Top-level things are given external names
708 | otherwise = False -- Type variables
710 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
711 = do { let suffix' = mkListExpr elt_ty suffix
712 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
713 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
715 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
716 spanTail f xs = (reverse rejected, reverse satisfying)
717 where (satisfying, rejected) = span f $ reverse xs
720 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
721 handled in DsListComp). Basically does the translation given in the
725 dsDo :: [LStmt Id] -> DsM CoreExpr
729 goL [] = panic "dsDo"
730 goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
732 go _ (LastStmt body _) stmts
733 = ASSERT( null stmts ) dsLExpr body
734 -- The 'return' op isn't used for 'do' expressions
736 go _ (ExprStmt rhs then_expr _ _) stmts
737 = do { rhs2 <- dsLExpr rhs
738 ; warnDiscardedDoBindings rhs (exprType rhs2)
739 ; then_expr2 <- dsExpr then_expr
741 ; return (mkApps then_expr2 [rhs2, rest]) }
743 go _ (LetStmt binds) stmts
744 = do { rest <- goL stmts
745 ; dsLocalBinds binds rest }
747 go _ (BindStmt pat rhs bind_op fail_op) stmts
748 = do { body <- goL stmts
749 ; rhs' <- dsLExpr rhs
750 ; bind_op' <- dsExpr bind_op
751 ; var <- selectSimpleMatchVarL pat
752 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
753 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
754 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
755 res1_ty (cantFailMatchResult body)
756 ; match_code <- handle_failure pat match fail_op
757 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
759 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
760 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
761 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
762 , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
763 = ASSERT( length rec_ids > 0 )
764 goL (new_bind_stmt : stmts)
766 new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
768 noSyntaxExpr -- Tuple cannot fail
770 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
771 tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
772 rec_tup_pats = map nlVarPat tup_ids
773 later_pats = rec_tup_pats
774 rets = map noLoc rec_rets
775 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
776 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
777 (mkFunTy tup_ty body_ty))
778 mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
779 body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
780 ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
781 ret_stmt = noLoc $ mkLastStmt ret_app
782 -- This LastStmt will be desugared with dsDo,
783 -- which ignores the return_op in the LastStmt,
784 -- so we must apply the return_op explicitly
786 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
787 -- In a do expression, pattern-match failure just calls
788 -- the monadic 'fail' rather than throwing an exception
789 handle_failure pat match fail_op
791 = do { fail_op' <- dsExpr fail_op
792 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
793 ; extractMatchResult match (App fail_op' fail_msg) }
795 = extractMatchResult match (error "It can't fail")
797 mk_fail_msg :: Located e -> String
798 mk_fail_msg pat = "Pattern match failure in do expression at " ++
799 showSDoc (ppr (getLoc pat))
803 %************************************************************************
805 Warning about identities
807 %************************************************************************
809 Warn about functions that convert between one type and another
810 when the to- and from- types are the same. Then it's probably
811 (albeit not definitely) the identity
813 warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM ()
814 warnAboutIdentities (Var v) co_fn
815 | idName v `elem` conversionNames
816 , let fun_ty = exprType (co_fn (Var v))
817 , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
818 , arg_ty `eqType` res_ty -- So we are converting ty -> ty
819 = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
820 , nest 2 $ ptext (sLit "can probably be omitted")
821 , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
823 warnAboutIdentities _ _ = return ()
825 conversionNames :: [Name]
827 = [ toIntegerName, toRationalName
828 , fromIntegralName, realToFracName ]
829 -- We can't easily add fromIntegerName, fromRationalName,
830 -- becuase they are generated by literals
833 %************************************************************************
835 \subsection{Errors and contexts}
837 %************************************************************************
840 -- Warn about certain types of values discarded in monadic bindings (#3263)
841 warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
842 warnDiscardedDoBindings rhs rhs_ty
843 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
844 = do { -- Warn about discarding non-() things in 'monadic' binding
845 ; warn_unused <- doptDs Opt_WarnUnusedDoBind
846 ; if warn_unused && not (isUnitTy elt_ty)
847 then warnDs (unusedMonadBind rhs elt_ty)
849 -- Warn about discarding m a things in 'monadic' binding of the same type,
850 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
851 do { warn_wrong <- doptDs Opt_WarnWrongDoBind
852 ; case tcSplitAppTy_maybe elt_ty of
853 Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
854 -> warnDs (wrongMonadBind rhs elt_ty)
857 | otherwise -- RHS does have type of form (m ty), which is wierd
858 = return () -- but at lesat this warning is irrelevant
860 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
861 unusedMonadBind rhs elt_ty
862 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
863 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
864 ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
866 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
867 wrongMonadBind rhs elt_ty
868 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
869 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
870 ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")