diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs --- a/compiler/basicTypes/UniqSupply.hs +++ b/compiler/basicTypes/UniqSupply.hs @@ -3,8 +3,13 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, UnboxedTuples #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +#if !defined(GHC_LOADED_INTO_GHCI) +{-# LANGUAGE UnboxedTuples #-} +#endif + module UniqSupply ( -- * Main data type UniqSupply, -- Abstractly @@ -131,22 +136,37 @@ ************************************************************************ -} +-- Avoids using unboxed tuples when loading into GHCi +#if !defined(GHC_LOADED_INTO_GHCI) + +type UniqResult result = (# result, UniqSupply #) + +pattern UniqResult :: a -> b -> (# a, b #) +pattern UniqResult x y = (# x, y #) +{-# COMPLETE UniqResult #-} + +#else + +data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply + +#endif + -- | A monad which just gives the ability to obtain 'Unique's -newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) } +newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } instance Monad UniqSM where (>>=) = thenUs (>>) = (*>) instance Functor UniqSM where - fmap f (USM x) = USM (\us -> case x us of - (# r, us' #) -> (# f r, us' #)) + fmap f (USM x) = USM (\us0 -> case x us0 of + UniqResult r us1 -> UniqResult (f r) us1) instance Applicative UniqSM where pure = returnUs - (USM f) <*> (USM x) = USM $ \us -> case f us of - (# ff, us' #) -> case x us' of - (# xx, us'' #) -> (# ff xx, us'' #) + (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of + UniqResult ff us1 -> case x us1 of + UniqResult xx us2 -> UniqResult (ff xx) us2 (*>) = thenUs_ -- TODO: try to get rid of this instance @@ -155,11 +175,11 @@ -- | Run the 'UniqSM' action, returning the final 'UniqSupply' initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) -initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) } +initUs init_us m = case unUSM m init_us of { UniqResult r us -> (r, us) } -- | Run the 'UniqSM' action, discarding the final 'UniqSupply' initUs_ :: UniqSupply -> UniqSM a -> a -initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r } +initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } {-# INLINE thenUs #-} {-# INLINE lazyThenUs #-} @@ -169,29 +189,29 @@ -- @thenUs@ is where we split the @UniqSupply@. liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) -liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us') +liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) instance MonadFix UniqSM where - mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #)) + mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b thenUs (USM expr) cont - = USM (\us -> case (expr us) of - (# result, us' #) -> unUSM (cont result) us') + = USM (\us0 -> case (expr us0) of + UniqResult result us1 -> unUSM (cont result) us1) lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b lazyThenUs expr cont - = USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us') + = USM (\us0 -> let (result, us1) = liftUSM expr us0 in unUSM (cont result) us1) thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b thenUs_ (USM expr) (USM cont) - = USM (\us -> case (expr us) of { (# _, us' #) -> cont us' }) + = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) returnUs :: a -> UniqSM a -returnUs result = USM (\us -> (# result, us #)) +returnUs result = USM (\us -> UniqResult result us) getUs :: UniqSM UniqSupply -getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #)) +getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) -- | A monad for generating unique identifiers class Monad m => MonadUnique m where @@ -221,12 +241,12 @@ liftUs m = getUniqueSupplyM >>= return . flip initUs_ m getUniqueUs :: UniqSM Unique -getUniqueUs = USM (\us -> case takeUniqFromSupply us of - (u,us') -> (# u, us' #)) +getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of + (u,us1) -> UniqResult u us1) getUniquesUs :: UniqSM [Unique] -getUniquesUs = USM (\us -> case splitUniqSupply us of - (us1,us2) -> (# uniqsFromSupply us1, us2 #)) +getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of + (us1,us2) -> UniqResult (uniqsFromSupply us1) us2) -- {-# SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-} -- {-# SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-} diff --git a/compiler/ghci/LinkerTypes.hs b/compiler/ghci/LinkerTypes.hs new file mode 100644 --- /dev/null +++ b/compiler/ghci/LinkerTypes.hs @@ -0,0 +1,112 @@ +----------------------------------------------------------------------------- +-- +-- Types for the Dynamic Linker +-- +-- (c) The University of Glasgow 2019 +-- +----------------------------------------------------------------------------- + +module LinkerTypes ( + DynLinker(..), + PersistentLinkerState(..), + LinkerUnitId, + Linkable(..), + Unlinked(..), + SptEntry(..) + ) where + +import GhcPrelude ( FilePath, String, show ) +import Data.Time ( UTCTime ) +import Data.Maybe ( Maybe ) +import Control.Concurrent.MVar ( MVar ) +import Module ( InstalledUnitId, Module ) +import ByteCodeTypes ( ItblEnv, CompiledByteCode ) +import Outputable +import Var ( Id ) +import GHC.Fingerprint.Type ( Fingerprint ) +import NameEnv ( NameEnv ) +import Name ( Name ) +import GHCi.RemoteTypes ( ForeignHValue ) + +type ClosureEnv = NameEnv (Name, ForeignHValue) + +newtype DynLinker = + DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) } + +data PersistentLinkerState + = PersistentLinkerState { + + -- Current global mapping from Names to their true values + closure_env :: ClosureEnv, + + -- The current global mapping from RdrNames of DataCons to + -- info table addresses. + -- When a new Unlinked is linked into the running image, or an existing + -- module in the image is replaced, the itbl_env must be updated + -- appropriately. + itbl_env :: !ItblEnv, + + -- The currently loaded interpreted modules (home package) + bcos_loaded :: ![Linkable], + + -- And the currently-loaded compiled modules (home package) + objs_loaded :: ![Linkable], + + -- The currently-loaded packages; always object code + -- Held, as usual, in dependency order; though I am not sure if + -- that is really important + pkgs_loaded :: ![LinkerUnitId], + + -- we need to remember the name of previous temporary DLL/.so + -- libraries so we can link them (see #10322) + temp_sos :: ![(FilePath, String)] } + +-- TODO: Make this type more precise +type LinkerUnitId = InstalledUnitId + +-- | Information we can use to dynamically link modules into the compiler +data Linkable = LM { + linkableTime :: UTCTime, -- ^ Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + linkableModule :: Module, -- ^ The linkable module itself + linkableUnlinked :: [Unlinked] + -- ^ Those files and chunks of code we have yet to link. + -- + -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. + -- If this list is empty, the Linkable represents a fake linkable, which + -- is generated in HscNothing mode to avoid recompiling modules. + -- + -- ToDo: Do items get removed from this list when they get linked? + } + +instance Outputable Linkable where + ppr (LM when_made mod unlinkeds) + = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr unlinkeds) + +-- | Objects which have yet to be linked by the compiler +data Unlinked + = DotO FilePath -- ^ An object file (.o) + | DotA FilePath -- ^ Static archive file (.a) + | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) + | BCOs CompiledByteCode + [SptEntry] -- ^ A byte-code object, lives only in memory. Also + -- carries some static pointer table entries which + -- should be loaded along with the BCOs. + -- See Note [Grant plan for static forms] in + -- StaticPtrTable. + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt + +-- | An entry to be inserted into a module's static pointer table. +-- See Note [Grand plan for static forms] in StaticPtrTable. +data SptEntry = SptEntry Id Fingerprint + +instance Outputable SptEntry where + ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr + diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -37,11 +37,11 @@ -- ** Instance declarations InstDecl(..), LInstDecl, FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, + TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl, - pprDataFamInstFlavour, pprHsFamInstLHS, + pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS, FamInstEqn, LFamInstEqn, FamEqn(..), - TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, - HsTyPats, + TyFamInstEqn, LTyFamInstEqn, HsTyPats, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations @@ -533,7 +533,7 @@ tcdSigs :: [LSig pass], -- ^ Methods' signatures tcdMeths :: LHsBinds pass, -- ^ Default methods tcdATs :: [LFamilyDecl pass], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltEqn pass], -- ^ Associated type defaults + tcdATDefs :: [LTyFamDefltDecl pass], -- ^ Associated type defaults tcdDocs :: [LDocDecl] -- ^ Haddock docs } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', @@ -726,7 +726,7 @@ | otherwise -- Laid out = vcat [ top_matter <+> text "where" , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++ - map ppr_fam_deflt_eqn at_defs ++ + map (pprTyFamDefltDecl . unLoc) at_defs ++ pprLHsBindsForUser methods sigs) ] where top_matter = text "class" @@ -1507,28 +1507,23 @@ Note [Type family instance declarations in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The data type FamEqn represents one equation of a type family instance. -Aside from the pass, it is also parameterised over two fields: -feqn_pats and feqn_rhs. - -feqn_pats is either LHsTypes (for ordinary data/type family instances) or -LHsQTyVars (for associated type family default instances). In particular: +Aside from the pass, it is also parameterised over another field, feqn_rhs. +feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType +(for type family instances). - * An ordinary type family instance declaration looks like this in source Haskell - type instance T [a] Int = a -> a - (or something similar for a closed family) - It is represented by a FamInstEqn, with a *type* (LHsType) in the feqn_pats - field. +Type family instances also include associated type family default equations. +That is because a default for a type family looks like this: - * On the other hand, the *default instance* of an associated type looks like - this in source Haskell - class C a where - type T a b - type T a b = a -> b -- The default instance - It is represented by a TyFamDefltEqn, with *type variables* (LHsQTyVars) in - the feqn_pats field. + class C a where + type family F a b :: Type + type F c d = (c,d) -- Default instance -feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType -(for type family instances). +The default declaration is really just a `type instance` declaration, but one +with particularly simple patterns: they must all be distinct type variables. +That's because we will instantiate it (in an instance declaration for `C`) if +we don't give an explicit instance for `F`. Note that the names of the +variables don't need to match those of the class: it really is like a +free-standing `type instance` declaration. -} ----------------- Type synonym family instances ------------- @@ -1540,16 +1535,13 @@ -- For details on above see note [Api annotations] in ApiAnnotation --- | Located Type Family Default Equation -type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass) - -- | Haskell Type Patterns type HsTyPats pass = [LHsTypeArg pass] {- Note [Family instance declaration binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For ordinary data/type family instances, the feqn_pats field of FamEqn stores -the LHS type (and kind) patterns. Any type (and kind) variables contained +The feqn_pats field of FamEqn (family instance equation) stores the LHS type +(and kind) patterns. Any type (and kind) variables contained in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs in FamInstEqn depending on whether or not an explicit forall is present. In the case of an explicit forall, the hsib_vars only includes kind variables not @@ -1577,20 +1569,20 @@ so that we can compare the type pattern in the 'instance' decl and in the associated 'type' decl -For associated type family default instances (TyFamDefltEqn), instead of using -type patterns with binders in a surrounding HsImplicitBndrs, we use raw type -variables (LHsQTyVars) in the feqn_pats field of FamEqn. - -c.f. Note [TyVar binders for associated declarations] +c.f. Note [TyVar binders for associated decls] -} -- | Type Family Instance Equation type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) --- | Type Family Default Equation -type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass) - -- See Note [Type family instance declarations in HsSyn] +-- | Type family default declarations. +-- A convenient synonym for 'TyFamInstDecl'. +-- See @Note [Type family instance declarations in HsSyn]@. +type TyFamDefltDecl = TyFamInstDecl +-- | Located type family default declarations. +type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass) + -- | Located Type Family Instance Declaration type LTyFamInstDecl pass = Located (TyFamInstDecl pass) @@ -1625,8 +1617,7 @@ type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs) -- | Family Instance Equation -type FamInstEqn pass rhs - = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) +type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs) -- ^ Here, the @pats@ are type patterns (with kind and type bndrs). -- See Note [Family instance declaration binders] @@ -1636,23 +1627,23 @@ -- declaration, or type family default. -- See Note [Type family instance declarations in HsSyn] -- See Note [Family instance declaration binders] -data FamEqn pass pats rhs +data FamEqn pass rhs = FamEqn - { feqn_ext :: XCFamEqn pass pats rhs + { feqn_ext :: XCFamEqn pass rhs , feqn_tycon :: Located (IdP pass) , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars - , feqn_pats :: pats + , feqn_pats :: HsTyPats pass , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' - | XFamEqn (XXFamEqn pass pats rhs) + | XFamEqn (XXFamEqn pass rhs) -- For details on above see note [Api annotations] in ApiAnnotation -type instance XCFamEqn (GhcPass _) p r = NoExt -type instance XXFamEqn (GhcPass _) p r = NoExt +type instance XCFamEqn (GhcPass _) r = NoExt +type instance XXFamEqn (GhcPass _) r = NoExt ----------------- Class instances ------------- @@ -1723,6 +1714,10 @@ ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty +pprTyFamDefltDecl :: (OutputableBndrId (GhcPass p)) + => TyFamDefltDecl (GhcPass p) -> SDoc +pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel + ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p)) => TyFamInstEqn (GhcPass p) -> SDoc ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon @@ -1733,16 +1728,6 @@ = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x - -ppr_fam_deflt_eqn :: (OutputableBndrId (GhcPass p)) - => LTyFamDefltEqn (GhcPass p) -> SDoc -ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon - , feqn_pats = tvs - , feqn_fixity = fixity - , feqn_rhs = rhs })) - = text "type" <+> pp_vanilla_decl_head tycon tvs fixity noLHsContext - <+> equals <+> ppr rhs -ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DataFamInstDecl p) where diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -355,12 +355,12 @@ -- ------------------------------------- -- FamEqn type families -type family XCFamEqn x p r -type family XXFamEqn x p r +type family XCFamEqn x r +type family XXFamEqn x r -type ForallXFamEqn (c :: * -> Constraint) (x :: *) (p :: *) (r :: *) = - ( c (XCFamEqn x p r) - , c (XXFamEqn x p r) +type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) = + ( c (XCFamEqn x r) + , c (XXFamEqn x r) ) -- ------------------------------------- diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs --- a/compiler/hsSyn/HsInstances.hs +++ b/compiler/hsSyn/HsInstances.hs @@ -164,10 +164,10 @@ deriving instance Data (DataFamInstDecl GhcRn) deriving instance Data (DataFamInstDecl GhcTc) --- deriving instance (DataIdLR p p,Data pats,Data rhs)=>Data (FamEqn p pats rhs) -deriving instance (Data pats,Data rhs) => Data (FamEqn GhcPs pats rhs) -deriving instance (Data pats,Data rhs) => Data (FamEqn GhcRn pats rhs) -deriving instance (Data pats,Data rhs) => Data (FamEqn GhcTc pats rhs) +-- deriving instance (DataIdLR p p,Data rhs)=>Data (FamEqn p rhs) +deriving instance Data rhs => Data (FamEqn GhcPs rhs) +deriving instance Data rhs => Data (FamEqn GhcRn rhs) +deriving instance Data rhs => Data (FamEqn GhcTc rhs) -- deriving instance (DataIdLR p p) => Data (ClsInstDecl p) deriving instance Data (ClsInstDecl GhcPs) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1022,6 +1022,7 @@ -- For ghc -M depMakefile :: FilePath, depIncludePkgDeps :: Bool, + depIncludeCppDeps :: Bool, depExcludeMods :: [ModuleName], depSuffixes :: [String], @@ -2010,6 +2011,7 @@ -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, + depIncludeCppDeps = False, depExcludeMods = [], depSuffixes = [], -- end of ghc -M values @@ -2684,6 +2686,9 @@ setDepMakefile :: FilePath -> DynFlags -> DynFlags setDepMakefile f d = d { depMakefile = f } +setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags +setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } + setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } @@ -3100,6 +3105,8 @@ -------- ghc -M ----------------------------------------------------- , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "include-cpp-deps" + (noArg (setDepIncludeCppDeps True)) , make_ord_flag defGhcFlag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) @@ -5838,7 +5845,7 @@ llvmTargets = panic "v_unsafeGlobalDynFlags: llvmTargets not initialised" llvmPasses = panic "v_unsafeGlobalDynFlags: llvmPasses not initialised" -#if STAGE < 2 +#if 1 GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) #else SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -181,6 +181,7 @@ import Packages hiding ( Version(..) ) import CmdLineParser import DynFlags +import LinkerTypes ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) import DriverPhases ( Phase, HscSource(..), hscSourceString , isHsBootOrSig, isHsigFile ) import qualified DriverPhases as Phase @@ -375,8 +376,10 @@ -- | HscEnv is like 'Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source --- code (after preprocessing) to either C, assembly or C--. Things like --- the module graph don't change during a single compilation. +-- code (after preprocessing) to either C, assembly or C--. It's also used +-- to store the dynamic linker state to allow for multiple linkers in the +-- same address space. +-- Things like the module graph don't change during a single compilation. -- -- Historical note: \"hsc\" used to be the name of the compiler binary, -- when there was a separate driver and compiler. To compile a single @@ -438,6 +441,10 @@ , hsc_iserv :: MVar (Maybe IServ) -- ^ interactive server process. Created the first -- time it is needed. + + , hsc_dynLinker :: DynLinker + -- ^ dynamic linker. + } -- Note [hsc_type_env_var hack] @@ -1388,13 +1395,6 @@ appendStubC NoStubs c_code = ForeignStubs empty c_code appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) --- | An entry to be inserted into a module's static pointer table. --- See Note [Grand plan for static forms] in StaticPtrTable. -data SptEntry = SptEntry Id Fingerprint - -instance Outputable SptEntry where - ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr - {- ************************************************************************ * * @@ -2992,22 +2992,6 @@ stuff is the *dynamic* linker, and isn't present in a stage-1 compiler -} --- | Information we can use to dynamically link modules into the compiler -data Linkable = LM { - linkableTime :: UTCTime, -- ^ Time at which this linkable was built - -- (i.e. when the bytecodes were produced, - -- or the mod date on the files) - linkableModule :: Module, -- ^ The linkable module itself - linkableUnlinked :: [Unlinked] - -- ^ Those files and chunks of code we have yet to link. - -- - -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. - -- If this list is empty, the Linkable represents a fake linkable, which - -- is generated in HscNothing mode to avoid recompiling modules. - -- - -- ToDo: Do items get removed from this list when they get linked? - } - isObjectLinkable :: Linkable -> Bool isObjectLinkable l = not (null unlinked) && all isObject unlinked where unlinked = linkableUnlinked l @@ -3019,30 +3003,7 @@ 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) - $$ nest 3 (ppr unlinkeds) - ------------------------------------------- - --- | Objects which have yet to be linked by the compiler -data Unlinked - = DotO FilePath -- ^ An object file (.o) - | DotA FilePath -- ^ Static archive file (.a) - | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | BCOs CompiledByteCode - [SptEntry] -- ^ A byte-code object, lives only in memory. Also - -- carries some static pointer table entries which - -- should be loaded along with the BCOs. - -- See Note [Grant plan for static forms] in - -- StaticPtrTable. - -instance Outputable Unlinked where - ppr (DotO path) = text "DotO" <+> text path - ppr (DotA path) = text "DotA" <+> text path - ppr (DotDLL path) = text "DotDLL" <+> text path - ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt -- | Is this an actual file on disk we can link in somehow? isObject :: Unlinked -> Bool diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -45,7 +45,6 @@ mkExtName, -- RdrName -> CLabelString mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkConDeclH98, - mkATDefault, -- Bunch of functions in the parser monad for -- checking and constructing values @@ -173,14 +172,12 @@ -> P (LTyClDecl GhcPs) mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls - = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls + = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars,annst) <- checkTyVarsP (text "class") whereDots cls tparams + ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; (at_defs, annsi) <- mapAndUnzipM (eitherToP . mkATDefault) at_insts - ; sequence_ annsi ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity @@ -190,34 +187,6 @@ , tcdATs = ats, tcdATDefs = at_defs , tcdDocs = docs })) } -mkATDefault :: LTyFamInstDecl GhcPs - -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ()) --- ^ Take a type-family instance declaration and turn it into --- a type-family default equation for a class declaration. --- We parse things as the former and use this function to convert to the latter --- --- We use the Either monad because this also called from "Convert". --- --- The @P ()@ we return corresponds represents an action which will add --- some necessary paren annotations to the parsing context. Naturally, this --- is not something that the "Convert" use cares about. -mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) - | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats - , feqn_fixity = fixity, feqn_rhs = rhs } <- e - = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats - ; let f = cL loc (FamEqn { feqn_ext = noExt - , feqn_tycon = tc - , feqn_bndrs = ASSERT( isNothing bndrs ) - Nothing - , feqn_pats = tvs - , feqn_fixity = fixity - , feqn_rhs = rhs }) - ; pure (f, addAnnsAt loc anns) } -mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" -mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" -mkATDefault _ = panic "mkATDefault: Impossible Match" - -- due to #15884 - mkTyData :: SrcSpan -> NewOrData -> Maybe (Located CType) @@ -230,7 +199,7 @@ ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams + ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (cL loc (DataDecl { tcdDExt = noExt, @@ -263,7 +232,7 @@ mkTySynonym loc lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVarsP (text "type") equalsDots tc tparams + ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; return (cL loc (SynDecl { tcdSExt = noExt , tcdLName = tc, tcdTyVars = tyvars @@ -322,7 +291,7 @@ mkFamDecl loc info lhs ksig injAnn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVarsP (ppr info) equals_or_where tc tparams + ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; return (cL loc (FamDecl noExt (FamilyDecl { fdExt = noExt @@ -804,56 +773,47 @@ really doesn't matter! -} -checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] - -> P (LHsQTyVars GhcPs, [AddAnn]) --- Same as checkTyVars, but in the P monad -checkTyVarsP pp_what equals_or_where tc tparms - = do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms - ; eitherToP checkedTvs } - eitherToP :: Either (SrcSpan, SDoc) a -> P a -- Adapts the Either monad to the P monad eitherToP (Left (loc, doc)) = addFatalError loc doc eitherToP (Right thing) = return thing checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] - -> Either (SrcSpan, SDoc) - ( LHsQTyVars GhcPs -- the synthesized type variables - , [AddAnn] ) -- action which adds annotations + -> P ( LHsQTyVars GhcPs -- the synthesized type variables + , [AddAnn] ) -- action which adds annotations -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). --- We use the Either monad because it's also called (via 'mkATDefault') from --- "Convert". checkTyVars pp_what equals_or_where tc tparms = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, concat anns) } where check (HsTypeArg _ ki@(L loc _)) - = Left (loc, + = addFatalError loc $ vcat [ text "Unexpected type application" <+> text "@" <> ppr ki , text "In the" <+> pp_what <+> - ptext (sLit "declaration for") <+> quotes (ppr tc)]) + ptext (sLit "declaration for") <+> quotes (ppr tc)] check (HsValArg ty) = chkParens [] ty - check (HsArgPar sp) = Left (sp, vcat [text "Malformed" <+> pp_what - <+> text "declaration for" <+> quotes (ppr tc)]) + check (HsArgPar sp) = addFatalError sp $ + vcat [text "Malformed" <+> pp_what + <+> text "declaration for" <+> quotes (ppr tc)] -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs - -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn]) + -> P (LHsTyVarBndr GhcPs, [AddAnn]) chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty - chkParens acc ty = case chk ty of - Left err -> Left err - Right tv -> Right (tv, reverse acc) + chkParens acc ty = do + tv <- chk ty + return (tv, reverse acc) -- Check that the name space is correct! - chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs) + chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs) chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) | isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k)) chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) | isRdrTyVar tv = return (cL l (UserTyVar noExt (cL ltv tv))) chk t@(dL->L loc _) - = Left (loc, + = addFatalError loc $ vcat [ text "Unexpected type" <+> quotes (ppr t) , text "In the" <+> pp_what <+> ptext (sLit "declaration for") <+> quotes tc' @@ -863,7 +823,7 @@ (pp_what <+> tc' <+> hsep (map text (takeList tparms allNameStrings)) - <+> equals_or_where) ] ]) + <+> equals_or_where) ] ] -- Avoid printing a constraint tuple in the error message. Print -- a plain old tuple instead (since that's what the user probably diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs --- a/compiler/utils/FastString.hs +++ b/compiler/utils/FastString.hs @@ -125,7 +125,7 @@ import Foreign -#if STAGE >= 2 +#if 0 import GHC.Conc.Sync (sharedCAF) #endif @@ -326,7 +326,7 @@ -- use the support wired into the RTS to share this CAF among all images of -- libHSghc -#if STAGE < 2 +#if 1 return tab #else sharedCAF tab getOrSetLibHSghcFastStringTable diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser -version: 0.20190516 +version: 0.20190523 license: BSD3 license-file: LICENSE category: Development @@ -268,6 +268,7 @@ Language.Haskell.TH.Syntax Lexeme Lexer + LinkerTypes ListSetOps Literal Maybes diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -6,7 +6,7 @@ #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190514 +#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190522 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage0/compiler/build/Parser.hs b/ghc-lib/stage0/compiler/build/Parser.hs --- a/ghc-lib/stage0/compiler/build/Parser.hs +++ b/ghc-lib/stage0/compiler/build/Parser.hs @@ -12744,7 +12744,7 @@ {-# LINE 19 "" #-} -{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc72921_0/ghc_2.h" #-} +{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc35710_0/ghc_2.h" #-} diff --git a/ghc-lib/stage1/compiler/build/Config.hs b/ghc-lib/stage1/compiler/build/Config.hs --- a/ghc-lib/stage1/compiler/build/Config.hs +++ b/ghc-lib/stage1/compiler/build/Config.hs @@ -13,17 +13,17 @@ cProjectName :: String cProjectName = "The Glorious Glasgow Haskell Compilation System" cProjectGitCommitId :: String -cProjectGitCommitId = "a416ae26a2e45de3d9a76e94fc22aaa53e9e5b12" +cProjectGitCommitId = "4ba73e00c4887b58d85131601a15d00608acaa60" cProjectVersion :: String -cProjectVersion = "8.9.0.20190514" +cProjectVersion = "8.9.0.20190522" cProjectVersionInt :: String cProjectVersionInt = "809" cProjectPatchLevel :: String -cProjectPatchLevel = "020190514" +cProjectPatchLevel = "020190522" cProjectPatchLevel1 :: String cProjectPatchLevel1 = "0" cProjectPatchLevel2 :: String -cProjectPatchLevel2 = "20190514" +cProjectPatchLevel2 = "20190522" cBooterVersion :: String cBooterVersion = "8.6.5" cStage :: String diff --git a/includes/rts/storage/InfoTables.h b/includes/rts/storage/InfoTables.h --- a/includes/rts/storage/InfoTables.h +++ b/includes/rts/storage/InfoTables.h @@ -189,7 +189,7 @@ StgHalfWord type; /* closure type */ StgSRTField srt; /* In a CONSTR: - - the constructor tag + - the zero-based constructor tag In a FUN/THUNK - if USE_INLINE_SRT_FIELD - offset to the SRT (or zero if no SRT) diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs --- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs @@ -36,14 +36,14 @@ import Language.Haskell.TH.Syntax - (Name(..), showName', NameFlavour(..), NameIs(..)) + (Uniq, Name(..), showName', NameFlavour(..), NameIs(..)) import qualified Text.PrettyPrint as HPJ import Control.Monad (liftM, liftM2, ap) import Language.Haskell.TH.Lib.Map ( Map ) import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty ) import Prelude hiding ((<>)) -infixl 6 <> +infixl 6 <> infixl 6 <+> infixl 5 $$, $+$ @@ -117,7 +117,7 @@ -- --------------------------------------------------------------------------- -- The "implementation" -type State = (Map Name Name, Int) +type State = (Map Name Name, Uniq) data PprM a = PprM { runPprM :: State -> (a, State) } pprName :: Name -> Doc diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -155,7 +155,7 @@ ; fail "Template Haskell failure" } -- Global variable to generate unique symbols -counter :: IORef Int +counter :: IORef Uniq {-# NOINLINE counter #-} counter = unsafePerformIO (newIORef 0) @@ -1299,8 +1299,8 @@ data NameFlavour = NameS -- ^ An unqualified name; dynamically bound | NameQ ModName -- ^ A qualified name; dynamically bound - | NameU !Int -- ^ A unique local name - | NameL !Int -- ^ Local name bound outside of the TH AST + | NameU !Uniq -- ^ A unique local name + | NameL !Uniq -- ^ Local name bound outside of the TH AST | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST: -- An original name (occurrences only, not binders) -- Need the namespace too to be sure which @@ -1313,7 +1313,8 @@ -- in the same name space for now. deriving( Eq, Ord, Show, Data, Generic ) -type Uniq = Int +-- | @Uniq@ is used by GHC to distinguish names from each other. +type Uniq = Integer -- | The name without its module prefix. --