[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 18:28:32 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
bb407a32 by Matthew Pickering at 2023-10-04T14:27:43-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

- - - - -
d1d3455b by John Ericson at 2023-10-04T14:27:44-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)

- - - - -
8271cc80 by Ben Gamari at 2023-10-04T14:27:44-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.

- - - - -
c90e5890 by Andreas Klebinger at 2023-10-04T14:27:45-04:00
Fix isAArch64Bitmask for 32bit immediates.

Fixes #23802

- - - - -
b490351e by Bryan Richter at 2023-10-04T14:27:45-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/16522f85e1264718fd7f4902d5abaea3cd78c492...b490351e2b98bf05ba6da6e29ae67b74e398b6ce

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/16522f85e1264718fd7f4902d5abaea3cd78c492...b490351e2b98bf05ba6da6e29ae67b74e398b6ce
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/4c11094c/attachment-0001.html>


More information about the ghc-commits mailing list