[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Revert "Pass preprocessor options to C compiler when building foreign C files (#16737)"
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Oct 4 14:47:20 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
abfeaafd by Matthew Pickering at 2023-10-04T10:47:06-04:00
Revert "Pass preprocessor options to C compiler when building foreign C files (#16737)"
This reverts commit 1c18d3b41f897f34a93669edaebe6069f319f9e2.
`-optP` should pass options to the preprocessor, that might be a very
different program to the C compiler, so passing the options to the C
compiler is likely to result in `-optP` being useless.
Fixes #17185 and #21291
- - - - -
66ac5bf0 by John Ericson at 2023-10-04T10:47:06-04:00
Test that functions from `mingwex` are available
Ryan wrote these two minimizations, but they never got added to the test
suite.
See #23309, #23378
Co-Authored-By: Ben Gamari <bgamari.foss at gmail.com>
Co-Authored-By: Ryan Scott <ryan.gl.scott at gmail.com>
Apply 1 suggestion(s) to 1 file(s)
- - - - -
e4eea8aa by Ben Gamari at 2023-10-04T10:47:07-04:00
rts/nonmoving: Fix on LLP64 platforms
Previously `NONMOVING_SEGMENT_MASK` and friends were defined with the `UL`
size suffix. However, this is wrong on LLP64 platforms like Windows,
where `long` is 32-bits.
Fixes #23003.
Fixes #24042.
- - - - -
baa9d573 by Andreas Klebinger at 2023-10-04T10:47:08-04:00
Fix isAArch64Bitmask for 32bit immediates.
Fixes #23802
- - - - -
16522f85 by Bryan Richter at 2023-10-04T10:47:08-04:00
Work around perf note fetch failure
Addresses #24055.
- - - - -
19 changed files:
- .gitlab/test-metrics.sh
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- driver/ghci/ghci-wrapper.cabal.in
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Settings/Packages.hs
- rts/sm/NonMoving.h
- − testsuite/tests/driver/T16737.hs
- − testsuite/tests/driver/T16737.stdout
- − testsuite/tests/driver/T16737include/T16737.h
- testsuite/tests/driver/all.T
- + testsuite/tests/th/T23309.c
- + testsuite/tests/th/T23309.hs
- + testsuite/tests/th/T23309.stderr
- + testsuite/tests/th/T23309A.hs
- + testsuite/tests/th/T23378.hs
- + testsuite/tests/th/T23378.stderr
- + testsuite/tests/th/T23378A.hs
- testsuite/tests/th/all.T
Changes:
=====================================
.gitlab/test-metrics.sh
=====================================
@@ -17,7 +17,12 @@ fail() {
function pull() {
local ref="refs/notes/$REF"
- run git fetch -f "$NOTES_ORIGIN" "$ref:$ref"
+ # 2023-10-04: `git fetch` started failing, first on Darwin in CI and then on
+ # Linux locally, both using git version 2.40.1. See #24055. One workaround is
+ # to set a larger http.postBuffer, although this is definitely a workaround.
+ # The default should work just fine. The error could be in git, GitLab, or
+ # perhaps the networking tube (including all proxies etc) between the two.
+ run git -c http.postBuffer=2097152 fetch -f "$NOTES_ORIGIN" "$ref:$ref"
echo "perf notes ref $ref is $(git rev-parse $ref)"
}
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -781,12 +781,12 @@ getRegister' config plat expr
return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
-- 3. Logic &&, ||
- CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) ->
+ CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) ->
return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
where w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
r' = getRegisterReg plat reg
- CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) ->
+ CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) ->
return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
where w' = formatToWidth (cmmTypeFormat (cmmRegType reg))
r' = getRegisterReg plat reg
@@ -1070,13 +1070,16 @@ getRegister' config plat expr
-- | Is a given number encodable as a bitmask immediate?
--
-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly
-isAArch64Bitmask :: Integer -> Bool
+isAArch64Bitmask :: Width -> Integer -> Bool
-- N.B. zero and ~0 are not encodable as bitmask immediates
-isAArch64Bitmask 0 = False
-isAArch64Bitmask n
- | n == bit 64 - 1 = False
-isAArch64Bitmask n =
- check 64 || check 32 || check 16 || check 8
+isAArch64Bitmask width n =
+ assert (width `elem` [W32,W64]) $
+ case n of
+ 0 -> False
+ _ | n == bit (widthInBits width) - 1
+ -> False -- 1111...1111
+ | otherwise
+ -> (width == W64 && check 64) || check 32 || check 16 || check 8
where
-- Check whether @n@ can be represented as a subpattern of the given
-- width.
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -411,19 +411,6 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
includePathsQuoteImplicit cmdline_include_paths)
let include_paths = include_paths_quote ++ include_paths_global
- -- pass -D or -optP to preprocessor when compiling foreign C files
- -- (#16737). Doing it in this way is simpler and also enable the C
- -- compiler to perform preprocessing and parsing in a single pass,
- -- but it may introduce inconsistency if a different pgm_P is specified.
- let opts = getOpts dflags opt_P
- aug_imports = augmentImports dflags opts
-
- more_preprocessor_opts = concat
- [ ["-Xpreprocessor", i]
- | not hcc
- , i <- aug_imports
- ]
-
let gcc_extra_viac_flags = extraGccViaCFlags dflags
let pic_c_flags = picCCOpts dflags
@@ -512,7 +499,6 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
++ [ "-include", ghcVersionH ]
++ framework_paths
++ include_paths
- ++ more_preprocessor_opts
++ pkg_extra_cc_opts
))
=====================================
driver/ghci/ghci-wrapper.cabal.in
=====================================
@@ -29,4 +29,4 @@ Executable ghci
-- We need to call the versioned ghc executable because the unversioned
-- GHC executable is a wrapper that doesn't call FreeConsole and so
-- breaks an interactive process like GHCi. See #21889, #14150 and #13411
- CPP-Options: -DEXE_PATH="ghc- at ProjectVersion@"
+ cc-options: -DEXE_PATH="ghc- at ProjectVersion@"
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -515,8 +515,8 @@ createVersionWrapper pkg versioned_exe install_path = do
| otherwise = 0
cmd ghcPath (["-no-hs-main", "-o", install_path, "-I"++version_wrapper_dir
- , "-DEXE_PATH=\"" ++ versioned_exe ++ "\""
- , "-DINTERACTIVE_PROCESS=" ++ show interactive
+ , "-optc-DEXE_PATH=\"" ++ versioned_exe ++ "\""
+ , "-optc-DINTERACTIVE_PROCESS=" ++ show interactive
] ++ wrapper_files)
{-
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -297,14 +297,11 @@ rtsPackageArgs = package rts ? do
libzstdIncludeDir <- getSetting LibZstdIncludeDir
libzstdLibraryDir <- getSetting LibZstdLibDir
+
-- Arguments passed to GHC when compiling C and .cmm sources.
let ghcArgs = mconcat
[ arg "-Irts"
, arg $ "-I" ++ path
- , arg $ "-DRtsWay=\"rts_" ++ show way ++ "\""
- -- Set the namespace for the rts fs functions
- , arg $ "-DFS_NAMESPACE=rts"
- , arg $ "-DCOMPILING_RTS"
, notM targetSupportsSMP ? arg "-DNOSMP"
, way `elem` [debug, debugDynamic] ? pure [ "-DTICKY_TICKY"
, "-optc-DTICKY_TICKY"]
@@ -333,9 +330,16 @@ rtsPackageArgs = package rts ? do
, "-fno-omit-frame-pointer"
, "-g3"
, "-O0" ]
+ -- Set the namespace for the rts fs functions
+ , arg $ "-DFS_NAMESPACE=rts"
+
+ , arg $ "-DCOMPILING_RTS"
, inputs ["**/RtsMessages.c", "**/Trace.c"] ?
- arg ("-DProjectVersion=" ++ show projectVersion)
+ pure
+ ["-DProjectVersion=" ++ show projectVersion
+ , "-DRtsWay=\"rts_" ++ show way ++ "\""
+ ]
, input "**/RtsUtils.c" ? pure
[ "-DProjectVersion=" ++ show projectVersion
@@ -353,6 +357,7 @@ rtsPackageArgs = package rts ? do
, "-DTargetVendor=" ++ show targetVendor
, "-DGhcUnregisterised=" ++ show ghcUnreg
, "-DTablesNextToCode=" ++ show ghcEnableTNC
+ , "-DRtsWay=\"rts_" ++ show way ++ "\""
]
-- We're after pur performance here. So make sure fast math and
=====================================
rts/sm/NonMoving.h
=====================================
@@ -17,13 +17,13 @@
#include "BeginPrivate.h"
// Segments
-#define NONMOVING_SEGMENT_BITS 15UL // 2^15 = 32kByte
+#define NONMOVING_SEGMENT_BITS 15ULL // 2^15 = 32kByte
// Mask to find base of segment
-#define NONMOVING_SEGMENT_MASK ((1UL << NONMOVING_SEGMENT_BITS) - 1)
+#define NONMOVING_SEGMENT_MASK (((uintptr_t)1 << NONMOVING_SEGMENT_BITS) - 1)
// In bytes
-#define NONMOVING_SEGMENT_SIZE (1UL << NONMOVING_SEGMENT_BITS)
+#define NONMOVING_SEGMENT_SIZE ((uintptr_t)1 << NONMOVING_SEGMENT_BITS)
// In words
-#define NONMOVING_SEGMENT_SIZE_W ((1UL << NONMOVING_SEGMENT_BITS) / SIZEOF_VOID_P)
+#define NONMOVING_SEGMENT_SIZE_W (((uintptr_t)1 << NONMOVING_SEGMENT_BITS) / SIZEOF_VOID_P)
// In blocks
#define NONMOVING_SEGMENT_BLOCKS (NONMOVING_SEGMENT_SIZE / BLOCK_SIZE)
=====================================
testsuite/tests/driver/T16737.hs deleted
=====================================
@@ -1,32 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# OPTIONS_GHC -DFOO=2 -optP=-DBAR=3 -optc=-DBAZ=5 -optcxx=-DBAZ=7 #-}
-
-import Language.Haskell.TH.Syntax
-
-do
- let code = unlines
- [ "#if defined(__cplusplus)"
- , "extern \"C\" {"
- , "#endif"
- , "#include <T16737.h>"
- , "int FUN(void) {"
- , " return FOO * BAR * BAZ;"
- , "}"
- , "#if defined(__cplusplus)"
- , "}"
- , "#endif"
- ]
- addForeignSource LangC code
- addForeignSource LangCxx code
- pure []
-
-foreign import ccall unsafe "c_value"
- c_value :: IO Int
-
-foreign import ccall unsafe "cxx_value"
- cxx_value :: IO Int
-
-main :: IO ()
-main = do
- print =<< c_value
- print =<< cxx_value
=====================================
testsuite/tests/driver/T16737.stdout deleted
=====================================
@@ -1,2 +0,0 @@
-30
-42
=====================================
testsuite/tests/driver/T16737include/T16737.h deleted
=====================================
@@ -1,7 +0,0 @@
-#pragma once
-
-#if defined(__cplusplus)
-#define FUN cxx_value
-#else
-#define FUN c_value
-#endif
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -285,12 +285,6 @@ test('inline-check', [omit_ways(['hpc', 'profasm'])]
test('T14452', js_broken(22261), makefile_test, [])
test('T14923', normal, makefile_test, [])
test('T15396', normal, compile_and_run, ['-package ghc'])
-test('T16737',
- [extra_files(['T16737include/']),
- req_th,
- req_c,
- expect_broken_for(16541, ghci_ways)],
- compile_and_run, ['-optP=-isystem -optP=T16737include'])
test('T17143', exit_code(1), run_command, ['{compiler} T17143.hs -S -fno-code'])
test('T17786', unless(opsys('mingw32'), skip), makefile_test, [])
=====================================
testsuite/tests/th/T23309.c
=====================================
@@ -0,0 +1,8 @@
+#define _GNU_SOURCE 1
+#include <stdio.h>
+
+const char* foo(int e) {
+ static char s[256];
+ sprintf(s, "The value of e is: %u", e);
+ return s;
+}
=====================================
testsuite/tests/th/T23309.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T23309 where
+
+import Foreign.C.String
+import Language.Haskell.TH
+import System.IO
+
+import T23309A
+
+$(do runIO $ do
+ cstr <- c_foo 42
+ str <- peekCString cstr
+ hPutStrLn stderr str
+ hFlush stderr
+ return [])
=====================================
testsuite/tests/th/T23309.stderr
=====================================
@@ -0,0 +1 @@
+The value of e is: 42
=====================================
testsuite/tests/th/T23309A.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP #-}
+module T23309A (c_foo) where
+
+import Foreign.C.String
+import Foreign.C.Types
+
+#if defined(mingw32_HOST_OS)
+# if defined(i386_HOST_ARCH)
+# define CALLCONV stdcall
+# elif defined(x86_64_HOST_ARCH)
+# define CALLCONV ccall
+# else
+# error Unknown mingw32 arch
+# endif
+#else
+# define CALLCONV ccall
+#endif
+
+foreign import CALLCONV unsafe "foo" c_foo :: CInt -> IO CString
=====================================
testsuite/tests/th/T23378.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T23378 where
+
+import Foreign.C.String
+import Language.Haskell.TH
+import System.IO
+
+import T23378A
+
+$(do runIO $ do
+ hPrint stderr isatty
+ hFlush stderr
+ return [])
=====================================
testsuite/tests/th/T23378.stderr
=====================================
@@ -0,0 +1 @@
+False
=====================================
testsuite/tests/th/T23378A.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP #-}
+module T23378A where
+
+import Foreign.C.Types
+import System.IO.Unsafe
+
+isatty :: Bool
+isatty =
+ unsafePerformIO (c_isatty 1) == 1
+{-# NOINLINE isatty #-}
+
+#if defined(mingw32_HOST_OS)
+# define SYM "_isatty"
+#else
+# define SYM "isatty"
+#endif
+
+foreign import ccall unsafe SYM
+ c_isatty :: CInt -> IO CInt
=====================================
testsuite/tests/th/all.T
=====================================
@@ -589,6 +589,8 @@ test('T23829_hasty', normal, compile_fail, [''])
test('T23829_hasty_b', normal, compile_fail, [''])
test('T23927', normal, compile_and_run, [''])
test('T23954', normal, compile_and_run, [''])
+test('T23309', [extra_files(['T23309A.hs']), req_c], multimod_compile, ['T23309', '-v0 T23309.c -optc-fPIC'])
+test('T23378', [extra_files(['T23378A.hs'])], multimod_compile, ['T23378', '-v0'])
test('T23962', normal, compile_and_run, [''])
test('T23968', normal, compile_and_run, [''])
test('T23971', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c41ad4f65ed12a1a1a519f2fc9a4d0c2e8400db...16522f85e1264718fd7f4902d5abaea3cd78c492
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c41ad4f65ed12a1a1a519f2fc9a4d0c2e8400db...16522f85e1264718fd7f4902d5abaea3cd78c492
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231004/459c3044/attachment-0001.html>
More information about the ghc-commits
mailing list