import UniqFM
import Unique
import Util hiding ( eqListBy )
-import FiniteMap
import FastString
import Maybes
import ListSetOps
import Control.Monad
import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.IORef
import System.FilePath
\end{code}
intermediate_iface decls
-- Warn about orphans
- ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans
- | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
- | otherwise = emptyBag
+ ; let warn_orphs = dopt Opt_WarnOrphans dflags
+ warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags
+ orph_warnings --- Laziness means no work done unless -fwarn-orphans
+ | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
+ | otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn unqual d
, isNothing (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
| r <- iface_rules
- , isNothing (ifRuleOrph r) ]
+ , isNothing (ifRuleOrph r)
+ , if ifRuleAuto r then warn_auto_orphs
+ else warn_orphs ]
; if errorsFound dflags errs_and_warns
then return ( errs_and_warns, Nothing )
-- wiki/Commentary/Compiler/RecompilationAvoidance
-- put the declarations in a canonical order, sorted by OccName
- let sorted_decls = eltsFM $ listToFM $
+ let sorted_decls = Map.elems $ Map.fromList $
[(ifName d, e) | e@(_, d) <- decls_w_hashes]
-- the ABI hash depends on:
| otherwise
= case nameModule_maybe name of
Nothing -> pprPanic "mkUsageInfo: internal name?" (ppr name)
- Just mod -> -- We use this fiddly lambda function rather than
- -- (++) as the argument to extendModuleEnv_C to
+ Just mod -> -- This lambda function is really just a
+ -- specialised (++); originally came about to
-- avoid quadratic behaviour (trac #2680)
- extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
+ extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
where occ = nameOccName name
-- We want to create a Usage for a home module if
usg_mod_name = moduleName mod,
usg_mod_hash = mod_hash,
usg_exports = export_hash,
- usg_entities = fmToList ent_hashs }
+ usg_entities = Map.toList ent_hashs }
where
maybe_iface = lookupIfaceByModule dflags hpt pit mod
-- In one-shot mode, the interfaces for home-package
used_occs = lookupModuleEnv ent_map mod `orElse` []
- -- Making a FiniteMap here ensures that (a) we remove duplicates
+ -- Making a Map here ensures that (a) we remove duplicates
-- when we have usages on several subordinates of a single parent,
-- and (b) that the usages emerge in a canonical order, which
- -- is why we use FiniteMap rather than OccEnv: FiniteMap works
+ -- is why we use Map rather than OccEnv: Map works
-- using Ord on the OccNames, which is a lexicographic ordering.
- ent_hashs :: FiniteMap OccName Fingerprint
- ent_hashs = listToFM (map lookup_occ used_occs)
+ ent_hashs :: Map OccName Fingerprint
+ ent_hashs = Map.fromList (map lookup_occ used_occs)
lookup_occ occ =
case hash_env occ of
-> [(Module, [GenAvailInfo OccName])]
-- Group by module and sort by occurrence
mkIfaceExports exports
- = [ (mod, eltsFM avails)
+ = [ (mod, Map.elems avails)
| (mod, avails) <- sortBy (stableModuleCmp `on` fst)
(moduleEnvToList groupFM)
- -- NB. the fmToList is in a random order,
+ -- NB. the Map.toList is in a random order,
-- because Ord Module is not a predictable
-- ordering. Hence we perform a final sort
-- using the stable Module ordering.
where
-- Group by the module where the exported entities are defined
-- (which may not be the same for all Names in an Avail)
- -- Deliberately use FiniteMap rather than UniqFM so we
+ -- Deliberately use Map rather than UniqFM so we
-- get a canonical ordering
- groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+ groupFM :: ModuleEnv (Map FastString (GenAvailInfo OccName))
groupFM = foldl add emptyModuleEnv exports
- add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+ add_one :: ModuleEnv (Map FastString (GenAvailInfo OccName))
-> Module -> GenAvailInfo OccName
- -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+ -> ModuleEnv (Map FastString (GenAvailInfo OccName))
add_one env mod avail
- = extendModuleEnv_C plusFM env mod
- (unitFM (occNameFS (availName avail)) avail)
+ -- XXX Is there a need to flip Map.union here?
+ = extendModuleEnvWith (flip Map.union) env mod
+ (Map.singleton (occNameFS (availName avail)) avail)
-- NB: we should not get T(X) and T(Y) in the export list
- -- else the plusFM will simply discard one! They
+ -- else the Map.union will simply discard one! They
-- should have been combined by now.
add env (Avail n)
= ASSERT( isExternalName n )
--------------------------
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
- , uf_src = src, uf_guidance = guidance })
+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+ , uf_src = src, uf_guidance = guidance })
= Just $ HsUnfold lb $
case src of
- InlineRule {}
+ InlineStable
-> case guidance of
- UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs)
- _other -> pprPanic "toIfUnfolding" (ppr unf)
+ UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
+ _other -> IfCoreUnfold True if_rhs
InlineWrapper w -> IfWrapper arity (idName w)
- InlineCompulsory -> IfCompulsory (toIfaceExpr rhs)
- InlineRhs -> IfCoreUnfold (toIfaceExpr rhs)
+ InlineCompulsory -> IfCompulsory if_rhs
+ InlineRhs -> IfCoreUnfold False if_rhs
-- Yes, even if guidance is UnfNever, expose the unfolding
-- If we didn't want to expose the unfolding, TidyPgm would
-- have stuck in NoUnfolding. For supercompilation we want
-- to see that unfolding!
+ where
+ if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding _ar _con ops)
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops)))
coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
- ru_args = args, ru_rhs = rhs })
+ ru_args = args, ru_rhs = rhs,
+ ru_auto = auto })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
ifRuleArgs = map do_arg args,
ifRuleRhs = toIfaceExpr rhs,
+ ifRuleAuto = auto,
ifRuleOrph = orph }
where
-- For type args we must remove synonyms from the outermost
bogusIfaceRule id_name
= IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
- ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
+ ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
---------------------
toIfaceExpr :: CoreExpr -> IfaceExpr
projects / ghc-hetmet.git / blobdiff