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