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