From 91944423d83620441d6d3b120654a10fb41cfb3c Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 28 Apr 2005 16:05:57 +0000 Subject: [PATCH] [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. --- ghc/compiler/codeGen/CodeGen.lhs | 9 +-- ghc/compiler/coreSyn/CorePrep.lhs | 45 ++++------- ghc/compiler/coreSyn/MkExternalCore.lhs | 47 ++---------- ghc/compiler/ghci/ByteCodeGen.lhs | 7 +- ghc/compiler/iface/MkIface.lhs | 18 +++-- ghc/compiler/main/CodeOutput.lhs | 9 +-- ghc/compiler/main/HscMain.lhs | 61 +++++++-------- ghc/compiler/main/HscTypes.lhs | 44 +++++++---- ghc/compiler/main/TidyPgm.lhs | 128 +++++++++++++++++++++---------- ghc/compiler/rename/RnNames.lhs | 2 +- ghc/compiler/typecheck/TcClassDcl.lhs | 2 +- ghc/compiler/typecheck/TcUnify.lhs | 4 +- ghc/compiler/types/TyCon.lhs | 4 +- 13 files changed, 191 insertions(+), 189 deletions(-) diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 90a0efe..abe78f4 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index f918d72..d2c2c53 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -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} diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index e101a78..291b16e 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -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 diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index a4dd7ce..9335fd5 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -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] diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index b5abe7e..e508a17 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -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 diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 723227f..fbda3f1 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 8b3ad40..bd6bc43 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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" diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index b02debb..55caa22 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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 diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index ca7bced..b4f560c 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -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 nc_var = hsc_NC hsc_env @@ -493,7 +518,7 @@ tidyTopBinds hsc_env mod env_tc ext_ids binds -- 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 @@ -503,10 +528,28 @@ tidyTopBinds hsc_env mod env_tc ext_ids binds -- 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 @@ -622,9 +665,10 @@ tidyTopPair :: VarEnv Bool -- 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) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 6a82c56..e5052ce 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -34,7 +34,7 @@ import NameEnv 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(..) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index c16e681..d5ab178 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -18,7 +18,7 @@ import RnHsSyn ( maybeGenericMatch, extractHsTyVars ) 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, diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 60648b7..dea7766 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -53,13 +53,13 @@ import TcMType ( condLookupTcTyVar, LookupTyVarResult(..), 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 ) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 944d0ab..ffad3ce 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -397,11 +397,11 @@ isDataTyCon :: TyCon -> Bool -- 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 -- 1.7.10.4