From 3df92bb75dcef6630e68c0a885ca3c77a759c653 Mon Sep 17 00:00:00 2001 From: Gergo Erdi Date: Fri, 18 Jun 2021 15:03:21 +0800 Subject: [PATCH] Upgrade underlying GHC to 8f021b8c474f328441982c90c6a12f716b5607eb --- external-stg-compiler/app/gen-obj.hs | 4 +-- external-stg-compiler/app/gen-obj2.hs | 4 +-- external-stg-compiler/lib/Stg/GHC/Backend.hs | 18 +++++++------- external-stg-compiler/lib/Stg/GHC/Convert.hs | 26 ++++++++++---------- external-stg-compiler/lib/Stg/GHC/ToStg.hs | 12 ++++----- ghc-wpc | 2 +- stack.yaml | 1 + 7 files changed, 34 insertions(+), 33 deletions(-) diff --git a/external-stg-compiler/app/gen-obj.hs b/external-stg-compiler/app/gen-obj.hs index 3002431..c8836d4 100644 --- a/external-stg-compiler/app/gen-obj.hs +++ b/external-stg-compiler/app/gen-obj.hs @@ -18,7 +18,7 @@ import GHC.Paths ( libdir ) {- = StgModule - { stgUnitId :: UnitId + { stgUnit :: Unit , stgModuleName :: ModuleName , stgModuleTyCons :: [TyCon] , stgTopBindings :: [StgTopBinding] @@ -45,6 +45,6 @@ main = runGhc (Just libdir) $ do --putStrLn $ unlines $ map show stgIdUniqueMap -- HINT: the stubs are compiled at link time - compileToObjectM cg stgUnitId stgModuleName GHC.NoStubs stgModuleTyCons stgTopBindings oName + compileToObjectM cg stgUnit stgModuleName GHC.NoStubs stgModuleTyCons stgTopBindings oName -- TODO: simplify API to: compileToObject cg stgModule oName diff --git a/external-stg-compiler/app/gen-obj2.hs b/external-stg-compiler/app/gen-obj2.hs index c4d23de..85e4fbf 100644 --- a/external-stg-compiler/app/gen-obj2.hs +++ b/external-stg-compiler/app/gen-obj2.hs @@ -20,7 +20,7 @@ import GHC.Paths ( libdir ) {- = StgModule - { stgUnitId :: UnitId + { stgUnit :: Unit , stgModuleName :: ModuleName , stgModuleTyCons :: [TyCon] , stgTopBindings :: [StgTopBinding] @@ -48,4 +48,4 @@ main = do oName = objectOutputPath modName ++ ".o" -- HINT: the stubs are compiled at link time - compileToObjectM cg stgUnitId stgModuleName GHC.NoStubs stgModuleTyCons stgTopBindings oName + compileToObjectM cg stgUnit stgModuleName GHC.NoStubs stgModuleTyCons stgTopBindings oName diff --git a/external-stg-compiler/lib/Stg/GHC/Backend.hs b/external-stg-compiler/lib/Stg/GHC/Backend.hs index 86931b6..725b621 100644 --- a/external-stg-compiler/lib/Stg/GHC/Backend.hs +++ b/external-stg-compiler/lib/Stg/GHC/Backend.hs @@ -21,7 +21,7 @@ import GHC.Stg.Lint import GHC.Stg.Syntax import GHC.Stg.Unarise import GHC.Types.CostCentre -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Name.Set import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream @@ -58,18 +58,18 @@ modl = mkModule mainUnitId (mkModuleName ":Main") data Backend = NCG | LLVM -compileToObject :: Backend -> UnitId -> ModuleName -> ForeignStubs -> [TyCon] -> [StgTopBinding] -> FilePath -> IO () -compileToObject backend unitId modName stubs tyCons topBinds_simple outputName = do - runGhc (Just libdir) $ compileToObjectM backend unitId modName stubs tyCons topBinds_simple outputName +compileToObject :: Backend -> Unit -> ModuleName -> ForeignStubs -> [TyCon] -> [StgTopBinding] -> FilePath -> IO () +compileToObject backend unit modName stubs tyCons topBinds_simple outputName = do + runGhc (Just libdir) $ compileToObjectM backend unit modName stubs tyCons topBinds_simple outputName -compileToObjectM :: Backend -> UnitId -> ModuleName -> ForeignStubs -> [TyCon] -> [StgTopBinding] -> FilePath -> Ghc () -compileToObjectM backend unitId modName stubs tyCons topBinds_simple outputName = do +compileToObjectM :: Backend -> Unit -> ModuleName -> ForeignStubs -> [TyCon] -> [StgTopBinding] -> FilePath -> Ghc () +compileToObjectM backend unit modName stubs tyCons topBinds_simple outputName = do dflags <- getSessionDynFlags let ccs = emptyCollectedCCs :: CollectedCCs hpc = emptyHpcInfo False - this_mod = mkModule unitId modName :: Module + this_mod = mkModule unit modName :: Module -- backend (target, link, outAsmFName) = case backend of @@ -189,7 +189,7 @@ type CollectedCCs let libSet = Set.fromList ["rts"] -- "rts", "ghc-prim-cbits", "base-cbits", "integer-gmp-cbits"] dflags <- getSessionDynFlags - let ignored_pkgs = [IgnorePackage p | p <- map (unpackFS . installedUnitIdFS) pkgs, Set.notMember p libSet] + let ignored_pkgs = [IgnorePackage p | p <- map unitIdString pkgs, Set.notMember p libSet] my_pkgs = [ExposePackage p (PackageArg p) (ModRenaming True []) | p <- Set.toList libSet] setSessionDynFlags $ dflags { ignorePackageFlags = ignored_pkgs, packageFlags = my_pkgs } dflags <- getSessionDynFlags @@ -216,7 +216,7 @@ newGen :: DynFlags -> CollectedCCs -> [StgTopBinding] -> HpcInfo - -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet) + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NonCaffySet) newGen dflags hsc_env output_filename this_mod foreign_stubs data_tycons cost_centre_info stg_binds hpc_info = do -- TODO: add these to parameters let location = ModLocation diff --git a/external-stg-compiler/lib/Stg/GHC/Convert.hs b/external-stg-compiler/lib/Stg/GHC/Convert.hs index 457f5c3..26bf4c4 100644 --- a/external-stg-compiler/lib/Stg/GHC/Convert.hs +++ b/external-stg-compiler/lib/Stg/GHC/Convert.hs @@ -30,7 +30,7 @@ import qualified GHC.Types.Name as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Types.RepType as GHC import qualified GHC.Types.Unique as GHC -import qualified GHC.Types.Module as GHC +import qualified GHC.Unit.Module as GHC import qualified GHC.Utils.Outputable as GHC import Control.Monad @@ -116,14 +116,14 @@ cvtUnique u = Unique a b cvtOccName :: GHC.OccName -> Name cvtOccName = GHC.bytesFS . GHC.occNameFS -cvtUnitId :: GHC.UnitId -> UnitId -cvtUnitId = UnitId . GHC.bytesFS . GHC.unitIdFS +cvtUnit :: GHC.Unit -> UnitId +cvtUnit = UnitId . GHC.bytesFS . GHC.unitFS cvtModuleName :: GHC.ModuleName -> ModuleName cvtModuleName = ModuleName . GHC.bytesFS . GHC.moduleNameFS -cvtUnitIdAndModuleName :: GHC.Module -> (UnitId, ModuleName) -cvtUnitIdAndModuleName m = (cvtUnitId $ GHC.moduleUnitId m, cvtModuleName $ GHC.moduleName m) +cvtUnitAndModuleName :: GHC.Module -> (UnitId, ModuleName) +cvtUnitAndModuleName m = (cvtUnit $ GHC.moduleUnit m, cvtModuleName $ GHC.moduleName m) -- source location conversion @@ -439,7 +439,7 @@ cvtSourceText = \case cvtCCallTarget :: GHC.CCallTarget -> CCallTarget cvtCCallTarget = \case - GHC.StaticTarget s l u b -> StaticTarget (cvtSourceText s) (GHC.bytesFS l) (fmap cvtUnitId u) b + GHC.StaticTarget s l u b -> StaticTarget (cvtSourceText s) (GHC.bytesFS l) (fmap cvtUnit u) b GHC.DynamicTarget -> DynamicTarget cvtCCallConv :: GHC.CCallConv -> CCallConv @@ -460,7 +460,7 @@ cvtForeignCall :: GHC.ForeignCall -> ForeignCall cvtForeignCall (GHC.CCall (GHC.CCallSpec t c s)) = ForeignCall (cvtCCallTarget t) (cvtCCallConv c) (cvtSafety s) cvtPrimCall :: GHC.PrimCall -> PrimCall -cvtPrimCall (GHC.PrimCall lbl uid) = PrimCall (GHC.bytesFS lbl) (cvtUnitId uid) +cvtPrimCall (GHC.PrimCall lbl uid) = PrimCall (GHC.bytesFS lbl) (cvtUnit uid) cvtOp :: GHC.StgOp -> StgOp cvtOp = \case @@ -563,8 +563,8 @@ cvtForeignSrcLang = \case GHC.RawObject -> RawObject -- module conversion -cvtModule :: String -> GHC.UnitId -> GHC.ModuleName -> Maybe FilePath -> [GHC.StgTopBinding] -> GHC.ForeignStubs -> [(GHC.ForeignSrcLang, FilePath)] -> SModule -cvtModule phase unitId' modName' mSrcPath binds foreignStubs foreignFiles = +cvtModule :: String -> GHC.Unit -> GHC.ModuleName -> Maybe FilePath -> [GHC.StgTopBinding] -> GHC.ForeignStubs -> [(GHC.ForeignSrcLang, FilePath)] -> SModule +cvtModule phase unit modName' mSrcPath binds foreignStubs foreignFiles = Module { modulePhase = BS8.pack phase , moduleUnitId = unitId @@ -583,11 +583,11 @@ cvtModule phase unitId' modName' mSrcPath binds foreignStubs foreignFiles = initialEnv = emptyEnv stgTopIds = concatMap topBindIds binds modName = cvtModuleName modName' - unitId = cvtUnitId unitId' + unitId = cvtUnit unit tyCons = groupByUnitIdAndModule . map mkTyCon $ IntMap.elems envTyCons -- calculate dependencies - externalTyCons = [(cvtUnitIdAndModuleName m, ()) | m <- catMaybes $ map (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] + externalTyCons = [(cvtUnitAndModuleName m, ()) | m <- catMaybes $ map (GHC.nameModule_maybe . GHC.getName) $ IntMap.elems envTyCons] dependencies = map (fmap (map fst)) $ groupByUnitIdAndModule $ [((u, m), ()) | (u, ml) <- externalIds, (m, _) <- ml] ++ externalTyCons -- utils @@ -599,10 +599,10 @@ groupByUnitIdAndModule l = [Map.singleton u (Map.singleton m (Set.singleton b)) | ((u, m), b) <- l] mkExternalName :: GHC.Id -> M ((UnitId, ModuleName), SBinder) -mkExternalName x = (cvtUnitIdAndModuleName . GHC.nameModule $ GHC.getName x,) <$> cvtBinderIdM "mkExternalName" x +mkExternalName x = (cvtUnitAndModuleName . GHC.nameModule $ GHC.getName x,) <$> cvtBinderIdM "mkExternalName" x mkTyCon :: GHC.TyCon -> ((UnitId, ModuleName), STyCon) -mkTyCon tc = (cvtUnitIdAndModuleName $ GHC.nameModule n, b) where +mkTyCon tc = (cvtUnitAndModuleName $ GHC.nameModule n, b) where n = GHC.getName tc b = STyCon { stcName = cvtOccName $ GHC.getOccName n diff --git a/external-stg-compiler/lib/Stg/GHC/ToStg.hs b/external-stg-compiler/lib/Stg/GHC/ToStg.hs index 5ceb5d0..85f3d31 100644 --- a/external-stg-compiler/lib/Stg/GHC/ToStg.hs +++ b/external-stg-compiler/lib/Stg/GHC/ToStg.hs @@ -10,7 +10,7 @@ import GHC.Driver.Types import GHC.Utils.Outputable -- Stg Types -import GHC.Types.Module +import GHC.Unit.Module import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info @@ -240,8 +240,8 @@ cvtNewId Ext.Binder{..} = do state $ \env@Env{..} -> (finalId, env {envIdMap = Map.insert binderId finalId envIdMap}) -cvtUnitId :: Ext.UnitId -> UnitId -cvtUnitId = fsToUnitId . mkFastStringByteString . Ext.getUnitId +cvtUnitId :: Ext.UnitId -> Unit +cvtUnitId = fsToUnit . mkFastStringByteString . Ext.getUnitId cvtModuleName :: Ext.ModuleName -> ModuleName cvtModuleName = mkModuleNameFS . mkFastStringByteString . Ext.getModuleName @@ -284,7 +284,7 @@ cvtPrimRepType = \case Ext.SingleValue Ext.VoidRep -> mkTupleTy Unboxed [] Ext.SingleValue r -> primRepToType $ cvtPrimRep r Ext.UnboxedTuple l -> mkTupleTy Unboxed $ map (primRepToType . cvtPrimRep) l - Ext.PolymorphicRep -> mkInvForAllTy runtimeRep2TyVar + Ext.PolymorphicRep -> mkInfForAllTy runtimeRep2TyVar $ mkSpecForAllTys [openBetaTyVar] $ mkTyVarTy openBetaTyVar -- HINT: forall (r :: RuntimeRep) (b :: TYPE r). b @@ -460,7 +460,7 @@ cvtForeignSrcLang = \case data StgModule = StgModule - { stgUnitId :: UnitId + { stgUnit :: Unit , stgModuleName :: ModuleName , stgModuleTyCons :: [TyCon] , stgTopBindings :: [StgTopBinding] @@ -499,7 +499,7 @@ toStg Ext.Module{..} = stgModule where ] stgModule = StgModule - { stgUnitId = cvtUnitId moduleUnitId + { stgUnit = cvtUnitId moduleUnitId , stgModuleName = cvtModuleName moduleName , stgModuleTyCons = Map.elems $ Map.restrictKeys envADTTyConMap localTyConIds , stgTopBindings = topBindings diff --git a/ghc-wpc b/ghc-wpc index 728b01e..c3d0ed3 160000 --- a/ghc-wpc +++ b/ghc-wpc @@ -1 +1 @@ -Subproject commit 728b01e6de9a9477115cb4425d6555f71490a9be +Subproject commit c3d0ed3af62aed1258188907c9b5dc06d69a82d5 diff --git a/stack.yaml b/stack.yaml index 2adcc3c..64187d3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,6 +13,7 @@ extra-deps: - async-pool-0.9.1@sha256:4015140f896c3f1652b06a679b0ade2717d05557970c283ea2c372a71be2a6a1,1605 - souffle-haskell-1.1.0 - zip-1.7.0 + - th-abstraction-0.4.2.0 # use custom ext-stg whole program compiler GHC