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) = do { e' <- dsExpr (unLoc e)
221 ; brak <- dsLookupGlobalId hetmet_brak_name
222 ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] }
223 dsExpr (HsHetMetEsc c t e) = do { e' <- dsExpr (unLoc e)
224 ; esc <- dsLookupGlobalId hetmet_esc_name
225 ; return $ mkApps (Var esc) [ (Type c), (Type t), e'] }
226 dsExpr (HsHetMetCSP c e) = do { e' <- dsExpr (unLoc e)
227 ; csp <- dsLookupGlobalId hetmet_csp_name
228 ; return $ mkApps (Var csp) [ (Type c), (Type $ exprType e'), e'] }
229 dsExpr (ExprWithTySigOut e _) = dsLExpr e
230 dsExpr (HsVar var) = return (Var var)
231 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
232 dsExpr (HsLit lit) = dsLit lit
233 dsExpr (HsOverLit lit) = dsOverLit lit
235 dsExpr (HsWrap co_fn e)
236 = do { co_fn' <- dsHsWrapper co_fn
238 ; warn_id <- doptDs Opt_WarnIdentities
239 ; when warn_id $ warnAboutIdentities e' co_fn'
240 ; return (co_fn' e') }
242 dsExpr (NegApp expr neg_expr)
243 = App <$> dsExpr neg_expr <*> dsLExpr expr
245 dsExpr (HsLam a_Match)
246 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
248 dsExpr (HsApp fun arg)
249 = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
252 Operator sections. At first it looks as if we can convert
261 But no! expr might be a redex, and we can lose laziness badly this
266 for example. So we convert instead to
268 let y = expr in \x -> op y x
270 If \tr{expr} is actually just a variable, say, then the simplifier
274 dsExpr (OpApp e1 op _ e2)
275 = -- for the type of y, we need the type of op's 2nd argument
276 mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
278 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
279 = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
281 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
282 dsExpr (SectionR op expr) = do
283 core_op <- dsLExpr op
284 -- for the type of x, we need the type of op's 2nd argument
285 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
286 -- See comment with SectionL
287 y_core <- dsLExpr expr
288 x_id <- newSysLocalDs x_ty
289 y_id <- newSysLocalDs y_ty
290 return (bindNonRec y_id y_core $
291 Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
293 dsExpr (ExplicitTuple tup_args boxity)
294 = do { let go (lam_vars, args) (Missing ty)
295 -- For every missing expression, we need
296 -- another lambda in the desugaring.
297 = do { lam_var <- newSysLocalDs ty
298 ; return (lam_var : lam_vars, Var lam_var : args) }
299 go (lam_vars, args) (Present expr)
300 -- Expressions that are present don't generate
301 -- lambdas, just arguments.
302 = do { core_expr <- dsLExpr expr
303 ; return (lam_vars, core_expr : args) }
305 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
306 -- The reverse is because foldM goes left-to-right
308 ; return $ mkCoreLams lam_vars $
309 mkConApp (tupleCon boxity (length tup_args))
310 (map (Type . exprType) args ++ args) }
312 dsExpr (HsSCC cc expr) = do
313 mod_name <- getModuleDs
314 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
316 dsExpr (HsCoreAnn fs expr)
317 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
319 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
320 | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
321 = -- So desugar empty HsCase to error call
322 mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
325 = do { core_discrim <- dsLExpr discrim
326 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
327 ; return (scrungleMatch discrim_var core_discrim matching_code) }
329 -- Pepe: The binds are in scope in the body but NOT in the binding group
330 -- This is to avoid silliness in breakpoints
331 dsExpr (HsLet binds body) = do
332 body' <- dsLExpr body
333 dsLocalBinds binds body'
335 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
336 -- because the interpretation of `stmts' depends on what sort of thing it is.
338 dsExpr (HsDo ListComp stmts body result_ty)
339 = -- Special case for list comprehensions
340 dsListComp stmts body elt_ty
342 [elt_ty] = tcTyConAppArgs result_ty
344 dsExpr (HsDo DoExpr stmts body result_ty)
345 = dsDo stmts body result_ty
347 dsExpr (HsDo GhciStmt stmts body result_ty)
348 = dsDo stmts body result_ty
350 dsExpr (HsDo MDoExpr stmts body result_ty)
351 = dsDo stmts body result_ty
353 dsExpr (HsDo PArrComp stmts body result_ty)
354 = -- Special case for array comprehensions
355 dsPArrComp (map unLoc stmts) body elt_ty
357 [elt_ty] = tcTyConAppArgs result_ty
359 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
360 = do { pred <- dsLExpr guard_expr
361 ; b1 <- dsLExpr then_expr
362 ; b2 <- dsLExpr else_expr
364 Just fun -> do { core_fun <- dsExpr fun
365 ; return (mkCoreApps core_fun [pred,b1,b2]) }
366 Nothing -> return $ mkIfThenElse pred b1 b2 }
371 \underline{\bf Various data construction things}
372 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
374 dsExpr (ExplicitList elt_ty xs)
375 = dsExplicitList elt_ty xs
377 -- We desugar [:x1, ..., xn:] as
378 -- singletonP x1 +:+ ... +:+ singletonP xn
380 dsExpr (ExplicitPArr ty []) = do
381 emptyP <- dsLookupDPHId emptyPName
382 return (Var emptyP `App` Type ty)
383 dsExpr (ExplicitPArr ty xs) = do
384 singletonP <- dsLookupDPHId singletonPName
385 appP <- dsLookupDPHId appPName
386 xs' <- mapM dsLExpr xs
387 return . foldr1 (binary appP) $ map (unary singletonP) xs'
389 unary fn x = mkApps (Var fn) [Type ty, x]
390 binary fn x y = mkApps (Var fn) [Type ty, x, y]
392 dsExpr (ArithSeq expr (From from))
393 = App <$> dsExpr expr <*> dsLExpr from
395 dsExpr (ArithSeq expr (FromTo from to))
396 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
398 dsExpr (ArithSeq expr (FromThen from thn))
399 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
401 dsExpr (ArithSeq expr (FromThenTo from thn to))
402 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
404 dsExpr (PArrSeq expr (FromTo from to))
405 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
407 dsExpr (PArrSeq expr (FromThenTo from thn to))
408 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
411 = panic "DsExpr.dsExpr: Infinite parallel array!"
412 -- the parser shouldn't have generated it and the renamer and typechecker
413 -- shouldn't have let it through
417 \underline{\bf Record construction and update}
418 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
419 For record construction we do this (assuming T has three arguments)
423 let err = /\a -> recConErr a
424 T (recConErr t1 "M.lhs/230/op1")
426 (recConErr t1 "M.lhs/230/op3")
428 @recConErr@ then converts its arugment string into a proper message
429 before printing it as
431 M.lhs, line 230: missing field op1 was evaluated
434 We also handle @C{}@ as valid construction syntax for an unlabelled
435 constructor @C@, setting all of @C@'s fields to bottom.
438 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
439 con_expr' <- dsExpr con_expr
441 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
442 -- A newtype in the corner should be opaque;
443 -- hence TcType.tcSplitFunTys
445 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
446 = case findField (rec_flds rbinds) lbl of
447 (rhs:rhss) -> ASSERT( null rhss )
449 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
450 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
452 labels = dataConFieldLabels (idDataCon data_con_id)
453 -- The data_con_id is guaranteed to be the wrapper id of the constructor
455 con_args <- if null labels
456 then mapM unlabelled_bottom arg_tys
457 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
459 return (mkApps con_expr' con_args)
462 Record update is a little harder. Suppose we have the decl:
464 data T = T1 {op1, op2, op3 :: Int}
465 | T2 {op4, op2 :: Int}
468 Then we translate as follows:
474 T1 op1 _ op3 -> T1 op1 op2 op3
475 T2 op4 _ -> T2 op4 op2
476 other -> recUpdError "M.lhs/230"
478 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
479 RHSs, and do not generate a Core constructor application directly, because the constructor
480 might do some argument-evaluation first; and may have to throw away some
483 Note [Update for GADTs]
484 ~~~~~~~~~~~~~~~~~~~~~~~
487 T1 { f1 :: a } :: T a Int
489 Then the wrapper function for T1 has type
491 But if x::T a b, then
492 x { f1 = v } :: T a b (not T a Int!)
493 So we need to cast (T a Int) to (T a b). Sigh.
496 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
497 cons_to_upd in_inst_tys out_inst_tys)
499 = dsLExpr record_expr
501 = ASSERT2( notNull cons_to_upd, ppr expr )
503 do { record_expr' <- dsLExpr record_expr
504 ; field_binds' <- mapM ds_field fields
505 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
506 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
508 -- It's important to generate the match with matchWrapper,
509 -- and the right hand sides with applications of the wrapper Id
510 -- so that everything works when we are doing fancy unboxing on the
511 -- constructor aguments.
512 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
513 ; ([discrim_var], matching_code)
514 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
516 ; return (add_field_binds field_binds' $
517 bindNonRec discrim_var record_expr' matching_code) }
519 ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
520 -- Clone the Id in the HsRecField, because its Name is that
521 -- of the record selector, and we must not make that a lcoal binder
522 -- else we shadow other uses of the record selector
523 -- Hence 'lcl_id'. Cf Trac #2735
524 ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
525 ; let fld_id = unLoc (hsRecFieldId rec_field)
526 ; lcl_id <- newSysLocalDs (idType fld_id)
527 ; return (idName fld_id, lcl_id, rhs) }
529 add_field_binds [] expr = expr
530 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
532 -- Awkwardly, for families, the match goes
533 -- from instance type to family type
534 tycon = dataConTyCon (head cons_to_upd)
535 in_ty = mkTyConApp tycon in_inst_tys
536 in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
538 mk_alt upd_fld_env con
539 = do { let (univ_tvs, ex_tvs, eq_spec,
540 eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
541 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
543 -- I'm not bothering to clone the ex_tvs
544 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
545 ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
546 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
547 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
548 (dataConFieldLabels con) arg_ids
549 mk_val_arg field_name pat_arg_id
550 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
551 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
552 -- Reconstruct with the WrapId so that unpacking happens
553 wrap = mkWpEvVarApps theta_vars `WpCompose`
554 mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
555 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
556 , isNothing (lookupTyVar wrap_subst tv) ]
557 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
559 -- Tediously wrap the application in a cast
560 -- Note [Update for GADTs]
561 wrapped_rhs | null eq_spec = rhs
562 | otherwise = mkLHsWrap (WpCast wrap_co) rhs
563 wrap_co = mkTyConApp tycon [ lookup tv ty
564 | (tv,ty) <- univ_tvs `zip` out_inst_tys]
565 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
568 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
569 | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
571 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
572 , pat_dicts = eqs_vars ++ theta_vars
573 , pat_binds = emptyTcEvBinds
574 , pat_args = PrefixCon $ map nlVarPat arg_ids
576 ; return (mkSimpleMatch [pat] wrapped_rhs) }
580 Here is where we desugar the Template Haskell brackets and escapes
583 -- Template Haskell stuff
585 #ifdef GHCI /* Only if bootstrapping */
586 dsExpr (HsBracketOut x ps) = dsBracket x ps
587 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
590 -- Arrow notation extension
591 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
597 dsExpr (HsTick ix vars e) = do
601 -- There is a problem here. The then and else branches
602 -- have no free variables, so they are open to lifting.
603 -- We need someway of stopping this.
604 -- This will make no difference to binary coverage
605 -- (did you go here: YES or NO), but will effect accurate
608 dsExpr (HsBinTick ixT ixF e) = do
610 do { ASSERT(exprType e2 `coreEqType` boolTy)
611 mkBinaryTickBox ixT ixF e2
617 -- HsSyn constructs that just shouldn't be here:
618 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
621 findField :: [HsRecField Id arg] -> Name -> [arg]
623 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
624 , lbl == idName (unLoc id) ]
627 %--------------------------------------------------------------------
629 Note [Desugaring explicit lists]
630 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
631 Explicit lists are desugared in a cleverer way to prevent some
632 fruitless allocations. Essentially, whenever we see a list literal
635 1. Find the tail of the list that can be allocated statically (say
636 [x_k, ..., x_n]) by later stages and ensure we desugar that
637 normally: this makes sure that we don't cause a code size increase
638 by having the cons in that expression fused (see later) and hence
639 being unable to statically allocate any more
641 2. For the prefix of the list which cannot be allocated statically,
642 say [x_1, ..., x_(k-1)], we turn it into an expression involving
643 build so that if we find any foldrs over it it will fuse away
646 So in this example we will desugar to:
647 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
649 If fusion fails to occur then build will get inlined and (since we
650 defined a RULE for foldr (:) []) we will get back exactly the
651 normal desugaring for an explicit list.
653 This optimisation can be worth a lot: up to 25% of the total
654 allocation in some nofib programs. Specifically
656 Program Size Allocs Runtime CompTime
657 rewrite +0.0% -26.3% 0.02 -1.8%
658 ansi -0.3% -13.8% 0.00 +0.0%
659 lift +0.0% -8.7% 0.00 -2.3%
661 Of course, if rules aren't turned on then there is pretty much no
662 point doing this fancy stuff, and it may even be harmful.
664 =======> Note by SLPJ Dec 08.
666 I'm unconvinced that we should *ever* generate a build for an explicit
667 list. See the comments in GHC.Base about the foldr/cons rule, which
668 points out that (foldr k z [a,b,c]) may generate *much* less code than
669 (a `k` b `k` c `k` z).
671 Furthermore generating builds messes up the LHS of RULES.
672 Example: the foldr/single rule in GHC.Base
674 We do not want to generate a build invocation on the LHS of this RULE!
676 We fix this by disabling rules in rule LHSs, and testing that
677 flag here; see Note [Desugaring RULE left hand sides] in Desugar
679 To test this I've added a (static) flag -fsimple-list-literals, which
680 makes all list literals be generated via the simple route.
684 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
685 -- See Note [Desugaring explicit lists]
686 dsExplicitList elt_ty xs
687 = do { dflags <- getDOptsDs
688 ; xs' <- mapM dsLExpr xs
689 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
690 ; if opt_SimpleListLiterals -- -fsimple-list-literals
691 || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
692 -- Don't generate a build if there are no rules to eliminate it!
693 -- See Note [Desugaring RULE left hand sides] in Desugar
694 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
695 then return $ mkListExpr elt_ty xs'
696 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
698 is_static :: CoreExpr -> Bool
699 is_static e = all is_static_var (varSetElems (exprFreeVars e))
701 is_static_var :: Var -> Bool
703 | isId v = isExternalName (idName v) -- Top-level things are given external names
704 | otherwise = False -- Type variables
706 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
707 = do { let suffix' = mkListExpr elt_ty suffix
708 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
709 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
711 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
712 spanTail f xs = (reverse rejected, reverse satisfying)
713 where (satisfying, rejected) = span f $ reverse xs
716 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
717 handled in DsListComp). Basically does the translation given in the
723 -> Type -- Type of the whole expression
726 dsDo stmts body result_ty
729 -- result_ty must be of the form (m b)
730 (m_ty, _b_ty) = tcSplitAppTy result_ty
732 goL [] = dsLExpr body
733 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
735 go _ (ExprStmt rhs then_expr _) stmts
736 = do { rhs2 <- dsLExpr rhs
737 ; case tcSplitAppTy_maybe (exprType rhs2) of
738 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
740 ; then_expr2 <- dsExpr then_expr
742 ; return (mkApps then_expr2 [rhs2, rest]) }
744 go _ (LetStmt binds) stmts
745 = do { rest <- goL stmts
746 ; dsLocalBinds binds rest }
748 go _ (BindStmt pat rhs bind_op fail_op) stmts
749 = do { body <- goL stmts
750 ; rhs' <- dsLExpr rhs
751 ; bind_op' <- dsExpr bind_op
752 ; var <- selectSimpleMatchVarL pat
753 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
754 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
755 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
756 res1_ty (cantFailMatchResult body)
757 ; match_code <- handle_failure pat match fail_op
758 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
760 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
761 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
762 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
763 , recS_rec_rets = rec_rets }) stmts
764 = ASSERT( length rec_ids > 0 )
765 goL (new_bind_stmt : stmts)
767 -- returnE <- dsExpr return_id
768 -- mfixE <- dsExpr mfix_id
769 new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
771 noSyntaxExpr -- Tuple cannot fail
773 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
774 rec_tup_pats = map nlVarPat tup_ids
775 later_pats = rec_tup_pats
776 rets = map noLoc rec_rets
778 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
779 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
780 (mkFunTy tup_ty body_ty))
781 mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
782 body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
783 return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
784 body_ty = mkAppTy m_ty tup_ty
785 tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
787 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
788 -- In a do expression, pattern-match failure just calls
789 -- the monadic 'fail' rather than throwing an exception
790 handle_failure pat match fail_op
792 = do { fail_op' <- dsExpr fail_op
793 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
794 ; extractMatchResult match (App fail_op' fail_msg) }
796 = extractMatchResult match (error "It can't fail")
798 mk_fail_msg :: Located e -> String
799 mk_fail_msg pat = "Pattern match failure in do expression at " ++
800 showSDoc (ppr (getLoc pat))
803 Translation for RecStmt's:
804 -----------------------------
805 We turn (RecStmt [v1,..vn] stmts) into:
807 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
812 dsMDo :: HsStmtContext Name
816 -> Type -- Type of the whole expression
819 dsMDo ctxt tbl stmts body result_ty
822 goL [] = dsLExpr body
823 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
825 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
826 return_id = lookupEvidence tbl returnMName
827 bind_id = lookupEvidence tbl bindMName
828 then_id = lookupEvidence tbl thenMName
829 fail_id = lookupEvidence tbl failMName
831 go _ (LetStmt binds) stmts
832 = do { rest <- goL stmts
833 ; dsLocalBinds binds rest }
835 go _ (ExprStmt rhs then_expr rhs_ty) stmts
836 = do { rhs2 <- dsLExpr rhs
837 ; warnDiscardedDoBindings rhs m_ty rhs_ty
838 ; then_expr2 <- dsExpr then_expr
840 ; return (mkApps then_expr2 [rhs2, rest]) }
842 go _ (BindStmt pat rhs bind_op _) stmts
843 = do { body <- goL stmts
844 ; rhs' <- dsLExpr rhs
845 ; bind_op' <- dsExpr bind_op
846 ; var <- selectSimpleMatchVarL pat
847 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
848 result_ty (cantFailMatchResult body)
849 ; match_code <- handle_failure pat match fail_op
850 ; return (mkApps bind_op [rhs', Lam var match_code]) }
852 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
853 , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
854 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
855 = ASSERT( length rec_ids > 0 )
856 ASSERT( length rec_ids == length rec_rets )
857 ASSERT( isEmptyTcEvBinds _ev_binds )
858 pprTrace "dsMDo" (ppr later_ids) $
859 goL (new_bind_stmt : stmts)
861 new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
864 -- Remove the later_ids that appear (without fancy coercions)
865 -- in rec_rets, because there's no need to knot-tie them separately
866 -- See Note [RecStmt] in HsExpr
867 later_ids' = filter (`notElem` mono_rec_ids) later_ids
868 mono_rec_ids = [ id | HsVar id <- rec_rets ]
870 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
871 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
872 (mkFunTy tup_ty body_ty))
874 -- The rec_tup_pat must bind the rec_ids only; remember that the
875 -- trimmed_laters may share the same Names
876 -- Meanwhile, the later_pats must bind the later_vars
877 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
878 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
879 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
881 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
882 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
883 body_ty = mkAppTy m_ty tup_ty
884 tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
886 return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
888 mk_wild_pat :: Id -> LPat Id
889 mk_wild_pat v = noLoc $ WildPat $ idType v
891 mk_later_pat :: Id -> LPat Id
892 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
893 | otherwise = nlVarPat v
895 mk_tup_pat :: [LPat Id] -> LPat Id
897 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
902 %************************************************************************
904 Warning about identities
906 %************************************************************************
908 Warn about functions that convert between one type and another
909 when the to- and from- types are the same. Then it's probably
910 (albeit not definitely) the identity
912 warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM ()
913 warnAboutIdentities (Var v) co_fn
914 | idName v `elem` conversionNames
915 , let fun_ty = exprType (co_fn (Var v))
916 , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
917 , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty
918 = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
919 , nest 2 $ ptext (sLit "can probably be omitted")
920 , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
922 warnAboutIdentities _ _ = return ()
924 conversionNames :: [Name]
926 = [ toIntegerName, toRationalName
927 , fromIntegralName, realToFracName ]
928 -- We can't easily add fromIntegerName, fromRationalName,
929 -- becuase they are generated by literals
932 %************************************************************************
934 \subsection{Errors and contexts}
936 %************************************************************************
939 -- Warn about certain types of values discarded in monadic bindings (#3263)
940 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
941 warnDiscardedDoBindings rhs container_ty returning_ty = do {
942 -- Warn about discarding non-() things in 'monadic' binding
943 ; warn_unused <- doptDs Opt_WarnUnusedDoBind
944 ; if warn_unused && not (returning_ty `tcEqType` unitTy)
945 then warnDs (unusedMonadBind rhs returning_ty)
947 -- Warn about discarding m a things in 'monadic' binding of the same type,
948 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
949 ; warn_wrong <- doptDs Opt_WarnWrongDoBind
950 ; case tcSplitAppTy_maybe returning_ty of
951 Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
952 warnDs (wrongMonadBind rhs returning_ty)
955 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
956 unusedMonadBind rhs returning_ty
957 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
958 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
959 ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
961 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
962 wrongMonadBind rhs returning_ty
963 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
964 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
965 ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")