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 )
27 import HsSyn -- lots of things
28 import CoreSyn -- lots of things
33 import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
39 import Name ( localiseName )
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
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).
176 (c) The result is *still* quadratic-sized if there are a lot of
177 small bindings. So if there are more than some small
178 number (10), we filter the binding set B by the free
179 variables of the particular RHS. Tiresome.
181 Why got to this trouble? It's a common case, and it removes the
182 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
183 compilation, especially in a case where there are a *lot* of
188 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
189 | opt_DsMultiTyVar -- This (static) debug flag just lets us
190 -- switch on and off this optimisation to
191 -- see if it has any impact; it is on by default
192 = -- Note [Abstracting over tyvars only]
193 do { core_prs <- ds_lhs_binds NoSccs binds
194 ; arby_env <- mkArbitraryTypeEnv tyvars exports
195 ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
196 bndrs = mkVarSet (map fst core_prs)
198 add_lets | core_prs `lengthExceeds` 10 = add_some
199 | otherwise = mkLets lg_binds
200 add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
201 , b `elemVarSet` fvs] rhs
203 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
205 env = mkABEnv exports
208 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
209 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
210 addInlinePrags prags gbl_id $
211 addAutoScc auto_scc gbl_id $
213 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
214 | tv <- tyvars, not (tv `elem` id_tvs)] $
217 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
218 (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
220 non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
222 ; return (core_prs' ++ rest) }
224 -- Another common case: one exported variable
225 -- Non-recursive bindings come through this way
226 dsHsBind auto_scc rest
227 (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
228 = ASSERT( all (`elem` tyvars) all_tyvars ) do
229 core_prs <- ds_lhs_binds NoSccs binds
231 -- Always treat the binds as recursive, because the typechecker
232 -- makes rather mixed-up dictionary bindings
233 core_bind = Rec core_prs
235 mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
237 (spec_binds, rules) = unzip (catMaybes mb_specs)
238 global' = addIdSpecialisations global rules
239 rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
240 bind = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
242 return (bind : spec_binds ++ rest)
244 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
245 = do { core_prs <- ds_lhs_binds NoSccs binds
246 ; let env = mkABEnv exports
247 do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
248 = addInlinePrags prags lcl_id $
249 addAutoScc auto_scc gbl_id rhs
250 | otherwise = (lcl_id,rhs)
252 -- Rec because of mixed-up dictionary bindings
253 core_bind = Rec (map do_one core_prs)
255 tup_expr = mkBigCoreVarTup locals
256 tup_ty = exprType tup_expr
257 poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
258 Let core_bind tup_expr
259 locals = [local | (_, _, local, _) <- exports]
260 local_tys = map idType locals
262 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
264 ; let dict_args = map Var dicts
266 mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
267 = -- Need to make fresh locals to bind in the selector, because
268 -- some of the tyvars will be bound to 'Any'
269 do { ty_args <- mapM mk_ty_arg all_tyvars
270 ; let substitute = substTyWith all_tyvars ty_args
271 ; locals' <- newSysLocalsDs (map substitute local_tys)
272 ; tup_id <- newSysLocalDs (substitute tup_ty)
273 ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
275 ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
276 global' = addIdSpecialisations global rules
277 rhs = mkLams tyvars $ mkLams dicts $
278 mkTupleSelector locals' (locals' !! n) tup_id $
279 mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
280 ; return ((global', rhs) : spec_binds) }
283 | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
284 | otherwise = dsMkArbitraryType all_tyvar
286 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
287 -- don't scc (auto-)annotate the tuple itself.
289 ; return ((poly_tup_id, poly_tup_expr) :
290 (concat export_binds_s ++ rest)) }
292 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
293 -- Takes the exports of a AbsBinds, and returns a mapping
294 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
295 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
298 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
299 -> Id -> Id -- Global, local
301 -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
302 CoreRule)) -- Rule for the Global Id
305 -- f :: (Eq a, Ix b) => a -> b -> b
306 -- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
308 -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
310 -- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
311 -- (forall b. Ix b => Int -> b -> b)
313 -- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
315 -- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
316 -- /\b.\(d:Ix b). in f Int b dInt d
317 -- The idea is that f occurs just once, so it'll be
318 -- inlined and specialised
320 -- Given SpecPrag (/\as.\ds. f es) t, we have
321 -- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
323 -- and the RULE forall as, ds. f es = f_spec as ds
325 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
326 -- (a bit silly, because then the
327 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
330 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
331 (L loc (SpecPrag spec_expr spec_ty inl))
333 do { let poly_name = idName poly_id
334 ; spec_name <- newLocalName poly_name
335 ; ds_spec_expr <- dsExpr spec_expr
336 ; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
337 -- ds_spec_expr may look like
338 -- /\a. f a Int dOrdInt
339 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
340 -- The occurrence-analysis does two things
341 -- (a) identifies unused binders: Note [Unused spec binders]
342 -- (b) sorts dict bindings into NonRecs
343 -- so they can be inlined by decomposeRuleLhs
344 mb_lhs = decomposeRuleLhs body
346 -- Check for dead binders: Note [Unused spec binders]
347 ; case filter isDeadBinder bndrs of {
348 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
352 Nothing -> do { warnDs decomp_msg; return Nothing }
354 Just (_, args) -> do {
356 f_body <- fix_up (Let mono_bind (Var mono_id))
358 ; let local_poly = setIdNotExported poly_id
359 -- Very important to make the 'f' non-exported,
360 -- else it won't be inlined!
361 spec_id = mkLocalId spec_name spec_ty
362 spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
363 poly_f_body = mkLams (tvs ++ dicts) f_body
365 extra_dict_bndrs = [localise d
366 | d <- varSetElems (exprFreeVars ds_spec_expr)
368 -- Note [Const rule dicts]
370 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
371 AlwaysActive poly_name
372 (extra_dict_bndrs ++ bndrs) args
373 (mkVarApps (Var spec_id) bndrs)
374 ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
377 -- Bind to Any any of all_ptvs that aren't
378 -- relevant for this particular function
379 fix_up body | null void_tvs = return body
380 | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
381 ; return (mkTyApps (mkLams void_tvs body) void_tys) }
383 void_tvs = all_tvs \\ tvs
385 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
386 <+> ptext (sLit "in specialied type:"),
387 nest 2 (pprTheta (map get_pred bs))]
388 , ptext (sLit "SPECIALISE pragma ignored")]
389 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
391 decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
394 localise d = mkLocalId (localiseName (idName d)) (idType d)
395 -- See Note [Constant rule dicts]
397 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
398 -- If any of the tyvars is missing from any of the lists in
399 -- the second arg, return a binding in the result
400 mkArbitraryTypeEnv tyvars exports
401 = go emptyVarEnv exports
403 go env [] = return env
404 go env ((ltvs, _, _, _) : exports)
405 = do { env' <- foldlM extend env [tv | tv <- tyvars
406 , not (tv `elem` ltvs)
407 , not (tv `elemVarEnv` env)]
410 extend env tv = do { ty <- dsMkArbitraryType tv
411 ; return (extendVarEnv env tv ty) }
414 dsMkArbitraryType :: TcTyVar -> DsM Type
415 dsMkArbitraryType tv = mkArbitraryType warn tv
417 warn span msg = putSrcSpanDs span (warnDs msg)
420 Note [Unused spec binders]
421 ~~~~~~~~~~~~~~~~~~~~~~~~~~
424 {-# SPECIALISE f :: Eq a => a -> a #-}
425 It's true that this *is* a more specialised type, but the rule
426 we get is something like this:
429 Note that the rule is bogus, becuase it mentions a 'd' that is
430 not bound on the LHS! But it's a silly specialisation anyway, becuase
431 the constraint is unused. We could bind 'd' to (error "unused")
432 but it seems better to reject the program because it's almost certainly
433 a mistake. That's what the isDeadBinder call detects.
435 Note [Const rule dicts]
436 ~~~~~~~~~~~~~~~~~~~~~~~
437 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
438 which is presumably in scope at the function definition site, we can quantify
439 over it too. *Any* dict with that type will do.
441 So for example when you have
444 {-# SPECIALISE f :: Int -> Int #-}
446 Then we get the SpecPrag
447 SpecPrag (f Int dInt) Int
449 And from that we want the rule
451 RULE forall dInt. f Int dInt = f_spec
452 f_spec = let f = <rhs> in f Int dInt
454 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
455 Name, and you can't bind them in a lambda or forall without getting things
456 confused. Hence the use of 'localise' to make it Internal.
459 %************************************************************************
461 \subsection{Adding inline pragmas}
463 %************************************************************************
466 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
467 -- Returns Nothing if the LHS isn't of the expected shape
469 = go emptyVarEnv (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict
470 -- bindings so we know if they are recursive
472 -- Substitute dicts in the LHS args, so that there
473 -- aren't any lets getting in the way
474 -- Note that we substitute the function too; we might have this as
475 -- a LHS: let f71 = M.f Int in f71
476 go env (Let (NonRec dict rhs) body)
477 = go (extendVarEnv env dict (simpleSubst env rhs)) body
479 = case collectArgs (simpleSubst env body) of
480 (Var fn, args) -> Just (fn, args)
483 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
484 -- Similar to CoreSubst.substExpr, except that
485 -- (a) Takes no account of capture; at this point there is no shadowing
486 -- (b) Can have a GlobalId (imported) in its domain
487 -- (c) Ids only; no types are substituted
488 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
489 -- in-scope set mentions all LocalIds mentioned in the argument of the subst
491 -- (b) and (d) are the reasons we can't use CoreSubst
493 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
494 -- look relevant here. Perhaps there was another caller of simpleSubst.)
496 simpleSubst subst expr
499 go (Var v) = lookupVarEnv subst v `orElse` Var v
500 go (Cast e co) = Cast (go e) co
501 go (Type ty) = Type ty
502 go (Lit lit) = Lit lit
503 go (App fun arg) = App (go fun) (go arg)
504 go (Note note e) = Note note (go e)
505 go (Lam bndr body) = Lam bndr (go body)
506 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
507 go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body)
508 go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
509 [(c,bs,go r) | (c,bs,r) <- alts]
511 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
512 addInlinePrags prags bndr rhs
513 = case [inl | L _ (InlinePrag inl) <- prags] of
515 (inl:_) -> addInlineInfo inl bndr rhs
517 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
518 addInlineInfo (Inline phase is_inline) bndr rhs
519 = (attach_phase bndr phase, wrap_inline is_inline rhs)
521 attach_phase bndr phase
522 | isAlwaysActive phase = bndr -- Default phase
523 | otherwise = bndr `setInlinePragma` phase
525 wrap_inline True body = mkInlineMe body
526 wrap_inline False body = body
530 %************************************************************************
532 \subsection[addAutoScc]{Adding automatic sccs}
534 %************************************************************************
537 data AutoScc = NoSccs
538 | AddSccs Module (Id -> Bool)
539 -- The (Id->Bool) says which Ids to add SCCs to
541 addAutoScc :: AutoScc
544 -> CoreExpr -- Scc'd Rhs
546 addAutoScc NoSccs _ rhs
548 addAutoScc (AddSccs mod add_scc) id rhs
549 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
553 If profiling and dealing with a dict binding,
554 wrap the dict in @_scc_ DICT <dict>@:
557 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
558 addDictScc _ rhs = return rhs
560 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
561 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
562 || not (isDictId var)
563 = return rhs -- That's easy: do nothing
566 = do (mod, grp) <- getModuleAndGroupDs
567 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
568 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
573 %************************************************************************
577 %************************************************************************
581 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
582 dsCoercion WpHole thing_inside = thing_inside
583 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
584 dsCoercion (WpCast co) thing_inside = do { expr <- thing_inside
585 ; return (Cast expr co) }
586 dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside
587 ; return (Lam id expr) }
588 dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
589 ; return (Lam tv expr) }
590 dsCoercion (WpApp v) thing_inside
591 | isTyVar v = do { expr <- thing_inside
592 {- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) }
593 | otherwise = do { expr <- thing_inside
594 {- An Id -} ; return (App expr (Var v)) }
595 dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
596 ; return (App expr (Type ty)) }
597 dsCoercion WpInline thing_inside = do { expr <- thing_inside
598 ; return (mkInlineMe expr) }
599 dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs
600 ; expr <- thing_inside
601 ; return (Let (Rec prs) expr) }