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