GitLab

David Eichmann pushed to branch wip/davide/windows-dlls at Glasgow Haskell Compiler / GHC

Commits:

4456f207

by David Eichmann at 2026-06-15T16:18:24+01:00

Hadrian: create a ghc-internal .def file per ghc-internal dll

The .def file generated from rts/win32/libHSghc-internal.def.in contains
the name of the ghc-internal dll. The correct dll name differs based
on if the dll is inplace/final and if using the Dynamic way. Previously,
this was not accounted for and inconsistent dlls names where used. That
led to failure when loading dlls at runtime in experiments with windows
dynamic linking.

96c59586
by David Eichmann at 2026-06-15T16:18:45+01:00
```
Hadrian: fix ghc-internal .def file name
```
3432392f
by David Eichmann at 2026-06-19T14:33:31+01:00
```
WIP place SRT info tables into .rdata on windows
```

Changes:

compiler/GHC/Cmm/CLabel.hs

@@ -106,6 +106,7 @@ module GHC.Cmm.CLabel (
          labelDynamic,
          isLocalCLabel,
          mayRedirectTo,
 +        isSRTInfoLabel,
          isInfoTableLabel,
          isCmmInfoTableLabel,
          isConInfoTableLabel,
@@ -730,6 +731,27 @@ mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess")
  mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") ForeignLabelInExternalPackage ForeignLabelIsFunction
  mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo
 +isSRTInfoLabel :: CLabel -> Bool
 +isSRTInfoLabel clbl = case clbl of
 +  CmmLabel _ _ lbl CmmInfo ->
 +    lbl == fsLit "stg_SRT_1"
 +    || lbl == fsLit "stg_SRT_2"
 +    || lbl == fsLit "stg_SRT_3"
 +    || lbl == fsLit "stg_SRT_4"
 +    || lbl == fsLit "stg_SRT_5"
 +    || lbl == fsLit "stg_SRT_6"
 +    || lbl == fsLit "stg_SRT_7"
 +    || lbl == fsLit "stg_SRT_8"
 +    || lbl == fsLit "stg_SRT_9"
 +    || lbl == fsLit "stg_SRT_10"
 +    || lbl == fsLit "stg_SRT_11"
 +    || lbl == fsLit "stg_SRT_12"
 +    || lbl == fsLit "stg_SRT_13"
 +    || lbl == fsLit "stg_SRT_14"
 +    || lbl == fsLit "stg_SRT_15"
 +    || lbl == fsLit "stg_SRT_16"
 +  _ -> False
++
  mkSRTInfoLabel :: Int -> CLabel
  mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo
   where

compiler/GHC/CmmToAsm/X86/Ppr.hs

@@ -33,7 +33,7 @@ import GHC.CmmToAsm.Ppr
  import GHC.Cmm              hiding (topInfoTable)
  import GHC.Cmm.Dataflow.Label
  import GHC.Cmm.BlockId
 -import GHC.Cmm.CLabel
 +import GHC.Cmm.CLabel as CLabel
  import GHC.Cmm.InitFini
  import GHC.Cmm.DebugBlock (pprUnwindTable)
@@ -96,10 +96,16 @@ pprNatCmmDecl config proc@(CmmProc top_info entry_lbl _ (ListGraph blocks)) =
+           )
          | otherwise = (empty,empty)
 +      section = if platformOS platform == OSMinGW32
 +                  && externallyVisibleCLabel proc_lbl
 +                  && isSRTInfoLabel proc_lbl
 +                then ReadOnlyData
 +                else Text
++
    in vcat
      [ -- section directive. Requires proc_lbl when split-section is enabled to
        -- use as a subsection name.
 -      pprSectionAlign config (Section Text proc_lbl)
 +      pprSectionAlign config (Section section proc_lbl)
        -- section alignment. Note that when there is an info table, we align the
        -- info table and not the entry code!

hadrian/src/Rules/Generate.hs

@@ -377,7 +377,6 @@ templateRules = do
      , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1
      , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2
+     ]
 -  templateRule "rts/win32/libHSghc-internal.def" projectVersion
    templateRule "docs/index.html" $ packageUnitIds Stage1
    templateRule "docs/users_guide/ghc_config.py" $ mconcat
      [ projectVersion

hadrian/src/Rules/Library.hs

@@ -9,6 +9,7 @@ import GHC.Toolchain.Target (Target(tgtArchOs))
  import Base
  import Context
 +import qualified Data.List as List
  import Expression hiding (way, package, stage)
  import Oracles.ModuleFiles
  import Packages
@@ -20,6 +21,7 @@ import Utilities
  import Data.Time.Clock
  import Rules.Generate (generatedDependencies)
  import Oracles.Flag
 +import Way.Type (wayToUnits)
  -- * Library 'Rules'
@@ -203,13 +205,32 @@ extraObjects context
      | package context == rts = do
            target   <- interpretInContext context getStagedTarget
 -          builddir <- buildPath context
 -          return [ builddir -/- "libHSghc-internal.dll.a"
 -                 | archOS_OS (tgtArchOs target) == OSMinGW32
 -                 , Dynamic `wayUnit` way context ]
 +          if not (archOS_OS (tgtArchOs target) == OSMinGW32
 +                && Dynamic `wayUnit` way context)
 +          then return []
 +          else do
 +            -- Find the ghc-internal library file name. Note that the
 +            -- ghc-internal's .dll.a file is placed in the RTS build dir and not
 +            -- the ghc-internal build dir as we only use it when building the
 +            -- RTS and not other libraries.
 +            ghcInternalDllName <- takeFileName <$> pkgLibraryFile Context {
 +                    stage = stage context,
 +                    way = rtsWayToLibraryWay (way context),
 +                    iplace = iplace context,
 +                    package = ghcInternal
 +                }
++
 +            builddir <- buildPath context
 +            return [ builddir -/- ghcInternalDllName <> ".a"]
      | otherwise = return []
 +-- | The rts is compiled in many different ways, but libraries are only built in
 +-- (non)Dynamic and (non)Profiled ways. This function converts the rts way into
 +-- compatible library way.
 +rtsWayToLibraryWay :: Way -> Way
 +rtsWayToLibraryWay = wayFromUnits . List.intersect [Dynamic, Profiling] . wayToUnits
++
  -- | Return all the object files to be put into the library we're building for
  -- the given 'Context'.
  libraryObjects :: Context -> Action [FilePath]

hadrian/src/Rules/Rts.hs

@@ -13,11 +13,19 @@ rtsRules = priority 3 $ do
      -- to be linked into the rts dll.
      forM_ [Stage1, Stage2, Stage3 ] $ \ stage -> do
          let buildPath = root -/- buildDir (rtsContext stage)
 -        buildPath -/- "libHSghc-internal.dll.a" %> buildGhcInternalImportLib
 +        buildPath -/- "libHSghc-internal-*.def" %> buildGhcInternalImportDef
 +        buildPath -/- "libHSghc-internal-*.dll.a" %> buildGhcInternalImportLib
++
 +buildGhcInternalImportDef :: FilePath -> Action ()
 +buildGhcInternalImportDef target = do
 +    templateIn <- readFile' "rts/win32/libHSghc-internal.def.in"
 +    let dllName = takeFileName target -<.> "dll"
 +        templateOut = replace "@GhcInternalDll@" dllName templateIn
 +    writeFile' target templateOut
  buildGhcInternalImportLib :: FilePath -> Action ()
  buildGhcInternalImportLib target = do
 -    let input  = "rts/win32/libHSghc-internal.def"
 +    let input = dropExtension (dropExtension target) <.> "def" -- the .def file
          output = target -- the .dll.a import lib
      need [input]
      runBuilder Dlltool ["-d", input, "-l", output] [input] [output]

rts/win32/libHSghc-internal.def.in

 -LIBRARY libHSghc-internal-@ProjectVersionForLib@.0-ghc@ProjectVersion@.dll
 +LIBRARY @GhcInternalDll@
  EXPORTS
      init_ghc_hs_iface