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?
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
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).
175 (c) The result is *still* quadratic-sized if there are a lot of
176 small bindings. So if there are more than some small
177 number (10), we filter the binding set B by the free
178 variables of the particular RHS. Tiresome.
180 Why got to this trouble? It's a common case, and it removes the
181 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
182 compilation, especially in a case where there are a *lot* of
187 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
188 | opt_DsMultiTyVar -- This (static) debug flag just lets us
189 -- switch on and off this optimisation to
190 -- see if it has any impact; it is on by default
191 = -- Note [Abstracting over tyvars only]
192 do { core_prs <- ds_lhs_binds NoSccs binds
193 ; arby_env <- mkArbitraryTypeEnv tyvars exports
194 ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
195 bndrs = mkVarSet (map fst core_prs)
197 add_lets | core_prs `lengthExceeds` 10 = add_some
198 | otherwise = mkLets lg_binds
199 add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
200 , b `elemVarSet` fvs] rhs
202 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
204 env = mkABEnv exports
207 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
208 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
209 addInlinePrags prags gbl_id $
210 addAutoScc auto_scc gbl_id $
212 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
213 | tv <- tyvars, not (tv `elem` id_tvs)] $
216 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
217 (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
219 non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
221 ; return (core_prs' ++ rest) }
223 -- Another common case: one exported variable
224 -- Non-recursive bindings come through this way
225 dsHsBind auto_scc rest
226 (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
227 = ASSERT( all (`elem` tyvars) all_tyvars ) do
228 core_prs <- ds_lhs_binds NoSccs binds
230 -- Always treat the binds as recursive, because the typechecker
231 -- makes rather mixed-up dictionary bindings
232 core_bind = Rec core_prs
234 mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
236 (spec_binds, rules) = unzip (catMaybes mb_specs)
237 global' = addIdSpecialisations global rules
238 rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
239 bind = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
241 return (bind : spec_binds ++ rest)
243 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
244 = do { core_prs <- ds_lhs_binds NoSccs binds
245 ; let env = mkABEnv exports
246 do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
247 = addInlinePrags prags lcl_id $
248 addAutoScc auto_scc gbl_id rhs
249 | otherwise = (lcl_id,rhs)
251 -- Rec because of mixed-up dictionary bindings
252 core_bind = Rec (map do_one core_prs)
254 tup_expr = mkBigCoreVarTup locals
255 tup_ty = exprType tup_expr
256 poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
257 Let core_bind tup_expr
258 locals = [local | (_, _, local, _) <- exports]
259 local_tys = map idType locals
261 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
263 ; let dict_args = map Var dicts
265 mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
266 = -- Need to make fresh locals to bind in the selector, because
267 -- some of the tyvars will be bound to 'Any'
268 do { ty_args <- mapM mk_ty_arg all_tyvars
269 ; let substitute = substTyWith all_tyvars ty_args
270 ; locals' <- newSysLocalsDs (map substitute local_tys)
271 ; tup_id <- newSysLocalDs (substitute tup_ty)
272 ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
274 ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
275 global' = addIdSpecialisations global rules
276 rhs = mkLams tyvars $ mkLams dicts $
277 mkTupleSelector locals' (locals' !! n) tup_id $
278 mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
279 ; return ((global', rhs) : spec_binds) }
282 | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
283 | otherwise = dsMkArbitraryType all_tyvar
285 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
286 -- don't scc (auto-)annotate the tuple itself.
288 ; return ((poly_tup_id, poly_tup_expr) :
289 (concat export_binds_s ++ rest)) }
291 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
292 -- Takes the exports of a AbsBinds, and returns a mapping
293 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
294 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
297 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
298 -> Id -> Id -- Global, local
300 -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
301 CoreRule)) -- Rule for the Global Id
304 -- f :: (Eq a, Ix b) => a -> b -> b
305 -- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
307 -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
309 -- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
310 -- (forall b. Ix b => Int -> b -> b)
312 -- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
314 -- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
315 -- /\b.\(d:Ix b). in f Int b dInt d
316 -- The idea is that f occurs just once, so it'll be
317 -- inlined and specialised
319 -- Given SpecPrag (/\as.\ds. f es) t, we have
320 -- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
322 -- and the RULE forall as, ds. f es = f_spec as ds
324 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
325 -- (a bit silly, because then the
326 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
329 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
330 (L loc (SpecPrag spec_expr spec_ty inl))
332 do { let poly_name = idName poly_id
333 ; spec_name <- newLocalName poly_name
334 ; ds_spec_expr <- dsExpr spec_expr
335 ; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
336 -- The occurrence-analysis does two things
337 -- (a) identifies unused binders: Note [Unused spec binders]
338 -- (b) sorts dict bindings into NonRecs
339 -- so they can be inlined by decomposeRuleLhs
340 mb_lhs = decomposeRuleLhs body
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 }
348 Nothing -> do { warnDs decomp_msg; return Nothing }
350 Just (_, args) -> do {
352 f_body <- fix_up (Let mono_bind (Var mono_id))
354 ; let local_poly = setIdNotExported poly_id
355 -- Very important to make the 'f' non-exported,
356 -- else it won't be inlined!
357 spec_id = mkLocalId spec_name spec_ty
358 spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
359 poly_f_body = mkLams (tvs ++ dicts) f_body
361 extra_dict_bndrs = filter isDictId (varSetElems (exprFreeVars ds_spec_expr))
362 -- Note [Const rule dicts]
364 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
365 AlwaysActive poly_name
366 (extra_dict_bndrs ++ bndrs) args
367 (mkVarApps (Var spec_id) bndrs)
368 ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
371 -- Bind to Any any of all_ptvs that aren't
372 -- relevant for this particular function
373 fix_up body | null void_tvs = return body
374 | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
375 ; return (mkTyApps (mkLams void_tvs body) void_tys) }
377 void_tvs = all_tvs \\ tvs
379 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
380 <+> ptext (sLit "in specialied type:"),
381 nest 2 (pprTheta (map get_pred bs))]
382 , ptext (sLit "SPECIALISE pragma ignored")]
383 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
385 decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
388 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
389 -- If any of the tyvars is missing from any of the lists in
390 -- the second arg, return a binding in the result
391 mkArbitraryTypeEnv tyvars exports
392 = go emptyVarEnv exports
394 go env [] = return env
395 go env ((ltvs, _, _, _) : exports)
396 = do { env' <- foldlM extend env [tv | tv <- tyvars
397 , not (tv `elem` ltvs)
398 , not (tv `elemVarEnv` env)]
401 extend env tv = do { ty <- dsMkArbitraryType tv
402 ; return (extendVarEnv env tv ty) }
405 dsMkArbitraryType :: TcTyVar -> DsM Type
406 dsMkArbitraryType tv = mkArbitraryType warn tv
408 warn span msg = putSrcSpanDs span (warnDs msg)
411 Note [Unused spec binders]
412 ~~~~~~~~~~~~~~~~~~~~~~~~~~
415 {-# SPECIALISE f :: Eq a => a -> a #-}
416 It's true that this *is* a more specialised type, but the rule
417 we get is something like this:
420 Note that the rule is bogus, becuase it mentions a 'd' that is
421 not bound on the LHS! But it's a silly specialisation anyway, becuase
422 the constraint is unused. We could bind 'd' to (error "unused")
423 but it seems better to reject the program because it's almost certainly
424 a mistake. That's what the isDeadBinder call detects.
426 Note [Const rule dicts]
427 ~~~~~~~~~~~~~~~~~~~~~~~
428 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
429 which is presumably in scope at the function definition site, we can quantify
430 over it too. *Any* dict with that type will do.
432 So for example when you have
435 {-# SPECIALISE f :: Int -> Int #-}
437 Then we get the SpecPrag
438 SpecPrag (f Int dInt) Int
440 And from that we want the rule
442 RULE forall dInt. f Int dInt = f_spec
443 f_spec = let f = <rhs> in f Int dInt
447 %************************************************************************
449 \subsection{Adding inline pragmas}
451 %************************************************************************
454 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
455 -- Returns Nothing if the LHS isn't of the expected shape
457 = go emptyVarEnv (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict
458 -- bindings so we know if they are recursive
460 -- Substitute dicts in the LHS args, so that there
461 -- aren't any lets getting in the way
462 -- Note that we substitute the function too; we might have this as
463 -- a LHS: let f71 = M.f Int in f71
464 go env (Let (NonRec dict rhs) body)
465 = go (extendVarEnv env dict (simpleSubst env rhs)) body
467 = case collectArgs (simpleSubst env body) of
468 (Var fn, args) -> Just (fn, args)
471 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
472 -- Similar to CoreSubst.substExpr, except that
473 -- (a) Takes no account of capture; at this point there is no shadowing
474 -- (b) Can have a GlobalId (imported) in its domain
475 -- (c) Ids only; no types are substituted
476 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
477 -- in-scope set mentions all LocalIds mentioned in the argument of the subst
479 -- (b) and (d) are the reasons we can't use CoreSubst
481 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
482 -- look relevant here. Perhaps there was another caller of simpleSubst.)
484 simpleSubst subst expr
487 go (Var v) = lookupVarEnv subst v `orElse` Var v
488 go (Cast e co) = Cast (go e) co
489 go (Type ty) = Type ty
490 go (Lit lit) = Lit lit
491 go (App fun arg) = App (go fun) (go arg)
492 go (Note note e) = Note note (go e)
493 go (Lam bndr body) = Lam bndr (go body)
494 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
495 go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body)
496 go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
497 [(c,bs,go r) | (c,bs,r) <- alts]
499 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
500 addInlinePrags prags bndr rhs
501 = case [inl | L _ (InlinePrag inl) <- prags] of
503 (inl:_) -> addInlineInfo inl bndr rhs
505 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
506 addInlineInfo (Inline phase is_inline) bndr rhs
507 = (attach_phase bndr phase, wrap_inline is_inline rhs)
509 attach_phase bndr phase
510 | isAlwaysActive phase = bndr -- Default phase
511 | otherwise = bndr `setInlinePragma` phase
513 wrap_inline True body = mkInlineMe body
514 wrap_inline False body = body
518 %************************************************************************
520 \subsection[addAutoScc]{Adding automatic sccs}
522 %************************************************************************
525 data AutoScc = NoSccs
526 | AddSccs Module (Id -> Bool)
527 -- The (Id->Bool) says which Ids to add SCCs to
529 addAutoScc :: AutoScc
532 -> CoreExpr -- Scc'd Rhs
534 addAutoScc NoSccs _ rhs
536 addAutoScc (AddSccs mod add_scc) id rhs
537 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
541 If profiling and dealing with a dict binding,
542 wrap the dict in @_scc_ DICT <dict>@:
545 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
546 addDictScc _ rhs = return rhs
548 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
549 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
550 || not (isDictId var)
551 = return rhs -- That's easy: do nothing
554 = do (mod, grp) <- getModuleAndGroupDs
555 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
556 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
561 %************************************************************************
565 %************************************************************************
569 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
570 dsCoercion WpHole thing_inside = thing_inside
571 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
572 dsCoercion (WpCast co) thing_inside = do { expr <- thing_inside
573 ; return (Cast expr co) }
574 dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside
575 ; return (Lam id expr) }
576 dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
577 ; return (Lam tv expr) }
578 dsCoercion (WpApp id) thing_inside = do { expr <- thing_inside
579 ; return (App expr (Var id)) }
580 dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
581 ; return (App expr (Type ty)) }
582 dsCoercion WpInline thing_inside = do { expr <- thing_inside
583 ; return (mkInlineMe expr) }
584 dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs
585 ; expr <- thing_inside
586 ; return (Let (Rec prs) expr) }