X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=4d096d213a49e4364be40b124c98b8d311777d5b;hp=5d53739d1fc784539bc0af29024b01cfcb3cf4c3;hb=224ef3094189bc9a33f23285b5dccbffdd8d7de0;hpb=27310213397bb89555bb03585e057ba1b017e895 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 5d53739..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, @@ -130,7 +131,7 @@ import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) import IfaceSyn -import CoreSyn ( CoreRule ) +import CoreSyn ( CoreRule, CoreVect ) import Maybes ( orElse, expectJust, catMaybes ) import Outputable import BreakArray @@ -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 @@ -738,9 +742,11 @@ data ModGuts mg_binds :: ![CoreBind], -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_warns :: !Warnings, -- ^ Warnings declared in the module - mg_anns :: [Annotation], -- ^ Annotations declared in this module - mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module + mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module + -- (produced by desugarer & consumed by vectoriser) mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module -- The next two fields are unusual, because they give instance @@ -793,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 @@ -817,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} @@ -1031,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:] @@ -1063,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) @@ -1076,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 @@ -1101,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 @@ -1109,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] @@ -1164,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 @@ -1788,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)