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
39 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
40 -- needs to see source types
70 %************************************************************************
72 dsLocalBinds, dsValBinds
74 %************************************************************************
77 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
78 dsLocalBinds EmptyLocalBinds body = return body
79 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
80 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
82 -------------------------
83 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
84 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
86 -------------------------
87 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
88 dsIPBinds (IPBinds ip_binds ev_binds) body
89 = do { ds_ev_binds <- dsTcEvBinds ev_binds
90 ; let inner = wrapDsEvBinds ds_ev_binds body
91 -- The dict bindings may not be in
92 -- dependency order; hence Rec
93 ; foldrM ds_ip_bind inner ip_binds }
95 ds_ip_bind (L _ (IPBind n e)) body
97 return (Let (NonRec (ipNameName n) e') body)
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.)
112 = putSrcSpanDs loc (dsStrictBind bind body)
114 -- Ordinary case for bindings; none should be unlifted
115 ds_val_bind (_is_rec, binds) body
116 = do { prs <- dsLHsBinds binds
117 ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
120 _ -> return (Let (Rec prs) body) }
121 -- Use a Rec regardless of is_rec.
122 -- Why? Because it allows the binds to be all
123 -- mixed up, which is what happens in one rare case
124 -- Namely, for an AbsBind with no tyvars and no dicts,
125 -- but which does have dictionary bindings.
126 -- See notes with TcSimplify.inferLoop [NO TYVARS]
127 -- It turned out that wrapping a Rec here was the easiest solution
129 -- NB The previous case dealt with unlifted bindings, so we
130 -- only have to deal with lifted ones now; so Rec is ok
133 dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
134 dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
135 , abs_exports = exports
136 , abs_ev_binds = ev_binds
137 , abs_binds = binds }) body
138 = do { ds_ev_binds <- dsTcEvBinds ev_binds
139 ; let body1 = foldr bind_export body exports
140 bind_export (_, g, l, _) b = bindNonRec g (Var l) b
141 ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
143 ; return (wrapDsEvBinds ds_ev_binds body2) }
145 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
146 , fun_tick = tick, fun_infix = inf }) body
147 -- Can't be a bang pattern (that looks like a PatBind)
148 -- so must be simply unboxed
149 = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
150 ; MASSERT( null args ) -- Functions aren't lifted
151 ; MASSERT( isIdHsWrapper co_fn )
152 ; rhs' <- mkOptTickBox tick rhs
153 ; return (bindNonRec fun rhs' body) }
155 dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
156 = -- let C x# y# = rhs in body
157 -- ==> case rhs of C x# y# -> body
158 do { rhs <- dsGuarded grhss ty
159 ; let upat = unLoc pat
160 eqn = EqnInfo { eqn_pats = [upat],
161 eqn_rhs = cantFailMatchResult body }
162 ; var <- selectMatchVar upat
163 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
164 ; return (scrungleMatch var rhs result) }
166 dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
168 ----------------------
169 strictMatchOnly :: HsBind Id -> Bool
170 strictMatchOnly (AbsBinds { abs_binds = binds })
171 = anyBag (strictMatchOnly . unLoc) binds
172 strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
173 = isUnboxedTupleType ty
175 || any (isUnLiftedType . idType) (collectPatBinders lpat)
176 strictMatchOnly (FunBind { fun_id = L _ id })
177 = isUnLiftedType (idType id)
178 strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact
180 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
181 -- Returns something like (let var = scrut in body)
182 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
183 -- Special case to handle unboxed tuple patterns; they can't appear nested
185 -- case e of (# p1, p2 #) -> rhs
187 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
189 -- let x = e in case x of ....
191 -- But there may be a big
192 -- let fail = ... in case e of ...
193 -- wrapping the whole case, which complicates matters slightly
194 -- It all seems a bit fragile. Test is dsrun013.
196 scrungleMatch var scrut body
197 | isUnboxedTupleType (idType var) = scrungle body
198 | otherwise = bindNonRec var scrut body
200 scrungle (Case (Var x) bndr ty alts)
201 | x == var = Case scrut bndr ty alts
202 scrungle (Let binds body) = Let binds (scrungle body)
203 scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
207 %************************************************************************
209 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
211 %************************************************************************
214 dsLExpr :: LHsExpr Id -> DsM CoreExpr
216 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
218 dsExpr :: HsExpr Id -> DsM CoreExpr
219 dsExpr (HsPar e) = dsLExpr e
220 dsExpr (ExprWithTySigOut e _) = dsLExpr e
221 dsExpr (HsVar var) = return (Var var)
222 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
223 dsExpr (HsLit lit) = dsLit lit
224 dsExpr (HsOverLit lit) = dsOverLit lit
225 dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn
227 ; return (co_fn' e') }
229 dsExpr (NegApp expr neg_expr)
230 = App <$> dsExpr neg_expr <*> dsLExpr expr
232 dsExpr (HsLam a_Match)
233 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
235 dsExpr (HsApp fun arg)
236 = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
239 Operator sections. At first it looks as if we can convert
248 But no! expr might be a redex, and we can lose laziness badly this
253 for example. So we convert instead to
255 let y = expr in \x -> op y x
257 If \tr{expr} is actually just a variable, say, then the simplifier
261 dsExpr (OpApp e1 op _ e2)
262 = -- for the type of y, we need the type of op's 2nd argument
263 mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
265 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
266 = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
268 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
269 dsExpr (SectionR op expr) = do
270 core_op <- dsLExpr op
271 -- for the type of x, we need the type of op's 2nd argument
272 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
273 -- See comment with SectionL
274 y_core <- dsLExpr expr
275 x_id <- newSysLocalDs x_ty
276 y_id <- newSysLocalDs y_ty
277 return (bindNonRec y_id y_core $
278 Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
280 dsExpr (ExplicitTuple tup_args boxity)
281 = do { let go (lam_vars, args) (Missing ty)
282 -- For every missing expression, we need
283 -- another lambda in the desugaring.
284 = do { lam_var <- newSysLocalDs ty
285 ; return (lam_var : lam_vars, Var lam_var : args) }
286 go (lam_vars, args) (Present expr)
287 -- Expressions that are present don't generate
288 -- lambdas, just arguments.
289 = do { core_expr <- dsLExpr expr
290 ; return (lam_vars, core_expr : args) }
292 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
293 -- The reverse is because foldM goes left-to-right
295 ; return $ mkCoreLams lam_vars $
296 mkConApp (tupleCon boxity (length tup_args))
297 (map (Type . exprType) args ++ args) }
299 dsExpr (HsSCC cc expr) = do
300 mod_name <- getModuleDs
301 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
303 dsExpr (HsCoreAnn fs expr)
304 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
306 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
307 | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
308 = -- So desugar empty HsCase to error call
309 mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
312 = do { core_discrim <- dsLExpr discrim
313 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
314 ; return (scrungleMatch discrim_var core_discrim matching_code) }
316 -- Pepe: The binds are in scope in the body but NOT in the binding group
317 -- This is to avoid silliness in breakpoints
318 dsExpr (HsLet binds body) = do
319 body' <- dsLExpr body
320 dsLocalBinds binds body'
322 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
323 -- because the interpretation of `stmts' depends on what sort of thing it is.
325 dsExpr (HsDo ListComp stmts body result_ty)
326 = -- Special case for list comprehensions
327 dsListComp stmts body elt_ty
329 [elt_ty] = tcTyConAppArgs result_ty
331 dsExpr (HsDo DoExpr stmts body result_ty)
332 = dsDo stmts body result_ty
334 dsExpr (HsDo GhciStmt stmts body result_ty)
335 = dsDo stmts body result_ty
337 dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty)
338 = do { (meth_binds, tbl') <- dsSyntaxTable tbl
339 ; core_expr <- dsMDo ctxt tbl' stmts body result_ty
340 ; return (mkLets meth_binds core_expr) }
342 dsExpr (HsDo PArrComp stmts body result_ty)
343 = -- Special case for array comprehensions
344 dsPArrComp (map unLoc stmts) body elt_ty
346 [elt_ty] = tcTyConAppArgs result_ty
348 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
349 = do { pred <- dsLExpr guard_expr
350 ; b1 <- dsLExpr then_expr
351 ; b2 <- dsLExpr else_expr
353 Just fun -> do { core_fun <- dsExpr fun
354 ; return (mkCoreApps core_fun [pred,b1,b2]) }
355 Nothing -> return $ mkIfThenElse pred b1 b2 }
360 \underline{\bf Various data construction things}
361 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363 dsExpr (ExplicitList elt_ty xs)
364 = dsExplicitList elt_ty xs
366 -- We desugar [:x1, ..., xn:] as
367 -- singletonP x1 +:+ ... +:+ singletonP xn
369 dsExpr (ExplicitPArr ty []) = do
370 emptyP <- dsLookupGlobalId emptyPName
371 return (Var emptyP `App` Type ty)
372 dsExpr (ExplicitPArr ty xs) = do
373 singletonP <- dsLookupGlobalId singletonPName
374 appP <- dsLookupGlobalId appPName
375 xs' <- mapM dsLExpr xs
376 return . foldr1 (binary appP) $ map (unary singletonP) xs'
378 unary fn x = mkApps (Var fn) [Type ty, x]
379 binary fn x y = mkApps (Var fn) [Type ty, x, y]
381 dsExpr (ArithSeq expr (From from))
382 = App <$> dsExpr expr <*> dsLExpr from
384 dsExpr (ArithSeq expr (FromTo from to))
385 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
387 dsExpr (ArithSeq expr (FromThen from thn))
388 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
390 dsExpr (ArithSeq expr (FromThenTo from thn to))
391 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
393 dsExpr (PArrSeq expr (FromTo from to))
394 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
396 dsExpr (PArrSeq expr (FromThenTo from thn to))
397 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
400 = panic "DsExpr.dsExpr: Infinite parallel array!"
401 -- the parser shouldn't have generated it and the renamer and typechecker
402 -- shouldn't have let it through
406 \underline{\bf Record construction and update}
407 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
408 For record construction we do this (assuming T has three arguments)
412 let err = /\a -> recConErr a
413 T (recConErr t1 "M.lhs/230/op1")
415 (recConErr t1 "M.lhs/230/op3")
417 @recConErr@ then converts its arugment string into a proper message
418 before printing it as
420 M.lhs, line 230: missing field op1 was evaluated
423 We also handle @C{}@ as valid construction syntax for an unlabelled
424 constructor @C@, setting all of @C@'s fields to bottom.
427 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
428 con_expr' <- dsExpr con_expr
430 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
431 -- A newtype in the corner should be opaque;
432 -- hence TcType.tcSplitFunTys
434 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
435 = case findField (rec_flds rbinds) lbl of
436 (rhs:rhss) -> ASSERT( null rhss )
438 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
439 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
441 labels = dataConFieldLabels (idDataCon data_con_id)
442 -- The data_con_id is guaranteed to be the wrapper id of the constructor
444 con_args <- if null labels
445 then mapM unlabelled_bottom arg_tys
446 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
448 return (mkApps con_expr' con_args)
451 Record update is a little harder. Suppose we have the decl:
453 data T = T1 {op1, op2, op3 :: Int}
454 | T2 {op4, op2 :: Int}
457 Then we translate as follows:
463 T1 op1 _ op3 -> T1 op1 op2 op3
464 T2 op4 _ -> T2 op4 op2
465 other -> recUpdError "M.lhs/230"
467 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
468 RHSs, and do not generate a Core constructor application directly, because the constructor
469 might do some argument-evaluation first; and may have to throw away some
472 Note [Update for GADTs]
473 ~~~~~~~~~~~~~~~~~~~~~~~
476 T1 { f1 :: a } :: T a Int
478 Then the wrapper function for T1 has type
480 But if x::T a b, then
481 x { f1 = v } :: T a b (not T a Int!)
482 So we need to cast (T a Int) to (T a b). Sigh.
485 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
486 cons_to_upd in_inst_tys out_inst_tys)
488 = dsLExpr record_expr
490 = ASSERT2( notNull cons_to_upd, ppr expr )
492 do { record_expr' <- dsLExpr record_expr
493 ; field_binds' <- mapM ds_field fields
494 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
495 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
497 -- It's important to generate the match with matchWrapper,
498 -- and the right hand sides with applications of the wrapper Id
499 -- so that everything works when we are doing fancy unboxing on the
500 -- constructor aguments.
501 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
502 ; ([discrim_var], matching_code)
503 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
505 ; return (add_field_binds field_binds' $
506 bindNonRec discrim_var record_expr' matching_code) }
508 ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
509 -- Clone the Id in the HsRecField, because its Name is that
510 -- of the record selector, and we must not make that a lcoal binder
511 -- else we shadow other uses of the record selector
512 -- Hence 'lcl_id'. Cf Trac #2735
513 ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
514 ; let fld_id = unLoc (hsRecFieldId rec_field)
515 ; lcl_id <- newSysLocalDs (idType fld_id)
516 ; return (idName fld_id, lcl_id, rhs) }
518 add_field_binds [] expr = expr
519 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
521 -- Awkwardly, for families, the match goes
522 -- from instance type to family type
523 tycon = dataConTyCon (head cons_to_upd)
524 in_ty = mkTyConApp tycon in_inst_tys
525 in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
527 mk_alt upd_fld_env con
528 = do { let (univ_tvs, ex_tvs, eq_spec,
529 eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
530 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
532 -- I'm not bothering to clone the ex_tvs
533 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
534 ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
535 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
536 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
537 (dataConFieldLabels con) arg_ids
538 mk_val_arg field_name pat_arg_id
539 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
540 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
541 -- Reconstruct with the WrapId so that unpacking happens
542 wrap = mkWpEvVarApps theta_vars `WpCompose`
543 mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
544 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
545 , isNothing (lookupTyVar wrap_subst tv) ]
546 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
548 -- Tediously wrap the application in a cast
549 -- Note [Update for GADTs]
550 wrapped_rhs | null eq_spec = rhs
551 | otherwise = mkLHsWrap (WpCast wrap_co) rhs
552 wrap_co = mkTyConApp tycon [ lookup tv ty
553 | (tv,ty) <- univ_tvs `zip` out_inst_tys]
554 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
557 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
558 | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
560 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
561 , pat_dicts = eqs_vars ++ theta_vars
562 , pat_binds = emptyTcEvBinds
563 , pat_args = PrefixCon $ map nlVarPat arg_ids
565 ; return (mkSimpleMatch [pat] wrapped_rhs) }
569 Here is where we desugar the Template Haskell brackets and escapes
572 -- Template Haskell stuff
574 #ifdef GHCI /* Only if bootstrapping */
575 dsExpr (HsBracketOut x ps) = dsBracket x ps
576 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
579 -- Arrow notation extension
580 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
586 dsExpr (HsTick ix vars e) = do
590 -- There is a problem here. The then and else branches
591 -- have no free variables, so they are open to lifting.
592 -- We need someway of stopping this.
593 -- This will make no difference to binary coverage
594 -- (did you go here: YES or NO), but will effect accurate
597 dsExpr (HsBinTick ixT ixF e) = do
599 do { ASSERT(exprType e2 `coreEqType` boolTy)
600 mkBinaryTickBox ixT ixF e2
606 -- HsSyn constructs that just shouldn't be here:
607 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
610 findField :: [HsRecField Id arg] -> Name -> [arg]
612 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
613 , lbl == idName (unLoc id) ]
616 %--------------------------------------------------------------------
618 Note [Desugaring explicit lists]
619 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
620 Explicit lists are desugared in a cleverer way to prevent some
621 fruitless allocations. Essentially, whenever we see a list literal
624 1. Find the tail of the list that can be allocated statically (say
625 [x_k, ..., x_n]) by later stages and ensure we desugar that
626 normally: this makes sure that we don't cause a code size increase
627 by having the cons in that expression fused (see later) and hence
628 being unable to statically allocate any more
630 2. For the prefix of the list which cannot be allocated statically,
631 say [x_1, ..., x_(k-1)], we turn it into an expression involving
632 build so that if we find any foldrs over it it will fuse away
635 So in this example we will desugar to:
636 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
638 If fusion fails to occur then build will get inlined and (since we
639 defined a RULE for foldr (:) []) we will get back exactly the
640 normal desugaring for an explicit list.
642 This optimisation can be worth a lot: up to 25% of the total
643 allocation in some nofib programs. Specifically
645 Program Size Allocs Runtime CompTime
646 rewrite +0.0% -26.3% 0.02 -1.8%
647 ansi -0.3% -13.8% 0.00 +0.0%
648 lift +0.0% -8.7% 0.00 -2.3%
650 Of course, if rules aren't turned on then there is pretty much no
651 point doing this fancy stuff, and it may even be harmful.
653 =======> Note by SLPJ Dec 08.
655 I'm unconvinced that we should *ever* generate a build for an explicit
656 list. See the comments in GHC.Base about the foldr/cons rule, which
657 points out that (foldr k z [a,b,c]) may generate *much* less code than
658 (a `k` b `k` c `k` z).
660 Furthermore generating builds messes up the LHS of RULES.
661 Example: the foldr/single rule in GHC.Base
663 We do not want to generate a build invocation on the LHS of this RULE!
665 We fix this by disabling rules in rule LHSs, and testing that
666 flag here; see Note [Desugaring RULE left hand sides] in Desugar
668 To test this I've added a (static) flag -fsimple-list-literals, which
669 makes all list literals be generated via the simple route.
673 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
674 -- See Note [Desugaring explicit lists]
675 dsExplicitList elt_ty xs
676 = do { dflags <- getDOptsDs
677 ; xs' <- mapM dsLExpr xs
678 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
679 ; if opt_SimpleListLiterals -- -fsimple-list-literals
680 || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
681 -- Don't generate a build if there are no rules to eliminate it!
682 -- See Note [Desugaring RULE left hand sides] in Desugar
683 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
684 then return $ mkListExpr elt_ty xs'
685 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
687 is_static :: CoreExpr -> Bool
688 is_static e = all is_static_var (varSetElems (exprFreeVars e))
690 is_static_var :: Var -> Bool
692 | isId v = isExternalName (idName v) -- Top-level things are given external names
693 | otherwise = False -- Type variables
695 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
696 = do { let suffix' = mkListExpr elt_ty suffix
697 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
698 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
700 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
701 spanTail f xs = (reverse rejected, reverse satisfying)
702 where (satisfying, rejected) = span f $ reverse xs
705 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
706 handled in DsListComp). Basically does the translation given in the
712 -> Type -- Type of the whole expression
715 dsDo stmts body result_ty
718 -- result_ty must be of the form (m b)
719 (m_ty, _b_ty) = tcSplitAppTy result_ty
721 goL [] = dsLExpr body
722 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
724 go _ (ExprStmt rhs then_expr _) stmts
725 = do { rhs2 <- dsLExpr rhs
726 ; case tcSplitAppTy_maybe (exprType rhs2) of
727 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
729 ; then_expr2 <- dsExpr then_expr
731 ; return (mkApps then_expr2 [rhs2, rest]) }
733 go _ (LetStmt binds) stmts
734 = do { rest <- goL stmts
735 ; dsLocalBinds binds rest }
737 go _ (BindStmt pat rhs bind_op fail_op) stmts
738 = do { body <- goL stmts
739 ; rhs' <- dsLExpr rhs
740 ; bind_op' <- dsExpr bind_op
741 ; var <- selectSimpleMatchVarL pat
742 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
743 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
744 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
745 res1_ty (cantFailMatchResult body)
746 ; match_code <- handle_failure pat match fail_op
747 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
749 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
750 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
751 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
752 , recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts
753 = ASSERT( length rec_ids > 0 )
754 ASSERT( isEmptyTcEvBinds _ev_binds ) -- No method binds
755 goL (new_bind_stmt : stmts)
757 -- returnE <- dsExpr return_id
758 -- mfixE <- dsExpr mfix_id
759 new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
761 noSyntaxExpr -- Tuple cannot fail
763 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
764 rec_tup_pats = map nlVarPat tup_ids
765 later_pats = rec_tup_pats
766 rets = map noLoc rec_rets
768 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
769 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
770 (mkFunTy tup_ty body_ty))
771 mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
772 body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
773 return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
774 body_ty = mkAppTy m_ty tup_ty
775 tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
777 -- In a do expression, pattern-match failure just calls
778 -- the monadic 'fail' rather than throwing an exception
779 handle_failure pat match fail_op
781 = do { fail_op' <- dsExpr fail_op
782 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
783 ; extractMatchResult match (App fail_op' fail_msg) }
785 = extractMatchResult match (error "It can't fail")
787 mk_fail_msg :: Located e -> String
788 mk_fail_msg pat = "Pattern match failure in do expression at " ++
789 showSDoc (ppr (getLoc pat))
792 Translation for RecStmt's:
793 -----------------------------
794 We turn (RecStmt [v1,..vn] stmts) into:
796 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
800 dsMDo :: HsStmtContext Name
804 -> Type -- Type of the whole expression
807 dsMDo ctxt tbl stmts body result_ty
810 goL [] = dsLExpr body
811 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
813 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
814 mfix_id = lookupEvidence tbl mfixName
815 return_id = lookupEvidence tbl returnMName
816 bind_id = lookupEvidence tbl bindMName
817 then_id = lookupEvidence tbl thenMName
818 fail_id = lookupEvidence tbl failMName
820 go _ (LetStmt binds) stmts
821 = do { rest <- goL stmts
822 ; dsLocalBinds binds rest }
824 go _ (ExprStmt rhs _ rhs_ty) stmts
825 = do { rhs2 <- dsLExpr rhs
826 ; warnDiscardedDoBindings rhs m_ty rhs_ty
828 ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
830 go _ (BindStmt pat rhs _ _) stmts
831 = do { body <- goL stmts
832 ; var <- selectSimpleMatchVarL pat
833 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
834 result_ty (cantFailMatchResult body)
835 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
836 ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
837 ; match_code <- extractMatchResult match fail_expr
839 ; rhs' <- dsLExpr rhs
840 ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
841 rhs', Lam var match_code]) }
843 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
844 , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
845 , recS_dicts = _ev_binds }) stmts
846 = ASSERT( length rec_ids > 0 )
847 ASSERT( length rec_ids == length rec_rets )
848 ASSERT( isEmptyTcEvBinds _ev_binds )
849 pprTrace "dsMDo" (ppr later_ids) $
850 goL (new_bind_stmt : stmts)
852 new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
854 -- Remove the later_ids that appear (without fancy coercions)
855 -- in rec_rets, because there's no need to knot-tie them separately
856 -- See Note [RecStmt] in HsExpr
857 later_ids' = filter (`notElem` mono_rec_ids) later_ids
858 mono_rec_ids = [ id | HsVar id <- rec_rets ]
860 mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
861 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
862 (mkFunTy tup_ty body_ty))
864 -- The rec_tup_pat must bind the rec_ids only; remember that the
865 -- trimmed_laters may share the same Names
866 -- Meanwhile, the later_pats must bind the later_vars
867 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
868 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
869 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
871 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
872 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
873 body_ty = mkAppTy m_ty tup_ty
874 tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
876 return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
877 (mkLHsTupleExpr rets)
879 mk_wild_pat :: Id -> LPat Id
880 mk_wild_pat v = noLoc $ WildPat $ idType v
882 mk_later_pat :: Id -> LPat Id
883 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
884 | otherwise = nlVarPat v
886 mk_tup_pat :: [LPat Id] -> LPat Id
888 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
892 %************************************************************************
894 \subsection{Errors and contexts}
896 %************************************************************************
899 -- Warn about certain types of values discarded in monadic bindings (#3263)
900 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
901 warnDiscardedDoBindings rhs container_ty returning_ty = do {
902 -- Warn about discarding non-() things in 'monadic' binding
903 ; warn_unused <- doptDs Opt_WarnUnusedDoBind
904 ; if warn_unused && not (returning_ty `tcEqType` unitTy)
905 then warnDs (unusedMonadBind rhs returning_ty)
907 -- Warn about discarding m a things in 'monadic' binding of the same type,
908 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
909 ; warn_wrong <- doptDs Opt_WarnWrongDoBind
910 ; case tcSplitAppTy_maybe returning_ty of
911 Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
912 warnDs (wrongMonadBind rhs returning_ty)
915 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
916 unusedMonadBind rhs returning_ty
917 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
918 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
919 ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
921 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
922 wrongMonadBind rhs returning_ty
923 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
924 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
925 ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")