Move usage calculation to desugaring, simplifying ModGuts.
[ghc.git] / compiler / deSugar / Desugar.hs
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
9 {-# LANGUAGE CPP #-}
10
11 module Desugar (
12 -- * Desugaring operations
13 deSugar, deSugarExpr,
14 -- * Dependency/fingerprinting code (used by MkIface)
15 mkUsageInfo, mkUsedNames, mkDependencies
16 ) where
17
18 #include "HsVersions.h"
19
20 import DynFlags
21 import HscTypes
22 import HsSyn
23 import TcRnTypes
24 import TcRnMonad ( finalSafeMode, fixSafeInstances )
25 import Id
26 import Name
27 import Type
28 import FamInstEnv
29 import Coercion
30 import InstEnv
31 import Class
32 import Avail
33 import CoreSyn
34 import CoreFVs( exprsSomeFreeVars )
35 import CoreSubst
36 import PprCore
37 import DsMonad
38 import DsExpr
39 import DsBinds
40 import DsForeign
41 import Module
42 import NameSet
43 import NameEnv
44 import Rules
45 import TysPrim (eqReprPrimTyCon)
46 import TysWiredIn (coercibleTyCon )
47 import BasicTypes ( Activation(.. ), competesWith, pprRuleName )
48 import CoreMonad ( CoreToDo(..) )
49 import CoreLint ( endPassIO )
50 import MkCore
51 import VarSet
52 import FastString
53 import ErrUtils
54 import Outputable
55 import SrcLoc
56 import Coverage
57 import Util
58 import MonadUtils
59 import OrdList
60 import StaticPtrTable
61 import UniqFM
62 import ListSetOps
63 import Fingerprint
64 import Maybes
65
66 import Data.Function
67 import Data.List
68 import Data.IORef
69 import Control.Monad( when )
70 import Data.Map (Map)
71 import qualified Data.Map as Map
72
73 -- | Extract information from the rename and typecheck phases to produce
74 -- a dependencies information for the module being compiled.
75 mkDependencies :: TcGblEnv -> IO Dependencies
76 mkDependencies
77 TcGblEnv{ tcg_mod = mod,
78 tcg_imports = imports,
79 tcg_th_used = th_var
80 }
81 = do
82 -- Template Haskell used?
83 th_used <- readIORef th_var
84 let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
85 -- M.hi-boot can be in the imp_dep_mods, but we must remove
86 -- it before recording the modules on which this one depends!
87 -- (We want to retain M.hi-boot in imp_dep_mods so that
88 -- loadHiBootInterface can see if M's direct imports depend
89 -- on M.hi-boot, and hence that we should do the hi-boot consistency
90 -- check.)
91
92 pkgs | th_used = insertList thUnitId (imp_dep_pkgs imports)
93 | otherwise = imp_dep_pkgs imports
94
95 -- Set the packages required to be Safe according to Safe Haskell.
96 -- See Note [RnNames . Tracking Trust Transitively]
97 sorted_pkgs = sortBy stableUnitIdCmp pkgs
98 trust_pkgs = imp_trust_pkgs imports
99 dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
100
101 return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods,
102 dep_pkgs = dep_pkgs',
103 dep_orphs = sortBy stableModuleCmp (imp_orphs imports),
104 dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
105 -- sort to get into canonical order
106 -- NB. remember to use lexicographic ordering
107
108 mkUsedNames :: TcGblEnv -> NameSet
109 mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
110
111 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
112 mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
113 = do
114 eps <- hscEPS hsc_env
115 hashes <- mapM getFileHash dependent_files
116 let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
117 dir_imp_mods used_names
118 let usages = mod_usages ++ [ UsageFile { usg_file_path = f
119 , usg_file_hash = hash }
120 | (f, hash) <- zip dependent_files hashes ]
121 usages `seqList` return usages
122 -- seq the list of Usages returned: occasionally these
123 -- don't get evaluated for a while and we can end up hanging on to
124 -- the entire collection of Ifaces.
125
126 mk_mod_usage_info :: PackageIfaceTable
127 -> HscEnv
128 -> Module
129 -> ImportedMods
130 -> NameSet
131 -> [Usage]
132 mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
133 = mapMaybe mkUsage usage_mods
134 where
135 hpt = hsc_HPT hsc_env
136 dflags = hsc_dflags hsc_env
137 this_pkg = thisPackage dflags
138
139 used_mods = moduleEnvKeys ent_map
140 dir_imp_mods = moduleEnvKeys direct_imports
141 all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
142 usage_mods = sortBy stableModuleCmp all_mods
143 -- canonical order is imported, to avoid interface-file
144 -- wobblage.
145
146 -- ent_map groups together all the things imported and used
147 -- from a particular module
148 ent_map :: ModuleEnv [OccName]
149 ent_map = foldNameSet add_mv emptyModuleEnv used_names
150 where
151 add_mv name mv_map
152 | isWiredInName name = mv_map -- ignore wired-in names
153 | otherwise
154 = case nameModule_maybe name of
155 Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map
156 -- See Note [Internal used_names]
157
158 Just mod -> -- This lambda function is really just a
159 -- specialised (++); originally came about to
160 -- avoid quadratic behaviour (trac #2680)
161 extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
162 where occ = nameOccName name
163
164 -- We want to create a Usage for a home module if
165 -- a) we used something from it; has something in used_names
166 -- b) we imported it, even if we used nothing from it
167 -- (need to recompile if its export list changes: export_fprint)
168 mkUsage :: Module -> Maybe Usage
169 mkUsage mod
170 | isNothing maybe_iface -- We can't depend on it if we didn't
171 -- load its interface.
172 || mod == this_mod -- We don't care about usages of
173 -- things in *this* module
174 = Nothing
175
176 | moduleUnitId mod /= this_pkg
177 = Just UsagePackageModule{ usg_mod = mod,
178 usg_mod_hash = mod_hash,
179 usg_safe = imp_safe }
180 -- for package modules, we record the module hash only
181
182 | (null used_occs
183 && isNothing export_hash
184 && not is_direct_import
185 && not finsts_mod)
186 = Nothing -- Record no usage info
187 -- for directly-imported modules, we always want to record a usage
188 -- on the orphan hash. This is what triggers a recompilation if
189 -- an orphan is added or removed somewhere below us in the future.
190
191 | otherwise
192 = Just UsageHomeModule {
193 usg_mod_name = moduleName mod,
194 usg_mod_hash = mod_hash,
195 usg_exports = export_hash,
196 usg_entities = Map.toList ent_hashs,
197 usg_safe = imp_safe }
198 where
199 maybe_iface = lookupIfaceByModule dflags hpt pit mod
200 -- In one-shot mode, the interfaces for home-package
201 -- modules accumulate in the PIT not HPT. Sigh.
202
203 Just iface = maybe_iface
204 finsts_mod = mi_finsts iface
205 hash_env = mi_hash_fn iface
206 mod_hash = mi_mod_hash iface
207 export_hash | depend_on_exports = Just (mi_exp_hash iface)
208 | otherwise = Nothing
209
210 (is_direct_import, imp_safe)
211 = case lookupModuleEnv direct_imports mod of
212 Just (imv : _xs) -> (True, imv_is_safe imv)
213 Just _ -> pprPanic "mkUsage: empty direct import" Outputable.empty
214 Nothing -> (False, safeImplicitImpsReq dflags)
215 -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn'
216 -- is used in the source code. We require them to be safe in Safe Haskell
217
218 used_occs = lookupModuleEnv ent_map mod `orElse` []
219
220 -- Making a Map here ensures that (a) we remove duplicates
221 -- when we have usages on several subordinates of a single parent,
222 -- and (b) that the usages emerge in a canonical order, which
223 -- is why we use Map rather than OccEnv: Map works
224 -- using Ord on the OccNames, which is a lexicographic ordering.
225 ent_hashs :: Map OccName Fingerprint
226 ent_hashs = Map.fromList (map lookup_occ used_occs)
227
228 lookup_occ occ =
229 case hash_env occ of
230 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
231 Just r -> r
232
233 depend_on_exports = is_direct_import
234 {- True
235 Even if we used 'import M ()', we have to register a
236 usage on the export list because we are sensitive to
237 changes in orphan instances/rules.
238 False
239 In GHC 6.8.x we always returned true, and in
240 fact it recorded a dependency on *all* the
241 modules underneath in the dependency tree. This
242 happens to make orphans work right, but is too
243 expensive: it'll read too many interface files.
244 The 'isNothing maybe_iface' check above saved us
245 from generating many of these usages (at least in
246 one-shot mode), but that's even more bogus!
247 -}
248
249 {-
250 ************************************************************************
251 * *
252 * The main function: deSugar
253 * *
254 ************************************************************************
255 -}
256
257 -- | Main entry point to the desugarer.
258 deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
259 -- Can modify PCS by faulting in more declarations
260
261 deSugar hsc_env
262 mod_loc
263 tcg_env@(TcGblEnv { tcg_mod = mod,
264 tcg_src = hsc_src,
265 tcg_type_env = type_env,
266 tcg_imports = imports,
267 tcg_exports = exports,
268 tcg_keep = keep_var,
269 tcg_th_splice_used = tc_splice_used,
270 tcg_rdr_env = rdr_env,
271 tcg_fix_env = fix_env,
272 tcg_inst_env = inst_env,
273 tcg_fam_inst_env = fam_inst_env,
274 tcg_warns = warns,
275 tcg_anns = anns,
276 tcg_binds = binds,
277 tcg_imp_specs = imp_specs,
278 tcg_dependent_files = dependent_files,
279 tcg_ev_binds = ev_binds,
280 tcg_fords = fords,
281 tcg_rules = rules,
282 tcg_vects = vects,
283 tcg_patsyns = patsyns,
284 tcg_tcs = tcs,
285 tcg_insts = insts,
286 tcg_fam_insts = fam_insts,
287 tcg_hpc = other_hpc_info})
288
289 = do { let dflags = hsc_dflags hsc_env
290 print_unqual = mkPrintUnqualified dflags rdr_env
291 ; showPass dflags "Desugar"
292
293 -- Desugar the program
294 ; let export_set = availsToNameSet exports
295 target = hscTarget dflags
296 hpcInfo = emptyHpcInfo other_hpc_info
297
298 ; (binds_cvr, ds_hpc_info, modBreaks)
299 <- if not (isHsBoot hsc_src)
300 then addTicksToBinds dflags mod mod_loc export_set
301 (typeEnvTyCons type_env) binds
302 else return (binds, hpcInfo, emptyModBreaks)
303
304 ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
305 do { ds_ev_binds <- dsEvBinds ev_binds
306 ; core_prs <- dsTopLHsBinds binds_cvr
307 ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
308 ; (ds_fords, foreign_prs) <- dsForeigns fords
309 ; ds_rules <- mapMaybeM dsRule rules
310 ; ds_vects <- mapM dsVect vects
311 ; stBinds <- dsGetStaticBindsVar >>=
312 liftIO . readIORef
313 ; let hpc_init
314 | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
315 | otherwise = empty
316 -- Stub to insert the static entries of the
317 -- module into the static pointer table
318 spt_init = sptInitCode mod stBinds
319 ; return ( ds_ev_binds
320 , foreign_prs `appOL` core_prs `appOL` spec_prs
321 `appOL` toOL (map snd stBinds)
322 , spec_rules ++ ds_rules, ds_vects
323 , ds_fords `appendStubC` hpc_init
324 `appendStubC` spt_init) }
325
326 ; case mb_res of {
327 Nothing -> return (msgs, Nothing) ;
328 Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
329
330 do { -- Add export flags to bindings
331 keep_alive <- readIORef keep_var
332 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
333 final_prs = addExportFlagsAndRules target export_set keep_alive
334 rules_for_locals (fromOL all_prs)
335
336 final_pgm = combineEvBinds ds_ev_binds final_prs
337 -- Notice that we put the whole lot in a big Rec, even the foreign binds
338 -- When compiling PrelFloat, which defines data Float = F# Float#
339 -- we want F# to be in scope in the foreign marshalling code!
340 -- You might think it doesn't matter, but the simplifier brings all top-level
341 -- things into the in-scope set before simplifying; so we get no unfolding for F#!
342
343 #ifdef DEBUG
344 -- Debug only as pre-simple-optimisation program may be really big
345 ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
346 #endif
347 ; (ds_binds, ds_rules_for_imps, ds_vects)
348 <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
349 -- The simpleOptPgm gets rid of type
350 -- bindings plus any stupid dead code
351
352 ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
353
354 ; let used_names = mkUsedNames tcg_env
355 ; deps <- mkDependencies tcg_env
356
357 ; used_th <- readIORef tc_splice_used
358 ; dep_files <- readIORef dependent_files
359 ; safe_mode <- finalSafeMode dflags tcg_env
360 ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files
361
362 ; let mod_guts = ModGuts {
363 mg_module = mod,
364 mg_hsc_src = hsc_src,
365 mg_loc = mkFileSrcSpan mod_loc,
366 mg_exports = exports,
367 mg_usages = usages,
368 mg_deps = deps,
369 mg_used_th = used_th,
370 mg_rdr_env = rdr_env,
371 mg_fix_env = fix_env,
372 mg_warns = warns,
373 mg_anns = anns,
374 mg_tcs = tcs,
375 mg_insts = fixSafeInstances safe_mode insts,
376 mg_fam_insts = fam_insts,
377 mg_inst_env = inst_env,
378 mg_fam_inst_env = fam_inst_env,
379 mg_patsyns = patsyns,
380 mg_rules = ds_rules_for_imps,
381 mg_binds = ds_binds,
382 mg_foreign = ds_fords,
383 mg_hpc_info = ds_hpc_info,
384 mg_modBreaks = modBreaks,
385 mg_vect_decls = ds_vects,
386 mg_vect_info = noVectInfo,
387 mg_safe_haskell = safe_mode,
388 mg_trust_pkg = imp_trust_own_pkg imports
389 }
390 ; return (msgs, Just mod_guts)
391 }}}
392
393 mkFileSrcSpan :: ModLocation -> SrcSpan
394 mkFileSrcSpan mod_loc
395 = case ml_hs_file mod_loc of
396 Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
397 Nothing -> interactiveSrcSpan -- Presumably
398
399 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
400 dsImpSpecs imp_specs
401 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
402 ; let (spec_binds, spec_rules) = unzip spec_prs
403 ; return (concatOL spec_binds, spec_rules) }
404
405 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
406 -- Top-level bindings can include coercion bindings, but not via superclasses
407 -- See Note [Top-level evidence]
408 combineEvBinds [] val_prs
409 = [Rec val_prs]
410 combineEvBinds (NonRec b r : bs) val_prs
411 | isId b = combineEvBinds bs ((b,r):val_prs)
412 | otherwise = NonRec b r : combineEvBinds bs val_prs
413 combineEvBinds (Rec prs : bs) val_prs
414 = combineEvBinds bs (prs ++ val_prs)
415
416 {-
417 Note [Top-level evidence]
418 ~~~~~~~~~~~~~~~~~~~~~~~~~
419 Top-level evidence bindings may be mutually recursive with the top-level value
420 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
421 because the occurrence analyser doesn't teke account of type/coercion variables
422 when computing dependencies.
423
424 So we pull out the type/coercion variables (which are in dependency order),
425 and Rec the rest.
426 -}
427
428 deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
429
430 deSugarExpr hsc_env tc_expr
431 = do { let dflags = hsc_dflags hsc_env
432 icntxt = hsc_IC hsc_env
433 rdr_env = ic_rn_gbl_env icntxt
434 type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
435 fam_insts = snd (ic_instances icntxt)
436 fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
437 -- This stuff is a half baked version of TcRnDriver.setInteractiveContext
438
439 ; showPass dflags "Desugar"
440
441 -- Do desugaring
442 ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
443 type_env fam_inst_env $
444 dsLExpr tc_expr
445
446 ; case mb_core_expr of
447 Nothing -> return ()
448 Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
449
450 ; return (msgs, mb_core_expr) }
451
452 {-
453 ************************************************************************
454 * *
455 * Add rules and export flags to binders
456 * *
457 ************************************************************************
458 -}
459
460 addExportFlagsAndRules
461 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
462 -> [(Id, t)] -> [(Id, t)]
463 addExportFlagsAndRules target exports keep_alive rules prs
464 = mapFst add_one prs
465 where
466 add_one bndr = add_rules name (add_export name bndr)
467 where
468 name = idName bndr
469
470 ---------- Rules --------
471 -- See Note [Attach rules to local ids]
472 -- NB: the binder might have some existing rules,
473 -- arising from specialisation pragmas
474 add_rules name bndr
475 | Just rules <- lookupNameEnv rule_base name
476 = bndr `addIdSpecialisations` rules
477 | otherwise
478 = bndr
479 rule_base = extendRuleBaseList emptyRuleBase rules
480
481 ---------- Export flag --------
482 -- See Note [Adding export flags]
483 add_export name bndr
484 | dont_discard name = setIdExported bndr
485 | otherwise = bndr
486
487 dont_discard :: Name -> Bool
488 dont_discard name = is_exported name
489 || name `elemNameSet` keep_alive
490
491 -- In interactive mode, we don't want to discard any top-level
492 -- entities at all (eg. do not inline them away during
493 -- simplification), and retain them all in the TypeEnv so they are
494 -- available from the command line.
495 --
496 -- isExternalName separates the user-defined top-level names from those
497 -- introduced by the type checker.
498 is_exported :: Name -> Bool
499 is_exported | targetRetainsAllBindings target = isExternalName
500 | otherwise = (`elemNameSet` exports)
501
502 {-
503 Note [Adding export flags]
504 ~~~~~~~~~~~~~~~~~~~~~~~~~~
505 Set the no-discard flag if either
506 a) the Id is exported
507 b) it's mentioned in the RHS of an orphan rule
508 c) it's in the keep-alive set
509
510 It means that the binding won't be discarded EVEN if the binding
511 ends up being trivial (v = w) -- the simplifier would usually just
512 substitute w for v throughout, but we don't apply the substitution to
513 the rules (maybe we should?), so this substitution would make the rule
514 bogus.
515
516 You might wonder why exported Ids aren't already marked as such;
517 it's just because the type checker is rather busy already and
518 I didn't want to pass in yet another mapping.
519
520 Note [Attach rules to local ids]
521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522 Find the rules for locally-defined Ids; then we can attach them
523 to the binders in the top-level bindings
524
525 Reason
526 - It makes the rules easier to look up
527 - It means that transformation rules and specialisations for
528 locally defined Ids are handled uniformly
529 - It keeps alive things that are referred to only from a rule
530 (the occurrence analyser knows about rules attached to Ids)
531 - It makes sure that, when we apply a rule, the free vars
532 of the RHS are more likely to be in scope
533 - The imported rules are carried in the in-scope set
534 which is extended on each iteration by the new wave of
535 local binders; any rules which aren't on the binding will
536 thereby get dropped
537
538
539 ************************************************************************
540 * *
541 * Desugaring transformation rules
542 * *
543 ************************************************************************
544 -}
545
546 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
547 dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
548 = putSrcSpanDs loc $
549 do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
550
551 ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
552 unsetWOptM Opt_WarnIdentities $
553 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
554
555 ; rhs' <- dsLExpr rhs
556 ; this_mod <- getModule
557
558 ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
559
560 -- Substitute the dict bindings eagerly,
561 -- and take the body apart into a (f args) form
562 ; case decomposeRuleLhs bndrs'' lhs'' of {
563 Left msg -> do { warnDs msg; return Nothing } ;
564 Right (final_bndrs, fn_id, args) -> do
565
566 { let is_local = isLocalId fn_id
567 -- NB: isLocalId is False of implicit Ids. This is good because
568 -- we don't want to attach rules to the bindings of implicit Ids,
569 -- because they don't show up in the bindings until just before code gen
570 fn_name = idName fn_id
571 final_rhs = simpleOptExpr rhs'' -- De-crap it
572 rule_name = snd (unLoc name)
573 arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
574
575 ; dflags <- getDynFlags
576 ; rule <- dsMkUserRule this_mod is_local
577 rule_name rule_act fn_name final_bndrs args
578 final_rhs
579 ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
580 warnRuleShadowing rule_name rule_act fn_id arg_ids
581
582 ; return (Just rule)
583 } } }
584
585
586 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
587 -- See Note [Rules and inlining/other rules]
588 warnRuleShadowing rule_name rule_act fn_id arg_ids
589 = do { check False fn_id -- We often have multiple rules for the same Id in a
590 -- module. Maybe we should check that they don't overlap
591 -- but currently we don't
592 ; mapM_ (check True) arg_ids }
593 where
594 check check_rules_too lhs_id
595 | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
596 -- If imported with no unfolding, no worries
597 , idInlineActivation lhs_id `competesWith` rule_act
598 = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
599 <+> ptext (sLit "may never fire"))
600 2 (ptext (sLit "because") <+> quotes (ppr lhs_id)
601 <+> ptext (sLit "might inline first"))
602 , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for")
603 <+> quotes (ppr lhs_id)
604 , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
605
606 | check_rules_too
607 , bad_rule : _ <- get_bad_rules lhs_id
608 = warnDs (vcat [ hang (ptext (sLit "Rule") <+> pprRuleName rule_name
609 <+> ptext (sLit "may never fire"))
610 2 (ptext (sLit "because rule") <+> pprRuleName (ruleName bad_rule)
611 <+> ptext (sLit "for")<+> quotes (ppr lhs_id)
612 <+> ptext (sLit "might fire first"))
613 , ptext (sLit "Probable fix: add phase [n] or [~n] to the competing rule")
614 , ifPprDebug (ppr bad_rule) ])
615
616 | otherwise
617 = return ()
618
619 get_bad_rules lhs_id
620 = [ rule | rule <- idCoreRules lhs_id
621 , ruleActivation rule `competesWith` rule_act ]
622
623 -- See Note [Desugaring coerce as cast]
624 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
625 unfold_coerce bndrs lhs rhs = do
626 (bndrs', wrap) <- go bndrs
627 return (bndrs', wrap lhs, wrap rhs)
628 where
629 go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
630 go [] = return ([], id)
631 go (v:vs)
632 | Just (tc, args) <- splitTyConApp_maybe (idType v)
633 , tc == coercibleTyCon = do
634 let ty' = mkTyConApp eqReprPrimTyCon args
635 v' <- mkDerivedLocalM mkRepEqOcc v ty'
636
637 (bndrs, wrap) <- go vs
638 return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)
639 | otherwise = do
640 (bndrs,wrap) <- go vs
641 return (v:bndrs, wrap)
642
643 {- Note [Desugaring RULE left hand sides]
644 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
645 For the LHS of a RULE we do *not* want to desugar
646 [x] to build (\cn. x `c` n)
647 We want to leave explicit lists simply as chains
648 of cons's. We can achieve that slightly indirectly by
649 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
650
651 That keeps the desugaring of list comprehensions simple too.
652
653
654
655 Nor do we want to warn of conversion identities on the LHS;
656 the rule is precisly to optimise them:
657 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
658
659 Note [Desugaring coerce as cast]
660 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
661 We want the user to express a rule saying roughly “mapping a coercion over a
662 list can be replaced by a coercion”. But the cast operator of Core () cannot
663 be written in Haskell. So we use `coerce` for that (#2110). The user writes
664 map coerce = coerce
665 as a RULE, and this optimizes any kind of mapped' casts aways, including `map
666 MkNewtype`.
667
668 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
669 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
670 `let c = MkCoercible co in ...`. This is later simplified to the desired form
671 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
672
673 Note [Rules and inlining/other rules]
674 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
675 If you have
676 f x = ...
677 g x = ...
678 {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
679 then there's a good chance that in a potential rule redex
680 ...f (g e)...
681 then 'f' or 'g' will inline befor the rule can fire. Solution: add an
682 INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
683
684 Note that this applies to all the free variables on the LHS, both the
685 main function and things in its arguments.
686
687 We also check if there are Ids on the LHS that have competing RULES.
688 In the above example, suppose we had
689 {-# RULES "rule-for-g" forally. g [y] = ... #-}
690 Then "rule-for-f" and "rule-for-g" would compete. Better to add phase
691 control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
692 active; or perhpas after "rule-for-g" has become inactive. This is checked
693 by 'competesWith'
694
695 Class methods have a built-in RULE to select the method from the dictionary,
696 so you can't change the phase on this. That makes id very dubious to
697 match on class methods in RULE lhs's. See Trac #10595. I'm not happy
698 about this. For exmaple in Control.Arrow we have
699
700 {-# RULES "compose/arr" forall f g .
701 (arr f) . (arr g) = arr (f . g) #-}
702
703 and similar, which will elicit exactly these warnings, and risk never
704 firing. But it's not clear what to do instead. We could make the
705 class methocd rules inactive in phase 2, but that would delay when
706 subsequent transformations could fire.
707
708
709 ************************************************************************
710 * *
711 * Desugaring vectorisation declarations
712 * *
713 ************************************************************************
714 -}
715
716 dsVect :: LVectDecl Id -> DsM CoreVect
717 dsVect (L loc (HsVect _ (L _ v) rhs))
718 = putSrcSpanDs loc $
719 do { rhs' <- dsLExpr rhs
720 ; return $ Vect v rhs'
721 }
722 dsVect (L _loc (HsNoVect _ (L _ v)))
723 = return $ NoVect v
724 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
725 = return $ VectType isScalar tycon' rhs_tycon
726 where
727 tycon' | Just ty <- coreView $ mkTyConTy tycon
728 , (tycon', []) <- splitTyConApp ty = tycon'
729 | otherwise = tycon
730 dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
731 = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
732 dsVect (L _loc (HsVectClassOut cls))
733 = return $ VectClass (classTyCon cls)
734 dsVect vc@(L _ (HsVectClassIn _ _))
735 = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
736 dsVect (L _loc (HsVectInstOut inst))
737 = return $ VectInst (instanceDFunId inst)
738 dsVect vi@(L _ (HsVectInstIn _))
739 = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)