Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Upgrade underlying GHC to 8f021b8c474f328441982c90c6a12f716b5607eb #6

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Upgrade underlying GHC to 8f021b8c474f328441982c90c6a12f716b5607eb #6

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 2 additions & 2 deletions external-stg-compiler/app/gen-obj.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,7 @@ import GHC.Paths ( libdir )

{-
= StgModule
{ stgUnitId :: UnitId
{ stgUnit :: Unit
, stgModuleName :: ModuleName
, stgModuleTyCons :: [TyCon]
, stgTopBindings :: [StgTopBinding]
Expand All @@ -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
4 changes: 2 additions & 2 deletions external-stg-compiler/app/gen-obj2.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ import GHC.Paths ( libdir )

{-
= StgModule
{ stgUnitId :: UnitId
{ stgUnit :: Unit
, stgModuleName :: ModuleName
, stgModuleTyCons :: [TyCon]
, stgTopBindings :: [StgTopBinding]
Expand Down Expand Up @@ -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
18 changes: 9 additions & 9 deletions external-stg-compiler/lib/Stg/GHC/Backend.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
26 changes: 13 additions & 13 deletions external-stg-compiler/lib/Stg/GHC/Convert.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
12 changes: 6 additions & 6 deletions external-stg-compiler/lib/Stg/GHC/ToStg.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -460,7 +460,7 @@ cvtForeignSrcLang = \case

data StgModule
= StgModule
{ stgUnitId :: UnitId
{ stgUnit :: Unit
, stgModuleName :: ModuleName
, stgModuleTyCons :: [TyCon]
, stgTopBindings :: [StgTopBinding]
Expand Down Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion ghc-wpc
Open in desktop
Submodule ghc-wpc updated 670 files
1 change: 1 addition & 0 deletions stack.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down