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
32 import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
47 import BasicTypes hiding ( TopLevel )
49 import StaticFlags ( opt_DsMultiTyVar )
50 import Util ( mapSnd, mapAndUnzip, lengthExceeds )
56 %************************************************************************
58 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
60 %************************************************************************
63 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
64 dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
66 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
67 dsLHsBinds binds = ds_lhs_binds NoSccs binds
70 ------------------------
71 ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
72 -- scc annotation policy (see below)
73 ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds)
76 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
78 -> DsM [(Id,CoreExpr)] -- Result
79 dsLHsBind auto_scc rest (L loc bind)
80 = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
83 -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
85 -> DsM [(Id,CoreExpr)] -- Result
87 dsHsBind _ rest (VarBind var expr) = do
88 core_expr <- dsLExpr expr
90 -- Dictionary bindings are always VarMonoBinds, so
91 -- we only need do this here
92 core_expr' <- addDictScc var core_expr
93 return ((var, core_expr') : rest)
95 dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches,
96 fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do
97 (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
98 body' <- mkOptTickBox tick body
99 rhs <- dsCoercion co_fn (return (mkLams args body'))
100 return ((fun,rhs) : rest)
102 dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do
103 body_expr <- dsGuarded grhss ty
104 sel_binds <- mkSelectorBinds pat body_expr
105 return (sel_binds ++ rest)
107 {- Note [Rules and inlining]
108 ~~~~~~~~~~~~~~~~~~~~~~~~~
109 Common special case: no type or dictionary abstraction
110 This is a bit less trivial than you might suppose
111 The naive way woudl be to desguar to something like
112 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
113 M.f = f_lcl -- Generated from "exports"
114 But we don't want that, because if M.f isn't exported,
115 it'll be inlined unconditionally at every call site (its rhs is
116 trivial). That would be ok unless it has RULES, which would
117 thereby be completely lost. Bad, bad, bad.
119 Instead we want to generate
122 Now all is cool. The RULES are attached to M.f (by SimplCore),
123 and f_lcl is rapidly inlined away.
125 This does not happen in the same way to polymorphic binds,
126 because they desugar to
127 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
128 Although I'm a bit worried about whether full laziness might
129 float the f_lcl binding out and then inline M.f at its call site -}
131 dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
132 = do { core_prs <- ds_lhs_binds NoSccs binds
133 ; let env = mkABEnv exports
134 do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
135 = addInlinePrags prags gbl_id $
136 addAutoScc auto_scc gbl_id rhs
137 | otherwise = (lcl_id, rhs)
138 locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
139 -- Note [Rules and inlining]
140 ; return (map do_one core_prs ++ locals' ++ rest) }
141 -- No Rec needed here (contrast the other AbsBinds cases)
142 -- because we can rely on the enclosing dsBind to wrap in Rec
145 {- Note [Abstracting over tyvars only]
146 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
147 When abstracting over type variable only (not dictionaries), we don't really need to
148 built a tuple and select from it, as we do in the general case. Instead we can take
150 AbsBinds [a,b] [ ([a,b], fg, fl, _),
158 fg = /\ab. let B in e1
159 gg = /\b. let a = () in let B in S(e2)
160 h = /\ab. let B in e3
162 where B is the *non-recursive* binding
167 Notice (a) g has a different number of type variables to f, so we must
168 use the mkArbitraryType thing to fill in the gaps.
169 We use a type-let to do that.
171 (b) The local variable h isn't in the exports, and rather than
172 clone a fresh copy we simply replace h by (h a b).
174 (c) The result is *still* quadratic-sized if there are a lot of
175 small bindings. So if there are more than some small
176 number (10), we filter the binding set B by the free
177 variables of the particular RHS. Tiresome.
179 Why got to this trouble? It's a common case, and it removes the
180 quadratic-sized tuple desugaring. Less clutter, hopefullly faster
181 compilation, especially in a case where there are a *lot* of
186 dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
187 | opt_DsMultiTyVar -- This (static) debug flag just lets us
188 -- switch on and off this optimisation to
189 -- see if it has any impact; it is on by default
190 = -- Note [Abstracting over tyvars only]
191 do { core_prs <- ds_lhs_binds NoSccs binds
192 ; arby_env <- mkArbitraryTypeEnv tyvars exports
193 ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs
194 bndrs = mkVarSet (map fst core_prs)
196 add_lets | core_prs `lengthExceeds` 10 = add_some
197 | otherwise = mkLets lg_binds
198 add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds
199 , b `elemVarSet` fvs] rhs
201 fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs
203 env = mkABEnv exports
206 | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id
207 = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)),
208 addInlinePrags prags gbl_id $
209 addAutoScc auto_scc gbl_id $
211 mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv))
212 | tv <- tyvars, not (tv `elem` id_tvs)] $
215 = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)),
216 (non_exp_gbl_id, mkLams tyvars (add_lets rhs)))
218 non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id))
220 ; return (core_prs' ++ rest) }
222 -- Another common case: one exported variable
223 -- Non-recursive bindings come through this way
224 dsHsBind auto_scc rest
225 (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
226 = ASSERT( all (`elem` tyvars) all_tyvars ) do
227 core_prs <- ds_lhs_binds NoSccs binds
229 -- Always treat the binds as recursive, because the typechecker
230 -- makes rather mixed-up dictionary bindings
231 core_bind = Rec core_prs
233 mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags
235 (spec_binds, rules) = unzip (catMaybes mb_specs)
236 global' = addIdSpecialisations global rules
237 rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
238 bind = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
240 return (bind : spec_binds ++ rest)
242 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
243 = do { core_prs <- ds_lhs_binds NoSccs binds
244 ; let env = mkABEnv exports
245 do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id
246 = addInlinePrags prags lcl_id $
247 addAutoScc auto_scc gbl_id rhs
248 | otherwise = (lcl_id,rhs)
250 -- Rec because of mixed-up dictionary bindings
251 core_bind = Rec (map do_one core_prs)
253 tup_expr = mkBigCoreVarTup locals
254 tup_ty = exprType tup_expr
255 poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
256 Let core_bind tup_expr
257 locals = [local | (_, _, local, _) <- exports]
258 local_tys = map idType locals
260 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
262 ; let dict_args = map Var dicts
264 mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
265 = -- Need to make fresh locals to bind in the selector, because
266 -- some of the tyvars will be bound to 'Any'
267 do { ty_args <- mapM mk_ty_arg all_tyvars
268 ; let substitute = substTyWith all_tyvars ty_args
269 ; locals' <- newSysLocalsDs (map substitute local_tys)
270 ; tup_id <- newSysLocalDs (substitute tup_ty)
271 ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
273 ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
274 global' = addIdSpecialisations global rules
275 rhs = mkLams tyvars $ mkLams dicts $
276 mkTupleSelector locals' (locals' !! n) tup_id $
277 mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
278 ; return ((global', rhs) : spec_binds) }
281 | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
282 | otherwise = dsMkArbitraryType all_tyvar
284 ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
285 -- don't scc (auto-)annotate the tuple itself.
287 ; return ((poly_tup_id, poly_tup_expr) :
288 (concat export_binds_s ++ rest)) }
290 mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag])
291 -- Takes the exports of a AbsBinds, and returns a mapping
292 -- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
293 mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
296 dsSpec :: [TyVar] -> [DictId] -> [TyVar]
297 -> Id -> Id -- Global, local
299 -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
300 CoreRule)) -- Rule for the Global Id
303 -- f :: (Eq a, Ix b) => a -> b -> b
304 -- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
306 -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
308 -- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
309 -- (forall b. Ix b => Int -> b -> b)
311 -- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
313 -- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
314 -- /\b.\(d:Ix b). in f Int b dInt d
315 -- The idea is that f occurs just once, so it'll be
316 -- inlined and specialised
318 -- Given SpecPrag (/\as.\ds. f es) t, we have
319 -- the defn f_spec as ds = let-nonrec f = /\fas\fds. let f_mono = <f-rhs> in f_mono
321 -- and the RULE forall as, ds. f es = f_spec as ds
323 -- It is *possible* that 'es' does not mention all of the dictionaries 'ds'
324 -- (a bit silly, because then the
325 dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
328 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
329 (L loc (SpecPrag spec_expr spec_ty inl))
331 do { let poly_name = idName poly_id
332 ; spec_name <- newLocalName poly_name
333 ; ds_spec_expr <- dsExpr spec_expr
334 ; let (bndrs, body) = collectBinders (occurAnalyseExpr ds_spec_expr)
335 -- The occurrence-analysis does two things
336 -- (a) identifies unused binders: Note [Unused spec binders]
337 -- (b) sorts dict bindings into NonRecs
338 -- so they can be inlined by decomposeRuleLhs
339 mb_lhs = decomposeRuleLhs body
341 -- Check for dead binders: Note [Unused spec binders]
342 ; case filter isDeadBinder bndrs of {
343 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
347 Nothing -> do { warnDs decomp_msg; return Nothing }
349 Just (_, args) -> do {
351 f_body <- fix_up (Let mono_bind (Var mono_id))
353 ; let local_poly = setIdNotExported poly_id
354 -- Very important to make the 'f' non-exported,
355 -- else it won't be inlined!
356 spec_id = mkLocalId spec_name spec_ty
357 spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
358 poly_f_body = mkLams (tvs ++ dicts) f_body
360 extra_dict_bndrs = filter isDictId (varSetElems (exprFreeVars ds_spec_expr))
361 -- Note [Const rule dicts]
363 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
364 AlwaysActive poly_name
365 (extra_dict_bndrs ++ bndrs) args
366 (mkVarApps (Var spec_id) bndrs)
367 ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
370 -- Bind to Any any of all_ptvs that aren't
371 -- relevant for this particular function
372 fix_up body | null void_tvs = return body
373 | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
374 ; return (mkTyApps (mkLams void_tvs body) void_tys) }
376 void_tvs = all_tvs \\ tvs
378 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
379 <+> ptext (sLit "in specialied type:"),
380 nest 2 (pprTheta (map get_pred bs))]
381 , ptext (sLit "SPECIALISE pragma ignored")]
382 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
384 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
446 %************************************************************************
448 \subsection{Adding inline pragmas}
450 %************************************************************************
453 decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
454 -- Returns Nothing if the LHS isn't of the expected shape
456 = go emptyVarEnv (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict
457 -- bindings so we know if they are recursive
459 -- Substitute dicts in the LHS args, so that there
460 -- aren't any lets getting in the way
461 -- Note that we substitute the function too; we might have this as
462 -- a LHS: let f71 = M.f Int in f71
463 go env (Let (NonRec dict rhs) body)
464 = go (extendVarEnv env dict (simpleSubst env rhs)) body
466 = case collectArgs (simpleSubst env body) of
467 (Var fn, args) -> Just (fn, args)
470 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
471 -- Similar to CoreSubst.substExpr, except that
472 -- (a) Takes no account of capture; at this point there is no shadowing
473 -- (b) Can have a GlobalId (imported) in its domain
474 -- (c) Ids only; no types are substituted
475 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
476 -- in-scope set mentions all LocalIds mentioned in the argument of the subst
478 -- (b) and (d) are the reasons we can't use CoreSubst
480 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
481 -- look relevant here. Perhaps there was another caller of simpleSubst.)
483 simpleSubst subst expr
486 go (Var v) = lookupVarEnv subst v `orElse` Var v
487 go (Cast e co) = Cast (go e) co
488 go (Type ty) = Type ty
489 go (Lit lit) = Lit lit
490 go (App fun arg) = App (go fun) (go arg)
491 go (Note note e) = Note note (go e)
492 go (Lam bndr body) = Lam bndr (go body)
493 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
494 go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body)
495 go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
496 [(c,bs,go r) | (c,bs,r) <- alts]
498 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
499 addInlinePrags prags bndr rhs
500 = case [inl | L _ (InlinePrag inl) <- prags] of
502 (inl:_) -> addInlineInfo inl bndr rhs
504 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
505 addInlineInfo (Inline phase is_inline) bndr rhs
506 = (attach_phase bndr phase, wrap_inline is_inline rhs)
508 attach_phase bndr phase
509 | isAlwaysActive phase = bndr -- Default phase
510 | otherwise = bndr `setInlinePragma` phase
512 wrap_inline True body = mkInlineMe body
513 wrap_inline False body = body
517 %************************************************************************
519 \subsection[addAutoScc]{Adding automatic sccs}
521 %************************************************************************
524 data AutoScc = NoSccs
525 | AddSccs Module (Id -> Bool)
526 -- The (Id->Bool) says which Ids to add SCCs to
528 addAutoScc :: AutoScc
531 -> CoreExpr -- Scc'd Rhs
533 addAutoScc NoSccs _ rhs
535 addAutoScc (AddSccs mod add_scc) id rhs
536 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
540 If profiling and dealing with a dict binding,
541 wrap the dict in @_scc_ DICT <dict>@:
544 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
545 addDictScc _ rhs = return rhs
547 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
548 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
549 || not (isDictId var)
550 = return rhs -- That's easy: do nothing
553 = do (mod, grp) <- getModuleAndGroupDs
554 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
555 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
560 %************************************************************************
564 %************************************************************************
568 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
569 dsCoercion WpHole thing_inside = thing_inside
570 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
571 dsCoercion (WpCast co) thing_inside = do { expr <- thing_inside
572 ; return (Cast expr co) }
573 dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside
574 ; return (Lam id expr) }
575 dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
576 ; return (Lam tv expr) }
577 dsCoercion (WpApp id) thing_inside = do { expr <- thing_inside
578 ; return (App expr (Var id)) }
579 dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
580 ; return (App expr (Type ty)) }
581 dsCoercion WpInline thing_inside = do { expr <- thing_inside
582 ; return (mkInlineMe expr) }
583 dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs
584 ; expr <- thing_inside
585 ; return (Let (Rec prs) expr) }