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 )
49 import BasicTypes hiding ( TopLevel )
51 import StaticFlags ( opt_DsMultiTyVar )
52 import Util ( mapSnd, mapAndUnzip, lengthExceeds )
58 %************************************************************************
60 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
62 %************************************************************************
65 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
66 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
68 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
69 dsLHsBinds binds = ds_lhs_binds NoSccs binds
72 ------------------------
73 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
74 -- scc annotation policy (see below)
75 ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds)
78 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
80 -> DsM [(Id,CoreExpr)] -- Result
81 dsLHsBind auto_scc rest (L loc bind)
82 = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
85 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
87 -> DsM [(Id,CoreExpr)] -- Result
89 dsHsBind _ rest (VarBind var expr) = do
90 core_expr <- dsLExpr expr
92 -- Dictionary bindings are always VarMonoBinds, so
93 -- we only need do this here
94 core_expr' <- addDictScc var core_expr
95 return ((var, core_expr') : rest)
97 dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches,
98 fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do
99 (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
100 body' <- mkOptTickBox tick body
101 rhs <- dsCoercion co_fn (return (mkLams args body'))
102 return ((fun,rhs) : rest)
104 dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do
105 body_expr <- dsGuarded grhss ty
106 sel_binds <- mkSelectorBinds pat body_expr
107 return (sel_binds ++ rest)
109 {- Note [Rules and inlining]
110 ~~~~~~~~~~~~~~~~~~~~~~~~~
111 Common special case: no type or dictionary abstraction
112 This is a bit less trivial than you might suppose
113 The naive way woudl be to desguar to something like
114 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
115 M.f = f_lcl -- Generated from "exports"
116 But we don't want that, because if M.f isn't exported,
117 it'll be inlined unconditionally at every call site (its rhs is
118 trivial). That would be ok unless it has RULES, which would
119 thereby be completely lost. Bad, bad, bad.
121 Instead we want to generate
124 Now all is cool. The RULES are attached to M.f (by SimplCore),
125 and f_lcl is rapidly inlined away.
127 This does not happen in the same way to polymorphic binds,
128 because they desugar to
129 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
130 Although I'm a bit worried about whether full laziness might
131 float the f_lcl binding out and then inline M.f at its call site -}
133 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
134 = do { core_prs <- ds_lhs_binds NoSccs binds
135 ; let env = mkABEnv exports
136 do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
137 = addInlinePrags prags gbl_id $
138 addAutoScc auto_scc gbl_id rhs
139 | otherwise = (lcl_id, rhs)
140 locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
141 -- Note [Rules and inlining]
142 ; return (map do_one core_prs ++ locals' ++ rest) }
143 -- No Rec needed here (contrast the other AbsBinds cases)
144 -- because we can rely on the enclosing dsBind to wrap in Rec
147 {- Note [Abstracting over tyvars only]
148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
149 When abstracting over type variable only (not dictionaries), we don't really need to
150 built a tuple and select from it, as we do in the general case. Instead we can take
152 AbsBinds [a,b] [ ([a,b], fg, fl, _),
160 fg = /\ab. let B in e1
161 gg = /\b. let a = () in let B in S(e2)
162 h = /\ab. let B in e3
164 where B is the *non-recursive* binding
167 h = h a b -- See (b); note shadowing!
169 Notice (a) g has a different number of type variables to f, so we must
170 use the mkArbitraryType thing to fill in the gaps.
171 We use a type-let to do that.
173 (b) The local variable h isn't in the exports, and rather than
174 clone a fresh copy we simply replace h by (h a b), where
175 the two h's have different types! Shadowing happens here,
176 which looks confusing but works fine.
178 (c) The result is *still* quadratic-sized if there are a lot of
179 small bindings. So if there are more than some small
180 number (10), we filter the binding set B by the free
181 variables of the particular RHS. Tiresome.
183 Why got to this trouble? It's a common case, and it removes the
184 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
185 compilation, especially in a case where there are a *lot* of
190 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
191 | opt_DsMultiTyVar -- This (static) debug flag just lets us
192 -- switch on and off this optimisation to
193 -- see if it has any impact; it is on by default
194 = -- Note [Abstracting over tyvars only]
195 do { core_prs <- ds_lhs_binds NoSccs binds
196 ; arby_env <- mkArbitraryTypeEnv tyvars exports
197 ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
198 bndrs = mkVarSet (map fst core_prs)
200 add_lets | core_prs `lengthExceeds` 10 = add_some
201 | otherwise = mkLets lg_binds
202 add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
203 , b `elemVarSet` fvs] rhs
205 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
207 env = mkABEnv exports
210 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
211 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
212 addInlinePrags prags gbl_id $
213 addAutoScc auto_scc gbl_id $
215 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
216 | tv <- tyvars, not (tv `elem` id_tvs)] $
219 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
220 (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
222 non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
224 ; return (core_prs' ++ rest) }
226 -- Another common case: one exported variable
227 -- Non-recursive bindings come through this way
228 dsHsBind auto_scc rest
229 (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
230 = ASSERT( all (`elem` tyvars) all_tyvars ) do
231 core_prs <- ds_lhs_binds NoSccs binds
233 -- Always treat the binds as recursive, because the typechecker
234 -- makes rather mixed-up dictionary bindings
235 core_bind = Rec core_prs
237 mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
239 (spec_binds, rules) = unzip (catMaybes mb_specs)
240 global' = addIdSpecialisations global rules
241 rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
242 bind = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
244 return (bind : spec_binds ++ rest)
246 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
247 = do { core_prs <- ds_lhs_binds NoSccs binds
248 ; let env = mkABEnv exports
249 do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
250 = addInlinePrags prags lcl_id $
251 addAutoScc auto_scc gbl_id rhs
252 | otherwise = (lcl_id,rhs)
254 -- Rec because of mixed-up dictionary bindings
255 core_bind = Rec (map do_one core_prs)
257 tup_expr = mkBigCoreVarTup locals
258 tup_ty = exprType tup_expr
259 poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
260 Let core_bind tup_expr
261 locals = [local | (_, _, local, _) <- exports]
262 local_tys = map idType locals
264 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
266 ; let dict_args = map Var dicts
268 mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
269 = -- Need to make fresh locals to bind in the selector, because
270 -- some of the tyvars will be bound to 'Any'
271 do { ty_args <- mapM mk_ty_arg all_tyvars
272 ; let substitute = substTyWith all_tyvars ty_args
273 ; locals' <- newSysLocalsDs (map substitute local_tys)
274 ; tup_id <- newSysLocalDs (substitute tup_ty)
275 ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
277 ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
278 global' = addIdSpecialisations global rules
279 rhs = mkLams tyvars $ mkLams dicts $
280 mkTupleSelector locals' (locals' !! n) tup_id $
281 mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
282 ; return ((global', rhs) : spec_binds) }
285 | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
286 | otherwise = dsMkArbitraryType all_tyvar
288 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
289 -- don't scc (auto-)annotate the tuple itself.
291 ; return ((poly_tup_id, poly_tup_expr) :
292 (concat export_binds_s ++ rest)) }
294 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
295 -- Takes the exports of a AbsBinds, and returns a mapping
296 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
297 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
300 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
301 -> Id -> Id -- Global, local
303 -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
304 CoreRule)) -- Rule for the Global Id
307 -- f :: (Eq a, Ix b) => a -> b -> b
308 -- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
310 -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
312 -- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
313 -- (forall b. Ix b => Int -> b -> b)
315 -- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
317 -- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
318 -- /\b.\(d:Ix b). in f Int b dInt d
319 -- The idea is that f occurs just once, so it'll be
320 -- inlined and specialised
322 -- Given SpecPrag (/\as.\ds. f es) t, we have
323 -- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
325 -- and the RULE forall as, ds. f es = f_spec as ds
327 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
328 -- (a bit silly, because then the
329 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
332 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
333 (L loc (SpecPrag spec_expr spec_ty inl))
335 do { let poly_name = idName poly_id
336 ; spec_name <- newLocalName poly_name
337 ; ds_spec_expr <- dsExpr spec_expr
338 ; case (decomposeRuleLhs ds_spec_expr) of {
339 Nothing -> do { warnDs decomp_msg; return Nothing } ;
341 Just (bndrs, _fn, args) ->
343 -- Check for dead binders: Note [Unused spec binders]
344 case filter isDeadBinder bndrs of {
345 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
348 { f_body <- fix_up (Let mono_bind (Var mono_id))
350 ; let local_poly = setIdNotExported poly_id
351 -- Very important to make the 'f' non-exported,
352 -- else it won't be inlined!
353 spec_id = mkLocalId spec_name spec_ty
354 spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
355 poly_f_body = mkLams (tvs ++ dicts) f_body
357 extra_dict_bndrs = [localiseId d -- See Note [Constant rule dicts]
358 | d <- varSetElems (exprFreeVars ds_spec_expr)
360 -- Note [Const rule dicts]
362 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
363 AlwaysActive poly_name
364 (extra_dict_bndrs ++ bndrs) args
365 (mkVarApps (Var spec_id) bndrs)
366 ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
369 -- Bind to Any any of all_ptvs that aren't
370 -- relevant for this particular function
371 fix_up body | null void_tvs = return body
372 | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
373 ; return (mkTyApps (mkLams void_tvs body) void_tys) }
375 void_tvs = all_tvs \\ tvs
377 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
378 <+> ptext (sLit "in specialied type:"),
379 nest 2 (pprTheta (map get_pred bs))]
380 , ptext (sLit "SPECIALISE pragma ignored")]
381 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
383 decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
387 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
388 -- If any of the tyvars is missing from any of the lists in
389 -- the second arg, return a binding in the result
390 mkArbitraryTypeEnv tyvars exports
391 = go emptyVarEnv exports
393 go env [] = return env
394 go env ((ltvs, _, _, _) : exports)
395 = do { env' <- foldlM extend env [tv | tv <- tyvars
396 , not (tv `elem` ltvs)
397 , not (tv `elemVarEnv` env)]
400 extend env tv = do { ty <- dsMkArbitraryType tv
401 ; return (extendVarEnv env tv ty) }
404 dsMkArbitraryType :: TcTyVar -> DsM Type
405 dsMkArbitraryType tv = mkArbitraryType warn tv
407 warn span msg = putSrcSpanDs span (warnDs msg)
410 Note [Unused spec binders]
411 ~~~~~~~~~~~~~~~~~~~~~~~~~~
414 {-# SPECIALISE f :: Eq a => a -> a #-}
415 It's true that this *is* a more specialised type, but the rule
416 we get is something like this:
419 Note that the rule is bogus, becuase it mentions a 'd' that is
420 not bound on the LHS! But it's a silly specialisation anyway, becuase
421 the constraint is unused. We could bind 'd' to (error "unused")
422 but it seems better to reject the program because it's almost certainly
423 a mistake. That's what the isDeadBinder call detects.
425 Note [Const rule dicts]
426 ~~~~~~~~~~~~~~~~~~~~~~~
427 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
428 which is presumably in scope at the function definition site, we can quantify
429 over it too. *Any* dict with that type will do.
431 So for example when you have
434 {-# SPECIALISE f :: Int -> Int #-}
436 Then we get the SpecPrag
437 SpecPrag (f Int dInt) Int
439 And from that we want the rule
441 RULE forall dInt. f Int dInt = f_spec
442 f_spec = let f = <rhs> in f Int dInt
444 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
445 Name, and you can't bind them in a lambda or forall without getting things
446 confused. Hence the use of 'localiseId' to make it Internal.
449 %************************************************************************
451 \subsection{Adding inline pragmas}
453 %************************************************************************
456 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
457 -- Take apart the LHS of a RULE. It's suuposed to look like
458 -- /\a. f a Int dOrdInt
459 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
460 -- That is, the RULE binders are lambda-bound
461 -- Returns Nothing if the LHS isn't of the expected shape
463 = case (decomp emptyVarEnv body) of
465 Just (fn, args) -> Just (bndrs, fn, args)
467 occ_lhs = occurAnalyseExpr lhs
468 -- The occurrence-analysis does two things
469 -- (a) identifies unused binders: Note [Unused spec binders]
470 -- (b) sorts dict bindings into NonRecs
471 -- so they can be inlined by 'decomp'
472 (bndrs, body) = collectBinders occ_lhs
474 -- Substitute dicts in the LHS args, so that there
475 -- aren't any lets getting in the way
476 -- Note that we substitute the function too; we might have this as
477 -- a LHS: let f71 = M.f Int in f71
478 decomp env (Let (NonRec dict rhs) body)
479 = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
481 decomp env (Case scrut bndr ty [(DEFAULT, _, body)])
482 | isDeadBinder bndr -- Note [Matching seqId]
483 = Just (seqId, [Type (idType bndr), Type ty,
484 simpleSubst env scrut, simpleSubst env body])
487 = case collectArgs (simpleSubst env body) of
488 (Var fn, args) -> Just (fn, args)
491 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
492 -- Similar to CoreSubst.substExpr, except that
493 -- (a) Takes no account of capture; at this point there is no shadowing
494 -- (b) Can have a GlobalId (imported) in its domain
495 -- (c) Ids only; no types are substituted
496 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
497 -- in-scope set mentions all LocalIds mentioned in the argument of the subst
499 -- (b) and (d) are the reasons we can't use CoreSubst
501 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
502 -- look relevant here. Perhaps there was another caller of simpleSubst.)
504 simpleSubst subst expr
507 go (Var v) = lookupVarEnv subst v `orElse` Var v
508 go (Cast e co) = Cast (go e) co
509 go (Type ty) = Type ty
510 go (Lit lit) = Lit lit
511 go (App fun arg) = App (go fun) (go arg)
512 go (Note note e) = Note note (go e)
513 go (Lam bndr body) = Lam bndr (go body)
514 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
515 go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body)
516 go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
517 [(c,bs,go r) | (c,bs,r) <- alts]
519 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
520 addInlinePrags prags bndr rhs
521 = case [inl | L _ (InlinePrag inl) <- prags] of
523 (inl:_) -> addInlineInfo inl bndr rhs
525 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
526 addInlineInfo (Inline prag is_inline) bndr rhs
527 = (attach_pragma bndr prag, wrap_inline is_inline rhs)
529 attach_pragma bndr prag
530 | isDefaultInlinePragma prag = bndr
531 | otherwise = bndr `setInlinePragma` prag
533 wrap_inline True body = mkInlineMe body
534 wrap_inline False body = body
539 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
540 and this code turns it back into an application of seq!
541 See Note [Rules for seq] in MkId for the details.
544 %************************************************************************
546 \subsection[addAutoScc]{Adding automatic sccs}
548 %************************************************************************
551 data AutoScc = NoSccs
552 | AddSccs Module (Id -> Bool)
553 -- The (Id->Bool) says which Ids to add SCCs to
555 addAutoScc :: AutoScc
558 -> CoreExpr -- Scc'd Rhs
560 addAutoScc NoSccs _ rhs
562 addAutoScc (AddSccs mod add_scc) id rhs
563 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
567 If profiling and dealing with a dict binding,
568 wrap the dict in @_scc_ DICT <dict>@:
571 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
572 addDictScc _ rhs = return rhs
574 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
575 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
576 || not (isDictId var)
577 = return rhs -- That's easy: do nothing
580 = do (mod, grp) <- getModuleAndGroupDs
581 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
582 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
587 %************************************************************************
591 %************************************************************************
595 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
596 dsCoercion WpHole thing_inside = thing_inside
597 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
598 dsCoercion (WpCast co) thing_inside = do { expr <- thing_inside
599 ; return (Cast expr co) }
600 dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside
601 ; return (Lam id expr) }
602 dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
603 ; return (Lam tv expr) }
604 dsCoercion (WpApp v) thing_inside
605 | isTyVar v = do { expr <- thing_inside
606 {- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) }
607 | otherwise = do { expr <- thing_inside
608 {- An Id -} ; return (App expr (Var v)) }
609 dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
610 ; return (App expr (Type ty)) }
611 dsCoercion WpInline thing_inside = do { expr <- thing_inside
612 ; return (mkInlineMe expr) }
613 dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs
614 ; expr <- thing_inside
615 ; return (Let (Rec prs) expr) }