, elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C
, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv
, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
- , rngModuleEnv, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
+ , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
, lookupModuleEnvByName, extendModuleEnv_C
) where
delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a
plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b
-rngModuleEnv :: ModuleEnv a -> [a]
+moduleEnvElts :: ModuleEnv a -> [a]
isEmptyModuleEnv :: ModuleEnv a -> Bool
lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a
mapModuleEnv = mapUFM
mkModuleEnv = listToUFM
emptyModuleEnv = emptyUFM
-rngModuleEnv = eltsUFM
+moduleEnvElts = eltsUFM
unitModuleEnv = unitUFM
isEmptyModuleEnv = isNullUFM
foldModuleEnv = foldUFM
import StgSyn
import CgMonad
import AbsCSyn
-import CLabel ( CLabel, mkSRTLabel, mkClosureLabel,
- mkModuleInitLabel, labelDynamic )
+import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel )
import PprAbsC ( dumpRealC )
import AbsCUtils ( mkAbstractCs, flattenAbsC )
opt_SccProfilingOn, opt_EnsureSplittableC )
import CostCentre ( CostCentre, CostCentreStack )
import Id ( Id, idName )
-import Module ( Module, moduleString, moduleName,
- ModuleName )
-import PrimRep ( getPrimRepSize, PrimRep(..) )
-import Type ( Type )
+import Module ( Module )
+import PrimRep ( PrimRep(..) )
import TyCon ( TyCon, isDataTyCon )
import Class ( Class, classTyCon )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn )
-import Util
import Panic ( assertPanic )
\end{code}
import VarEnv
import VarSet
import Var ( Id, Var )
-import Id ( idType, idInfo, idName, idSpecialisation,
+import Id ( idType, idInfo, idName,
mkVanillaId, mkId, exportWithOrigOccName,
idStrictness, setIdStrictness,
idDemandInfo, setIdDemandInfo,
workerInfo, setWorkerInfo, WorkerInfo(..)
)
import Demand ( wwLazy )
-import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
+import Name ( getOccName, tidyTopName, mkLocalName )
import OccName ( initTidyOccEnv, tidyOccName )
-import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars )
+import Type ( tidyTopType, tidyType, tidyTyVar )
import Module ( Module )
import UniqSupply ( mkSplitUniqSupply )
import Unique ( Uniquable(..) )
binds_in1 <- if opt_UsageSPOn
then _scc_ "CoreUsageSPInf"
- doUsageSPInf dflags us binds_in rulebase_in
+ doUsageSPInf dflags us binds_in
else return binds_in
let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name))
HsExpr(..), HsBinds(..), MonoBinds(..) )
import TcHsSyn ( TypecheckedRuleDecl )
import TcModule ( TcResults(..) )
+import Id ( Id )
import CoreSyn
import PprCore ( pprIdCoreRule )
import Subst ( substExpr, mkSubst, mkInScopeSet )
VersionInfo(..), initialVersionInfo,
- TyThing(..), groupTyThings,
+ TyThing(..), groupTyThings, isTyClThing,
TypeEnv, extendTypeEnv, lookupTypeEnv,
| ATyCon TyCon
| AClass Class
+isTyClThing :: TyThing -> Bool
+isTyClThing (ATyCon _) = True
+isTyClThing (AClass _) = True
+isTyClThing (AnId _) = False
+
instance NamedThing TyThing where
getName (AnId id) = getName id
getName (ATyCon tc) = getName tc
\section[MkIface]{Print an interface for a module}
\begin{code}
-module MkIface ( completeIface ) where
+module MkIface (
+ mkModDetails, mkModDetailsFromIface, completeIface
+ ) where
#include "HsVersions.h"
import HsSyn
-import HsCore ( HsIdInfo(..), toUfExpr, ifaceSigName )
+import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
import HsTypes ( toHsTyVars )
import BasicTypes ( Fixity(..), NewOrData(..),
Version, bumpVersion, isLoopBreaker
)
import RnMonad
-import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedIfaceSig )
+import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
+import TcHsSyn ( TypecheckedRuleDecl )
import HscTypes ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
- TyThing(..), DFunId )
+ TyThing(..), DFunId, TypeEnv, isTyClThing
+ )
import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
- idSpecialisation
+ idSpecialisation, idName, setIdInfo
)
import Var ( isId )
import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
-import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
- CprInfo(..), CafInfo(..),
- inlinePragInfo, arityInfo, arityLowerBound,
- strictnessInfo, isBottomingStrictness,
- cafInfo, specInfo, cprInfo,
- occInfo, isNeverInlinePrag,
- workerInfo, WorkerInfo(..)
+import IdInfo -- Lots
+import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
+ isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
+ bindersOfBinds
)
-import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
-import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold )
-import Name ( isLocallyDefined, getName, nameModule,
+import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
+import Name ( isLocallyDefined, getName,
Name, NamedThing(..),
- plusNameEnv, lookupNameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv_NF, nameEnvElts
+ plusNameEnv, lookupNameEnv, emptyNameEnv, mkNameEnv,
+ extendNameEnv, lookupNameEnv_NF, nameEnvElts
)
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
import Class ( classExtraBigSig, DefMeth(..) )
import FieldLabel ( fieldLabelType )
import Type ( splitSigmaTy, tidyTopType, deNoteType )
-
-import Rules ( ProtoCoreRule(..) )
-
-import Bag ( bagToList )
-import UniqFM ( lookupUFM, listToUFM )
import SrcLoc ( noSrcLoc )
-import Bag
import Outputable
import List ( partition )
%************************************************************************
\begin{code}
-completeModDetails :: ModDetails
- -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
- -- code generator; they have authoritative arity info
- -> [IdCoreRule] -- Tidy orphan rules
- -> ModDetails
-completeModDetails mds tidy_binds stg_ids orphan_rules
- = ModDetails {
-
+mkModDetails :: TypeEnv -> [DFunId] -- From typechecker
+ -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
+ -- code generator; they have authoritative arity info
+ -> [IdCoreRule] -- Tidy orphan rules
+ -> ModDetails
+mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
+ = ModDetails { md_types = new_type_env,
+ md_rules = rule_dcls,
+ md_insts = dfun_ids }
where
- dfun_ids = md_insts mds
-
+ -- The competed type environment is gotten from
+ -- a) keeping the types and classes
+ -- b) removing all Ids, and Ids with correct IdInfo
+ -- gotten from the bindings
+ new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
+ `plusNameEnv`
+ mkNameEnv [(idName id, AnId id) | id <- final_ids]
+
+ orig_type_env = nameEnvElts type_env
+
final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
(mkVarSet stg_ids)
tidy_binds
- rule_dcls | opt_OmitInterfacePragmas = []
- | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
-
- orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
- | (_, rule) <- tidy_orphan_rules]
-
+ -- The complete rules are gotten by combining
+ -- a) the orphan rules
+ -- b) rules embedded in the top-level Ids
+ rule_dcls | opt_OmitInterfacePragmas = []
+ | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
+
+ orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
+ | (_, rule) <- orphan_rules]
+
+
+-- This version is used when we are re-linking a module
+-- so we've only run the type checker on its previous interface
+mkModDetailsFromIface :: TypeEnv -> [DFunId] -- From typechecker
+ -> [TypecheckedRuleDecl]
+ -> ModDetails
+mkModDetailsFromIface type_env dfun_ids rules
+ = ModDetails { md_types = type_env,
+ md_rules = rule_dcls,
+ md_insts = dfun_ids }
+ where
+ rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
+ -- All the rules from an interface are of the IfaceRuleOut form
completeIface :: Maybe ModIface -- The old interface, if we have it
-> ModIface -- The new one, minus the decls and versions
dcl_insts = inst_dcls,
dcl_rules = rule_dcls }
- inst_dcls = map ifaceInstance (mk_insts mds)
- ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types details))
- rule_dcls = map ifaceRule (md_rules details)
+ inst_dcls = map ifaceInstance (md_insts mod_details)
+ ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types mod_details))
+ rule_dcls = map ifaceRule (md_rules mod_details)
\end{code}
------------ Worker --------------
- wkr_hsinfo = case workerInfo id_info of
+ wrkr_hsinfo = case workerInfo id_info of
HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
NoWorker -> []
------------ Unfolding --------------
- unfold_info = unfoldInfo id_info
- inine_prag = inlinePragInfo id_info
- rhs = unfoldingTempate unfold_info
+ unfold_info = unfoldingInfo id_info
+ inline_prag = inlinePragInfo id_info
+ rhs = unfoldingTemplate unfold_info
unfold_hsinfo | neverUnfold unfold_info = []
| otherwise = [HsUnfold inline_prag (toUfExpr rhs)]
\end{code}
-- exported, there's no need to emit anything
need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
- go needed [] decls emitted
+ go needed [] emitted
| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
(sep (map ppr (varSetElems needed)))
emitted
binds
(new_id:emitted)
| otherwise
- = go needed binds decls emitted
+ = go needed binds emitted
where
(new_id, extras) = mkFinalId codegen_ids False id rhs
-- have to look for a fixed point. We don't want necessarily them all,
-- because without -O we may only need the first one (if we don't emit
-- its unfolding)
- go needed (Rec pairs : binds) decls emitted
+ go needed (Rec pairs : binds) emitted
= go needed' binds emitted'
where
(new_emitted, extras) = go_rec needed pairs
mkFinalId codegen_ids is_rec id rhs
= (id `setIdInfo` new_idinfo, new_needed_ids)
where
- id_type = idType id
core_idinfo = idInfo id
stg_idinfo = case lookupVarSet codegen_ids id of
Just id' -> idInfo id'
new_idinfo | opt_OmitInterfacePragmas
= vanillaIdInfo
| otherwise
- = core_idinfo `setArityInfo` stg_arity_info
+ = core_idinfo `setArityInfo` arity_info
`setCafInfo` cafInfo stg_idinfo
`setUnfoldingInfo` unfold_info
`setWorkerInfo` worker_info
-- passed on separately through the modules IdCoreRules
------------ Arity --------------
- stg_arity_info = arityInfo stg_idinfo
- stg_arity = arityLowerBound arity_info
+ arity_info = arityInfo stg_idinfo
+ stg_arity = arityLowerBound arity_info
------------ Worker --------------
-- We only treat a function as having a worker if
-- compilation of this module it means "how many things can I apply
-- this to".
worker_info = case workerInfo core_idinfo of
- HasWorker work_id wrap_arity
- | wrap_arity == stg_arity -> worker_info_in
+ info@(HasWorker work_id wrap_arity)
+ | wrap_arity == stg_arity -> info
| otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
NoWorker
NoWorker -> NoWorker
= Nothing
| otherwise -- Add updated version numbers
- = Just (final_iface, pp_tc_diffs $$ pp_sig_diffs)
+ = Just (final_iface, pp_tc_diffs)
where
final_iface = new_iface { mi_version = new_version }
new_version = VersionInfo { vers_module = bumpVersion no_output_change (vers_module old_version),
vers_exports = bumpVersion no_export_change (vers_exports old_version),
vers_rules = bumpVersion no_rule_change (vers_rules old_version),
- vers_decls = sig_vers `plusNameEnv` tc_vers }
+ vers_decls = tc_vers }
no_output_change = no_tc_change && no_rule_change && no_export_change
no_usage_change = mi_usages old_iface == mi_usages new_iface
-- Set the flag if anything changes.
-- Assumes that the decls are sorted by hsDeclName.
old_vers_decls = vers_decls old_version
- (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls (dcl_tycl old_decls) (dcl_tycl new_decls)
+ (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
+ (dcl_tycl old_decls) (dcl_tycl new_decls)
diffDecls :: NameEnv Version -- Old version map
+ -> NameEnv Fixity -> NameEnv Fixity -- Old and new fixities
-> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls
-> (Bool, -- True <=> no change
SDoc, -- Record of differences
NameEnv Version) -- New version
-diffDecls old_vers old new
+diffDecls old_vers old_fixities new_fixities old new
= diff True empty emptyNameEnv old new
where
-- When seeing if two decls are the same,
= case od_name `compare` nd_name of
LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds)
GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
- EQ | od `eq` nd -> diff ok_so_far pp new_vers ods nds
- | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
+ EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds
+ | otherwise -> diff False (pp $$ changed od nd) new_vers' ods nds
where
- od_name = get_name od
- nd_name = get_name nd
+ od_name = tyClDeclName od
+ nd_name = tyClDeclName nd
new_vers' = extendNameEnv new_vers nd_name
(bumpVersion True (lookupNameEnv_NF old_vers od_name))
fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
= fiExpr new_to_drop body
where
- (binders, rhss) = unzip bindings
+ rhss = map snd bindings
rhss_fvs = map freeVarsOf rhss
body_fvs = freeVarsOf body
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import ErrUtils ( dumpIfSet_dyn )
import CostCentre ( dupifyCC, CostCentre )
-import Id ( Id, idType )
+import Id ( Id )
import VarEnv
import CoreLint ( beginPass, endPass )
import SetLevels ( setLevels,
Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl
)
-import Type ( isUnLiftedType )
-import Var ( TyVar )
import UniqSupply ( UniqSupply )
import List ( partition )
import Outputable
)
import CoreLint ( beginPass, endPass )
import CoreSyn
+import CoreFVs ( ruleSomeFreeVars )
+import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) )
import CSE ( cseProgram )
-import Rules ( RuleBase, extendRuleBaseList, addRuleBaseFVs )
+import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, extendRuleBaseList, addRuleBaseFVs )
+import Module ( moduleEnvElts )
import CoreUnfold
-import PprCore ( pprCoreBindings, pprCoreRulePair )
+import PprCore ( pprCoreBindings, pprIdCoreRule )
import OccurAnal ( occurAnalyseBinds )
-import CoreUtils ( exprIsTrivial, etaReduceExpr, coreBindsSize )
+import CoreUtils ( etaReduceExpr, coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplBinders )
import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( isDataConWrapId )
+import Id ( Id, isDataConWrapId, setIdNoDiscard )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
- (rule_base, binds1, orphan_rules) <- prepareRules pkg_rule_base hst binds rules
+ (rule_base, binds1, orphan_rules)
+ <- prepareRules dflags pkg_rule_base hst ru_us binds rules
-- DO THE BUSINESS
(stats, processed_binds)
- <- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 rule_base core_todos
+ <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
= do
let (us1, us2) = splitUniqSupply us
- (stats1, binds1, mlrb1) <- doCorePass dflags rb us1 binds to_do
+ (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
= _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
doCorePass dfs rb us binds CoreDoCPResult
= _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
-doCorePass dfs us binds CoreDoPrintCore
+doCorePass dfs rb us binds CoreDoPrintCore
= _scc_ "PrintCore" noStats dfs (printCore binds)
doCorePass dfs rb us binds CoreDoUSPInf
= _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
(mapSmpl simplRule rules)
; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
- (vcat (map pprCoreRulePair better_rules))
+ (vcat (map pprIdCoreRule better_rules))
- ; let (local_id_rules, orphan_rules) = partition (`elemVarSet` local_ids . fst) better_rules
+ ; let (local_id_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
(binds1, local_rule_fvs) = addRulesToBinds binds local_id_rules
imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst)
rule_base = extendRuleBaseList imp_rule_base orphan_rules
final_rule_base = addRuleBaseFVs rule_base local_rule_fvs
-- The last step black-lists the free vars of local rules too
- ; return (rule_base, binds1, orphan_rules)
+ ; return (final_rule_base, binds1, orphan_rules)
}
where
sw_chkr any = SwBool False -- A bit bogus
-- simpVar fails if it isn't right, and it might conceiveably matter
local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], FreeVars)
+addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], IdSet)
-- A horrible function
-- Attach the rules for each locally-defined Id to that Id.
-- - It makes sure that, when we apply a rule, the free vars
-- of the RHS are more likely to be in scope
--
- -- The LHS and RHS Ids are marked 'no-discard'.
+ -- Both the LHS and RHS Ids are marked 'no-discard'.
-- This means that the binding won't be discarded EVEN if the binding
-- ends up being trivial (v = w) -- the simplifier would usually just
-- substitute w for v throughout, but we don't apply the substitution to
-- the rules (maybe we should?), so this substitution would make the rule
-- bogus.
-addRulesToBinds binds imported_rule_base local_rules
+addRulesToBinds binds local_rules
= (map zap_bind binds, rule_lhs_fvs)
where
- RuleBase rule_ids rule_lhs_fvs = extendRuleBaseList emptyRuleBase local_rules
-
- imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-
-- rule_fvs is the set of all variables mentioned in this module's rules
- rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
+ rule_fvs = unionVarSets [ ruleSomeFreeVars isId rule | (_,rule) <- local_rules ]
+
+ rule_base = extendRuleBaseList emptyRuleBase local_rules
+ rule_lhs_fvs = ruleBaseFVs rule_base
+ rule_ids = ruleBaseIds rule_base
zap_bind (NonRec b r) = NonRec (zap_bndr b) r
zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
-> [CoreBind] -- Input
-> IO (SimplCount, [CoreBind]) -- New bindings
-simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs)
+simplifyPgm dflags rule_base
sw_chkr us binds
= do {
beginPass dflags "Simplify";
return (counts_out, binds')
}
where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
-
+ max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
+ black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
+ imported_rule_ids = ruleBaseIds rule_base
+ rule_lhs_fvs = ruleBaseFVs rule_base
+
iteration us iteration_no counts binds
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
import CoreUtils ( exprOkForSpeculation )
import PprCore () -- Instances
import CostCentre ( CostCentreStack, subsumedCCS )
-import Name ( isLocallyDefined )
import OccName ( UserFS )
import VarEnv
import VarSet
import qualified Subst
import Subst ( Subst, mkSubst, substEnv,
- InScopeSet, mkInScopeSet, substInScope, isInScope
+ InScopeSet, mkInScopeSet, substInScope
)
import Type ( Type, isUnLiftedType )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
opt_UF_UpdateInPlace
)
import CoreSyn
-import CoreUnfold ( isValueUnfolding )
import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
-import Id ( Id, idType, isId, idName,
- idOccInfo, idUnfolding, idStrictness,
+import Id ( idType, idName,
+ idUnfolding, idStrictness,
mkId, idInfo
)
-import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, setOccInfo, vanillaIdInfo )
+import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, vanillaIdInfo )
import Maybes ( maybeToBool, catMaybes )
import Name ( setNameUnique )
-import Demand ( Demand, isStrict, wwLazy, wwLazy )
+import Demand ( isStrict )
import SimplMonad
-import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
- splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys,
- isDictTy, isDataType, applyTy, splitFunTy, isUnLiftedType,
+import Type ( Type, mkForAllTys, seqType, repType,
+ splitTyConApp_maybe, mkTyVarTys, splitFunTys,
+ isDictTy, isDataType, isUnLiftedType,
splitRepFunTys
)
import TyCon ( tyConDataConsIfAvailable )
import DataCon ( dataConRepArity )
-import VarSet
-import VarEnv ( SubstEnv, SubstResult(..) )
+import VarEnv ( SubstEnv )
import Util ( lengthExceeds )
-import BasicTypes ( Arity )
import Outputable
\end{code}
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
- ArityInfo, setArityInfo, unknownArity,
+ setArityInfo, unknownArity,
setUnfoldingInfo,
occInfo
)
-import Demand ( Demand, isStrict )
+import Demand ( isStrict )
import DataCon ( dataConNumInstArgs, dataConRepStrictness,
dataConSig, dataConArgTys
)
)
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe,
exprType, coreAltsType, exprIsValue, idAppIsCheap,
- exprOkForSpeculation, etaReduceExpr,
+ exprOkForSpeculation,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
import Rules ( lookupRule )
import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType,
- mkFunTy, splitFunTy, splitTyConApp_maybe,
+ mkFunTy, splitTyConApp_maybe,
funResultTy
)
-import Subst ( mkSubst, substTy, substExpr,
+import Subst ( mkSubst, substTy,
isInScope, lookupIdSubst, substIdInfo
)
import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
old_info = idInfo old_bndr
occ_info = occInfo old_info
loop_breaker = isLoopBreaker occ_info
- trivial_rhs = exprIsTrivial new_rhs
must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
finally_bind_it arity_info new_rhs
\begin{code}
module Rules (
- RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList, pprRuleBase,
- addRuleBaseFVs,
+ RuleBase, emptyRuleBase,
+ extendRuleBase, extendRuleBaseList, addRuleBaseFVs,
+ ruleBaseIds, ruleBaseFVs,
+ pprRuleBase,
lookupRule, addRule, addIdSpecialisations
) where
-- This representation is a bit cute, and I wonder if we should
-- change it to use (IdEnv CoreRule) which seems a bit more natural
+ruleBaseIds (RuleBase ids _) = ids
+ruleBaseFVs (RuleBase _ fvs) = fvs
+
emptyRuleBase = RuleBase emptyVarSet emptyVarSet
addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
-import Id ( Id, idName, idType, mkTemplateLocals, mkUserLocal,
- idSpecialisation, setIdNoDiscard, isExportedId,
- modifyIdInfo, idUnfolding
+import Id ( Id, idName, idType, mkUserLocal,
+ idSpecialisation, modifyIdInfo
)
import IdInfo ( zapSpecPragInfo )
import VarSet
import VarEnv
-import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
- tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
- mkForAllTys, boxedTypeKind
+import Type ( Type, mkTyVarTy, splitSigmaTy,
+ tyVarsOfTypes, tyVarsOfTheta,
+ mkForAllTys
)
import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, mkInScopeSet,
substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
)
-import Var ( TyVar, mkSysTyVar, setVarUnique )
import VarSet
import VarEnv
import CoreSyn
import UniqSupply ( UniqSupply,
UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs,
- getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
+ getUs, setUs, mapUs
)
import Name ( nameOccName, mkSpecOcc, getSrcLoc )
import FiniteMap
-import Maybes ( MaybeErr(..), catMaybes, maybeToBool )
+import Maybes ( catMaybes, maybeToBool )
import ErrUtils ( dumpIfSet_dyn )
import Bag
import List ( partition )
-import Util ( zipEqual, zipWithEqual, mapAccumL )
+import Util ( zipEqual, zipWithEqual )
import Outputable
type SpecM a = UniqSM a
thenSM = thenUs
-thenSM_ = thenUs_
returnSM = returnUs
getUniqSM = getUniqueUs
-getUniqSupplySM = getUs
-setUniqSupplySM = setUs
mapSM = mapUs
initSM = initUs_
new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
in
returnSM new_id
-
-newTyVarSM
- = getUniqSM `thenSM` \ uniq ->
- returnSM (mkSysTyVar uniq boxedTypeKind)
\end{code}
projects / ghc-hetmet.git / commitdiff