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
71 %************************************************************************
73 dsLocalBinds, dsValBinds
75 %************************************************************************
78 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
79 dsLocalBinds EmptyLocalBinds body = return body
80 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
81 dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
83 -------------------------
84 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
85 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
87 -------------------------
88 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
89 dsIPBinds (IPBinds ip_binds ev_binds) body
90 = do { ds_ev_binds <- dsTcEvBinds ev_binds
91 ; let inner = wrapDsEvBinds ds_ev_binds body
92 -- The dict bindings may not be in
93 -- dependency order; hence Rec
94 ; foldrM ds_ip_bind inner ip_binds }
96 ds_ip_bind (L _ (IPBind n e)) body
98 return (Let (NonRec (ipNameName n) e') body)
100 -------------------------
101 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
102 -- Special case for bindings which bind unlifted variables
103 -- We need to do a case right away, rather than building
104 -- a tuple and doing selections.
105 -- Silently ignore INLINE and SPECIALISE pragmas...
106 ds_val_bind (NonRecursive, hsbinds) body
107 | [L loc bind] <- bagToList hsbinds,
108 -- Non-recursive, non-overloaded bindings only come in ones
109 -- ToDo: in some bizarre case it's conceivable that there
110 -- could be dict binds in the 'binds'. (See the notes
111 -- below. Then pattern-match would fail. Urk.)
113 = putSrcSpanDs loc (dsStrictBind bind body)
115 -- Ordinary case for bindings; none should be unlifted
116 ds_val_bind (_is_rec, binds) body
117 = do { prs <- dsLHsBinds binds
118 ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
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
130 -- NB The previous case dealt with unlifted bindings, so we
131 -- only have to deal with lifted ones now; so Rec is ok
134 dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
135 dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
136 , abs_exports = exports
137 , abs_ev_binds = ev_binds
138 , abs_binds = binds }) body
139 = do { ds_ev_binds <- dsTcEvBinds ev_binds
140 ; let body1 = foldr bind_export body exports
141 bind_export (_, g, l, _) b = bindNonRec g (Var l) b
142 ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
144 ; return (wrapDsEvBinds ds_ev_binds body2) }
146 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
147 , fun_tick = tick, fun_infix = inf }) body
148 -- Can't be a bang pattern (that looks like a PatBind)
149 -- so must be simply unboxed
150 = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
151 ; MASSERT( null args ) -- Functions aren't lifted
152 ; MASSERT( isIdHsWrapper co_fn )
153 ; rhs' <- mkOptTickBox tick rhs
154 ; return (bindNonRec fun rhs' body) }
156 dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
157 = -- let C x# y# = rhs in body
158 -- ==> case rhs of C x# y# -> body
159 do { rhs <- dsGuarded grhss ty
160 ; let upat = unLoc pat
161 eqn = EqnInfo { eqn_pats = [upat],
162 eqn_rhs = cantFailMatchResult body }
163 ; var <- selectMatchVar upat
164 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
165 ; return (scrungleMatch var rhs result) }
167 dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
169 ----------------------
170 strictMatchOnly :: HsBind Id -> Bool
171 strictMatchOnly (AbsBinds { abs_binds = binds })
172 = anyBag (strictMatchOnly . unLoc) binds
173 strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
174 = isUnboxedTupleType ty
176 || any (isUnLiftedType . idType) (collectPatBinders lpat)
177 strictMatchOnly (FunBind { fun_id = L _ id })
178 = isUnLiftedType (idType id)
179 strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact
181 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
182 -- Returns something like (let var = scrut in body)
183 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
184 -- Special case to handle unboxed tuple patterns; they can't appear nested
186 -- case e of (# p1, p2 #) -> rhs
188 -- case e of (# x1, x2 #) -> ... match p1, p2 ...
190 -- let x = e in case x of ....
192 -- But there may be a big
193 -- let fail = ... in case e of ...
194 -- wrapping the whole case, which complicates matters slightly
195 -- It all seems a bit fragile. Test is dsrun013.
197 scrungleMatch var scrut body
198 | isUnboxedTupleType (idType var) = scrungle body
199 | otherwise = bindNonRec var scrut body
201 scrungle (Case (Var x) bndr ty alts)
202 | x == var = Case scrut bndr ty alts
203 scrungle (Let binds body) = Let binds (scrungle body)
204 scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
208 %************************************************************************
210 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
212 %************************************************************************
215 dsLExpr :: LHsExpr Id -> DsM CoreExpr
217 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
219 dsExpr :: HsExpr Id -> DsM CoreExpr
220 dsExpr (HsPar e) = dsLExpr e
221 dsExpr (ExprWithTySigOut e _) = dsLExpr e
222 dsExpr (HsVar var) = return (Var var)
223 dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
224 dsExpr (HsLit lit) = dsLit lit
225 dsExpr (HsOverLit lit) = dsOverLit lit
226 dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn
228 ; return (co_fn' e') }
230 dsExpr (NegApp expr neg_expr)
231 = App <$> dsExpr neg_expr <*> dsLExpr expr
233 dsExpr (HsLam a_Match)
234 = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
236 dsExpr (HsApp fun arg)
237 = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
240 Operator sections. At first it looks as if we can convert
249 But no! expr might be a redex, and we can lose laziness badly this
254 for example. So we convert instead to
256 let y = expr in \x -> op y x
258 If \tr{expr} is actually just a variable, say, then the simplifier
262 dsExpr (OpApp e1 op _ e2)
263 = -- for the type of y, we need the type of op's 2nd argument
264 mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
266 dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)
267 = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
269 -- dsLExpr (SectionR op expr) -- \ x -> op x expr
270 dsExpr (SectionR op expr) = do
271 core_op <- dsLExpr op
272 -- for the type of x, we need the type of op's 2nd argument
273 let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
274 -- See comment with SectionL
275 y_core <- dsLExpr expr
276 x_id <- newSysLocalDs x_ty
277 y_id <- newSysLocalDs y_ty
278 return (bindNonRec y_id y_core $
279 Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
281 dsExpr (ExplicitTuple tup_args boxity)
282 = do { let go (lam_vars, args) (Missing ty)
283 -- For every missing expression, we need
284 -- another lambda in the desugaring.
285 = do { lam_var <- newSysLocalDs ty
286 ; return (lam_var : lam_vars, Var lam_var : args) }
287 go (lam_vars, args) (Present expr)
288 -- Expressions that are present don't generate
289 -- lambdas, just arguments.
290 = do { core_expr <- dsLExpr expr
291 ; return (lam_vars, core_expr : args) }
293 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
294 -- The reverse is because foldM goes left-to-right
296 ; return $ mkCoreLams lam_vars $
297 mkConApp (tupleCon boxity (length tup_args))
298 (map (Type . exprType) args ++ args) }
300 dsExpr (HsSCC cc expr) = do
301 mod_name <- getModuleDs
302 Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
304 dsExpr (HsCoreAnn fs expr)
305 = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
307 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
308 | isEmptyMatchGroup matches -- A Core 'case' is always non-empty
309 = -- So desugar empty HsCase to error call
310 mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
313 = do { core_discrim <- dsLExpr discrim
314 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
315 ; return (scrungleMatch discrim_var core_discrim matching_code) }
317 -- Pepe: The binds are in scope in the body but NOT in the binding group
318 -- This is to avoid silliness in breakpoints
319 dsExpr (HsLet binds body) = do
320 body' <- dsLExpr body
321 dsLocalBinds binds body'
323 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
324 -- because the interpretation of `stmts' depends on what sort of thing it is.
326 dsExpr (HsDo ListComp stmts body result_ty)
327 = -- Special case for list comprehensions
328 dsListComp stmts body elt_ty
330 [elt_ty] = tcTyConAppArgs result_ty
332 dsExpr (HsDo DoExpr stmts body result_ty)
333 = dsDo stmts body result_ty
335 dsExpr (HsDo GhciStmt stmts body result_ty)
336 = dsDo stmts body result_ty
338 dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty)
339 = do { (meth_binds, tbl') <- dsSyntaxTable tbl
340 ; core_expr <- dsMDo ctxt tbl' stmts body result_ty
341 ; return (mkLets meth_binds core_expr) }
343 dsExpr (HsDo PArrComp stmts body result_ty)
344 = -- Special case for array comprehensions
345 dsPArrComp (map unLoc stmts) body elt_ty
347 [elt_ty] = tcTyConAppArgs result_ty
349 dsExpr (HsIf guard_expr then_expr else_expr)
350 = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
355 \underline{\bf Various data construction things}
356 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
358 dsExpr (ExplicitList elt_ty xs)
359 = dsExplicitList elt_ty xs
361 -- We desugar [:x1, ..., xn:] as
362 -- singletonP x1 +:+ ... +:+ singletonP xn
364 dsExpr (ExplicitPArr ty []) = do
365 emptyP <- dsLookupGlobalId emptyPName
366 return (Var emptyP `App` Type ty)
367 dsExpr (ExplicitPArr ty xs) = do
368 singletonP <- dsLookupGlobalId singletonPName
369 appP <- dsLookupGlobalId appPName
370 xs' <- mapM dsLExpr xs
371 return . foldr1 (binary appP) $ map (unary singletonP) xs'
373 unary fn x = mkApps (Var fn) [Type ty, x]
374 binary fn x y = mkApps (Var fn) [Type ty, x, y]
376 dsExpr (ArithSeq expr (From from))
377 = App <$> dsExpr expr <*> dsLExpr from
379 dsExpr (ArithSeq expr (FromTo from to))
380 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
382 dsExpr (ArithSeq expr (FromThen from thn))
383 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
385 dsExpr (ArithSeq expr (FromThenTo from thn to))
386 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
388 dsExpr (PArrSeq expr (FromTo from to))
389 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
391 dsExpr (PArrSeq expr (FromThenTo from thn to))
392 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
395 = panic "DsExpr.dsExpr: Infinite parallel array!"
396 -- the parser shouldn't have generated it and the renamer and typechecker
397 -- shouldn't have let it through
401 \underline{\bf Record construction and update}
402 % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
403 For record construction we do this (assuming T has three arguments)
407 let err = /\a -> recConErr a
408 T (recConErr t1 "M.lhs/230/op1")
410 (recConErr t1 "M.lhs/230/op3")
412 @recConErr@ then converts its arugment string into a proper message
413 before printing it as
415 M.lhs, line 230: missing field op1 was evaluated
418 We also handle @C{}@ as valid construction syntax for an unlabelled
419 constructor @C@, setting all of @C@'s fields to bottom.
422 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
423 con_expr' <- dsExpr con_expr
425 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
426 -- A newtype in the corner should be opaque;
427 -- hence TcType.tcSplitFunTys
429 mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
430 = case findField (rec_flds rbinds) lbl of
431 (rhs:rhss) -> ASSERT( null rhss )
433 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
434 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
436 labels = dataConFieldLabels (idDataCon data_con_id)
437 -- The data_con_id is guaranteed to be the wrapper id of the constructor
439 con_args <- if null labels
440 then mapM unlabelled_bottom arg_tys
441 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
443 return (mkApps con_expr' con_args)
446 Record update is a little harder. Suppose we have the decl:
448 data T = T1 {op1, op2, op3 :: Int}
449 | T2 {op4, op2 :: Int}
452 Then we translate as follows:
458 T1 op1 _ op3 -> T1 op1 op2 op3
459 T2 op4 _ -> T2 op4 op2
460 other -> recUpdError "M.lhs/230"
462 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
463 RHSs, and do not generate a Core constructor application directly, because the constructor
464 might do some argument-evaluation first; and may have to throw away some
467 Note [Update for GADTs]
468 ~~~~~~~~~~~~~~~~~~~~~~~
471 T1 { f1 :: a } :: T a Int
473 Then the wrapper function for T1 has type
475 But if x::T a b, then
476 x { f1 = v } :: T a b (not T a Int!)
477 So we need to cast (T a Int) to (T a b). Sigh.
480 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
481 cons_to_upd in_inst_tys out_inst_tys)
483 = dsLExpr record_expr
485 = ASSERT2( notNull cons_to_upd, ppr expr )
487 do { record_expr' <- dsLExpr record_expr
488 ; field_binds' <- mapM ds_field fields
489 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
490 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
492 -- It's important to generate the match with matchWrapper,
493 -- and the right hand sides with applications of the wrapper Id
494 -- so that everything works when we are doing fancy unboxing on the
495 -- constructor aguments.
496 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
497 ; ([discrim_var], matching_code)
498 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
500 ; return (add_field_binds field_binds' $
501 bindNonRec discrim_var record_expr' matching_code) }
503 ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
504 -- Clone the Id in the HsRecField, because its Name is that
505 -- of the record selector, and we must not make that a lcoal binder
506 -- else we shadow other uses of the record selector
507 -- Hence 'lcl_id'. Cf Trac #2735
508 ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
509 ; let fld_id = unLoc (hsRecFieldId rec_field)
510 ; lcl_id <- newSysLocalDs (idType fld_id)
511 ; return (idName fld_id, lcl_id, rhs) }
513 add_field_binds [] expr = expr
514 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
516 -- Awkwardly, for families, the match goes
517 -- from instance type to family type
518 tycon = dataConTyCon (head cons_to_upd)
519 in_ty = mkTyConApp tycon in_inst_tys
520 in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
522 mk_alt upd_fld_env con
523 = do { let (univ_tvs, ex_tvs, eq_spec,
524 eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
525 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
527 -- I'm not bothering to clone the ex_tvs
528 ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
529 ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
530 ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
531 ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
532 (dataConFieldLabels con) arg_ids
533 mk_val_arg field_name pat_arg_id
534 = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
535 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
536 -- Reconstruct with the WrapId so that unpacking happens
537 wrap = mkWpEvVarApps theta_vars `WpCompose`
538 mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
539 mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
540 , isNothing (lookupTyVar wrap_subst tv) ]
541 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
543 -- Tediously wrap the application in a cast
544 -- Note [Update for GADTs]
545 wrapped_rhs | null eq_spec = rhs
546 | otherwise = mkLHsWrap (WpCast wrap_co) rhs
547 wrap_co = mkTyConApp tycon [ lookup tv ty
548 | (tv,ty) <- univ_tvs `zip` out_inst_tys]
549 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
552 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
553 | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
555 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
556 , pat_dicts = eqs_vars ++ theta_vars
557 , pat_binds = emptyTcEvBinds
558 , pat_args = PrefixCon $ map nlVarPat arg_ids
560 ; return (mkSimpleMatch [pat] wrapped_rhs) }
564 Here is where we desugar the Template Haskell brackets and escapes
567 -- Template Haskell stuff
569 #ifdef GHCI /* Only if bootstrapping */
570 dsExpr (HsBracketOut x ps) = dsBracket x ps
571 dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s)
574 -- Arrow notation extension
575 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
581 dsExpr (HsTick ix vars e) = do
585 -- There is a problem here. The then and else branches
586 -- have no free variables, so they are open to lifting.
587 -- We need someway of stopping this.
588 -- This will make no difference to binary coverage
589 -- (did you go here: YES or NO), but will effect accurate
592 dsExpr (HsBinTick ixT ixF e) = do
594 do { ASSERT(exprType e2 `coreEqType` boolTy)
595 mkBinaryTickBox ixT ixF e2
601 -- HsSyn constructs that just shouldn't be here:
602 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
605 findField :: [HsRecField Id arg] -> Name -> [arg]
607 = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
608 , lbl == idName (unLoc id) ]
611 %--------------------------------------------------------------------
613 Note [Desugaring explicit lists]
614 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
615 Explicit lists are desugared in a cleverer way to prevent some
616 fruitless allocations. Essentially, whenever we see a list literal
619 1. Find the tail of the list that can be allocated statically (say
620 [x_k, ..., x_n]) by later stages and ensure we desugar that
621 normally: this makes sure that we don't cause a code size increase
622 by having the cons in that expression fused (see later) and hence
623 being unable to statically allocate any more
625 2. For the prefix of the list which cannot be allocated statically,
626 say [x_1, ..., x_(k-1)], we turn it into an expression involving
627 build so that if we find any foldrs over it it will fuse away
630 So in this example we will desugar to:
631 build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
633 If fusion fails to occur then build will get inlined and (since we
634 defined a RULE for foldr (:) []) we will get back exactly the
635 normal desugaring for an explicit list.
637 This optimisation can be worth a lot: up to 25% of the total
638 allocation in some nofib programs. Specifically
640 Program Size Allocs Runtime CompTime
641 rewrite +0.0% -26.3% 0.02 -1.8%
642 ansi -0.3% -13.8% 0.00 +0.0%
643 lift +0.0% -8.7% 0.00 -2.3%
645 Of course, if rules aren't turned on then there is pretty much no
646 point doing this fancy stuff, and it may even be harmful.
648 =======> Note by SLPJ Dec 08.
650 I'm unconvinced that we should *ever* generate a build for an explicit
651 list. See the comments in GHC.Base about the foldr/cons rule, which
652 points out that (foldr k z [a,b,c]) may generate *much* less code than
653 (a `k` b `k` c `k` z).
655 Furthermore generating builds messes up the LHS of RULES.
656 Example: the foldr/single rule in GHC.Base
658 We do not want to generate a build invocation on the LHS of this RULE!
660 We fix this by disabling rules in rule LHSs, and testing that
661 flag here; see Note [Desugaring RULE left hand sides] in Desugar
663 To test this I've added a (static) flag -fsimple-list-literals, which
664 makes all list literals be generated via the simple route.
668 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
669 -- See Note [Desugaring explicit lists]
670 dsExplicitList elt_ty xs
671 = do { dflags <- getDOptsDs
672 ; xs' <- mapM dsLExpr xs
673 ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
674 ; if opt_SimpleListLiterals -- -fsimple-list-literals
675 || not (dopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
676 -- Don't generate a build if there are no rules to eliminate it!
677 -- See Note [Desugaring RULE left hand sides] in Desugar
678 || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!
679 then return $ mkListExpr elt_ty xs'
680 else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
682 is_static :: CoreExpr -> Bool
683 is_static e = all is_static_var (varSetElems (exprFreeVars e))
685 is_static_var :: Var -> Bool
687 | isId v = isExternalName (idName v) -- Top-level things are given external names
688 | otherwise = False -- Type variables
690 mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
691 = do { let suffix' = mkListExpr elt_ty suffix
692 ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
693 ; return (foldr (App . App (Var c)) folded_suffix prefix) }
695 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
696 spanTail f xs = (reverse rejected, reverse satisfying)
697 where (satisfying, rejected) = span f $ reverse xs
700 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
701 handled in DsListComp). Basically does the translation given in the
707 -> Type -- Type of the whole expression
710 dsDo stmts body result_ty
713 -- result_ty must be of the form (m b)
714 (m_ty, _b_ty) = tcSplitAppTy result_ty
716 goL [] = dsLExpr body
717 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
719 go _ (ExprStmt rhs then_expr _) stmts
720 = do { rhs2 <- dsLExpr rhs
721 ; case tcSplitAppTy_maybe (exprType rhs2) of
722 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
724 ; then_expr2 <- dsExpr then_expr
726 ; return (mkApps then_expr2 [rhs2, rest]) }
728 go _ (LetStmt binds) stmts
729 = do { rest <- goL stmts
730 ; dsLocalBinds binds rest }
732 go _ (BindStmt pat rhs bind_op fail_op) stmts
733 = do { body <- goL stmts
734 ; rhs' <- dsLExpr rhs
735 ; bind_op' <- dsExpr bind_op
736 ; var <- selectSimpleMatchVarL pat
737 ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
738 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
739 ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
740 res1_ty (cantFailMatchResult body)
741 ; match_code <- handle_failure pat match fail_op
742 ; return (mkApps bind_op' [rhs', Lam var match_code]) }
744 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
745 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
746 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
747 , recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts
748 = ASSERT( length rec_ids > 0 )
749 ASSERT( isEmptyTcEvBinds _ev_binds ) -- No method binds
750 goL (new_bind_stmt : stmts)
752 -- returnE <- dsExpr return_id
753 -- mfixE <- dsExpr mfix_id
754 new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
756 noSyntaxExpr -- Tuple cannot fail
758 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
759 rec_tup_pats = map nlVarPat tup_ids
760 later_pats = rec_tup_pats
761 rets = map noLoc rec_rets
763 mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
764 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
765 (mkFunTy tup_ty body_ty))
766 mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
767 body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
768 return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
769 body_ty = mkAppTy m_ty tup_ty
770 tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
772 -- In a do expression, pattern-match failure just calls
773 -- the monadic 'fail' rather than throwing an exception
774 handle_failure pat match fail_op
776 = do { fail_op' <- dsExpr fail_op
777 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
778 ; extractMatchResult match (App fail_op' fail_msg) }
780 = extractMatchResult match (error "It can't fail")
782 mk_fail_msg :: Located e -> String
783 mk_fail_msg pat = "Pattern match failure in do expression at " ++
784 showSDoc (ppr (getLoc pat))
787 Translation for RecStmt's:
788 -----------------------------
789 We turn (RecStmt [v1,..vn] stmts) into:
791 (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
795 dsMDo :: HsStmtContext Name
799 -> Type -- Type of the whole expression
802 dsMDo ctxt tbl stmts body result_ty
805 goL [] = dsLExpr body
806 goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
808 (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
809 mfix_id = lookupEvidence tbl mfixName
810 return_id = lookupEvidence tbl returnMName
811 bind_id = lookupEvidence tbl bindMName
812 then_id = lookupEvidence tbl thenMName
813 fail_id = lookupEvidence tbl failMName
815 go _ (LetStmt binds) stmts
816 = do { rest <- goL stmts
817 ; dsLocalBinds binds rest }
819 go _ (ExprStmt rhs _ rhs_ty) stmts
820 = do { rhs2 <- dsLExpr rhs
821 ; warnDiscardedDoBindings rhs m_ty rhs_ty
823 ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
825 go _ (BindStmt pat rhs _ _) stmts
826 = do { body <- goL stmts
827 ; var <- selectSimpleMatchVarL pat
828 ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
829 result_ty (cantFailMatchResult body)
830 ; fail_msg <- mkStringExpr (mk_fail_msg pat)
831 ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
832 ; match_code <- extractMatchResult match fail_expr
834 ; rhs' <- dsLExpr rhs
835 ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
836 rhs', Lam var match_code]) }
838 go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
839 , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
840 , recS_dicts = _ev_binds }) stmts
841 = ASSERT( length rec_ids > 0 )
842 ASSERT( length rec_ids == length rec_rets )
843 ASSERT( isEmptyTcEvBinds _ev_binds )
844 pprTrace "dsMDo" (ppr later_ids) $
845 goL (new_bind_stmt : stmts)
847 new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
849 -- Remove the later_ids that appear (without fancy coercions)
850 -- in rec_rets, because there's no need to knot-tie them separately
851 -- See Note [RecStmt] in HsExpr
852 later_ids' = filter (`notElem` mono_rec_ids) later_ids
853 mono_rec_ids = [ id | HsVar id <- rec_rets ]
855 mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
856 mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
857 (mkFunTy tup_ty body_ty))
859 -- The rec_tup_pat must bind the rec_ids only; remember that the
860 -- trimmed_laters may share the same Names
861 -- Meanwhile, the later_pats must bind the later_vars
862 rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
863 later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
864 rets = map nlHsVar later_ids' ++ map noLoc rec_rets
866 mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
867 body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
868 body_ty = mkAppTy m_ty tup_ty
869 tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
871 return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
872 (mkLHsTupleExpr rets)
874 mk_wild_pat :: Id -> LPat Id
875 mk_wild_pat v = noLoc $ WildPat $ idType v
877 mk_later_pat :: Id -> LPat Id
878 mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
879 | otherwise = nlVarPat v
881 mk_tup_pat :: [LPat Id] -> LPat Id
883 mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
887 %************************************************************************
889 \subsection{Errors and contexts}
891 %************************************************************************
894 -- Warn about certain types of values discarded in monadic bindings (#3263)
895 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
896 warnDiscardedDoBindings rhs container_ty returning_ty = do {
897 -- Warn about discarding non-() things in 'monadic' binding
898 ; warn_unused <- doptDs Opt_WarnUnusedDoBind
899 ; if warn_unused && not (returning_ty `tcEqType` unitTy)
900 then warnDs (unusedMonadBind rhs returning_ty)
902 -- Warn about discarding m a things in 'monadic' binding of the same type,
903 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
904 ; warn_wrong <- doptDs Opt_WarnWrongDoBind
905 ; case tcSplitAppTy_maybe returning_ty of
906 Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
907 warnDs (wrongMonadBind rhs returning_ty)
910 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
911 unusedMonadBind rhs returning_ty
912 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
913 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
914 ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
916 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
917 wrongMonadBind rhs returning_ty
918 = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
919 ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
920 ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")