Make the matcher and wrapper Ids in PatSyn into LocalIds, not GlobalIds
[ghc.git] / compiler / deSugar / Desugar.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 The Desugarer: turning HsSyn into Core.
7
8 \begin{code}
9 {-# LANGUAGE CPP #-}
10
11 module Desugar ( deSugar, deSugarExpr ) where
12
13 import DynFlags
14 import HscTypes
15 import HsSyn
16 import TcRnTypes
17 import TcRnMonad ( finalSafeMode )
18 import MkIface
19 import Id
20 import Name
21 import Type
22 import FamInstEnv
23 import Coercion
24 import InstEnv
25 import Class
26 import Avail
27 import PatSyn
28 import CoreSyn
29 import CoreSubst
30 import PprCore
31 import DsMonad
32 import DsExpr
33 import DsBinds
34 import DsForeign
35 import Module
36 import NameSet
37 import NameEnv
38 import Rules
39 import TysPrim (eqReprPrimTyCon)
40 import TysWiredIn (coercibleTyCon )
41 import BasicTypes       ( Activation(.. ) )
42 import CoreMonad        ( endPass, CoreToDo(..) )
43 import MkCore
44 import FastString
45 import ErrUtils
46 import Outputable
47 import SrcLoc
48 import Coverage
49 import Util
50 import MonadUtils
51 import OrdList
52 import Data.List
53 import Data.IORef
54 import Control.Monad( when )
55 \end{code}
56
57 %************************************************************************
58 %*                                                                      *
59 %*              The main function: deSugar
60 %*                                                                      *
61 %************************************************************************
62
63 \begin{code}
64 -- | Main entry point to the desugarer.
65 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
66 -- Can modify PCS by faulting in more declarations
67
68 deSugar hsc_env
69         mod_loc
70         tcg_env@(TcGblEnv { tcg_mod          = mod,
71                             tcg_src          = hsc_src,
72                             tcg_type_env     = type_env,
73                             tcg_imports      = imports,
74                             tcg_exports      = exports,
75                             tcg_keep         = keep_var,
76                             tcg_th_splice_used = tc_splice_used,
77                             tcg_rdr_env      = rdr_env,
78                             tcg_fix_env      = fix_env,
79                             tcg_inst_env     = inst_env,
80                             tcg_fam_inst_env = fam_inst_env,
81                             tcg_warns        = warns,
82                             tcg_anns         = anns,
83                             tcg_binds        = binds,
84                             tcg_imp_specs    = imp_specs,
85                             tcg_dependent_files = dependent_files,
86                             tcg_ev_binds     = ev_binds,
87                             tcg_fords        = fords,
88                             tcg_rules        = rules,
89                             tcg_vects        = vects,
90                             tcg_patsyns      = patsyns,
91                             tcg_tcs          = tcs,
92                             tcg_insts        = insts,
93                             tcg_fam_insts    = fam_insts,
94                             tcg_hpc          = other_hpc_info })
95
96   = do { let dflags = hsc_dflags hsc_env
97         ; showPass dflags "Desugar"
98
99         -- Desugar the program
100         ; let export_set = availsToNameSet exports
101               target     = hscTarget dflags
102               hpcInfo    = emptyHpcInfo other_hpc_info
103               want_ticks = gopt Opt_Hpc dflags
104                         || target == HscInterpreted
105                         || (gopt Opt_SccProfilingOn dflags
106                             && case profAuto dflags of
107                                  NoProfAuto -> False
108                                  _          -> True)
109
110         ; (binds_cvr, ds_hpc_info, modBreaks)
111                          <- if want_ticks && not (isHsBoot hsc_src)
112                               then addTicksToBinds dflags mod mod_loc export_set
113                                           (typeEnvTyCons type_env) binds
114                               else return (binds, hpcInfo, emptyModBreaks)
115
116         ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
117                        do { ds_ev_binds <- dsEvBinds ev_binds
118                           ; core_prs <- dsTopLHsBinds binds_cvr
119                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
120                           ; (ds_fords, foreign_prs) <- dsForeigns fords
121                           ; ds_rules <- mapMaybeM dsRule rules
122                           ; ds_vects <- mapM dsVect vects
123                           ; let hpc_init
124                                   | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
125                                   | otherwise = empty
126                           ; return ( ds_ev_binds
127                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
128                                    , spec_rules ++ ds_rules, ds_vects
129                                    , ds_fords `appendStubC` hpc_init) }
130
131         ; case mb_res of {
132            Nothing -> return (msgs, Nothing) ;
133            Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
134
135      do {       -- Add export flags to bindings
136           keep_alive <- readIORef keep_var
137         ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
138               final_prs = addExportFlagsAndRules target export_set keep_alive
139                                                  rules_for_locals (fromOL all_prs)
140
141               final_pgm = combineEvBinds ds_ev_binds final_prs
142         -- Notice that we put the whole lot in a big Rec, even the foreign binds
143         -- When compiling PrelFloat, which defines data Float = F# Float#
144         -- we want F# to be in scope in the foreign marshalling code!
145         -- You might think it doesn't matter, but the simplifier brings all top-level
146         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
147
148 #ifdef DEBUG
149           -- Debug only as pre-simple-optimisation program may be really big
150         ; endPass hsc_env CoreDesugar final_pgm rules_for_imps
151 #endif
152         ; (ds_binds, ds_rules_for_imps, ds_vects)
153             <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
154                          -- The simpleOptPgm gets rid of type
155                          -- bindings plus any stupid dead code
156
157         ; endPass hsc_env CoreDesugarOpt ds_binds ds_rules_for_imps
158
159         ; let used_names = mkUsedNames tcg_env
160         ; deps <- mkDependencies tcg_env
161
162         ; used_th <- readIORef tc_splice_used
163         ; dep_files <- readIORef dependent_files
164         ; safe_mode <- finalSafeMode dflags tcg_env
165
166         ; let mod_guts = ModGuts {
167                 mg_module       = mod,
168                 mg_boot         = isHsBoot hsc_src,
169                 mg_exports      = exports,
170                 mg_deps         = deps,
171                 mg_used_names   = used_names,
172                 mg_used_th      = used_th,
173                 mg_dir_imps     = imp_mods imports,
174                 mg_rdr_env      = rdr_env,
175                 mg_fix_env      = fix_env,
176                 mg_warns        = warns,
177                 mg_anns         = anns,
178                 mg_tcs          = tcs,
179                 mg_insts        = insts,
180                 mg_fam_insts    = fam_insts,
181                 mg_inst_env     = inst_env,
182                 mg_fam_inst_env = fam_inst_env,
183                 mg_patsyns      = filter ((`elemNameSet` export_set) . patSynName) patsyns,
184                 mg_rules        = ds_rules_for_imps,
185                 mg_binds        = ds_binds,
186                 mg_foreign      = ds_fords,
187                 mg_hpc_info     = ds_hpc_info,
188                 mg_modBreaks    = modBreaks,
189                 mg_vect_decls   = ds_vects,
190                 mg_vect_info    = noVectInfo,
191                 mg_safe_haskell = safe_mode,
192                 mg_trust_pkg    = imp_trust_own_pkg imports,
193                 mg_dependent_files = dep_files
194               }
195         ; return (msgs, Just mod_guts)
196         }}}
197
198 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
199 dsImpSpecs imp_specs
200  = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
201       ; let (spec_binds, spec_rules) = unzip spec_prs
202       ; return (concatOL spec_binds, spec_rules) }
203
204 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
205 -- Top-level bindings can include coercion bindings, but not via superclasses
206 -- See Note [Top-level evidence]
207 combineEvBinds [] val_prs
208   = [Rec val_prs]
209 combineEvBinds (NonRec b r : bs) val_prs
210   | isId b    = combineEvBinds bs ((b,r):val_prs)
211   | otherwise = NonRec b r : combineEvBinds bs val_prs
212 combineEvBinds (Rec prs : bs) val_prs
213   = combineEvBinds bs (prs ++ val_prs)
214 \end{code}
215
216 Note [Top-level evidence]
217 ~~~~~~~~~~~~~~~~~~~~~~~~~
218 Top-level evidence bindings may be mutually recursive with the top-level value
219 bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
220 because the occurrence analyser doesn't teke account of type/coercion variables
221 when computing dependencies.
222
223 So we pull out the type/coercion variables (which are in dependency order),
224 and Rec the rest.
225
226
227 \begin{code}
228 deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
229
230 deSugarExpr hsc_env tc_expr
231   = do { let dflags       = hsc_dflags hsc_env
232              icntxt       = hsc_IC hsc_env
233              rdr_env      = ic_rn_gbl_env icntxt
234              type_env     = mkTypeEnvWithImplicits (ic_tythings icntxt)
235              fam_insts    = snd (ic_instances icntxt)
236              fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
237              -- This stuff is a half baked version of TcRnDriver.setInteractiveContext
238
239        ; showPass dflags "Desugar"
240
241          -- Do desugaring
242        ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
243                                         type_env fam_inst_env $
244                                  dsLExpr tc_expr
245
246        ; case mb_core_expr of
247             Nothing   -> return ()
248             Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
249
250        ; return (msgs, mb_core_expr) }
251 \end{code}
252
253 %************************************************************************
254 %*                                                                      *
255 %*              Add rules and export flags to binders
256 %*                                                                      *
257 %************************************************************************
258
259 \begin{code}
260 addExportFlagsAndRules
261     :: HscTarget -> NameSet -> NameSet -> [CoreRule]
262     -> [(Id, t)] -> [(Id, t)]
263 addExportFlagsAndRules target exports keep_alive rules prs
264   = mapFst add_one prs
265   where
266     add_one bndr = add_rules name (add_export name bndr)
267        where
268          name = idName bndr
269
270     ---------- Rules --------
271         -- See Note [Attach rules to local ids]
272         -- NB: the binder might have some existing rules,
273         -- arising from specialisation pragmas
274     add_rules name bndr
275         | Just rules <- lookupNameEnv rule_base name
276         = bndr `addIdSpecialisations` rules
277         | otherwise
278         = bndr
279     rule_base = extendRuleBaseList emptyRuleBase rules
280
281     ---------- Export flag --------
282     -- See Note [Adding export flags]
283     add_export name bndr
284         | dont_discard name = setIdExported bndr
285         | otherwise         = bndr
286
287     dont_discard :: Name -> Bool
288     dont_discard name = is_exported name
289                      || name `elemNameSet` keep_alive
290
291         -- In interactive mode, we don't want to discard any top-level
292         -- entities at all (eg. do not inline them away during
293         -- simplification), and retain them all in the TypeEnv so they are
294         -- available from the command line.
295         --
296         -- isExternalName separates the user-defined top-level names from those
297         -- introduced by the type checker.
298     is_exported :: Name -> Bool
299     is_exported | targetRetainsAllBindings target = isExternalName
300                 | otherwise                       = (`elemNameSet` exports)
301 \end{code}
302
303
304 Note [Adding export flags]
305 ~~~~~~~~~~~~~~~~~~~~~~~~~~
306 Set the no-discard flag if either
307         a) the Id is exported
308         b) it's mentioned in the RHS of an orphan rule
309         c) it's in the keep-alive set
310
311 It means that the binding won't be discarded EVEN if the binding
312 ends up being trivial (v = w) -- the simplifier would usually just
313 substitute w for v throughout, but we don't apply the substitution to
314 the rules (maybe we should?), so this substitution would make the rule
315 bogus.
316
317 You might wonder why exported Ids aren't already marked as such;
318 it's just because the type checker is rather busy already and
319 I didn't want to pass in yet another mapping.
320
321 Note [Attach rules to local ids]
322 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
323 Find the rules for locally-defined Ids; then we can attach them
324 to the binders in the top-level bindings
325
326 Reason
327   - It makes the rules easier to look up
328   - It means that transformation rules and specialisations for
329     locally defined Ids are handled uniformly
330   - It keeps alive things that are referred to only from a rule
331     (the occurrence analyser knows about rules attached to Ids)
332   - It makes sure that, when we apply a rule, the free vars
333     of the RHS are more likely to be in scope
334   - The imported rules are carried in the in-scope set
335     which is extended on each iteration by the new wave of
336     local binders; any rules which aren't on the binding will
337     thereby get dropped
338
339
340 %************************************************************************
341 %*                                                                      *
342 %*              Desugaring transformation rules
343 %*                                                                      *
344 %************************************************************************
345
346 \begin{code}
347
348 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
349 dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
350   = putSrcSpanDs loc $
351     do  { let bndrs' = [var | RuleBndr (L _ var) <- vars]
352
353         ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
354                   unsetWOptM Opt_WarnIdentities $
355                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
356
357         ; rhs' <- dsLExpr rhs
358         ; dflags <- getDynFlags
359
360         ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
361
362         -- Substitute the dict bindings eagerly,
363         -- and take the body apart into a (f args) form
364         ; case decomposeRuleLhs bndrs'' lhs'' of {
365                 Left msg -> do { warnDs msg; return Nothing } ;
366                 Right (final_bndrs, fn_id, args) -> do
367
368         { let is_local = isLocalId fn_id
369                 -- NB: isLocalId is False of implicit Ids.  This is good because
370                 -- we don't want to attach rules to the bindings of implicit Ids,
371                 -- because they don't show up in the bindings until just before code gen
372               fn_name   = idName fn_id
373               final_rhs = simpleOptExpr rhs''    -- De-crap it
374               rule      = mkRule False {- Not auto -} is_local
375                                  name act fn_name final_bndrs args final_rhs
376
377               inline_shadows_rule   -- Function can be inlined before rule fires
378                 | wopt Opt_WarnInlineRuleShadowing dflags
379                 , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)   
380                        -- If imported with no unfolding, no worries
381                 = case (idInlineActivation fn_id, act) of
382                     (NeverActive, _)    -> False
383                     (AlwaysActive, _)   -> True
384                     (ActiveBefore {}, _) -> True
385                     (ActiveAfter {}, NeverActive)     -> True
386                     (ActiveAfter n, ActiveAfter r)    -> r < n  -- Rule active strictly first
387                     (ActiveAfter {}, AlwaysActive)    -> False
388                     (ActiveAfter {}, ActiveBefore {}) -> False
389                 | otherwise = False
390
391         ; when inline_shadows_rule $
392           warnDs (vcat [ hang (ptext (sLit "Rule") <+> doubleQuotes (ftext name)
393                                <+> ptext (sLit "may never fire"))
394                             2 (ptext (sLit "because") <+> quotes (ppr fn_id)
395                                <+> ptext (sLit "might inline first"))
396                        , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on")
397                          <+> quotes (ppr fn_id) ])
398
399         ; return (Just rule)
400         } } }
401
402 -- See Note [Desugaring coerce as cast]
403 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
404 unfold_coerce bndrs lhs rhs = do
405     (bndrs', wrap) <- go bndrs
406     return (bndrs', wrap lhs, wrap rhs)
407   where
408     go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
409     go []     = return ([], id)
410     go (v:vs)
411         | Just (tc, args) <- splitTyConApp_maybe (idType v)
412         , tc == coercibleTyCon = do
413             let ty' = mkTyConApp eqReprPrimTyCon args
414             v' <- mkDerivedLocalM mkRepEqOcc v ty'
415
416             (bndrs, wrap) <- go vs
417             return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)
418         | otherwise = do
419             (bndrs,wrap) <- go vs
420             return (v:bndrs, wrap)
421
422 \end{code}
423
424 Note [Desugaring RULE left hand sides]
425 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
426 For the LHS of a RULE we do *not* want to desugar
427     [x]   to    build (\cn. x `c` n)
428 We want to leave explicit lists simply as chains
429 of cons's. We can achieve that slightly indirectly by
430 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
431
432 That keeps the desugaring of list comprehensions simple too.
433
434
435
436 Nor do we want to warn of conversion identities on the LHS;
437 the rule is precisly to optimise them:
438   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
439
440
441 Note [Desugaring coerce as cast]
442 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
443 We want the user to express a rule saying roughly “mapping a coercion over a
444 list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
445 be written in Haskell. So we use `coerce` for that (#2110). The user writes
446     map coerce = coerce
447 as a RULE, and this optimizes any kind of mapped' casts aways, including `map
448 MkNewtype`.
449
450 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
451 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
452 `let c = MkCoercible co in ...`. This is later simplified to the desired form
453 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
454
455 %************************************************************************
456 %*                                                                      *
457 %*              Desugaring vectorisation declarations
458 %*                                                                      *
459 %************************************************************************
460
461 \begin{code}
462 dsVect :: LVectDecl Id -> DsM CoreVect
463 dsVect (L loc (HsVect (L _ v) rhs))
464   = putSrcSpanDs loc $
465     do { rhs' <- dsLExpr rhs
466        ; return $ Vect v rhs'
467        }
468 dsVect (L _loc (HsNoVect (L _ v)))
469   = return $ NoVect v
470 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
471   = return $ VectType isScalar tycon' rhs_tycon
472   where
473     tycon' | Just ty <- coreView $ mkTyConTy tycon
474            , (tycon', []) <- splitTyConApp ty      = tycon'
475            | otherwise                             = tycon
476 dsVect vd@(L _ (HsVectTypeIn _ _ _))
477   = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
478 dsVect (L _loc (HsVectClassOut cls))
479   = return $ VectClass (classTyCon cls)
480 dsVect vc@(L _ (HsVectClassIn _))
481   = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
482 dsVect (L _loc (HsVectInstOut inst))
483   = return $ VectInst (instanceDFunId inst)
484 dsVect vi@(L _ (HsVectInstIn _))
485   = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
486 \end{code}