Skip to content

GitLab

Commit 243dedb8 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-25 13:51:50 by simonpj] 

Wibbles
parent 90fa6b84
Hide whitespace changes
Inline Side-by-side
Showing with 160 additions and 142 deletions
ghc/compiler/basicTypes/Module.lhs
View file @ 243dedb8
......@@ -56,7 +56,7 @@ module Module
, 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
......@@ -275,7 +275,7 @@ delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a
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
......@@ -298,7 +298,7 @@ lookupWithDefaultModuleEnv = lookupWithDefaultUFM
mapModuleEnv = mapUFM
mkModuleEnv = listToUFM
emptyModuleEnv = emptyUFM
rngModuleEnv = eltsUFM
moduleEnvElts = eltsUFM
unitModuleEnv = unitUFM
isEmptyModuleEnv = isNullUFM
foldModuleEnv = foldUFM
......
ghc/compiler/codeGen/CodeGen.lhs
View file @ 243dedb8
......@@ -22,8 +22,7 @@ module CodeGen ( codeGen ) where
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 )
......@@ -36,16 +35,13 @@ import CmdLineOpts ( DynFlags, DynFlag(..),
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}
......
ghc/compiler/coreSyn/CoreTidy.lhs
View file @ 243dedb8
......@@ -19,7 +19,7 @@ import UsageSPInf ( doUsageSPInf )
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,
......@@ -29,9 +29,9 @@ import IdInfo ( specInfo, setSpecInfo,
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(..) )
......@@ -76,7 +76,7 @@ tidyCorePgm dflags module_name binds_in orphans_in
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))
......
ghc/compiler/deSugar/Desugar.lhs
View file @ 243dedb8
......@@ -13,6 +13,7 @@ import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
HsExpr(..), HsBinds(..), MonoBinds(..) )
import TcHsSyn ( TypecheckedRuleDecl )
import TcModule ( TcResults(..) )
import Id ( Id )
import CoreSyn
import PprCore ( pprIdCoreRule )
import Subst ( substExpr, mkSubst, mkInScopeSet )
......
ghc/compiler/main/HscTypes.lhs
View file @ 243dedb8
......@@ -16,7 +16,7 @@ module HscTypes (
VersionInfo(..), initialVersionInfo,
TyThing(..), groupTyThings,
TyThing(..), groupTyThings, isTyClThing,
TypeEnv, extendTypeEnv, lookupTypeEnv,
......@@ -215,6 +215,11 @@ data TyThing = AnId Id
| 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
......
ghc/compiler/main/MkIface.lhs
View file @ 243dedb8
......@@ -4,42 +4,43 @@
\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
......@@ -47,13 +48,7 @@ import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
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 )
......@@ -67,27 +62,52 @@ 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
......@@ -109,9 +129,9 @@ completeIface maybe_old_iface new_iface mod_details
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}
......@@ -220,14 +240,14 @@ ifaceTyCls (AnId id)
------------ 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}
......@@ -293,7 +313,7 @@ bindsToIds needed_ids codegen_ids binds
-- 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
......@@ -308,7 +328,7 @@ bindsToIds needed_ids codegen_ids binds
binds
(new_id:emitted)
| otherwise
= go needed binds decls emitted
= go needed binds emitted
where
(new_id, extras) = mkFinalId codegen_ids False id rhs
......@@ -317,7 +337,7 @@ bindsToIds needed_ids codegen_ids binds
-- 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
......@@ -351,7 +371,6 @@ mkFinalId :: IdSet -- The Ids with arity info from the code generator
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'
......@@ -361,7 +380,7 @@ mkFinalId codegen_ids is_rec id rhs
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
......@@ -370,8 +389,8 @@ mkFinalId codegen_ids is_rec id rhs
-- 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
......@@ -396,8 +415,8 @@ mkFinalId codegen_ids is_rec id rhs
-- 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
......@@ -508,14 +527,14 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
= 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
......@@ -527,17 +546,19 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
-- 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,
......@@ -552,11 +573,11 @@ diffDecls old_vers old new
= 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))
......
ghc/compiler/simplCore/FloatIn.lhs
View file @ 243dedb8
......@@ -270,7 +270,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
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
......
ghc/compiler/simplCore/FloatOut.lhs
View file @ 243dedb8
......@@ -16,14 +16,12 @@ import CoreUtils ( mkSCC )
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
......
ghc/compiler/simplCore/SimplCore.lhs
View file @ 243dedb8
......@@ -15,19 +15,22 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
)
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 )
......@@ -65,12 +68,13 @@ core2core dflags pkg_rule_base hst core_todos binds rules
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"
......@@ -97,7 +101,7 @@ doCorePasses dflags rb stats us binds (to_do : to_dos)
= 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
......@@ -121,7 +125,7 @@ doCorePass dfs rb us binds CoreDoSpecialising
= _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)
......@@ -165,16 +169,16 @@ prepareRules dflags pkg_rule_base hst us binds rules
(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
......@@ -189,7 +193,7 @@ prepareRules dflags pkg_rule_base hst us binds rules
-- 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.
......@@ -201,22 +205,22 @@ addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], FreeVars)
-- - 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]
......@@ -312,7 +316,7 @@ simplifyPgm :: DynFlags
-> [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";
......@@ -335,9 +339,11 @@ simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs)
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.
......
ghc/compiler/simplCore/SimplMonad.lhs
View file @ 243dedb8
......@@ -55,13 +55,12 @@ import CoreUnfold ( isCompulsoryUnfolding )
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,
......
ghc/compiler/simplCore/SimplUtils.lhs
View file @ 243dedb8
......@@ -23,29 +23,26 @@ import CmdLineOpts ( switchIsOn, SimplifierSwitch(..),
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}
......
ghc/compiler/simplCore/Simplify.lhs
View file @ 243dedb8
......@@ -29,11 +29,11 @@ import Id ( Id, idType, idInfo, isDataConId,
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
)
......@@ -44,16 +44,16 @@ import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
)
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe,
exprType, coreAltsType, exprIsValue, idAppIsCheap,
exprOkForSpeculation, etaReduceExpr,
exprOkForSpeculation,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr