[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Revert "Pass preprocessor options to C compiler when building foreign C files (#16737)"
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Oct 5 06:46:11 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
0d9f1761 by Matthew Pickering at 2023-10-05T02:44:47-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
- - - - -
077d25ef by Ben Gamari at 2023-10-05T02:44:48-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.
- - - - -
36b85b26 by Andreas Klebinger at 2023-10-05T02:44:49-04:00
Fix isAArch64Bitmask for 32bit immediates.
Fixes #23802
- - - - -
6edc3287 by Bryan Richter at 2023-10-05T02:44:49-04:00
Work around perf note fetch failure
Addresses #24055.
- - - - -
18cd5d3e by Krzysztof Gogolewski at 2023-10-05T02:44:49-04:00
Add a test for #21348
- - - - -
34f92752 by Rewbert at 2023-10-05T02:44:51-04:00
Fixes #24046
- - - - -
15 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/simplCore/should_compile/T21348.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/th/T24046.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/simplCore/should_compile/T21348.hs
=====================================
@@ -0,0 +1,97 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T21348 where
+
+import qualified Data.Map as M
+import Data.Kind (Type)
+
+newtype Parser a = Parser {
+ runParser :: () -> (a -> Int) -> Int
+ } deriving (Functor)
+
+instance Applicative Parser where
+ pure a = Parser $ \_path ks -> ks a
+ {-# INLINE pure #-}
+ (<*>) m e = Parser $ \path ks -> let ks' a = runParser (a <$> e) path ks
+ in runParser m path ks'
+ {-# INLINE (<*>) #-}
+
+data Value = Object (M.Map String Value) | Unused
+
+class FromJSON a where
+ parseJSON :: Value -> Parser a
+ _unused :: a -> a
+
+instance FromJSON Bool where
+ parseJSON _ = pure False
+ _unused = id
+
+data Pa a = MkPa Bool a
+
+class RecordFromJSON f where
+ recordParseJSON :: () -> M.Map String Value -> Parser (Pa f)
+
+class RecordFromJSON2 f where
+ recordParseJSON2 :: M.Map String Value -> Parser f
+
+instance (RecordFromJSON2 b) => RecordFromJSON b where
+ recordParseJSON _ obj = MkPa <$> pure False
+ <*> recordParseJSON2 obj
+ {-# INLINE recordParseJSON #-}
+
+instance (FromJSON a) => RecordFromJSON2 a where
+ recordParseJSON2 obj = pure () *> (id <$> (id <$> parseJSON (obj M.! "x")))
+ {-# INLINE recordParseJSON2 #-}
+
+data Rec :: [Type] -> Type where
+ RNil :: Rec '[]
+ RCons :: Field r -> Rec rs -> Rec (r ': rs)
+
+data Rec2 :: [Type] -> Type where
+ RNil2 :: Rec2 '[]
+ RCons2 :: DocField r -> Rec2 rs -> Rec2 (r ': rs)
+
+data Field x = Field x
+
+newtype DocField x = DocField (Field x)
+
+instance FromJSON (Rec '[]) where
+ parseJSON _ = undefined
+ _unused = id
+
+instance (FromJSON t, FromJSON (Rec rs)) => FromJSON (Rec (t ': rs)) where
+ parseJSON v = rebuild <$> parseJSON v <*> parseJSON v
+ where rebuild m rest = Field m `RCons` rest
+ _unused = id
+
+instance (RMap rs, FromJSON (Rec rs)) => FromJSON (Rec2 rs) where
+ parseJSON v = rmap DocField <$> parseJSON v
+ _unused = id
+
+class RMap rs where
+ rmap :: (forall x. Field x -> DocField x) -> Rec rs -> Rec2 rs
+
+instance RMap '[] where
+ rmap _ RNil = RNil2
+ {-# INLINE rmap #-}
+
+instance RMap xs => RMap (x ': xs) where
+ rmap f (x `RCons` xs) = f x `RCons2` rmap f xs
+ {-# INLINE rmap #-}
+
+g :: RecordFromJSON a => Value -> Parser (Pa a)
+g (Object r) = recordParseJSON () r
+g Unused = undefined
+
+bug :: Value -> Parser (Pa (Rec2 '[Bool, Bool, Bool, Bool]))
+bug = g
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -503,3 +503,4 @@ test('T23922a', normal, compile, ['-O'])
test('T23952', [extra_files(['T23952a.hs'])], multimod_compile, ['T23952', '-v0 -O'])
test('T24014', normal, compile, ['-dcore-lint'])
test('T24029', normal, compile, [''])
+test('T21348', normal, compile, ['-O'])
=====================================
testsuite/tests/th/T24046.hs
=====================================
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T24046 where
+
+import Language.Haskell.TH.Syntax
+
+-- Test added in relation to this issue: https://gitlab.haskell.org/ghc/ghc/-/issues/24046
+
+{-# NOINLINE foo #-}
+foo = undefined
+
+$( let simplerule = [PragmaD $ RuleP "rejected-rule" Nothing foralld lhs rhs AllPhases]
+
+ foralld = [RuleVar $ mkName "x", RuleVar $ mkName "y"]
+
+ lhs = AppE (AppE (VarE $ mkName "foo") (VarE $ mkName "x")) (VarE $ mkName "y")
+
+ rhs = AppE (AppE (VarE $ mkName "foo") (VarE $ mkName "y")) (VarE $ mkName "x")
+ in return simplerule)
=====================================
testsuite/tests/th/all.T
=====================================
@@ -146,6 +146,7 @@ test('T2817', normal, compile, ['-v0'])
test('T2713', normal, compile_fail, ['-v0'])
test('T2674', normal, compile_fail, ['-v0'])
test('TH_emptycase', normal, compile, ['-v0'])
+test('T24046', normal, compile, ['-v0'])
test('T2386', [only_ways(['normal'])], makefile_test, ['T2386'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b490351e2b98bf05ba6da6e29ae67b74e398b6ce...34f927525bdc679ac56f53993c7911bcf5f68832
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b490351e2b98bf05ba6da6e29ae67b74e398b6ce...34f927525bdc679ac56f53993c7911bcf5f68832
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/20231005/334bf0b5/attachment-0001.html>
More information about the ghc-commits
mailing list