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?
39 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
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 ; case (decomposeRuleLhs ds_spec_expr) of {
336 Nothing -> do { warnDs decomp_msg; return Nothing } ;
338 Just (bndrs, _fn, args) ->
340 -- Check for dead binders: Note [Unused spec binders]
341 case filter isDeadBinder bndrs of {
342 bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
345 { f_body <- fix_up (Let mono_bind (Var mono_id))
347 ; let local_poly = setIdNotExported poly_id
348 -- Very important to make the 'f' non-exported,
349 -- else it won't be inlined!
350 spec_id = mkLocalId spec_name spec_ty
351 spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
352 poly_f_body = mkLams (tvs ++ dicts) f_body
354 extra_dict_bndrs = [localiseId d -- See Note [Constant rule dicts]
355 | d <- varSetElems (exprFreeVars ds_spec_expr)
357 -- Note [Const rule dicts]
359 rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
360 AlwaysActive poly_name
361 (extra_dict_bndrs ++ bndrs) args
362 (mkVarApps (Var spec_id) bndrs)
363 ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
366 -- Bind to Any any of all_ptvs that aren't
367 -- relevant for this particular function
368 fix_up body | null void_tvs = return body
369 | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
370 ; return (mkTyApps (mkLams void_tvs body) void_tys) }
372 void_tvs = all_tvs \\ tvs
374 dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
375 <+> ptext (sLit "in specialied type:"),
376 nest 2 (pprTheta (map get_pred bs))]
377 , ptext (sLit "SPECIALISE pragma ignored")]
378 get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
380 decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
384 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
385 -- If any of the tyvars is missing from any of the lists in
386 -- the second arg, return a binding in the result
387 mkArbitraryTypeEnv tyvars exports
388 = go emptyVarEnv exports
390 go env [] = return env
391 go env ((ltvs, _, _, _) : exports)
392 = do { env' <- foldlM extend env [tv | tv <- tyvars
393 , not (tv `elem` ltvs)
394 , not (tv `elemVarEnv` env)]
397 extend env tv = do { ty <- dsMkArbitraryType tv
398 ; return (extendVarEnv env tv ty) }
401 dsMkArbitraryType :: TcTyVar -> DsM Type
402 dsMkArbitraryType tv = mkArbitraryType warn tv
404 warn span msg = putSrcSpanDs span (warnDs msg)
407 Note [Unused spec binders]
408 ~~~~~~~~~~~~~~~~~~~~~~~~~~
411 {-# SPECIALISE f :: Eq a => a -> a #-}
412 It's true that this *is* a more specialised type, but the rule
413 we get is something like this:
416 Note that the rule is bogus, becuase it mentions a 'd' that is
417 not bound on the LHS! But it's a silly specialisation anyway, becuase
418 the constraint is unused. We could bind 'd' to (error "unused")
419 but it seems better to reject the program because it's almost certainly
420 a mistake. That's what the isDeadBinder call detects.
422 Note [Const rule dicts]
423 ~~~~~~~~~~~~~~~~~~~~~~~
424 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
425 which is presumably in scope at the function definition site, we can quantify
426 over it too. *Any* dict with that type will do.
428 So for example when you have
431 {-# SPECIALISE f :: Int -> Int #-}
433 Then we get the SpecPrag
434 SpecPrag (f Int dInt) Int
436 And from that we want the rule
438 RULE forall dInt. f Int dInt = f_spec
439 f_spec = let f = <rhs> in f Int dInt
441 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
442 Name, and you can't bind them in a lambda or forall without getting things
443 confused. Hence the use of 'localiseId' to make it Internal.
446 %************************************************************************
448 \subsection{Adding inline pragmas}
450 %************************************************************************
453 decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
454 -- Take apart the LHS of a RULE. It's suuposed to look like
455 -- /\a. f a Int dOrdInt
456 -- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
457 -- That is, the RULE binders are lambda-bound
458 -- Returns Nothing if the LHS isn't of the expected shape
460 = case (decomp emptyVarEnv body) of
462 Just (fn, args) -> Just (bndrs, fn, args)
464 occ_lhs = occurAnalyseExpr lhs
465 -- The occurrence-analysis does two things
466 -- (a) identifies unused binders: Note [Unused spec binders]
467 -- (b) sorts dict bindings into NonRecs
468 -- so they can be inlined by 'decomp'
469 (bndrs, body) = collectBinders occ_lhs
471 -- Substitute dicts in the LHS args, so that there
472 -- aren't any lets getting in the way
473 -- Note that we substitute the function too; we might have this as
474 -- a LHS: let f71 = M.f Int in f71
475 decomp env (Let (NonRec dict rhs) body)
476 = decomp (extendVarEnv env dict (simpleSubst env rhs)) body
478 = case collectArgs (simpleSubst env body) of
479 (Var fn, args) -> Just (fn, args)
482 simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
483 -- Similar to CoreSubst.substExpr, except that
484 -- (a) Takes no account of capture; at this point there is no shadowing
485 -- (b) Can have a GlobalId (imported) in its domain
486 -- (c) Ids only; no types are substituted
487 -- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the
488 -- in-scope set mentions all LocalIds mentioned in the argument of the subst
490 -- (b) and (d) are the reasons we can't use CoreSubst
492 -- (I had a note that (b) is "no longer relevant", and indeed it doesn't
493 -- look relevant here. Perhaps there was another caller of simpleSubst.)
495 simpleSubst subst expr
498 go (Var v) = lookupVarEnv subst v `orElse` Var v
499 go (Cast e co) = Cast (go e) co
500 go (Type ty) = Type ty
501 go (Lit lit) = Lit lit
502 go (App fun arg) = App (go fun) (go arg)
503 go (Note note e) = Note note (go e)
504 go (Lam bndr body) = Lam bndr (go body)
505 go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
506 go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body)
507 go (Case scrut bndr ty alts) = Case (go scrut) bndr ty
508 [(c,bs,go r) | (c,bs,r) <- alts]
510 addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr)
511 addInlinePrags prags bndr rhs
512 = case [inl | L _ (InlinePrag inl) <- prags] of
514 (inl:_) -> addInlineInfo inl bndr rhs
516 addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
517 addInlineInfo (Inline phase is_inline) bndr rhs
518 = (attach_phase bndr phase, wrap_inline is_inline rhs)
520 attach_phase bndr phase
521 | isAlwaysActive phase = bndr -- Default phase
522 | otherwise = bndr `setInlinePragma` phase
524 wrap_inline True body = mkInlineMe body
525 wrap_inline False body = body
529 %************************************************************************
531 \subsection[addAutoScc]{Adding automatic sccs}
533 %************************************************************************
536 data AutoScc = NoSccs
537 | AddSccs Module (Id -> Bool)
538 -- The (Id->Bool) says which Ids to add SCCs to
540 addAutoScc :: AutoScc
543 -> CoreExpr -- Scc'd Rhs
545 addAutoScc NoSccs _ rhs
547 addAutoScc (AddSccs mod add_scc) id rhs
548 | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
552 If profiling and dealing with a dict binding,
553 wrap the dict in @_scc_ DICT <dict>@:
556 addDictScc :: Id -> CoreExpr -> DsM CoreExpr
557 addDictScc _ rhs = return rhs
559 {- DISABLED for now (need to somehow make up a name for the scc) -- SDM
560 | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
561 || not (isDictId var)
562 = return rhs -- That's easy: do nothing
565 = do (mod, grp) <- getModuleAndGroupDs
566 -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
567 return (Note (SCC (mkAllDictsCC mod grp False)) rhs)
572 %************************************************************************
576 %************************************************************************
580 dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
581 dsCoercion WpHole thing_inside = thing_inside
582 dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
583 dsCoercion (WpCast co) thing_inside = do { expr <- thing_inside
584 ; return (Cast expr co) }
585 dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside
586 ; return (Lam id expr) }
587 dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
588 ; return (Lam tv expr) }
589 dsCoercion (WpApp v) thing_inside
590 | isTyVar v = do { expr <- thing_inside
591 {- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) }
592 | otherwise = do { expr <- thing_inside
593 {- An Id -} ; return (App expr (Var v)) }
594 dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
595 ; return (App expr (Type ty)) }
596 dsCoercion WpInline thing_inside = do { expr <- thing_inside
597 ; return (mkInlineMe expr) }
598 dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs
599 ; expr <- thing_inside
600 ; return (Let (Rec prs) expr) }