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