2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Pattern-matching bindings (HsBinds and MonoBinds)
8 Handles @HsBinds@; those at the top level require different handling,
9 in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
10 lower levels it is preserved with @let@/@letrec@s).
13 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} DsExpr( dsLExpr, dsExpr )
21 import {-# SOURCE #-} Match( matchWrapper )
28 import HsSyn -- lots of things
29 import CoreSyn -- lots of things
34 import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
40 import Var ( Var, TyVar )
48 import BasicTypes hiding ( TopLevel )
50 import StaticFlags ( opt_DsMultiTyVar )
51 import Util ( mapSnd, mapAndUnzip, lengthExceeds )
57 %************************************************************************
59 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
61 %************************************************************************
64 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
65 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
67 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
68 dsLHsBinds binds = ds_lhs_binds NoSccs binds
71 ------------------------
72 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
73 -- scc annotation policy (see below)
74 ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds)
77 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
79 -> DsM [(Id,CoreExpr)] -- Result
80 dsLHsBind auto_scc rest (L loc bind)
81 = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
84 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
86 -> DsM [(Id,CoreExpr)] -- Result
88 dsHsBind _ rest (VarBind var expr) = do
89 core_expr <- dsLExpr expr
91 -- Dictionary bindings are always VarMonoBinds, so
92 -- we only need do this here
93 core_expr' <- addDictScc var core_expr
94 return ((var, core_expr') : rest)
96 dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches,
97 fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do
98 (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
99 body' <- mkOptTickBox tick body
100 rhs <- dsCoercion co_fn (return (mkLams args body'))
101 return ((fun,rhs) : rest)
103 dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do
104 body_expr <- dsGuarded grhss ty
105 sel_binds <- mkSelectorBinds pat body_expr
106 return (sel_binds ++ rest)
108 {- Note [Rules and inlining]
109 ~~~~~~~~~~~~~~~~~~~~~~~~~
110 Common special case: no type or dictionary abstraction
111 This is a bit less trivial than you might suppose
112 The naive way woudl be to desguar to something like
113 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
114 M.f = f_lcl -- Generated from "exports"
115 But we don't want that, because if M.f isn't exported,
116 it'll be inlined unconditionally at every call site (its rhs is
117 trivial). That would be ok unless it has RULES, which would
118 thereby be completely lost. Bad, bad, bad.
120 Instead we want to generate
123 Now all is cool. The RULES are attached to M.f (by SimplCore),
124 and f_lcl is rapidly inlined away.
126 This does not happen in the same way to polymorphic binds,
127 because they desugar to
128 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
129 Although I'm a bit worried about whether full laziness might
130 float the f_lcl binding out and then inline M.f at its call site -}
132 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
133 = do { core_prs <- ds_lhs_binds NoSccs binds
134 ; let env = mkABEnv exports
135 do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
136 = addInlinePrags prags gbl_id $
137 addAutoScc auto_scc gbl_id rhs
138 | otherwise = (lcl_id, rhs)
139 locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
140 -- Note [Rules and inlining]
141 ; return (map do_one core_prs ++ locals' ++ rest) }
142 -- No Rec needed here (contrast the other AbsBinds cases)
143 -- because we can rely on the enclosing dsBind to wrap in Rec
146 {- Note [Abstracting over tyvars only]
147 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
148 When abstracting over type variable only (not dictionaries), we don't really need to
149 built a tuple and select from it, as we do in the general case. Instead we can take
151 AbsBinds [a,b] [ ([a,b], fg, fl, _),
159 fg = /\ab. let B in e1
160 gg = /\b. let a = () in let B in S(e2)
161 h = /\ab. let B in e3
163 where B is the *non-recursive* binding
166 h = h a b -- See (b); note shadowing!
168 Notice (a) g has a different number of type variables to f, so we must
169 use the mkArbitraryType thing to fill in the gaps.
170 We use a type-let to do that.
172 (b) The local variable h isn't in the exports, and rather than
173 clone a fresh copy we simply replace h by (h a b), where
174 the two h's have different types! Shadowing happens here,
175 which looks confusing but works fine.
177 (c) The result is *still* quadratic-sized if there are a lot of
178 small bindings. So if there are more than some small
179 number (10), we filter the binding set B by the free
180 variables of the particular RHS. Tiresome.
182 Why got to this trouble? It's a common case, and it removes the
183 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
184 compilation, especially in a case where there are a *lot* of
189 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
190 | opt_DsMultiTyVar -- This (static) debug flag just lets us
191 -- switch on and off this optimisation to
192 -- see if it has any impact; it is on by default
193 = -- Note [Abstracting over tyvars only]
194 do { core_prs <- ds_lhs_binds NoSccs binds
195 ; arby_env <- mkArbitraryTypeEnv tyvars exports
196 ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
197 bndrs = mkVarSet (map fst core_prs)
199 add_lets | core_prs `lengthExceeds` 10 = add_some
200 | otherwise = mkLets lg_binds
201 add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
202 , b `elemVarSet` fvs] rhs
204 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
206 env = mkABEnv exports
209 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
210 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
211 addInlinePrags prags gbl_id $
212 addAutoScc auto_scc gbl_id $
214 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
215 | tv <- tyvars, not (tv `elem` id_tvs)] $
218 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
219 (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
221 non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
223 ; return (core_prs' ++ rest) }
225 -- Another common case: one exported variable
226 -- Non-recursive bindings come through this way
227 dsHsBind auto_scc rest
228 (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
229 = ASSERT( all (`elem` tyvars) all_tyvars ) do
230 core_prs <- ds_lhs_binds NoSccs binds
232 -- Always treat the binds as recursive, because the typechecker
233 -- makes rather mixed-up dictionary bindings
234 core_bind = Rec core_prs
236 mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
238 (spec_binds, rules) = unzip (catMaybes mb_specs)
239 global' = addIdSpecialisations global rules
240 rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
241 bind = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
243 return (bind : spec_binds ++ rest)
245 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
246 = do { core_prs <- ds_lhs_binds NoSccs binds
247 ; let env = mkABEnv exports
248 do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
249 = addInlinePrags prags lcl_id $
250 addAutoScc auto_scc gbl_id rhs
251 | otherwise = (lcl_id,rhs)
253 -- Rec because of mixed-up dictionary bindings
254 core_bind = Rec (map do_one core_prs)
256 tup_expr = mkBigCoreVarTup locals
257 tup_ty = exprType tup_expr
258 poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
259 Let core_bind tup_expr
260 locals = [local | (_, _, local, _) <- exports]
261 local_tys = map idType locals
263 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
265 ; let dict_args = map Var dicts
267 mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
268 = -- Need to make fresh locals to bind in the selector, because
269 -- some of the tyvars will be bound to 'Any'
270 do { ty_args <- mapM mk_ty_arg all_tyvars
271 ; let substitute = substTyWith all_tyvars ty_args
272 ; locals' <- newSysLocalsDs (map substitute local_tys)
273 ; tup_id <- newSysLocalDs (substitute tup_ty)
274 ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
276 ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
277 global' = addIdSpecialisations global rules
278 rhs = mkLams tyvars $ mkLams dicts $
279 mkTupleSelector locals' (locals' !! n) tup_id $
280 mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
281 ; return ((global', rhs) : spec_binds) }
284 | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
285 | otherwise = dsMkArbitraryType all_tyvar
287 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
288 -- don't scc (auto-)annotate the tuple itself.
290 ; return ((poly_tup_id, poly_tup_expr) :
291 (concat export_binds_s ++ rest)) }
293 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
294 -- Takes the exports of a AbsBinds, and returns a mapping
295 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
296 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
299 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
300 -> Id -> Id -- Global, local
302 -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
303 CoreRule)) -- Rule for the Global Id
306 -- f :: (Eq a, Ix b) => a -> b -> b
307 -- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
309 -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
311 -- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
312 -- (forall b. Ix b => Int -> b -> b)
314 -- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
316 -- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
317 -- /\b.\(d:Ix b). in f Int b dInt d
318 -- The idea is that f occurs just once, so it'll be
319 -- inlined and specialised
321 -- Given SpecPrag (/\as.\ds. f es) t, we have
322 -- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
324 -- and the RULE forall as, ds. f es = f_spec as ds
326 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
327 -- (a bit silly, because then the
328 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
331 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
332 (L loc (SpecPrag spec_expr spec_ty inl))
334 do { let poly_name = idName poly_id
335 ; spec_name <- newLocalName poly_name
336 ; ds_spec_expr <- dsExpr spec_expr
337 ; case (decomposeRuleLhs ds_spec_expr) of {
338 Nothing -> do { warnDs decomp_msg; return Nothing } ;
340 Just (bndrs, _fn, args) ->
342 -- Check for dead binders: Note [Unused spec binders]
343 case filter isDeadBinder bndrs of {
344 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
347 { f_body <- fix_up (Let mono_bind (Var mono_id))
349 ; let local_poly = setIdNotExported poly_id
350 -- Very important to make the 'f' non-exported,
351 -- else it won't be inlined!
352 spec_id = mkLocalId spec_name spec_ty
353 spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
354 poly_f_body = mkLams (tvs ++ dicts) f_body
356 extra_dict_bndrs = [localiseId d -- See Note [Constant rule dicts]
357 | d <- varSetElems (exprFreeVars ds_spec_expr)
359 -- Note [Const rule dicts]
361 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
362 AlwaysActive poly_name
363 (extra_dict_bndrs ++ bndrs) args
364 (mkVarApps (Var spec_id) bndrs)
365 ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
368 -- Bind to Any any of all_ptvs that aren't
369 -- relevant for this particular function
370 fix_up body | null void_tvs = return body
371 | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
372 ; return (mkTyApps (mkLams void_tvs body) void_tys) }
374 void_tvs = all_tvs \\ tvs
376 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
377 <+> ptext (sLit "in specialied type:"),
378 nest 2 (pprTheta (map get_pred bs))]
379 , ptext (sLit "SPECIALISE pragma ignored")]
380 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
382 decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
386 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
387 -- If any of the tyvars is missing from any of the lists in
388 -- the second arg, return a binding in the result
389 mkArbitraryTypeEnv tyvars exports
390 = go emptyVarEnv exports
392 go env [] = return env
393 go env ((ltvs, _, _, _) : exports)
394 = do { env' <- foldlM extend env [tv | tv <- tyvars
395 , not (tv `elem` ltvs)
396 , not (tv `elemVarEnv` env)]
399 extend env tv = do { ty <- dsMkArbitraryType tv
400 ; return (extendVarEnv env tv ty) }
403 dsMkArbitraryType :: TcTyVar -> DsM Type
404 dsMkArbitraryType tv = mkArbitraryType warn tv
406 warn span msg = putSrcSpanDs span (warnDs msg)
409 Note [Unused spec binders]
410 ~~~~~~~~~~~~~~~~~~~~~~~~~~
413 {-# SPECIALISE f :: Eq a => a -> a #-}
414 It's true that this *is* a more specialised type, but the rule
415 we get is something like this:
418 Note that the rule is bogus, becuase it mentions a 'd' that is
419 not bound on the LHS! But it's a silly specialisation anyway, becuase
420 the constraint is unused. We could bind 'd' to (error "unused")
421 but it seems better to reject the program because it's almost certainly
422 a mistake. That's what the isDeadBinder call detects.
424 Note [Const rule dicts]
425 ~~~~~~~~~~~~~~~~~~~~~~~
426 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
427 which is presumably in scope at the function definition site, we can quantify
428 over it too. *Any* dict with that type will do.
430 So for example when you have
433 {-# SPECIALISE f :: Int -> Int #-}
435 Then we get the SpecPrag
436 SpecPrag (f Int dInt) Int
438 And from that we want the rule
440 RULE forall dInt. f Int dInt = f_spec
441 f_spec = let f = <rhs> in f Int dInt
443 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
444 Name, and you can't bind them in a lambda or forall without getting things
445 confused. Hence the use of 'localiseId' to make it Internal.
448 %************************************************************************
450 \subsection{Adding inline pragmas}
452 %************************************************************************
455 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
456 -- Take apart the LHS of a RULE. It's suuposed to look like
457 -- /\a. f a Int dOrdInt
458 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
459 -- That is, the RULE binders are lambda-bound
460 -- Returns Nothing if the LHS isn't of the expected shape
462 = case (decomp emptyVarEnv body) of
464 Just (fn, args) -> Just (bndrs, fn, args)
466 occ_lhs = occurAnalyseExpr lhs
467 -- The occurrence-analysis does two things
468 -- (a) identifies unused binders: Note [Unused spec binders]
469 -- (b) sorts dict bindings into NonRecs
470 -- so they can be inlined by 'decomp'
471 (bndrs, body) = collectBinders occ_lhs
473 -- Substitute dicts in the LHS args, so that there
474 -- aren't any lets getting in the way
475 -- Note that we substitute the function too; we might have this as
476 -- a LHS: let f71 = M.f Int in f71
477 decomp env (Let (NonRec dict rhs) body)
478 = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
480 decomp env (Case scrut bndr ty [(DEFAULT, _, body)])
481 | isDeadBinder bndr -- Note [Matching seqId]
482 = Just (seqId, [Type (idType bndr), Type ty,
483 simpleSubst env scrut, simpleSubst env body])
486 = case collectArgs (simpleSubst env body) of
487 (Var fn, args) -> Just (fn, args)
490 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
491 -- Similar to CoreSubst.substExpr, except that
492 -- (a) Takes no account of capture; at this point there is no shadowing
493 -- (b) Can have a GlobalId (imported) in its domain
494 -- (c) Ids only; no types are substituted
495 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
496 -- in-scope set mentions all LocalIds mentioned in the argument of the subst
498 -- (b) and (d) are the reasons we can't use CoreSubst
500 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
501 -- look relevant here. Perhaps there was another caller of simpleSubst.)
503 simpleSubst subst expr
506 go (Var v) = lookupVarEnv subst v `orElse` Var v
507 go (Cast e co) = Cast (go e) co
508 go (Type ty) = Type ty
509 go (Lit lit) = Lit lit
510 go (App fun arg) = App (go fun) (go arg)
511 go (Note note e) = Note note (go e)
512 go (Lam bndr body) = Lam bndr (go body)
513 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
514 go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body)
515 go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
516 [(c,bs,go r) | (c,bs,r) <- alts]
518 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
519 addInlinePrags prags bndr rhs
520 = case [inl | L _ (InlinePrag inl) <- prags] of
522 (inl:_) -> addInlineInfo inl bndr rhs
524 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
525 addInlineInfo (Inline prag is_inline) bndr rhs
526 = (attach_pragma bndr prag, wrap_inline is_inline rhs)
528 attach_pragma bndr prag
529 | isDefaultInlinePragma prag = bndr
530 | otherwise = bndr `setInlinePragma` prag
532 wrap_inline True body = mkInlineMe body
533 wrap_inline False body = body
538 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
539 and this code turns it back into an application of seq!
540 See Note [Rules for seq] in MkId for the details.
543 %************************************************************************
545 \subsection[addAutoScc]{Adding automatic sccs}
547 %************************************************************************
550 data AutoScc = NoSccs
551 | AddSccs Module (Id -> Bool)
552 -- The (Id->Bool) says which Ids to add SCCs to
554 addAutoScc :: AutoScc
557 -> CoreExpr -- Scc'd Rhs
559 addAutoScc NoSccs _ rhs
561 addAutoScc (AddSccs mod add_scc) id rhs
562 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
566 If profiling and dealing with a dict binding,
567 wrap the dict in @_scc_ DICT <dict>@:
570 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
571 addDictScc _ rhs = return rhs
573 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
574 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
575 || not (isDictId var)
576 = return rhs -- That's easy: do nothing
579 = do (mod, grp) <- getModuleAndGroupDs
580 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
581 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
586 %************************************************************************
590 %************************************************************************
594 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
595 dsCoercion WpHole thing_inside = thing_inside
596 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
597 dsCoercion (WpCast co) thing_inside = do { expr <- thing_inside
598 ; return (Cast expr co) }
599 dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside
600 ; return (Lam id expr) }
601 dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
602 ; return (Lam tv expr) }
603 dsCoercion (WpApp v) thing_inside
604 | isTyVar v = do { expr <- thing_inside
605 {- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) }
606 | otherwise = do { expr <- thing_inside
607 {- An Id -} ; return (App expr (Var v)) }
608 dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
609 ; return (App expr (Type ty)) }
610 dsCoercion WpInline thing_inside = do { expr <- thing_inside
611 ; return (mkInlineMe expr) }
612 dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs
613 ; expr <- thing_inside
614 ; return (Let (Rec prs) expr) }