Skip to content

GitLab

Glasgow Haskell Compiler
Glasgow Haskell Compiler
Commit 90fa6b84 authored by simonpj's avatar simonpj
Browse files
Options

[project @ 2000-10-25 12:56:20 by simonpj] 

Tons of stuff for the mornings work
parent b125ffe2
Hide whitespace changes
Inline Side-by-side
Showing with 656 additions and 707 deletions
ghc/compiler/Simon-log
View file @ 90fa6b84
------------------------------------
GHCI hacking
------------------------------------
* Don't forget to put deferred-type-decls back into RnIfaces
* Do we want to record a package name in a .hi file?
Does pi_mod have a ModuleName or a Module?
* Does teh finder
------------------------------------
Mainly PredTypes (28 Sept 00)
------------------------------------
......
ghc/compiler/basicTypes/Name.lhs
View file @ 90fa6b84
......@@ -41,7 +41,7 @@ module Name (
#include "HsVersions.h"
import OccName -- All of it
import Module ( Module, moduleName, pprModule, mkVanillaModule,
import Module ( Module, moduleName, mkVanillaModule,
isModuleInThisPackage )
import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc,
rdrNameModule )
......@@ -480,7 +480,7 @@ toRdrName :: NamedThing a => a -> RdrName
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
getOccString x = occNameString (getOccName x)
getOccString = occNameString . getOccName
toRdrName = ifaceNameRdrName . getName
\end{code}
......
ghc/compiler/coreSyn/CoreSyn.lhs
View file @ 90fa6b84
......@@ -28,7 +28,7 @@ module CoreSyn (
noUnfolding, mkOtherCon,
unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
-- Seq stuff
seqRules, seqExpr, seqExprs, seqUnfolding,
......@@ -39,6 +39,7 @@ module CoreSyn (
-- Core rules
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
IdCoreRule,
RuleName,
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
isBuiltinRule
......@@ -47,9 +48,9 @@ module CoreSyn (
#include "HsVersions.h"
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId, idType )
import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
import Literal ( Literal(MachStr), mkMachInt )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, UsageAnn, mkTyVarTy, seqType )
import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConId )
import VarSet
import Outputable
......@@ -137,6 +138,7 @@ rulesRules (Rules rules _) = rules
\begin{code}
type RuleName = FAST_STRING
type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
data CoreRule
= Rule RuleName
......@@ -257,6 +259,12 @@ hasUnfolding other = False
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
hasSomeUnfolding other = True
neverUnfold :: Unfolding -> Bool
neverUnfold NoUnfolding = True
neverUnfold (OtherCon _) = True
neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
neverUnfold other = False
\end{code}
......@@ -296,7 +304,6 @@ type CoreExpr = Expr CoreBndr
type CoreArg = Arg CoreBndr
type CoreBind = Bind CoreBndr
type CoreAlt = Alt CoreBndr
type CoreNote = Note
\end{code}
Binders are ``tagged'' with a \tr{t}:
......
ghc/compiler/coreSyn/CoreTidy.lhs
View file @ 90fa6b84
......@@ -15,7 +15,6 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt )
import CoreSyn
import CoreUnfold ( noUnfolding )
import CoreLint ( beginPass, endPass )
import Rules ( ProtoCoreRule(..), RuleBase )
import UsageSPInf ( doUsageSPInf )
import VarEnv
import VarSet
......@@ -66,9 +65,10 @@ Several tasks are done by @tidyCorePgm@
from the uniques for local thunks etc.]
\begin{code}
tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase
-> IO ([CoreBind], [ProtoCoreRule])
tidyCorePgm dflags module_name binds_in rulebase_in
tidyCorePgm :: DynFlags -> Module
-> [CoreBind] -> [IdCoreRule]
-> IO ([CoreBind], [IdCoreRule])
tidyCorePgm dflags module_name binds_in orphans_in
= do
us <- mkSplitUniqSupply 'u'
......@@ -81,13 +81,13 @@ tidyCorePgm dflags module_name binds_in rulebase_in
let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name))
init_tidy_env binds_in1
rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in)
orphans_out = tidyIdRules tidy_env1 orphans_in
endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
dopt Opt_D_verbose_core2core dflags)
binds_out
return (binds_out, rules_out)
return (binds_out, orphans_out)
where
-- We also make sure to avoid any exported binders. Consider
-- f{-u1-} = 1 -- Local decl
......@@ -101,11 +101,6 @@ tidyCorePgm dflags module_name binds_in rulebase_in
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
exportWithOrigOccName bndr]
mk_local_protos :: RuleBase -> [ProtoCoreRule]
mk_local_protos (rule_ids, _)
= [ProtoCoreRule True id rule | id <- varSetElems rule_ids,
rule <- rulesRules (idSpecialisation id)]
tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
-> TidyEnv
-> CoreBind
......@@ -245,17 +240,15 @@ tidyIdInfo env info
| otherwise = info `setSpecInfo` tidyRules env rules
info3 = info2 `setUnfoldingInfo` noUnfolding
info4 = info3 `setDemandInfo` wwLazy -- I don't understand why...
info4 = info3 `setDemandInfo` wwLazy
info5 = case workerInfo info of
NoWorker -> info4
HasWorker w a -> info4 `setWorkerInfo` HasWorker (tidyVarOcc env w) a
tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule]
tidyProtoRules env rules
= [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule)
| ProtoCoreRule is_local fn rule <- rules
]
tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
tidyIdRules env rules
= [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules ]
tidyRules :: TidyEnv -> CoreRules -> CoreRules
tidyRules env (Rules rules fvs)
......
ghc/compiler/coreSyn/CoreUnfold.lhs
View file @ 90fa6b84
......@@ -20,7 +20,7 @@ module CoreUnfold (
mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
couldBeSmallEnoughToInline,
certainlyWillInline,
......
ghc/compiler/coreSyn/PprCore.lhs
View file @ 90fa6b84
......@@ -12,7 +12,7 @@ module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprIdBndr,
pprCoreBinding, pprCoreBindings,
pprCoreRules, pprCoreRule
pprCoreRules, pprCoreRule, pprIdCoreRule
) where
#include "HsVersions.h"
......@@ -361,6 +361,9 @@ ppIdInfo b info
pprCoreRules :: Id -> CoreRules -> SDoc
pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
pprIdCoreRule :: IdCoreRule -> SDoc
pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
pprCoreRule :: SDoc -> CoreRule -> SDoc
pprCoreRule pp_fn (BuiltinRule _)
= ifPprDebug (ptext SLIT("A built in rule"))
......
ghc/compiler/deSugar/Desugar.lhs
View file @ 90fa6b84
......@@ -14,7 +14,7 @@ import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
import TcHsSyn ( TypecheckedRuleDecl )
import TcModule ( TcResults(..) )
import CoreSyn
import Rules ( ProtoCoreRule(..), pprProtoCoreRule )
import PprCore ( pprIdCoreRule )
import Subst ( substExpr, mkSubst, mkInScopeSet )
import DsMonad
import DsExpr ( dsExpr )
......@@ -48,7 +48,7 @@ deSugar :: DynFlags
-> UniqSupply
-> HomeSymbolTable
-> TcResults
-> IO ([CoreBind], RuleEnv, SDoc, SDoc, [CoreBndr])
-> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr])
deSugar dflags mod_name us hst
(TcResults {tc_env = global_val_env,
......@@ -98,7 +98,7 @@ dsProgram mod_name all_binds rules fo_decls
ppr_ds_rules [] = empty
ppr_ds_rules rules
= text "" $$ text "-------------- DESUGARED RULES -----------------" $$
vcat (map pprProtoCoreRule rules)
vcat (map pprIdCoreRule rules)
\end{code}
......@@ -109,13 +109,12 @@ ppr_ds_rules rules
%************************************************************************
\begin{code}
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
dsExpr rhs `thenDs` \ core_rhs ->
returnDs (ProtoCoreRule True {- local -} fn
(Rule name tpl_vars args core_rhs))
returnDs (fn, Rule name tpl_vars args core_rhs)
where
tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
......
ghc/compiler/hsSyn/HsDecls.lhs
View file @ 90fa6b84
......@@ -15,7 +15,7 @@ module HsDecls (
BangType(..), getBangType,
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl,
getClassDeclSysNames
) where
......@@ -27,20 +27,19 @@ import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
import HsExpr ( HsExpr )
import HsTypes
import PprCore ( pprCoreRule )
import HsCore ( UfExpr(UfVar), UfBinder, HsIdInfo, pprHsIdInfo,
eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr
import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
eq_ufBinders, eq_ufExpr, pprUfExpr
)
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
import CallConv ( CallConv, pprCallConv )
import Name ( getName )
-- others:
import FunDeps ( pprFundeps )
import Class ( FunDep )
import CStrings ( CLabelString, pprCLabelString )
import Outputable
import SrcLoc ( SrcLoc, noSrcLoc )
import SrcLoc ( SrcLoc )
\end{code}
......@@ -200,7 +199,29 @@ data TyClDecl name pat
(MonoBinds name pat) -- default methods
(ClassDeclSysNames name)
SrcLoc
\end{code}
Simple classifiers
\begin{code}
isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isIfaceSigDecl (IfaceSig _ _ _ _) = True
isIfaceSigDecl other = False
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other = False
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
isClassDecl other = False
\end{code}
Dealing with names
\begin{code}
tyClDeclName :: TyClDecl name pat -> name
tyClDeclName (IfaceSig name _ _ _) = name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
......@@ -237,19 +258,6 @@ mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds
getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code}
\begin{code}
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other = False
isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other = False
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
isClassDecl other = False
\end{code}
\begin{code}
instance Ord name => Eq (TyClDecl name pat) where
-- Used only when building interface files
......@@ -669,16 +677,6 @@ instance (Outputable name, Outputable pat)
instance Outputable name => Outputable (RuleBndr name) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
toHsRule id (BuiltinRule _)
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
toHsRule id (Rule name bndrs args rhs)
= IfaceRule name (map toUfBndr bndrs) (getName id)
(map toUfExpr args) (toUfExpr rhs) noSrcLoc
bogusIfaceRule id
= IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
......
ghc/compiler/hsSyn/HsSyn.lhs
View file @ 90fa6b84
......@@ -38,7 +38,6 @@ import HsLit
import HsMatches
import HsPat
import HsTypes
import HsCore
import BasicTypes ( Fixity, Version, NewOrData )
-- others:
......
ghc/compiler/main/HscTypes.lhs
View file @ 90fa6b84
......@@ -54,7 +54,6 @@ import Module ( Module, ModuleName, ModuleEnv,
)
import Rules ( RuleBase )
import VarSet ( TyVarSet )
import VarEnv ( emptyVarEnv )
import Id ( Id )
import Class ( Class )
import TyCon ( TyCon )
......@@ -65,7 +64,7 @@ import HsSyn ( DeprecTxt )
import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
import CoreSyn ( CoreRule )
import CoreSyn ( CoreRule, IdCoreRule )
import Type ( Type )
import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
......@@ -150,7 +149,7 @@ data ModDetails
-- The next three fields are created by the typechecker
md_types :: TypeEnv,
md_insts :: [DFunId], -- Dfun-ids for the instances in this module
md_rules :: [(Id,CoreRule)] -- Domain may include Ids from other modules
md_rules :: [IdCoreRule] -- Domain may include Ids from other modules
}
\end{code}
......
ghc/compiler/main/MkIface.lhs
View file @ 90fa6b84
......@@ -36,7 +36,7 @@ import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..),
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold )
import Name ( isLocallyDefined, getName, nameModule,
Name, NamedThing(..),
plusNameEnv, lookupNameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv_NF, nameEnvElts
......@@ -70,8 +70,24 @@ import List ( partition )
completeModDetails :: ModDetails
-> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
-- code generator; they have authoritative arity info
-> [ProtoCoreRule] -- Tidy orphan rules
-> [IdCoreRule] -- Tidy orphan rules
-> ModDetails
completeModDetails mds tidy_binds stg_ids orphan_rules
= ModDetails {
where
dfun_ids = md_insts mds
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]
completeIface :: Maybe ModIface -- The old interface, if we have it
-> ModIface -- The new one, minus the decls and versions
......@@ -87,33 +103,18 @@ completeIface :: Maybe ModIface -- The old interface, if we have it
-- The IO in the type is solely for debug output
-- In particular, dumping a record of what has changed
completeIface maybe_old_iface new_iface mod_details
tidy_binds final_ids tidy_orphan_rules
= let
new_decls = declsFromDetails mod_details tidy_binds final_ids tidy_orphan_rules
in
addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls
declsFromDetails details tidy_binds final_ids tidy_orphan_rules
= IfaceDecls { dcl_tycl = ty_cls_dcls ++ bagToList val_dcls,
dcl_insts = inst_dcls,
dcl_rules = rule_dcls }
where
dfun_ids = md_insts details
inst_dcls = map ifaceInstance dfun_ids
ty_cls_dcls = map ifaceTyCls (filter emitTyCls (nameEnvElts (md_types details)))
(val_dcls, emitted_ids) = ifaceBinds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
final_ids tidy_binds
rule_dcls | opt_OmitInterfacePragmas = []
| otherwise = ifaceRules tidy_orphan_rules emitted_ids
orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
| ProtoCoreRule _ _ rule <- tidy_orphan_rules]
= addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
where
new_decls = IfaceDecls { dcl_tycl = ty_cls_dcls,
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)
\end{code}
%************************************************************************
%* *
\subsection{Types and classes}
......@@ -121,13 +122,6 @@ declsFromDetails details tidy_binds final_ids tidy_orphan_rules
%************************************************************************
\begin{code}
emitTyCls :: TyThing -> Bool
emitTyCls (ATyCon tc) = True -- Could filter out wired in ones, but it's not
-- strictly necessary, and it costs extra time
emitTyCls (AClass cl) = True
emitTyCls (AnId _) = False
ifaceTyCls :: TyThing -> RenamedTyClDecl
ifaceTyCls (AClass clas)
= ClassDecl (toHsContext sc_theta)
......@@ -193,6 +187,49 @@ ifaceTyCls (ATyCon tycon)
= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
ifaceTyCls (AnId id)
= IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
where
id_type = idType id
id_info = idInfo id
hs_idinfo | opt_OmitInterfacePragmas = []
| otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
------------ Arity --------------
arity_hsinfo = case arityInfo id_info of
a@(ArityExactly n) -> [HsArity a]
other -> []
------------ Caf Info --------------
caf_hsinfo = case cafInfo id_info of
NoCafRefs -> [HsNoCafRefs]
otherwise -> []
------------ CPR Info --------------
cpr_hsinfo = case cprInfo id_info of
ReturnsCPR -> [HsCprInfo]
NoCPRInfo -> []
------------ Strictness --------------
strict_hsinfo = case strictnessInfo id_info of
NoStrictnessInfo -> []
info -> [HsStrictness info]
------------ Worker --------------
wkr_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_hsinfo | neverUnfold unfold_info = []
| otherwise = [HsUnfold inline_prag (toUfExpr rhs)]
\end{code}
......@@ -217,55 +254,40 @@ ifaceInstance dfun_id
-- instance Foo Tibble where ...
-- and this instance decl wouldn't get imported into a module
-- that mentioned T but not Tibble.
\end{code}
\begin{code}
ifaceRules :: [ProtoCoreRule] -> IdSet -> [RenamedRuleDecl]
ifaceRules rules emitted
= orphan_rules ++ local_rules
where
orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
local_rules = [ toHsRule fn rule
| fn <- varSetElems emitted,
rule <- rulesRules (idSpecialisation fn),
not (isBuiltinRule rule),
-- We can't print builtin rules in interface files
-- Since they are built in, an importing module
-- will have access to them anyway
ifaceRule (id, BuiltinRule _)
= pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
-- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
-- from coming out, and to make it work properly we need to add ????
-- (put it back in for now)
all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
-- Spit out a rule only if all its lhs free vars are emitted
-- This is a good reason not to do it when we emit the Id itself
]
ifaceRule (id, Rule name bndrs args rhs)
= IfaceRule name (map toUfBndr bndrs) (getName id)
(map toUfExpr args) (toUfExpr rhs) noSrcLoc
bogusIfaceRule id
= IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
%************************************************************************
%* *
\subsection{Value bindings}
\subsection{Compute final Ids}
%* *
%************************************************************************
A "final Id" has exactly the IdInfo for going into an interface file, or
exporting to another module.
\begin{code}
ifaceBinds :: IdSet -- These Ids are needed already
-> [Id] -- Ids used at code-gen time; they have better pragma info!
bindsToIds :: IdSet -- These Ids are needed already
-> IdSet -- Ids used at code-gen time; they have better pragma info!
-> [CoreBind] -- In dependency order, later depend on earlier
-> (Bag RenamedIfaceSig, IdSet) -- Set of Ids actually spat out
-> [Id] -- Set of Ids actually spat out, complete with exactly the IdInfo
-- they need for exporting to another module
ifaceBinds needed_ids final_ids binds
= go needed_ids (reverse binds) emptyBag emptyVarSet
bindsToIds needed_ids codegen_ids binds
= go needed_ids (reverse binds) []
-- Reverse so that later things will
-- provoke earlier ones to be emitted
where
final_id_map = listToUFM [(id,id) | id <- final_ids]
get_idinfo id = case lookupUFM final_id_map id of
Just id' -> idInfo id'
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
idInfo id
-- The 'needed' set contains the Ids that are needed by earlier
-- interface file emissions. If the Id isn't in this set, and isn't
-- exported, there's no need to emit anything
......@@ -274,22 +296,21 @@ ifaceBinds needed_ids final_ids binds
go needed [] decls emitted
| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
(sep (map ppr (varSetElems needed)))
(decls, emitted)
| otherwise = (decls, emitted)
emitted
| otherwise = emitted
go needed (NonRec id rhs : binds) decls emitted
go needed (NonRec id rhs : binds) emitted
| need_id needed id
= if omitIfaceSigForId id then
go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
go (needed `delVarSet` id) binds (id:emitted)
else
go ((needed `unionVarSet` extras) `delVarSet` id)
binds
(decl `consBag` decls)
(emitted `extendVarSet` id)
(new_id:emitted)
| otherwise
= go needed binds decls emitted
where
(decl, extras) = ifaceId get_idinfo False id rhs
(new_id, extras) = mkFinalId codegen_ids False id rhs
-- Recursive groups are a bit more of a pain. We may only need one to
-- start with, but it may call out the next one, and so on. So we
......@@ -297,72 +318,60 @@ ifaceBinds needed_ids final_ids binds
-- 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' binds decls' emitted'
= go needed' binds emitted'
where
(new_decls, new_emitted, extras) = go_rec needed pairs
decls' = new_decls `unionBags` decls
(new_emitted, extras) = go_rec needed pairs
needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
emitted' = emitted `unionVarSet` new_emitted
emitted' = new_emitted ++ emitted
go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RenamedIfaceSig, IdSet, IdSet)
go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
go_rec needed pairs
| null decls = (emptyBag, emptyVarSet, emptyVarSet)
| otherwise = (more_decls `unionBags` listToBag decls,
more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
more_extras `unionVarSet` extras)
| null needed_prs = ([], emptyVarSet)
| otherwise = (emitted ++ more_emitted,
extras `unionVarSet` more_extras)
where
(needed_prs,leftover_prs) = partition is_needed pairs
(decls, extras_s) = unzip [ifaceId get_idinfo True id rhs
| (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
extras = unionVarSets extras_s
(more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
(needed_prs,leftover_prs) = partition is_needed pairs
(emitted, extras_s) = unzip [ mkFinalId codegen_ids True id rhs
| (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
extras = unionVarSets extras_s
(more_emitted, more_extras) = go_rec extras leftover_prs
is_needed (id,_) = need_id needed id
\end{code}
\begin{code}
ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
-- by the STG passes. Sigh
-> Bool -- True <=> recursive, so don't print unfolding
-> Id
-> CoreExpr -- The Id's right hand side
-> (RenamedTyClDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
ifaceId get_idinfo is_rec id rhs
= (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc, new_needed_ids)
mkFinalId :: IdSet -- The Ids with arity info from the code generator
-> Bool -- True <=> recursive, so don't include unfolding
-> Id
-> CoreExpr -- The Id's right hand side
-> (Id, IdSet) -- The emitted id, plus any *extra* needed Ids
mkFinalId codegen_ids is_rec id rhs
= (id `setIdInfo` new_idinfo, new_needed_ids)