diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -2599,7 +2599,7 @@ dst_off <- assignTempE dst_off0 -- Nonmoving collector write barrier - emitCopyUpdRemSetPush dflags (arrPtrsHdrSizeW dflags) dst dst_off n + emitCopyUpdRemSetPush dflags (arrPtrsHdrSize dflags) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) @@ -2664,7 +2664,7 @@ dst <- assignTempE dst0 -- Nonmoving collector write barrier - emitCopyUpdRemSetPush dflags (smallArrPtrsHdrSizeW dflags) dst dst_off n + emitCopyUpdRemSetPush dflags (smallArrPtrsHdrSize dflags) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) @@ -2987,7 +2987,7 @@ -- | Push a range of pointer-array elements that are about to be copied over to -- the update remembered set. emitCopyUpdRemSetPush :: DynFlags - -> WordOff -- ^ array header size + -> ByteOff -- ^ array header size (in bytes) -> CmmExpr -- ^ destination array -> CmmExpr -- ^ offset in destination array (in words) -> Int -- ^ number of elements to copy diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -914,7 +914,7 @@ concatMap (\l -> [ Option ("-l" ++ l) ]) (nub $ snd <$> temp_sos) ++ concatMap (\lp -> Option ("-L" ++ lp) - : if gopt Opt_RPath dflags + : if useXLinkerRPath dflags (platformOS platform) then [ Option "-Xlinker" , Option "-rpath" , Option "-Xlinker" @@ -923,7 +923,7 @@ (nub $ fst <$> temp_sos) ++ concatMap (\lp -> Option ("-L" ++ lp) - : if gopt Opt_RPath dflags + : if useXLinkerRPath dflags (platformOS platform) then [ Option "-Xlinker" , Option "-rpath" , Option "-Xlinker" diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -268,7 +268,7 @@ where ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty - ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args + ppValues = ppCallParams (map snd params) args ppArgTy = (ppCommaJoin $ map fst params) <> (case argTy of VarArgs -> text ", ..." @@ -279,10 +279,13 @@ <> fnty <+> ppName fptr <> lparen <+> ppValues <+> rparen <+> attrDoc - -- Metadata needs to be marked as having the `metadata` type when used - -- in a call argument - ppCallMetaExpr (MetaVar v) = ppr v - ppCallMetaExpr v = text "metadata" <+> ppr v + ppCallParams :: [[LlvmParamAttr]] -> [MetaExpr] -> SDoc + ppCallParams attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args + where + -- Metadata needs to be marked as having the `metadata` type when used + -- in a call argument + ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs v + ppCallMetaExpr _ v = text "metadata" <+> ppr v ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc ppMachOp op left right = diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -114,10 +114,14 @@ deriving (Eq) instance Outputable LlvmVar where - ppr (LMLitVar x) = ppr x - ppr (x ) = ppr (getVarType x) <+> ppName x + ppr = ppVar' [] +ppVar' :: [LlvmParamAttr] -> LlvmVar -> SDoc +ppVar' attrs v = case v of + LMLitVar x -> ppTypeLit' attrs x + x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName x + -- | Llvm Literal Data. -- -- These can be used inline in expressions. @@ -135,8 +139,12 @@ deriving (Eq) instance Outputable LlvmLit where - ppr l@(LMVectorLit {}) = ppLit l - ppr l = ppr (getLitType l) <+> ppLit l + ppr = ppTypeLit' [] + +ppTypeLit' :: [LlvmParamAttr] -> LlvmLit -> SDoc +ppTypeLit' attrs l = case l of + l@(LMVectorLit {}) -> ppLit l + _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit l -- | Llvm Static Data. diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -58,8 +58,8 @@ let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $ "You are using an unsupported version of LLVM!" $$ - "Currently only" <+> text (llvmVersionStr supportedLlvmVersionMin) <+> - "to" <+> text (llvmVersionStr supportedLlvmVersionMax) <+> "is supported." <+> + "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+> + "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..." let isS390X = platformArch (targetPlatform dflags) == ArchS390X @@ -72,7 +72,7 @@ -- currently don't use the LLVM version to guide code generation -- so this is okay. let llvm_ver :: LlvmVersion - llvm_ver = fromMaybe supportedLlvmVersionMin mb_ver + llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver -- run code generation a <- runLlvm dflags llvm_ver bufh $ diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -14,7 +14,7 @@ LlvmUnresData, LlvmData, UnresLabel, UnresStatic, LlvmVersion, llvmVersionSupported, parseLlvmVersion, - supportedLlvmVersionMin, supportedLlvmVersionMax, + supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, llvmVersionList, LlvmM, @@ -267,7 +267,6 @@ -- * Llvm Version -- --- Newtype to avoid using the Eq instance! newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } deriving (Eq, Ord) @@ -285,14 +284,17 @@ where (ver_str, rest) = span isDigit s --- | The LLVM Version that is currently supported. -supportedLlvmVersionMin, supportedLlvmVersionMax :: LlvmVersion -supportedLlvmVersionMin = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) -supportedLlvmVersionMax = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) +-- | The (inclusive) lower bound on the LLVM Version that is currently supported. +supportedLlvmVersionLowerBound :: LlvmVersion +supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) +-- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. +supportedLlvmVersionUpperBound :: LlvmVersion +supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) + llvmVersionSupported :: LlvmVersion -> Bool llvmVersionSupported v = - v > supportedLlvmVersionMin && v <= supportedLlvmVersionMax + v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound llvmVersionStr :: LlvmVersion -> String llvmVersionStr = intercalate "." . map show . llvmVersionList diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -460,6 +460,12 @@ The native code generator only handles StdCall and CCallConv. -} + let arg_type (hint, expr) = + case expr of + ty@(LMInt n) | n < 64 && lmconv == CC_Ccc && platformCConvNeedsExtension platform + -> (ty, if hint == Signed then [SignExt] else [ZeroExt]) + ty -> (ty, []) + -- call attributes let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs | otherwise = llvmStdFunAttrs @@ -477,7 +483,7 @@ let retTyCmm = ret_type_cmm ress_hints - let argTy = tysToParams $ map (snd . primRepToLlvmTy) args_rep + let argTy = map arg_type $ map primRepToLlvmTy args_rep let retTy = snd $ primRepToLlvmTy ret_rep let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy (llvmFunAlign dflags) @@ -524,6 +530,15 @@ v2 <- doExprW ty $ Cast op v1 ty statement $ Store v2 vreg doReturn + where + -- | For some architectures the C calling convention is that any + -- integer shorter than 64 bits is replaced by its 64 bits + -- representation using sign or zero extension. + platformCConvNeedsExtension :: Platform -> Bool + platformCConvNeedsExtension platform = case platformArch platform of + ArchPPC_64 _ -> True + ArchS390X -> True + _ -> False -- | Generate a call to an LLVM intrinsic that performs arithmetic operation -- with overflow bit (i.e., returns a struct containing the actual result of the diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1731,7 +1731,7 @@ (l `makeRelativeTo` full_output_fn) else l -- See Note [-Xlinker -rpath vs -Wl,-rpath] - rpath = if gopt Opt_RPath dflags + rpath = if useXLinkerRPath dflags (platformOS platform) then ["-Xlinker", "-rpath", "-Xlinker", libpath] else [] -- Solaris 11's linker does not support -rpath-link option. It silently @@ -1747,7 +1747,7 @@ | osMachOTarget (platformOS platform) && dynLibLoader dflags == SystemDependent && WayDyn `elem` ways dflags && - gopt Opt_RPath dflags + useXLinkerRPath dflags (platformOS platform) = let libpath = if gopt Opt_RelativeDynlibPaths dflags then "@loader_path" (l `makeRelativeTo` full_output_fn) diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -248,6 +248,8 @@ pkgs <- getPreloadPackagesAnd dflags dep_packages + let platform = targetPlatform dflags + os = platformOS platform let pkg_lib_paths = collectLibraryPaths dflags pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l @@ -257,7 +259,7 @@ -- Only if we want dynamic libraries WayDyn `elem` ways dflags && -- Only use RPath if we explicitly asked for it - gopt Opt_RPath dflags + useXLinkerRPath dflags os = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] -- See Note [-Xlinker -rpath vs -Wl,-rpath] | otherwise = ["-L" ++ l] @@ -272,9 +274,7 @@ -- not allow undefined symbols. -- The RTS library path is still added to the library search path -- above in case the RTS is being explicitly linked in (see #3807). - let platform = targetPlatform dflags - os = platformOS platform - pkgs_no_rts = case os of + let pkgs_no_rts = case os of OSMinGW32 -> pkgs _ -> diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -18,19 +18,22 @@ import Util import Data.List +import Data.Char +import Data.Maybe import System.IO import System.Process import GhcPrelude -import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionMin, supportedLlvmVersionMax, llvmVersionStr, parseLlvmVersion) +import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion) import SysTools.Process import SysTools.Info -import Control.Monad (join, forM, filterM) +import Control.Monad (join, forM, filterM, void) import System.Directory (doesFileExist) import System.FilePath (()) +import Text.ParserCombinators.ReadP as Parser {- ************************************************************************ @@ -236,10 +239,11 @@ errorMsg dflags $ vcat [ text "Warning:", nest 9 $ text "Couldn't figure out LLVM version!" $$ - text ("Make sure you have installed LLVM between " - ++ llvmVersionStr supportedLlvmVersionMin + text ("Make sure you have installed LLVM between [" + ++ llvmVersionStr supportedLlvmVersionLowerBound ++ " and " - ++ llvmVersionStr supportedLlvmVersionMax) ] + ++ llvmVersionStr supportedLlvmVersionUpperBound + ++ ")") ] return Nothing) @@ -260,15 +264,15 @@ -- -- See Note [Dynamic linking on macOS] runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO () +runInjectRPaths dflags _ _ | not (gopt Opt_RPath dflags) = return () runInjectRPaths dflags lib_paths dylib = do info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib] -- filter the output for only the libraries. And then drop the @rpath prefix. let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info -- find any pre-existing LC_PATH items - info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib] - let paths = concatMap f info - where f ("path":p:_) = [p] - f _ = [] + info <- lines <$> askOtool dflags Nothing [Option "-l", Option dylib] + + let paths = mapMaybe get_rpath info lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ] -- only find those rpaths, that aren't already in the library. rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l f)) lib_paths') @@ -277,6 +281,24 @@ [] -> return () _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] +get_rpath :: String -> Maybe FilePath +get_rpath l = case readP_to_S rpath_parser l of + [(rpath, "")] -> Just rpath + _ -> Nothing + + +rpath_parser :: ReadP FilePath +rpath_parser = do + skipSpaces + void $ string "path" + void $ many1 (satisfy isSpace) + rpath <- many get + void $ many1 (satisfy isSpace) + void $ string "(offset " + void $ munch1 isDigit + void $ Parser.char ')' + skipSpaces + return rpath runLink :: DynFlags -> [Option] -> IO () runLink dflags args = traceToolCommand dflags "linker" $ do diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 8.10.5.20210606 +version: 8.10.6.20210814 license: BSD3 license-file: LICENSE category: Development @@ -39,7 +39,6 @@ ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl - includes/ghcconfig.h includes/MachDeps.h includes/stg/MachRegs.h includes/CodeGen.Platform.hs @@ -65,7 +64,6 @@ else build-depends: Win32 build-depends: - rts, ghc-prim > 0.2 && < 0.8, base >= 4.12 && < 4.16, containers >= 0.5 && < 0.7, @@ -79,8 +77,9 @@ time >= 1.4 && < 1.10, transformers == 0.5.*, process >= 1 && < 1.7, + rts, hpc == 0.6.*, - ghc-lib-parser == 8.10.5.20210606 + ghc-lib-parser == 8.10.6.20210814 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns diff --git a/ghc-lib/stage0/lib/ghcautoconf.h b/ghc-lib/stage0/lib/ghcautoconf.h --- a/ghc-lib/stage0/lib/ghcautoconf.h +++ b/ghc-lib/stage0/lib/ghcautoconf.h @@ -598,10 +598,10 @@ /* #undef pid_t */ /* The maximum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MAX (12) +#define sUPPORTED_LLVM_VERSION_MAX (13) /* The minimum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MIN (10) +#define sUPPORTED_LLVM_VERSION_MIN (9) /* Define to `unsigned int' if does not define. */ /* #undef size_t */ diff --git a/includes/ghcconfig.h b/includes/ghcconfig.h deleted file mode 100644 --- a/includes/ghcconfig.h +++ /dev/null @@ -1,4 +0,0 @@ -#pragma once - -#include "ghcautoconf.h" -#include "ghcplatform.h"