X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=4d096d213a49e4364be40b124c98b8d311777d5b;hp=3673b3ee7ae3d86e7774efa481fb6c63f1b60c75;hb=224ef3094189bc9a33f23285b5dccbffdd8d7de0;hpb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3673b3e..4d096d2 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -14,7 +14,7 @@ module HscTypes ( -- * Information about modules ModDetails(..), emptyModDetails, - ModGuts(..), CgGuts(..), ForeignStubs(..), + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ModSummary(..), ms_mod_name, showModMsg, isBootSummary, @@ -25,8 +25,9 @@ module HscTypes ( -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, hptVectInfo, - + hptInstances, hptRules, hptVectInfo, + hptObjs, + -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -53,13 +54,13 @@ module HscTypes ( -- * TyThings and type environments TyThing(..), - tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, + tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom, implicitTyThings, isImplicitTyThing, TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, - typeEnvDataCons, + typeEnvDataCons, typeEnvCoAxioms, -- * MonadThings MonadThings(..), @@ -76,7 +77,7 @@ module HscTypes ( Warnings(..), WarningTxt(..), plusWarns, -- * Linker stuff - Linkable(..), isObjectLinkable, + Linkable(..), isObjectLinkable, linkableObjs, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, @@ -494,6 +495,9 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- And get its dfuns , thing <- things ] + +hptObjs :: HomePackageTable -> [FilePath] +hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) \end{code} %************************************************************************ @@ -713,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)] -- | A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module -- being compiled right now. Once it is compiled, a 'ModIface' and --- 'ModDetails' are extracted and the ModGuts is dicarded. +-- 'ModDetails' are extracted and the ModGuts is discarded. data ModGuts = ModGuts { mg_module :: !Module, -- ^ Module being compiled @@ -795,11 +799,7 @@ data CgGuts -- 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, -- ^ Foreign export stubs + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information @@ -819,6 +819,10 @@ data ForeignStubs = NoStubs -- ^ We don't have any stubs -- -- 2) C stubs to use when calling -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) \end{code} \begin{code} @@ -1033,7 +1037,10 @@ implicitTyThings (ATyCon tc) -- for each data constructor in order, -- the contructor, worker, and (possibly) wrapper concatMap (extras_plus . ADataCon) (tyConDataCons tc) - + +implicitTyThings (ACoAxiom _cc) + = [] + implicitTyThings (AClass cl) = -- dictionary datatype: -- [extras_plus:] @@ -1065,10 +1072,10 @@ extras_plus thing = thing : implicitTyThings thing -- add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc - = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not - newTyConCo_maybe tc, + = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not + newTyConCo_maybe tc, -- Just if family instance, Nothing if not - tyConFamilyCoercion_maybe tc] + tyConFamilyCoercion_maybe tc] -- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y) @@ -1078,10 +1085,11 @@ implicitCoTyCon tc -- of some other declaration, or it is generated implicitly by some -- other declaration. isImplicitTyThing :: TyThing -> Bool -isImplicitTyThing (ADataCon _) = True -isImplicitTyThing (AnId id) = isImplicitId id -isImplicitTyThing (AClass _) = False -isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ADataCon {}) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (AClass {}) = False +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom {}) = True extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids @@ -1103,6 +1111,7 @@ emptyTypeEnv :: TypeEnv typeEnvElts :: TypeEnv -> [TyThing] typeEnvClasses :: TypeEnv -> [Class] typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom] typeEnvIds :: TypeEnv -> [Id] typeEnvDataCons :: TypeEnv -> [DataCon] lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing @@ -1111,6 +1120,7 @@ emptyTypeEnv = emptyNameEnv typeEnvElts env = nameEnvElts env typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] @@ -1166,6 +1176,11 @@ tyThingTyCon :: TyThing -> TyCon tyThingTyCon (ATyCon tc) = tc tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other) +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: TyThing -> CoAxiom +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other) + -- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise tyThingClass :: TyThing -> Class tyThingClass (AClass cls) = cls @@ -1790,6 +1805,9 @@ isObjectLinkable l = not (null unlinked) && all isObject unlinked -- compiling a module in HscNothing mode, and this choice -- happens to work well with checkStability in module GHC. +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + instance Outputable Linkable where ppr (LM when_made mod unlinkeds) = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)