Attach INLINE pagmas in mutually recursive bindings
[ghc.git] / compiler / deSugar / DsBinds.lhs
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 \begin{code}
13 {-# OPTIONS -fno-warn-tabs #-}
14 -- The above warning supression flag is a temporary kludge.
15 -- While working on this module you are encouraged to remove it and
16 -- detab the module (please do the detabbing in a separate patch). See
17 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
18 -- for details
19
20 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
21                  dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion
22   ) where
23
24 #include "HsVersions.h"
25
26 import {-# SOURCE #-}   DsExpr( dsLExpr )
27 import {-# SOURCE #-}   Match( matchWrapper )
28
29 import DsMonad
30 import DsGRHSs
31 import DsUtils
32
33 import HsSyn            -- lots of things
34 import CoreSyn          -- lots of things
35 import Literal          ( Literal(MachStr) )
36 import CoreSubst
37 import MkCore
38 import CoreUtils
39 import CoreArity ( etaExpand )
40 import CoreUnfold
41 import CoreFVs
42 import Digraph
43
44
45 import TyCon      ( isTupleTyCon, tyConDataCons_maybe )
46 import TcEvidence
47 import TcType
48 import Type
49 import Coercion hiding (substCo)
50 import TysWiredIn ( eqBoxDataCon, tupleCon )
51 import Id
52 import Class
53 import DataCon  ( dataConWorkId )
54 import Name     ( Name, localiseName )
55 import MkId     ( seqId )
56 import Var
57 import VarSet
58 import Rules
59 import VarEnv
60 import Outputable
61 import SrcLoc
62 import Maybes
63 import OrdList
64 import Bag
65 import BasicTypes hiding ( TopLevel )
66 import DynFlags
67 import FastString
68 import ErrUtils( MsgDoc )
69 import Util
70 import Control.Monad( when )
71 import MonadUtils
72 \end{code}
73
74 %************************************************************************
75 %*                                                                      *
76 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
77 %*                                                                      *
78 %************************************************************************
79
80 \begin{code}
81 dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
82 dsTopLHsBinds binds = ds_lhs_binds binds
83
84 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
85 dsLHsBinds binds = do { binds' <- ds_lhs_binds binds
86                       ; return (fromOL binds') }
87
88 ------------------------
89 ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
90
91 ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
92                         ; return (foldBag appOL id nilOL ds_bs) }
93
94 dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
95 dsLHsBind (L loc bind)
96   = 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  { core_expr <- dsLExpr expr
102
103                 -- Dictionary bindings are always VarBinds,
104                 -- so we only need do this here
105         ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
106                    | otherwise         = var
107
108         ; return (unitOL (makeCorePair var' False 0 core_expr)) }
109
110 dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
111                   , fun_co_fn = co_fn, fun_tick = tick
112                   , fun_infix = inf })
113  = do   { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
114         ; let body' = mkOptTickBox tick body
115               rhs = dsHsWrapper co_fn (mkLams args body')
116         ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
117            return (unitOL (makeCorePair fun False 0 rhs)) }
118
119 dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
120                   , pat_ticks = (rhs_tick, var_ticks) })
121   = do  { body_expr <- dsGuarded grhss ty
122         ; let body' = mkOptTickBox rhs_tick body_expr
123         ; sel_binds <- mkSelectorBinds var_ticks pat body'
124           -- We silently ignore inline pragmas; no makeCorePair
125           -- Not so cool, but really doesn't matter
126     ; return (toOL sel_binds) }
127
128         -- A common case: one exported variable
129         -- Non-recursive bindings come through this way
130         -- So do self-recursive bindings, and recursive bindings
131         -- that have been chopped up with type signatures
132 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
133                    , abs_exports = [export]
134                    , abs_ev_binds = ev_binds, abs_binds = binds })
135   | ABE { abe_wrap = wrap, abe_poly = global
136         , abe_mono = local, abe_prags = prags } <- export
137   = do  { bind_prs    <- ds_lhs_binds binds
138         ; let   core_bind = Rec (fromOL bind_prs)
139                 rhs       = dsHsWrapper wrap $  -- Usually the identity
140                             mkLams tyvars $ mkLams dicts $ 
141                             mkCoreLets (dsTcEvBinds ev_binds) $
142                             Let core_bind $
143                             Var local
144     
145         ; (spec_binds, rules) <- dsSpecs rhs prags
146
147         ; let   global'   = addIdSpecialisations global rules
148                 main_bind = makeCorePair global' (isDefaultMethod prags)
149                                          (dictArity dicts) rhs 
150     
151         ; return (main_bind `consOL` spec_binds) }
152
153 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
154                    , abs_exports = exports, abs_ev_binds = ev_binds
155                    , abs_binds = binds })
156          -- See Note [Desugaring AbsBinds]
157   = do  { bind_prs    <- ds_lhs_binds binds
158         ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs
159                               | (lcl_id, rhs) <- fromOL bind_prs ]
160                 -- Monomorphic recursion possible, hence Rec
161
162               tup_expr     = mkBigCoreVarTup locals
163               tup_ty       = exprType tup_expr
164               poly_tup_rhs = mkLams tyvars $ mkLams dicts $
165                              mkCoreLets (dsTcEvBinds ev_binds) $
166                              Let core_bind $
167                              tup_expr
168               locals       = map abe_mono exports
169
170         ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
171
172         ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
173                            , abe_mono = local, abe_prags = spec_prags })
174                 = do { tup_id  <- newSysLocalDs tup_ty
175                      ; let rhs = dsHsWrapper wrap $ 
176                                  mkLams tyvars $ mkLams dicts $
177                                  mkTupleSelector locals local tup_id $
178                                  mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
179                            rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
180                      ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
181                      ; let global' = (global `setInlinePragma` defaultInlinePragma)
182                                              `addIdSpecialisations` rules
183                            -- Kill the INLINE pragma because it applies to
184                            -- the user written (local) function.  The global
185                            -- Id is just the selector.  Hmm.  
186                      ; return ((global', rhs) `consOL` spec_binds) }
187
188         ; export_binds_s <- mapM mk_bind exports
189
190         ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
191                     concatOL export_binds_s) }
192   where
193     inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with
194                              -- the inline pragma from the source
195                              -- The type checker put the inline pragma
196                              -- on the *global* Id, so we need to transfer it
197     inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
198                           | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
199                           , let prag = idInlinePragma gbl_id ]
200
201     add_inline :: Id -> Id    -- tran
202     add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
203
204 ------------------------
205 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
206 makeCorePair gbl_id is_default_method dict_arity rhs
207   | is_default_method                 -- Default methods are *always* inlined
208   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
209
210   | otherwise
211   = case inlinePragmaSpec inline_prag of
212           EmptyInlineSpec -> (gbl_id, rhs)
213           NoInline        -> (gbl_id, rhs)
214           Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
215           Inline          -> inline_pair
216
217   where
218     inline_prag   = idInlinePragma gbl_id
219     inlinable_unf = mkInlinableUnfolding rhs
220     inline_pair
221        | Just arity <- inlinePragmaSat inline_prag
222         -- Add an Unfolding for an INLINE (but not for NOINLINE)
223         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
224        , let real_arity = dict_arity + arity
225         -- NB: The arity in the InlineRule takes account of the dictionaries
226        = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
227          , etaExpand real_arity rhs)
228
229        | otherwise
230        = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
231          (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)
232
233
234 dictArity :: [Var] -> Arity
235 -- Don't count coercion variables in arity
236 dictArity dicts = count isId dicts
237 \end{code}
238
239 [Desugaring AbsBinds]
240 ~~~~~~~~~~~~~~~~~~~~~
241 In the general AbsBinds case we desugar the binding to this:
242
243        tup a (d:Num a) = let fm = ...gm...
244                              gm = ...fm...
245                          in (fm,gm)
246        f a d = case tup a d of { (fm,gm) -> fm }
247        g a d = case tup a d of { (fm,gm) -> fm }
248
249 Note [Rules and inlining]
250 ~~~~~~~~~~~~~~~~~~~~~~~~~
251 Common special case: no type or dictionary abstraction
252 This is a bit less trivial than you might suppose
253 The naive way woudl be to desguar to something like
254         f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
255         M.f = f_lcl             -- Generated from "exports"
256 But we don't want that, because if M.f isn't exported,
257 it'll be inlined unconditionally at every call site (its rhs is 
258 trivial).  That would be ok unless it has RULES, which would 
259 thereby be completely lost.  Bad, bad, bad.
260
261 Instead we want to generate
262         M.f = ...f_lcl...
263         f_lcl = M.f
264 Now all is cool. The RULES are attached to M.f (by SimplCore), 
265 and f_lcl is rapidly inlined away.
266
267 This does not happen in the same way to polymorphic binds,
268 because they desugar to
269         M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
270 Although I'm a bit worried about whether full laziness might
271 float the f_lcl binding out and then inline M.f at its call site
272
273 Note [Specialising in no-dict case]
274 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
275 Even if there are no tyvars or dicts, we may have specialisation pragmas.
276 Class methods can generate
277       AbsBinds [] [] [( ... spec-prag]
278          { AbsBinds [tvs] [dicts] ...blah }
279 So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
280
281   class  (Real a, Fractional a) => RealFrac a  where
282     round :: (Integral b) => a -> b
283
284   instance  RealFrac Float  where
285     {-# SPECIALIZE round :: Float -> Int #-}
286
287 The top-level AbsBinds for $cround has no tyvars or dicts (because the 
288 instance does not).  But the method is locally overloaded!
289
290 Note [Abstracting over tyvars only]
291 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
292 When abstracting over type variable only (not dictionaries), we don't really need to
293 built a tuple and select from it, as we do in the general case. Instead we can take
294
295         AbsBinds [a,b] [ ([a,b], fg, fl, _),
296                          ([b],   gg, gl, _) ]
297                 { fl = e1
298                   gl = e2
299                    h = e3 }
300
301 and desugar it to
302
303         fg = /\ab. let B in e1
304         gg = /\b. let a = () in let B in S(e2)
305         h  = /\ab. let B in e3
306
307 where B is the *non-recursive* binding
308         fl = fg a b
309         gl = gg b
310         h  = h a b    -- See (b); note shadowing!
311
312 Notice (a) g has a different number of type variables to f, so we must
313              use the mkArbitraryType thing to fill in the gaps.  
314              We use a type-let to do that.
315
316          (b) The local variable h isn't in the exports, and rather than
317              clone a fresh copy we simply replace h by (h a b), where
318              the two h's have different types!  Shadowing happens here,
319              which looks confusing but works fine.
320
321          (c) The result is *still* quadratic-sized if there are a lot of
322              small bindings.  So if there are more than some small
323              number (10), we filter the binding set B by the free
324              variables of the particular RHS.  Tiresome.
325
326 Why got to this trouble?  It's a common case, and it removes the
327 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
328 compilation, especially in a case where there are a *lot* of
329 bindings.
330
331
332 Note [Eta-expanding INLINE things]
333 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
334 Consider
335    foo :: Eq a => a -> a
336    {-# INLINE foo #-}
337    foo x = ...
338
339 If (foo d) ever gets floated out as a common sub-expression (which can
340 happen as a result of method sharing), there's a danger that we never 
341 get to do the inlining, which is a Terribly Bad thing given that the
342 user said "inline"!
343
344 To avoid this we pre-emptively eta-expand the definition, so that foo
345 has the arity with which it is declared in the source code.  In this
346 example it has arity 2 (one for the Eq and one for x). Doing this 
347 should mean that (foo d) is a PAP and we don't share it.
348
349 Note [Nested arities]
350 ~~~~~~~~~~~~~~~~~~~~~
351 For reasons that are not entirely clear, method bindings come out looking like
352 this:
353
354   AbsBinds [] [] [$cfromT <= [] fromT]
355     $cfromT [InlPrag=INLINE] :: T Bool -> Bool
356     { AbsBinds [] [] [fromT <= [] fromT_1]
357         fromT :: T Bool -> Bool
358         { fromT_1 ((TBool b)) = not b } } }
359
360 Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
361 gotten from the binding for fromT_1.
362
363 It might be better to have just one level of AbsBinds, but that requires more
364 thought!
365
366 Note [Implementing SPECIALISE pragmas]
367 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
368 Example:
369         f :: (Eq a, Ix b) => a -> b -> Bool
370         {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
371         f = <poly_rhs>
372
373 From this the typechecker generates
374
375     AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
376
377     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
378                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
379
380 Note that wrap_fn can transform *any* function with the right type prefix 
381     forall ab. (Eq a, Ix b) => XXX
382 regardless of XXX.  It's sort of polymorphic in XXX.  This is
383 useful: we use the same wrapper to transform each of the class ops, as
384 well as the dict.
385
386 From these we generate:
387
388     Rule:       forall p, q, (dp:Ix p), (dq:Ix q). 
389                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
390
391     Spec bind:  f_spec = wrap_fn <poly_rhs>
392
393 Note that 
394
395   * The LHS of the rule may mention dictionary *expressions* (eg
396     $dfIxPair dp dq), and that is essential because the dp, dq are
397     needed on the RHS.
398
399   * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
400     can fully specialise it.
401
402 \begin{code}
403 ------------------------
404 dsSpecs :: CoreExpr     -- Its rhs
405         -> TcSpecPrags
406         -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
407                , [CoreRule] )           -- Rules for the Global Ids
408 -- See Note [Implementing SPECIALISE pragmas]
409 dsSpecs _ IsDefaultMethod = return (nilOL, [])
410 dsSpecs poly_rhs (SpecPrags sps)
411   = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
412        ; let (spec_binds_s, rules) = unzip pairs
413        ; return (concatOL spec_binds_s, rules) }
414
415 dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
416                                 -- Nothing => RULE is for an imported Id
417                                 --            rhs is in the Id's unfolding
418        -> Located TcSpecPrag
419        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
420 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
421   | isJust (isClassOpId_maybe poly_id)
422   = putSrcSpanDs loc $ 
423     do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") 
424                  <+> quotes (ppr poly_id))
425        ; return Nothing  }  -- There is no point in trying to specialise a class op
426                             -- Moreover, classops don't (currently) have an inl_sat arity set
427                             -- (it would be Just 0) and that in turn makes makeCorePair bleat
428
429   | no_act_spec && isNeverActive rule_act 
430   = putSrcSpanDs loc $ 
431     do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
432                  <+> quotes (ppr poly_id))
433        ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that
434                             -- See Note [Activation pragmas for SPECIALISE]
435
436   | otherwise
437   = putSrcSpanDs loc $ 
438     do { let poly_name = idName poly_id
439        ; spec_name <- newLocalName poly_name
440        ; let (bndrs, ds_lhs) = collectBinders (dsHsWrapper spec_co (Var poly_id))
441              spec_ty = mkPiTypes bndrs (exprType ds_lhs)
442        ; case decomposeRuleLhs bndrs ds_lhs of {
443            Left msg -> do { warnDs msg; return Nothing } ;
444            Right (final_bndrs, _fn, args) -> do
445
446        { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
447
448        ; let spec_id  = mkLocalId spec_name spec_ty 
449                             `setInlinePragma` inl_prag
450                             `setIdUnfolding`  spec_unf
451              rule =  mkRule False {- Not auto -} is_local_id
452                         (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
453                         rule_act poly_name
454                         final_bndrs args
455                         (mkVarApps (Var spec_id) bndrs)
456
457              spec_rhs  = dsHsWrapper spec_co poly_rhs
458              spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
459
460        ; dflags <- getDynFlags
461        ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
462               (warnDs (specOnInline poly_name))
463        ; return (Just (spec_pair `consOL` unf_pairs, rule))
464        } } }
465   where
466     is_local_id = isJust mb_poly_rhs
467     poly_rhs | Just rhs <-  mb_poly_rhs
468              = rhs          -- Local Id; this is its rhs
469              | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
470              = unfolding    -- Imported Id; this is its unfolding
471                             -- Use realIdUnfolding so we get the unfolding 
472                             -- even when it is a loop breaker. 
473                             -- We want to specialise recursive functions!
474              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
475                             -- The type checker has checked that it *has* an unfolding
476
477     id_inl = idInlinePragma poly_id
478
479     -- See Note [Activation pragmas for SPECIALISE]
480     inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
481              | not is_local_id  -- See Note [Specialising imported functions]
482                                  -- in OccurAnal
483              , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
484              | otherwise                               = id_inl
485      -- Get the INLINE pragma from SPECIALISE declaration, or,
486      -- failing that, from the original Id
487
488     spec_prag_act = inlinePragmaActivation spec_inl
489
490     -- See Note [Activation pragmas for SPECIALISE]
491     -- no_act_spec is True if the user didn't write an explicit
492     -- phase specification in the SPECIALISE pragma
493     no_act_spec = case inlinePragmaSpec spec_inl of
494                     NoInline -> isNeverActive  spec_prag_act
495                     _        -> isAlwaysActive spec_prag_act
496     rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
497              | otherwise   = spec_prag_act                   -- Specified by user
498
499
500 specUnfolding :: HsWrapper -> Type 
501               -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
502 {-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
503               generate unfoldings for specialised DFuns
504
505 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
506   = do { let spec_rhss = map wrap_fn ops
507        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
508        ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
509 -}
510 specUnfolding _ _ _
511   = return (noUnfolding, nilOL)
512
513 specOnInline :: Name -> MsgDoc
514 specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") 
515                  <+> quotes (ppr f)
516 \end{code}
517
518
519 Note [Activation pragmas for SPECIALISE]
520 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
521 From a user SPECIALISE pragma for f, we generate
522   a) A top-level binding    spec_fn = rhs
523   b) A RULE                 f dOrd = spec_fn
524
525 We need two pragma-like things:
526
527 * spec_fn's inline pragma: inherited from f's inline pragma (ignoring 
528                            activation on SPEC), unless overriden by SPEC INLINE
529
530 * Activation of RULE: from SPECIALISE pragma (if activation given)
531                       otherwise from f's inline pragma
532
533 This is not obvious (see Trac #5237)!
534
535 Examples      Rule activation   Inline prag on spec'd fn
536 ---------------------------------------------------------------------
537 SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
538                                   copy f's prag
539
540 NOINLINE f
541 SPEC [n] f :: ty            [n]   NOINLINE
542                                   copy f's prag
543
544 NOINLINE [k] f
545 SPEC [n] f :: ty            [n]   NOINLINE [k]
546                                   copy f's prag
547
548 INLINE [k] f
549 SPEC [n] f :: ty            [n]   INLINE [k] 
550                                   copy f's prag
551
552 SPEC INLINE [n] f :: ty     [n]   INLINE [n]
553                                   (ignore INLINE prag on f,
554                                   same activation for rule and spec'd fn)
555
556 NOINLINE [k] f
557 SPEC f :: ty                [n]   INLINE [k]
558
559
560 %************************************************************************
561 %*                                                                      *
562 \subsection{Adding inline pragmas}
563 %*                                                                      *
564 %************************************************************************
565
566 \begin{code}
567 decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
568 -- Take apart the LHS of a RULE.  It's supposed to look like
569 --     /\a. f a Int dOrdInt
570 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
571 -- That is, the RULE binders are lambda-bound
572 -- Returns Nothing if the LHS isn't of the expected shape
573 decomposeRuleLhs bndrs lhs 
574   =  -- Note [Simplifying the left-hand side of a RULE]
575     case collectArgs opt_lhs of
576         (Var fn, args) -> check_bndrs fn args
577
578         (Case scrut bndr ty [(DEFAULT, _, body)], args)
579                 | isDeadBinder bndr     -- Note [Matching seqId]
580                 -> check_bndrs seqId (args' ++ args)
581                 where
582                    args' = [Type (idType bndr), Type ty, scrut, body]
583            
584         _other -> Left bad_shape_msg
585  where
586    opt_lhs = simpleOptExpr lhs
587
588    check_bndrs fn args
589      | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args)
590      | otherwise         = Left (vcat (map dead_msg dead_bndrs))
591      where
592        arg_fvs = exprsFreeVars args
593
594             -- Check for dead binders: Note [Unused spec binders]
595        dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
596
597             -- Add extra dict binders: Note [Constant rule dicts]
598        extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
599                           | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
600                           , isDictId d]
601
602
603    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
604                       2 (ppr opt_lhs)
605    dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
606                              , ptext (sLit "is not bound in RULE lhs")])
607                       2 (ppr opt_lhs)
608    pp_bndr bndr
609     | isTyVar bndr                      = ptext (sLit "type variable") <+> quotes (ppr bndr)
610     | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)
611     | otherwise                         = ptext (sLit "variable") <+> quotes (ppr bndr)
612 \end{code}
613
614 Note [Simplifying the left-hand side of a RULE]
615 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
616 simpleOptExpr occurrence-analyses and simplifies the lhs
617 and thereby
618 (a) sorts dict bindings into NonRecs and inlines them
619 (b) substitute trivial lets so that they don't get in the way
620     Note that we substitute the function too; we might 
621     have this as a LHS:  let f71 = M.f Int in f71
622 (c) does eta reduction
623
624 For (c) consider the fold/build rule, which without simplification
625 looked like:
626         fold k z (build (/\a. g a))  ==>  ...
627 This doesn't match unless you do eta reduction on the build argument.
628 Similarly for a LHS like
629         augment g (build h) 
630 we do not want to get
631         augment (\a. g a) (build h)
632 otherwise we don't match when given an argument like
633         augment (\a. h a a) (build h)
634
635 NB: tcSimplifyRuleLhs is very careful not to generate complicated
636     dictionary expressions that we might have to match
637
638 Note [Matching seqId]
639 ~~~~~~~~~~~~~~~~~~~
640 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
641 and this code turns it back into an application of seq!  
642 See Note [Rules for seq] in MkId for the details.
643
644 Note [Unused spec binders]
645 ~~~~~~~~~~~~~~~~~~~~~~~~~~
646 Consider
647         f :: a -> a
648         {-# SPECIALISE f :: Eq a => a -> a #-}
649 It's true that this *is* a more specialised type, but the rule
650 we get is something like this:
651         f_spec d = f
652         RULE: f = f_spec d
653 Note that the rule is bogus, becuase it mentions a 'd' that is
654 not bound on the LHS!  But it's a silly specialisation anyway, becuase
655 the constraint is unused.  We could bind 'd' to (error "unused")
656 but it seems better to reject the program because it's almost certainly
657 a mistake.  That's what the isDeadBinder call detects.
658
659 Note [Constant rule dicts]
660 ~~~~~~~~~~~~~~~~~~~~~~~
661 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
662 which is presumably in scope at the function definition site, we can quantify 
663 over it too.  *Any* dict with that type will do.
664
665 So for example when you have
666         f :: Eq a => a -> a
667         f = <rhs>
668         {-# SPECIALISE f :: Int -> Int #-}
669
670 Then we get the SpecPrag
671         SpecPrag (f Int dInt) 
672
673 And from that we want the rule
674         
675         RULE forall dInt. f Int dInt = f_spec
676         f_spec = let f = <rhs> in f Int dInt
677
678 But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
679 Name, and you can't bind them in a lambda or forall without getting things
680 confused.   Likewise it might have an InlineRule or something, which would be
681 utterly bogus. So we really make a fresh Id, with the same unique and type
682 as the old one, but with an Internal name and no IdInfo.
683
684
685 %************************************************************************
686 %*                                                                      *
687                 Desugaring evidence
688 %*                                                                      *
689 %************************************************************************
690
691
692 \begin{code}
693 dsHsWrapper :: HsWrapper -> CoreExpr -> CoreExpr
694 dsHsWrapper WpHole            e = e
695 dsHsWrapper (WpTyApp ty)      e = App e (Type ty)
696 dsHsWrapper (WpLet ev_binds)  e = mkCoreLets (dsTcEvBinds ev_binds) e
697 dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 (dsHsWrapper c2 e) 
698 dsHsWrapper (WpCast co)       e = dsTcCoercion co (mkCast e) 
699 dsHsWrapper (WpEvLam ev)      e = Lam ev e 
700 dsHsWrapper (WpTyLam tv)      e = Lam tv e 
701 dsHsWrapper (WpEvApp evtrm)   e = App e (dsEvTerm evtrm)
702
703 --------------------------------------
704 dsTcEvBinds :: TcEvBinds -> [CoreBind]
705 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"  -- Zonker has got rid of this
706 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
707
708 dsEvBinds :: Bag EvBind -> [CoreBind]
709 dsEvBinds bs = map ds_scc (sccEvBinds bs)
710   where
711     ds_scc (AcyclicSCC (EvBind v r)) = NonRec v (dsEvTerm r)
712     ds_scc (CyclicSCC bs)            = Rec (map ds_pair bs)
713
714     ds_pair (EvBind v r) = (v, dsEvTerm r)
715
716 sccEvBinds :: Bag EvBind -> [SCC EvBind]
717 sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
718   where
719     edges :: [(EvBind, EvVar, [EvVar])]
720     edges = foldrBag ((:) . mk_node) [] bs 
721
722     mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
723     mk_node b@(EvBind var term) = (b, var, evVarsOfTerm term)
724
725
726 ---------------------------------------
727 dsEvTerm :: EvTerm -> CoreExpr
728 dsEvTerm (EvId v) = Var v
729
730 dsEvTerm (EvCast v co) 
731   = dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
732                                      -- unnecessary to call varToCoreExpr v here.
733 dsEvTerm (EvKindCast v co)
734   = dsTcCoercion co $ (\_ -> Var v)
735
736 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
737 dsEvTerm (EvCoercion co)         = dsTcCoercion co mkEqBox
738 dsEvTerm (EvTupleSel v n)
739    = ASSERT( isTupleTyCon tc )
740      Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
741   where
742     (tc, tys) = splitTyConApp (evVarPred v)
743     Just [dc] = tyConDataCons_maybe tc
744     v' = v `setVarType` ty_want
745     xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
746     (tys_before, ty_want:tys_after) = splitAt n tys
747 dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
748   where dc = tupleCon ConstraintTuple (length vs)
749         tys = map varType vs
750 dsEvTerm (EvSuperClass d n)
751   = Var sc_sel_id `mkTyApps` tys `App` Var d
752   where
753     sc_sel_id  = classSCSelId cls n     -- Zero-indexed
754     (cls, tys) = getClassPredTys (evVarPred d)   
755 dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
756   where errorId = rUNTIME_ERROR_ID
757         litMsg  = Lit (MachStr msg)
758
759 ---------------------------------------
760 dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
761 -- This is the crucial function that moves 
762 -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
763 -- e.g.  dsTcCoercion (trans g1 g2) k
764 --       = case g1 of EqBox g1# ->
765 --         case g2 of EqBox g2# ->
766 --         k (trans g1# g2#)
767 dsTcCoercion co thing_inside
768   = foldr wrap_in_case result_expr eqvs_covs
769   where
770     result_expr = thing_inside (ds_tc_coercion subst co)
771     result_ty   = exprType result_expr
772
773     -- We use the same uniques for the EqVars and the CoVars, and just change
774     -- the type. So the CoVars shadow the EqVars
775
776     eqvs_covs :: [(EqVar,CoVar)]
777     eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
778                 | eqv <- varSetElems (coVarsOfTcCo co)
779                 , let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
780
781     subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
782
783     wrap_in_case (eqv, cov) body 
784       = Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
785
786 ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
787 -- If the incoming TcCoercion if of type (a ~ b), 
788 --                 the result is of type (a ~# b)
789 -- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b)
790 -- No need for InScope set etc because the 
791 ds_tc_coercion subst tc_co
792   = go tc_co
793   where
794     go (TcRefl ty)            = Refl (Coercion.substTy subst ty)
795     go (TcTyConAppCo tc cos)  = mkTyConAppCo tc (map go cos)
796     go (TcAppCo co1 co2)      = mkAppCo (go co1) (go co2)
797     go (TcForAllCo tv co)     = mkForAllCo tv' (ds_tc_coercion subst' co)
798                               where
799                                 (subst', tv') = Coercion.substTyVarBndr subst tv
800     go (TcAxiomInstCo ax tys) = mkAxInstCo ax (map (Coercion.substTy subst) tys)
801     go (TcSymCo co)           = mkSymCo (go co)
802     go (TcTransCo co1 co2)    = mkTransCo (go co1) (go co2)
803     go (TcNthCo n co)         = mkNthCo n (go co)
804     go (TcInstCo co ty)       = mkInstCo (go co) ty
805     go (TcLetCo bs co)        = ds_tc_coercion (ds_co_binds bs) co
806     go (TcCoVarCo v)          = ds_ev_id subst v
807
808     ds_co_binds :: TcEvBinds -> CvSubst
809     ds_co_binds (EvBinds bs)      = foldl ds_scc subst (sccEvBinds bs)
810     ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
811
812     ds_scc :: CvSubst -> SCC EvBind -> CvSubst
813     ds_scc subst (AcyclicSCC (EvBind v ev_term))
814       = extendCvSubstAndInScope subst v (ds_ev_term subst ev_term)
815     ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
816
817     ds_ev_term :: CvSubst -> EvTerm -> Coercion
818     ds_ev_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
819     ds_ev_term subst (EvId v)           = ds_ev_id subst v
820     ds_ev_term _ other = pprPanic "ds_ev_term" (ppr other $$ ppr tc_co)
821
822     ds_ev_id :: CvSubst -> EqVar -> Coercion
823     ds_ev_id subst v
824      | Just co <- Coercion.lookupCoVar subst v = co
825      | otherwise  = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)
826 \end{code}