Major patch to add -fwarn-redundant-constraints
[ghc.git] / compiler / deSugar / DsBinds.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Pattern-matching bindings (HsBinds and MonoBinds)
7
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).
11 -}
12
13 {-# LANGUAGE CPP #-}
14
15 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
16 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
17 ) where
18
19 #include "HsVersions.h"
20
21 import {-# SOURCE #-} DsExpr( dsLExpr )
22 import {-# SOURCE #-} Match( matchWrapper )
23
24 import DsMonad
25 import DsGRHSs
26 import DsUtils
27
28 import HsSyn -- lots of things
29 import CoreSyn -- lots of things
30 import Literal ( Literal(MachStr) )
31 import CoreSubst
32 import OccurAnal ( occurAnalyseExpr )
33 import MkCore
34 import CoreUtils
35 import CoreArity ( etaExpand )
36 import CoreUnfold
37 import CoreFVs
38 import UniqSupply
39 import Unique( Unique )
40 import Digraph
41
42
43 import TyCon ( isTupleTyCon, tyConDataCons_maybe )
44 import TcEvidence
45 import TcType
46 import Type
47 import Coercion hiding (substCo)
48 import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
49 import Id
50 import Class
51 import DataCon ( dataConWorkId )
52 import Name
53 import MkId ( seqId )
54 import IdInfo ( IdDetails(..) )
55 import Var
56 import VarSet
57 import Rules
58 import VarEnv
59 import Outputable
60 import SrcLoc
61 import Maybes
62 import OrdList
63 import Bag
64 import BasicTypes hiding ( TopLevel )
65 import DynFlags
66 import FastString
67 import ErrUtils( MsgDoc )
68 import ListSetOps( getNth )
69 import Util
70 import Control.Monad( when )
71 import MonadUtils
72 import Control.Monad(liftM)
73
74 {-
75 ************************************************************************
76 * *
77 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
78 * *
79 ************************************************************************
80 -}
81
82 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
83 dsTopLHsBinds binds = ds_lhs_binds binds
84
85 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
86 dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
87 ; return (fromOL binds') }
88
89 ------------------------
90 ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
91
92 ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
93 ; return (foldBag appOL id nilOL ds_bs) }
94
95 dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
96 dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind
97
98 dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
99
100 dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
101 = do { dflags <- getDynFlags
102 ; core_expr <- dsLExpr expr
103
104 -- Dictionary bindings are always VarBinds,
105 -- so we only need do this here
106 ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
107 | otherwise = var
108
109 ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
110
111 dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
112 , fun_co_fn = co_fn, fun_tick = tick
113 , fun_infix = inf })
114 = do { dflags <- getDynFlags
115 ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
116 ; let body' = mkOptTickBox tick body
117 ; rhs <- dsHsWrapper co_fn (mkLams args body')
118 ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
119 return (unitOL (makeCorePair dflags fun False 0 rhs)) }
120
121 dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
122 , pat_ticks = (rhs_tick, var_ticks) })
123 = do { body_expr <- dsGuarded grhss ty
124 ; let body' = mkOptTickBox rhs_tick body_expr
125 ; sel_binds <- mkSelectorBinds var_ticks pat body'
126 -- We silently ignore inline pragmas; no makeCorePair
127 -- Not so cool, but really doesn't matter
128 ; return (toOL sel_binds) }
129
130 -- A common case: one exported variable
131 -- Non-recursive bindings come through this way
132 -- So do self-recursive bindings, and recursive bindings
133 -- that have been chopped up with type signatures
134 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
135 , abs_exports = [export]
136 , abs_ev_binds = ev_binds, abs_binds = binds })
137 | ABE { abe_wrap = wrap, abe_poly = global
138 , abe_mono = local, abe_prags = prags } <- export
139 = do { dflags <- getDynFlags
140 ; bind_prs <- ds_lhs_binds binds
141 ; let core_bind = Rec (fromOL bind_prs)
142 ; ds_binds <- dsTcEvBinds_s ev_binds
143 ; rhs <- dsHsWrapper wrap $ -- Usually the identity
144 mkLams tyvars $ mkLams dicts $
145 mkCoreLets ds_binds $
146 Let core_bind $
147 Var local
148
149 ; (spec_binds, rules) <- dsSpecs rhs prags
150
151 ; let global' = addIdSpecialisations global rules
152 main_bind = makeCorePair dflags global' (isDefaultMethod prags)
153 (dictArity dicts) rhs
154
155 ; return (main_bind `consOL` spec_binds) }
156
157 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
158 , abs_exports = exports, abs_ev_binds = ev_binds
159 , abs_binds = binds })
160 -- See Note [Desugaring AbsBinds]
161 = do { dflags <- getDynFlags
162 ; bind_prs <- ds_lhs_binds binds
163 ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
164 | (lcl_id, rhs) <- fromOL bind_prs ]
165 -- Monomorphic recursion possible, hence Rec
166
167 locals = map abe_mono exports
168 tup_expr = mkBigCoreVarTup locals
169 tup_ty = exprType tup_expr
170 ; ds_binds <- dsTcEvBinds_s ev_binds
171 ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
172 mkCoreLets ds_binds $
173 Let core_bind $
174 tup_expr
175
176 ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
177
178 ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
179 , abe_mono = local, abe_prags = spec_prags })
180 = do { tup_id <- newSysLocalDs tup_ty
181 ; rhs <- dsHsWrapper wrap $
182 mkLams tyvars $ mkLams dicts $
183 mkTupleSelector locals local tup_id $
184 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
185 ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
186 ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
187 ; let global' = (global `setInlinePragma` defaultInlinePragma)
188 `addIdSpecialisations` rules
189 -- Kill the INLINE pragma because it applies to
190 -- the user written (local) function. The global
191 -- Id is just the selector. Hmm.
192 ; return ((global', rhs) `consOL` spec_binds) }
193
194 ; export_binds_s <- mapM mk_bind exports
195
196 ; return ((poly_tup_id, poly_tup_rhs) `consOL`
197 concatOL export_binds_s) }
198 where
199 inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
200 -- the inline pragma from the source
201 -- The type checker put the inline pragma
202 -- on the *global* Id, so we need to transfer it
203 inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
204 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
205 , let prag = idInlinePragma gbl_id ]
206
207 add_inline :: Id -> Id -- tran
208 add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
209
210 dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"
211
212 ------------------------
213 makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
214 makeCorePair dflags gbl_id is_default_method dict_arity rhs
215 | is_default_method -- Default methods are *always* inlined
216 = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
217
218 | DFunId is_newtype <- idDetails gbl_id
219 = (mk_dfun_w_stuff is_newtype, rhs)
220
221 | otherwise
222 = case inlinePragmaSpec inline_prag of
223 EmptyInlineSpec -> (gbl_id, rhs)
224 NoInline -> (gbl_id, rhs)
225 Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
226 Inline -> inline_pair
227
228 where
229 inline_prag = idInlinePragma gbl_id
230 inlinable_unf = mkInlinableUnfolding dflags rhs
231 inline_pair
232 | Just arity <- inlinePragmaSat inline_prag
233 -- Add an Unfolding for an INLINE (but not for NOINLINE)
234 -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
235 , let real_arity = dict_arity + arity
236 -- NB: The arity in the InlineRule takes account of the dictionaries
237 = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
238 , etaExpand real_arity rhs)
239
240 | otherwise
241 = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
242 (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
243
244 -- See Note [ClassOp/DFun selection] in TcInstDcls
245 -- See Note [Single-method classes] in TcInstDcls
246 mk_dfun_w_stuff is_newtype
247 | is_newtype
248 = gbl_id `setIdUnfolding` mkInlineUnfolding (Just 0) rhs
249 `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
250 | otherwise
251 = gbl_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dfun_constr dfun_args
252 `setInlinePragma` dfunInlinePragma
253 (dfun_bndrs, dfun_body) = collectBinders (simpleOptExpr rhs)
254 (dfun_con, dfun_args) = collectArgs dfun_body
255 dfun_constr | Var id <- dfun_con
256 , DataConWorkId con <- idDetails id
257 = con
258 | otherwise = pprPanic "makeCorePair: dfun" (ppr rhs)
259
260
261 dictArity :: [Var] -> Arity
262 -- Don't count coercion variables in arity
263 dictArity dicts = count isId dicts
264
265 {-
266 [Desugaring AbsBinds]
267 ~~~~~~~~~~~~~~~~~~~~~
268 In the general AbsBinds case we desugar the binding to this:
269
270 tup a (d:Num a) = let fm = ...gm...
271 gm = ...fm...
272 in (fm,gm)
273 f a d = case tup a d of { (fm,gm) -> fm }
274 g a d = case tup a d of { (fm,gm) -> fm }
275
276 Note [Rules and inlining]
277 ~~~~~~~~~~~~~~~~~~~~~~~~~
278 Common special case: no type or dictionary abstraction
279 This is a bit less trivial than you might suppose
280 The naive way woudl be to desguar to something like
281 f_lcl = ...f_lcl... -- The "binds" from AbsBinds
282 M.f = f_lcl -- Generated from "exports"
283 But we don't want that, because if M.f isn't exported,
284 it'll be inlined unconditionally at every call site (its rhs is
285 trivial). That would be ok unless it has RULES, which would
286 thereby be completely lost. Bad, bad, bad.
287
288 Instead we want to generate
289 M.f = ...f_lcl...
290 f_lcl = M.f
291 Now all is cool. The RULES are attached to M.f (by SimplCore),
292 and f_lcl is rapidly inlined away.
293
294 This does not happen in the same way to polymorphic binds,
295 because they desugar to
296 M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
297 Although I'm a bit worried about whether full laziness might
298 float the f_lcl binding out and then inline M.f at its call site
299
300 Note [Specialising in no-dict case]
301 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
302 Even if there are no tyvars or dicts, we may have specialisation pragmas.
303 Class methods can generate
304 AbsBinds [] [] [( ... spec-prag]
305 { AbsBinds [tvs] [dicts] ...blah }
306 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
307
308 class (Real a, Fractional a) => RealFrac a where
309 round :: (Integral b) => a -> b
310
311 instance RealFrac Float where
312 {-# SPECIALIZE round :: Float -> Int #-}
313
314 The top-level AbsBinds for $cround has no tyvars or dicts (because the
315 instance does not). But the method is locally overloaded!
316
317 Note [Abstracting over tyvars only]
318 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
319 When abstracting over type variable only (not dictionaries), we don't really need to
320 built a tuple and select from it, as we do in the general case. Instead we can take
321
322 AbsBinds [a,b] [ ([a,b], fg, fl, _),
323 ([b], gg, gl, _) ]
324 { fl = e1
325 gl = e2
326 h = e3 }
327
328 and desugar it to
329
330 fg = /\ab. let B in e1
331 gg = /\b. let a = () in let B in S(e2)
332 h = /\ab. let B in e3
333
334 where B is the *non-recursive* binding
335 fl = fg a b
336 gl = gg b
337 h = h a b -- See (b); note shadowing!
338
339 Notice (a) g has a different number of type variables to f, so we must
340 use the mkArbitraryType thing to fill in the gaps.
341 We use a type-let to do that.
342
343 (b) The local variable h isn't in the exports, and rather than
344 clone a fresh copy we simply replace h by (h a b), where
345 the two h's have different types! Shadowing happens here,
346 which looks confusing but works fine.
347
348 (c) The result is *still* quadratic-sized if there are a lot of
349 small bindings. So if there are more than some small
350 number (10), we filter the binding set B by the free
351 variables of the particular RHS. Tiresome.
352
353 Why got to this trouble? It's a common case, and it removes the
354 quadratic-sized tuple desugaring. Less clutter, hopefully faster
355 compilation, especially in a case where there are a *lot* of
356 bindings.
357
358
359 Note [Eta-expanding INLINE things]
360 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
361 Consider
362 foo :: Eq a => a -> a
363 {-# INLINE foo #-}
364 foo x = ...
365
366 If (foo d) ever gets floated out as a common sub-expression (which can
367 happen as a result of method sharing), there's a danger that we never
368 get to do the inlining, which is a Terribly Bad thing given that the
369 user said "inline"!
370
371 To avoid this we pre-emptively eta-expand the definition, so that foo
372 has the arity with which it is declared in the source code. In this
373 example it has arity 2 (one for the Eq and one for x). Doing this
374 should mean that (foo d) is a PAP and we don't share it.
375
376 Note [Nested arities]
377 ~~~~~~~~~~~~~~~~~~~~~
378 For reasons that are not entirely clear, method bindings come out looking like
379 this:
380
381 AbsBinds [] [] [$cfromT <= [] fromT]
382 $cfromT [InlPrag=INLINE] :: T Bool -> Bool
383 { AbsBinds [] [] [fromT <= [] fromT_1]
384 fromT :: T Bool -> Bool
385 { fromT_1 ((TBool b)) = not b } } }
386
387 Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
388 gotten from the binding for fromT_1.
389
390 It might be better to have just one level of AbsBinds, but that requires more
391 thought!
392
393 Note [Implementing SPECIALISE pragmas]
394 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
395 Example:
396 f :: (Eq a, Ix b) => a -> b -> Bool
397 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
398 f = <poly_rhs>
399
400 From this the typechecker generates
401
402 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
403
404 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
405 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
406
407 Note that wrap_fn can transform *any* function with the right type prefix
408 forall ab. (Eq a, Ix b) => XXX
409 regardless of XXX. It's sort of polymorphic in XXX. This is
410 useful: we use the same wrapper to transform each of the class ops, as
411 well as the dict.
412
413 From these we generate:
414
415 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
416 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
417
418 Spec bind: f_spec = wrap_fn <poly_rhs>
419
420 Note that
421
422 * The LHS of the rule may mention dictionary *expressions* (eg
423 $dfIxPair dp dq), and that is essential because the dp, dq are
424 needed on the RHS.
425
426 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
427 can fully specialise it.
428 -}
429
430 ------------------------
431 dsSpecs :: CoreExpr -- Its rhs
432 -> TcSpecPrags
433 -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
434 , [CoreRule] ) -- Rules for the Global Ids
435 -- See Note [Implementing SPECIALISE pragmas]
436 dsSpecs _ IsDefaultMethod = return (nilOL, [])
437 dsSpecs poly_rhs (SpecPrags sps)
438 = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
439 ; let (spec_binds_s, rules) = unzip pairs
440 ; return (concatOL spec_binds_s, rules) }
441
442 dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
443 -- Nothing => RULE is for an imported Id
444 -- rhs is in the Id's unfolding
445 -> Located TcSpecPrag
446 -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
447 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
448 | isJust (isClassOpId_maybe poly_id)
449 = putSrcSpanDs loc $
450 do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
451 <+> quotes (ppr poly_id))
452 ; return Nothing } -- There is no point in trying to specialise a class op
453 -- Moreover, classops don't (currently) have an inl_sat arity set
454 -- (it would be Just 0) and that in turn makes makeCorePair bleat
455
456 | no_act_spec && isNeverActive rule_act
457 = putSrcSpanDs loc $
458 do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
459 <+> quotes (ppr poly_id))
460 ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that
461 -- See Note [Activation pragmas for SPECIALISE]
462
463 | otherwise
464 = putSrcSpanDs loc $
465 do { uniq <- newUnique
466 ; let poly_name = idName poly_id
467 spec_occ = mkSpecOcc (getOccName poly_name)
468 spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
469 ; (bndrs, ds_lhs) <- liftM collectBinders
470 (dsHsWrapper spec_co (Var poly_id))
471 ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
472 ; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id
473 -- , ptext (sLit "spec_co:") <+> ppr spec_co
474 -- , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $
475 case decomposeRuleLhs bndrs ds_lhs of {
476 Left msg -> do { warnDs msg; return Nothing } ;
477 Right (rule_bndrs, _fn, args) -> do
478
479 { dflags <- getDynFlags
480 ; let fn_unf = realIdUnfolding poly_id
481 unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet
482 in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
483 spec_unf = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf
484 spec_id = mkLocalId spec_name spec_ty
485 `setInlinePragma` inl_prag
486 `setIdUnfolding` spec_unf
487 rule = mkRule False {- Not auto -} is_local_id
488 (mkFastString ("SPEC " ++ showPpr dflags poly_name))
489 rule_act poly_name
490 rule_bndrs args
491 (mkVarApps (Var spec_id) bndrs)
492
493 ; spec_rhs <- dsHsWrapper spec_co poly_rhs
494
495 ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
496 (warnDs (specOnInline poly_name))
497
498 ; return (Just (unitOL (spec_id, spec_rhs), rule))
499 -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
500 -- makeCorePair overwrites the unfolding, which we have
501 -- just created using specUnfolding
502 } } }
503 where
504 is_local_id = isJust mb_poly_rhs
505 poly_rhs | Just rhs <- mb_poly_rhs
506 = rhs -- Local Id; this is its rhs
507 | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
508 = unfolding -- Imported Id; this is its unfolding
509 -- Use realIdUnfolding so we get the unfolding
510 -- even when it is a loop breaker.
511 -- We want to specialise recursive functions!
512 | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
513 -- The type checker has checked that it *has* an unfolding
514
515 id_inl = idInlinePragma poly_id
516
517 -- See Note [Activation pragmas for SPECIALISE]
518 inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
519 | not is_local_id -- See Note [Specialising imported functions]
520 -- in OccurAnal
521 , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
522 | otherwise = id_inl
523 -- Get the INLINE pragma from SPECIALISE declaration, or,
524 -- failing that, from the original Id
525
526 spec_prag_act = inlinePragmaActivation spec_inl
527
528 -- See Note [Activation pragmas for SPECIALISE]
529 -- no_act_spec is True if the user didn't write an explicit
530 -- phase specification in the SPECIALISE pragma
531 no_act_spec = case inlinePragmaSpec spec_inl of
532 NoInline -> isNeverActive spec_prag_act
533 _ -> isAlwaysActive spec_prag_act
534 rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
535 | otherwise = spec_prag_act -- Specified by user
536
537
538 specOnInline :: Name -> MsgDoc
539 specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
540 <+> quotes (ppr f)
541
542 {-
543 Note [Activation pragmas for SPECIALISE]
544 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
545 From a user SPECIALISE pragma for f, we generate
546 a) A top-level binding spec_fn = rhs
547 b) A RULE f dOrd = spec_fn
548
549 We need two pragma-like things:
550
551 * spec_fn's inline pragma: inherited from f's inline pragma (ignoring
552 activation on SPEC), unless overriden by SPEC INLINE
553
554 * Activation of RULE: from SPECIALISE pragma (if activation given)
555 otherwise from f's inline pragma
556
557 This is not obvious (see Trac #5237)!
558
559 Examples Rule activation Inline prag on spec'd fn
560 ---------------------------------------------------------------------
561 SPEC [n] f :: ty [n] Always, or NOINLINE [n]
562 copy f's prag
563
564 NOINLINE f
565 SPEC [n] f :: ty [n] NOINLINE
566 copy f's prag
567
568 NOINLINE [k] f
569 SPEC [n] f :: ty [n] NOINLINE [k]
570 copy f's prag
571
572 INLINE [k] f
573 SPEC [n] f :: ty [n] INLINE [k]
574 copy f's prag
575
576 SPEC INLINE [n] f :: ty [n] INLINE [n]
577 (ignore INLINE prag on f,
578 same activation for rule and spec'd fn)
579
580 NOINLINE [k] f
581 SPEC f :: ty [n] INLINE [k]
582
583
584 ************************************************************************
585 * *
586 \subsection{Adding inline pragmas}
587 * *
588 ************************************************************************
589 -}
590
591 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
592 -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
593 -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
594 -- may add some extra dictionary binders (see Note [Free dictionaries])
595 --
596 -- Returns Nothing if the LHS isn't of the expected shape
597 -- Note [Decomposing the left-hand side of a RULE]
598 decomposeRuleLhs orig_bndrs orig_lhs
599 | not (null unbound) -- Check for things unbound on LHS
600 -- See Note [Unused spec binders]
601 = Left (vcat (map dead_msg unbound))
602
603 | Var fn_var <- fun
604 , not (fn_var `elemVarSet` orig_bndr_set)
605 = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs
606 -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs
607 -- , ptext (sLit "lhs1:") <+> ppr lhs1
608 -- , ptext (sLit "bndrs1:") <+> ppr bndrs1
609 -- , ptext (sLit "fn_var:") <+> ppr fn_var
610 -- , ptext (sLit "args:") <+> ppr args]) $
611 Right (bndrs1, fn_var, args)
612
613 | Case scrut bndr ty [(DEFAULT, _, body)] <- fun
614 , isDeadBinder bndr -- Note [Matching seqId]
615 , let args' = [Type (idType bndr), Type ty, scrut, body]
616 = Right (bndrs1, seqId, args' ++ args)
617
618 | otherwise
619 = Left bad_shape_msg
620 where
621 lhs1 = drop_dicts orig_lhs
622 lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS]
623 (fun,args) = collectArgs lhs2
624 lhs_fvs = exprFreeVars lhs2
625 unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
626 bndrs1 = orig_bndrs ++ extra_dict_bndrs
627
628 orig_bndr_set = mkVarSet orig_bndrs
629
630 -- Add extra dict binders: Note [Free dictionaries]
631 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
632 | d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs)
633 , isDictId d ]
634
635 bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
636 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
637 , text "Orig lhs:" <+> ppr orig_lhs])
638 dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
639 , ptext (sLit "is not bound in RULE lhs")])
640 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
641 , text "Orig lhs:" <+> ppr orig_lhs
642 , text "optimised lhs:" <+> ppr lhs2 ])
643 pp_bndr bndr
644 | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)
645 | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
646 | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
647
648 drop_dicts :: CoreExpr -> CoreExpr
649 drop_dicts e
650 = wrap_lets needed bnds body
651 where
652 needed = orig_bndr_set `minusVarSet` exprFreeVars body
653 (bnds, body) = split_lets (occurAnalyseExpr e)
654 -- The occurAnalyseExpr drops dead bindings which is
655 -- crucial to ensure that every binding is used later;
656 -- which in turn makes wrap_lets work right
657
658 split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
659 split_lets e
660 | Let (NonRec d r) body <- e
661 , isDictId d
662 , (bs, body') <- split_lets body
663 = ((d,r):bs, body')
664 | otherwise
665 = ([], e)
666
667 wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
668 wrap_lets _ [] body = body
669 wrap_lets needed ((d, r) : bs) body
670 | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body)
671 | otherwise = wrap_lets needed bs body
672 where
673 rhs_fvs = exprFreeVars r
674 needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
675
676 {-
677 Note [Decomposing the left-hand side of a RULE]
678 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
679 There are several things going on here.
680 * drop_dicts: see Note [Drop dictionary bindings on rule LHS]
681 * simpleOptExpr: see Note [Simplify rule LHS]
682 * extra_dict_bndrs: see Note [Free dictionaries]
683
684 Note [Drop dictionary bindings on rule LHS]
685 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
686 drop_dicts drops dictionary bindings on the LHS where possible.
687 E.g. let d:Eq [Int] = $fEqList $fEqInt in f d
688 --> f d
689 Reasoning here is that there is only one d:Eq [Int], and so we can
690 quantify over it. That makes 'd' free in the LHS, but that is later
691 picked up by extra_dict_bndrs (Note [Dead spec binders]).
692
693 NB 1: We can only drop the binding if the RHS doesn't bind
694 one of the orig_bndrs, which we assume occur on RHS.
695 Example
696 f :: (Eq a) => b -> a -> a
697 {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
698 Here we want to end up with
699 RULE forall d:Eq a. f ($dfEqList d) = f_spec d
700 Of course, the ($dfEqlist d) in the pattern makes it less likely
701 to match, but ther is no other way to get d:Eq a
702
703 NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
704 the evidence bindings to be wrapped around the outside of the
705 LHS. (After simplOptExpr they'll usually have been inlined.)
706 dsHsWrapper does dependency analysis, so that civilised ones
707 will be simple NonRec bindings. We don't handle recursive
708 dictionaries!
709
710 NB3: In the common case of a non-overloaded, but perhaps-polymorphic
711 specialisation, we don't need to bind *any* dictionaries for use
712 in the RHS. For example (Trac #8331)
713 {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
714 useAbstractMonad :: MonadAbstractIOST m => m Int
715 Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
716 but the RHS uses no dictionaries, so we want to end up with
717 RULE forall s (d :: MonadBstractIOST (ReaderT s)).
718 useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
719
720 Trac #8848 is a good example of where there are some intersting
721 dictionary bindings to discard.
722
723 The drop_dicts algorithm is based on these observations:
724
725 * Given (let d = rhs in e) where d is a DictId,
726 matching 'e' will bind e's free variables.
727
728 * So we want to keep the binding if one of the needed variables (for
729 which we need a binding) is in fv(rhs) but not already in fv(e).
730
731 * The "needed variables" are simply the orig_bndrs. Consider
732 f :: (Eq a, Show b) => a -> b -> String
733 ... SPECIALISE f :: (Show b) => Int -> b -> String ...
734 Then orig_bndrs includes the *quantified* dictionaries of the type
735 namely (dsb::Show b), but not the one for Eq Int
736
737 So we work inside out, applying the above criterion at each step.
738
739
740 Note [Simplify rule LHS]
741 ~~~~~~~~~~~~~~~~~~~~~~~~
742 simplOptExpr occurrence-analyses and simplifies the LHS:
743
744 (a) Inline any remaining dictionary bindings (which hopefully
745 occur just once)
746
747 (b) Substitute trivial lets so that they don't get in the way
748 Note that we substitute the function too; we might
749 have this as a LHS: let f71 = M.f Int in f71
750
751 (c) Do eta reduction. To see why, consider the fold/build rule,
752 which without simplification looked like:
753 fold k z (build (/\a. g a)) ==> ...
754 This doesn't match unless you do eta reduction on the build argument.
755 Similarly for a LHS like
756 augment g (build h)
757 we do not want to get
758 augment (\a. g a) (build h)
759 otherwise we don't match when given an argument like
760 augment (\a. h a a) (build h)
761
762 Note [Matching seqId]
763 ~~~~~~~~~~~~~~~~~~~
764 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
765 and this code turns it back into an application of seq!
766 See Note [Rules for seq] in MkId for the details.
767
768 Note [Unused spec binders]
769 ~~~~~~~~~~~~~~~~~~~~~~~~~~
770 Consider
771 f :: a -> a
772 ... SPECIALISE f :: Eq a => a -> a ...
773 It's true that this *is* a more specialised type, but the rule
774 we get is something like this:
775 f_spec d = f
776 RULE: f = f_spec d
777 Note that the rule is bogus, because it mentions a 'd' that is
778 not bound on the LHS! But it's a silly specialisation anyway, because
779 the constraint is unused. We could bind 'd' to (error "unused")
780 but it seems better to reject the program because it's almost certainly
781 a mistake. That's what the isDeadBinder call detects.
782
783 Note [Free dictionaries]
784 ~~~~~~~~~~~~~~~~~~~~~~~~
785 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
786 which is presumably in scope at the function definition site, we can quantify
787 over it too. *Any* dict with that type will do.
788
789 So for example when you have
790 f :: Eq a => a -> a
791 f = <rhs>
792 ... SPECIALISE f :: Int -> Int ...
793
794 Then we get the SpecPrag
795 SpecPrag (f Int dInt)
796
797 And from that we want the rule
798
799 RULE forall dInt. f Int dInt = f_spec
800 f_spec = let f = <rhs> in f Int dInt
801
802 But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
803 Name, and you can't bind them in a lambda or forall without getting things
804 confused. Likewise it might have an InlineRule or something, which would be
805 utterly bogus. So we really make a fresh Id, with the same unique and type
806 as the old one, but with an Internal name and no IdInfo.
807
808
809 ************************************************************************
810 * *
811 Desugaring evidence
812 * *
813 ************************************************************************
814
815 -}
816
817 dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
818 dsHsWrapper WpHole e = return e
819 dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
820 dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
821 return (mkCoreLets bs e)
822 dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
823 ; dsHsWrapper c1 e1 }
824 dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
825 ; e1 <- dsHsWrapper c1 (Var x)
826 ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
827 ; return (Lam x e2) }
828 dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
829 dsTcCoercion co (mkCast e)
830 dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
831 dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
832 dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm)
833
834 --------------------------------------
835 dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
836 dsTcEvBinds_s [] = return []
837 dsTcEvBinds_s (b:rest) = ASSERT( null rest ) -- Zonker ensures null
838 dsTcEvBinds b
839
840 dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
841 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
842 dsTcEvBinds (EvBinds bs) = dsEvBinds bs
843
844 dsEvBinds :: Bag EvBind -> DsM [CoreBind]
845 dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
846 where
847 ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r }))
848 = liftM (NonRec v) (dsEvTerm r)
849 ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
850
851 ds_pair (EvBind { eb_lhs = v, eb_rhs = r }) = liftM ((,) v) (dsEvTerm r)
852
853 sccEvBinds :: Bag EvBind -> [SCC EvBind]
854 sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
855 where
856 edges :: [(EvBind, EvVar, [EvVar])]
857 edges = foldrBag ((:) . mk_node) [] bs
858
859 mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
860 mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
861 = (b, var, varSetElems (evVarsOfTerm term))
862
863
864 ---------------------------------------
865 dsEvTerm :: EvTerm -> DsM CoreExpr
866 dsEvTerm (EvId v) = return (Var v)
867
868 dsEvTerm (EvCast tm co)
869 = do { tm' <- dsEvTerm tm
870 ; dsTcCoercion co $ mkCast tm' }
871 -- 'v' is always a lifted evidence variable so it is
872 -- unnecessary to call varToCoreExpr v here.
873
874 dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
875 ; return (Var df `mkTyApps` tys `mkApps` tms') }
876
877 dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
878 dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
879
880 dsEvTerm (EvTupleSel v n)
881 = do { tm' <- dsEvTerm v
882 ; let scrut_ty = exprType tm'
883 (tc, tys) = splitTyConApp scrut_ty
884 Just [dc] = tyConDataCons_maybe tc
885 xs = mkTemplateLocals tys
886 the_x = getNth xs n
887 ; ASSERT( isTupleTyCon tc )
888 return $
889 Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
890
891 dsEvTerm (EvTupleMk tms)
892 = do { tms' <- mapM dsEvTerm tms
893 ; let tys = map exprType tms'
894 ; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }
895 where
896 dc = tupleCon ConstraintTuple (length tms)
897
898 dsEvTerm (EvSuperClass d n)
899 = do { d' <- dsEvTerm d
900 ; let (cls, tys) = getClassPredTys (exprType d')
901 sc_sel_id = classSCSelId cls n -- Zero-indexed
902 ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
903 where
904
905 dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
906 where
907 errorId = rUNTIME_ERROR_ID
908 litMsg = Lit (MachStr (fastStringToByteString msg))
909
910 dsEvTerm (EvLit l) =
911 case l of
912 EvNum n -> mkIntegerExpr n
913 EvStr s -> mkStringExprFS s
914
915 ---------------------------------------
916 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
917 -- This is the crucial function that moves
918 -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
919 -- e.g. dsTcCoercion (trans g1 g2) k
920 -- = case g1 of EqBox g1# ->
921 -- case g2 of EqBox g2# ->
922 -- k (trans g1# g2#)
923 -- thing_inside will get a coercion at the role requested
924 dsTcCoercion co thing_inside
925 = do { us <- newUniqueSupply
926 ; let eqvs_covs :: [(EqVar,CoVar)]
927 eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
928 (uniqsFromSupply us)
929
930 subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
931 result_expr = thing_inside (ds_tc_coercion subst co)
932 result_ty = exprType result_expr
933
934 ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
935 where
936 mk_co_var :: Id -> Unique -> (Id, Id)
937 mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)
938 where
939 eq_nm = idName eqv
940 occ = nameOccName eq_nm
941 loc = nameSrcSpan eq_nm
942 ty = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2
943 (ty1, ty2) = getEqPredTys (evVarPred eqv)
944
945 wrap_in_case result_ty (eqv, cov) body
946 = case getEqPredRole (evVarPred eqv) of
947 Nominal -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
948 Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)]
949 Phantom -> panic "wrap_in_case/phantom"
950
951 ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
952 -- If the incoming TcCoercion if of type (a ~ b) (resp. Coercible a b)
953 -- the result is of type (a ~# b) (reps. a ~# b)
954 -- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on)
955 -- No need for InScope set etc because the
956 ds_tc_coercion subst tc_co
957 = go tc_co
958 where
959 go (TcRefl r ty) = Refl r (Coercion.substTy subst ty)
960 go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos)
961 go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
962 go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
963 where
964 (subst', tv') = Coercion.substTyVarBndr subst tv
965 go (TcAxiomInstCo ax ind cos)
966 = AxiomInstCo ax ind (map go cos)
967 go (TcPhantomCo ty1 ty2) = UnivCo (fsLit "ds_tc_coercion") Phantom ty1 ty2
968 go (TcSymCo co) = mkSymCo (go co)
969 go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
970 go (TcNthCo n co) = mkNthCo n (go co)
971 go (TcLRCo lr co) = mkLRCo lr (go co)
972 go (TcSubCo co) = mkSubCo (go co)
973 go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
974 go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
975 go (TcCoVarCo v) = ds_ev_id subst v
976 go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)
977 go (TcCoercion co) = co
978
979 ds_co_binds :: TcEvBinds -> CvSubst
980 ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
981 ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
982
983 ds_scc :: CvSubst -> SCC EvBind -> CvSubst
984 ds_scc subst (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = ev_term }))
985 = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
986 ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
987
988 ds_co_term :: CvSubst -> EvTerm -> Coercion
989 ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
990 ds_co_term subst (EvId v) = ds_ev_id subst v
991 ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
992 ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
993
994 ds_ev_id :: CvSubst -> EqVar -> Coercion
995 ds_ev_id subst v
996 | Just co <- Coercion.lookupCoVar subst v = co
997 | otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)
998
999 {-
1000 Note [Simple coercions]
1001 ~~~~~~~~~~~~~~~~~~~~~~~
1002 We have a special case for coercions that are simple variables.
1003 Suppose cv :: a ~ b is in scope
1004 Lacking the special case, if we see
1005 f a b cv
1006 we'd desguar to
1007 f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#)
1008 which is a bit stupid. The special case does the obvious thing.
1009
1010 This turns out to be important when desugaring the LHS of a RULE
1011 (see Trac #7837). Suppose we have
1012 normalise :: (a ~ Scalar a) => a -> a
1013 normalise_Double :: Double -> Double
1014 {-# RULES "normalise" normalise = normalise_Double #-}
1015
1016 Then the RULE we want looks like
1017 forall a, (cv:a~Scalar a).
1018 normalise a cv = normalise_Double
1019 But without the special case we generate the redundant box/unbox,
1020 which simpleOpt (currently) doesn't remove. So the rule never matches.
1021
1022 Maybe simpleOpt should be smarter. But it seems like a good plan
1023 to simply never generate the redundant box/unbox in the first place.
1024 -}