[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Substitute bindist files with Hadrian not configure
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon May 6 17:44:46 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
adba68e7 by John Ericson at 2024-05-05T19:35:56-04:00
Substitute bindist files with Hadrian not configure
The `ghc-toolchain` overhaul will eventually replace all this stuff with
something much more cleaned up, but I think it is still worth making
this sort of cleanup in the meantime so other untanglings and dead code
cleaning can procede.
I was able to delete a fair amount of dead code doing this too.
`LLVMTarget_CPP` is renamed to / merged with `LLVMTarget` because it
wasn't actually turned into a valid CPP identifier. (Original to
1345c7cc42c45e63ab1726a8fd24a7e4d4222467, actually.)
Progress on #23966
Co-Authored-By: Sylvain Henry <hsyl20 at gmail.com>
- - - - -
18f4ff84 by Alan Zimmerman at 2024-05-05T19:36:32-04:00
EPA: fix mkHsOpTyPV duplicating comments
Closes #24753
- - - - -
ed4adb41 by Matthew Craven at 2024-05-06T13:44:21-04:00
Add test cases for #24664
...since none are present in the original MR !12463 fixing this issue.
- - - - -
e4644bcb by Alan Zimmerman at 2024-05-06T13:44:21-04:00
EPA: preserve comments in data decls
Closes #24771
- - - - -
21 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/Generate.hs
- mk/project.mk.in
- + testsuite/tests/codeGen/should_run/T24664a.hs
- + testsuite/tests/codeGen/should_run/T24664a.stdout
- + testsuite/tests/codeGen/should_run/T24664b.hs
- + testsuite/tests/codeGen/should_run/T24664b.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test24753.hs
- testsuite/tests/printer/Test24755.hs
- + testsuite/tests/printer/Test24771.hs
- testsuite/tests/printer/all.T
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2486,9 +2486,8 @@ forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
| {- empty -} { noLoc ([], Nothing) }
constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }
- : infixtype {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b,
- dataConBuilderDetails b))))
- (runPV $1) }
+ : infixtype {% do { b <- runPV $1
+ ; return (sL1 b (dataConBuilderCon b, dataConBuilderDetails b)) }}
| '(#' usum_constr '#)' {% let (t, tag, arity) = $2 in pure (sLL $1 $3 $ mkUnboxedSumCon t tag arity)}
usum_constr :: { (LHsType GhcPs, Int, Int) } -- constructor for the data decls SumN#
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -236,7 +236,8 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
; let anns' = annsIn Semi.<> ann
; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
- ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
+ ; !cs' <- getCommentsFor loc'
+ ; let loc = EpAnn (spanAsAnchor loc') noAnn (cs' Semi.<> cs)
; return (L loc (DataDecl { tcdDExt = anns',
tcdLName = tc, tcdTyVars = tyvars,
tcdFixity = fixity,
@@ -2059,28 +2060,32 @@ instance DisambTD (HsType GhcPs) where
mkHsAppTyHeadPV = return
mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)
- mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)
+ mkHsOpTyPV prom t1 op t2 = do
+ let (L l ty) = mkLHsOpTy prom t1 op t2
+ !cs <- getCommentsFor (locA l)
+ return (L (addCommentsToEpAnn l cs) ty)
mkUnpackednessPV = addUnpackednessP
-dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
-dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
-dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
+dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName
+dataConBuilderCon (L _ (PrefixDataConBuilder _ dc)) = dc
+dataConBuilderCon (L _ (InfixDataConBuilder _ dc _)) = dc
-dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs
+dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
-- Detect when the record syntax is used:
-- data T = MkT { ... }
-dataConBuilderDetails (PrefixDataConBuilder flds _)
+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
| [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds
= RecCon (L (EpAnn anc an cs) fields)
-- Normal prefix constructor, e.g. data T = MkT A B C
-dataConBuilderDetails (PrefixDataConBuilder flds _)
+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
= PrefixCon noTypeArgs (map hsLinear (toList flds))
-- Infix constructor, e.g. data T = Int :! Bool
-dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)
- = InfixCon (hsLinear lhs) (hsLinear rhs)
+dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs))
+ = InfixCon (hsLinear (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsLinear rhs)
+
instance DisambTD DataConBuilder where
mkHsAppTyHeadPV = tyToDataConBuilder
@@ -2101,8 +2106,9 @@ instance DisambTD DataConBuilder where
mkHsOpTyPV prom lhs tc rhs = do
check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative
data_con <- eitherToP $ tyConToDataCon tc
+ !cs <- getCommentsFor (locA l)
checkNotPromotedDataCon prom data_con
- return $ L l (InfixDataConBuilder lhs data_con rhs)
+ return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
where
l = combineLocsA lhs rhs
check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
@@ -3223,8 +3229,8 @@ mkSumOrTuplePat l Boxed a at Sum{} _ =
mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy prom x op y =
- let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
- in L loc (mkHsOpTy prom x op y)
+ let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y
+ in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)
mkMultTy :: EpToken "%" -> LHsType GhcPs -> EpUniToken "->" "→" -> HsArrow GhcPs
mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr
=====================================
configure.ac
=====================================
@@ -379,15 +379,7 @@ then
else
TargetPlatformFull="${target_alias}"
fi
-if test "$CrossCompiling" = "YES"
-then
- # Use value passed by user from --target=
- CrossCompilePrefix="${TargetPlatformFull}-"
-else
- CrossCompilePrefix=""
-fi
AC_SUBST(CrossCompiling)
-AC_SUBST(CrossCompilePrefix)
AC_SUBST(TargetPlatformFull)
dnl ** Which gcc to use?
@@ -623,9 +615,6 @@ FP_LD_NO_WARN_DUPLICATE_LIBRARIES([target], [CONF_GCC_LINKER_OPTS_STAGE2])
FP_MERGE_OBJECTS_SUPPORTS_RESPONSE_FILES
GHC_LLVM_TARGET_SET_VAR
-# we intend to pass trough --targets to llvm as is.
-LLVMTarget_CPP=` echo "$LlvmTarget"`
-AC_SUBST(LLVMTarget_CPP)
# The target is substituted into the distrib/configure.ac file
AC_SUBST(LlvmTarget)
@@ -951,12 +940,10 @@ PREP_TARGET_FILE
FIND_GHC_TOOLCHAIN([hadrian/cfg])
AC_CONFIG_FILES(
-[ mk/project.mk
- hadrian/cfg/system.config
+[ hadrian/cfg/system.config
hadrian/ghci-cabal
hadrian/ghci-multi-cabal
hadrian/ghci-stack
- distrib/configure.ac
hadrian/cfg/default.host.target
hadrian/cfg/default.target
])
=====================================
distrib/configure.ac.in
=====================================
@@ -23,19 +23,12 @@ bootstrap_llvm_target=@LlvmTarget@
TargetHasLibm=@TargetHasLibm@
AC_SUBST(TargetHasLibm)
-FFIIncludeDir=@FFIIncludeDir@
-FFILibDir=@FFILibDir@
-AC_SUBST(FFILibDir)
-AC_SUBST(FFIIncludeDir)
-
-LibdwIncludeDir=@LibdwIncludeDir@
-LibdwLibDir=@LibdwLibDir@
-AC_SUBST(LibdwLibDir)
-AC_SUBST(LibdwIncludeDir)
-
UseLibffiForAdjustors=@UseLibffiForAdjustors@
AC_SUBST(UseLibffiForAdjustors)
+GhcWithSMP=@GhcWithSMP@
+AC_SUBST(GhcWithSMP)
+
# We have to run these unconditionally as FPTOOLS_SET_PLATFORMS_VARS wants the
# values it computes.
AC_CANONICAL_BUILD
@@ -59,13 +52,11 @@ if test "$target" != "$host" ; then
fi
LeadingUnderscore="@LeadingUnderscore@"
CrossCompilePrefix="@CrossCompilePrefix@"
-TargetPlatformFull="${target}"
TablesNextToCode="@TablesNextToCode@"
AC_SUBST(LeadingUnderscore)
AC_SUBST(CrossCompiling)
AC_SUBST(CrossCompilePrefix)
-AC_SUBST(TargetPlatformFull)
AC_SUBST(TablesNextToCode)
Unregisterised="@Unregisterised@"
=====================================
hadrian/bindist/Makefile
=====================================
@@ -123,7 +123,7 @@ lib/settings : config.mk
@echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@
@echo ',("target has libm", "$(TargetHasLibm)")' >> $@
@echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@
- @echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@
+ @echo ',("LLVM target", "$(LLVMTarget)")' >> $@
@echo ',("LLVM llc command", "$(SettingsLlcCommand)")' >> $@
@echo ',("LLVM opt command", "$(SettingsOptCommand)")' >> $@
@echo ',("LLVM llvm-as command", "$(SettingsLlvmAsCommand)")' >> $@
=====================================
hadrian/bindist/config.mk.in
=====================================
@@ -134,20 +134,9 @@ CrossCompiling = @CrossCompiling@
CrossCompilePrefix = @CrossCompilePrefix@
GhcUnregisterised = @Unregisterised@
-# ArchSupportsSMP should be set iff there is support for that arch in
-# rts/include/stg/SMP.h
-ifeq "$(TargetArch_CPP)" "arm"
-# We don't support load/store barriers pre-ARMv7. See #10433.
-ArchSupportsSMP=$(if $(filter $(ARM_ISA),ARMv5 ARMv6),NO,YES)
-else ifeq "$(TargetArch_CPP)" "javascript"
-ArchSupportsSMP=NO
-else
-ArchSupportsSMP=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 sparc powerpc powerpc64 powerpc64le s390x aarch64 riscv64)))
-endif
-
# The THREADED_RTS requires `BaseReg` to be in a register and the
# `GhcUnregisterised` mode doesn't allow that.
-GhcWithSMP := $(strip $(if $(filter YESNO, $(ArchSupportsSMP)$(GhcUnregisterised)),YES,NO))
+GhcWithSMP := @GhcWithSMP@
# Whether to include GHCi in the compiler. Depends on whether the RTS linker
# has support for this OS/ARCH combination.
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -128,3 +128,5 @@ use-lib-dl = @UseLibdl@
use-lib-bfd = @UseLibbfd@
use-lib-pthread = @UseLibpthread@
need-libatomic = @NeedLibatomic@
+
+emsdk-version = @ConfiguredEmsdkVersion@
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -72,6 +72,7 @@ data Setting = CursesIncludeDir
| SystemGhc
| TargetPlatformFull
| BourneShell
+ | EmsdkVersion
-- TODO compute solely in Hadrian, removing these variables' definitions
-- from aclocal.m4 whenever they can be calculated from other variables
@@ -128,6 +129,7 @@ setting key = lookupSystemConfig $ case key of
SystemGhc -> "system-ghc"
TargetPlatformFull -> "target-platform-full"
BourneShell -> "bourne-shell"
+ EmsdkVersion -> "emsdk-version"
-- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the
-- result.
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -337,6 +337,7 @@ bindistRules = do
-- Prepare binary distribution configure script
-- (generated under <ghc root>/distrib/configure by 'autoreconf')
root -/- "bindist" -/- "ghc-*" -/- "configure" %> \configurePath -> do
+ need ["distrib" -/- "configure.ac"]
ghcRoot <- topDirectory
copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4")
copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib")
@@ -360,8 +361,7 @@ bindistRules = do
-- creating the archive).
forM_ bindistInstallFiles $ \file ->
root -/- "bindist" -/- "ghc-*" -/- file %> \dest -> do
- ghcRoot <- topDirectory
- copyFile (ghcRoot -/- fixup file) dest
+ copyFile (fixup file) dest
where
fixup f | f `elem` ["INSTALL", "README"] = "distrib" -/- f
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -371,6 +371,57 @@ templateRules = do
[ interpolateVar "LlvmMinVersion" $ replaceEq '.' ',' <$> setting LlvmMinVersion
, interpolateVar "LlvmMaxVersion" $ replaceEq '.' ',' <$> setting LlvmMaxVersion
]
+ bindistRules
+
+bindistRules :: Rules ()
+bindistRules = do
+ templateRule ("mk" -/- "project.mk") $ mconcat
+ [ interpolateSetting "ProjectName" ProjectName
+ , interpolateSetting "ProjectVersion" ProjectVersion
+ , interpolateSetting "ProjectVersionInt" ProjectVersionInt
+ , interpolateSetting "ProjectPatchLevel" ProjectPatchLevel
+ , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1
+ , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2
+ , interpolateSetting "ProjectGitCommitId" ProjectGitCommitId
+
+ , interpolateVar "HostOS_CPP" $ fmap cppify $ interp $ queryHost queryOS
+
+ , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+ , interpolateVar "TargetPlatform_CPP" $ cppify <$> getTarget targetPlatformTriple
+ , interpolateVar "TargetArch_CPP" $ cppify <$> getTarget queryArch
+ , interpolateVar "TargetOS_CPP" $ cppify <$> getTarget queryOS
+ , interpolateVar "LLVMTarget" $ getTarget tgtLlvmTarget
+ ]
+ templateRule ("distrib" -/- "configure.ac") $ mconcat
+ [ interpolateSetting "ConfiguredEmsdkVersion" EmsdkVersion
+ , interpolateVar "CrossCompilePrefix" $ do
+ crossCompiling <- interp $ getFlag CrossCompiling
+ tpf <- setting TargetPlatformFull
+ pure $ if crossCompiling then tpf <> "-" else ""
+ , interpolateVar "LeadingUnderscore" $ yesNo <$> getTarget tgtSymbolsHaveLeadingUnderscore
+ , interpolateSetting "LlvmMaxVersion" LlvmMaxVersion
+ , interpolateSetting "LlvmMinVersion" LlvmMinVersion
+ , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget
+ , interpolateSetting "ProjectVersion" ProjectVersion
+ , interpolateVar "SettingsUseDistroMINGW" $ settingsFileSetting ToolchainSetting_DistroMinGW
+ , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
+ , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm"
+ , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+ , interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian
+ , interpolateVar "TargetWordSize" $ getTarget wordSize
+ , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised
+ , interpolateVar "UseLibdw" $ fmap yesNo $ interp $ getFlag UseLibdw
+ , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
+ , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
+ ]
+ where
+ interp = interpretInContext (semiEmptyTarget Stage2)
+ getTarget = interp . queryTarget
+
+-- | Given a 'String' replace characters '.' and '-' by underscores ('_') so that
+-- the resulting 'String' is a valid C preprocessor identifier.
+cppify :: String -> String
+cppify = replaceEq '-' '_' . replaceEq '.' '_'
-- Generators
@@ -486,10 +537,11 @@ generateSettings settingsFile = do
arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr
arSupportsDashL' = yesNo . arSupportsDashL . tgtAr
ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib
- isBigEndian = yesNo . (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness
- wordSize = show . wordSize2Bytes . tgtWordSize
mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs
+isBigEndian, wordSize :: Toolchain.Target -> String
+isBigEndian = yesNo . (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness
+wordSize = show . wordSize2Bytes . tgtWordSize
-- | Generate @Config.hs@ files.
generateConfigHs :: Expr String
=====================================
mk/project.mk.in
=====================================
@@ -1,5 +1,5 @@
# WARNING: mk/project.mk is automatically generated from mk/project.mk.in by
-# ./configure. Make sure you are editing mk/project.mk.in, not mk/project.mk.
+# Hadrian. Make sure you are editing mk/project.mk.in, not mk/project.mk.
################################################################################
#
@@ -25,8 +25,7 @@
# random .o-file stuff might change even if the .hi syntax doesn't
ProjectName = @ProjectName@
-ProjectTags =
-ProjectVersion = @ProjectVersion@$(ProjectTags)
+ProjectVersion = @ProjectVersion@
ProjectVersionInt = @ProjectVersionInt@
ProjectPatchLevel = @ProjectPatchLevel@
ProjectPatchLevel1 = @ProjectPatchLevel1@
@@ -81,41 +80,14 @@ ProjectGitCommitId = @ProjectGitCommitId@
# You have to do a lot of work by hand to cross compile: see the
# section on "Porting GHC" in the Building Guide.
-HOSTPLATFORM = @HostPlatform@
TARGETPLATFORM = @TargetPlatform@
-BUILDPLATFORM = @BuildPlatform@
-HostPlatform_CPP = @HostPlatform_CPP@
-HostArch_CPP = @HostArch_CPP@
HostOS_CPP = @HostOS_CPP@
-HostVendor_CPP = @HostVendor_CPP@
TargetPlatform_CPP = @TargetPlatform_CPP@
TargetArch_CPP = @TargetArch_CPP@
TargetOS_CPP = @TargetOS_CPP@
-TargetVendor_CPP = @TargetVendor_CPP@
-LLVMTarget_CPP = @LLVMTarget_CPP@
-
-BuildPlatform_CPP = @BuildPlatform_CPP@
-BuildArch_CPP = @BuildArch_CPP@
-BuildOS_CPP = @BuildOS_CPP@
-BuildVendor_CPP = @BuildVendor_CPP@
-
- at HostPlatform_CPP@_HOST = 1
- at TargetPlatform_CPP@_TARGET = 1
- at BuildPlatform_CPP@_BUILD = 1
-
- at HostArch_CPP@_HOST_ARCH = 1
- at TargetArch_CPP@_TARGET_ARCH = 1
- at BuildArch_CPP@_BUILD_ARCH = 1
-
- at HostOS_CPP@_HOST_OS = 1
- at TargetOS_CPP@_TARGET_OS = 1
- at BuildOS_CPP@_BUILD_OS = 1
-
- at HostVendor_CPP@_HOST_VENDOR = 1
- at TargetVendor_CPP@_TARGET_VENDOR = 1
- at BuildVendor_CPP@_BUILD_VENDOR = 1
+LLVMTarget = @LLVMTarget@
################################################################################
#
@@ -123,13 +95,6 @@ BuildVendor_CPP = @BuildVendor_CPP@
#
################################################################################
-# Pin a suffix on executables? If so, what (Windows only).
-exeext0=@exeext_host@
-exeext1=@exeext_target@
-exeext2=@exeext_target@
-exeext3=@exeext_target@
-soext=@soext_target@
-
# Windows_Host=YES if on a Windows platform
ifneq "$(findstring $(HostOS_CPP), mingw32)" ""
Windows_Host=YES
@@ -143,17 +108,3 @@ Darwin_Host=YES
else
Darwin_Host=NO
endif
-
-# Windows_Target=YES if we are targeting a Windows platform
-ifneq "$(findstring $(TargetOS_CPP), mingw32)" ""
-Windows_Target=YES
-else
-Windows_Target=NO
-endif
-
-# Is the stage0 compiler affected by Bug #9439?
-GHC_LLVM_AFFECTED_BY_9439 = @GHC_LLVM_AFFECTED_BY_9439@
-
-ifeq "$(TargetArch_CPP)" "arm"
-ARM_ISA=@ARM_ISA@
-endif
=====================================
testsuite/tests/codeGen/should_run/T24664a.hs
=====================================
@@ -0,0 +1,27 @@
+-- This program tests the passing of RUBBISH values
+-- with the Int64 representation, which were found
+-- to by mis-handled by the JS backend in #24664.
+
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts (Int64#, intToInt64#)
+
+takesInt64a :: String -> Int64# -> String -> IO ()
+{-# OPAQUE takesInt64a #-}
+-- Idea: This function takes an Int64# but doesn't use it,
+-- so that its argument might be turned into a rubbish literal.
+-- We don't want WW to remove the argument entirely, so OPAQUE
+takesInt64a str1 _ str2 = putStrLn str1 >> putStrLn str2
+
+takesInt64b :: Int64# -> IO ()
+{-# NOINLINE takesInt64b #-}
+-- Idea: This function will get a worker that doesn't take an
+-- Int64# at all, and the body of that worker will pass a
+-- rubbish literal to takesInt64a since no real arg exists.
+takesInt64b x = takesInt64a "first string to print" x "second string to print"
+
+main :: IO ()
+main = do
+ takesInt64b (intToInt64# 12345#)
=====================================
testsuite/tests/codeGen/should_run/T24664a.stdout
=====================================
@@ -0,0 +1,2 @@
+first string to print
+second string to print
=====================================
testsuite/tests/codeGen/should_run/T24664b.hs
=====================================
@@ -0,0 +1,31 @@
+-- This is a variant of T24664a that could reproduce
+-- the compiler crash originally observed in #24664.
+
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts (Int64#, intToInt64#, uncheckedIShiftRL64#)
+
+takesInt64a :: String -> Int64# -> String -> IO ()
+{-# OPAQUE takesInt64a #-}
+-- Idea: This function takes an Int64# but doesn't use it,
+-- so that its argument might be turned into a rubbish literal.
+-- We don't want WW to remove the argument entirely, so OPAQUE
+takesInt64a str1 _ str2 = putStrLn str1 >> putStrLn str2
+
+takesInt64b :: String -> Int64# -> String -> IO ()
+{-# NOINLINE takesInt64b #-}
+-- Idea: This function will get a worker that doesn't take an
+-- Int64# at all, and the body of that worker will pass a
+-- rubbish literal to takesInt64a since no real arg exists.
+takesInt64b s1 x s2
+ = takesInt64a (s1 ++ t) (x `uncheckedIShiftRL64#` 13#) (s2 ++ t)
+ where t = " string to print"
+
+takesInt64c :: Int64# -> IO ()
+takesInt64c x = takesInt64b "first" x "second"
+
+main :: IO ()
+main = do
+ takesInt64c (intToInt64# 12345#)
=====================================
testsuite/tests/codeGen/should_run/T24664b.stdout
=====================================
@@ -0,0 +1,2 @@
+first string to print
+second string to print
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -243,3 +243,6 @@ test('MulMayOflo_full',
test('T24264run', normal, compile_and_run, [''])
test('T24295a', normal, compile_and_run, ['-O -floopification'])
test('T24295b', normal, compile_and_run, ['-O -floopification -fpedantic-bottoms'])
+test('T24664a', normal, compile_and_run, ['-O'])
+test('T24664b', normal, compile_and_run, ['-O'])
+
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -861,3 +861,13 @@ Test24754:
Test24755:
$(CHECK_PPR) $(LIBDIR) Test24755.hs
$(CHECK_EXACT) $(LIBDIR) Test24755.hs
+
+.PHONY: Test24753
+Test24753:
+ $(CHECK_PPR) $(LIBDIR) Test24753.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24753.hs
+
+.PHONY: Test24771
+Test24771:
+ $(CHECK_PPR) $(LIBDIR) Test24771.hs
+ $(CHECK_EXACT) $(LIBDIR) Test24771.hs
=====================================
testsuite/tests/printer/Test24753.hs
=====================================
@@ -0,0 +1,8 @@
+module Test24753 where
+
+type ErrorChoiceApi
+ = "path0" :> Get '[JSON] Int -- c0
+ :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- c4
+ :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- c5
+ :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- c6
+ :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- c7
=====================================
testsuite/tests/printer/Test24755.hs
=====================================
@@ -3,6 +3,6 @@
module Test24755 where
class
- a -- Before operator
- :+
- b -- After operator
+ a -- c1
+ :+ -- c2
+ b -- c3
=====================================
testsuite/tests/printer/Test24771.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24771 where
+
+data Foo
+ = Int -- c1
+ :* -- c2
+ String -- c3
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -205,3 +205,5 @@ test('DataDeclShort', [ignore_stderr, req_ppr_deps], makefile_test, ['DataDeclSh
test('Test24749', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24749'])
test('Test24754', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24754'])
test('Test24755', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24755'])
+test('Test24753', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24753'])
+test('Test24771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24771'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0f74e54459ec7838c4f8954929b9f29fb35b73b3...e4644bcbb9793b1a449835efa2f3e23e253d869b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0f74e54459ec7838c4f8954929b9f29fb35b73b3...e4644bcbb9793b1a449835efa2f3e23e253d869b
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/20240506/9ee8791c/attachment-0001.html>
More information about the ghc-commits
mailing list