Commit 562926d7 authored by simonpj's avatar simonpj

[project @ 2000-11-24 09:51:03 by simonpj]

Version management

[WARNING: may not work!  Don't update till I've tested it.]

This commit is a first stab at getting version management to
work properly.  The main trick is to get consistent naming when
comparing old and new versions of the same module.  

Some functionality has moved arond between
  coreSyn/CoreTidy, which tidies up the result of
			the middle end of the compiler
	Main change: now responsible for figuring out which
	Ids are "external" (i.e visible to importing modules),
	and constructing the final IdInfo for each Id

  main/MkIface, which produces the ModIface and ModDetails
		for the module being compiled
	Main change: CoreTidy does more, so MkIface does less

  stgSyn/CoreToStg, which converts Core to STG
	Main change: responsible for globalising internal
	names when we are doing object code splitting 
			
The game plan is documented at the top of CoreTidy.
parent 4ccf9507
......@@ -11,14 +11,14 @@ module Name (
-- The Name type
Name, -- Abstract
mkLocalName, mkSysLocalName, mkCCallName,
mkTopName, mkIPName,
mkIPName,
mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInName,
nameUnique, setNameUnique,
tidyTopName,
nameOccName, nameModule, nameModule_maybe,
setNameOcc, nameRdrName, setNameModuleAndLoc,
toRdrName, hashName,
toRdrName, hashName,
globaliseName, localiseName,
nameSrcLoc, nameIsLocallyDefined, isDllName, nameIsFrom, nameIsLocalOrFrom,
......@@ -28,7 +28,7 @@ module Name (
-- Environment
NameEnv, mkNameEnv,
emptyNameEnv, unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnv, foldNameEnv,
extendNameEnv_C, extendNameEnv, foldNameEnv, filterNameEnv,
plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv,
......@@ -173,7 +173,6 @@ mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, n_
mkGlobalName :: Unique -> Module -> OccName -> SrcLoc -> Name
mkGlobalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = Global mod,
n_occ = occ, n_loc = loc }
mkKnownKeyGlobal :: RdrName -> Unique -> Name
mkKnownKeyGlobal rdr_name uniq
......@@ -216,11 +215,14 @@ mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)}
setNameUnique name uniq = name {n_uniq = uniq}
setNameOcc :: Name -> OccName -> Name
-- Give the thing a new OccName, *and*
-- record that it's no longer a sys-local
-- This is used by the tidy-up pass
setNameOcc name occ = name {n_occ = occ}
globaliseName :: Name -> Module -> Name
globaliseName n mod = n { n_sort = Global mod }
localiseName :: Name -> Name
localiseName n = n { n_sort = Local }
setNameModuleAndLoc :: Name -> Module -> SrcLoc -> Name
setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc}
where
......@@ -228,91 +230,6 @@ setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc
\end{code}
%************************************************************************
%* *
\subsection{Tidying a name}
%* *
%************************************************************************
tidyTopName is applied to top-level names in the final program
For top-level things,
it globalises Local names
(if all top-level things should be visible)
and localises non-exported Global names
(if only exported things should be visible)
In all cases except an exported global, it gives it a new occurrence name.
The "visibility" here concerns whether the .o file's symbol table
mentions the thing; if so, it needs a module name in its symbol.
The Global things are "visible" and the Local ones are not
Why should things be "visible"? Certainly they must be if they
are exported. But also:
(a) In certain (prelude only) modules we split up the .hc file into
lots of separate little files, which are separately compiled by the C
compiler. That gives lots of little .o files. The idea is that if
you happen to mention one of them you don't necessarily pull them all
in. (Pulling in a piece you don't need can be v bad, because it may
mention other pieces you don't need either, and so on.)
Sadly, splitting up .hc files means that local names (like s234) are
now globally visible, which can lead to clashes between two .hc
files. So unlocaliseWhatnot goes through making all the local things
into global things, essentially by giving them full names so when they
are printed they'll have their module name too. Pretty revolting
really.
(b) When optimisation is on we want to make all the internal
top-level defns externally visible
\begin{code}
tidyTopName :: Module -> TidyOccEnv -> Bool -> Name -> (TidyOccEnv, Name)
tidyTopName mod env is_exported
name@(Name { n_occ = occ, n_sort = sort, n_uniq = uniq, n_loc = loc })
= case sort of
Global _ | is_exported -> (env, name)
| otherwise -> (env, name { n_sort = new_sort })
-- Don't change the occurrnce names of globals, because many of them
-- are bound by either a class declaration or a data declaration
-- or an explicit user export.
other | is_exported -> (env', name { n_sort = Global mod, n_occ = occ' })
| otherwise -> (env', name { n_sort = new_sort, n_occ = occ' })
where
(env', occ') = tidyOccName env occ
new_sort = mkLocalTopSort mod
mkTopName :: Unique -> Module -> FAST_STRING -> Name
-- Make a top-level name; make it Global if top-level
-- things should be externally visible; Local otherwise
-- This chap is only used *after* the tidyCore phase
-- Notably, it is used during STG lambda lifting
--
-- We have to make sure that the name is globally unique
-- and we don't have tidyCore to help us. So we append
-- the unique. Hack! Hack!
-- (Used only by the STG lambda lifter.)
mkTopName uniq mod fs
= Name { n_uniq = uniq,
n_sort = mkLocalTopSort mod,
n_occ = mkVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq)),
n_loc = noSrcLoc }
mkLocalTopSort :: Module -> NameSort
mkLocalTopSort mod
| all_toplev_ids_visible = Global mod
| otherwise = Local
all_toplev_ids_visible
= not opt_OmitInterfacePragmas || -- Pragmas can make them visible
opt_EnsureSplittableC -- Splitting requires visiblilty
\end{code}
%************************************************************************
%* *
\subsection{Predicates and selectors}
......@@ -340,7 +257,6 @@ isDllName nm = not opt_Static &&
isTyVarName :: Name -> Bool
isTyVarName name = isTvOcc (nameOccName name)
\end{code}
......@@ -398,6 +314,7 @@ lookupNameEnv :: NameEnv a -> Name -> Maybe a
lookupNameEnv_NF :: NameEnv a -> Name -> a
mapNameEnv :: (a->b) -> NameEnv a -> NameEnv b
foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b
filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
emptyNameEnv = emptyUFM
foldNameEnv = foldUFM
......@@ -412,6 +329,7 @@ delFromNameEnv = delFromUFM
elemNameEnv = elemUFM
mapNameEnv = mapUFM
unitNameEnv = unitUFM
filterNameEnv = filterUFM
lookupNameEnv = lookupUFM
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n)
......
This diff is collapsed.
......@@ -4,7 +4,10 @@
\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
\begin{code}
module HscMain ( HscResult(..), hscMain, hscExpr, hscTypeExpr,
module HscMain ( HscResult(..), hscMain,
#ifdef GHCI
hscExpr, hscTypeExpr,
#endif
initPersistentCompilerState ) where
#include "HsVersions.h"
......@@ -33,7 +36,6 @@ import TcHsSyn
import InstEnv ( emptyInstEnv )
import Desugar
import SimplCore
import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
import CoreToStg ( topCoreBindsToStg )
......@@ -213,12 +215,12 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
-- We grab the the unfoldings at this point.
; simpl_result <- dsThenSimplThenTidy dflags pcs_tc hst this_mod
print_unqualified is_exported tc_result
; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result
; let (pcs_simpl, tidy_binds, orphan_rules, foreign_stuff) = simpl_result
-------------------
-- CONVERT TO STG
-------------------
; (stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids)
; (stg_binds, cost_centre_info, top_level_ids)
<- myCoreToStg dflags this_mod tidy_binds
......@@ -236,11 +238,11 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
<- restOfCodeGeneration dflags toInterp this_mod
(map ideclName (hsModuleImports rdr_module))
cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds
hit (pcs_PIT pcs_tc)
cost_centre_info foreign_stuff env_tc stg_binds tidy_binds
hit (pcs_PIT pcs_simpl)
-- and the answer is ...
; return (HscRecomp pcs_tc new_details final_iface
; return (HscRecomp pcs_simpl new_details final_iface
maybe_stub_h_filename maybe_stub_c_filename
maybe_ibinds)
}}}}}}}
......@@ -296,7 +298,7 @@ myParseModule dflags src_filename
restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_info
foreign_stuff env_tc stg_binds oa_tidy_binds
foreign_stuff env_tc stg_binds tidy_binds
hit pit -- these last two for mapping ModNames to Modules
| toInterp
= do (ibinds,itbl_env)
......@@ -315,7 +317,7 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
-- _scc_ "CodeOutput"
(maybe_stub_h_name, maybe_stub_c_name)
<- codeOutput dflags this_mod local_tycons
oa_tidy_binds stg_binds
tidy_binds stg_binds
c_code h_code abstractC
return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
......@@ -349,17 +351,14 @@ dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result
<- core2core dflags pcs hst is_exported desugared rules
-- Do the final tidy-up
(tidy_binds, tidy_orphan_rules)
<- tidyCorePgm dflags this_mod simplified orphan_rules
(pcs', tidy_binds, tidy_orphan_rules)
<- tidyCorePgm dflags this_mod pcs simplified orphan_rules
return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
return (pcs', tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
myCoreToStg dflags this_mod tidy_binds
= do
st_uniqs <- mkSplitUniqSupply 'g'
let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds
() <- coreBindsSize occ_anal_tidy_binds `seq` return ()
-- TEMP: the above call zaps some space usage allocated by the
-- simplifier, which for reasons I don't understand, persists
......@@ -368,12 +367,11 @@ myCoreToStg dflags this_mod tidy_binds
-- _scc_ "Core2Stg"
stg_binds <- topCoreBindsToStg dflags occ_anal_tidy_binds
showPass dflags "Stg2Stg"
-- _scc_ "Stg2Stg"
(stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds
let final_ids = collectFinalStgBinders (map fst stg_binds2)
return (stg_binds2, occ_anal_tidy_binds, cost_centre_info, final_ids)
return (stg_binds2, cost_centre_info, final_ids)
\end{code}
......
......@@ -24,23 +24,24 @@ import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
TyThing(..), DFunId, TypeEnv, isTyClThing, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..)
ImportVersion, AvailInfo, Deprecations(..),
extendTypeEnvList
)
import CmdLineOpts
import Id ( Id, idType, idInfo, omitIfaceSigForId, isExportedId, hasNoBinding,
idSpecialisation, idName, setIdInfo
import Id ( Id, idType, idInfo, omitIfaceSigForId,
idSpecialisation, setIdInfo, isLocalId
)
import Var ( isId )
import VarSet
import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
bindersOfBinds
import CoreSyn ( CoreBind, CoreRule(..), IdCoreRule,
isBuiltinRule, rulesRules,
bindersOf, bindersOfBinds
)
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars, mustHaveLocalBinding )
import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
import CoreFVs ( ruleSomeLhsFreeVars, ruleSomeFreeVars )
import CoreUnfold ( neverUnfold, unfoldingTemplate )
import Name ( getName, nameModule, Name, NamedThing(..) )
import Name -- Env
import OccName ( pprOccName )
......@@ -54,7 +55,6 @@ import SrcLoc ( noSrcLoc )
import Outputable
import Module ( ModuleName )
import List ( partition )
import IO ( IOMode(..), openFile, hClose )
\end{code}
......@@ -89,15 +89,14 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
-- However, we do keep things like constructors, which should not appear
-- in interface files, because they are needed by importing modules when
-- using the compilation manager
new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
`plusNameEnv`
mkNameEnv [(idName id, AnId id) | id <- final_ids]
new_type_env = extendTypeEnvList (filterNameEnv isTyClThing type_env)
(map AnId final_ids)
orig_type_env = nameEnvElts type_env
stg_id_set = mkVarSet stg_ids
final_ids = [addStgInfo stg_id_set id | bind <- tidy_binds
, id <- bindersOf bind
, isGlobalName (idName id)]
final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
(mkVarSet stg_ids)
tidy_binds
-- The complete rules are gotten by combining
-- a) the orphan rules
......@@ -105,10 +104,6 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
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
......@@ -121,8 +116,96 @@ mkModDetailsFromIface type_env dfun_ids rules
where
rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
-- All the rules from an interface are of the IfaceRuleOut form
\end{code}
We have to add on the arity and CAF info computed by the code generator
This is also the moment at which we may forget that this function has
a worker: see the comments below
\begin{code}
addStgInfo :: IdSet -- Ids used at code-gen time; they have better pragma info!
-> Id -> Id
addStgInfo stg_ids id
= id `setIdInfo` final_idinfo
where
idinfo = idInfo id
idinfo' = idinfo `setArityInfo` stg_arity
`setCafInfo` cafInfo stg_idinfo
final_idinfo | worker_ok = idinfo'
| otherwise = idinfo' `setWorkerInfo` NoWorker
stg_idinfo = case lookupVarSet stg_ids id of
Just id' -> idInfo id'
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
idInfo id
stg_arity = arityInfo stg_idinfo
------------ Worker --------------
-- We only treat a function as having a worker if
-- the exported arity (which is now the number of visible lambdas)
-- is the same as the arity at the moment of the w/w split
-- If so, we can safely omit the unfolding inside the wrapper, and
-- instead re-generate it from the type/arity/strictness info
-- But if the arity has changed, we just take the simple path and
-- put the unfolding into the interface file, forgetting the fact
-- that it's a wrapper.
--
-- How can this happen? Sometimes we get
-- f = coerce t (\x y -> $wf x y)
-- at the moment of w/w split; but the eta reducer turns it into
-- f = coerce t $wf
-- which is perfectly fine except that the exposed arity so far as
-- the code generator is concerned (zero) differs from the arity
-- when we did the split (2).
--
-- All this arises because we use 'arity' to mean "exactly how many
-- top level lambdas are there" in interface files; but during the
-- compilation of this module it means "how many things can I apply
-- this to".
worker_ok = case workerInfo idinfo of
NoWorker -> True
HasWorker work_id wrap_arity -> wrap_arity == arityLowerBound stg_arity
\end{code}
\begin{code}
getRules :: [IdCoreRule] -- Orphan rules
-> [CoreBind] -- Bindings, with rules in the top-level Ids
-> IdSet -- Ids that are exported, so we need their rules
-> [IdCoreRule]
getRules orphan_rules binds emitted
= orphan_rules ++ local_rules
where
local_rules = [ (fn, rule)
| fn <- bindersOfBinds binds,
fn `elemVarSet` 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
-- 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
]
interestingId id = isId id && isLocalId id
\end{code}
%************************************************************************
%* *
\subsection{Completing an interface}
%* *
%************************************************************************
\begin{code}
completeIface :: Maybe ModIface -- The old interface, if we have it
-> ModIface -- The new one, minus the decls and versions
-> ModDetails -- The ModDetails for this module
......@@ -143,12 +226,6 @@ completeIface maybe_old_iface new_iface mod_details
\end{code}
%************************************************************************
%* *
\subsection{Types and classes}
%* *
%************************************************************************
\begin{code}
ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
ifaceTyCls (AClass clas) so_far
......@@ -255,25 +332,22 @@ ifaceTyCls (AnId id) so_far
------------ Worker --------------
wrkr_hsinfo = case workerInfo id_info of
work_info = workerInfo id_info
has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
wrkr_hsinfo = case work_info of
HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
NoWorker -> []
------------ Unfolding --------------
-- The unfolding is redundant if there is a worker
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)]
unfold_hsinfo | neverUnfold unfold_info
|| has_worker = []
| otherwise = [HsUnfold inline_prag (toUfExpr rhs)]
\end{code}
%************************************************************************
%* *
\subsection{Instances and rules}
%* *
%************************************************************************
\begin{code}
ifaceInstance :: DFunId -> RenamedInstDecl
ifaceInstance dfun_id
......@@ -302,212 +376,6 @@ bogusIfaceRule id
\end{code}
%************************************************************************
%* *
\subsection{Compute final Ids}
%* *
%************************************************************************
A "final Id" has exactly the IdInfo for going into an interface file, or
exporting to another module.
\begin{code}
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
-> [Id] -- Set of Ids actually spat out, complete with exactly the IdInfo
-- they need for exporting to another module
bindsToIds needed_ids codegen_ids binds
= go needed_ids (reverse binds) []
-- Reverse so that later things will
-- provoke earlier ones to be emitted
where
-- 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
need_id needed_set id = id `elemVarSet` needed_set || isExportedId id
go needed [] emitted
| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
(sep (map ppr (varSetElems needed)))
emitted
| otherwise = emitted
go needed (NonRec id rhs : binds) emitted
| need_id needed id = go new_needed binds (new_id:emitted)
| otherwise = go needed binds emitted
where
(new_id, extras) = mkFinalId codegen_ids False id rhs
new_needed = (needed `unionVarSet` extras) `delVarSet` id
-- 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
-- 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) emitted
= go needed' binds emitted'
where
(new_emitted, extras) = go_rec needed pairs
needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
emitted' = new_emitted ++ emitted
go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
go_rec needed pairs
| null needed_prs = ([], emptyVarSet)
| otherwise = (emitted ++ more_emitted,
extras `unionVarSet` more_extras)
where
(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}
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
| omitIfaceSigForId id
= (id, emptyVarSet) -- An optimisation for top-level constructors and suchlike
| otherwise
= (id `setIdInfo` new_idinfo, new_needed_ids)
where
core_idinfo = idInfo id
stg_idinfo = case lookupVarSet codegen_ids id of
Just id' -> idInfo id'
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
idInfo id
new_idinfo | opt_OmitInterfacePragmas
= constantIdInfo
| otherwise
= core_idinfo `setArityInfo` arity_info
`setCafInfo` cafInfo stg_idinfo
`setUnfoldingInfo` unfold_info
`setWorkerInfo` worker_info
`setSpecInfo` emptyCoreRules
-- We zap the specialisations because they are
-- passed on separately through the modules IdCoreRules
------------ Arity --------------
arity_info = arityInfo stg_idinfo
stg_arity = arityLowerBound arity_info
------------ Worker --------------
-- We only treat a function as having a worker if
-- the exported arity (which is now the number of visible lambdas)
-- is the same as the arity at the moment of the w/w split
-- If so, we can safely omit the unfolding inside the wrapper, and
-- instead re-generate it from the type/arity/strictness info
-- But if the arity has changed, we just take the simple path and
-- put the unfolding into the interface file, forgetting the fact
-- that it's a wrapper.
--
-- How can this happen? Sometimes we get
-- f = coerce t (\x y -> $wf x y)
-- at the moment of w/w split; but the eta reducer turns it into
-- f = coerce t $wf
-- which is perfectly fine except that the exposed arity so far as
-- the code generator is concerned (zero) differs from the arity
-- when we did the split (2).
--
-- All this arises because we use 'arity' to mean "exactly how many
-- top level lambdas are there" in interface files; but during the
-- compilation of this module it means "how many things can I apply
-- this to".
worker_info = case workerInfo core_idinfo of
info@(HasWorker work_id wrap_arity)
| wrap_arity == stg_arity -> info
| otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
NoWorker
NoWorker -> NoWorker
has_worker = case worker_info of
HasWorker _ _ -> True
other -> False
HasWorker work_id _ = worker_info
------------ Unfolding --------------
inline_pragma = inlinePragInfo core_idinfo
dont_inline = isNeverInlinePrag inline_pragma
loop_breaker = isLoopBreaker (occInfo core_idinfo)
bottoming_fn = isBottomingStrictness (strictnessInfo core_idinfo)
unfolding = mkTopUnfolding rhs
rhs_is_small = not (neverUnfold unfolding)
unfold_info | show_unfold = unfolding
| otherwise = noUnfolding
show_unfold = not has_worker && -- Not unnecessary
not bottoming_fn && -- Not necessary
not dont_inline &&
not loop_breaker &&
rhs_is_small && -- Small enough
okToUnfoldInHiFile rhs -- No casms etc
------------ Extra free Ids --------------
new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
| otherwise = worker_ids `unionVarSet`
unfold_ids `unionVarSet`
spec_ids
spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))
worker_ids | has_worker && interestingId work_id = unitVarSet work_id
-- Conceivably, the worker might come from
-- another module
| otherwise = emptyVarSet
unfold_ids | show_unfold = find_fvs rhs
| otherwise = emptyVarSet
find_fvs expr = exprSomeFreeVars interestingId expr
interestingId id = isId id && mustHaveLocalBinding id
\end{code}
\begin{code}
getRules :: [IdCoreRule] -- Orphan rules
-> [CoreBind] -- Bindings, with rules in the top-level Ids
-> IdSet -- Ids that are exported, so we need their rules
-> [IdCoreRule]
getRules orphan_rules binds emitted
= orphan_rules ++ local_rules
where
local_rules = [ (fn, rule)
| fn <- bindersOfBinds binds,
fn `elemVarSet` emitted,