Duncan Coutts pushed to branch wip/dcoutts/windows-dlls at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • hadrian/src/Oracles/Flag.hs
    ... ... @@ -92,11 +92,10 @@ arSupportsAtFile stage = Toolchain.arSupportsAtFile . tgtAr <$> targetStage stag
    92 92 
     platformSupportsSharedLibs :: Action Bool
    93 93 
     -- FIXME: This is querying about the target but is named "platformXXX", targetSupportsSharedLibs would be better
    94 94 
     platformSupportsSharedLibs = do
    95 
    -    windows       <- isWinTarget
    96 95 
         ppc_linux     <- (&&) <$> anyTargetArch [ ArchPPC ] <*> anyTargetOs [ OSLinux ]
    97 96 
         solaris       <- (&&) <$> anyTargetArch [ ArchX86 ] <*> anyTargetOs [ OSSolaris2 ]
    98 97 
         javascript    <- anyTargetArch     [ ArchJavaScript ]
    99 
    -    return $ not (windows || javascript || ppc_linux || solaris)
    98 
    +    return $ not (javascript || ppc_linux || solaris)
    100 99
    101 100 
     -- | Does the target support threaded RTS?
    102 101 
     targetSupportsThreadedRts :: Action Bool

  • hadrian/src/Rules/Register.hs
    ... ... @@ -14,7 +14,6 @@ import Hadrian.Expression
    14 14 
     import Hadrian.Haskell.Cabal
    15 15 
     import Oracles.Flag (platformSupportsGhciObjects)
    16 16 
     import Packages
    17 
    -import Rules.Rts
    18 17 
     import Settings
    19 18 
     import Target
    20 19 
     import Utilities
    ... ... @@ -91,14 +90,9 @@ parseToBuildSubdirectory root = do
    91 90 
     -- * Registering
    92 91
    93 92 
     registerPackages :: [Context] -> Action ()
    94 
    -registerPackages ctxs = do
    93 
    +registerPackages ctxs =
    95 94 
         need =<< mapM pkgRegisteredLibraryFile ctxs
    96 95
    97 
    -    -- Dynamic RTS library files need symlinks (Rules.Rts.rtsRules).
    98 
    -    forM_ ctxs $ \ ctx -> when (package ctx == rts) $ do
    99 
    -        ways <- interpretInContext ctx (getLibraryWays <> getRtsWays)
    100 
    -        needRtsSymLinks (stage ctx) ways
    101 
    -
    102 96 
     -- | Register a package and initialise the corresponding package database if
    103 97 
     -- need be. Note that we only register packages in 'Stage0' and 'Stage1'.
    104 98 
     registerPackageRules :: [(Resource, Int)] -> Stage -> Inplace -> Rules ()

  • hadrian/src/Rules/Rts.hs
    1 
    -{-# LANGUAGE MultiWayIf #-}
    1 
    +module Rules.Rts (rtsRules) where
    2 2
    3 
    -module Rules.Rts (rtsRules, needRtsSymLinks) where
    4 
    -
    5 
    -import qualified Data.Set as Set
    6 
    -
    7 
    -import Packages (rts)
    8 3 
     import Hadrian.Utilities
    9 4 
     import Settings.Builders.Common
    10 5
    ... ... @@ -12,17 +7,7 @@ import Settings.Builders.Common
    12 7 
     -- library files (see Rules.Library.libraryRules).
    13 8 
     rtsRules :: Rules ()
    14 9 
     rtsRules = priority 3 $ do
    15 
    -    -- Dynamic RTS library files need symlinks without the dummy version number.
    16 
    -    -- This is for backwards compatibility (the old make build system omitted the
    17 
    -    -- dummy version number).
    18 10 
         root <- buildRootRules
    19 
    -    [ root -/- "**/libHSrts_*-ghc*.so",
    20 
    -      root -/- "**/libHSrts_*-ghc*.dylib",
    21 
    -      root -/- "**/libHSrts-ghc*.so",
    22 
    -      root -/- "**/libHSrts-ghc*.dylib"]
    23 
    -      |%> \ rtsLibFilePath' -> createFileLink
    24 
    -            (addRtsDummyVersion $ takeFileName rtsLibFilePath')
    25 
    -            rtsLibFilePath'
    26 11 
         -- An import lib for the ghc-internal dll, to be linked into the rts dll.
    27 12 
         forM_ [Stage1, Stage2, Stage3] $ \stage -> do
    28 13 
             let buildPath = root -/- buildDir (rtsContext stage)
    ... ... @@ -36,35 +21,3 @@ buildGhcInternalImportLib target = do
    36 21 
             output = target -- the .dll.a import lib
    37 22 
         need [input]
    38 23 
         runBuilder Dlltool ["-d", input, "-l", output] [input] [output]
    39 
    -
    40 
    --- Need symlinks generated by rtsRules.
    41 
    -needRtsSymLinks :: Stage -> Set.Set Way -> Action ()
    42 
    -needRtsSymLinks stage rtsWays
    43 
    -    = forM_ (Set.filter (wayUnit Dynamic) rtsWays) $ \ way -> do
    44 
    -        let ctx = Context stage rts way Final
    45 
    -        distDir     <- distDynDir ctx
    46 
    -        rtsLibFile  <- takeFileName <$> pkgLibraryFile ctx
    47 
    -        need [removeRtsDummyVersion (distDir </> rtsLibFile)]
    48 
    -
    49 
    -prefix, versionlessPrefix :: String
    50 
    -versionlessPrefix = "libHSrts"
    51 
    -prefix = versionlessPrefix ++ "-1.0.3"
    52 
    -
    53 
    --- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so"
    54 
    ---                    == "a/libHSrts-ghc1.2.3.4.so"
    55 
    -removeRtsDummyVersion :: FilePath -> FilePath
    56 
    -removeRtsDummyVersion = replaceLibFilePrefix prefix versionlessPrefix
    57 
    -
    58 
    --- addRtsDummyVersion "a/libHSrts-ghc1.2.3.4.so"
    59 
    ---                 == "a/libHSrts-1.0-ghc1.2.3.4.so"
    60 
    -addRtsDummyVersion :: FilePath -> FilePath
    61 
    -addRtsDummyVersion = replaceLibFilePrefix versionlessPrefix prefix
    62 
    -
    63 
    -replaceLibFilePrefix :: String -> String -> FilePath -> FilePath
    64 
    -replaceLibFilePrefix oldPrefix newPrefix oldFilePath = let
    65 
    -    oldFileName = takeFileName oldFilePath
    66 
    -    newFileName = maybe
    67 
    -        (error $ "Expected RTS library file to start with " ++ oldPrefix)
    68 
    -        (newPrefix ++)
    69 
    -        (stripPrefix oldPrefix oldFileName)
    70 
    -    in replaceFileName oldFilePath newFileName

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help