Commit 91944423 authored by simonpj's avatar simonpj

[project @ 2005-04-28 16:05:54 by simonpj]

Re-plumb the connections between TidyPgm and the various
code generators.  There's a new type, CgGuts, to mediate this,
which has the happy effect that ModGuts can die earlier.

The non-O route still isn't quite right, because default methods
are being lost.  I'm working on it.
parent 69ccf53d
......@@ -47,7 +47,7 @@ import CostCentre ( CollectedCCs )
import Id ( Id, idName, setIdName )
import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
import OccName ( mkLocalOcc )
import TyCon ( isDataTyCon )
import TyCon ( TyCon )
import Module ( Module, mkModule )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic )
......@@ -60,23 +60,20 @@ import Outputable
\begin{code}
codeGen :: DynFlags
-> Module
-> TypeEnv
-> [TyCon]
-> ForeignStubs
-> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> IO [Cmm] -- Output
codeGen dflags this_mod type_env foreign_stubs imported_mods
codeGen dflags this_mod data_tycons foreign_stubs imported_mods
cost_centre_info stg_binds
= do
{ showPass dflags "CodeGen"
; let way = buildTag dflags
mb_main_mod = mainModIs dflags
; let tycons = typeEnvTyCons type_env
data_tycons = filter isDataTyCon tycons
-- Why?
-- ; mapM_ (\x -> seq x (return ())) data_tycons
......
......@@ -16,18 +16,18 @@ import CoreLint ( endPass )
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe,
isUnLiftedType, isUnboxedTupleType, seqType )
import TyCon ( TyCon, tyConDataCons )
import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
isFCallId, isGlobalId, isImplicitId,
isFCallId, isGlobalId,
isLocalId, hasNoBinding, idNewStrictness,
idUnfolding, isDataConWorkId_maybe, isPrimOpId_maybe
isPrimOpId_maybe
)
import DataCon ( isVanillaDataCon )
import DataCon ( isVanillaDataCon, dataConWorkId )
import PrimOp ( PrimOp( DataToTagOp ) )
import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
......@@ -98,12 +98,12 @@ any trivial or useless bindings.
-- -----------------------------------------------------------------------------
\begin{code}
corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
corePrepPgm dflags binds types
corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
corePrepPgm dflags binds data_tycons
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
let implicit_binds = mkImplicitBinds types
let implicit_binds = mkDataConWorkers data_tycons
-- NB: we must feed mkImplicitBinds through corePrep too
-- so that they are suitably cloned and eta-expanded
......@@ -130,16 +130,8 @@ corePrepExpr dflags expr
-- Implicit bindings
-- -----------------------------------------------------------------------------
Create any necessary "implicit" bindings (data constructors etc).
Namely:
* Constructor workers
* Constructor wrappers
* Data type record selectors
* Class op selectors
In the latter three cases, the Id contains the unfolding to use for
the binding. In the case of data con workers we create the rather
strange (non-recursive!) binding
Create any necessary "implicit" bindings for data con workers. We
create the rather strange (non-recursive!) binding
$wC = \x y -> $wC x y
......@@ -154,20 +146,11 @@ always fully applied, and the bindings are just there to support
partial applications. But it's easier to let them through.
\begin{code}
mkImplicitBinds type_env
= [ NonRec id (get_unfolding id)
| AnId id <- typeEnvElts type_env, isImplicitId id ]
-- The type environment already contains all the implicit Ids,
-- so we just filter them out
--
-- The etaExpand is so that the manifest arity of the
-- binding matches its claimed arity, which is an
-- invariant of top level bindings going into the code gen
get_unfolding id -- See notes above
| Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
-- CorePrep will eta-expand it
| otherwise = unfoldingTemplate (idUnfolding id)
mkDataConWorkers data_tycons
= [ NonRec id (Var id) -- The ice is thin here, but it works
| tycon <- data_tycons, -- CorePrep will eta-expand it
data_con <- tyConDataCons tycon,
let id = dataConWorkId data_con ]
\end{code}
......
......@@ -15,34 +15,29 @@ import Module
import CoreSyn
import HscTypes
import TyCon
import Class
import TypeRep
import Type
import PprExternalCore -- Instances
import DataCon ( DataCon, dataConTyVars, dataConRepArgTys,
dataConName, dataConTyCon, dataConWrapId_maybe )
dataConName, dataConTyCon )
import CoreSyn
import Var
import IdInfo
import Id ( idUnfolding )
import Kind
import CoreTidy ( tidyExpr )
import VarEnv ( emptyTidyEnv )
import Literal
import Name
import Outputable
import ForeignCall
import DynFlags ( DynFlags(..) )
import StaticFlags ( opt_EmitExternalCore )
import Maybes ( mapCatMaybes )
import IO
import FastString
emitExternalCore :: DynFlags -> ModGuts -> IO ()
emitExternalCore dflags mod_impl
emitExternalCore :: DynFlags -> CgGuts -> IO ()
emitExternalCore dflags cg_guts
| opt_EmitExternalCore
= (do handle <- openFile corename WriteMode
hPutStrLn handle (show (mkExternalCore mod_impl))
hPutStrLn handle (show (mkExternalCore cg_guts))
hClose handle)
`catch` (\err -> pprPanic "Failed to open or write external core output file"
(text corename))
......@@ -52,45 +47,17 @@ emitExternalCore _ _
= return ()
mkExternalCore :: ModGuts -> C.Module
mkExternalCore :: CgGuts -> C.Module
-- The ModGuts has been tidied, but the implicit bindings have
-- not been injected, so we have to add them manually here
-- We don't include the strange data-con *workers* because they are
-- implicit in the data type declaration itself
mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = binds})
= C.Module mname tdefs (map make_vdef all_binds)
mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds})
= C.Module mname tdefs (map make_vdef binds)
where
mname = make_mid this_mod
tdefs = foldr collect_tdefs [] tycons
all_binds = implicit_con_wrappers ++ other_implicit_binds ++ binds
-- Put the constructor wrappers first, because
-- other implicit bindings (notably the fromT functions arising
-- from generics) use the constructor wrappers.
tycons = map classTyCon (typeEnvClasses type_env) ++ typeEnvTyCons type_env
implicit_con_wrappers = map get_defn (concatMap implicit_con_ids (typeEnvElts type_env))
other_implicit_binds = map get_defn (concatMap other_implicit_ids (typeEnvElts type_env))
implicit_con_ids :: TyThing -> [Id]
implicit_con_ids (ATyCon tc) | isAlgTyCon tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
implicit_con_ids other = []
other_implicit_ids :: TyThing -> [Id]
other_implicit_ids (ATyCon tc) = tyConSelIds tc
other_implicit_ids (AClass cl) = classSelIds cl
other_implicit_ids other = []
get_defn :: Id -> CoreBind
get_defn id = NonRec id rhs
where
rhs = tidyExpr emptyTidyEnv body
body = unfoldingTemplate (idUnfolding id)
-- Don't forget to tidy the body ! Otherwise you get silly things like
-- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
-- Maybe we should inject these bindings during CoreTidy?
collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs tcon tdefs
| isAlgTyCon tcon = tdef: tdefs
......
......@@ -67,13 +67,10 @@ import Data.Char ( ord, chr )
byteCodeGen :: DynFlags
-> [CoreBind]
-> TypeEnv
-> [TyCon]
-> IO CompiledByteCode
byteCodeGen dflags binds type_env
byteCodeGen dflags binds tycs
= do showPass dflags "ByteCodeGen"
let local_tycons = typeEnvTyCons type_env
local_classes = typeEnvClasses type_env
tycs = local_tycons ++ map classTyCon local_classes
let flatBinds = [ (bndr, freeVars rhs)
| (bndr, rhs) <- flattenBinds binds]
......
......@@ -186,7 +186,7 @@ import LoadIface ( readIface, loadInterface )
import BasicTypes ( Version, initialVersion, bumpVersion )
import TcRnMonad
import TcRnTypes ( mkModDeps )
import HscTypes ( ModIface(..),
import HscTypes ( ModIface(..), ModDetails(..),
ModGuts(..), ModGuts, IfaceExport,
HscEnv(..), hscEPS, Dependencies(..), FixItem(..),
ModSummary(..), msHiFilePath,
......@@ -248,23 +248,25 @@ import Maybes ( orElse, mapCatMaybes, isNothing, isJust,
\begin{code}
mkIface :: HscEnv
-> Maybe ModIface -- The old interface, if we have it
-> ModGuts -- The compiled, tidied module
-> ModGuts -- Usages, deprecations, etc
-> ModDetails -- The trimmed, tidied interface
-> IO (ModIface, -- The new one, complete with decls and versions
Bool) -- True <=> there was an old Iface, and the new one
-- is identical, so no need to write it
mkIface hsc_env maybe_old_iface
guts@ModGuts{ mg_module = this_mod,
(ModGuts{ mg_module = this_mod,
mg_boot = is_boot,
mg_usages = usages,
mg_deps = deps,
mg_exports = exports,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_deprecs = src_deprecs,
mg_insts = insts,
mg_rules = rules,
mg_types = type_env }
mg_deprecs = src_deprecs })
(ModDetails{ md_insts = insts,
md_rules = rules,
md_types = type_env,
md_exports = exports })
-- NB: notice that mkIface does not look at the bindings
-- only at the TypeEnv. The previous Tidy phase has
-- put exactly the info into the TypeEnv that we want
......
......@@ -54,11 +54,11 @@ import IO
codeOutput :: DynFlags
-> Module
-> ForeignStubs
-> Dependencies
-> [PackageId]
-> [Cmm] -- Compiled C--
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
codeOutput dflags this_mod foreign_stubs deps flat_abstractC
codeOutput dflags this_mod foreign_stubs pkg_deps flat_abstractC
=
-- You can have C (c_output) or assembly-language (ncg_output),
-- but not both. [Allowing for both gives a space leak on
......@@ -83,7 +83,7 @@ codeOutput dflags this_mod foreign_stubs deps flat_abstractC
HscInterpreted -> return ();
HscAsm -> outputAsm dflags filenm flat_abstractC;
HscC -> outputC dflags filenm flat_abstractC stubs_exist
deps foreign_stubs;
pkg_deps foreign_stubs;
HscJava ->
#ifdef JAVA
outputJava dflags filenm mod_name tycons core_binds;
......@@ -114,7 +114,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
\begin{code}
outputC dflags filenm flat_absC
(stub_h_exists, _) dependencies foreign_stubs
(stub_h_exists, _) packages foreign_stubs
= do
-- figure out which header files to #include in the generated .hc file:
--
......@@ -122,7 +122,6 @@ outputC dflags filenm flat_absC
-- * -#include options from the cmdline and OPTIONS pragmas
-- * the _stub.h file, if there is one.
--
let packages = dep_pkgs dependencies
pkg_configs <- getExplicitPackagesAnd dflags packages
let pkg_names = map (showPackageId.package) pkg_configs
......
......@@ -64,6 +64,7 @@ import SimplCore
import TidyPgm ( optTidyPgm, simpleTidyPgm )
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import TyCon ( isDataTyCon )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
......@@ -355,11 +356,11 @@ hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO
hscBootBackEnd hsc_env mod_summary maybe_old_iface Nothing
= return HscFail
hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
= do { tidy_pgm <- simpleTidyPgm hsc_env ds_result
= do { (_cg_guts, details) <- simpleTidyPgm hsc_env ds_result
; (new_iface, no_change)
<- {-# SCC "MkFinalIface" #-}
mkIface hsc_env maybe_old_iface tidy_pgm
mkIface hsc_env maybe_old_iface ds_result details
; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
......@@ -428,13 +429,10 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
-- TIDY
-------------------
; let omit_prags = dopt Opt_OmitInterfacePragmas dflags
; tidy_result <- {-# SCC "CoreTidy" #-}
if omit_prags
then simpleTidyPgm hsc_env simpl_result
else optTidyPgm hsc_env simpl_result
-- Emit external core
; emitExternalCore dflags tidy_result
; (cg_guts, details) <- {-# SCC "CoreTidy" #-}
if omit_prags
then simpleTidyPgm hsc_env simpl_result
else optTidyPgm hsc_env simpl_result
-- Alive at this point:
-- tidy_result, pcs_final
......@@ -446,8 +444,9 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
-- This has to happen *after* code gen so that the back-end
-- info has been set. Not yet clear if it matters waiting
-- until after code output
; (new_iface, no_change) <- {-# SCC "MkFinalIface" #-}
mkIface hsc_env maybe_old_iface tidy_result
; (new_iface, no_change)
<- {-# SCC "MkFinalIface" #-}
mkIface hsc_env maybe_old_iface simpl_result details
; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change
......@@ -459,18 +458,16 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
-- Build the final ModDetails (except in one-shot mode, where
-- we won't need this information after compilation).
; final_details <-
if one_shot then return (error "no final details")
else return $! ModDetails {
md_types = mg_types tidy_result,
md_exports = mg_exports tidy_result,
md_insts = mg_insts tidy_result,
md_rules = mg_rules tidy_result }
; final_details <- if one_shot then return (error "no final details")
else return $! details
-- Emit external core
; emitExternalCore dflags cg_guts
-------------------
-- CONVERT TO STG and COMPLETE CODE GENERATION
; (stub_h_exists, stub_c_exists, maybe_bcos)
<- hscCodeGen dflags tidy_result
<- hscCodeGen dflags cg_guts
-- And the answer is ...
; dumpIfaceStats hsc_env
......@@ -484,20 +481,24 @@ hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result)
hscCodeGen dflags
ModGuts{ -- This is the last use of the ModGuts in a compilation.
CgGuts{ -- This is the last use of the ModGuts in a compilation.
-- From now on, we just use the bits we need.
mg_module = this_mod,
mg_binds = core_binds,
mg_types = type_env,
mg_dir_imps = dir_imps,
mg_foreign = foreign_stubs,
mg_deps = dependencies } = do {
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
cg_dep_pkgs = dependencies } = do {
let { data_tycons = filter isDataTyCon tycons } ;
-- cg_tycons includes newtypes, for the benefit of External Core,
-- but we don't generate any code for newtypes
-------------------
-- PREPARE FOR CODE GENERATION
-- Do saturation and convert to A-normal form
prepd_binds <- {-# SCC "CorePrep" #-}
corePrepPgm dflags core_binds type_env;
corePrepPgm dflags core_binds data_tycons ;
case hscTarget dflags of
HscNothing -> return (False, False, Nothing)
......@@ -505,7 +506,7 @@ hscCodeGen dflags
HscInterpreted ->
#ifdef GHCI
do ----------------- Generate byte code ------------------
comp_bc <- byteCodeGen dflags prepd_binds type_env
comp_bc <- byteCodeGen dflags prepd_binds data_tycons
------------------ Create f-x-dynamic C-side stuff ---
(istub_h_exists, istub_c_exists)
......@@ -524,7 +525,7 @@ hscCodeGen dflags
------------------ Code generation ------------------
abstractC <- {-# SCC "CodeGen" #-}
codeGen dflags this_mod type_env foreign_stubs
codeGen dflags this_mod data_tycons foreign_stubs
dir_imps cost_centre_info stg_binds
------------------ Code output -----------------------
......@@ -542,7 +543,7 @@ hscCmmFile dflags filename = do
case maybe_cmm of
Nothing -> return False
Just cmm -> do
codeOutput dflags no_mod NoStubs noDependencies [cmm]
codeOutput dflags no_mod NoStubs [] [cmm]
return True
where
no_mod = panic "hscCmmFile: no_mod"
......
......@@ -12,7 +12,7 @@ module HscTypes (
ModuleGraph, emptyMG,
ModDetails(..), emptyModDetails,
ModGuts(..), ModImports(..), ForeignStubs(..),
ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..),
ModSummary(..), showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
......@@ -398,24 +398,35 @@ data ModGuts
-- After simplification, the following fields change slightly:
-- mg_rules Orphan rules only (local ones now attached to binds)
-- mg_binds With rules attached
--
-- After CoreTidy, the following fields change slightly:
-- mg_types Now contains Ids as well, replete with final IdInfo
-- The Ids are only the ones that are visible from
-- importing modules. Without -O that means only
-- exported Ids, but with -O importing modules may
-- see ids mentioned in unfoldings of exported Ids
--
-- mg_insts Same DFunIds as before, but with final IdInfo,
-- and the unique might have changed; remember that
-- CoreTidy links up the uniques of old and new versions
--
-- mg_rules All rules for exported things, substituted with final Ids
--
-- mg_binds Tidied
---------------------------------------------------------
-- The Tidy pass forks the information about this module:
-- * one lot goes to interface file generation (ModIface)
-- and later compilations (ModDetails)
-- * the other lot goes to code generation (CgGuts)
data CgGuts
= CgGuts {
cg_module :: !Module,
cg_tycons :: [TyCon], -- Algebraic data types (including ones that started life
-- as classes); generate constructors and info tables
-- Includes newtypes, just for the benefit of External Core
cg_binds :: [CoreBind], -- The tidied main bindings, including previously-implicit
-- bindings for record and class selectors, and
-- data construtor wrappers.
-- But *not* data constructor workers; reason: we
-- we regard them as part of the code-gen of tycons
cg_dir_imps :: ![Module], -- Directly-imported modules; used to generate
-- initialisation code
cg_foreign :: !ForeignStubs,
cg_dep_pkgs :: ![PackageId] -- Used to generate #includes for C code gen
}
-----------------------------------
data ModImports
= ModImports {
imp_direct :: ![(Module,Bool)], -- Explicitly-imported modules
......@@ -427,6 +438,7 @@ data ModImports
-- directly or indirectly
}
-----------------------------------
data ForeignStubs = NoStubs
| ForeignStubs
SDoc -- Header file prototypes for
......
......@@ -21,7 +21,7 @@ import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, idCoreRules, isGlobalId,
isExportedId, mkVanillaGlobal, isLocalId,
idArity, idCafInfo
idArity, idCafInfo, idUnfolding
)
import IdInfo {- loads of stuff -}
import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
......@@ -37,12 +37,15 @@ import NameEnv ( filterNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
import Type ( tidyTopType )
import TcType ( isFFITy )
import DataCon ( dataConName, dataConFieldLabels )
import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, newTyConRep )
import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe )
import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon,
newTyConRep, isDataTyCon, tyConSelIds, isAlgTyCon )
import Class ( classSelIds )
import Module ( Module )
import HscTypes ( HscEnv(..), NameCache( nsUniqs ),
TypeEnv, typeEnvIds, typeEnvElts, extendTypeEnvWithIds, mkTypeEnv,
ModGuts(..), ModGuts, TyThing(..)
import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons,
extendTypeEnvWithIds, mkTypeEnv,
ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..)
)
import Maybes ( orElse, mapCatMaybes )
import ErrUtils ( showPass, dumpIfSet_core )
......@@ -107,18 +110,22 @@ Plan A: simpleTidyPgm: omit pragmas, make interfaces small
* Drop rules altogether
* Leave the bindings untouched. There's no need to make the Ids
in the bindings into Globals, think, ever.
* Tidy the bindings, to ensure that the Caf and Arity
information is correct for each top-level binder; the
code generator needs it. And to ensure that local names have
distinct OccNames in case of object-file splitting
\begin{code}
simpleTidyPgm :: HscEnv -> ModGuts -> IO ModGuts
simpleTidyPgm :: HscEnv -> ModGuts
-> IO (CgGuts, ModDetails)
-- This is Plan A: make a small type env when typechecking only,
-- or when compiling a hs-boot file, or simply when not using -O
simpleTidyPgm hsc_env mod_impl@(ModGuts { mg_exports = exports,
simpleTidyPgm hsc_env mod_impl@(ModGuts { mg_module = mod,
mg_exports = exports,
mg_types = type_env,
mg_insts = ispecs })
mg_insts = ispecs,
mg_binds = binds })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy Type Env"
......@@ -129,11 +136,15 @@ simpleTidyPgm hsc_env mod_impl@(ModGuts { mg_exports = exports,
; type_env' = extendTypeEnvWithIds (mkTypeEnv things')
(map instanceDFunId ispecs')
; ext_ids = mkVarEnv [ (id, False) | id <- typeEnvIds type_env']
}
; return (mod_impl { mg_types = type_env'
, mg_insts = ispecs'
, mg_rules = [] })
; (_, cg_guts) <- tidyCgStuff hsc_env ext_ids mod_impl
; return (cg_guts, ModDetails { md_types = type_env'
, md_insts = ispecs'
, md_rules = []
, md_exports = exports })
}
tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance]
......@@ -180,6 +191,9 @@ mustExposeTyCon :: NameSet -- Exports
-- possible into the interface file. But we must expose the details of
-- any data types whose constructors or fields are exported
mustExposeTyCon exports tc
| not (isAlgTyCon tc) -- Synonyms
= True
| otherwise -- Newtype, datatype
= any exported_con (tyConDataCons tc)
-- Expose rep if any datacon or field is exported
......@@ -266,10 +280,11 @@ throughout, including in unfoldings. We also tidy binders in
RHSs, so that they print nicely in interfaces.
\begin{code}
optTidyPgm :: HscEnv -> ModGuts -> IO ModGuts
optTidyPgm :: HscEnv -> ModGuts
-> IO (CgGuts, ModDetails)
optTidyPgm hsc_env
mod_impl@(ModGuts { mg_module = mod,
mod_impl@(ModGuts { mg_module = mod, mg_exports = exports,
mg_types = env_tc, mg_insts = insts_tc,
mg_binds = binds_in,
mg_rules = imp_rules })
......@@ -285,11 +300,10 @@ optTidyPgm hsc_env
-- So in fact we may export more than we need.
-- (It's a sort of mutual recursion.)
; (final_env, tidy_binds) <- tidyTopBinds hsc_env mod env_tc
ext_ids binds_in
; (final_env, cg_guts) <- tidyCgStuff hsc_env ext_ids mod_impl
; let { tidy_rules = tidyRules final_env ext_rules
; tidy_type_env = tidyTypeEnv env_tc tidy_binds
; tidy_type_env = tidyTypeEnv env_tc (cg_binds cg_guts)
; tidy_ispecs = tidyInstances (tidyVarOcc final_env) insts_tc
-- A DFunId will have a binding in tidy_binds, and so
-- will now be in final_env, replete with IdInfo
......@@ -297,15 +311,15 @@ optTidyPgm hsc_env
-- we want Global, IdInfo-rich DFunId in the tidy_ispecs
}
; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
; endPass dflags "Tidy Core" Opt_D_dump_simpl (cg_binds cg_guts)
; dumpIfSet_core dflags Opt_D_dump_simpl
"Tidy Core Rules"
(pprRules tidy_rules)
; return (mod_impl { mg_types = tidy_type_env,
mg_rules = tidy_rules,
mg_insts = tidy_ispecs,
mg_binds = tidy_binds })
; return (cg_guts, ModDetails { md_types = tidy_type_env
, md_rules = tidy_rules
, md_insts = tidy_ispecs
, md_exports = exports })
}
......@@ -470,16 +484,27 @@ findExternalRules binds non_local_rules ext_ids
--
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
tidyTopBinds :: HscEnv
-> Module
-> TypeEnv
-> IdEnv Bool -- Domain = Ids that should be external
tidyCgStuff :: HscEnv
-> IdEnv Bool -- Domain = Ids that should be external
-- True <=> their unfolding is external too
-> [CoreBind]
-> IO (TidyEnv, [CoreBind])
tidyTopBinds hsc_env mod env_tc ext_ids binds
= go init_env binds
-> ModGuts
-> IO (TidyEnv, CgGuts)
-- * Tidy the bindings
-- * Add bindings for the "implicit" Ids
tidyCgStuff hsc_env ext_ids
(ModGuts { mg_module = mod, mg_binds = binds, mg_types = type_env,
mg_dir_imps = dir_imps, mg_deps = deps,
mg_foreign = foreign_stubs })
= do { (env, binds') <- tidy init_env (map get_defn implicit_ids ++ binds)
; return (env, CgGuts { cg_module = mod,
cg_tycons = filter isAlgTyCon tycons,
cg_binds = binds',
cg_dir_imps = dir_imps,
cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps })
}
where
dflags = hsc_dflags hsc_env