[Git][ghc/ghc][master] compiler: Warn when -finfo-table-map is used with -fllvm
by Marge Bot (＠marge-bot) 08 Apr '26
by Marge Bot (＠marge-bot) 08 Apr '26
08 Apr '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7fe84ea5 by Zubin Duggal at 2026-04-07T19:11:52+05:30
compiler: Warn when -finfo-table-map is used with -fllvm
These are currently not supported together.
Fixes #26435
- - - - -
6 changed files:
- compiler/GHC/Driver/Session.hs
- docs/users_guide/debug-info.rst
- + testsuite/tests/driver/T26435.ghc.stderr
- + testsuite/tests/driver/T26435.hs
- + testsuite/tests/driver/T26435.stdout
- testsuite/tests/driver/all.T
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3895,6 +3895,11 @@ makeDynFlagsConsistent dflags
hostFullWays
in dflags_c
+ | gopt Opt_InfoTableMap dflags
+ , LlvmCodeOutput <- backendCodeOutput (backend dflags)
+ = loop (gopt_unset dflags Opt_InfoTableMap)
+ "-finfo-table-map is incompatible with -fllvm and is disabled (See #26435)"
+
| otherwise = (dflags, mempty, mempty)
where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
loop updated_dflags warning
=====================================
docs/users_guide/debug-info.rst
=====================================
@@ -370,6 +370,11 @@ to a source location. This lookup table is generated by using the ``-finfo-table
also want more precise information about constructor info tables then you
should also use :ghc-flag:`-fdistinct-constructor-tables`.
+ .. note::
+ This flag is incompatible with :ghc-flag:`-fllvm`. If both flags are
+ enabled, GHC will emit a warning and :ghc-flag:`-finfo-table-map` will
+ have no effect.
+
The :ghc-flag:`-finfo-table-map` flag will increase the binary size by quite
a lot, depending on how big your project is. For compiling a project the
size of GHC the overhead was about 200 megabytes.
=====================================
testsuite/tests/driver/T26435.ghc.stderr
=====================================
@@ -0,0 +1,5 @@
+when making flags consistent: warning: [GHC-74335] [-Winconsistent-flags (in -Wdefault)]
+ -finfo-table-map is incompatible with -fllvm and is disabled (See #26435)
+
+[1 of 2] Compiling Main ( T26435.hs, T26435.o )
+[2 of 2] Linking T26435
=====================================
testsuite/tests/driver/T26435.hs
=====================================
@@ -0,0 +1,5 @@
+module Main where
+import GHC.InfoProv
+
+main :: IO ()
+main = print =<< whereFrom main
=====================================
testsuite/tests/driver/T26435.stdout
=====================================
@@ -0,0 +1 @@
+Nothing
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -337,3 +337,4 @@ test('T25382', normal, makefile_test, [])
test('T26018', req_c, makefile_test, [])
test('T24120', normal, compile, ['-Wunused-packages -hide-all-packages -package base -package system-cxx-std-lib'])
test('T26551', [extra_files(['T26551.hs'])], makefile_test, [])
+test('T26435', [only_ways(['llvm'])], warn_and_run, ['-finfo-table-map'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fe84ea5c2159204bf845ff3f7fd1e6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fe84ea5c2159204bf845ff3f7fd1e6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: packaging: correctly propagate build/host/target to bindist configure script
by Marge Bot (＠marge-bot) 07 Apr '26
by Marge Bot (＠marge-bot) 07 Apr '26
07 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8a04650b by Matthew Pickering at 2026-04-07T22:35:49-04:00
packaging: correctly propagate build/host/target to bindist configure script
At the moment the host and target which we will produce a compiler for
is fixed at the initial configure time. Therefore we need to persist
the choice made at this time into the installation bindist as well so we
look for the right tools, with the right prefixes at install time.
In the future, we want to provide a bit more control about what kind of
bindist we produce so the logic about what the host/target will have to
be written by hadrian rather than persisted by the configure script. In
particular with cross compilers we want to either build a normal stage 2
cross bindist or a stage 3 bindist, which creates a bindist which has a
native compiler for the target platform.
Fixes #21970
Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com>
- - - - -
d54231f2 by Sven Tennie at 2026-04-07T22:35:49-04:00
Cross --host and --target no longer required for cross (#21970)
We set sane defaults in the configure script. Thus, these paramenters
aren't required any longer.
- - - - -
366cb96f by Sven Tennie at 2026-04-07T22:35:49-04:00
ci: Define USER_CONF_CC_OPTS_STAGE2 for aarch64/mingw
ghc-toolchain doesn't see $CONF_CC_OPTS_STAGE2 when the bindist gets
configured. So, the hack to override the compiler gets lost.
- - - - -
3d5e5781 by Cheng Shao at 2026-04-07T22:35:50-04:00
ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages
This patch refactors ghci to use `ShortByteString` for
`LookupSymbol`/`LookupSymbolInDLL`/`LookupClosure` messages as the
first part of #27147.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
0e905840 by Cheng Shao at 2026-04-07T22:35:50-04:00
ghci: use ShortByteString for MkCostCentres message
This patch refactors ghci to use `ShortByteString` for `MkCostCentres`
messages as a first part of #27147. This also considerably lowers the
memory overhead of breakpoints when cost center profiling is enabled.
-------------------------
Metric Decrease:
interpreter_steplocal
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
23 changed files:
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Default.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/ObjLink.hs
- libraries/ghci/GHCi/Run.hs
- m4/fptools_set_platform_vars.m4
- m4/ghc_toolchain.m4
- testsuite/tests/driver/linkwhole/Main.hs
- testsuite/tests/ghci/should_run/T18064.script
- testsuite/tests/rts/KeepCafsMain.hs
- utils/jsffi/dyld.mjs
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -628,20 +628,6 @@ function install_bindist() {
*)
read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}"
- if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then
- # We suppose that host target = build target.
- # By the fact above it is clearly turning out which host value is
- # for currently built compiler.
- # The fix for #21970 will probably remove this if-branch.
- local -r CROSS_HOST_GUESS=$($SHELL ./config.guess)
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_HOST_GUESS" )
-
- # FIXME: The bindist configure script shouldn't need to be reminded of
- # the target platform. See #21970.
- elif [ -n "${CROSS_TARGET:-}" ]; then
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" )
- fi
-
run ${CONFIGURE_WRAPPER:-} ./configure \
--prefix="$instdir" \
"${args[@]+"${args[@]}"}" || fail "bindist configure failed"
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -1316,6 +1316,13 @@ cross_jobs = [
-- unexpected triple.
. setVariable "CFLAGS" cflags
. setVariable "CONF_CC_OPTS_STAGE2" cflags
+ -- For bindists `$USER_CONF_CC_OPTS_STAGE2` is not automatically set
+ -- to `$CONF_CC_OPTS_STAGE2`. But, we still have to deal with the hack
+ -- mentioned in the previous comment.
+ --
+ -- TODO: It would be nice to get rid of this hack. This would probably
+ -- involve setting the toolchain up in a different way.
+ . setVariable "USER_CONF_CC_OPTS_STAGE2" cflags
) where
llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-"
cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt"
=====================================
.gitlab/jobs.yaml
=====================================
@@ -331,6 +331,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -412,6 +413,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -1123,6 +1125,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
@@ -1205,6 +1208,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Name.Occurrence
import Control.DeepSeq
+import qualified Data.ByteString.Short as SBS
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
@@ -235,8 +236,8 @@ getBreakVars = getBreakXXX modBreaks_vars
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
getBreakDecls = getBreakXXX modBreaks_decls
--- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String))
+-- | Get the cost centre info for this breakpoint
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (SBS.ShortByteString, SBS.ShortByteString)
getBreakCCS = getBreakXXX modBreaks_ccs
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -405,7 +405,7 @@ loadExternalPlugins ps = do
symbol
| null unit = ztmp
| otherwise = zEncodeString unit ++ "_" ++ ztmp
- plugin <- lookupSymbol symbol >>= \case
+ plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case
Nothing -> pprPanic "loadExternalPlugins"
(vcat [ text "Symbol not found"
, text " Library path: " <> text path
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.HsToCore.Breakpoints
import GHC.Prelude
import Data.Array
+import qualified Data.ByteString.Short as SBS
import GHC.HsToCore.Ticks (Tick (..))
import GHC.Data.SizedSeq
@@ -31,6 +32,7 @@ import GHC.Types.Name (OccName)
import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))
import GHC.Unit.Module (Module)
import GHC.Utils.Binary
+import GHC.Utils.Encoding (utf8EncodeShortByteString)
import GHC.Utils.Outputable
import Data.List (intersperse)
import Data.Coerce
@@ -59,7 +61,7 @@ data ModBreaks
, modBreaks_decls :: !(Array BreakTickIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
-- See Note [Field modBreaks_decls]
- , modBreaks_ccs :: !(Array BreakTickIndex (String, String))
+ , modBreaks_ccs :: !(Array BreakTickIndex (SBS.ShortByteString, SBS.ShortByteString))
-- ^ Array pointing to cost centre info for each breakpoint;
-- actual 'CostCentre' allocation is done at link-time.
, modBreaks_module :: !Module
@@ -89,8 +91,8 @@ mkModBreaks interpreterProfiled modl extendedMixEntries
| interpreterProfiled =
listArray
(0, count - 1)
- [ ( concat $ intersperse "." $ tick_path t,
- renderWithContext defaultSDocContext $ ppr $ tick_loc t
+ [ ( utf8EncodeShortByteString $ concat $ intersperse "." $ tick_path t,
+ utf8EncodeShortByteString $ renderWithContext defaultSDocContext $ ppr $ tick_loc t
)
| t <- entries
]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -1846,7 +1846,7 @@ allocateCCS interp ce mbss
ccs <- {- one ccs ptr per tick index -}
mkCostCentres
interp
- (moduleNameString $ moduleName modBreaks_module)
+ (moduleNameFS $ moduleName modBreaks_module)
(elems modBreaks_ccs)
return $ M.fromList $
zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..]
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -107,6 +107,7 @@ import Control.Monad.IO.Class
import Control.Monad.Catch as MC (mask)
import Data.Binary
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Short as SBS
import Foreign hiding (void)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
@@ -352,9 +353,15 @@ evalStringToIOString interp fhv str =
mallocData :: Interp -> ByteString -> IO (RemotePtr ())
mallocData interp bs = interpCmd interp (MallocData bs)
-mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
-mkCostCentres interp mod ccs =
- interpCmd interp (MkCostCentres mod ccs)
+mkCostCentres :: Interp -> FastString -> [(SBS.ShortByteString, SBS.ShortByteString)] -> IO [RemotePtr CostCentre]
+mkCostCentres interp mod ccs = do
+ rp <- modifyMVar (interpStringCache interp) $ \fs_env ->
+ case lookupFsEnv fs_env mod of
+ Just rp -> pure (fs_env, rp)
+ Nothing -> do
+ rp <- fmap head $ interpCmd interp $ MallocStrings [bytesFS mod]
+ pure (extendFsEnv fs_env mod rp, rp)
+ interpCmd interp $ MkCostCentres rp ccs
-- | Create a set of BCOs that may be mutually recursive.
createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
@@ -413,7 +420,7 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId eval_break =
let
mkUnitId u = fsToUnit $ mkFastStringShortByteString u
- toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ toModule u n = mkModule (mkUnitId u) (mkModuleNameFS (mkFastStringShortByteString n))
in
InternalBreakpointId
{ ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
@@ -465,27 +472,27 @@ lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbol interp str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbolInDLL interp dll str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
-- wasm dyld doesn't track which symbol comes from which .so
ExtWasm {} -> lookupSymbol interp str
@@ -519,7 +526,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is -
lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
lookupClosure interp str =
- interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
+ interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str)))
-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
=====================================
configure.ac
=====================================
@@ -255,6 +255,7 @@ if test "${WithGhc}" != ""
then
bootstrap_host=`"${WithGhc}" --info | grep '^ ,("Host platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
bootstrap_target=`"${WithGhc}" --info | grep '^ ,("Target platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
+ bootstrap_build="$bootstrap_host"
if test "$bootstrap_host" != "$bootstrap_target"
then
echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work"
@@ -394,8 +395,33 @@ then
else
TargetPlatformFull="${target_alias}"
fi
+
+if test -z "${build_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ BuildPlatformFull="${build}"
+else
+ BuildPlatformFull="${build_alias}"
+fi
+if test -z "${host_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ HostPlatformFull="${host}"
+else
+ HostPlatformFull="${host_alias}"
+fi
+if test "$CrossCompiling" = "YES"
+then
+ # Use value passed by user from --target=
+ CrossCompilePrefix="${TargetPlatformFull}-"
+else
+ CrossCompilePrefix=""
+fi
+
AC_SUBST(CrossCompiling)
AC_SUBST(TargetPlatformFull)
+AC_SUBST(BuildPlatformFull)
+AC_SUBST(HostPlatformFull)
dnl ** Which gcc to use?
dnl --------------------------------------------------------------
=====================================
distrib/configure.ac.in
=====================================
@@ -15,7 +15,18 @@ dnl--------------------------------------------------------------------
dnl * Deal with arguments telling us gmp is somewhere odd
dnl--------------------------------------------------------------------
+build_alias=@BuildPlatformFull@
+host_alias=@HostPlatformFull@
+target_alias=@TargetPlatformFull@
+
+dnl this makes sure `./configure --target=<cross-compile-target>`
+dnl works as expected, since we're slightly modifying how Autoconf
+dnl interprets build/host/target and how this interacts with $CC tests
+test -n "$target_alias" && ac_tool_prefix=$target_alias-
+
dnl Various things from the source distribution configure
+bootstrap_build=@BuildPlatform@
+bootstrap_host=@HostPlatform@
bootstrap_target=@TargetPlatform@
bootstrap_llvm_target=@LlvmTarget@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -50,6 +50,9 @@ use-ghc-toolchain = @EnableGhcToolchain@
# And we can reconstruct the platform info using targetPlatformTriple
# Q: What is TargetPlatformFull?
target-platform-full = @TargetPlatformFull@
+build-platform-full = @BuildPlatformFull@
+host-platform-full = @HostPlatformFull@
+
cross-compiling = @CrossCompiling@
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -69,6 +69,8 @@ data Setting = CursesIncludeDir
| ProjectPatchLevel2
| SystemGhc
| TargetPlatformFull
+ | BuildPlatformFull
+ | HostPlatformFull
| BourneShell
| EmsdkVersion
@@ -107,6 +109,8 @@ setting key = lookupSystemConfig $ case key of
ProjectPatchLevel2 -> "project-patch-level2"
SystemGhc -> "system-ghc"
TargetPlatformFull -> "target-platform-full"
+ BuildPlatformFull -> "build-platform-full"
+ HostPlatformFull -> "host-platform-full"
BourneShell -> "bourne-shell"
EmsdkVersion -> "emsdk-version"
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -424,6 +424,8 @@ bindistRules = do
, interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
, interpolateVar "TargetHasLibm" $ yesNo <$> getTarget tgtHasLibm
, interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+ , interpolateVar "BuildPlatform" $ interp $ queryBuild targetPlatformTriple
+ , interpolateVar "HostPlatform" $ interp $ queryHost targetPlatformTriple
, interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian
, interpolateVar "TargetWordSize" $ getTarget wordSize
, interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised
@@ -431,6 +433,9 @@ bindistRules = do
, interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
, interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
, interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base
+ , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull)
+ , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull)
+ , interpolateVar "HostPlatformFull" (setting HostPlatformFull)
]
where
interp = interpretInContext (semiEmptyTarget Stage2)
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -122,7 +122,11 @@ stage0Packages = do
-- for upper stages. As we only use stage0 to build upper stages,
-- this should be fine.
++ [ terminfo | not windowsHost, not cross ]
- ++ [ timeout | windowsHost ]
+ ++ [ timeout | windowsHost ]
+ -- Due to some weird logic, we need ghcToolchainBin in Stage0 and
+ -- Stage1 packages if we're cross compiling. "Stage2 cross-compilers"
+ -- will solve this.
+ ++ [ ghcToolchainBin | cross ]
-- | Packages built in 'Stage1' by default. You can change this in "UserSettings".
stage1Packages :: Action [Package]
@@ -181,12 +185,12 @@ stage1Packages = do
, transformers
, unlit
, xhtml
+ , ghcToolchainBin
, if winTarget then win32 else unix
]
, when (not cross)
[ hpcBin
, runGhc
- , ghcToolchainBin
]
, when (winTarget && not cross)
[ -- See Note [Hadrian's ghci-wrapper package]
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -86,9 +86,9 @@ data Message a where
-- These all invoke the corresponding functions in the RTS Linker API.
InitLinker :: Message ()
- LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
- LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
- LookupClosure :: String -> Message (Maybe HValueRef)
+ LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef)
LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL])
LoadArchive :: String -> Message () -- error?
LoadObj :: String -> Message () -- error?
@@ -162,8 +162,8 @@ data Message a where
-- | Create a set of CostCentres with the same module name
MkCostCentres
- :: String -- module, RemotePtr so it can be shared
- -> [(String,String)] -- (name, SrcSpan)
+ :: !(RemotePtr ()) -- ModuleName
+ -> ![(BS.ShortByteString, BS.ShortByteString)] -- (name, SrcSpan)
-> Message [RemotePtr CostCentre]
-- | Show a 'CostCentreStack' as a @[String]@
@@ -430,7 +430,7 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_info_mod :: String -- ^ Breakpoint info module
+ { eb_info_mod :: !BS.ShortByteString -- ^ Breakpoint info module
, eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
, eb_info_index :: Int -- ^ Breakpoint info index
}
=====================================
libraries/ghci/GHCi/ObjLink.hs
=====================================
@@ -31,6 +31,8 @@ import GHCi.RemoteTypes
import GHCi.Message (LoadedDLL)
import Control.Exception (throwIO, ErrorCall(..))
import Control.Monad ( when )
+import qualified Data.ByteString.Short as BS
+import Data.Char (ord)
import Data.Foldable
import Foreign.C
import Foreign.Marshal.Alloc ( alloca, free )
@@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f
purgeObj :: String -> IO ()
purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f
-lookupSymbol :: String -> IO (Maybe (Ptr a))
-lookupSymbol sym = do
- r <- js_lookupSymbol $ toJSString sym
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
+lookupSymbol sym@(BS.SBS ba#) = do
+ r <- js_lookupSymbolPtr ba# (BS.length sym)
evaluate $ if r == nullPtr then Nothing else Just r
-foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)"
- js_lookupSymbol :: JSString -> IO (Ptr a)
+foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)"
+ js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL _ _ = pure Nothing
resolveObjs :: IO Bool
@@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO ()
initObjLinker RetainCAFs = c_initLinker_ 1
initObjLinker _ = c_initLinker_ 0
-lookupSymbol :: String -> IO (Maybe (Ptr a))
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL dll str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbolInNativeObj dll c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-prefixUnderscore :: String -> String
+prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString
prefixUnderscore
- | cLeadingUnderscore = ('_':)
+ | cLeadingUnderscore = BS.cons (fromIntegral (ord '_'))
| otherwise = id
-- | loadDLL loads a dynamic library using the OS's native linker
@@ -298,7 +300,7 @@ isWindowsHost = False
#endif
-lookupClosure :: String -> IO (Maybe HValueRef)
+lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupClosure str = do
m <- lookupSymbol str
case m of
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -34,7 +34,7 @@ import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
-import qualified Data.ByteString.Short as BS
+import qualified Data.ByteString.Short.Internal as BS
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import qualified GHC.Exts.Heap as Heap
@@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o
foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #)
-lookupJSClosure' :: String -> IO Int
-lookupJSClosure' str = withCString str $ \cstr -> IO (\s ->
+lookupJSClosure' :: BS.ShortByteString -> IO Int
+lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s ->
case lookupJSClosure# cstr s of
(# s', r #) -> (# s', I# r #))
-lookupJSClosure :: String -> IO (Maybe HValueRef)
+lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupJSClosure str = lookupJSClosure' str >>= \case
0 -> pure Nothing
r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r))))
@@ -359,7 +359,7 @@ withBreakAction opts breakMVar statusMVar mtid act
if is_exception
then pure Nothing
else do
- info_mod <- peekCString (Ptr info_mod#)
+ info_mod <- BS.packCString (Ptr info_mod#)
info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
@@ -434,17 +434,24 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
pokeElemOff (ptr :: Ptr CChar) len 0
return (castRemotePtr (toRemotePtr ptr))
-mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING)
mkCostCentres mod ccs = do
- c_module <- newCString mod
+ let c_module = fromRemotePtr $ castRemotePtr mod
mapM (mk_one c_module) ccs
where
mk_one c_module (decl_path,srcspan) = do
- c_name <- newCString decl_path
- c_srcspan <- newCString srcspan
+ c_name <- newCStringFromSBS decl_path
+ c_srcspan <- newCStringFromSBS srcspan
toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
+ newCStringFromSBS sbs = do
+ let len = BS.length sbs
+ buf <- mallocBytes $ len + 1
+ BS.copyToPtr sbs 0 buf (fromIntegral len)
+ pokeByteOff buf len (0 :: Word8)
+ pure buf
+
foreign import ccall unsafe "mkCostCentre"
c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
#else
=====================================
m4/fptools_set_platform_vars.m4
=====================================
@@ -77,9 +77,9 @@ dnl fi
# compiler's target platform.
AC_DEFUN([FPTOOLS_OVERRIDE_PLATFORM_FROM_BOOTSTRAP],
[
- if test "$bootstrap_target" != ""
+ if test "$bootstrap_$1" != ""
then
- $1=$bootstrap_target
+ $1=$bootstrap_$1
echo "$1 platform inferred as: [$]$1"
else
echo "Can't work out $1 platform"
=====================================
m4/ghc_toolchain.m4
=====================================
@@ -136,8 +136,10 @@ dnl and that we must compile ghc-toolchain before invoking it
AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[
case "$1" in
YES)
- # We're configuring the bindist, and the binary is already available
- GHC_TOOLCHAIN_BIN="bin/ghc-toolchain-bin"
+ # We're configuring the bindist, and the binary is already available.
+ # For cross-compilation bindists, Hadrian names the binary with the
+ # cross-compile prefix (e.g. riscv64-linux-gnu-ghc-toolchain-bin).
+ GHC_TOOLCHAIN_BIN="bin/${CrossCompilePrefix}ghc-toolchain-bin"
;;
NO)
# We're in the source tree, so compile ghc-toolchain
=====================================
testsuite/tests/driver/linkwhole/Main.hs
=====================================
@@ -1,9 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Exception
import Control.Monad
+import Data.ByteString.Short (ShortByteString)
import Foreign
@@ -15,7 +17,7 @@ import GHCi.ObjLink
rotateSO
:: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a)))
- -> String
+ -> ShortByteString
-> (Maybe FilePath, FilePath)
-> IO a
rotateSO dynamicCall symName (old, newDLL) = do
=====================================
testsuite/tests/ghci/should_run/T18064.script
=====================================
@@ -1,2 +1,3 @@
+:set -XOverloadedStrings
import GHCi.ObjLink
lookupClosure "blah"
=====================================
testsuite/tests/rts/KeepCafsMain.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Main (main) where
import Foreign
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1334,6 +1334,13 @@ class DyLD {
}
return 0;
}
+
+ lookupSymbolPtr(symPtr, symLen) {
+ const sym = new TextDecoder("utf-8", { fatal: true }).decode(
+ new Uint8Array(this.#memory.buffer, symPtr, symLen)
+ );
+ return this.lookupSymbol(sym);
+ }
}
// The main entry point of dyld that may be run on node/browser, and
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba0bcfa8cd6ba8540d93080173bb56…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba0bcfa8cd6ba8540d93080173bb56…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC
Commits:
5bdcdf82 by Simon Peyton Jones at 2026-04-07T23:25:52+01:00
Wibbles [skip ci]
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Rules.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -40,7 +40,8 @@ import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe
, typeArity, arityTypeArity, etaExpandAT )
import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} )
-import GHC.Core.Rules ( lookupRule, getRules )
+import GHC.Core.Rules ( RuleMatch(..), applyBindWrapper, isEmptyBindWrapper
+ , lookupRule, getRules )
import GHC.Core.Multiplicity
import GHC.Hs.Extension
@@ -2298,7 +2299,7 @@ simplOutExpr env expr cont
_ -> rebuild_go env expr cont
where
(fun, args) = collectArgs expr
- cont' = pushArgs env Simplified (expType fun) args cont
+ cont' = pushArgs env Simplified (exprType fun) args cont
occ_fun = occurAnalyseExpr fun -- ToDo:explain; c.f. Note [Occurrence-analyse after rule firing]
---------------------------------------------------------
@@ -2364,10 +2365,14 @@ simplOutId env fun cont
then tryRules env rules_for_me fun out_args
else return Nothing
; case mb_match of {
- Just (rule_arity, rhs, rhs_args ) -> simplExprF env rhs $
- pushArgs env NoDup rhs_args $
- dropContArgs rule_arity cont ;
- Nothing ->
+ Just (RM { rm_rule = rule, rm_rhs = rhs
+ , rm_args = rhs_args, rm_binds = wrap })
+ -> simplExprF env rhs' $
+ dropContArgs (ruleArity rule) cont
+ where
+ rhs' = applyBindWrapper wrap $
+ mkApps rhs rhs_args
+ ; Nothing ->
-- Try inlining
do { logger <- getLogger
@@ -2451,18 +2456,15 @@ rebuildCall env fun_info
; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }
---------- No further useful info, revert to generic rebuild ------------
-rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_arg_specs, ai_rules = rules }) cont
| null rules
- = rebuild env (argInfoExpr fun rev_args) cont
+ = rebuild env (argInfoExpr fun rev_arg_specs) cont
| otherwise -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules]
- = do { let args = reverse rev_args
- ; mb_match <- tryRules env rules fun (map argSpecArg args)
+ = do { let arg_specs = reverse rev_arg_specs
+ ; mb_match <- tryRules env rules fun (map argSpecArg arg_specs)
; case mb_match of
- Just (rule_arity, rhs, rhs_args)
- -> simplExprF env rhs $
- pushArgs env Simplified rhs_args $
- pushArgSpecs env (drop rule_arity args) cont
- Nothing -> rebuild env (argInfoExpr fun rev_args) cont }
+ Just rule_match -> fireRuleAFTER env rule_match arg_specs cont
+ Nothing -> rebuild env (argInfoExpr fun rev_arg_specs) cont }
-----------------------------------
tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr)
@@ -2644,20 +2646,36 @@ See Note [No free join points in arityType] in GHC.Core.Opt.Arity
************************************************************************
-}
+fireRuleAFTER :: SimplEnv -> RuleMatch
+ -> [ArgSpec] -> SimplCont
+ -> SimplM (SimplFloats, CoreExpr)
+fireRuleAFTER env rule_match arg_specs cont
+ | RM { rm_rule = rule, rm_rhs = rhs, rm_args = rhs_args
+ , rm_binds = wrap, rm_bndrs = bndrs } <- rule_match
+ = do { let env' = env `addNewInScopeIds` bndrs
+ ; (floats, e') <- simplExprF env' rhs $
+ pushArgs env' Simplified (exprType rhs) rhs_args $
+ pushArgSpecs env' (drop (ruleArity rule) arg_specs) cont
+ ; return $
+ if isEmptyBindWrapper wrap
+ then (floats, e')
+ else (emptyFloats env', applyBindWrapper wrap $
+ wrapFloats floats e') }
+
+
tryRules :: SimplEnv -> [CoreRule]
-> OutId -> [OutExpr]
- -> SimplM (Maybe (FullArgCount, CoreExpr, [CoreExpr]))
+ -> SimplM (Maybe RuleMatch)
tryRules env rules fn args
- | Just (rule, rule_rhs, rule_args) <- lookupRule ropts in_scope_env
- act_fun fn args rules
- -- Fire a rule for the function
- = do { logger <- getLogger
- ; checkedTick (RuleFired (ruleName rule))
--- ; let occ_anald_rhs = occurAnalyseExpr rule_rhs
--- -- See Note [Occurrence-analyse after rule firing]
- ; dump logger rule rule_rhs
- ; return (Just (ruleArity rule, rhs_rhs, rule_args)) }
+ | Just rule_match <- lookupRule ropts in_scope_env
+ act_fun fn args rules
+ -- Fire a rule for the function
+ = do { let the_rule = rm_rule rule_match
+ ; logger <- getLogger
+ ; checkedTick (RuleFired (ruleName the_rule))
+ ; dump logger the_rule (rm_rhs rule_match)
+ ; return (Just rule_match) }
| otherwise -- No rule fires
= do { logger <- getLogger
@@ -2723,12 +2741,8 @@ trySeqRules in_env scrut rhs cont
; let seq_rules = getRules rule_base seqId
; mb_match <- tryRules in_env seq_rules seqId out_args
; case mb_match of
- Nothing -> return Nothing
- Just (rule_arity, rhs, rhs_args) -> return (Just (rhs, cont'))
- where
- cont' = pushArgs in_env Simplified rhs_args $
- pushArgSpecs in_env (drop rule_arity out_arg_specs) rule_cont
- }
+ Nothing -> return Nothing
+ Just rule_match -> Just <$> fireRuleAFTER in_env rule_match out_arg_specs cont }
where
no_cast_scrut = drop_casts scrut
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -10,6 +10,7 @@
module GHC.Core.Rules (
-- ** Looking up rules
RuleMatch(..), lookupRule, matchExprs, ruleLhsIsMoreSpecific,
+ BindWrapper, isEmptyBindWrapper, applyBindWrapper,
-- ** RuleBase, RuleEnv
RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,
@@ -88,6 +89,7 @@ import GHC.Types.Basic
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Data.Bag
+import GHC.Data.OrdList
import GHC.Data.List.SetOps( hasNoDups )
import GHC.Utils.FV( filterFV, fvVarSet )
@@ -591,7 +593,7 @@ lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules
go ms [] = ms
go ms (r:rs)
| Just rm <- matchRule opts rule_env is_active fn args' rough_args r
- = go (rm { rm_binds = mkTicks ticks . rm_binds rm } : ms) rs
+ = go (rm { rm_binds = mkTicks ticks `consOL` rm_binds rm } : ms) rs
| otherwise
= -- pprTrace "match failed" (ppr r $$ ppr args $$
-- ppr [ (arg_id, maybeUnfoldingTemplate unf)
@@ -746,7 +748,7 @@ matchRule opts rule_env _is_active fn args _rough_args
; return (RM { rm_rule = rule
, rm_rhs = rhs
, rm_args = []
- , rm_binds = id
+ , rm_binds = emptyBindWrapper
, rm_bndrs = [] }) }
matchRule _opts rule_env is_active _fn target_es rough_args
@@ -968,13 +970,23 @@ data RuleSubst = RS { -- Substitution; applied only to the template, not the tar
, rs_bndrs :: [Var] -- Variables bound by floated lets
}
-type BindWrapper = CoreExpr -> CoreExpr
+type BindWrapper = OrdList (CoreExpr -> CoreExpr)
-- See Notes [Matching lets] and [Matching cases]
-- we represent the floated bindings as a core-to-core function
+ -- WE use an OrdList so that we can tell the common case of an empty wrapper
+
+emptyBindWrapper :: BindWrapper
+emptyBindWrapper = nilOL
+
+isEmptyBindWrapper :: BindWrapper -> Bool
+isEmptyBindWrapper = isNilOL
+
+applyBindWrapper :: BindWrapper -> CoreExpr -> CoreExpr
+applyBindWrapper bw e = foldrOL ($) e bw
emptyRuleSubst :: RuleSubst
emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv
- , rs_binds = \e -> e, rs_bndrs = [] }
+ , rs_binds = nilOL, rs_bndrs = [] }
{- Note [Casts in the target]
@@ -1110,7 +1122,7 @@ match renv subst e1 (Tick t e2) mco
| otherwise
= Nothing
where
- subst' = subst { rs_binds = rs_binds subst . mkTick t }
+ subst' = subst { rs_binds = rs_binds subst `snocOL` mkTick t }
match renv subst e@(Tick t e1) e2 mco
| tickishFloatable t -- Ignore floatable ticks in rule template.
@@ -1344,7 +1356,7 @@ match renv subst e1 (Let bind e2) mco
-- We are floating the let-binding out, as if it had enclosed
-- the entire target from Day 1. So we must add its binders to
-- the in-scope set (#20200)
- (subst { rs_binds = rs_binds subst . Let bind'
+ (subst { rs_binds = rs_binds subst `snocOL` Let bind'
, rs_bndrs = new_bndrs ++ rs_bndrs subst })
e1 e2 mco
| otherwise
@@ -1370,7 +1382,7 @@ match renv subst (Lam x1 e1) e2 mco
, Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2
-- See Note [Lambdas in the template]
= let renv' = rnMatchBndr2 renv x1 x2
- subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }
+ subst' = subst { rs_binds = rs_binds subst `snocOL` flip (foldr mkTick) ts }
in match renv' subst' e1 e2' MRefl
match renv subst e1 e2@(Lam {}) mco
@@ -1435,11 +1447,11 @@ match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (
eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr)
-- See Note [Eta reduction in the target]
eta_reduce renv e@(Lam {})
- = go renv id [] e
+ = go renv emptyBindWrapper [] e
where
go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr
-> Maybe (RuleMatchEnv, CoreExpr)
- go renv bw vs (Let b e) = go renv (bw . Let b) vs e
+ go renv bw vs (Let b e) = go renv (bw `snocOL` Let b) vs e
go renv bw vs (Lam v e) = go renv' bw (v':vs) e
where
@@ -1454,7 +1466,7 @@ eta_reduce renv e@(Lam {})
, v == rnOccR (rv_lcl renv) tv
= go renv bw vs f
- go renv bw [] e = Just (renv, bw e)
+ go renv bw [] e = Just (renv, applyBindWrapper bw e)
go _ _ (_:_) _ = Nothing
eta_reduce _ _ = Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bdcdf82179fbeb1748127ba46a6eb2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bdcdf82179fbeb1748127ba46a6eb2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: packaging: correctly propagate build/host/target to bindist configure script
by Marge Bot (＠marge-bot) 07 Apr '26
by Marge Bot (＠marge-bot) 07 Apr '26
07 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b1bac3fe by Matthew Pickering at 2026-04-07T18:21:20-04:00
packaging: correctly propagate build/host/target to bindist configure script
At the moment the host and target which we will produce a compiler for
is fixed at the initial configure time. Therefore we need to persist
the choice made at this time into the installation bindist as well so we
look for the right tools, with the right prefixes at install time.
In the future, we want to provide a bit more control about what kind of
bindist we produce so the logic about what the host/target will have to
be written by hadrian rather than persisted by the configure script. In
particular with cross compilers we want to either build a normal stage 2
cross bindist or a stage 3 bindist, which creates a bindist which has a
native compiler for the target platform.
Fixes #21970
Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com>
- - - - -
37198b5a by Sven Tennie at 2026-04-07T18:21:20-04:00
Cross --host and --target no longer required for cross (#21970)
We set sane defaults in the configure script. Thus, these paramenters
aren't required any longer.
- - - - -
3bfe7777 by Sven Tennie at 2026-04-07T18:21:20-04:00
ci: Define USER_CONF_CC_OPTS_STAGE2 for aarch64/mingw
ghc-toolchain doesn't see $CONF_CC_OPTS_STAGE2 when the bindist gets
configured. So, the hack to override the compiler gets lost.
- - - - -
676a2183 by Cheng Shao at 2026-04-07T18:21:21-04:00
ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages
This patch refactors ghci to use `ShortByteString` for
`LookupSymbol`/`LookupSymbolInDLL`/`LookupClosure` messages as the
first part of #27147.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
ba0bcfa8 by Cheng Shao at 2026-04-07T18:21:21-04:00
ghci: use ShortByteString for MkCostCentres message
This patch refactors ghci to use `ShortByteString` for `MkCostCentres`
messages as a first part of #27147. This also considerably lowers the
memory overhead of breakpoints when cost center profiling is enabled.
-------------------------
Metric Decrease:
interpreter_steplocal
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
23 changed files:
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Default.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/ObjLink.hs
- libraries/ghci/GHCi/Run.hs
- m4/fptools_set_platform_vars.m4
- m4/ghc_toolchain.m4
- testsuite/tests/driver/linkwhole/Main.hs
- testsuite/tests/ghci/should_run/T18064.script
- testsuite/tests/rts/KeepCafsMain.hs
- utils/jsffi/dyld.mjs
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -628,20 +628,6 @@ function install_bindist() {
*)
read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}"
- if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then
- # We suppose that host target = build target.
- # By the fact above it is clearly turning out which host value is
- # for currently built compiler.
- # The fix for #21970 will probably remove this if-branch.
- local -r CROSS_HOST_GUESS=$($SHELL ./config.guess)
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_HOST_GUESS" )
-
- # FIXME: The bindist configure script shouldn't need to be reminded of
- # the target platform. See #21970.
- elif [ -n "${CROSS_TARGET:-}" ]; then
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" )
- fi
-
run ${CONFIGURE_WRAPPER:-} ./configure \
--prefix="$instdir" \
"${args[@]+"${args[@]}"}" || fail "bindist configure failed"
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -1316,6 +1316,13 @@ cross_jobs = [
-- unexpected triple.
. setVariable "CFLAGS" cflags
. setVariable "CONF_CC_OPTS_STAGE2" cflags
+ -- For bindists `$USER_CONF_CC_OPTS_STAGE2` is not automatically set
+ -- to `$CONF_CC_OPTS_STAGE2`. But, we still have to deal with the hack
+ -- mentioned in the previous comment.
+ --
+ -- TODO: It would be nice to get rid of this hack. This would probably
+ -- involve setting the toolchain up in a different way.
+ . setVariable "USER_CONF_CC_OPTS_STAGE2" cflags
) where
llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-"
cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt"
=====================================
.gitlab/jobs.yaml
=====================================
@@ -331,6 +331,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -412,6 +413,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -1123,6 +1125,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
@@ -1205,6 +1208,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Name.Occurrence
import Control.DeepSeq
+import qualified Data.ByteString.Short as SBS
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
@@ -235,8 +236,8 @@ getBreakVars = getBreakXXX modBreaks_vars
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
getBreakDecls = getBreakXXX modBreaks_decls
--- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String))
+-- | Get the cost centre info for this breakpoint
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (SBS.ShortByteString, SBS.ShortByteString)
getBreakCCS = getBreakXXX modBreaks_ccs
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -405,7 +405,7 @@ loadExternalPlugins ps = do
symbol
| null unit = ztmp
| otherwise = zEncodeString unit ++ "_" ++ ztmp
- plugin <- lookupSymbol symbol >>= \case
+ plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case
Nothing -> pprPanic "loadExternalPlugins"
(vcat [ text "Symbol not found"
, text " Library path: " <> text path
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.HsToCore.Breakpoints
import GHC.Prelude
import Data.Array
+import qualified Data.ByteString.Short as SBS
import GHC.HsToCore.Ticks (Tick (..))
import GHC.Data.SizedSeq
@@ -31,6 +32,7 @@ import GHC.Types.Name (OccName)
import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))
import GHC.Unit.Module (Module)
import GHC.Utils.Binary
+import GHC.Utils.Encoding (utf8EncodeShortByteString)
import GHC.Utils.Outputable
import Data.List (intersperse)
import Data.Coerce
@@ -59,7 +61,7 @@ data ModBreaks
, modBreaks_decls :: !(Array BreakTickIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
-- See Note [Field modBreaks_decls]
- , modBreaks_ccs :: !(Array BreakTickIndex (String, String))
+ , modBreaks_ccs :: !(Array BreakTickIndex (SBS.ShortByteString, SBS.ShortByteString))
-- ^ Array pointing to cost centre info for each breakpoint;
-- actual 'CostCentre' allocation is done at link-time.
, modBreaks_module :: !Module
@@ -89,8 +91,8 @@ mkModBreaks interpreterProfiled modl extendedMixEntries
| interpreterProfiled =
listArray
(0, count - 1)
- [ ( concat $ intersperse "." $ tick_path t,
- renderWithContext defaultSDocContext $ ppr $ tick_loc t
+ [ ( utf8EncodeShortByteString $ concat $ intersperse "." $ tick_path t,
+ utf8EncodeShortByteString $ renderWithContext defaultSDocContext $ ppr $ tick_loc t
)
| t <- entries
]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -1846,7 +1846,7 @@ allocateCCS interp ce mbss
ccs <- {- one ccs ptr per tick index -}
mkCostCentres
interp
- (moduleNameString $ moduleName modBreaks_module)
+ (moduleNameFS $ moduleName modBreaks_module)
(elems modBreaks_ccs)
return $ M.fromList $
zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..]
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -107,6 +107,7 @@ import Control.Monad.IO.Class
import Control.Monad.Catch as MC (mask)
import Data.Binary
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Short as SBS
import Foreign hiding (void)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
@@ -352,9 +353,15 @@ evalStringToIOString interp fhv str =
mallocData :: Interp -> ByteString -> IO (RemotePtr ())
mallocData interp bs = interpCmd interp (MallocData bs)
-mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
-mkCostCentres interp mod ccs =
- interpCmd interp (MkCostCentres mod ccs)
+mkCostCentres :: Interp -> FastString -> [(SBS.ShortByteString, SBS.ShortByteString)] -> IO [RemotePtr CostCentre]
+mkCostCentres interp mod ccs = do
+ rp <- modifyMVar (interpStringCache interp) $ \fs_env ->
+ case lookupFsEnv fs_env mod of
+ Just rp -> pure (fs_env, rp)
+ Nothing -> do
+ rp <- fmap head $ interpCmd interp $ MallocStrings [bytesFS mod]
+ pure (extendFsEnv fs_env mod rp, rp)
+ interpCmd interp $ MkCostCentres rp ccs
-- | Create a set of BCOs that may be mutually recursive.
createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
@@ -413,7 +420,7 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId eval_break =
let
mkUnitId u = fsToUnit $ mkFastStringShortByteString u
- toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ toModule u n = mkModule (mkUnitId u) (mkModuleNameFS (mkFastStringShortByteString n))
in
InternalBreakpointId
{ ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
@@ -465,27 +472,27 @@ lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbol interp str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbolInDLL interp dll str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
-- wasm dyld doesn't track which symbol comes from which .so
ExtWasm {} -> lookupSymbol interp str
@@ -519,7 +526,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is -
lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
lookupClosure interp str =
- interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
+ interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str)))
-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
=====================================
configure.ac
=====================================
@@ -255,6 +255,7 @@ if test "${WithGhc}" != ""
then
bootstrap_host=`"${WithGhc}" --info | grep '^ ,("Host platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
bootstrap_target=`"${WithGhc}" --info | grep '^ ,("Target platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
+ bootstrap_build="$bootstrap_host"
if test "$bootstrap_host" != "$bootstrap_target"
then
echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work"
@@ -394,8 +395,33 @@ then
else
TargetPlatformFull="${target_alias}"
fi
+
+if test -z "${build_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ BuildPlatformFull="${build}"
+else
+ BuildPlatformFull="${build_alias}"
+fi
+if test -z "${host_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ HostPlatformFull="${host}"
+else
+ HostPlatformFull="${host_alias}"
+fi
+if test "$CrossCompiling" = "YES"
+then
+ # Use value passed by user from --target=
+ CrossCompilePrefix="${TargetPlatformFull}-"
+else
+ CrossCompilePrefix=""
+fi
+
AC_SUBST(CrossCompiling)
AC_SUBST(TargetPlatformFull)
+AC_SUBST(BuildPlatformFull)
+AC_SUBST(HostPlatformFull)
dnl ** Which gcc to use?
dnl --------------------------------------------------------------
=====================================
distrib/configure.ac.in
=====================================
@@ -15,7 +15,18 @@ dnl--------------------------------------------------------------------
dnl * Deal with arguments telling us gmp is somewhere odd
dnl--------------------------------------------------------------------
+build_alias=@BuildPlatformFull@
+host_alias=@HostPlatformFull@
+target_alias=@TargetPlatformFull@
+
+dnl this makes sure `./configure --target=<cross-compile-target>`
+dnl works as expected, since we're slightly modifying how Autoconf
+dnl interprets build/host/target and how this interacts with $CC tests
+test -n "$target_alias" && ac_tool_prefix=$target_alias-
+
dnl Various things from the source distribution configure
+bootstrap_build=@BuildPlatform@
+bootstrap_host=@HostPlatform@
bootstrap_target=@TargetPlatform@
bootstrap_llvm_target=@LlvmTarget@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -50,6 +50,9 @@ use-ghc-toolchain = @EnableGhcToolchain@
# And we can reconstruct the platform info using targetPlatformTriple
# Q: What is TargetPlatformFull?
target-platform-full = @TargetPlatformFull@
+build-platform-full = @BuildPlatformFull@
+host-platform-full = @HostPlatformFull@
+
cross-compiling = @CrossCompiling@
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -69,6 +69,8 @@ data Setting = CursesIncludeDir
| ProjectPatchLevel2
| SystemGhc
| TargetPlatformFull
+ | BuildPlatformFull
+ | HostPlatformFull
| BourneShell
| EmsdkVersion
@@ -107,6 +109,8 @@ setting key = lookupSystemConfig $ case key of
ProjectPatchLevel2 -> "project-patch-level2"
SystemGhc -> "system-ghc"
TargetPlatformFull -> "target-platform-full"
+ BuildPlatformFull -> "build-platform-full"
+ HostPlatformFull -> "host-platform-full"
BourneShell -> "bourne-shell"
EmsdkVersion -> "emsdk-version"
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -424,6 +424,8 @@ bindistRules = do
, interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
, interpolateVar "TargetHasLibm" $ yesNo <$> getTarget tgtHasLibm
, interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+ , interpolateVar "BuildPlatform" $ interp $ queryBuild targetPlatformTriple
+ , interpolateVar "HostPlatform" $ interp $ queryHost targetPlatformTriple
, interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian
, interpolateVar "TargetWordSize" $ getTarget wordSize
, interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised
@@ -431,6 +433,9 @@ bindistRules = do
, interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
, interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
, interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base
+ , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull)
+ , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull)
+ , interpolateVar "HostPlatformFull" (setting HostPlatformFull)
]
where
interp = interpretInContext (semiEmptyTarget Stage2)
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -122,7 +122,11 @@ stage0Packages = do
-- for upper stages. As we only use stage0 to build upper stages,
-- this should be fine.
++ [ terminfo | not windowsHost, not cross ]
- ++ [ timeout | windowsHost ]
+ ++ [ timeout | windowsHost ]
+ -- Due to some weird logic, we need ghcToolchainBin in Stage0 and
+ -- Stage1 packages if we're cross compiling. "Stage2 cross-compilers"
+ -- will solve this.
+ ++ [ ghcToolchainBin | cross ]
-- | Packages built in 'Stage1' by default. You can change this in "UserSettings".
stage1Packages :: Action [Package]
@@ -181,12 +185,12 @@ stage1Packages = do
, transformers
, unlit
, xhtml
+ , ghcToolchainBin
, if winTarget then win32 else unix
]
, when (not cross)
[ hpcBin
, runGhc
- , ghcToolchainBin
]
, when (winTarget && not cross)
[ -- See Note [Hadrian's ghci-wrapper package]
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -86,9 +86,9 @@ data Message a where
-- These all invoke the corresponding functions in the RTS Linker API.
InitLinker :: Message ()
- LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
- LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
- LookupClosure :: String -> Message (Maybe HValueRef)
+ LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef)
LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL])
LoadArchive :: String -> Message () -- error?
LoadObj :: String -> Message () -- error?
@@ -162,8 +162,8 @@ data Message a where
-- | Create a set of CostCentres with the same module name
MkCostCentres
- :: String -- module, RemotePtr so it can be shared
- -> [(String,String)] -- (name, SrcSpan)
+ :: !(RemotePtr ()) -- ModuleName
+ -> ![(BS.ShortByteString, BS.ShortByteString)] -- (name, SrcSpan)
-> Message [RemotePtr CostCentre]
-- | Show a 'CostCentreStack' as a @[String]@
@@ -430,7 +430,7 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_info_mod :: String -- ^ Breakpoint info module
+ { eb_info_mod :: !BS.ShortByteString -- ^ Breakpoint info module
, eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
, eb_info_index :: Int -- ^ Breakpoint info index
}
=====================================
libraries/ghci/GHCi/ObjLink.hs
=====================================
@@ -31,6 +31,8 @@ import GHCi.RemoteTypes
import GHCi.Message (LoadedDLL)
import Control.Exception (throwIO, ErrorCall(..))
import Control.Monad ( when )
+import qualified Data.ByteString.Short as BS
+import Data.Char (ord)
import Data.Foldable
import Foreign.C
import Foreign.Marshal.Alloc ( alloca, free )
@@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f
purgeObj :: String -> IO ()
purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f
-lookupSymbol :: String -> IO (Maybe (Ptr a))
-lookupSymbol sym = do
- r <- js_lookupSymbol $ toJSString sym
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
+lookupSymbol sym@(BS.SBS ba#) = do
+ r <- js_lookupSymbolPtr ba# (BS.length sym)
evaluate $ if r == nullPtr then Nothing else Just r
-foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)"
- js_lookupSymbol :: JSString -> IO (Ptr a)
+foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)"
+ js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL _ _ = pure Nothing
resolveObjs :: IO Bool
@@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO ()
initObjLinker RetainCAFs = c_initLinker_ 1
initObjLinker _ = c_initLinker_ 0
-lookupSymbol :: String -> IO (Maybe (Ptr a))
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL dll str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbolInNativeObj dll c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-prefixUnderscore :: String -> String
+prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString
prefixUnderscore
- | cLeadingUnderscore = ('_':)
+ | cLeadingUnderscore = BS.cons (fromIntegral (ord '_'))
| otherwise = id
-- | loadDLL loads a dynamic library using the OS's native linker
@@ -298,7 +300,7 @@ isWindowsHost = False
#endif
-lookupClosure :: String -> IO (Maybe HValueRef)
+lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupClosure str = do
m <- lookupSymbol str
case m of
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -34,7 +34,7 @@ import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
-import qualified Data.ByteString.Short as BS
+import qualified Data.ByteString.Short.Internal as BS
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import qualified GHC.Exts.Heap as Heap
@@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o
foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #)
-lookupJSClosure' :: String -> IO Int
-lookupJSClosure' str = withCString str $ \cstr -> IO (\s ->
+lookupJSClosure' :: BS.ShortByteString -> IO Int
+lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s ->
case lookupJSClosure# cstr s of
(# s', r #) -> (# s', I# r #))
-lookupJSClosure :: String -> IO (Maybe HValueRef)
+lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupJSClosure str = lookupJSClosure' str >>= \case
0 -> pure Nothing
r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r))))
@@ -359,7 +359,7 @@ withBreakAction opts breakMVar statusMVar mtid act
if is_exception
then pure Nothing
else do
- info_mod <- peekCString (Ptr info_mod#)
+ info_mod <- BS.packCString (Ptr info_mod#)
info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
@@ -434,17 +434,24 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
pokeElemOff (ptr :: Ptr CChar) len 0
return (castRemotePtr (toRemotePtr ptr))
-mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING)
mkCostCentres mod ccs = do
- c_module <- newCString mod
+ let c_module = fromRemotePtr $ castRemotePtr mod
mapM (mk_one c_module) ccs
where
mk_one c_module (decl_path,srcspan) = do
- c_name <- newCString decl_path
- c_srcspan <- newCString srcspan
+ c_name <- newCStringFromSBS decl_path
+ c_srcspan <- newCStringFromSBS srcspan
toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
+ newCStringFromSBS sbs = do
+ let len = BS.length sbs
+ buf <- mallocBytes $ len + 1
+ BS.copyToPtr sbs 0 buf (fromIntegral len)
+ pokeByteOff buf len (0 :: Word8)
+ pure buf
+
foreign import ccall unsafe "mkCostCentre"
c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
#else
=====================================
m4/fptools_set_platform_vars.m4
=====================================
@@ -77,9 +77,9 @@ dnl fi
# compiler's target platform.
AC_DEFUN([FPTOOLS_OVERRIDE_PLATFORM_FROM_BOOTSTRAP],
[
- if test "$bootstrap_target" != ""
+ if test "$bootstrap_$1" != ""
then
- $1=$bootstrap_target
+ $1=$bootstrap_$1
echo "$1 platform inferred as: [$]$1"
else
echo "Can't work out $1 platform"
=====================================
m4/ghc_toolchain.m4
=====================================
@@ -136,8 +136,10 @@ dnl and that we must compile ghc-toolchain before invoking it
AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[
case "$1" in
YES)
- # We're configuring the bindist, and the binary is already available
- GHC_TOOLCHAIN_BIN="bin/ghc-toolchain-bin"
+ # We're configuring the bindist, and the binary is already available.
+ # For cross-compilation bindists, Hadrian names the binary with the
+ # cross-compile prefix (e.g. riscv64-linux-gnu-ghc-toolchain-bin).
+ GHC_TOOLCHAIN_BIN="bin/${CrossCompilePrefix}ghc-toolchain-bin"
;;
NO)
# We're in the source tree, so compile ghc-toolchain
=====================================
testsuite/tests/driver/linkwhole/Main.hs
=====================================
@@ -1,9 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Exception
import Control.Monad
+import Data.ByteString.Short (ShortByteString)
import Foreign
@@ -15,7 +17,7 @@ import GHCi.ObjLink
rotateSO
:: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a)))
- -> String
+ -> ShortByteString
-> (Maybe FilePath, FilePath)
-> IO a
rotateSO dynamicCall symName (old, newDLL) = do
=====================================
testsuite/tests/ghci/should_run/T18064.script
=====================================
@@ -1,2 +1,3 @@
+:set -XOverloadedStrings
import GHCi.ObjLink
lookupClosure "blah"
=====================================
testsuite/tests/rts/KeepCafsMain.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Main (main) where
import Foreign
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1334,6 +1334,13 @@ class DyLD {
}
return 0;
}
+
+ lookupSymbolPtr(symPtr, symLen) {
+ const sym = new TextDecoder("utf-8", { fatal: true }).decode(
+ new Uint8Array(this.#memory.buffer, symPtr, symLen)
+ );
+ return this.lookupSymbol(sym);
+ }
}
// The main entry point of dyld that may be run on node/browser, and
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/467c6638fb9db9338aac0153baf127…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/467c6638fb9db9338aac0153baf127…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: compiler: Warn when -finfo-table-map is used with -fllvm
by Marge Bot (＠marge-bot) 07 Apr '26
by Marge Bot (＠marge-bot) 07 Apr '26
07 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
7fe84ea5 by Zubin Duggal at 2026-04-07T19:11:52+05:30
compiler: Warn when -finfo-table-map is used with -fllvm
These are currently not supported together.
Fixes #26435
- - - - -
421646dc by Matthew Pickering at 2026-04-07T15:50:15-04:00
packaging: correctly propagate build/host/target to bindist configure script
At the moment the host and target which we will produce a compiler for
is fixed at the initial configure time. Therefore we need to persist
the choice made at this time into the installation bindist as well so we
look for the right tools, with the right prefixes at install time.
In the future, we want to provide a bit more control about what kind of
bindist we produce so the logic about what the host/target will have to
be written by hadrian rather than persisted by the configure script. In
particular with cross compilers we want to either build a normal stage 2
cross bindist or a stage 3 bindist, which creates a bindist which has a
native compiler for the target platform.
Fixes #21970
Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com>
- - - - -
52c05e11 by Sven Tennie at 2026-04-07T15:50:15-04:00
Cross --host and --target no longer required for cross (#21970)
We set sane defaults in the configure script. Thus, these paramenters
aren't required any longer.
- - - - -
c1863865 by Sven Tennie at 2026-04-07T15:50:15-04:00
ci: Define USER_CONF_CC_OPTS_STAGE2 for aarch64/mingw
ghc-toolchain doesn't see $CONF_CC_OPTS_STAGE2 when the bindist gets
configured. So, the hack to override the compiler gets lost.
- - - - -
0715d1f4 by Cheng Shao at 2026-04-07T15:50:16-04:00
compiler: improve Binary instance of Array
This patch improves the `Binary` instance of `Array`:
- We no longer allocate intermediate lists. When serializing an
`Array`, we iterate over the elements directly; when deserializing
it, we allocate the result `Array` and fill it in a loop.
- Now we only serialize the array bounds tuple; the length field is
not needed.
Closes #27109.
- - - - -
57a4eaaa by Cheng Shao at 2026-04-07T15:50:17-04:00
ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages
This patch refactors ghci to use `ShortByteString` for
`LookupSymbol`/`LookupSymbolInDLL`/`LookupClosure` messages as the
first part of #27147.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
467c6638 by Cheng Shao at 2026-04-07T15:50:17-04:00
ghci: use ShortByteString for MkCostCentres message
This patch refactors ghci to use `ShortByteString` for `MkCostCentres`
messages as a first part of #27147. This also considerably lowers the
memory overhead of breakpoints when cost center profiling is enabled.
-------------------------
Metric Decrease:
interpreter_steplocal
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
30 changed files:
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Utils/Binary.hs
- configure.ac
- distrib/configure.ac.in
- docs/users_guide/debug-info.rst
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Default.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/ObjLink.hs
- libraries/ghci/GHCi/Run.hs
- m4/fptools_set_platform_vars.m4
- m4/ghc_toolchain.m4
- + testsuite/tests/driver/T26435.ghc.stderr
- + testsuite/tests/driver/T26435.hs
- + testsuite/tests/driver/T26435.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/linkwhole/Main.hs
- testsuite/tests/ghci/should_run/T18064.script
- testsuite/tests/rts/KeepCafsMain.hs
- utils/jsffi/dyld.mjs
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -628,20 +628,6 @@ function install_bindist() {
*)
read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}"
- if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then
- # We suppose that host target = build target.
- # By the fact above it is clearly turning out which host value is
- # for currently built compiler.
- # The fix for #21970 will probably remove this if-branch.
- local -r CROSS_HOST_GUESS=$($SHELL ./config.guess)
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_HOST_GUESS" )
-
- # FIXME: The bindist configure script shouldn't need to be reminded of
- # the target platform. See #21970.
- elif [ -n "${CROSS_TARGET:-}" ]; then
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" )
- fi
-
run ${CONFIGURE_WRAPPER:-} ./configure \
--prefix="$instdir" \
"${args[@]+"${args[@]}"}" || fail "bindist configure failed"
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -1316,6 +1316,13 @@ cross_jobs = [
-- unexpected triple.
. setVariable "CFLAGS" cflags
. setVariable "CONF_CC_OPTS_STAGE2" cflags
+ -- For bindists `$USER_CONF_CC_OPTS_STAGE2` is not automatically set
+ -- to `$CONF_CC_OPTS_STAGE2`. But, we still have to deal with the hack
+ -- mentioned in the previous comment.
+ --
+ -- TODO: It would be nice to get rid of this hack. This would probably
+ -- involve setting the toolchain up in a different way.
+ . setVariable "USER_CONF_CC_OPTS_STAGE2" cflags
) where
llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-"
cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt"
=====================================
.gitlab/jobs.yaml
=====================================
@@ -331,6 +331,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -412,6 +413,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -1123,6 +1125,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
@@ -1205,6 +1208,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Name.Occurrence
import Control.DeepSeq
+import qualified Data.ByteString.Short as SBS
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
@@ -235,8 +236,8 @@ getBreakVars = getBreakXXX modBreaks_vars
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
getBreakDecls = getBreakXXX modBreaks_decls
--- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String))
+-- | Get the cost centre info for this breakpoint
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (SBS.ShortByteString, SBS.ShortByteString)
getBreakCCS = getBreakXXX modBreaks_ccs
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -405,7 +405,7 @@ loadExternalPlugins ps = do
symbol
| null unit = ztmp
| otherwise = zEncodeString unit ++ "_" ++ ztmp
- plugin <- lookupSymbol symbol >>= \case
+ plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case
Nothing -> pprPanic "loadExternalPlugins"
(vcat [ text "Symbol not found"
, text " Library path: " <> text path
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3895,6 +3895,11 @@ makeDynFlagsConsistent dflags
hostFullWays
in dflags_c
+ | gopt Opt_InfoTableMap dflags
+ , LlvmCodeOutput <- backendCodeOutput (backend dflags)
+ = loop (gopt_unset dflags Opt_InfoTableMap)
+ "-finfo-table-map is incompatible with -fllvm and is disabled (See #26435)"
+
| otherwise = (dflags, mempty, mempty)
where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
loop updated_dflags warning
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.HsToCore.Breakpoints
import GHC.Prelude
import Data.Array
+import qualified Data.ByteString.Short as SBS
import GHC.HsToCore.Ticks (Tick (..))
import GHC.Data.SizedSeq
@@ -31,6 +32,7 @@ import GHC.Types.Name (OccName)
import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))
import GHC.Unit.Module (Module)
import GHC.Utils.Binary
+import GHC.Utils.Encoding (utf8EncodeShortByteString)
import GHC.Utils.Outputable
import Data.List (intersperse)
import Data.Coerce
@@ -59,7 +61,7 @@ data ModBreaks
, modBreaks_decls :: !(Array BreakTickIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
-- See Note [Field modBreaks_decls]
- , modBreaks_ccs :: !(Array BreakTickIndex (String, String))
+ , modBreaks_ccs :: !(Array BreakTickIndex (SBS.ShortByteString, SBS.ShortByteString))
-- ^ Array pointing to cost centre info for each breakpoint;
-- actual 'CostCentre' allocation is done at link-time.
, modBreaks_module :: !Module
@@ -89,8 +91,8 @@ mkModBreaks interpreterProfiled modl extendedMixEntries
| interpreterProfiled =
listArray
(0, count - 1)
- [ ( concat $ intersperse "." $ tick_path t,
- renderWithContext defaultSDocContext $ ppr $ tick_loc t
+ [ ( utf8EncodeShortByteString $ concat $ intersperse "." $ tick_path t,
+ utf8EncodeShortByteString $ renderWithContext defaultSDocContext $ ppr $ tick_loc t
)
| t <- entries
]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -1846,7 +1846,7 @@ allocateCCS interp ce mbss
ccs <- {- one ccs ptr per tick index -}
mkCostCentres
interp
- (moduleNameString $ moduleName modBreaks_module)
+ (moduleNameFS $ moduleName modBreaks_module)
(elems modBreaks_ccs)
return $ M.fromList $
zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..]
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -107,6 +107,7 @@ import Control.Monad.IO.Class
import Control.Monad.Catch as MC (mask)
import Data.Binary
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Short as SBS
import Foreign hiding (void)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
@@ -352,9 +353,15 @@ evalStringToIOString interp fhv str =
mallocData :: Interp -> ByteString -> IO (RemotePtr ())
mallocData interp bs = interpCmd interp (MallocData bs)
-mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
-mkCostCentres interp mod ccs =
- interpCmd interp (MkCostCentres mod ccs)
+mkCostCentres :: Interp -> FastString -> [(SBS.ShortByteString, SBS.ShortByteString)] -> IO [RemotePtr CostCentre]
+mkCostCentres interp mod ccs = do
+ rp <- modifyMVar (interpStringCache interp) $ \fs_env ->
+ case lookupFsEnv fs_env mod of
+ Just rp -> pure (fs_env, rp)
+ Nothing -> do
+ rp <- fmap head $ interpCmd interp $ MallocStrings [bytesFS mod]
+ pure (extendFsEnv fs_env mod rp, rp)
+ interpCmd interp $ MkCostCentres rp ccs
-- | Create a set of BCOs that may be mutually recursive.
createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
@@ -413,7 +420,7 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId eval_break =
let
mkUnitId u = fsToUnit $ mkFastStringShortByteString u
- toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ toModule u n = mkModule (mkUnitId u) (mkModuleNameFS (mkFastStringShortByteString n))
in
InternalBreakpointId
{ ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
@@ -465,27 +472,27 @@ lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbol interp str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbolInDLL interp dll str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
-- wasm dyld doesn't track which symbol comes from which .so
ExtWasm {} -> lookupSymbol interp str
@@ -519,7 +526,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is -
lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
lookupClosure interp str =
- interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
+ interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str)))
-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -142,6 +142,7 @@ import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
+import Data.Array.Base (traverseArray_, unsafeFreezeIOArray)
import Data.Array.IO
import Data.Array.Unsafe
import qualified Data.Binary as Binary
@@ -970,11 +971,12 @@ instance Binary a => Binary (NonEmpty a) where
instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
put_ bh arr = do
put_ bh $ bounds arr
- put_ bh $ elems arr
+ traverseArray_ (put_ bh) arr
+
get bh = do
- bounds <- get bh
- xs <- get bh
- return $ listArray bounds xs
+ (l, u) <- get bh
+ marr <- newGenArray (l, u) $ \_ -> get bh
+ unsafeFreezeIOArray marr
instance Binary a => Binary (SmallArray a) where
put_ bh sa = do
=====================================
configure.ac
=====================================
@@ -255,6 +255,7 @@ if test "${WithGhc}" != ""
then
bootstrap_host=`"${WithGhc}" --info | grep '^ ,("Host platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
bootstrap_target=`"${WithGhc}" --info | grep '^ ,("Target platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
+ bootstrap_build="$bootstrap_host"
if test "$bootstrap_host" != "$bootstrap_target"
then
echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work"
@@ -394,8 +395,33 @@ then
else
TargetPlatformFull="${target_alias}"
fi
+
+if test -z "${build_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ BuildPlatformFull="${build}"
+else
+ BuildPlatformFull="${build_alias}"
+fi
+if test -z "${host_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ HostPlatformFull="${host}"
+else
+ HostPlatformFull="${host_alias}"
+fi
+if test "$CrossCompiling" = "YES"
+then
+ # Use value passed by user from --target=
+ CrossCompilePrefix="${TargetPlatformFull}-"
+else
+ CrossCompilePrefix=""
+fi
+
AC_SUBST(CrossCompiling)
AC_SUBST(TargetPlatformFull)
+AC_SUBST(BuildPlatformFull)
+AC_SUBST(HostPlatformFull)
dnl ** Which gcc to use?
dnl --------------------------------------------------------------
=====================================
distrib/configure.ac.in
=====================================
@@ -15,7 +15,18 @@ dnl--------------------------------------------------------------------
dnl * Deal with arguments telling us gmp is somewhere odd
dnl--------------------------------------------------------------------
+build_alias=@BuildPlatformFull@
+host_alias=@HostPlatformFull@
+target_alias=@TargetPlatformFull@
+
+dnl this makes sure `./configure --target=<cross-compile-target>`
+dnl works as expected, since we're slightly modifying how Autoconf
+dnl interprets build/host/target and how this interacts with $CC tests
+test -n "$target_alias" && ac_tool_prefix=$target_alias-
+
dnl Various things from the source distribution configure
+bootstrap_build=@BuildPlatform@
+bootstrap_host=@HostPlatform@
bootstrap_target=@TargetPlatform@
bootstrap_llvm_target=@LlvmTarget@
=====================================
docs/users_guide/debug-info.rst
=====================================
@@ -370,6 +370,11 @@ to a source location. This lookup table is generated by using the ``-finfo-table
also want more precise information about constructor info tables then you
should also use :ghc-flag:`-fdistinct-constructor-tables`.
+ .. note::
+ This flag is incompatible with :ghc-flag:`-fllvm`. If both flags are
+ enabled, GHC will emit a warning and :ghc-flag:`-finfo-table-map` will
+ have no effect.
+
The :ghc-flag:`-finfo-table-map` flag will increase the binary size by quite
a lot, depending on how big your project is. For compiling a project the
size of GHC the overhead was about 200 megabytes.
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -50,6 +50,9 @@ use-ghc-toolchain = @EnableGhcToolchain@
# And we can reconstruct the platform info using targetPlatformTriple
# Q: What is TargetPlatformFull?
target-platform-full = @TargetPlatformFull@
+build-platform-full = @BuildPlatformFull@
+host-platform-full = @HostPlatformFull@
+
cross-compiling = @CrossCompiling@
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -69,6 +69,8 @@ data Setting = CursesIncludeDir
| ProjectPatchLevel2
| SystemGhc
| TargetPlatformFull
+ | BuildPlatformFull
+ | HostPlatformFull
| BourneShell
| EmsdkVersion
@@ -107,6 +109,8 @@ setting key = lookupSystemConfig $ case key of
ProjectPatchLevel2 -> "project-patch-level2"
SystemGhc -> "system-ghc"
TargetPlatformFull -> "target-platform-full"
+ BuildPlatformFull -> "build-platform-full"
+ HostPlatformFull -> "host-platform-full"
BourneShell -> "bourne-shell"
EmsdkVersion -> "emsdk-version"
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -424,6 +424,8 @@ bindistRules = do
, interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
, interpolateVar "TargetHasLibm" $ yesNo <$> getTarget tgtHasLibm
, interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+ , interpolateVar "BuildPlatform" $ interp $ queryBuild targetPlatformTriple
+ , interpolateVar "HostPlatform" $ interp $ queryHost targetPlatformTriple
, interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian
, interpolateVar "TargetWordSize" $ getTarget wordSize
, interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised
@@ -431,6 +433,9 @@ bindistRules = do
, interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
, interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
, interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base
+ , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull)
+ , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull)
+ , interpolateVar "HostPlatformFull" (setting HostPlatformFull)
]
where
interp = interpretInContext (semiEmptyTarget Stage2)
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -122,7 +122,11 @@ stage0Packages = do
-- for upper stages. As we only use stage0 to build upper stages,
-- this should be fine.
++ [ terminfo | not windowsHost, not cross ]
- ++ [ timeout | windowsHost ]
+ ++ [ timeout | windowsHost ]
+ -- Due to some weird logic, we need ghcToolchainBin in Stage0 and
+ -- Stage1 packages if we're cross compiling. "Stage2 cross-compilers"
+ -- will solve this.
+ ++ [ ghcToolchainBin | cross ]
-- | Packages built in 'Stage1' by default. You can change this in "UserSettings".
stage1Packages :: Action [Package]
@@ -181,12 +185,12 @@ stage1Packages = do
, transformers
, unlit
, xhtml
+ , ghcToolchainBin
, if winTarget then win32 else unix
]
, when (not cross)
[ hpcBin
, runGhc
- , ghcToolchainBin
]
, when (winTarget && not cross)
[ -- See Note [Hadrian's ghci-wrapper package]
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -86,9 +86,9 @@ data Message a where
-- These all invoke the corresponding functions in the RTS Linker API.
InitLinker :: Message ()
- LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
- LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
- LookupClosure :: String -> Message (Maybe HValueRef)
+ LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef)
LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL])
LoadArchive :: String -> Message () -- error?
LoadObj :: String -> Message () -- error?
@@ -162,8 +162,8 @@ data Message a where
-- | Create a set of CostCentres with the same module name
MkCostCentres
- :: String -- module, RemotePtr so it can be shared
- -> [(String,String)] -- (name, SrcSpan)
+ :: !(RemotePtr ()) -- ModuleName
+ -> ![(BS.ShortByteString, BS.ShortByteString)] -- (name, SrcSpan)
-> Message [RemotePtr CostCentre]
-- | Show a 'CostCentreStack' as a @[String]@
@@ -430,7 +430,7 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_info_mod :: String -- ^ Breakpoint info module
+ { eb_info_mod :: !BS.ShortByteString -- ^ Breakpoint info module
, eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
, eb_info_index :: Int -- ^ Breakpoint info index
}
=====================================
libraries/ghci/GHCi/ObjLink.hs
=====================================
@@ -31,6 +31,8 @@ import GHCi.RemoteTypes
import GHCi.Message (LoadedDLL)
import Control.Exception (throwIO, ErrorCall(..))
import Control.Monad ( when )
+import qualified Data.ByteString.Short as BS
+import Data.Char (ord)
import Data.Foldable
import Foreign.C
import Foreign.Marshal.Alloc ( alloca, free )
@@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f
purgeObj :: String -> IO ()
purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f
-lookupSymbol :: String -> IO (Maybe (Ptr a))
-lookupSymbol sym = do
- r <- js_lookupSymbol $ toJSString sym
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
+lookupSymbol sym@(BS.SBS ba#) = do
+ r <- js_lookupSymbolPtr ba# (BS.length sym)
evaluate $ if r == nullPtr then Nothing else Just r
-foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)"
- js_lookupSymbol :: JSString -> IO (Ptr a)
+foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)"
+ js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL _ _ = pure Nothing
resolveObjs :: IO Bool
@@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO ()
initObjLinker RetainCAFs = c_initLinker_ 1
initObjLinker _ = c_initLinker_ 0
-lookupSymbol :: String -> IO (Maybe (Ptr a))
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL dll str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbolInNativeObj dll c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-prefixUnderscore :: String -> String
+prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString
prefixUnderscore
- | cLeadingUnderscore = ('_':)
+ | cLeadingUnderscore = BS.cons (fromIntegral (ord '_'))
| otherwise = id
-- | loadDLL loads a dynamic library using the OS's native linker
@@ -298,7 +300,7 @@ isWindowsHost = False
#endif
-lookupClosure :: String -> IO (Maybe HValueRef)
+lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupClosure str = do
m <- lookupSymbol str
case m of
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -34,7 +34,7 @@ import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
-import qualified Data.ByteString.Short as BS
+import qualified Data.ByteString.Short.Internal as BS
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import qualified GHC.Exts.Heap as Heap
@@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o
foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #)
-lookupJSClosure' :: String -> IO Int
-lookupJSClosure' str = withCString str $ \cstr -> IO (\s ->
+lookupJSClosure' :: BS.ShortByteString -> IO Int
+lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s ->
case lookupJSClosure# cstr s of
(# s', r #) -> (# s', I# r #))
-lookupJSClosure :: String -> IO (Maybe HValueRef)
+lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupJSClosure str = lookupJSClosure' str >>= \case
0 -> pure Nothing
r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r))))
@@ -359,7 +359,7 @@ withBreakAction opts breakMVar statusMVar mtid act
if is_exception
then pure Nothing
else do
- info_mod <- peekCString (Ptr info_mod#)
+ info_mod <- BS.packCString (Ptr info_mod#)
info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
@@ -434,17 +434,24 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
pokeElemOff (ptr :: Ptr CChar) len 0
return (castRemotePtr (toRemotePtr ptr))
-mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING)
mkCostCentres mod ccs = do
- c_module <- newCString mod
+ let c_module = fromRemotePtr $ castRemotePtr mod
mapM (mk_one c_module) ccs
where
mk_one c_module (decl_path,srcspan) = do
- c_name <- newCString decl_path
- c_srcspan <- newCString srcspan
+ c_name <- newCStringFromSBS decl_path
+ c_srcspan <- newCStringFromSBS srcspan
toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
+ newCStringFromSBS sbs = do
+ let len = BS.length sbs
+ buf <- mallocBytes $ len + 1
+ BS.copyToPtr sbs 0 buf (fromIntegral len)
+ pokeByteOff buf len (0 :: Word8)
+ pure buf
+
foreign import ccall unsafe "mkCostCentre"
c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
#else
=====================================
m4/fptools_set_platform_vars.m4
=====================================
@@ -77,9 +77,9 @@ dnl fi
# compiler's target platform.
AC_DEFUN([FPTOOLS_OVERRIDE_PLATFORM_FROM_BOOTSTRAP],
[
- if test "$bootstrap_target" != ""
+ if test "$bootstrap_$1" != ""
then
- $1=$bootstrap_target
+ $1=$bootstrap_$1
echo "$1 platform inferred as: [$]$1"
else
echo "Can't work out $1 platform"
=====================================
m4/ghc_toolchain.m4
=====================================
@@ -136,8 +136,10 @@ dnl and that we must compile ghc-toolchain before invoking it
AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[
case "$1" in
YES)
- # We're configuring the bindist, and the binary is already available
- GHC_TOOLCHAIN_BIN="bin/ghc-toolchain-bin"
+ # We're configuring the bindist, and the binary is already available.
+ # For cross-compilation bindists, Hadrian names the binary with the
+ # cross-compile prefix (e.g. riscv64-linux-gnu-ghc-toolchain-bin).
+ GHC_TOOLCHAIN_BIN="bin/${CrossCompilePrefix}ghc-toolchain-bin"
;;
NO)
# We're in the source tree, so compile ghc-toolchain
=====================================
testsuite/tests/driver/T26435.ghc.stderr
=====================================
@@ -0,0 +1,5 @@
+when making flags consistent: warning: [GHC-74335] [-Winconsistent-flags (in -Wdefault)]
+ -finfo-table-map is incompatible with -fllvm and is disabled (See #26435)
+
+[1 of 2] Compiling Main ( T26435.hs, T26435.o )
+[2 of 2] Linking T26435
=====================================
testsuite/tests/driver/T26435.hs
=====================================
@@ -0,0 +1,5 @@
+module Main where
+import GHC.InfoProv
+
+main :: IO ()
+main = print =<< whereFrom main
=====================================
testsuite/tests/driver/T26435.stdout
=====================================
@@ -0,0 +1 @@
+Nothing
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -337,3 +337,4 @@ test('T25382', normal, makefile_test, [])
test('T26018', req_c, makefile_test, [])
test('T24120', normal, compile, ['-Wunused-packages -hide-all-packages -package base -package system-cxx-std-lib'])
test('T26551', [extra_files(['T26551.hs'])], makefile_test, [])
+test('T26435', [only_ways(['llvm'])], warn_and_run, ['-finfo-table-map'])
=====================================
testsuite/tests/driver/linkwhole/Main.hs
=====================================
@@ -1,9 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Exception
import Control.Monad
+import Data.ByteString.Short (ShortByteString)
import Foreign
@@ -15,7 +17,7 @@ import GHCi.ObjLink
rotateSO
:: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a)))
- -> String
+ -> ShortByteString
-> (Maybe FilePath, FilePath)
-> IO a
rotateSO dynamicCall symName (old, newDLL) = do
=====================================
testsuite/tests/ghci/should_run/T18064.script
=====================================
@@ -1,2 +1,3 @@
+:set -XOverloadedStrings
import GHCi.ObjLink
lookupClosure "blah"
=====================================
testsuite/tests/rts/KeepCafsMain.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Main (main) where
import Foreign
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1334,6 +1334,13 @@ class DyLD {
}
return 0;
}
+
+ lookupSymbolPtr(symPtr, symLen) {
+ const sym = new TextDecoder("utf-8", { fatal: true }).decode(
+ new Uint8Array(this.#memory.buffer, symPtr, symLen)
+ );
+ return this.lookupSymbol(sym);
+ }
}
// The main entry point of dyld that may be run on node/browser, and
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/720af979b34259c300ff227c0eebee…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/720af979b34259c300ff227c0eebee…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
07 Apr '26
Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC
Commits:
0a767c33 by Simon Peyton Jones at 2026-04-07T17:43:00+01:00
Wibble
- - - - -
1 changed file:
- compiler/GHC/Types/Name.hs
Changes:
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -668,10 +668,12 @@ stableNameCmp (Name { n_sort = s1, n_occ = occ1 })
-- The ordinary compare on OccNames is lexicographic
where
-- Later constructors are bigger
+ -- Compare External and KnownKey solely module
sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2
+ sort_cmp (External m1) (KnownKey m2) = m1 `stableModuleCmp` m2
sort_cmp (External {}) _ = LT
- sort_cmp (KnownKey {}) (External {}) = GT
+ sort_cmp (KnownKey m1) (External m2) = m1 `stableModuleCmp` m2
sort_cmp (KnownKey m1) (KnownKey m2) = m1 `stableModuleCmp` m2
sort_cmp (KnownKey {}) _ = LT
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a767c33d522f24d81e8626d329c97b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a767c33d522f24d81e8626d329c97b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
07 Apr '26
Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC
Commits:
d5e3ac97 by Simon Peyton Jones at 2026-04-07T17:33:40+01:00
More
- - - - -
13 changed files:
- compiler/GHC/Builtin.hs
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/RdrNames.hs
- compiler/GHC/Builtin/Names/TH.hs → compiler/GHC/Builtin/TH.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Errors/Ppr.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/ghc.cabal.in
- libraries/base/src/GHC/KnownKeyNames.hs
- libraries/ghc-internal/src/GHC/Internal/Base.hs
Changes:
=====================================
compiler/GHC/Builtin.hs
=====================================
@@ -21,7 +21,8 @@
module GHC.Builtin (
-- * Main exports
wiredInNames, wiredInIds, ghcPrimIds,
- knownKeyTable, knownKeyOccMap, knownKeyUniqMap, knownKeyOccName,
+ knownKeyTable, knownKeyOccMap, knownKeyUniqMap,
+ knownKeyOccName, knownKeyOccName_maybe,
knownKeyRdrName, knownOccRdrName, knownVarOccRdrName,
-- * Known-key names
@@ -51,7 +52,7 @@ import GHC.Builtin.PrimOps.Ids
import GHC.Builtin.Types
import GHC.Builtin.Types.Literals ( typeNatTyCons )
import GHC.Builtin.Types.Prim
-import GHC.Builtin.Names.TH ( templateHaskellNames, thKnownKeyTable )
+import GHC.Builtin.TH ( templateHaskellNames, thKnownKeyTable )
import GHC.Builtin.Names( basicKnownKeyTable, basicKnownKeyNames )
import GHC.Builtin.Names( charDataConKey, intDataConKey, numericClassKeys, standardClassKeys )
@@ -84,6 +85,7 @@ import GHC.Unit.Module.ModIface (IfaceExport)
import GHC.Unit.Module.Warnings
import GHC.Data.List.SetOps
+import GHC.Data.Maybe( orElse )
import Control.Applicative ((<|>))
import Data.Maybe
@@ -351,10 +353,14 @@ knownKeyTable = basicKnownKeyTable ++
knownKeyOccName :: HasDebugCallStack => KnownKey -> OccName
-- Find the OccName from the KnownKey,
-- by looking in the knownKeyUniqMap
-knownKeyOccName std_uniq
- = case lookupUFM knownKeyUniqMap std_uniq of
- Just occ -> occ
- Nothing -> pprPanic "knownKeyOccName" (pprKnownKey std_uniq)
+knownKeyOccName key
+ = knownKeyOccName_maybe key `orElse`
+ pprPanic "knownKeyOccName" (pprKnownKey key)
+
+knownKeyOccName_maybe :: HasDebugCallStack
+ => KnownKey -> Maybe OccName
+knownKeyOccName_maybe key
+ = lookupUFM knownKeyUniqMap key
knownKeyRdrName :: KnownKey -> RdrName
knownKeyRdrName key = knownOccRdrName (knownKeyOccName key)
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -1261,7 +1261,7 @@ hasFieldClassKey = mkPreludeClassUnique 50
---------------- Template Haskell -------------------
--- GHC.Builtin.Names.TH: USES ClassUniques 200-299
+-- GHC.Builtin.TH: USES ClassUniques 200-299
-----------------------------------------------------
{-
@@ -1507,7 +1507,7 @@ multMulTyConKey :: KnownKey
multMulTyConKey = mkPreludeTyConUnique 199
---------------- Template Haskell -------------------
--- GHC.Builtin.Names.TH: USES TyConUniques 200-299
+-- GHC.Builtin.TH: USES TyConUniques 200-299
-----------------------------------------------------
----------------------- SIMD ------------------------
@@ -1734,7 +1734,7 @@ naturalNBDataConKey = mkPreludeDataConUnique 124
---------------- Template Haskell -------------------
--- GHC.Builtin.Names.TH: USES DataUniques 200-250
+-- GHC.Builtin.TH: USES DataUniques 200-250
-----------------------------------------------------
@@ -1943,7 +1943,7 @@ proxyHashKey :: KnownKey
proxyHashKey = mkPreludeMiscIdUnique 502
---------------- Template Haskell -------------------
--- GHC.Builtin.Names.TH: USES IdUniques 200-499
+-- GHC.Builtin.TH: USES IdUniques 200-499
-----------------------------------------------------
-- Used to make `Typeable` dictionaries
=====================================
compiler/GHC/Builtin/RdrNames.hs
=====================================
@@ -18,7 +18,7 @@ import GHC.Builtin
import GHC.Builtin.PrimOps
import GHC.Builtin.Types -- A bunch of wired-in TyCons and DataCons
import GHC.Builtin.PrimOps.Ids (primOpId)
-import GHC.Builtin.Names.TH( unsafeCodeCoerceName, liftTypedName )
+import GHC.Builtin.TH( unsafeCodeCoerceName, liftTypedName )
import GHC.Builtin.Names
import GHC.Types.Name.Reader( RdrName, mkVarUnqual, getRdrName
=====================================
compiler/GHC/Builtin/Names/TH.hs → compiler/GHC/Builtin/TH.hs
=====================================
@@ -4,7 +4,7 @@
-- %* *
-- %************************************************************************
-module GHC.Builtin.Names.TH where
+module GHC.Builtin.TH where
import GHC.Prelude ()
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -53,7 +53,7 @@ import GHC.Core.Make
import GHC.Core.Utils
import GHC.Builtin.Names
-import GHC.Builtin.Names.TH
+import GHC.Builtin.TH
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
=====================================
compiler/GHC/Iface/Errors/Ppr.hs
=====================================
@@ -24,6 +24,7 @@ module GHC.Iface.Errors.Ppr
import GHC.Prelude
+import GHC.Builtin( knownKeyOccName_maybe )
import GHC.Types.Error
import GHC.Types.Hint.Ppr () -- Outputable GhcHint
import GHC.Types.Error.Codes
@@ -295,12 +296,20 @@ interfaceErrorDiagnostic opts = \ case
CircularImport mod ->
text "Circular imports: module" <+> quotes (ppr mod)
<+> text "depends on itself"
+
MissingKnownKey1 key -> hang (text "Could not find known key" <+> quotes (pprKnownKey key))
- 2 (text "in the exports of GHC.KnownKeys")
+ 2 (vcat [ text "in the exports of GHC.KnownKeys"
+ , text "occname:" <+> pp_occ (knownKeyOccName_maybe key) ])
+ where
+ pp_occ (Just occ) = ppr occ
+ pp_occ Nothing = text "Yikes: that key isn't in the known-key table"
+
MissingKnownKey2 key -> hang (text "Could not find known key" <+> quotes (pprKnownKey key))
2 (text "in the static known-key table")
+
MissingKnownKey3 occ -> hang (text "Could not find known occurrence" <+> quotes (ppr occ))
2 (text "in the exports of GHC.KnownKeys")
+
KnownKeyScopeError occ gres
| null gres
-> hang (text "Could not find known-key entity" <+> quotes (ppr occ))
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -51,7 +51,7 @@ import GHC.Data.FastString
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Driver.Hooks
-import GHC.Builtin.Names.TH
+import GHC.Builtin.TH
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr )
import {-# SOURCE #-} GHC.Tc.Gen.Splice
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -73,7 +73,7 @@ import GHC.Types.Var.Set
import GHC.Builtin.Names
import GHC.Builtin.RdrNames
-import GHC.Builtin.Names.TH
+import GHC.Builtin.TH
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -66,7 +66,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Var.Set
import GHC.Builtin.Names
-import GHC.Builtin.Names.TH (liftClassKey)
+import GHC.Builtin.TH (liftClassKey)
import GHC.Utils.Misc
import GHC.Utils.Outputable
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -68,7 +68,7 @@ import GHC.Core.TyCo.Rep as TyCoRep
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv as InstEnv
-import GHC.Builtin.Names.TH
+import GHC.Builtin.TH
import GHC.Builtin.Names
import GHC.Builtin.Types
@@ -864,7 +864,7 @@ tcUntypedSplice q splice_name (XUntypedSplice ils)
-- lift :: Quote m' => a -> m' Exp
; lift <- setSrcSpan (getLocA id_name) $
newKnownOccMethod (ImplicitLiftOrigin ils)
- GHC.Builtin.Names.TH.liftIdOcc
+ GHC.Builtin.TH.liftIdOcc
[getRuntimeRep id_ty, id_ty]
; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) v_expr'
@@ -890,7 +890,7 @@ tcPendingSpliceTyped q splice_name (XTypedSplice ils) res_ty
-- lift :: Quote m' => a -> m' Exp
; lift <- setSrcSpan (getLocA id_name) $
newKnownOccMethod (ImplicitLiftOrigin ils)
- GHC.Builtin.Names.TH.liftIdOcc
+ GHC.Builtin.TH.liftIdOcc
[rep, res_ty]
; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) v_expr'
; return (PendingTcSplice splice_name res) }
@@ -3108,7 +3108,7 @@ tcGetInterp = do
-- Note [Hard-wiring in-tree template-haskell for desugaring quotes]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- To desugar Template Haskell quotes, GHC needs to wire in a bunch of Names in the
--- `ghc-internal` library as Note [Known-key names], in GHC.Builtin.Names.TH.
+-- `ghc-internal` library as Note [Known-key names], in GHC.Builtin.TH.
-- Consider
-- > foo :: Q Exp
-- > foo = [| unwords ["hello", "world"] |]
=====================================
compiler/ghc.cabal.in
=====================================
@@ -201,11 +201,11 @@ Library
GHC
GHC.Builtin
GHC.Builtin.Names
- GHC.Builtin.Names.TH
GHC.Builtin.PrimOps
GHC.Builtin.PrimOps.Casts
GHC.Builtin.PrimOps.Ids
GHC.Builtin.RdrNames
+ GHC.Builtin.TH
GHC.Builtin.Types
GHC.Builtin.Types.Literals
GHC.Builtin.Types.Prim
=====================================
libraries/base/src/GHC/KnownKeyNames.hs
=====================================
@@ -81,7 +81,7 @@ module GHC.KnownKeyNames
, arr, (>>>), first, app, (|||), loop
-- IO
- , thenIO, bindIO, returnIO, print
+ , IO, thenIO, bindIO, returnIO, print
-- Unsatisfiable
, Unsatisfiable, unsatisfiable
@@ -112,8 +112,11 @@ module GHC.KnownKeyNames
, integerComplement, integerBit#, integerTestBit#, integerShiftL#, integerShiftR#
-- Template Haskell
- , Q, Name, FieldExp, Decs, TH.Type, FunDep
+ , Q, DecsQ, ExpQ, TypeQ, PatQ
+ , Name, Decs, TH.Type, FunDep
, Pred, Code, InjectivityAnn, Overlap, ModName, QuasiQuoter
+ , Stmt, Con, BangType, VarBangType, RuleBndr, TySynEqn, Role, DerivClause
+ , Kind, TyVarBndrUnit, TyVarBndrSpec, TyVarBndrVis, DerivStrategy
, sequenceQ, newName, mkName, mkNameG_v, mkNameG_d, mkNameG_tc, mkNameG_fld, mkNameL
, mkNameQ, mkNameS, mkModName, unType, unTypeCode, unsafeCodeCoerce
, lift, liftString, liftTyped
=====================================
libraries/ghc-internal/src/GHC/Internal/Base.hs
=====================================
@@ -453,7 +453,7 @@ W6:
in GHC.HsToCore.Foreign.Wasm.
A complete list could probably be made by going through the known-key
-names in GHC.Builtin.Names and GHC.Builtin.Names.TH. To test whether
+names in GHC.Builtin.Names and GHC.Builtin.TH. To test whether
the transitive imports are sufficient for any single module, instruct
the build system to build /only/ that module in stage 2. For example,
a command to check whether the transitive imports for GHC.Internal.Maybe
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5e3ac9746cb91a984c3b354fe03c01…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5e3ac9746cb91a984c3b354fe03c01…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: packaging: correctly propagate build/host/target to bindist configure script
by Marge Bot (＠marge-bot) 07 Apr '26
by Marge Bot (＠marge-bot) 07 Apr '26
07 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
3f40c16e by Matthew Pickering at 2026-04-07T11:57:18-04:00
packaging: correctly propagate build/host/target to bindist configure script
At the moment the host and target which we will produce a compiler for
is fixed at the initial configure time. Therefore we need to persist
the choice made at this time into the installation bindist as well so we
look for the right tools, with the right prefixes at install time.
In the future, we want to provide a bit more control about what kind of
bindist we produce so the logic about what the host/target will have to
be written by hadrian rather than persisted by the configure script. In
particular with cross compilers we want to either build a normal stage 2
cross bindist or a stage 3 bindist, which creates a bindist which has a
native compiler for the target platform.
Fixes #21970
Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com>
- - - - -
971f0fab by Sven Tennie at 2026-04-07T11:57:18-04:00
Cross --host and --target no longer required for cross (#21970)
We set sane defaults in the configure script. Thus, these paramenters
aren't required any longer.
- - - - -
7b618251 by Sven Tennie at 2026-04-07T11:57:18-04:00
ci: Define USER_CONF_CC_OPTS_STAGE2 for aarch64/mingw
ghc-toolchain doesn't see $CONF_CC_OPTS_STAGE2 when the bindist gets
configured. So, the hack to override the compiler gets lost.
- - - - -
4d8586fe by Cheng Shao at 2026-04-07T11:57:20-04:00
compiler: improve Binary instance of Array
This patch improves the `Binary` instance of `Array`:
- We no longer allocate intermediate lists. When serializing an
`Array`, we iterate over the elements directly; when deserializing
it, we allocate the result `Array` and fill it in a loop.
- Now we only serialize the array bounds tuple; the length field is
not needed.
Closes #27109.
- - - - -
0f7bbd95 by Cheng Shao at 2026-04-07T11:57:21-04:00
ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages
This patch refactors ghci to use `ShortByteString` for
`LookupSymbol`/`LookupSymbolInDLL`/`LookupClosure` messages as the
first part of #27147.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
720af979 by Cheng Shao at 2026-04-07T11:57:21-04:00
ghci: use ShortByteString for MkCostCentres message
This patch refactors ghci to use `ShortByteString` for `MkCostCentres`
messages as a first part of #27147. This also considerably lowers the
memory overhead of breakpoints when cost center profiling is enabled.
-------------------------
Metric Decrease:
interpreter_steplocal
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
24 changed files:
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Utils/Binary.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Default.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/ObjLink.hs
- libraries/ghci/GHCi/Run.hs
- m4/fptools_set_platform_vars.m4
- m4/ghc_toolchain.m4
- testsuite/tests/driver/linkwhole/Main.hs
- testsuite/tests/ghci/should_run/T18064.script
- testsuite/tests/rts/KeepCafsMain.hs
- utils/jsffi/dyld.mjs
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -628,20 +628,6 @@ function install_bindist() {
*)
read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}"
- if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then
- # We suppose that host target = build target.
- # By the fact above it is clearly turning out which host value is
- # for currently built compiler.
- # The fix for #21970 will probably remove this if-branch.
- local -r CROSS_HOST_GUESS=$($SHELL ./config.guess)
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_HOST_GUESS" )
-
- # FIXME: The bindist configure script shouldn't need to be reminded of
- # the target platform. See #21970.
- elif [ -n "${CROSS_TARGET:-}" ]; then
- args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" )
- fi
-
run ${CONFIGURE_WRAPPER:-} ./configure \
--prefix="$instdir" \
"${args[@]+"${args[@]}"}" || fail "bindist configure failed"
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -1316,6 +1316,13 @@ cross_jobs = [
-- unexpected triple.
. setVariable "CFLAGS" cflags
. setVariable "CONF_CC_OPTS_STAGE2" cflags
+ -- For bindists `$USER_CONF_CC_OPTS_STAGE2` is not automatically set
+ -- to `$CONF_CC_OPTS_STAGE2`. But, we still have to deal with the hack
+ -- mentioned in the previous comment.
+ --
+ -- TODO: It would be nice to get rid of this hack. This would probably
+ -- involve setting the toolchain up in a different way.
+ . setVariable "USER_CONF_CC_OPTS_STAGE2" cflags
) where
llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-"
cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt"
=====================================
.gitlab/jobs.yaml
=====================================
@@ -331,6 +331,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -412,6 +413,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres"
}
},
@@ -1123,6 +1125,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
@@ -1205,6 +1208,7 @@
"STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings",
"STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip",
"TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm",
+ "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt",
"WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres",
"XZ_OPT": "-9"
}
=====================================
compiler/GHC/ByteCode/Breakpoints.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Name.Occurrence
import Control.DeepSeq
+import qualified Data.ByteString.Short as SBS
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
@@ -235,8 +236,8 @@ getBreakVars = getBreakXXX modBreaks_vars
getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]
getBreakDecls = getBreakXXX modBreaks_decls
--- | Get the decls for this breakpoint
-getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String))
+-- | Get the cost centre info for this breakpoint
+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (SBS.ShortByteString, SBS.ShortByteString)
getBreakCCS = getBreakXXX modBreaks_ccs
-- | Internal utility to access a ModBreaks field at a particular breakpoint index
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -405,7 +405,7 @@ loadExternalPlugins ps = do
symbol
| null unit = ztmp
| otherwise = zEncodeString unit ++ "_" ++ ztmp
- plugin <- lookupSymbol symbol >>= \case
+ plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case
Nothing -> pprPanic "loadExternalPlugins"
(vcat [ text "Symbol not found"
, text " Library path: " <> text path
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.HsToCore.Breakpoints
import GHC.Prelude
import Data.Array
+import qualified Data.ByteString.Short as SBS
import GHC.HsToCore.Ticks (Tick (..))
import GHC.Data.SizedSeq
@@ -31,6 +32,7 @@ import GHC.Types.Name (OccName)
import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..))
import GHC.Unit.Module (Module)
import GHC.Utils.Binary
+import GHC.Utils.Encoding (utf8EncodeShortByteString)
import GHC.Utils.Outputable
import Data.List (intersperse)
import Data.Coerce
@@ -59,7 +61,7 @@ data ModBreaks
, modBreaks_decls :: !(Array BreakTickIndex [String])
-- ^ An array giving the names of the declarations enclosing each breakpoint.
-- See Note [Field modBreaks_decls]
- , modBreaks_ccs :: !(Array BreakTickIndex (String, String))
+ , modBreaks_ccs :: !(Array BreakTickIndex (SBS.ShortByteString, SBS.ShortByteString))
-- ^ Array pointing to cost centre info for each breakpoint;
-- actual 'CostCentre' allocation is done at link-time.
, modBreaks_module :: !Module
@@ -89,8 +91,8 @@ mkModBreaks interpreterProfiled modl extendedMixEntries
| interpreterProfiled =
listArray
(0, count - 1)
- [ ( concat $ intersperse "." $ tick_path t,
- renderWithContext defaultSDocContext $ ppr $ tick_loc t
+ [ ( utf8EncodeShortByteString $ concat $ intersperse "." $ tick_path t,
+ utf8EncodeShortByteString $ renderWithContext defaultSDocContext $ ppr $ tick_loc t
)
| t <- entries
]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -1846,7 +1846,7 @@ allocateCCS interp ce mbss
ccs <- {- one ccs ptr per tick index -}
mkCostCentres
interp
- (moduleNameString $ moduleName modBreaks_module)
+ (moduleNameFS $ moduleName modBreaks_module)
(elems modBreaks_ccs)
return $ M.fromList $
zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..]
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -107,6 +107,7 @@ import Control.Monad.IO.Class
import Control.Monad.Catch as MC (mask)
import Data.Binary
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Short as SBS
import Foreign hiding (void)
import qualified GHC.Exts.Heap as Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
@@ -352,9 +353,15 @@ evalStringToIOString interp fhv str =
mallocData :: Interp -> ByteString -> IO (RemotePtr ())
mallocData interp bs = interpCmd interp (MallocData bs)
-mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
-mkCostCentres interp mod ccs =
- interpCmd interp (MkCostCentres mod ccs)
+mkCostCentres :: Interp -> FastString -> [(SBS.ShortByteString, SBS.ShortByteString)] -> IO [RemotePtr CostCentre]
+mkCostCentres interp mod ccs = do
+ rp <- modifyMVar (interpStringCache interp) $ \fs_env ->
+ case lookupFsEnv fs_env mod of
+ Just rp -> pure (fs_env, rp)
+ Nothing -> do
+ rp <- fmap head $ interpCmd interp $ MallocStrings [bytesFS mod]
+ pure (extendFsEnv fs_env mod rp, rp)
+ interpCmd interp $ MkCostCentres rp ccs
-- | Create a set of BCOs that may be mutually recursive.
createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef]
@@ -413,7 +420,7 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId
evalBreakpointToId eval_break =
let
mkUnitId u = fsToUnit $ mkFastStringShortByteString u
- toModule u n = mkModule (mkUnitId u) (mkModuleName n)
+ toModule u n = mkModule (mkUnitId u) (mkModuleNameFS (mkFastStringShortByteString n))
in
InternalBreakpointId
{ ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break)
@@ -465,27 +472,27 @@ lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbol interp str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbolInDLL interp dll str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
+ sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
-- wasm dyld doesn't track which symbol comes from which .so
ExtWasm {} -> lookupSymbol interp str
@@ -519,7 +526,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is -
lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
lookupClosure interp str =
- interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
+ interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str)))
-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -142,6 +142,7 @@ import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
+import Data.Array.Base (traverseArray_, unsafeFreezeIOArray)
import Data.Array.IO
import Data.Array.Unsafe
import qualified Data.Binary as Binary
@@ -970,11 +971,12 @@ instance Binary a => Binary (NonEmpty a) where
instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
put_ bh arr = do
put_ bh $ bounds arr
- put_ bh $ elems arr
+ traverseArray_ (put_ bh) arr
+
get bh = do
- bounds <- get bh
- xs <- get bh
- return $ listArray bounds xs
+ (l, u) <- get bh
+ marr <- newGenArray (l, u) $ \_ -> get bh
+ unsafeFreezeIOArray marr
instance Binary a => Binary (SmallArray a) where
put_ bh sa = do
=====================================
configure.ac
=====================================
@@ -255,6 +255,7 @@ if test "${WithGhc}" != ""
then
bootstrap_host=`"${WithGhc}" --info | grep '^ ,("Host platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
bootstrap_target=`"${WithGhc}" --info | grep '^ ,("Target platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'`
+ bootstrap_build="$bootstrap_host"
if test "$bootstrap_host" != "$bootstrap_target"
then
echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work"
@@ -394,8 +395,33 @@ then
else
TargetPlatformFull="${target_alias}"
fi
+
+if test -z "${build_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ BuildPlatformFull="${build}"
+else
+ BuildPlatformFull="${build_alias}"
+fi
+if test -z "${host_alias}"
+then
+ # --target wasn't given; use result from AC_CANONICAL_TARGET
+ HostPlatformFull="${host}"
+else
+ HostPlatformFull="${host_alias}"
+fi
+if test "$CrossCompiling" = "YES"
+then
+ # Use value passed by user from --target=
+ CrossCompilePrefix="${TargetPlatformFull}-"
+else
+ CrossCompilePrefix=""
+fi
+
AC_SUBST(CrossCompiling)
AC_SUBST(TargetPlatformFull)
+AC_SUBST(BuildPlatformFull)
+AC_SUBST(HostPlatformFull)
dnl ** Which gcc to use?
dnl --------------------------------------------------------------
=====================================
distrib/configure.ac.in
=====================================
@@ -15,7 +15,18 @@ dnl--------------------------------------------------------------------
dnl * Deal with arguments telling us gmp is somewhere odd
dnl--------------------------------------------------------------------
+build_alias=@BuildPlatformFull@
+host_alias=@HostPlatformFull@
+target_alias=@TargetPlatformFull@
+
+dnl this makes sure `./configure --target=<cross-compile-target>`
+dnl works as expected, since we're slightly modifying how Autoconf
+dnl interprets build/host/target and how this interacts with $CC tests
+test -n "$target_alias" && ac_tool_prefix=$target_alias-
+
dnl Various things from the source distribution configure
+bootstrap_build=@BuildPlatform@
+bootstrap_host=@HostPlatform@
bootstrap_target=@TargetPlatform@
bootstrap_llvm_target=@LlvmTarget@
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -50,6 +50,9 @@ use-ghc-toolchain = @EnableGhcToolchain@
# And we can reconstruct the platform info using targetPlatformTriple
# Q: What is TargetPlatformFull?
target-platform-full = @TargetPlatformFull@
+build-platform-full = @BuildPlatformFull@
+host-platform-full = @HostPlatformFull@
+
cross-compiling = @CrossCompiling@
=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -69,6 +69,8 @@ data Setting = CursesIncludeDir
| ProjectPatchLevel2
| SystemGhc
| TargetPlatformFull
+ | BuildPlatformFull
+ | HostPlatformFull
| BourneShell
| EmsdkVersion
@@ -107,6 +109,8 @@ setting key = lookupSystemConfig $ case key of
ProjectPatchLevel2 -> "project-patch-level2"
SystemGhc -> "system-ghc"
TargetPlatformFull -> "target-platform-full"
+ BuildPlatformFull -> "build-platform-full"
+ HostPlatformFull -> "host-platform-full"
BourneShell -> "bourne-shell"
EmsdkVersion -> "emsdk-version"
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -424,6 +424,8 @@ bindistRules = do
, interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
, interpolateVar "TargetHasLibm" $ yesNo <$> getTarget tgtHasLibm
, interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+ , interpolateVar "BuildPlatform" $ interp $ queryBuild targetPlatformTriple
+ , interpolateVar "HostPlatform" $ interp $ queryHost targetPlatformTriple
, interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian
, interpolateVar "TargetWordSize" $ getTarget wordSize
, interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised
@@ -431,6 +433,9 @@ bindistRules = do
, interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
, interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
, interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base
+ , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull)
+ , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull)
+ , interpolateVar "HostPlatformFull" (setting HostPlatformFull)
]
where
interp = interpretInContext (semiEmptyTarget Stage2)
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -122,7 +122,11 @@ stage0Packages = do
-- for upper stages. As we only use stage0 to build upper stages,
-- this should be fine.
++ [ terminfo | not windowsHost, not cross ]
- ++ [ timeout | windowsHost ]
+ ++ [ timeout | windowsHost ]
+ -- Due to some weird logic, we need ghcToolchainBin in Stage0 and
+ -- Stage1 packages if we're cross compiling. "Stage2 cross-compilers"
+ -- will solve this.
+ ++ [ ghcToolchainBin | cross ]
-- | Packages built in 'Stage1' by default. You can change this in "UserSettings".
stage1Packages :: Action [Package]
@@ -181,12 +185,12 @@ stage1Packages = do
, transformers
, unlit
, xhtml
+ , ghcToolchainBin
, if winTarget then win32 else unix
]
, when (not cross)
[ hpcBin
, runGhc
- , ghcToolchainBin
]
, when (winTarget && not cross)
[ -- See Note [Hadrian's ghci-wrapper package]
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -86,9 +86,9 @@ data Message a where
-- These all invoke the corresponding functions in the RTS Linker API.
InitLinker :: Message ()
- LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
- LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
- LookupClosure :: String -> Message (Maybe HValueRef)
+ LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
+ LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef)
LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL])
LoadArchive :: String -> Message () -- error?
LoadObj :: String -> Message () -- error?
@@ -162,8 +162,8 @@ data Message a where
-- | Create a set of CostCentres with the same module name
MkCostCentres
- :: String -- module, RemotePtr so it can be shared
- -> [(String,String)] -- (name, SrcSpan)
+ :: !(RemotePtr ()) -- ModuleName
+ -> ![(BS.ShortByteString, BS.ShortByteString)] -- (name, SrcSpan)
-> Message [RemotePtr CostCentre]
-- | Show a 'CostCentreStack' as a @[String]@
@@ -430,7 +430,7 @@ data EvalStatus_ a b
instance Binary a => Binary (EvalStatus_ a b)
data EvalBreakpoint = EvalBreakpoint
- { eb_info_mod :: String -- ^ Breakpoint info module
+ { eb_info_mod :: !BS.ShortByteString -- ^ Breakpoint info module
, eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id
, eb_info_index :: Int -- ^ Breakpoint info index
}
=====================================
libraries/ghci/GHCi/ObjLink.hs
=====================================
@@ -31,6 +31,8 @@ import GHCi.RemoteTypes
import GHCi.Message (LoadedDLL)
import Control.Exception (throwIO, ErrorCall(..))
import Control.Monad ( when )
+import qualified Data.ByteString.Short as BS
+import Data.Char (ord)
import Data.Foldable
import Foreign.C
import Foreign.Marshal.Alloc ( alloca, free )
@@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f
purgeObj :: String -> IO ()
purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f
-lookupSymbol :: String -> IO (Maybe (Ptr a))
-lookupSymbol sym = do
- r <- js_lookupSymbol $ toJSString sym
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
+lookupSymbol sym@(BS.SBS ba#) = do
+ r <- js_lookupSymbolPtr ba# (BS.length sym)
evaluate $ if r == nullPtr then Nothing else Just r
-foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)"
- js_lookupSymbol :: JSString -> IO (Ptr a)
+foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)"
+ js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL _ _ = pure Nothing
resolveObjs :: IO Bool
@@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO ()
initObjLinker RetainCAFs = c_initLinker_ 1
initObjLinker _ = c_initLinker_ 0
-lookupSymbol :: String -> IO (Maybe (Ptr a))
+lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
+lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
lookupSymbolInDLL dll str_in = do
let str = prefixUnderscore str_in
- withCAString str $ \c_str -> do
+ BS.useAsCString str $ \c_str -> do
addr <- c_lookupSymbolInNativeObj dll c_str
if addr == nullPtr
then return Nothing
else return (Just addr)
-prefixUnderscore :: String -> String
+prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString
prefixUnderscore
- | cLeadingUnderscore = ('_':)
+ | cLeadingUnderscore = BS.cons (fromIntegral (ord '_'))
| otherwise = id
-- | loadDLL loads a dynamic library using the OS's native linker
@@ -298,7 +300,7 @@ isWindowsHost = False
#endif
-lookupClosure :: String -> IO (Maybe HValueRef)
+lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupClosure str = do
m <- lookupSymbol str
case m of
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -34,7 +34,7 @@ import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
-import qualified Data.ByteString.Short as BS
+import qualified Data.ByteString.Short.Internal as BS
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import qualified GHC.Exts.Heap as Heap
@@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o
foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #)
-lookupJSClosure' :: String -> IO Int
-lookupJSClosure' str = withCString str $ \cstr -> IO (\s ->
+lookupJSClosure' :: BS.ShortByteString -> IO Int
+lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s ->
case lookupJSClosure# cstr s of
(# s', r #) -> (# s', I# r #))
-lookupJSClosure :: String -> IO (Maybe HValueRef)
+lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
lookupJSClosure str = lookupJSClosure' str >>= \case
0 -> pure Nothing
r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r))))
@@ -359,7 +359,7 @@ withBreakAction opts breakMVar statusMVar mtid act
if is_exception
then pure Nothing
else do
- info_mod <- peekCString (Ptr info_mod#)
+ info_mod <- BS.packCString (Ptr info_mod#)
info_mod_uid <- BS.packCString (Ptr info_mod_uid#)
pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#)))
putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs
@@ -434,17 +434,24 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do
pokeElemOff (ptr :: Ptr CChar) len 0
return (castRemotePtr (toRemotePtr ptr))
-mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre]
#if defined(PROFILING)
mkCostCentres mod ccs = do
- c_module <- newCString mod
+ let c_module = fromRemotePtr $ castRemotePtr mod
mapM (mk_one c_module) ccs
where
mk_one c_module (decl_path,srcspan) = do
- c_name <- newCString decl_path
- c_srcspan <- newCString srcspan
+ c_name <- newCStringFromSBS decl_path
+ c_srcspan <- newCStringFromSBS srcspan
toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan
+ newCStringFromSBS sbs = do
+ let len = BS.length sbs
+ buf <- mallocBytes $ len + 1
+ BS.copyToPtr sbs 0 buf (fromIntegral len)
+ pokeByteOff buf len (0 :: Word8)
+ pure buf
+
foreign import ccall unsafe "mkCostCentre"
c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)
#else
=====================================
m4/fptools_set_platform_vars.m4
=====================================
@@ -77,9 +77,9 @@ dnl fi
# compiler's target platform.
AC_DEFUN([FPTOOLS_OVERRIDE_PLATFORM_FROM_BOOTSTRAP],
[
- if test "$bootstrap_target" != ""
+ if test "$bootstrap_$1" != ""
then
- $1=$bootstrap_target
+ $1=$bootstrap_$1
echo "$1 platform inferred as: [$]$1"
else
echo "Can't work out $1 platform"
=====================================
m4/ghc_toolchain.m4
=====================================
@@ -136,8 +136,10 @@ dnl and that we must compile ghc-toolchain before invoking it
AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[
case "$1" in
YES)
- # We're configuring the bindist, and the binary is already available
- GHC_TOOLCHAIN_BIN="bin/ghc-toolchain-bin"
+ # We're configuring the bindist, and the binary is already available.
+ # For cross-compilation bindists, Hadrian names the binary with the
+ # cross-compile prefix (e.g. riscv64-linux-gnu-ghc-toolchain-bin).
+ GHC_TOOLCHAIN_BIN="bin/${CrossCompilePrefix}ghc-toolchain-bin"
;;
NO)
# We're in the source tree, so compile ghc-toolchain
=====================================
testsuite/tests/driver/linkwhole/Main.hs
=====================================
@@ -1,9 +1,11 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main (main) where
import Control.Exception
import Control.Monad
+import Data.ByteString.Short (ShortByteString)
import Foreign
@@ -15,7 +17,7 @@ import GHCi.ObjLink
rotateSO
:: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a)))
- -> String
+ -> ShortByteString
-> (Maybe FilePath, FilePath)
-> IO a
rotateSO dynamicCall symName (old, newDLL) = do
=====================================
testsuite/tests/ghci/should_run/T18064.script
=====================================
@@ -1,2 +1,3 @@
+:set -XOverloadedStrings
import GHCi.ObjLink
lookupClosure "blah"
=====================================
testsuite/tests/rts/KeepCafsMain.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Main (main) where
import Foreign
=====================================
utils/jsffi/dyld.mjs
=====================================
@@ -1334,6 +1334,13 @@ class DyLD {
}
return 0;
}
+
+ lookupSymbolPtr(symPtr, symLen) {
+ const sym = new TextDecoder("utf-8", { fatal: true }).decode(
+ new Uint8Array(this.#memory.buffer, symPtr, symLen)
+ );
+ return this.lookupSymbol(sym);
+ }
}
// The main entry point of dyld that may be run on node/browser, and
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7df6bd1694e8fe7c6a52673858639e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7df6bd1694e8fe7c6a52673858639e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/hadrian-persistent-flavour] 19 commits: Streamline expansions using HsExpansion (#25001)
by Sylvain Henry (＠hsyl20) 07 Apr '26
by Sylvain Henry (＠hsyl20) 07 Apr '26
07 Apr '26
Sylvain Henry pushed to branch wip/hadrian-persistent-flavour at Glasgow Haskell Compiler / GHC
Commits:
58009c14 by Apoorv Ingle at 2026-04-02T09:51:24+01:00
Streamline expansions using HsExpansion (#25001)
Notes added [Error Context Stack] [Typechecking by expansion: overview]
Notes updated Note [Expanding HsDo with XXExprGhcRn] [tcApp: typechecking applications]
-------------------------
Metric Decrease:
T9020
-------------------------
There are 2 key changes:
1. `HsExpand` datatype mediates between expansions
2. Replace `ErrCtxtM` to a simpler `HsCtxt` that does not depend on a `TidyEnv`
This has some consequences detailed below:
1. `HsExpand` datatype mediates between expansions
* Simplifies the implementations of `tcExpr` to work on `XExpr`
* Removes `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`.
* Removes the function `addHeadCtxt` as it is now mearly setting a location
* The function `tcValArgs` does its own argument number management
* move `splitHsTypes` out of `tcApp`
* Removes special case of tcBody from `tcLambdaMatches`
* Removes special case of `dsExpr` for `ExpandedThingTc`
* Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr`
* Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span`
* Remove `PopErrCtxt` from `XXExprGhcRn`
* `fun_orig` in tcInstFun depends on the SrcSpan of the head of the application chain (similar to addArgCtxt)
- it references the application chain head if it is user located, or
uses the error context stack as a fallback if it's a generated
location
* Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes
- Expressions wrapped around `GeneratedSrcSpan` are ignored and never added to the error context stack
- In Explicit list expansion `fromListN` is wrapped with a `GeneratedSrcSpan` with `GeneratedSrcSpanDetails` field to store the original srcspan
2. Replace `ErrCtxtM` to a simpler `HsCtxt` that does not depend on a `TidyEnv`
* Merge `HsThingRn` to `HsCtxt`
* Landmark Error messages are now just computed on the fly
* Make HsExpandedRn and HsExpandedTc payload a located HsExpr GhcRn
* `HsCtxt` are tidied and zonked at the end right before printing
Co-authored-by: simonpj <simon.peytonjones(a)gmail.com>
- - - - -
bc4b4487 by Zubin Duggal at 2026-04-03T14:22:27-04:00
driver: recognise .dyn_o as a valid object file to link if passed on the command line.
This allows plugins compiled with this suffix to run.
Fixes #24486
- - - - -
5ebb9121 by Simon Jakobi at 2026-04-03T14:23:11-04:00
Add regression test for #16145
Closes #16145.
- - - - -
c1fc1c44 by Simon Peyton Jones at 2026-04-03T19:56:07-04:00
Refactor eta-expansion in Prep
The Prep pass does eta-expansion but I found cases where it was
doing bad things. So I refactored and simplified it quite a bit.
In the new design
* There is no distinction between `rhs` and `body`; in particular,
lambdas can now appear anywhere, rather than just as the RHS of
a let-binding.
* This change led to a significant simplification of Prep, and
a more straightforward explanation of eta-expansion. See the new
Note [Eta expansion]
* The consequences is that CoreToStg needs to handle naked lambdas.
This is very easy; but it does need a unique supply, which forces
some simple refactoring. Having a unique supply to hand is probably
a good thing anyway.
- - - - -
21beda2c by Simon Peyton Jones at 2026-04-03T19:56:07-04:00
Clarify Note [Interesting dictionary arguments]
Ticket #26831 ended up concluding that the code for
GHC.Core.Opt.Specialise.interestingDict was good, but the
commments were a bit inadequate.
This commit improves the comments slightly.
- - - - -
3eaac1f2 by Simon Peyton Jones at 2026-04-03T19:56:07-04:00
Make inlining a bit more eager for overloaded functions
If we have
f d = ... (class-op d x y) ...
we should be eager to inline `f`, because that may change the
higher order call (class-op d x y) into a call to a statically
known function.
See the discussion on #26831.
Even though this does a bit /more/ inlining, compile times
decrease by an average of 0.4%.
Compile time changes:
DsIncompleteRecSel3(normal) 431,786,104 -2.2%
ManyAlternatives(normal) 670,883,768 -1.6%
ManyConstructors(normal) 3,758,493,832 -2.6% GOOD
MultilineStringsPerf(normal) 29,900,576 -2.8%
T14052Type(ghci) 1,047,600,848 -1.2%
T17836(normal) 392,852,328 -5.2%
T18478(normal) 442,785,768 -1.4%
T21839c(normal) 341,536,992 -14.1% GOOD
T3064(normal) 174,086,152 +5.3% BAD
T5631(normal) 506,867,800 +1.0%
hard_hole_fits(normal) 209,530,736 -1.3%
info_table_map_perf(normal) 19,523,093,184 -1.2%
parsing001(normal) 377,810,528 -1.1%
pmcOrPats(normal) 60,075,264 -0.5%
geo. mean -0.4%
minimum -14.1%
maximum +5.3%
Runtime changes
haddock.Cabal(normal) 27,351,988,792 -0.7%
haddock.base(normal) 26,997,212,560 -0.6%
haddock.compiler(normal) 219,531,332,960 -1.0%
Metric Decrease:
LinkableUsage01
ManyConstructors
T17949
T21839c
T13035
TcPlugin_RewritePerf
hard_hole_fits
Metric Increase:
T3064
- - - - -
5cbc2c82 by Matthew Pickering at 2026-04-03T19:57:02-04:00
bytecode: Add magic header/version to bytecode files
In order to avoid confusing errors when using stale interface files (ie
from an older compiler version), we add a simple header/version check
like the one for interface files.
Fixes #27068
- - - - -
d95a1936 by fendor at 2026-04-03T19:57:02-04:00
Add constants for bytecode in-memory buffer size
Introduce a common constant for the default size of the .gbc and
.bytecodelib binary buffer.
The buffer is by default set to 1 MB.
- - - - -
b822c30a by mangoiv at 2026-04-03T19:57:49-04:00
testsuite: filter stderr for static001 on darwin
This reactivates the test on x86_64 darwin as this should have been done
long ago and ignores warnings emitted by ranlib on newer version of the
darwin toolchain since they are benign. (no symbols for stub libraries)
Fixes #27116
- - - - -
28ce1f8a by Andreas Klebinger at 2026-04-03T19:58:44-04:00
Give the Data instance for ModuleName a non-bottom toConstr implementation.
I've also taken the liberty to add Note [Data.Data instances for GHC AST Types]
describing some of the uses of Data.Data I could find.
Fixes #27129
- - - - -
8ca41ffe by mangoiv at 2026-04-03T19:59:30-04:00
issue template: fix add bug label
- - - - -
3981db0c by Sylvain Henry at 2026-04-03T20:00:33-04:00
Add more canned GC functions for common register patterns (#27142)
Based on analysis of heap-check sites across the GHC compiler and Cabal,
the following patterns were not covered by existing canned GC functions
but occurred frequently enough to warrant specialisation:
stg_gc_ppppp -- 5 GC pointers
stg_gc_ip -- unboxed word + GC pointer
stg_gc_pi -- GC pointer + unboxed word
stg_gc_ii -- two unboxed words
stg_gc_bpp -- byte (I8) + two GC pointers
Adding these reduces the fraction of heap-check sites falling back to
the generic GC path from ~1.4% to ~0.4% when compiling GHC itself.
Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com>
- - - - -
d17d1435 by Matthew Pickering at 2026-04-03T20:01:19-04:00
Make home unit dependencies stored as sets
Co-authored-by: Wolfgang Jeltsch <wolfgang(a)well-typed.com>
- - - - -
92a97015 by Simon Peyton Jones at 2026-04-05T00:58:57+01:00
Add Invariant (NoTypeShadowing) to Core
This commit addresses #26868, by adding
a new invariant (NoTypeShadowing) to Core.
See Note [No type-shadowing in Core] in GHC.Core
- - - - -
8b5a5020 by Simon Peyton Jones at 2026-04-05T00:58:57+01:00
Major refactor of free-variable functions
For some time we have had two free-variable mechanims for types:
* The "FV" mechanism, embodied in GHC.Utils.FV, which worked OK, but
was fragile where eta-expansion was concerned.
* The TyCoFolder mechanism, using a one-shot EndoOS accumulator
I finally got tired of this and refactored the whole thing, thereby
addressing #27080. Now we have
* `GHC.Types.Var.FV`, which has a composable free-variable result type,
very much in the spirit of the old `FV`, but much more robust.
(It uses the "one shot trick".)
* GHC.Core.TyCo.FVs now has just one technology for free variables.
All this led to a lot of renaming.
There are couple of error-message changes. The change in T18451
makes an already-poor error message even more mysterious. But
it really needs a separate look.
We also now traverse the AST in a different order leading to a different
but still deterministic order for FVs and test output has been adjusted
accordingly.
- - - - -
4bf040c6 by sheaf at 2026-04-05T14:56:29-04:00
Add utility pprTrace_ function
This function is useful for quick debugging, as it can be added to a
where clause to pretty-print debugging information:
fooBar x y
| cond = body1
| otherwise = body2
where
!_ = pprTrace_ "fooBar" $
vcat [ text "x:" <+> ppr x
, text "y:" <+> ppr y
, text "cond:" <+> ppr cond
]
- - - - -
502e6ffe by Andrew Lelechenko at 2026-04-07T04:47:21-04:00
base: improve error message for Data.Char.chr
As per https://github.com/haskell/core-libraries-committee/issues/384
- - - - -
b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00
Refactor FunResCtxt a bit
Fixes #27154
- - - - -
9096266b by Ben Gamari at 2026-04-07T17:06:08+02:00
hadrian: Persist the used flavour name in the build root (#20650)
This executes the idea proposed in #20650, teaching Hadrian to persist
the flavour used to build a build root. This both makes use of multiple
build roots more ergonomic (as the user no longer needs to repeat
themselves) and avoids a tiresome foot-gun (forgetting to specify a
flavour, often wholly invalidating a build root).
Closes #20650.
Co-authored-by: Sylvain Henry <sylvain(a)haskus.fr>
- - - - -
237 changed files:
- .gitlab/issue_templates/default.md
- compiler/GHC.hs
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Expr.hs-boot
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Parser/HaddockLex.x
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Expr.hs-boot
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Lit.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Splice.hs-boot
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Debugger/Breakpoints.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/StgToCmm/Heap.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Infer.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Do.hs
- + compiler/GHC/Tc/Gen/Expand.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Match.hs-boot
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Instance/FunDeps.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/BasicTypes.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/CtLoc.hs
- compiler/GHC/Tc/Types/ErrCtxt.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/LclEnv.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Types/Origin.hs-boot
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/TcType.hs-boot
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Error.hs
- + compiler/GHC/Types/Error.hs-boot
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/Name/Set.hs
- compiler/GHC/Types/SrcLoc.hs
- + compiler/GHC/Types/Var/FV.hs
- compiler/GHC/Types/Var/Set.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/State.hs
- + compiler/GHC/Unit/State.hs-boot
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/EndoOS.hs
- − compiler/GHC/Utils/FV.hs
- compiler/GHC/Utils/Logger.hs
- compiler/GHC/Utils/Trace.hs
- compiler/Language/Haskell/Syntax/Module/Name.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- hadrian/doc/flavours.md
- hadrian/src/Rules.hs
- hadrian/src/Settings.hs
- libraries/base/changelog.md
- libraries/base/tests/enum01.stdout
- libraries/base/tests/enum01.stdout-alpha-dec-osf3
- libraries/base/tests/enum01.stdout-ws-64
- libraries/ghc-internal/src/GHC/Internal/Char.hs
- rts/HeapStackCheck.cmm
- rts/RtsSymbols.c
- rts/include/stg/MiscClosures.h
- testsuite/driver/testlib.py
- testsuite/tests/arityanal/should_compile/Arity01.stderr
- testsuite/tests/arityanal/should_compile/Arity05.stderr
- testsuite/tests/arityanal/should_compile/Arity08.stderr
- testsuite/tests/arityanal/should_compile/Arity11.stderr
- testsuite/tests/arityanal/should_compile/Arity14.stderr
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/cpranal/should_compile/T18401.stderr
- testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr
- testsuite/tests/driver/all.T
- testsuite/tests/driver/bytecode-object/Makefile
- testsuite/tests/driver/bytecode-object/all.T
- testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout
- testsuite/tests/indexed-types/should_fail/T2693.stderr
- testsuite/tests/indexed-types/should_fail/T5439.stderr
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/monadfail/MonadFailErrors.stderr
- testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr
- testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr
- testsuite/tests/partial-sigs/should_compile/T10403.stderr
- testsuite/tests/partial-sigs/should_compile/T12844.stderr
- testsuite/tests/partial-sigs/should_compile/T15039a.stderr
- testsuite/tests/partial-sigs/should_compile/T15039b.stderr
- testsuite/tests/partial-sigs/should_compile/T15039c.stderr
- testsuite/tests/partial-sigs/should_compile/T15039d.stderr
- testsuite/tests/partial-sigs/should_fail/T10999.stderr
- testsuite/tests/partial-sigs/should_fail/T12634.stderr
- testsuite/tests/plugins/Makefile
- + testsuite/tests/plugins/T24486-plugin/Makefile
- + testsuite/tests/plugins/T24486-plugin/Setup.hs
- + testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal
- + testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs
- + testsuite/tests/plugins/T24486.hs
- + testsuite/tests/plugins/T24486_Helper.hs
- testsuite/tests/plugins/all.T
- testsuite/tests/plugins/test-defaulting-plugin.stderr
- testsuite/tests/polykinds/T15789.stderr
- testsuite/tests/polykinds/T18451.stderr
- testsuite/tests/polykinds/T7328.stderr
- testsuite/tests/printer/T17697.stderr
- testsuite/tests/profiling/should_run/callstack001.stdout
- testsuite/tests/rebindable/rebindable6.stderr
- testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr
- testsuite/tests/runghc/Makefile
- + testsuite/tests/runghc/T16145.hs
- + testsuite/tests/runghc/T16145.stdout
- + testsuite/tests/runghc/T16145_aux.hs
- testsuite/tests/runghc/all.T
- testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr
- testsuite/tests/simplCore/should_compile/T15205.stderr
- testsuite/tests/simplCore/should_compile/T24229a.stderr
- testsuite/tests/simplCore/should_compile/T24229b.stderr
- testsuite/tests/simplCore/should_compile/T24359a.stderr
- testsuite/tests/simplCore/should_compile/T26116.stderr
- testsuite/tests/simplCore/should_compile/T4908.stderr
- testsuite/tests/simplCore/should_compile/spec-inline.stderr
- testsuite/tests/typecheck/no_skolem_info/T20063.stderr
- + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs
- testsuite/tests/typecheck/should_compile/T14590.stderr
- testsuite/tests/typecheck/should_compile/T25180.stderr
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/free_monad_hole_fits.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion1.stderr
- testsuite/tests/typecheck/should_fail/DoExpansion2.stderr
- testsuite/tests/typecheck/should_fail/T10971d.stderr
- testsuite/tests/typecheck/should_fail/T12589.stderr
- testsuite/tests/typecheck/should_fail/T13311.stderr
- testsuite/tests/typecheck/should_fail/T17773.stderr
- testsuite/tests/typecheck/should_fail/T2846b.stderr
- testsuite/tests/typecheck/should_fail/T3323.stderr
- testsuite/tests/typecheck/should_fail/T3613.stderr
- testsuite/tests/typecheck/should_fail/T6069.stderr
- testsuite/tests/typecheck/should_fail/T7851.stderr
- testsuite/tests/typecheck/should_fail/T7857.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/tcfail102.stderr
- testsuite/tests/typecheck/should_fail/tcfail128.stderr
- testsuite/tests/typecheck/should_fail/tcfail140.stderr
- testsuite/tests/typecheck/should_fail/tcfail181.stderr
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2af7210a5bfc9595bbad52c1524101…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2af7210a5bfc9595bbad52c1524101…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC
Commits:
094aa186 by sheaf at 2026-04-07T15:55:21+02:00
Simplify mkTick
This commit simplifies 'GHC.Core.Utils.mkTick', removing the
accumulating parameter 'rest' which was suspiciously treating a bunch of
different ticks as a group, and moving the group as a whole around the
AST, ignoring that the ticks in the group might have different placement
properties.
Also adds Note [Pushing SCCs inwards] which clarifies the logic for
pushing SCCs into lambdas, constructor applications, and dropping SCCs
around non-function variables (in particular the treatment of splittable
ticks).
A few other changes are also implemented:
- simplify 'can_split' predicate (no functional change)
- drop profiling ticks around coercions, fixing #26941 and #27121
- combine profiling ticks into one when possible
Fixes #26878, #26941 and #27121
Co-authored-by: simonpj <simon.peytonjones(a)gmail.com>
- - - - -
10 changed files:
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Types/Tickish.hs
- libraries/ghc-heap/tests/tso_and_stack_closures.hs
- + testsuite/tests/profiling/should_compile/T27121.hs
- + testsuite/tests/profiling/should_compile/T27121_aux.hs
- testsuite/tests/profiling/should_compile/all.T
- + testsuite/tests/simplCore/should_compile/T26941.hs
- + testsuite/tests/simplCore/should_compile/T26941_aux.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/FloatOut.hs
=====================================
@@ -383,10 +383,37 @@ floatExpr (Tick tickish expr)
case (floatExpr expr) of { (fs, floating_defns, expr') ->
-- Wrap floated code with the correct tick scope, but using 'mkNoCount'
-- to ensure we don't duplicate counters.
+ --
+ -- See also Note [Avoiding duplicate ticks].
let annotated_defns = wrapTick (mkNoCount tickish) floating_defns
in
(fs, annotated_defns, Tick tickish expr') }
+{- Note [Avoiding duplicate ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When FloatOut floats an expression through scoped ticks, it accumulates all
+the scopes on the way, e.g.
+
+ src<loc1>
+ let x = ..
+ in
+ src<loc2>
+ let y = ...
+ in
+ src<loc3>
+ let z = fib 100
+ in ...
+
+When we float 'z' out to the top level, it will accumulate all the intervening
+ticks:
+
+ lvl_z = src<loc1> src<loc2> src<loc3> fib 100
+
+It's important to combine these ticks up as much as possible to avoid hugely
+bloating the Core; for example if loc1 = loc3 then we should combine those two
+source notes, which requires moving src<loc1> past src<loc2> to allow
+cancellation to take place.
+-}
floatExpr (Cast expr co)
= case (floatExpr expr) of { (fs, floating_defns, expr') ->
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -303,101 +303,276 @@ mkCast expr co
* *
********************************************************************* -}
--- | Wraps the given expression in the source annotation, dropping the
--- annotation if possible.
+-- | Wraps the given expression in a Tick, floating the tick as far into
+-- the AST as possible in order to try to satisfy the tick's desired placement
+-- properties (as per Note [Tickish placement] in GHC.Types.Tickish).
+--
+-- Prefer using 'mkTick' over explicit use of the 'Tick' constructor.
+--
+-- Also performs small on-the-fly optimisations:
+--
+-- * Eliminate unnecessary ticks by either absorbing them into existing ones
+-- or dropping them if that is valid (e.g. dropping profiling ticks around
+-- types, coercions and literals).
+-- * Split profiling ticks into counting/scoping parts so that the two parts
+-- can be placed independently into the AST.
mkTick :: CoreTickish -> CoreExpr -> CoreExpr
-mkTick t orig_expr = mkTick' id orig_expr
+mkTick t orig_expr = mkTick' orig_expr
where
-- Some ticks (cost-centres) can be split in two, with the
-- non-counting part having laxer placement properties.
- canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t
-
- -- mkTick' handles floating of ticks *into* the expression.
- mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with)
- -- Always a composition of (Tick t) wrappers
- -> CoreExpr -- Current expression
- -> CoreExpr
- -- So in the call (mkTick' rest e), the expression
- -- (rest e)
- -- has the same type as e
- -- Returns an expression equivalent to (Tick t (rest e))
- mkTick' rest expr = case expr of
- -- Float ticks into unsafe coerce the same way we would do with a cast.
- Case scrut bndr ty alts@[Alt ac abs _rhs]
- | Just rhs <- isUnsafeEqualityCase scrut bndr alts
- -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)]
+ -- See Note [Scoping ticks and counting ticks] in GHC.Types.Tickish.
+ can_split = tickishCanSplit t
+
+ -- Can we commute these two ticks?
+ commutable :: CoreTickish -> CoreTickish -> Bool
+ -- Profiling ticks for different cost centres should never be reordered
+ -- relative to each other.
+ commutable (ProfNote { profNoteCC = cc1 }) (ProfNote { profNoteCC = cc2 })
+ = cc1 == cc2
+
+ -- Ticks of different placements float through each other, so that each
+ -- tick can be floated into its expected position in the AST.
+ -- See Note [Tickish placement] in GHC.Types.Tickish.
+ commutable t1 t2
+ | tickishPlace t1 /= tickishPlace t2
+ = True
- -- Cost centre ticks should never be reordered relative to each
- -- other. Therefore we can stop whenever two collide.
+ -- Source notes can be moved past all other ticks, in order to expose
+ -- cancellation opportunities, e.g. 'src<loc1> src<loc2> src<loc1>'.
+ -- This is crucially important for FloatOut: see
+ -- Note [Avoiding duplicate ticks] in GHC.Core.Opt.FloatOut.
+ commutable (SourceNote {}) _ = True
+ commutable _ (SourceNote {}) = True
+ commutable _ _ = False
+
+ -- mkTick' handles floating of tick `t` *into* the expression.
+ mkTick' :: CoreExpr -> CoreExpr
+ mkTick' expr = case expr of
Tick t2 e
- | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr
-
- -- Otherwise we assume that ticks of different placements float
- -- through each other.
- | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e
-
- -- For annotations this is where we make sure to not introduce
- -- redundant ticks.
- | tickishContains t t2 -> mkTick' rest e -- Drop t2
- | tickishContains t2 t -> rest e -- Drop t
- | otherwise -> mkTick' (rest . Tick t2) e
-
- -- Ticks don't care about types, so we just float all ticks
- -- through them. Note that it's not enough to check for these
- -- cases top-level. While mkTick will never produce Core with type
- -- expressions below ticks, such constructs can be the result of
- -- unfoldings. We therefore make an effort to put everything into
- -- the right place no matter what we start with.
- Cast e co -> mkCast (mkTick' rest e) co
- Coercion co -> Tick t $ rest (Coercion co)
+
+ -- Common up ticks when possible, including profiling ticks that
+ -- share a cost centre and source notes that subsume one another.
+ | Just t' <- combineTickish_maybe t t2
+ -> mkTick t' e
+
+ -- Re-order the ticks if possible, in an attempt to eliminate tick 't'.
+ | commutable t t2
+ -> Tick t2 $ mkTick' e
Lam x e
-- Always float through type lambdas. Even for non-type lambdas,
-- floating is allowed for all but the most strict placement rule.
| not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
- -> Lam x $ mkTick' rest e
+ -> Lam x $ mkTick' e
- -- If it is both counting and scoped, we split the tick into its
- -- two components, often allowing us to keep the counting tick on
- -- the outside of the lambda and push the scoped tick inside.
- -- The point of this is that the counting tick can probably be
- -- floated, and the lambda may then be in a position to be
- -- beta-reduced.
- | canSplit
- -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e
+ -- Push SCCs into lambdas.
+ -- See (PSCC2) in Note [Pushing SCCs inwards].
+ | can_split
+ -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e
App f arg
- -- Always float through type applications.
+ -- All ticks float inwards through non-runtime arguments, as per
+ -- Note [Tickish placement] in GHC.Types.Tickish.
| not (isRuntimeArg arg)
- -> App (mkTick' rest f) arg
+ -> App (mkTick' f) arg
- -- We can also float through constructor applications, placement
- -- permitting. Again we can split.
- | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)
+ -- Push SCCs into saturated constructor applications.
+ -- See (PSCC3) in Note [Pushing SCCs inwards].
+ | isSaturatedConApp expr
+ , tickishPlace t == PlaceCostCentre || can_split
-> if tickishPlace t == PlaceCostCentre
- then rest $ tickHNFArgs t expr
- else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
+ then tickHNFArgs t expr
+ else Tick (mkNoScope t) $ tickHNFArgs (mkNoCount t) expr
+
+ -- See Note [No ticks around types or coercions]
+ e@(Coercion {}) -> e
+ e@(Type {}) -> e
+ -- Don't wrap static data in a tick which compiles to code,
+ -- as the code will never be run.
+ e@(Lit {}) | tickishIsCode t -> e
+
+ -- All ticks can be floated through casts, as per Note [Tickish placement].
+ Cast e co -> mkCast (mkTick' e) co
+
+ -- Treat 'unsafeCoerce' as if it was a cast: float all ticks inwards.
+ -- See Note [Push ticks into unsafeCoerce]
+ Case scrut bndr ty alts@[Alt ac abs _rhs]
+ | Just rhs <- isUnsafeEqualityCase scrut bndr alts
+ -> Case scrut bndr ty [Alt ac abs (mkTick' rhs)]
Var x
- | notFunction && tickishPlace t == PlaceCostCentre
- -> rest expr -- Drop t
- | notFunction && canSplit
- -> Tick (mkNoScope t) $ rest expr
- where
- -- SCCs can be eliminated on variables provided the variable
- -- is not a function. In these cases the SCC makes no difference:
- -- the cost of evaluating the variable will be attributed to its
- -- definition site. When the variable refers to a function, however,
- -- an SCC annotation on the variable affects the cost-centre stack
- -- when the function is called, so we must retain those.
- notFunction = not (isFunTy (idType x))
-
- Lit{}
+ -- Don't drop any ticks around a function
+ | isFunTy (idType x)
+ -> Tick t expr
+ -- Drop SCCs around non-function variables.
+ -- See (PSCC1) in Note [Pushing SCCs inwards].
| tickishPlace t == PlaceCostCentre
- -> rest expr -- Drop t
+ -> -- Drop pure SCC ticks: scc<foo> (x :: Int) ==> x
+ expr
+ | can_split
+ -> -- Drop the scoping part of the tick, but keep the counting part.
+ Tick (mkNoScope t) expr
+
+ -- Catch-all: annotate where we stand.
+ -- In particular (but not only): Let, most Cases.
+ _other -> Tick t expr
+
+{- Note [Pushing SCCs inwards]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Amongst all ticks, SCCs have the laxest placement properties (PlaceCostCentre,
+as described in Note [Tickish placement] GHC.Types.Tickish):
+
+ (PSCC1) SCCs around non-function variables can be eliminated.
+ The cost of evaluating the variable will be attributed to its definition
+ site, so the SCC makes no difference. Example:
+
+ scc<foo> (x :: Int) ==> x
+
+ NB: this is only valid when the variable is not a function. For example, in:
+
+ scc<foo> (f :: Int -> Int)
+
+ we must retain the cost centre annotation, as it affects the cost-centre
+ pointer when the function is called. Discarding the SCC in this case would
+ defeat the profiling mechanism entirely!
+
+ (PSCC2) SCCs can be pushed into lambdas.
+
+ scc<foo> (\x -> e) ==> \x -> scc<foo> e
+
+ (PSCC3) We can push SCCs into (saturated) constructor applications.
+ For example, for an arity 2 data constructor 'D':
+
+ scc<foo> (D e1 e2) ==> D (scc<foo> e1) (scc<foo> e2)
+
+Now, two kinds of ticks contain SCCs:
+
+ - bare SCCs (i.e. ProfNote with profNoteCounts = False, profNoteScopes = True)
+ - profiling ticks that both count and scope
+
+The above explanation deals with bare SCCs. When handling profiling ticks that
+both count and scope, we can split tick into two, so that the scoping part can
+be pushed inwards (or even discarded). Specifically, we perform the following
+transformations:
+
+ (PSCC1) Drop the SCC around non-function variables, keeping only the counting
+ part:
+
+ scctick<foo> (x :: Int) ==> tick<foo> x
+
+ (PSCC2) Push the SCC inside lambdas:
+
+ scctick<foo> (\x. e) ==> tick<foo> (\x. scc<foo> e)
+
+ NB: we must keep the counting part outside the lambda, in order to preserve
+ tick counter tallies – it would not be sound to push the counting part inside.
- -- Catch-all: Annotate where we stand
- _any -> Tick t $ rest expr
+ (PSCC3) Push the SCC inside saturated contructor applications.
+
+ scctick<foo> (D e1 e2) ==> tick<foo> (D (scc<foo> e1) (scc<foo> e2))
+
+The benefit of these transformation is that the counting part, tick<foo>, can
+likely be floated out of the way, which may expose additional optimisation
+opportunities. For example, for (PSCC2):
+
+ (scctick<foo> (\x. e)) arg
+
+ ==>{PSCC2}
+
+ (tick<foo> (\x. scc<foo> e)) arg
+
+ ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope}
+
+ tick<foo> ((\x. scc<foo> e) arg)
+
+ ==>{beta reduction}
+
+ tick<foo> (let x = arg in scc<foo> e)
+
+For (PSCC3):
+
+ case (scctick<foo> (Just x)) of { Nothing -> 0; Just y -> y + 1 }
+
+ ==>{PSCC3}
+
+ case (tick<foo> (Just (scc<foo> x))) of { Nothing -> 0; Just y -> y + 1 }
+
+ ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope}
+
+ tick<foo> (case Just (scc<foo> x) of { Nothing -> 0; Just y -> y + 1 })
+
+ ==>{case of known constructor}
+
+ tick<foo> (let y = scc<foo> x in y + 1)
+
+Note [Push ticks into unsafeCoerce]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In #25212, we had a program of the form:
+
+ data Box = Box Any
+ asBox :: a -> Box
+ asBox x = {-# SCC asBox #-} Box (unsafeCoerce x)
+
+As per Note [Implementing unsafeCoerce] in GHC.Internal.Unsafe.Coerce, the call
+to `unsafeCoerce` turns into
+
+ case unsafeEqualityProof @Type @a @Any of
+ UnsafeRefl (co :: a ~# Any) -> x |> Sub co
+
+The worker for 'asBox' is then of the form:
+
+ $wasBox = \@a (x :: a) ->
+ (# case unsafeEqualityProof @Type @a @Any of
+ UnsafeRefl (co :: a ~# Any) -> x |> Sub co
+ #)
+
+When inserting the SCC, we push it into the constructor as per (PSCC3) in
+Note [Pushing SCCs inwards], so we get:
+
+ $wasBox = \@a (x :: a) ->
+ tick<asBox>
+ (# scc<asBox>
+ case unsafeEqualityProof @Type @a @Any of
+ UnsafeRefl (co :: a ~# Any) -> x |> Sub co
+ #)
+
+Now, if we don't push the SCC tick into the case statement, Core Prep will
+see an expression like 'MkSolo# (scc<asBox> ...)', which it will ANFise to
+'let x = scc<asBox> ... in MkSolo# x', creating an unwanted thunk in the process.
+
+So the strategy is to treat this 'unsafeEqualityProof' case statement as if it
+was a cast. We thus push the SCC into the RHS of the pattern match:
+
+ $wasBox = \@a (x :: a) ->
+ tick<asBox>
+ (# case unsafeEqualityProof @Type @a @Any of
+ UnsafeRefl (co :: a ~# Any) -> scc<asBox> x |> Sub co
+ #)
+
+Then the SCC completely evaporates, as per (PSCC1) in Note [Pushing SCCs inwards].
+
+Note [No ticks around types or coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It doesn't make much sense to put a tick around a type or a coercion, as both
+types and coercions are erased in the end.
+
+In fact, it is quite dangerous to add a tick around types or coercions, because
+the optimiser does not robustly look through ticks:
+
+ - 'GHC.Core.SimpleOpt.simple_bind_pair' does not look through ticks when
+ looking at the RHS to decide whether it is a Type or Coercion,
+ - 'GHC.Core.Opt.Simplify.Iteration.completeBind' does not look through ticks
+ when looking at the RHS of an CoVar binding.
+
+This means it is vital to drop ticks around types/coercions:
+
+ - (#26941) Core Lint rejects bindings of the form "let co = tick ..."
+ in which the LHS is a CoVar and the RHS is a ticked Coercion.
+ - (#27121) The simplifier mis-handles ticked coercion bindings, which can
+ result in 'lookupIdSubst' panics (due to failing to extend the substitution
+ with a coercion).
+-}
mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr
mkTicks ticks expr = foldr mkTick expr ticks
@@ -2545,8 +2720,8 @@ exprIsTickedString = isJust . exprIsTickedString_maybe
exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
exprIsTickedString_maybe (Lit (LitString bs)) = Just bs
exprIsTickedString_maybe (Tick t e)
- -- we don't tick literals with CostCentre ticks, compare to mkTick
- | tickishPlace t == PlaceCostCentre = Nothing
+ -- Shortcut: ticks with code never wrap literals (compare with 'mkTick')
+ | tickishIsCode t = Nothing
| otherwise = exprIsTickedString_maybe e
exprIsTickedString_maybe _ = Nothing
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -17,6 +17,7 @@ module GHC.Types.Tickish (
TickishPlacement(..),
tickishPlace,
tickishContains,
+ combineTickish_maybe,
-- * Breakpoint tick identifiers
BreakpointId(..), BreakTickIndex
@@ -140,20 +141,7 @@ data GenTickish pass =
-- | A source note.
--
- -- Source notes are pure annotations: Their presence should neither
- -- influence compilation nor execution. The semantics are given by
- -- causality: The presence of a source note means that a local
- -- change in the referenced source code span will possibly provoke
- -- the generated code to change. On the flip-side, the functionality
- -- of annotated code *must* be invariant against changes to all
- -- source code *except* the spans referenced in the source notes
- -- (see "Causality of optimized Haskell" paper for details).
- --
- -- Therefore extending the scope of any given source note is always
- -- valid. Note that it is still undesirable though, as this reduces
- -- their usefulness for debugging and profiling. Therefore we will
- -- generally try only to make use of this property where it is
- -- necessary to enable optimizations.
+ -- See Note [Source notes and debug information]
| SourceNote
{ sourceSpan :: RealSrcSpan -- ^ Source covered
, sourceName :: LexicalFastString -- ^ Name for source location
@@ -170,6 +158,45 @@ deriving instance Eq (GenTickish 'TickishPassCmm)
deriving instance Ord (GenTickish 'TickishPassCmm)
deriving instance Data (GenTickish 'TickishPassCmm)
+{- Note [Source notes and debug information]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Source notes are used to generate debug information, in the form of DWARF
+directives in the generated assembly:
+
+ # At the top of the assembly file
+
+ .file 1 "MyModule.hs"
+ .file 2 "OtherModule.hs"
+
+ ...
+
+ # Generated assembly for a particular piece of code
+
+ # - The DWARF debug information
+ # This is not an instruction; it's information for the debugger.
+ .loc 1 1287 8 # MyModule.hs, line 1287, column 8
+
+ # - The actual assembly instructions
+ movq 16(%rbx), %rax
+ addq $1, %rax
+ movq %rax, 16(%rbx)
+
+Source notes are enabled by passing the -g flag to GHC.
+
+Source notes are pure annotations: their presence should neither influence
+compilation nor execution.
+The semantics are given by causality: the presence of a source note means that
+a local change in the referenced source code span will possibly provoke the
+generated code to change.
+On the flip-side, the functionality of annotated code *must* be invariant
+against changes to all source code *except* the spans referenced in the source
+notes (see "Causality of optimized Haskell" paper for details).
+This means that it is valid to extend the scope of any given source note, but
+it is undesirable as this reduces its usefulness for debugging and profiling.
+Therefore, we will generally try only to make use of this property where it is
+necessary to enable optimizations.
+-}
+
--------------------------------------------------------------------------------
-- Tick breakpoint index
--------------------------------------------------------------------------------
@@ -261,8 +288,12 @@ Ticks have two independent attributes:
See Note [Scoped ticks]
+Note that profiling notes which both count and scope can be split into two
+separate ticks, one that counts and doesn't scope and one that scopes and doesn't
+count; see 'tickishCanSplit', 'mkNoCount' and 'mkNoScope'.
+
Note [Counting ticks]
-~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~
The following ticks count:
- ProfNote ticks with profNoteCounts = True
- HPC ticks
@@ -290,7 +321,7 @@ sharing, so in practice the actual number of ticks may vary, except
that we never change the value from zero to non-zero or vice-versa.
Note [Scoped ticks]
-~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~
The following ticks are scoped:
- ProfNote ticks with profNoteScope = True
- Breakpoints
@@ -375,6 +406,61 @@ Whether we are allowed to float in additional cost depends on the tick:
While these transformations are legal, we want to make a best effort to
only make use of them where it exposes transformation opportunities.
+
+Note [Tickish placement]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The placement behaviour of ticks (i.e. which nodes we want the tick to be placed
+around in the AST) is governed by 'TickishPlacement'.
+From most restrictive to least restrictive placement rules:
+
+ - PlaceRuntime: counting ticks.
+
+ Ticks with 'PlaceRuntime' placement want to be placed around run-time
+ expressions. They can be moved through pure compile-time constructs such as
+ other type arguments, casts, or type lambdas:
+
+ tick <t> (f @ty) ==> (tick <t> f) @ty
+ tick <t> (e |> co) ==> (tick <t> e) |> co
+ tick <t> (/\a. e) ==> /\a. tick <t> e
+
+ This is the most restrictive placement rule for ticks, as all tickishs have
+ in common that they want to track runtime behaviour.
+
+ Any tick that counts (see Note [Counting ticks]) has 'PlaceRuntime' placement.
+
+ - PlaceNonLam: source notes.
+
+ Like PlaceRuntime, but we can also float the tick through value lambdas:
+
+ tick <t> (\x. e) ==> \x. tick <t> e
+
+ This makes sense where there is little difference between annotating the
+ lambda and annotating the lambda's code.
+
+ - PlaceCostCentre: non-counting profiling ticks.
+
+ In addition to floating through lambdas, cost-centre style tickishs can be
+ pushed into (saturated) constructor applications, and can be eliminated when
+ placed around non-function variables:
+
+ tick <t> (C e1 e2) ==> C (tick <t> e1) (tick <t> e2)
+
+ tick <t> (x :: Int) ==> (x :: Int)
+
+ Neither the constructor application nor the variable 'x' are likely to have
+ any cost worth mentioning.
+
+We generally try to push ticks inwards until they end up placed around a Core
+expression that is appropriate for their placement rule, as described above.
+This gives us the opportunity to eliminate the tick, either by combining it with
+another tick (see 'combineTickish_maybe') or by dropping it altogether. For
+example, a (non-counting) SCC around a non-function variable can be dropped, as
+there is no cost to scope over.
+
+After the tick has been placed by 'mkTick', the simplifier may later (during
+simplification) decide to float it outwards (see e.g. GHC.Core.Opt.Simplify.Iteration.simplTick).
+The story here is not fully worked out, as the simplifier calls 'mkTick', which
+might push the tick inwards again.
-}
-- | Returns @True@ for ticks that can be floated upwards easily even
@@ -441,35 +527,19 @@ isProfTick _ = False
-- annotating for example using @mkTick@. If we find that we want to
-- put a tickish on an expression ruled out here, we try to float it
-- inwards until we find a suitable expression.
+--
+-- See Note [Tickish placement].
data TickishPlacement =
- -- | Place ticks exactly on run-time expressions. We can still
- -- move the tick through pure compile-time constructs such as
- -- other ticks, casts or type lambdas. This is the most
- -- restrictive placement rule for ticks, as all tickishs have in
- -- common that they want to track runtime processes. The only
- -- legal placement rule for counting ticks.
- -- NB: We generally try to move these as close to the relevant
- -- runtime expression as possible. This means they get pushed through
- -- tyoe arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`.
+ -- | Place ticks exactly on run-time expressions, moving them through pure
+ -- compile-time constructs such as other ticks, casts or type lambdas.
PlaceRuntime
- -- | As @PlaceRuntime@, but we float the tick through all
- -- lambdas. This makes sense where there is little difference
- -- between annotating the lambda and annotating the lambda's code.
+ -- | As @PlaceRuntime@, but also allow to float the tick through all lambdas.
| PlaceNonLam
- -- | In addition to floating through lambdas, cost-centre style
- -- tickishs can also be moved from constructors, non-function
- -- variables and literals. For example:
- --
- -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ...
- --
- -- Neither the constructor application, the variable or the
- -- literal are likely to have any cost worth mentioning. And even
- -- if y names a thunk, the call would not care about the
- -- evaluation context. Therefore removing all annotations in the
- -- above example is safe.
+ -- | As 'PlaceNonLam', but also float through constructors, non-function
+ -- variables and literals.
| PlaceCostCentre
deriving (Eq,Show)
@@ -477,7 +547,9 @@ data TickishPlacement =
instance Outputable TickishPlacement where
ppr = text . show
--- | Placement behaviour we want for the ticks
+-- | Placement behaviour we want for the ticks.
+--
+-- See Note [Tickish placement].
tickishPlace :: GenTickish pass -> TickishPlacement
tickishPlace n@ProfNote{}
| profNoteCount n = PlaceRuntime
@@ -486,6 +558,43 @@ tickishPlace HpcTick{} = PlaceRuntime
tickishPlace Breakpoint{} = PlaceRuntime
tickishPlace SourceNote{} = PlaceNonLam
+-- | Merge two ticks into one, if that is possible.
+--
+-- Examples:
+--
+-- - combine two source note ticks if one contains the other,
+-- - combine a non-counting profiling tick with a non-scoping profiling tick
+-- for the same cost centre
+-- - combine two equal breakpoint ticks or HPC ticks
+combineTickish_maybe :: Eq (GenTickish pass)
+ => GenTickish pass -> GenTickish pass -> Maybe (GenTickish pass)
+combineTickish_maybe
+ (ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 })
+ (ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 })
+ | cc1 == cc2
+ , not cnt1 || not cnt2
+ = Just $ ProfNote { profNoteCC = cc1
+ , profNoteCount = cnt1 || cnt2
+ , profNoteScope = scope1 || scope2
+ }
+combineTickish_maybe t1@(SourceNote sp1 n1) t2@(SourceNote sp2 n2)
+ | n1 == n2
+ , sp1 `containsSpan` sp2
+ = Just t1
+ | n1 == n2
+ , sp2 `containsSpan` sp1
+ = Just t2
+ -- NB: it would be possible to use 'combineRealSrcSpans' instead,
+ -- but that has the risk of combining many source note ticks into a single
+ -- tick with a huge source span.
+combineTickish_maybe t1@(HpcTick {}) t2@(HpcTick {})
+ | t1 == t2
+ = Just t1
+combineTickish_maybe t1@(Breakpoint {}) t2@(Breakpoint {})
+ | t1 == t2
+ = Just t1
+combineTickish_maybe _ _ = Nothing
+
-- | Returns whether one tick "contains" the other one, therefore
-- making the second tick redundant.
tickishContains :: Eq (GenTickish pass)
=====================================
libraries/ghc-heap/tests/tso_and_stack_closures.hs
=====================================
@@ -48,7 +48,9 @@ main = do
assertEqual (cc_module myCostCentre) "Main"
assertEqual (cc_srcloc myCostCentre) (Just "tso_and_stack_closures.hs:24:48-80")
assertEqual (cc_is_caf myCostCentre) False
- Nothing -> error $ "MyCostCentre not found in:\n" ++ unlines (cc_label <$> linkedCostCentres costCentre)
+ Nothing -> error "MyCostCentre not found"
+ -- Don't print all of 'linkedCostCentres costCentre',
+ -- as that is ~20k lines of output.
#endif
linkedCostCentres :: Maybe CostCentre -> [CostCentre]
=====================================
testsuite/tests/profiling/should_compile/T27121.hs
=====================================
@@ -0,0 +1,12 @@
+module T27121 where
+
+import T27121_aux
+
+updateFileDiagnostics
+ :: LanguageContextEnv ()
+ -> IO ()
+updateFileDiagnostics env = do
+ withTrace $ \ _tag ->
+ runLspT env $ do
+ sendNotification SMethod_TextDocumentPublishDiagnostics
+ PublishDiagnosticsParams
=====================================
testsuite/tests/profiling/should_compile/T27121_aux.hs
=====================================
@@ -0,0 +1,354 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T27121_aux
+ ( withTrace
+ , sendNotification
+ , LspT, runLspT
+ , SMethod(..)
+ , LanguageContextEnv
+ , PublishDiagnosticsParams(..)
+ )
+ where
+
+-- base
+import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Data.Kind ( Type )
+import GHC.TypeLits ( Symbol )
+
+--------------------------------------------------------------------------------
+
+withTrace :: Monad m => ((String -> String -> m ()) -> m a) -> m a
+withTrace act
+ | myUserTracingEnabled
+ = return undefined
+ | otherwise = act (\_ _ -> pure ())
+{-# NOINLINE withTrace #-}
+
+myUserTracingEnabled :: Bool
+myUserTracingEnabled = False
+{-# NOINLINE myUserTracingEnabled #-}
+
+type Text = String
+
+newtype LspT config a = LspT {unLspT :: LanguageContextEnv config -> IO a}
+
+instance Functor (LspT config) where
+ fmap f (LspT g) = LspT (fmap f . g)
+
+instance Applicative (LspT config) where
+ pure = LspT . const . pure
+ LspT f <*> LspT a = LspT $ \ env -> f env <*> a env
+instance Monad (LspT config) where
+ LspT a >>= f = LspT $ \ env -> do
+ b <- a env
+ unLspT ( f b ) env
+instance MonadIO (LspT config) where
+ liftIO = LspT . const . liftIO
+
+type role LspT representational nominal
+
+runLspT :: LanguageContextEnv config -> LspT config a -> IO a
+runLspT env (LspT f) = f env
+{-# INLINE runLspT #-}
+
+data PublishDiagnosticsParams = PublishDiagnosticsParams
+
+data LanguageContextEnv config =
+ LanguageContextEnv
+ { resSendMessage :: FromServerMessage -> IO () }
+
+
+sendNotification ::
+ forall (m :: Method ServerToClient Notification) f config.
+ MonadLsp config f =>
+ SServerMethod m ->
+ MessageParams m ->
+ f ()
+sendNotification m params =
+ let msg = TNotificationMessage { _method = m, _params = params }
+ in case splitServerMethod m of
+ IsServerNot -> sendToClient $ fromServerNot msg
+
+type Method :: MessageDirection -> MessageKind -> Type
+data Method f t where
+ Method_TextDocumentImplementation :: Method ClientToServer Request
+ Method_TextDocumentTypeDefinition :: Method ClientToServer Request
+ Method_WorkspaceWorkspaceFolders :: Method ServerToClient Request
+ Method_WorkspaceConfiguration :: Method ServerToClient Request
+ Method_TextDocumentDocumentColor :: Method ClientToServer Request
+ Method_TextDocumentColorPresentation :: Method ClientToServer Request
+ Method_TextDocumentFoldingRange :: Method ClientToServer Request
+ Method_TextDocumentDeclaration :: Method ClientToServer Request
+ Method_TextDocumentSelectionRange :: Method ClientToServer Request
+ Method_WindowWorkDoneProgressCreate :: Method ServerToClient Request
+ Method_TextDocumentPrepareCallHierarchy :: Method ClientToServer Request
+ Method_CallHierarchyIncomingCalls :: Method ClientToServer Request
+ Method_CallHierarchyOutgoingCalls :: Method ClientToServer Request
+ Method_TextDocumentSemanticTokensFull :: Method ClientToServer Request
+ Method_TextDocumentSemanticTokensFullDelta :: Method ClientToServer Request
+ Method_TextDocumentSemanticTokensRange :: Method ClientToServer Request
+ Method_WorkspaceSemanticTokensRefresh :: Method ServerToClient Request
+ Method_WindowShowDocument :: Method ServerToClient Request
+ Method_TextDocumentLinkedEditingRange :: Method ClientToServer Request
+ Method_WorkspaceWillCreateFiles :: Method ClientToServer Request
+ Method_WorkspaceWillRenameFiles :: Method ClientToServer Request
+ Method_WorkspaceWillDeleteFiles :: Method ClientToServer Request
+ Method_TextDocumentMoniker :: Method ClientToServer Request
+ Method_TextDocumentPrepareTypeHierarchy :: Method ClientToServer Request
+ Method_TypeHierarchySupertypes :: Method ClientToServer Request
+ Method_TypeHierarchySubtypes :: Method ClientToServer Request
+ Method_TextDocumentInlineValue :: Method ClientToServer Request
+ Method_WorkspaceInlineValueRefresh :: Method ServerToClient Request
+ Method_TextDocumentInlayHint :: Method ClientToServer Request
+ Method_InlayHintResolve :: Method ClientToServer Request
+ Method_WorkspaceInlayHintRefresh :: Method ServerToClient Request
+ Method_TextDocumentDiagnostic :: Method ClientToServer Request
+ Method_WorkspaceDiagnostic :: Method ClientToServer Request
+ Method_WorkspaceDiagnosticRefresh :: Method ServerToClient Request
+ Method_ClientRegisterCapability :: Method ServerToClient Request
+ Method_ClientUnregisterCapability :: Method ServerToClient Request
+ Method_Initialize :: Method ClientToServer Request
+ Method_Shutdown :: Method ClientToServer Request
+ Method_WindowShowMessageRequest :: Method ServerToClient Request
+ Method_TextDocumentWillSaveWaitUntil :: Method ClientToServer Request
+ Method_TextDocumentCompletion :: Method ClientToServer Request
+ Method_CompletionItemResolve :: Method ClientToServer Request
+ Method_TextDocumentHover :: Method ClientToServer Request
+ Method_TextDocumentSignatureHelp :: Method ClientToServer Request
+ Method_TextDocumentDefinition :: Method ClientToServer Request
+ Method_TextDocumentReferences :: Method ClientToServer Request
+ Method_TextDocumentDocumentHighlight :: Method ClientToServer Request
+ Method_TextDocumentDocumentSymbol :: Method ClientToServer Request
+ Method_TextDocumentCodeAction :: Method ClientToServer Request
+ Method_CodeActionResolve :: Method ClientToServer Request
+ Method_WorkspaceSymbol :: Method ClientToServer Request
+ Method_WorkspaceSymbolResolve :: Method ClientToServer Request
+ Method_TextDocumentCodeLens :: Method ClientToServer Request
+ Method_CodeLensResolve :: Method ClientToServer Request
+ Method_WorkspaceCodeLensRefresh :: Method ServerToClient Request
+ Method_TextDocumentDocumentLink :: Method ClientToServer Request
+ Method_DocumentLinkResolve :: Method ClientToServer Request
+ Method_TextDocumentFormatting :: Method ClientToServer Request
+ Method_TextDocumentRangeFormatting :: Method ClientToServer Request
+ Method_TextDocumentOnTypeFormatting :: Method ClientToServer Request
+ Method_TextDocumentRename :: Method ClientToServer Request
+ Method_TextDocumentPrepareRename :: Method ClientToServer Request
+ Method_WorkspaceExecuteCommand :: Method ClientToServer Request
+ Method_WorkspaceApplyEdit :: Method ServerToClient Request
+ Method_WorkspaceDidChangeWorkspaceFolders :: Method ClientToServer Notification
+ Method_WindowWorkDoneProgressCancel :: Method ClientToServer Notification
+ Method_WorkspaceDidCreateFiles :: Method ClientToServer Notification
+ Method_WorkspaceDidRenameFiles :: Method ClientToServer Notification
+ Method_WorkspaceDidDeleteFiles :: Method ClientToServer Notification
+ Method_NotebookDocumentDidOpen :: Method ClientToServer Notification
+ Method_NotebookDocumentDidChange :: Method ClientToServer Notification
+ Method_NotebookDocumentDidSave :: Method ClientToServer Notification
+ Method_NotebookDocumentDidClose :: Method ClientToServer Notification
+ Method_Initialized :: Method ClientToServer Notification
+ Method_Exit :: Method ClientToServer Notification
+ Method_WorkspaceDidChangeConfiguration :: Method ClientToServer Notification
+ Method_WindowShowMessage :: Method ServerToClient Notification
+ Method_WindowLogMessage :: Method ServerToClient Notification
+ Method_TelemetryEvent :: Method ServerToClient Notification
+ Method_TextDocumentDidOpen :: Method ClientToServer Notification
+ Method_TextDocumentDidChange :: Method ClientToServer Notification
+ Method_TextDocumentDidClose :: Method ClientToServer Notification
+ Method_TextDocumentDidSave :: Method ClientToServer Notification
+ Method_TextDocumentWillSave :: Method ClientToServer Notification
+ Method_WorkspaceDidChangeWatchedFiles :: Method ClientToServer Notification
+ Method_TextDocumentPublishDiagnostics :: Method ServerToClient Notification
+ Method_SetTrace :: Method ClientToServer Notification
+ Method_LogTrace :: Method ServerToClient Notification
+ Method_CancelRequest :: Method f Notification
+ Method_Progress :: Method f Notification
+ Method_CustomMethod :: Symbol -> Method f t
+
+type SMethod :: forall f t . Method f t -> Type
+data SMethod m where
+ SMethod_TextDocumentImplementation :: SMethod Method_TextDocumentImplementation
+ SMethod_TextDocumentTypeDefinition :: SMethod Method_TextDocumentTypeDefinition
+ SMethod_WorkspaceWorkspaceFolders :: SMethod Method_WorkspaceWorkspaceFolders
+ SMethod_WorkspaceConfiguration :: SMethod Method_WorkspaceConfiguration
+ SMethod_TextDocumentDocumentColor :: SMethod Method_TextDocumentDocumentColor
+ SMethod_TextDocumentColorPresentation :: SMethod Method_TextDocumentColorPresentation
+ SMethod_TextDocumentFoldingRange :: SMethod Method_TextDocumentFoldingRange
+ SMethod_TextDocumentDeclaration :: SMethod Method_TextDocumentDeclaration
+ SMethod_TextDocumentSelectionRange :: SMethod Method_TextDocumentSelectionRange
+ SMethod_WindowWorkDoneProgressCreate :: SMethod Method_WindowWorkDoneProgressCreate
+ SMethod_TextDocumentPrepareCallHierarchy :: SMethod Method_TextDocumentPrepareCallHierarchy
+ SMethod_CallHierarchyIncomingCalls :: SMethod Method_CallHierarchyIncomingCalls
+ SMethod_CallHierarchyOutgoingCalls :: SMethod Method_CallHierarchyOutgoingCalls
+ SMethod_TextDocumentSemanticTokensFull :: SMethod Method_TextDocumentSemanticTokensFull
+ SMethod_TextDocumentSemanticTokensFullDelta :: SMethod Method_TextDocumentSemanticTokensFullDelta
+ SMethod_TextDocumentSemanticTokensRange :: SMethod Method_TextDocumentSemanticTokensRange
+ SMethod_WorkspaceSemanticTokensRefresh :: SMethod Method_WorkspaceSemanticTokensRefresh
+ SMethod_WindowShowDocument :: SMethod Method_WindowShowDocument
+ SMethod_TextDocumentLinkedEditingRange :: SMethod Method_TextDocumentLinkedEditingRange
+ SMethod_WorkspaceWillCreateFiles :: SMethod Method_WorkspaceWillCreateFiles
+ SMethod_WorkspaceWillRenameFiles :: SMethod Method_WorkspaceWillRenameFiles
+ SMethod_WorkspaceWillDeleteFiles :: SMethod Method_WorkspaceWillDeleteFiles
+ SMethod_TextDocumentMoniker :: SMethod Method_TextDocumentMoniker
+ SMethod_TextDocumentPrepareTypeHierarchy :: SMethod Method_TextDocumentPrepareTypeHierarchy
+ SMethod_TypeHierarchySupertypes :: SMethod Method_TypeHierarchySupertypes
+ SMethod_TypeHierarchySubtypes :: SMethod Method_TypeHierarchySubtypes
+ SMethod_TextDocumentInlineValue :: SMethod Method_TextDocumentInlineValue
+ SMethod_WorkspaceInlineValueRefresh :: SMethod Method_WorkspaceInlineValueRefresh
+ SMethod_TextDocumentInlayHint :: SMethod Method_TextDocumentInlayHint
+ SMethod_InlayHintResolve :: SMethod Method_InlayHintResolve
+ SMethod_WorkspaceInlayHintRefresh :: SMethod Method_WorkspaceInlayHintRefresh
+ SMethod_TextDocumentDiagnostic :: SMethod Method_TextDocumentDiagnostic
+ SMethod_WorkspaceDiagnostic :: SMethod Method_WorkspaceDiagnostic
+ SMethod_WorkspaceDiagnosticRefresh :: SMethod Method_WorkspaceDiagnosticRefresh
+ SMethod_ClientRegisterCapability :: SMethod Method_ClientRegisterCapability
+ SMethod_ClientUnregisterCapability :: SMethod Method_ClientUnregisterCapability
+ SMethod_Initialize :: SMethod Method_Initialize
+ SMethod_Shutdown :: SMethod Method_Shutdown
+ SMethod_WindowShowMessageRequest :: SMethod Method_WindowShowMessageRequest
+ SMethod_TextDocumentWillSaveWaitUntil :: SMethod Method_TextDocumentWillSaveWaitUntil
+ SMethod_TextDocumentCompletion :: SMethod Method_TextDocumentCompletion
+ SMethod_CompletionItemResolve :: SMethod Method_CompletionItemResolve
+ SMethod_TextDocumentHover :: SMethod Method_TextDocumentHover
+ SMethod_TextDocumentSignatureHelp :: SMethod Method_TextDocumentSignatureHelp
+ SMethod_TextDocumentDefinition :: SMethod Method_TextDocumentDefinition
+ SMethod_TextDocumentReferences :: SMethod Method_TextDocumentReferences
+ SMethod_TextDocumentDocumentHighlight :: SMethod Method_TextDocumentDocumentHighlight
+ SMethod_TextDocumentDocumentSymbol :: SMethod Method_TextDocumentDocumentSymbol
+ SMethod_TextDocumentCodeAction :: SMethod Method_TextDocumentCodeAction
+ SMethod_CodeActionResolve :: SMethod Method_CodeActionResolve
+ SMethod_WorkspaceSymbol :: SMethod Method_WorkspaceSymbol
+ SMethod_WorkspaceSymbolResolve :: SMethod Method_WorkspaceSymbolResolve
+ SMethod_TextDocumentCodeLens :: SMethod Method_TextDocumentCodeLens
+ SMethod_CodeLensResolve :: SMethod Method_CodeLensResolve
+ SMethod_WorkspaceCodeLensRefresh :: SMethod Method_WorkspaceCodeLensRefresh
+ SMethod_TextDocumentDocumentLink :: SMethod Method_TextDocumentDocumentLink
+ SMethod_DocumentLinkResolve :: SMethod Method_DocumentLinkResolve
+ SMethod_TextDocumentFormatting :: SMethod Method_TextDocumentFormatting
+ SMethod_TextDocumentRangeFormatting :: SMethod Method_TextDocumentRangeFormatting
+ SMethod_TextDocumentOnTypeFormatting :: SMethod Method_TextDocumentOnTypeFormatting
+ SMethod_TextDocumentRename :: SMethod Method_TextDocumentRename
+ SMethod_TextDocumentPrepareRename :: SMethod Method_TextDocumentPrepareRename
+ SMethod_WorkspaceExecuteCommand :: SMethod Method_WorkspaceExecuteCommand
+ SMethod_WorkspaceApplyEdit :: SMethod Method_WorkspaceApplyEdit
+ SMethod_WorkspaceDidChangeWorkspaceFolders :: SMethod Method_WorkspaceDidChangeWorkspaceFolders
+ SMethod_WindowWorkDoneProgressCancel :: SMethod Method_WindowWorkDoneProgressCancel
+ SMethod_WorkspaceDidCreateFiles :: SMethod Method_WorkspaceDidCreateFiles
+ SMethod_WorkspaceDidRenameFiles :: SMethod Method_WorkspaceDidRenameFiles
+ SMethod_WorkspaceDidDeleteFiles :: SMethod Method_WorkspaceDidDeleteFiles
+ SMethod_NotebookDocumentDidOpen :: SMethod Method_NotebookDocumentDidOpen
+ SMethod_NotebookDocumentDidChange :: SMethod Method_NotebookDocumentDidChange
+ SMethod_NotebookDocumentDidSave :: SMethod Method_NotebookDocumentDidSave
+ SMethod_NotebookDocumentDidClose :: SMethod Method_NotebookDocumentDidClose
+ SMethod_Initialized :: SMethod Method_Initialized
+ SMethod_Exit :: SMethod Method_Exit
+ SMethod_WorkspaceDidChangeConfiguration :: SMethod Method_WorkspaceDidChangeConfiguration
+ SMethod_WindowShowMessage :: SMethod Method_WindowShowMessage
+ SMethod_WindowLogMessage :: SMethod Method_WindowLogMessage
+ SMethod_TelemetryEvent :: SMethod Method_TelemetryEvent
+ SMethod_TextDocumentDidOpen :: SMethod Method_TextDocumentDidOpen
+ SMethod_TextDocumentDidChange :: SMethod Method_TextDocumentDidChange
+ SMethod_TextDocumentDidClose :: SMethod Method_TextDocumentDidClose
+ SMethod_TextDocumentDidSave :: SMethod Method_TextDocumentDidSave
+ SMethod_TextDocumentWillSave :: SMethod Method_TextDocumentWillSave
+ SMethod_WorkspaceDidChangeWatchedFiles :: SMethod Method_WorkspaceDidChangeWatchedFiles
+ SMethod_TextDocumentPublishDiagnostics :: SMethod Method_TextDocumentPublishDiagnostics
+ SMethod_SetTrace :: SMethod Method_SetTrace
+ SMethod_LogTrace :: SMethod Method_LogTrace
+ SMethod_CancelRequest :: SMethod Method_CancelRequest
+ SMethod_Progress :: SMethod Method_Progress
+
+type SServerMethod (m :: Method ServerToClient t) = SMethod m
+
+data MessageDirection = ServerToClient | ClientToServer
+
+data MessageKind = Notification | Request
+
+
+type ServerNotOrReq :: forall t. Method ServerToClient t -> Type
+data ServerNotOrReq m where
+ IsServerNot ::
+ ( TMessage m ~ TNotificationMessage m
+ ) =>
+ ServerNotOrReq (m :: Method ServerToClient Notification)
+ IsServerReq ::
+ forall (m :: Method ServerToClient Request).
+ ( TMessage m ~ TRequestMessage m
+ ) =>
+ ServerNotOrReq m
+
+type TMessage :: forall f t. Method f t -> Type
+type family TMessage m where
+ TMessage (Method_CustomMethod s :: Method f t) = ()
+ TMessage (m :: Method f Request) = TRequestMessage m
+ TMessage (m :: Method f Notification) = TNotificationMessage m
+
+
+data TNotificationMessage (m :: Method f Notification) = TNotificationMessage
+ { _method :: SMethod m
+ , _params :: MessageParams m
+ }
+
+data TRequestMessage (m :: Method f Request) = TRequestMessage
+
+type MessageParams :: forall f t . Method f t -> Type
+type family MessageParams (m :: Method f t) where
+ MessageParams Method_TextDocumentPublishDiagnostics = PublishDiagnosticsParams
+
+class MonadIO m => MonadLsp config m | m -> config where
+ getLspEnv :: m (LanguageContextEnv config)
+
+instance MonadLsp config (LspT config) where
+ {-# INLINE getLspEnv #-}
+ getLspEnv = LspT pure
+
+
+{-# INLINE splitServerMethod #-}
+splitServerMethod :: SServerMethod m -> ServerNotOrReq m
+splitServerMethod = \case
+ SMethod_TextDocumentPublishDiagnostics -> IsServerNot
+ SMethod_WindowShowMessage -> IsServerNot
+ SMethod_WindowShowMessageRequest -> IsServerReq
+ SMethod_WindowShowDocument -> IsServerReq
+ SMethod_WindowLogMessage -> IsServerNot
+ SMethod_WindowWorkDoneProgressCreate -> IsServerReq
+ SMethod_Progress -> IsServerNot
+ SMethod_TelemetryEvent -> IsServerNot
+ SMethod_ClientRegisterCapability -> IsServerReq
+ SMethod_ClientUnregisterCapability -> IsServerReq
+ SMethod_WorkspaceWorkspaceFolders -> IsServerReq
+ SMethod_WorkspaceConfiguration -> IsServerReq
+ SMethod_WorkspaceApplyEdit -> IsServerReq
+ SMethod_LogTrace -> IsServerNot
+ SMethod_CancelRequest -> IsServerNot
+ SMethod_WorkspaceCodeLensRefresh -> IsServerReq
+ SMethod_WorkspaceSemanticTokensRefresh -> IsServerReq
+ SMethod_WorkspaceInlineValueRefresh -> IsServerReq
+ SMethod_WorkspaceInlayHintRefresh -> IsServerReq
+ SMethod_WorkspaceDiagnosticRefresh -> IsServerReq
+
+fromServerNot ::
+ forall (m :: Method ServerToClient Notification).
+ TMessage m ~ TNotificationMessage m =>
+ TNotificationMessage m ->
+ FromServerMessage
+fromServerNot m@TNotificationMessage{_method = meth} = FromServerMess meth m
+
+
+data FromServerMessage' a where
+ FromServerMess :: forall t (m :: Method ServerToClient t) a. SMethod m -> TMessage m -> FromServerMessage' a
+ FromServerRsp :: forall (m :: Method ClientToServer Request) a. a m -> TResponseMessage m -> FromServerMessage' a
+
+type FromServerMessage = FromServerMessage' SMethod
+
+data TResponseMessage (m :: Method f Request) = TResponseMessage
+
+sendToClient :: MonadLsp config m => FromServerMessage -> m ()
+sendToClient msg = do
+ f <- resSendMessage <$> getLspEnv
+ liftIO $ f msg
+{-# INLINE sendToClient #-}
=====================================
testsuite/tests/profiling/should_compile/all.T
=====================================
@@ -21,3 +21,4 @@ test('T15108', [test_opts], compile, ['-O -prof -fprof-auto'])
test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894'])
test('T20938', [test_opts], compile, ['-O -prof'])
test('T26056', [test_opts], compile, ['-O -prof'])
+test('T27121', [test_opts, extra_files(['T27121_aux.hs'])], multimod_compile, ['T27121', '-v0 -O -prof -fprof-auto'])
=====================================
testsuite/tests/simplCore/should_compile/T26941.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+
+module T26941 where
+
+import GHC.TypeLits
+
+import T26941_aux ( SMayNat(SKnown), ListH, shxHead )
+
+shsHead :: ListH (Just n : sh) Int -> SNat n
+shsHead shx =
+ case shxHead shx of
+ SKnown SNat -> SNat
=====================================
testsuite/tests/simplCore/should_compile/T26941_aux.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeOperators #-}
+
+module T26941_aux where
+
+import Data.Kind
+import GHC.TypeLits
+
+shxHead :: ListH (n : sh) i -> SMayNat i n
+shxHead list = {-# SCC "bad_scc" #-}
+ ( case list of (i `ConsKnown` _) -> SKnown i )
+
+type ListH :: [Maybe Nat] -> Type -> Type
+data ListH sh i where
+ ConsKnown :: SNat n -> ListH sh i -> ListH (Just n : sh) i
+
+data SMayNat i n where
+ SKnown :: SNat n -> SMayNat i (Just n)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -576,6 +576,8 @@ test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniqu
test('T26349', normal, compile, ['-O -ddump-rules'])
test('T26681', normal, compile, ['-O'])
+test('T26941', [extra_files(['T26941_aux.hs']), req_profiling], multimod_compile, ['T26941', '-v0 -O -prof'])
+
# T26709: we expect three `case` expressions not four
test('T26709', [grep_errmsg(r'case')],
multimod_compile,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/094aa1868ac7e374a4f3dc7a165decc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/094aa1868ac7e374a4f3dc7a165decc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0