[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: packaging: correctly propagate build/host/target to bindist configure script

7 Apr 2026

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@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@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@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/7df6bd1694e8fe7c6a52673858639ee...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7df6bd1694e8fe7c6a52673858639ee...
You're receiving this email because of your account on gitlab.haskell.org.

    

Marge Bot (＠marge-bot)

tags

participants (1)