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 )
\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
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
)
-- -----------------------------------------------------------------------------
\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
-- 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
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}
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))
= 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
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]
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,
\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
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
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;
\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:
--
-- * -#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
import TidyPgm ( optTidyPgm, simpleTidyPgm )
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
+import TyCon ( isDataTyCon )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
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
-- 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
-- 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
-- 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
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)
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)
------------------ 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 -----------------------
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"
ModuleGraph, emptyMG,
ModDetails(..), emptyModDetails,
- ModGuts(..), ModImports(..), ForeignStubs(..),
+ ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..),
ModSummary(..), showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
-- 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
-- directly or indirectly
}
+-----------------------------------
data ForeignStubs = NoStubs
| ForeignStubs
SDoc -- Header file prototypes for
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 )
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 )
* 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"
; 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]
-- 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
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 })
-- 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
-- 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 })
}
--
-- * 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
nc_var = hsc_NC hsc_env
-- have to put 'f' in the avoids list before we get to the first
-- decl. tidyTopId then does a no-op on exported binders.
init_env = (initTidyOccEnv avoids, emptyVarEnv)
- avoids = [getOccName name | bndr <- typeEnvIds env_tc,
+ avoids = [getOccName name | bndr <- typeEnvIds type_env,
let name = idName bndr,
isExternalName name]
-- In computing our "avoids" list, we must include
-- since their names are "taken".
-- The type environment is a convenient source of such things.
- go env [] = return (env, [])
- go env (b:bs) = do { (env1, b') <- tidyTopBind dflags mod nc_var ext_ids env b
- ; (env2, bs') <- go env1 bs
- ; return (env2, b':bs') }
+ tidy env [] = return (env, [])
+ tidy env (b:bs) = do { (env1, b') <- tidyTopBind dflags mod nc_var ext_ids env b
+ ; (env2, bs') <- tidy env1 bs
+ ; return (env2, b':bs') }
+
+ tycons = typeEnvTyCons type_env
+
+ implicit_ids :: [Id]
+ implicit_ids = concatMap implicit_con_ids tycons
+ ++ concatMap other_implicit_ids (typeEnvElts type_env)
+ --Put the constructor wrappers first, because
+ -- other implicit bindings (notably the fromT functions arising
+ -- from generics) use the constructor wrappers.
+
+ implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
+
+ 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 (unfoldingTemplate (idUnfolding id))
------------------------
tidyTopBind :: DynFlags
-- in the IdInfo of one early in the group
tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
- = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local
- -- until the CoreTidy phase" --GHC comentary
- (bndr', rhs')
+ | isGlobalId bndr -- Injected binding for record selector, etc
+ = (bndr, tidyExpr rhs_tidy_env rhs)
+ | otherwise
+ = (bndr', rhs')
where
bndr' = mkVanillaGlobal name' ty' idinfo'
ty' = tidyTopType (idType bndr)
import OccName ( srcDataName, isTcOcc, occNameFlavour, OccEnv,
mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv )
import HscTypes ( GenAvailInfo(..), AvailInfo,
- IfaceExport, HomePackageTable, PackageIfaceTable,
+ HomePackageTable, PackageIfaceTable,
availNames, unQualInScope,
Deprecs(..), ModIface(..), Dependencies(..),
lookupIface, ExternalPackageState(..)
import RnExpr ( rnLExpr )
import RnEnv ( lookupTopBndrRn, lookupImportedName )
import Inst ( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag )
-import InstEnv ( Instance, mkLocalInstance )
+import InstEnv ( mkLocalInstance )
import TcEnv ( tcLookupLocatedClass, tcExtendIdEnv2,
tcExtendTyVarEnv,
InstInfo(..), pprInstInfoDetails,
import TcSimplify ( tcSimplifyCheck )
import TcIface ( checkWiredInTyCon )
import TcEnv ( tcGetGlobalTyVars, findGlobals )
-import TyCon ( TyCon, tyConArity, tyConTyVars, tyConName )
+import TyCon ( TyCon, tyConArity, tyConTyVars )
import TysWiredIn ( listTyCon )
import Id ( Id, mkSysLocal )
import Var ( Var, varName, tyVarKind )
import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems )
import VarEnv
-import Name ( isSystemName, mkSysTvName, isWiredInName )
+import Name ( isSystemName, mkSysTvName )
import ErrUtils ( Message )
import SrcLoc ( noLoc )
import BasicTypes ( Arity )
-- True for all @data@ types
-- False for newtypes
-- unboxed tuples
-isDataTyCon (AlgTyCon {algTcRhs = rhs})
+isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
= case rhs of
DataTyCon _ _ -> True
NewTyCon _ _ _ -> False
- AbstractTyCon -> panic "isDataTyCon"
+ AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
projects / ghc-hetmet.git / commitdiff