The Backpack patch.
[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] -> [(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
301 = do { let dflags = hsc_dflags hsc_env
302 print_unqual = mkPrintUnqualified dflags rdr_env
303 ; withTiming (pure dflags)
304 (text "Desugar"<+>brackets (ppr mod))
305 (const ()) $
306 do { -- Desugar the program
307 ; let export_set =
308 -- Used to be 'availsToNameSet', but we now export selectors
309 -- only when necessary. See #12125.
310 availsToNameSetWithSelectors exports
311 target = hscTarget dflags
312 hpcInfo = emptyHpcInfo other_hpc_info
313
314 ; (binds_cvr, ds_hpc_info, modBreaks)
315 <- if not (isHsBootOrSig hsc_src)
316 then addTicksToBinds hsc_env mod mod_loc
317 export_set (typeEnvTyCons type_env) binds
318 else return (binds, hpcInfo, Nothing)
319
320 ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $
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 ; MASSERT ( id_mod == mod )
373
374 ; let mod_guts = ModGuts {
375 mg_module = mod,
376 mg_hsc_src = hsc_src,
377 mg_loc = mkFileSrcSpan mod_loc,
378 mg_exports = exports,
379 mg_usages = usages,
380 mg_deps = deps,
381 mg_used_th = used_th,
382 mg_rdr_env = rdr_env,
383 mg_fix_env = fix_env,
384 mg_warns = warns,
385 mg_anns = anns,
386 mg_tcs = tcs,
387 mg_insts = fixSafeInstances safe_mode insts,
388 mg_fam_insts = fam_insts,
389 mg_inst_env = inst_env,
390 mg_fam_inst_env = fam_inst_env,
391 mg_patsyns = patsyns,
392 mg_rules = ds_rules_for_imps,
393 mg_binds = ds_binds,
394 mg_foreign = ds_fords,
395 mg_hpc_info = ds_hpc_info,
396 mg_modBreaks = modBreaks,
397 mg_vect_decls = ds_vects,
398 mg_vect_info = noVectInfo,
399 mg_safe_haskell = safe_mode,
400 mg_trust_pkg = imp_trust_own_pkg imports
401 }
402 ; return (msgs, Just mod_guts)
403 }}}}
404
405 mkFileSrcSpan :: ModLocation -> SrcSpan
406 mkFileSrcSpan mod_loc
407 = case ml_hs_file mod_loc of
408 Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
409 Nothing -> interactiveSrcSpan -- Presumably
410
411 dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
412 dsImpSpecs imp_specs
413 = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
414 ; let (spec_binds, spec_rules) = unzip spec_prs
415 ; return (concatOL spec_binds, spec_rules) }
416
417 combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
418 -- Top-level bindings can include coercion bindings, but not via superclasses
419 -- See Note [Top-level evidence]
420 combineEvBinds [] val_prs
421 = [Rec val_prs]
422 combineEvBinds (NonRec b r : bs) val_prs
423 | isId b = combineEvBinds bs ((b,r):val_prs)
424 | otherwise = NonRec b r : combineEvBinds bs val_prs
425 combineEvBinds (Rec prs : bs) val_prs
426 = combineEvBinds bs (prs ++ val_prs)
427
428 {-
429 Note [Top-level evidence]
430 ~~~~~~~~~~~~~~~~~~~~~~~~~
431 Top-level evidence bindings may be mutually recursive with the top-level value
432 bindings, so we must put those in a Rec. But we can't put them *all* in a Rec
433 because the occurrence analyser doesn't teke account of type/coercion variables
434 when computing dependencies.
435
436 So we pull out the type/coercion variables (which are in dependency order),
437 and Rec the rest.
438 -}
439
440 deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
441
442 deSugarExpr hsc_env tc_expr
443 = do { let dflags = hsc_dflags hsc_env
444 icntxt = hsc_IC hsc_env
445 rdr_env = ic_rn_gbl_env icntxt
446 type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
447 fam_insts = snd (ic_instances icntxt)
448 fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts
449 -- This stuff is a half baked version of TcRnDriver.setInteractiveContext
450
451 ; showPass dflags "Desugar"
452
453 -- Do desugaring
454 ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env
455 type_env fam_inst_env $
456 dsLExpr tc_expr
457
458 ; case mb_core_expr of
459 Nothing -> return ()
460 Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
461
462 ; return (msgs, mb_core_expr) }
463
464 {-
465 ************************************************************************
466 * *
467 * Add rules and export flags to binders
468 * *
469 ************************************************************************
470 -}
471
472 addExportFlagsAndRules
473 :: HscTarget -> NameSet -> NameSet -> [CoreRule]
474 -> [(Id, t)] -> [(Id, t)]
475 addExportFlagsAndRules target exports keep_alive rules prs
476 = mapFst add_one prs
477 where
478 add_one bndr = add_rules name (add_export name bndr)
479 where
480 name = idName bndr
481
482 ---------- Rules --------
483 -- See Note [Attach rules to local ids]
484 -- NB: the binder might have some existing rules,
485 -- arising from specialisation pragmas
486 add_rules name bndr
487 | Just rules <- lookupNameEnv rule_base name
488 = bndr `addIdSpecialisations` rules
489 | otherwise
490 = bndr
491 rule_base = extendRuleBaseList emptyRuleBase rules
492
493 ---------- Export flag --------
494 -- See Note [Adding export flags]
495 add_export name bndr
496 | dont_discard name = setIdExported bndr
497 | otherwise = bndr
498
499 dont_discard :: Name -> Bool
500 dont_discard name = is_exported name
501 || name `elemNameSet` keep_alive
502
503 -- In interactive mode, we don't want to discard any top-level
504 -- entities at all (eg. do not inline them away during
505 -- simplification), and retain them all in the TypeEnv so they are
506 -- available from the command line.
507 --
508 -- isExternalName separates the user-defined top-level names from those
509 -- introduced by the type checker.
510 is_exported :: Name -> Bool
511 is_exported | targetRetainsAllBindings target = isExternalName
512 | otherwise = (`elemNameSet` exports)
513
514 {-
515 Note [Adding export flags]
516 ~~~~~~~~~~~~~~~~~~~~~~~~~~
517 Set the no-discard flag if either
518 a) the Id is exported
519 b) it's mentioned in the RHS of an orphan rule
520 c) it's in the keep-alive set
521
522 It means that the binding won't be discarded EVEN if the binding
523 ends up being trivial (v = w) -- the simplifier would usually just
524 substitute w for v throughout, but we don't apply the substitution to
525 the rules (maybe we should?), so this substitution would make the rule
526 bogus.
527
528 You might wonder why exported Ids aren't already marked as such;
529 it's just because the type checker is rather busy already and
530 I didn't want to pass in yet another mapping.
531
532 Note [Attach rules to local ids]
533 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
534 Find the rules for locally-defined Ids; then we can attach them
535 to the binders in the top-level bindings
536
537 Reason
538 - It makes the rules easier to look up
539 - It means that transformation rules and specialisations for
540 locally defined Ids are handled uniformly
541 - It keeps alive things that are referred to only from a rule
542 (the occurrence analyser knows about rules attached to Ids)
543 - It makes sure that, when we apply a rule, the free vars
544 of the RHS are more likely to be in scope
545 - The imported rules are carried in the in-scope set
546 which is extended on each iteration by the new wave of
547 local binders; any rules which aren't on the binding will
548 thereby get dropped
549
550
551 ************************************************************************
552 * *
553 * Desugaring transformation rules
554 * *
555 ************************************************************************
556 -}
557
558 dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
559 dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
560 = putSrcSpanDs loc $
561 do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
562
563 ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
564 unsetWOptM Opt_WarnIdentities $
565 dsLExpr lhs -- Note [Desugaring RULE left hand sides]
566
567 ; rhs' <- dsLExpr rhs
568 ; this_mod <- getModule
569
570 ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
571
572 -- Substitute the dict bindings eagerly,
573 -- and take the body apart into a (f args) form
574 ; case decomposeRuleLhs bndrs'' lhs'' of {
575 Left msg -> do { warnDs NoReason msg; return Nothing } ;
576 Right (final_bndrs, fn_id, args) -> do
577
578 { let is_local = isLocalId fn_id
579 -- NB: isLocalId is False of implicit Ids. This is good because
580 -- we don't want to attach rules to the bindings of implicit Ids,
581 -- because they don't show up in the bindings until just before code gen
582 fn_name = idName fn_id
583 final_rhs = simpleOptExpr rhs'' -- De-crap it
584 rule_name = snd (unLoc name)
585 final_bndrs_set = mkVarSet final_bndrs
586 arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
587 exprsSomeFreeVarsList isId args
588
589 ; dflags <- getDynFlags
590 ; rule <- dsMkUserRule this_mod is_local
591 rule_name rule_act fn_name final_bndrs args
592 final_rhs
593 ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
594 warnRuleShadowing rule_name rule_act fn_id arg_ids
595
596 ; return (Just rule)
597 } } }
598
599
600 warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
601 -- See Note [Rules and inlining/other rules]
602 warnRuleShadowing rule_name rule_act fn_id arg_ids
603 = do { check False fn_id -- We often have multiple rules for the same Id in a
604 -- module. Maybe we should check that they don't overlap
605 -- but currently we don't
606 ; mapM_ (check True) arg_ids }
607 where
608 check check_rules_too lhs_id
609 | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
610 -- If imported with no unfolding, no worries
611 , idInlineActivation lhs_id `competesWith` rule_act
612 = warnDs (Reason Opt_WarnInlineRuleShadowing)
613 (vcat [ hang (text "Rule" <+> pprRuleName rule_name
614 <+> text "may never fire")
615 2 (text "because" <+> quotes (ppr lhs_id)
616 <+> text "might inline first")
617 , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
618 <+> quotes (ppr lhs_id)
619 , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
620
621 | check_rules_too
622 , bad_rule : _ <- get_bad_rules lhs_id
623 = warnDs (Reason Opt_WarnInlineRuleShadowing)
624 (vcat [ hang (text "Rule" <+> pprRuleName rule_name
625 <+> text "may never fire")
626 2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
627 <+> text "for"<+> quotes (ppr lhs_id)
628 <+> text "might fire first")
629 , text "Probable fix: add phase [n] or [~n] to the competing rule"
630 , ifPprDebug (ppr bad_rule) ])
631
632 | otherwise
633 = return ()
634
635 get_bad_rules lhs_id
636 = [ rule | rule <- idCoreRules lhs_id
637 , ruleActivation rule `competesWith` rule_act ]
638
639 -- See Note [Desugaring coerce as cast]
640 unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
641 unfold_coerce bndrs lhs rhs = do
642 (bndrs', wrap) <- go bndrs
643 return (bndrs', wrap lhs, wrap rhs)
644 where
645 go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
646 go [] = return ([], id)
647 go (v:vs)
648 | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
649 , tc `hasKey` coercibleTyConKey = do
650 u <- newUnique
651
652 let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
653 v' = mkLocalCoVar
654 (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
655 box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
656 [k, t1, t2] `App`
657 Coercion (mkCoVarCo v')
658
659 (bndrs, wrap) <- go vs
660 return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
661 | otherwise = do
662 (bndrs,wrap) <- go vs
663 return (v:bndrs, wrap)
664
665 {- Note [Desugaring RULE left hand sides]
666 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
667 For the LHS of a RULE we do *not* want to desugar
668 [x] to build (\cn. x `c` n)
669 We want to leave explicit lists simply as chains
670 of cons's. We can achieve that slightly indirectly by
671 switching off EnableRewriteRules. See DsExpr.dsExplicitList.
672
673 That keeps the desugaring of list comprehensions simple too.
674
675 Nor do we want to warn of conversion identities on the LHS;
676 the rule is precisly to optimise them:
677 {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
678
679 Note [Desugaring coerce as cast]
680 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
681 We want the user to express a rule saying roughly “mapping a coercion over a
682 list can be replaced by a coercion”. But the cast operator of Core () cannot
683 be written in Haskell. So we use `coerce` for that (#2110). The user writes
684 map coerce = coerce
685 as a RULE, and this optimizes any kind of mapped' casts away, including `map
686 MkNewtype`.
687
688 For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
689 corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
690 `let c = MkCoercible co in ...`. This is later simplified to the desired form
691 by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
692 See also Note [Getting the map/coerce RULE to work] in CoreSubst.
693
694 Note [Rules and inlining/other rules]
695 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
696 If you have
697 f x = ...
698 g x = ...
699 {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
700 then there's a good chance that in a potential rule redex
701 ...f (g e)...
702 then 'f' or 'g' will inline befor the rule can fire. Solution: add an
703 INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
704
705 Note that this applies to all the free variables on the LHS, both the
706 main function and things in its arguments.
707
708 We also check if there are Ids on the LHS that have competing RULES.
709 In the above example, suppose we had
710 {-# RULES "rule-for-g" forally. g [y] = ... #-}
711 Then "rule-for-f" and "rule-for-g" would compete. Better to add phase
712 control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
713 active; or perhpas after "rule-for-g" has become inactive. This is checked
714 by 'competesWith'
715
716 Class methods have a built-in RULE to select the method from the dictionary,
717 so you can't change the phase on this. That makes id very dubious to
718 match on class methods in RULE lhs's. See Trac #10595. I'm not happy
719 about this. For exmaple in Control.Arrow we have
720
721 {-# RULES "compose/arr" forall f g .
722 (arr f) . (arr g) = arr (f . g) #-}
723
724 and similar, which will elicit exactly these warnings, and risk never
725 firing. But it's not clear what to do instead. We could make the
726 class methocd rules inactive in phase 2, but that would delay when
727 subsequent transformations could fire.
728
729
730 ************************************************************************
731 * *
732 * Desugaring vectorisation declarations
733 * *
734 ************************************************************************
735 -}
736
737 dsVect :: LVectDecl Id -> DsM CoreVect
738 dsVect (L loc (HsVect _ (L _ v) rhs))
739 = putSrcSpanDs loc $
740 do { rhs' <- dsLExpr rhs
741 ; return $ Vect v rhs'
742 }
743 dsVect (L _loc (HsNoVect _ (L _ v)))
744 = return $ NoVect v
745 dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
746 = return $ VectType isScalar tycon' rhs_tycon
747 where
748 tycon' | Just ty <- coreView $ mkTyConTy tycon
749 , (tycon', []) <- splitTyConApp ty = tycon'
750 | otherwise = tycon
751 dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
752 = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
753 dsVect (L _loc (HsVectClassOut cls))
754 = return $ VectClass (classTyCon cls)
755 dsVect vc@(L _ (HsVectClassIn _ _))
756 = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
757 dsVect (L _loc (HsVectInstOut inst))
758 = return $ VectInst (instanceDFunId inst)
759 dsVect vi@(L _ (HsVectInstIn _))
760 = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)