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