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