- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/26543] 2 commits: Tyvar priority
by Simon Peyton Jones (＠simonpj) 20 Nov '25

20 Nov '25

Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC Commits: a429ef71 by Simon Peyton Jones at 2025-11-20T08:46:06+00:00 Tyvar priority If necy, eliminate a vanilla tv in favour of a *concrete* tv. That is, concreteness is more important that QLInstVar - - - - - 214cbb19 by Simon Peyton Jones at 2025-11-20T14:12:14+00:00 Expermimental patch to QuickLook cf #26598/#26599 - - - - - 2 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -385,8 +385,7 @@ tcApp rn_expr exp_res_ty -- Step 3: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun - ; (inst_args, app_res_rho) - <- tcInstFun do_ql inst_final tc_head fun_sigma rn_args + ; (inst_args, app_res_rho) <- tcInstFun do_ql inst_final tc_head fun_sigma rn_args ; case do_ql of NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) @@ -406,10 +405,11 @@ tcApp rn_expr exp_res_ty -- Step 5.1: Take a quick look at the result type ; quickLookResultType app_res_rho exp_res_ty + ; inst_args' <- mapM quickLookArg inst_args -- Step 5.2: typecheck the arguments, and monomorphise -- any un-unified instantiation variables - ; tc_args <- tcValArgs DoQL inst_args + ; tc_args <- tcValArgs DoQL inst_args' -- Step 5.3: zonk to expose the polymorphism hidden under -- QuickLook instantiation variables in `app_res_rho` @@ -841,9 +841,11 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args (Just $ HsExprTcThing tc_fun) (n_val_args, fun_sigma) fun_ty - ; ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun - ; arg' <- quickLookArg ds_flag do_ql ctxt arg arg_ty - ; let acc' = arg' : addArgWrap (mkWpCastN fun_co) acc + ; let arg' = EValArg { ea_ctxt = ctxt + , ea_arg = arg + , ea_arg_ty = arg_ty } + acc' = arg' : addArgWrap (mkWpCastN fun_co) acc + ; go (pos+1) acc' res_ty rest_args } new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType) @@ -1841,68 +1843,20 @@ This turned out to be more subtle than I expected. Wrinkles: -} -quickLookArg :: DeepSubsumptionFlag - -> QLFlag -> AppCtxt - -> LHsExpr GhcRn -- ^ Argument - -> Scaled TcSigmaTypeFRR -- ^ Type expected by the function +quickLookArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst) +-- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper -- See Note [Quick Look at value arguments] -quickLookArg _ NoQL ctxt larg orig_arg_ty - = skipQuickLook ctxt larg orig_arg_ty -quickLookArg ds_flag DoQL ctxt larg orig_arg_ty - = do { is_rho <- tcIsDeepRho ds_flag (scaledThing orig_arg_ty) +quickLookArg e_arg@(EValArg { ea_ctxt = ctxt + , ea_arg = larg@(L _ arg) + , ea_arg_ty = orig_arg_ty@(Scaled _ orig_arg_rho) }) + = do { is_rho <- tcIsDeepRho orig_arg_rho ; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho) ; if not is_rho - then skipQuickLook ctxt larg orig_arg_ty - else quickLookArg1 ctxt larg orig_arg_ty } - -skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType - -> TcM (HsExprArg 'TcpInst) -skipQuickLook ctxt larg arg_ty - = return (EValArg { ea_ctxt = ctxt - , ea_arg = larg - , ea_arg_ty = arg_ty }) - -whenQL :: QLFlag -> ZonkM () -> TcM () -whenQL DoQL thing_inside = liftZonkM thing_inside -whenQL NoQL _ = return () - -tcIsDeepRho :: DeepSubsumptionFlag -> TcType -> TcM Bool --- This top-level zonk step, which is the reason we need a local 'go' loop, --- is subtle. See Section 9 of the QL paper - -tcIsDeepRho ds_flag = go - where - go ty - | isSigmaTy ty - = return False - - | Just kappa <- getTyVar_maybe ty - , isQLInstTyVar kappa - = do { info <- readMetaTyVar kappa - ; case info of - Indirect arg_ty' -> go arg_ty' - Flexi -> return True } - - | Deep {} <- ds_flag - , Just (_, res_ty) <- tcSplitFunTy_maybe ty - = go res_ty - - | otherwise - = return True + then return e_arg + else -isGuardedTy :: TcType -> Bool -isGuardedTy ty - | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal - | Just {} <- tcSplitAppTy_maybe ty = True - | otherwise = False - -quickLookArg1 :: AppCtxt -> LHsExpr GhcRn - -> Scaled TcRhoType -- Deeply skolemised - -> TcM (HsExprArg 'TcpInst) --- quickLookArg1 implements the "QL Argument" judgement in Fig 5 of the paper -quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) - = addArgCtxt ctxt larg $ -- Context needed for constraints + addArgCtxt ctxt larg $ -- Context needed for constraints -- generated by calls in arg do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg @@ -1920,7 +1874,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) , text "args:" <+> ppr rn_args ] ; case mb_fun_ty of { - Nothing -> skipQuickLook ctxt larg sc_arg_ty ; -- fun is too complicated + Nothing -> return e_arg ; -- fun is too complicated Just (tc_fun, fun_sigma) -> -- step 2: use |-inst to instantiate the head applied to the arguments @@ -1930,9 +1884,10 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) <- captureConstraints $ tcInstFun do_ql True tc_head fun_sigma rn_args -- We must capture type-class and equality constraints here, but - -- not equality constraints. See (QLA6) in Note [Quick Look at + -- not usage constraints. See (QLA6) in Note [Quick Look at -- value arguments] +{- ; traceTc "quickLookArg 2" $ vcat [ text "arg:" <+> ppr arg , text "orig_arg_rho:" <+> ppr orig_arg_rho @@ -1943,10 +1898,10 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) -- or: (B) fiv(app_res_rho) = emptyset -- This tells us if the quick look at the argument yields information that -- influences the enclosing function call - -- NB: guardedness is computed based on the original, - -- unzonked orig_arg_rho, so that we deliberately do - -- not exploit guardedness that emerges a result of QL on earlier args - -- We must do the anyFreeKappa test /after/ tcInstFun; see (QLA3). + -- NB: `isGuardedTy` is computed based on the original, + -- unzonked orig_arg_rho, so that we deliberately do not exploit + -- guardedness that emerges a result of QL on earlier args + -- In contrast, we must do the `anyFreeKappa` test /after/ tcInstFun; see (QLA3). ; arg_influences_enclosing_call <- if isGuardedTy orig_arg_rho then return True @@ -1957,18 +1912,69 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho) -- NB: orig_arg_rho may not be zonked, but that's ok ; when arg_influences_enclosing_call $ qlUnify app_res_rho orig_arg_rho +-} + + ; (arg_influences_call, inst_args') + <- if isGuardedTy orig_arg_rho + then do { qlUnify app_res_rho orig_arg_rho + ; inst_args' <- mapM quickLookArg inst_args + ; return (True, inst_args') } + else do { inst_args' <- mapM quickLookArg inst_args + ; has_free_inst_vars <- anyFreeKappa app_res_rho + ; if has_free_inst_vars + then return (False, inst_args') + else do { qlUnify app_res_rho orig_arg_rho + ; return (True, inst_args') } } ; traceTc "quickLookArg done }" (ppr rn_fun) ; return (EValArgQL { eaql_ctxt = ctxt - , eaql_arg_ty = sc_arg_ty + , eaql_arg_ty = orig_arg_ty , eaql_larg = larg , eaql_tc_fun = tc_head , eaql_fun_ue = fun_ue - , eaql_args = inst_args + , eaql_args = inst_args' , eaql_wanted = wanted - , eaql_encl = arg_influences_enclosing_call - , eaql_res_rho = app_res_rho }) }}} + , eaql_encl = arg_influences_call + , eaql_res_rho = app_res_rho }) }}}} + +quickLookArg other_arg = return other_arg + +whenQL :: QLFlag -> ZonkM () -> TcM () +whenQL DoQL thing_inside = liftZonkM thing_inside +whenQL NoQL _ = return () + +tcIsDeepRho :: TcType -> TcM Bool +-- This top-level zonk step, which is the reason we need a local 'go' loop, +-- is subtle. See Section 9 of the QL paper + +tcIsDeepRho ty + = do { ds_flag <- getDeepSubsumptionFlag + ; go ds_flag ty } + where + go ds_flag ty + | isSigmaTy ty + = return False + + | Just kappa <- getTyVar_maybe ty + , isQLInstTyVar kappa + = do { info <- readMetaTyVar kappa + ; case info of + Indirect arg_ty' -> go ds_flag arg_ty' + Flexi -> return True } + + | Deep {} <- ds_flag + , Just (_, res_ty) <- tcSplitFunTy_maybe ty + = go ds_flag res_ty + + | otherwise + = return True + +isGuardedTy :: TcType -> Bool +isGuardedTy ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal + | Just {} <- tcSplitAppTy_maybe ty = True + | otherwise = False {- ********************************************************************* * * @@ -2075,13 +2081,14 @@ We will instantiate Just with kappa, say, and then call quickLookArg1 False {kappa} (ids ++ ids) kappa The call to tcInstFun will return with app_res_rho = [forall a. a->a] which has no free instantiation variables, so we can QL-unify - kappa ~ [Forall a. a->a] + kappa ~ [forall a. a->a] -} anyFreeKappa :: TcType -> TcM Bool -- True if there is a free instantiation variable -- in the argument type, after zonking -- See Note [The fiv test in quickLookArg] +-- The function is monadic; it does not require a zonked type as input anyFreeKappa ty = unTcMBool (foldQLInstVars go_tv ty) where go_tv tv = TCMB $ do { info <- readMetaTyVar tv ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -3076,15 +3076,16 @@ lhsPriority tv RuntimeUnk -> 0 SkolemTv {} -> 0 MetaTv { mtv_info = info, mtv_tclvl = lvl } - | QLInstVar <- lvl - -> 5 -- Eliminate instantiation variables first - | otherwise -> case info of CycleBreakerTv -> 0 TyVarTv -> 1 - ConcreteTv {} -> 2 - TauTv -> 3 - RuntimeUnkTv -> 4 + ConcreteTv {} -> qli 2 -- 2,3 + TauTv -> qli 4 -- 4,5 + RuntimeUnkTv -> 6 + where + qli n = case lvl of + QLInstVar -> n+1 -- Eliminate instantiation variables first + _ -> n {- Note [Unification preconditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/85877603abca70b6c3679067229eb5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/85877603abca70b6c3679067229eb5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26548] 40 commits: compiler: Exclude units with no exposed modules from unused package check
by Simon Peyton Jones (＠simonpj) 20 Nov '25

20 Nov '25

Simon Peyton Jones pushed to branch wip/T26548 at Glasgow Haskell Compiler / GHC Commits: 5cdcfaed by Ben Gamari at 2025-11-06T09:01:36-05:00 compiler: Exclude units with no exposed modules from unused package check Such packages cannot be "used" in the Haskell sense of the word yet are nevertheless necessary as they may provide, e.g., C object code or link flags. Fixes #24120. - - - - - 74b8397a by Brandon Chinn at 2025-11-06T09:02:19-05:00 Replace deprecated argparse.FileType - - - - - 36ddf988 by Ben Gamari at 2025-11-06T09:03:01-05:00 Bump unix submodule to 2.8.8.0 Closes #26474. - - - - - c32b3a29 by fendor at 2025-11-06T09:03:43-05:00 Fix assertion in `postStringLen` to account for \0 byte We fix the assertion to handle trailing \0 bytes in `postStringLen`. Before this change, the assertion looked like this: ASSERT(eb->begin + eb->size > eb->pos + len + 1); Let's assume some values to see why this is actually off by one: eb->begin = 0 eb->size = 1 eb->pos = 0 len = 1 then the assertion would trigger correctly: 0 + 1 > 0 + 1 + 1 => 1 > 2 => false as there is not enough space for the \0 byte (which is the trailing +1). However, if we change `eb->size = 2`, then we do have enough space for a string of length 1, but the assertion still fails: 0 + 2 > 0 + 1 + 1 => 2 > 2 => false Which causes the assertion to fail if there is exactly enough space for the string with a trailing \0 byte. Clearly, the assertion should be `>=`! If we switch around the operand, it should become more obvious that `<=` is the correct comparison: ASSERT(eb->pos + len + 1 <= eb->begin + eb->size); This is expresses more naturally that the current position plus the length of the string (and the null byte) must be smaller or equal to the overall size of the buffer. This change also is in line with the implementation in `hasRoomForEvent` and `hasRoomForVariableEvent`: ``` StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum) { uint32_t size = ...; if (eb->pos + size > eb->begin + eb->size) ... ``` the check `eb->pos + size > eb->begin + eb->size` is identical to `eb->pos + size <= eb->begin + eb->size` plus a negation. - - - - - 3034a6f2 by Ben Gamari at 2025-11-06T09:04:24-05:00 Bump os-string submodule to 2.0.8 - - - - - 39567e85 by Cheng Shao at 2025-11-06T09:05:06-05:00 rts: use computed goto for instruction dispatch in the bytecode interpreter This patch uses computed goto for instruction dispatch in the bytecode interpreter. Previously instruction dispatch is done by a classic switch loop, so executing the next instruction requires two jumps: one to the start of the switch loop and another to the case block based on the instruction tag. By using computed goto, we can build a jump table consisted of code addresses indexed by the instruction tags themselves, so executing the next instruction requires only one jump, to the destination directly fetched from the jump table. Closes #12953. - - - - - 93fc7265 by sheaf at 2025-11-06T21:33:24-05:00 Correct hasFixedRuntimeRep in matchExpectedFunTys This commit fixes a bug in the representation-polymormorphism check in GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put the coercion resulting from hasFixedRuntimeRep in the wrong place, leading to the Core Lint error reported in #26528. The change is that we have to be careful when using 'mkWpFun': it expects **both** the expected and actual argument types to have a syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT] in GHC.Tc.Types.Evidence. On the way, this patch improves some of the commentary relating to other usages of 'mkWpFun' in the compiler, in particular in the view pattern case of 'tc_pat'. No functional changes, but some stylistic changes to make the code more readable, and make it easier to understand how we are upholding the WpFun-FRR-INVARIANT. Fixes #26528 - - - - - c052c724 by Simon Peyton Jones at 2025-11-06T21:34:06-05:00 Fix a horrible shadowing bug in implicit parameters Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts where we now do /not/ delete /Wanted/ implicit-parameeter constraints. This bug has been in GHC since 9.8! But it's quite hard to provoke; I contructed a tests in T26451, but it was hard to do so. - - - - - b253013e by Georgios Karachalias at 2025-11-07T17:21:57-05:00 Remove the `CoreBindings` constructor from `LinkablePart` Adjust HscRecompStatus to disallow unhydrated WholeCoreBindings from being passed as input to getLinkDeps (which would previously panic in this case). Fixes #26497 - - - - - ac7b737e by Sylvain Henry at 2025-11-07T17:22:51-05:00 Testsuite: pass ext-interp test way (#26552) Note that some tests are still marked as broken with the ext-interp way (see #26552 and #14335) - - - - - 3c2f4bb4 by sheaf at 2025-11-11T11:47:28-05:00 Preserve user-written kinds in data declarations This commit ensures that we preserve the user-written kind for data declarations, e.g. in type T2T = Type -> Type type D :: T2T data D a where { .. } that we preserve the user-written kind of D as 'T2T', instead of expanding the type synonym 'T2T' during kind checking. We do this by storing 'tyConKind' separately from 'tyConResKind'. This means that 'tyConKind' is not necessarily equal to 'mkTyConKind binders res_kind', as e.g. in the above example the former is 'T2T' while the latter is 'Type -> Type'. This is explained in Note [Preserve user-written TyCon kind] in GHC.Core.TyCon. This is particularly important for Haddock, as the kinds stored in interface files affect the generated documentation, and we want to preserve the user-written types as much as possible. - - - - - 19859584 by sheaf at 2025-11-11T11:47:28-05:00 Store user-written datacon tvs in interface files This commit ensures we store the user-written quantified type variables of data constructors in interface files, e.g. in data D a where MkD1 :: forall x. x -> D x MkD2 :: forall u v. u -> v -> D v The previous behaviour was to rename the universal variables to match the universal variables of the data constructor. This was undesirable because the names that end up in interface files end up mattering for generated Haddock documentation; it's better to preserve the user-written type variables. Moreover, the universal variables may not have been user-written at all, e.g. in an example such as: type T2T = Type -> Type data G :: T2T where MkG :: forall x. D x Here GHC will invent the type variable name 'a' for the first binder of the TyCon G. We really don't want to then rename the user-written 'x' into the generated 'a'. - - - - - 034b2056 by sheaf at 2025-11-11T11:47:28-05:00 DataCon univ_tvs names: pick TyCon over inferred This commit changes how we compute the names of universal type variables in GADT data constructors. This augments the existing logic that chose which type variable name to use, in GHC.Tc.TyCl.mkGADTVars. We continue to prefer DataCon tv names for user-written binders, but we now prefer TyCon tv names for inferred (non-user-written) DataCon binders. This makes a difference in examples such as: type (:~~:) :: k1 -> k2 -> Type data a :~~: b where HRefl :: a :~~: a Before this patch, we ended up giving HRefl the type: forall {k2}. forall (a :: k2). a :~~: a whereas we now give it the type: forall {k1}. forall (a :: k1). a :~~: a The important part isn't really 'k1' or 'k2', but more that the inferred type variable names of the DataCon can be arbitrary/unpredictable (as they are chosen by GHC and depend on how unification proceeds), so it's much better to use the more predictable TyCon type variable names. - - - - - 95078d00 by sheaf at 2025-11-11T11:47:28-05:00 Backpack Rename: use explicit record construction This commit updates the Backpack boilerplate in GHC.Iface.Rename to use explicit record construction rather than record update. This makes sure that the code stays up to date when the underlying constructors change (e.g. new fields are added). The rationale is further explained in Note [Prefer explicit record construction]. - - - - - 2bf36263 by sheaf at 2025-11-11T11:47:28-05:00 Store # eta binders in TyCon and use for Haddock This commit stores the number of TyCon binders that were introduced by eta-expansion (by the function GHC.Tc.Gen.HsType.splitTyConKind). This is then used to pretty-print the TyCon as the user wrote it, e.g. for type Effect :: (Type -> Type) -> Type -> Type data State s :: Effect where {..} -- arity 3 GHC will eta-expand the data declaration to data State s a b where {..} but also store in the 'TyCon' that the number of binders introduced by this eta expansion is 2. This allows us, in 'Haddock.Convert.synifyTyConKindSig', to recover the original user-written syntax, preserving the user's intent in Haddock documentation. See Note [Inline kind signatures with GADTSyntax] in Haddock.Convert. - - - - - 6c91582f by Matthew Pickering at 2025-11-11T11:48:12-05:00 driver: Properly handle errors during LinkNode steps Previously we were not properly catching errors during the LinkNode step (see T9930fail test). This is fixed by wrapping the `LinkNode` action in `wrapAction`, the same handler which is used for module compilation. Fixes #26496 - - - - - e1e1eb32 by Matthew Pickering at 2025-11-11T11:48:54-05:00 driver: Remove unecessary call to hscInsertHPT This call was left-over from e9445c013fbccf9318739ca3d095a3e0a2e1be8a If you follow the functions which call `upsweep_mod`, they immediately add the interface to the HomePackageTable when `upsweep_mod` returns. - - - - - b22777d4 by ARATA Mizuki at 2025-11-11T11:49:44-05:00 LLVM backend: Pass the +evex512 attribute to LLVM 18+ if -mavx512f is set The newer LLVM requires the +evex512 attribute to enable use of ZMM registers. LLVM exhibits a backward-compatible behavior if the cpu is `x86-64`, but not if `penryn`. Therefore, on macOS, where the cpu is set to `penryn`, we need to explicitly pass +evex512. Fixes #26410 - - - - - 6ead7d06 by Vladislav Zavialov at 2025-11-11T11:50:26-05:00 Comments only in GHC.Parser.PostProcess.Haddock Remove outdated Note [Register keyword location], as the issue it describes was addressed by commit 05eb50dff2fcc78d025e77b9418ddb369db49b9f. - - - - - 43fa8be8 by sheaf at 2025-11-11T11:51:18-05:00 localRegistersConflict: account for assignment LHS This commit fixes a serious oversight in GHC.Cmm.Sink.conflicts, specifically the code that computes which local registers conflict between an assignment and a Cmm statement. If we have: assignment: <local_reg> = <expr> node: <local_reg> = <other_expr> then clearly the two conflict, because we cannot move one statement past the other, as they assign two different values to the same local register. (Recall that 'conflicts (local_reg,expr) node' is False if and only if the assignment 'local_reg = expr' can be safely commuted past the statement 'node'.) The fix is to update 'GHC.Cmm.Sink.localRegistersConflict' to take into account the following two situations: (1) 'node' defines the LHS local register of the assignment, (2) 'node' defines a local register used in the RHS of the assignment. The bug is precisely that we were previously missing condition (1). Fixes #26550 - - - - - 79dfcfe0 by sheaf at 2025-11-11T11:51:18-05:00 Update assigned register format when spilling When we come to spilling a register to put new data into it, in GHC.CmmToAsm.Reg.Linear.allocRegsAndSpill_spill, we need to: 1. Spill the data currently in the register. That is, do a spill with a format that matches what's currently in the register. 2. Update the register assignment, allocating a virtual register to this real register, but crucially **updating the format** of this assignment. Due to shadowing in the Haskell code for allocRegsAndSpill_spill, we were mistakenly re-using the old format. This could lead to a situation where: a. We were using xmm6 to store a Double#. b. We want to store a DoubleX2# into xmm6, so we spill the current content of xmm6 to the stack using a scalar move (correct). c. We update the register assignment, but we fail to update the format of the assignment, so we continue to think that xmm6 stores a Double# and not a DoubleX2#. d. Later on, we need to spill xmm6 because it is getting clobbered by another instruction. We then decide to only spill the lower 64 bits of the register, because we still think that xmm6 only stores a Double# and not a DoubleX2#. Fixes #26542 - - - - - aada5db9 by ARATA Mizuki at 2025-11-11T11:52:07-05:00 Fix the order of spill/reload instructions The AArch64 NCG could emit multiple instructions for a single spill/reload, but their order was not consistent between the definition and a use. Fixes #26537 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - 64ec82ff by Andreas Klebinger at 2025-11-11T11:52:48-05:00 Add hpc to release script - - - - - 741da00c by Ben Gamari at 2025-11-12T03:38:20-05:00 template-haskell: Better describe getQ semantics Clarify that the state is a type-indexed map, as suggested by #26484. - - - - - 8b080e04 by ARATA Mizuki at 2025-11-12T03:39:11-05:00 Fix incorrect markups in the User's Guide * Correct markup for C--: "C-\-" in reST * Fix internal links * Fix code highlighting * Fix inline code: Use ``code`` rather than `code` * Remove extra backslashes Fixes #16812 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - a00840ea by Simon Peyton Jones at 2025-11-14T15:23:56+00:00 Make TYPE and CONSTRAINT apart again This patch finally fixes #24279. * The story started with #11715 * Then #21623 articulated a plan, which made Type and Constraint not-apart; a horrible hack but it worked. The main patch was commit 778c6adca2c995cd8a1b84394d4d5ca26b915dac Author: Simon Peyton Jones <simonpj(a)microsoft.com> Date: Wed Nov 9 10:33:22 2022 +0000 Type vs Constraint: finally nailed * #24279 reported a bug in the above big commit; this small patch fixes it commit af6932d6c068361c6ae300d52e72fbe13f8e1f18 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Mon Jan 8 10:49:49 2024 +0000 Make TYPE and CONSTRAINT not-apart Issue #24279 showed up a bug in the logic in GHC.Core.Unify.unify_ty which is supposed to make TYPE and CONSTRAINT be not-apart. * Then !10479 implemented "unary classes". * That change in turn allows us to make Type and Constraint apart again, cleaning up the compiler and allowing a little bit more expressiveness. It fixes the original hope in #24279, namely that `Type` and `Constraint` should be distinct throughout. - - - - - c0a1e574 by Georgios Karachalias at 2025-11-15T05:14:31-05:00 Report all missing modules with -M We now report all missing modules at once in GHC.Driver.Makefile.processDeps, as opposed to only reporting a single missing module. Fixes #26551. - - - - - c9fa3449 by Sylvain Henry at 2025-11-15T05:15:26-05:00 JS: fix array index for registers We used to store R32 in h$regs[-1]. While it's correct in JavaScript, fix this to store R32 in h$regs[0] instead. - - - - - 9e469909 by Sylvain Henry at 2025-11-15T05:15:26-05:00 JS: support more than 128 registers (#26558) The JS backend only supported 128 registers (JS variables/array slots used to pass function arguments). It failed in T26537 when 129 registers were required. This commit adds support for more than 128 registers: it is now limited to maxBound :: Int (compiler's Int). If we ever go above this threshold the compiler now panics with a more descriptive message. A few built-in JS functions were assuming 128 registers and have been rewritten to use loops. Note that loops are only used for "high" registers that are stored in an array: the 31 "low" registers are still handled with JS global variables and with explicit switch-cases to maintain good performance in the most common cases (i.e. few registers used). Adjusting the number of low registers is now easy: just one constant to adjust (GHC.StgToJS.Regs.lowRegsCount). No new test added: T26537 is used as a regression test instead. - - - - - 0a64a78b by Sven Tennie at 2025-11-15T20:31:10-05:00 AArch64: Simplify CmmAssign and CmmStore The special handling for floats was fake: The general case is always used. So, the additional code path isn't needed (and only adds complexity for the reader.) - - - - - 15b311be by sheaf at 2025-11-15T20:32:02-05:00 SimpleOpt: refactor & push coercions into lambdas This commit improves the simple optimiser (in GHC.Core.SimpleOpt) in a couple of ways: - The logic to push coercion lambdas is shored up. The function 'pushCoercionIntoLambda' used to be called in 'finish_app', but this meant we could not continue to optimise the program after performing this transformation. Now, we call 'pushCoercionIntoLambda' as part of 'simple_app'. Doing so can be important when dealing with unlifted newtypes, as explained in Note [Desugaring unlifted newtypes]. - The code is re-structured to avoid duplication and out-of-sync code paths. Now, 'simple_opt_expr' defers to 'simple_app' for the 'App', 'Var', 'Cast' and 'Lam' cases. This means all the logic for those is centralised in a single place (e.g. the 'go_lam' helper function). To do this, the general structure is brought a bit closer to the full-blown simplifier, with a notion of 'continuation' (see 'SimpleContItem'). This commit also modifies GHC.Core.Opt.Arity.pushCoercionIntoLambda to apply a substitution (a slight generalisation of its existing implementation). - - - - - b33284c7 by sheaf at 2025-11-15T20:32:02-05:00 Improve typechecking of data constructors This commit changes the way in which we perform typecheck data constructors, in particular how we make multiplicities line up. Now, impedance matching occurs as part of the existing subsumption machinery. See the revamped Note [Typechecking data constructors] in GHC.Tc.Gen.App, as well as Note [Polymorphisation of linear fields] in GHC.Core.Multiplicity. This allows us to get rid of a fair amount of hacky code that was added with the introduction of LinearTypes; in particular the logic of GHC.Tc.Gen.Head.tcInferDataCon. ------------------------- Metric Decrease: T10421 T14766 T15164 T15703 T19695 T5642 T9630 WWRec ------------------------- - - - - - b6faf5d0 by sheaf at 2025-11-15T20:32:02-05:00 Handle unsaturated rep-poly newtypes This commit allows GHC to handle unsaturated occurrences of unlifted newtype constructors. The plan is detailed in Note [Eta-expanding rep-poly unlifted newtypes] in GHC.Tc.Utils.Concrete: for unsaturated unlifted newtypes, we perform the appropriate representation-polymorphism check in tcInstFun. - - - - - 682bf979 by Mike Pilgrem at 2025-11-16T16:44:14+00:00 Fix #26293 Valid stack.yaml for hadrian - - - - - acc70c3a by Simon Peyton Jones at 2025-11-18T16:21:20-05:00 Fix a bug in defaulting Addresses #26582 Defaulting was doing some unification but then failing to iterate. Silly. I discovered that the main solver was unnecessarily iterating even if there was a unification for an /outer/ unification variable, so I fixed that too. - - - - - c12fa73e by Simon Peyton Jones at 2025-11-19T02:55:01-05:00 Make PmLit be in Ord, and use it in Map This MR addresses #26514, by changing from data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] to data PmAltConSet = PACS !(UniqDSet ConLike) !(Map PmLit PmLit) This matters when doing pattern-match overlap checking, when there is a very large set of patterns. For most programs it makes no difference at all. For the N=5000 case of the repro case in #26514, compiler mutator time (with `-fno-code`) goes from 1.9s to 0.43s. All for the price for an Ord instance for PmLit - - - - - 41b84f40 by sheaf at 2025-11-19T02:55:52-05:00 Add passing tests for #26311 and #26072 This commit adds two tests cases that now pass since landing the changes to typechecking of data constructors in b33284c7. Fixes #26072 #26311 - - - - - 1faa758a by sheaf at 2025-11-19T02:55:52-05:00 mkCast: weaken bad cast warning for multiplicity This commit weakens the warning message emitted when constructing a bad cast in mkCast to ignore multiplicity. Justification: since b33284c7, GHC uses sub-multiplicity coercions to typecheck data constructors. The coercion optimiser is free to discard these coercions, both for performance reasons, and because GHC's Core simplifier does not (yet) preserve linearity. We thus weaken 'mkCast' to use 'eqTypeIgnoringMultiplicity' instead of 'eqType', to avoid getting many spurious warnings about mismatched multiplicities. - - - - - 21339faf by Simon Peyton Jones at 2025-11-20T13:41:02+00:00 Fix evaluated-ness bug in Simplifier This fixes #26548, an error which meant that we were failing to attach evaluated-ness flags to case-alternative-bound variables - - - - - 032a880a by Simon Peyton Jones at 2025-11-20T13:41:02+00:00 Be a little less eager to inline - - - - - 239 changed files: - .gitlab/rel_eng/upload_ghc_libs.py - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Literals.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Cmm/Sink.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/RoughMap.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Hs/Expr.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/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Regs.hs - compiler/GHC/StgToJS/Rts/Rts.hs - compiler/GHC/StgToJS/Rts/Types.hs - compiler/GHC/Tc/Gen/App.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/Pat.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/SourceText.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Module/Status.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs - docs/users_guide/9.16.1-notes.rst - docs/users_guide/bugs.rst - docs/users_guide/compare-flags.py - docs/users_guide/debug-info.rst - docs/users_guide/debugging.rst - docs/users_guide/extending_ghc.rst - docs/users_guide/exts/arrows.rst - docs/users_guide/exts/derive_any_class.rst - docs/users_guide/exts/deriving_extra.rst - docs/users_guide/exts/deriving_inferred.rst - docs/users_guide/exts/deriving_strategies.rst - docs/users_guide/exts/gadt.rst - docs/users_guide/exts/generics.rst - docs/users_guide/exts/overloaded_labels.rst - docs/users_guide/exts/overloaded_strings.rst - docs/users_guide/exts/pattern_synonyms.rst - docs/users_guide/exts/poly_kinds.rst - docs/users_guide/exts/primitives.rst - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/rebindable_syntax.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/exts/scoped_type_variables.rst - docs/users_guide/exts/standalone_deriving.rst - docs/users_guide/exts/template_haskell.rst - docs/users_guide/exts/tuple_sections.rst - docs/users_guide/exts/type_data.rst - docs/users_guide/exts/type_defaulting.rst - docs/users_guide/gone_wrong.rst - docs/users_guide/hints.rst - docs/users_guide/javascript.rst - docs/users_guide/phases.rst - docs/users_guide/profiling.rst - docs/users_guide/separate_compilation.rst - docs/users_guide/using.rst - docs/users_guide/wasm.rst - docs/users_guide/win32-dlls.rst - hadrian/stack.yaml - hadrian/stack.yaml.lock - libraries/base/tests/all.T - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/os-string - libraries/unix - rts/Interpreter.c - rts/eventlog/EventLog.c - rts/gen_event_types.py - rts/include/rts/Bytecodes.h - testsuite/driver/runtests.py - testsuite/driver/testlib.py - testsuite/tests/backpack/should_fail/T19244a.stderr - + testsuite/tests/codeGen/should_run/T26537.hs - + testsuite/tests/codeGen/should_run/T26537.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/dependent/should_fail/T11334b.stderr - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/Makefile - testsuite/tests/driver/T20696/all.T - + testsuite/tests/driver/T24120.hs - + testsuite/tests/driver/T26551.hs - + testsuite/tests/driver/T26551.stderr - testsuite/tests/driver/all.T - testsuite/tests/driver/fat-iface/all.T - testsuite/tests/generics/T10604/T10604_deriving.stderr - testsuite/tests/ghc-e/should_fail/T9930fail.stderr - testsuite/tests/ghc-e/should_fail/all.T - testsuite/tests/ghci.debugger/scripts/print012.stdout - testsuite/tests/ghci/scripts/T10321.stdout - testsuite/tests/ghci/scripts/T24459.stdout - testsuite/tests/ghci/scripts/T7730.stdout - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/ghci051.stderr - testsuite/tests/ghci/scripts/ghci065.stdout - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/indexed-types/should_compile/T12538.stderr - testsuite/tests/indexed-types/should_fail/T21092.hs - − testsuite/tests/indexed-types/should_fail/T21092.stderr - testsuite/tests/indexed-types/should_fail/all.T - 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/linear/should_compile/LinearEtaExpansions.hs - testsuite/tests/linear/should_compile/all.T - testsuite/tests/linear/should_fail/TypeClass.hs - testsuite/tests/linear/should_fail/TypeClass.stderr - testsuite/tests/linear/should_run/LinearGhci.stdout - + testsuite/tests/linear/should_run/T26311.hs - + testsuite/tests/linear/should_run/T26311.stdout - testsuite/tests/linear/should_run/all.T - testsuite/tests/numeric/should_compile/T16402.stderr-ws-64 - testsuite/tests/numeric/should_compile/T19641.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/perf/compiler/all.T - testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr - testsuite/tests/rename/should_fail/rnfail055.stderr - testsuite/tests/rep-poly/RepPolyCase1.stderr - − testsuite/tests/rep-poly/RepPolyCase2.stderr - testsuite/tests/rep-poly/RepPolyRule3.stderr - testsuite/tests/rep-poly/RepPolyTuple4.stderr - testsuite/tests/rep-poly/T13233.stderr - − testsuite/tests/rep-poly/T17021.stderr - testsuite/tests/rep-poly/T20363b.stderr - − testsuite/tests/rep-poly/T21650_a.stderr - − testsuite/tests/rep-poly/T21650_b.stderr - + testsuite/tests/rep-poly/T26072.hs - + testsuite/tests/rep-poly/T26072b.hs - + testsuite/tests/rep-poly/T26528.hs - testsuite/tests/rep-poly/UnliftedNewtypesLevityBinder.stderr - testsuite/tests/rep-poly/all.T - testsuite/tests/saks/should_compile/saks023.stdout - testsuite/tests/saks/should_compile/saks034.stdout - testsuite/tests/saks/should_compile/saks035.stdout - testsuite/tests/showIface/Makefile - + testsuite/tests/showIface/T26246a.hs - + testsuite/tests/showIface/T26246a.stdout - testsuite/tests/showIface/all.T - + testsuite/tests/simd/should_run/T26410_ffi.hs - + testsuite/tests/simd/should_run/T26410_ffi.stdout - + testsuite/tests/simd/should_run/T26410_ffi_c.c - + testsuite/tests/simd/should_run/T26410_prim.hs - + testsuite/tests/simd/should_run/T26410_prim.stdout - + testsuite/tests/simd/should_run/T26542.hs - + testsuite/tests/simd/should_run/T26542.stdout - + testsuite/tests/simd/should_run/T26550.hs - + testsuite/tests/simd/should_run/T26550.stdout - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simplCore/should_compile/T26548.hs - + testsuite/tests/simplCore/should_compile/T26548.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/splice-imports/all.T - testsuite/tests/typecheck/T16127/T16127.stderr - testsuite/tests/typecheck/should_compile/T22560d.stdout - + testsuite/tests/typecheck/should_compile/T26451.hs - + testsuite/tests/typecheck/should_compile/T26582.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T15629.stderr - testsuite/tests/typecheck/should_fail/T15883e.stderr - testsuite/tests/typecheck/should_fail/T2414.stderr - testsuite/tests/typecheck/should_fail/T24279.hs - − testsuite/tests/typecheck/should_fail/T24279.stderr - testsuite/tests/typecheck/should_fail/T2534.stderr - testsuite/tests/typecheck/should_fail/T7264.stderr - testsuite/tests/typecheck/should_fail/all.T - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug1050.html - + utils/haddock/html-test/ref/Bug26246.html - utils/haddock/html-test/ref/Bug85.html - utils/haddock/html-test/ref/Bug923.html - utils/haddock/html-test/ref/BundledPatterns.html - utils/haddock/html-test/ref/BundledPatterns2.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/GADTRecords.html - utils/haddock/html-test/ref/LinearTypes.html - utils/haddock/html-test/ref/PromotedTypes.html - + utils/haddock/html-test/src/Bug26246.hs - utils/haddock/hypsrc-test/ref/src/Classes.html - utils/haddock/hypsrc-test/ref/src/Quasiquoter.html - utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86685eec36d6974608b56528b314f6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86685eec36d6974608b56528b314f6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26595-fragile] Mark T26410_ffi as fragile on Windows
by sheaf (＠sheaf) 20 Nov '25

20 Nov '25

sheaf pushed to branch wip/T26595-fragile at Glasgow Haskell Compiler / GHC Commits: 7eeedbed by sheaf at 2025-11-20T10:43:05+01:00 Mark T26410_ffi as fragile on Windows As seen in #26595, this test intermittently fails on Windows. This commit marks it as fragile, until we get around to fixing it. - - - - - 1 changed file: - testsuite/tests/simd/should_run/all.T Changes: ===================================== testsuite/tests/simd/should_run/all.T ===================================== @@ -175,6 +175,7 @@ test('T26410_ffi' , [ only_ways(llvm_ways) # SIMD NCG TODO: support 512-bit wide vectors , unless(arch('x86_64') and have_cpu_feature('avx512f'), skip) , extra_hc_opts('-mavx512f -optc -mavx512f -optlc -mcpu=penryn') + , when(opsys('mingw32'), fragile(26595)) ] , compile_and_run if have_cpu_feature('avx512f') else compile , ['T26410_ffi_c.c']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7eeedbedba05bab6379f5fe7d43dabc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7eeedbedba05bab6379f5fe7d43dabc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Build external interpreter program on demand (#24731)
by Marge Bot (＠marge-bot) 20 Nov '25

20 Nov '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 43198b09 by Sylvain Henry at 2025-11-19T20:38:18-05:00 Build external interpreter program on demand (#24731) This patch teaches GHC how to build the external interpreter program when it is missing. As long as we have the `ghci` library, doing this is trivial so most of this patch is refactoring for doing it sanely. - - - - - c900b914 by Rodrigo Mesquita at 2025-11-19T20:38:19-05:00 Add tests for #23973 and #26565 These were fixed by 4af4f0f070f83f948e49ad5d7835fd91b8d3f0e6 in !10417 - - - - - 28 changed files: - compiler/GHC.hs - + compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/Config/Linker.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Linker/Config.hs - compiler/GHC/Linker/Dynamic.hs - + compiler/GHC/Linker/Executable.hs - − compiler/GHC/Linker/ExtraObj.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/MacOS.hs - compiler/GHC/Linker/Static.hs - compiler/GHC/Linker/Windows.hs - + compiler/GHC/Runtime/Interpreter/C.hs - + compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/SysTools/Tasks.hs - compiler/ghc.cabal.in - + testsuite/tests/bytecode/T23973.hs - + testsuite/tests/bytecode/T23973.script - + testsuite/tests/bytecode/T23973.stdout - + testsuite/tests/bytecode/T26565.hs - + testsuite/tests/bytecode/T26565.script - + testsuite/tests/bytecode/T26565.stdout - testsuite/tests/bytecode/all.T - + testsuite/tests/driver/T24731.hs - testsuite/tests/driver/all.T - utils/iserv/iserv.cabal.in Changes: ===================================== compiler/GHC.hs ===================================== @@ -337,7 +337,6 @@ module GHC ( import GHC.Prelude hiding (init) import GHC.Platform -import GHC.Platform.Ways import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename , isSourceFilename, startPhase ) @@ -351,7 +350,6 @@ import GHC.Driver.Backend import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.StgToJS (initStgToJSConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Main import GHC.Driver.Make @@ -360,10 +358,11 @@ import GHC.Driver.Monad import GHC.Driver.Ppr import GHC.ByteCode.Types -import qualified GHC.Linker.Loader as Loader import GHC.Runtime.Loader import GHC.Runtime.Eval import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Init +import GHC.Driver.Config.Interpreter import GHC.Runtime.Context import GHCi.RemoteTypes @@ -439,10 +438,8 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo import qualified GHC.Unit.Home.Graph as HUG -import GHC.Settings import Control.Applicative ((<|>)) -import Control.Concurrent import Control.Monad import Control.Monad.Catch as MC import Data.Foldable @@ -715,98 +712,16 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m () setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger - lookup_cache <- liftIO $ mkInterpSymbolCache - - -- see Note [Target code interpreter] - interp <- if -#if !defined(wasm32_HOST_ARCH) - -- Wasm dynamic linker - | ArchWasm32 <- platformArch $ targetPlatform dflags - -> do - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - dyld <- liftIO $ makeAbsolute $ topDir dflags </> "dyld.mjs" - libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger dflags "libraries" - let profiled = ways dflags `hasWay` WayProf - way_tag = if profiled then "_p" else "" - let cfg = - WasmInterpConfig - { wasmInterpDyLD = dyld, - wasmInterpLibDir = libdir, - wasmInterpOpts = getOpts dflags opt_i, - wasmInterpBrowser = gopt Opt_GhciBrowser dflags, - wasmInterpBrowserHost = ghciBrowserHost dflags, - wasmInterpBrowserPort = ghciBrowserPort dflags, - wasmInterpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags, - wasmInterpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags, - wasmInterpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags, - wasmInterpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags, - wasmInterpTargetPlatform = targetPlatform dflags, - wasmInterpProfiled = profiled, - wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags), - wasmInterpUnitState = ue_homeUnitState $ hsc_unit_env hsc_env - } - pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache -#endif - - -- JavaScript interpreter - | ArchJavaScript <- platformArch (targetPlatform dflags) - -> do - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - let cfg = JSInterpConfig - { jsInterpNodeConfig = defaultNodeJsSettings - , jsInterpScript = topDir dflags </> "ghc-interp.js" - , jsInterpTmpFs = hsc_tmpfs hsc_env - , jsInterpTmpDir = tmpDir dflags - , jsInterpLogger = hsc_logger hsc_env - , jsInterpCodegenCfg = initStgToJSConfig dflags - , jsInterpUnitEnv = hsc_unit_env hsc_env - , jsInterpFinderOpts = initFinderOpts dflags - , jsInterpFinderCache = hsc_FC hsc_env - } - return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) - - -- external interpreter - | gopt Opt_ExternalInterpreter dflags - -> do - let - prog = pgm_i dflags ++ flavour - profiled = ways dflags `hasWay` WayProf - dynamic = ways dflags `hasWay` WayDyn - flavour - | profiled && dynamic = "-prof-dyn" - | profiled = "-prof" - | dynamic = "-dyn" - | otherwise = "" - msg = text "Starting " <> text prog - tr <- if verbosity dflags >= 3 - then return (logInfo logger $ withPprStyle defaultDumpStyle msg) - else return (pure ()) - let - conf = IServConfig - { iservConfProgram = prog - , iservConfOpts = getOpts dflags opt_i - , iservConfProfiled = profiled - , iservConfDynamic = dynamic - , iservConfHook = createIservProcessHook (hsc_hooks hsc_env) - , iservConfTrace = tr - } - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) - - -- Internal interpreter - | otherwise - -> -#if defined(HAVE_INTERNAL_INTERPRETER) - do - loader <- liftIO Loader.uninitializedLoader - return (Just (Interp InternalInterp loader lookup_cache)) -#else - return Nothing -#endif - + let platform = targetPlatform dflags + let unit_env = hsc_unit_env hsc_env + let tmpfs = hsc_tmpfs hsc_env + let finder_cache = hsc_FC hsc_env + interp_opts' <- liftIO $ initInterpOpts dflags + let interp_opts = interp_opts' + { interpCreateProcess = createIservProcessHook (hsc_hooks hsc_env) + } + + interp <- liftIO $ initInterpreter tmpfs logger platform finder_cache unit_env interp_opts modifySession $ \h -> hscSetFlags dflags h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -0,0 +1,46 @@ +module GHC.Driver.Config.Interpreter + ( initInterpOpts + ) +where + +import GHC.Prelude +import GHC.Runtime.Interpreter.Init +import GHC.Driver.DynFlags +import GHC.Driver.Session +import GHC.Driver.Config.Finder +import GHC.Driver.Config.StgToJS +import GHC.SysTools.Tasks +import GHC.Linker.Executable + +import System.FilePath +import System.Directory + +initInterpOpts :: DynFlags -> IO InterpOpts +initInterpOpts dflags = do + wasm_dyld <- makeAbsolute $ topDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ topDir dflags </> "ghc-interp.js" + pure $ InterpOpts + { interpExternal = gopt Opt_ExternalInterpreter dflags + , interpProg = pgm_i dflags + , interpOpts = getOpts dflags opt_i + , interpWays = ways dflags + , interpNameVer = ghcNameVersion dflags + , interpCreateProcess = Nothing + , interpWasmDyld = wasm_dyld + , interpBrowser = gopt Opt_GhciBrowser dflags + , interpBrowserHost = ghciBrowserHost dflags + , interpBrowserPort = ghciBrowserPort dflags + , interpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags + , interpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags + , interpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags + , interpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags + , interpJsInterp = js_interp + , interpTmpDir = tmpDir dflags + , interpJsCodegenCfg = initStgToJSConfig dflags + , interpFinderOpts = initFinderOpts dflags + , interpVerbosity = verbosity dflags + , interpLdConfig = configureLd dflags + , interpCcConfig = configureCc dflags + , interpExecutableLinkOpts = initExecutableLinkOpts dflags + } + ===================================== compiler/GHC/Driver/Config/Linker.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Linker.Config import GHC.Driver.DynFlags import GHC.Driver.Session +import GHC.Settings import Data.List (isPrefixOf) @@ -52,6 +53,8 @@ initLinkerConfig dflags = , linkerOptionsPost = post_args , linkerTempDir = tmpDir dflags , linkerFilter = ld_filter + , linkerSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind (toolSettings dflags) + , linkerIsGnuLd = toolSettings_ldIsGnuLd (toolSettings dflags) } {- Note [Solaris linker] ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Driver.DynFlags ( ParMakeCount(..), ways, HasDynFlags(..), ContainsDynFlags(..), - RtsOptsEnabled(..), + RtsOptsEnabled(..), haveRtsOptsFlags, GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), PackageArg(..), ModRenaming(..), @@ -902,6 +902,13 @@ data RtsOptsEnabled | RtsOptsAll deriving (Show) +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True + + -- | Are we building with @-fPIE@ or @-fPIC@ enabled? positionIndependent :: DynFlags -> Bool positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -71,7 +71,7 @@ import GHC.SysTools import GHC.SysTools.Cpp import GHC.Utils.TmpFs -import GHC.Linker.ExtraObj +import GHC.Linker.Executable import GHC.Linker.Static import GHC.Linker.Static.Utils import GHC.Linker.Types @@ -444,7 +444,9 @@ link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt case ghcLink dflags of LinkBinary | backendUseJSLinker (backend dflags) -> linkJSBinary logger tmpfs fc dflags unit_env obj_files pkg_deps - | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps + | otherwise -> do + let opts = initExecutableLinkOpts dflags + linkExecutable logger tmpfs opts unit_env obj_files pkg_deps LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps other -> panicBadLink other @@ -511,7 +513,8 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do if not (null lib_errs) || any (t <) lib_times then return $ needsRecompileBecause LibraryChanged else do - res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file + let opts = initExecutableLinkOpts dflags + res <- checkLinkInfo logger opts unit_env pkg_deps exe_file if res then return $ needsRecompileBecause FlagsChanged else return UpToDate @@ -585,7 +588,9 @@ doLink hsc_env o_files = do LinkBinary | backendUseJSLinker (backend dflags) -> linkJSBinary logger tmpfs fc dflags unit_env o_files [] - | otherwise -> linkBinary logger tmpfs dflags unit_env o_files [] + | otherwise -> do + let opts = initExecutableLinkOpts dflags + linkExecutable logger tmpfs opts unit_env o_files [] LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] LinkMergedObj ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -15,6 +15,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch import GHC.Driver.Hooks +import GHC.Driver.DynFlags import Control.Monad.Trans.Reader import GHC.Driver.Pipeline.Monad import GHC.Driver.Pipeline.Phases @@ -74,7 +75,6 @@ import GHC.CmmToLlvm.Version.Type (LlvmVersion (..)) import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) import GHC.Settings import System.IO -import GHC.Linker.ExtraObj import GHC.Linker.Dynamic import GHC.Utils.Panic import GHC.Utils.Touch @@ -416,6 +416,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do let unit_env = hsc_unit_env hsc_env let home_unit = hsc_home_unit_maybe hsc_env let tmpfs = hsc_tmpfs hsc_env + let tmpdir = tmpDir dflags let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc @@ -437,7 +438,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do let include_paths = include_paths_quote ++ include_paths_global let gcc_extra_viac_flags = extraGccViaCFlags dflags - let pic_c_flags = picCCOpts dflags + let cc_config = configureCc dflags let verbFlags = getVerbFlags dflags @@ -486,14 +487,14 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env withAtomicRename output_fn $ \temp_outputFilename -> - GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( + GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs tmpdir cc_config ( [ GHC.SysTools.Option "-c" , GHC.SysTools.FileOption "" input_fn , GHC.SysTools.Option "-o" , GHC.SysTools.FileOption "" temp_outputFilename ] ++ map GHC.SysTools.Option ( - pic_c_flags + (ccPicOpts cc_config) -- See Note [Produce big objects on Windows] ++ [ "-Wa,-mbig-obj" @@ -1149,7 +1150,8 @@ joinObjectFiles hsc_env o_files output_fn | otherwise = do withAtomicRename output_fn $ \tmp_ar -> - liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files + let ar_opts = configureAr dflags + in liftIO $ runAr logger ar_opts Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files where dashLSupported = sArSupportsDashL (settings dflags) dashL = if dashLSupported then "L" else "" ===================================== compiler/GHC/Linker/Config.hs ===================================== @@ -23,5 +23,7 @@ data LinkerConfig = LinkerConfig , linkerOptionsPost :: [Option] -- ^ Linker options (after user options) , linkerTempDir :: TempDir -- ^ Temporary directory to use , linkerFilter :: [String] -> [String] -- ^ Output filter + , linkerSupportsCompactUnwind :: !Bool -- ^ Does the linker support compact unwind + , linkerIsGnuLd :: !Bool -- ^ Is it GNU LD (used for gc-sections support) } ===================================== compiler/GHC/Linker/Dynamic.hs ===================================== @@ -12,6 +12,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule)) +import GHC.SysTools.Tasks import GHC.Driver.Config.Linker import GHC.Driver.Session @@ -207,8 +208,10 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] ) -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 - when (gopt Opt_RPath dflags) $ - runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn + when (gopt Opt_RPath dflags) $ do + let otool_opts = configureOtool dflags + let install_name_opts = configureInstallName dflags + runInjectRPaths logger otool_opts install_name_opts pkg_lib_paths output_fn _ -> do ------------------------------------------------------------------- -- Making a DSO ===================================== compiler/GHC/Linker/Executable.hs ===================================== @@ -0,0 +1,534 @@ +-- | Linking executables +module GHC.Linker.Executable + ( linkExecutable + , ExecutableLinkOpts (..) + , initExecutableLinkOpts + -- RTS Opts + , RtsOptsEnabled (..) + -- * Link info + , LinkInfo (..) + , initLinkInfo + , checkLinkInfo + , ghcLinkInfoSectionName + , ghcLinkInfoNoteName + , platformSupportsSavingLinkOpts + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Unit +import GHC.Unit.Env + +import GHC.Utils.Asm +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import GHC.Driver.Session +import GHC.Driver.Config.Linker + +import qualified GHC.Data.ShortText as ST + +import GHC.SysTools +import GHC.SysTools.Elf +import GHC.Linker.Config +import GHC.Linker.Unit +import GHC.Linker.MacOS +import GHC.Linker.Windows +import GHC.Linker.Dynamic (libmLinkOpts) +import GHC.Linker.External (runLink) +import GHC.Linker.Static.Utils (exeFileName) + +import Control.Monad +import Data.Maybe +import System.FilePath +import System.Directory + +data ExecutableLinkOpts = ExecutableLinkOpts + { leOutputFile :: Maybe FilePath + , leNameVersion :: GhcNameVersion + , leWays :: Ways + , leDynLibLoader :: DynLibLoader + , leRelativeDynlibPaths :: !Bool + , leUseXLinkerRPath :: !Bool + , leSingleLibFolder :: !Bool + , leWholeArchiveHsLibs :: !Bool + , leGenManifest :: !Bool + , leRPath :: !Bool + , leCompactUnwind :: !Bool + , leLibraryPaths :: [String] + , leFrameworkOpts :: FrameworkOpts + , leManifestOpts :: ManifestOpts + , leLinkerConfig :: LinkerConfig + , leOtoolConfig :: OtoolConfig + , leCcConfig :: CcConfig + , leInstallNameConfig :: InstallNameConfig + , leInputs :: [Option] + , lePieOpts :: [String] + , leTempDir :: TempDir + , leVerbFlags :: [String] + , leNoHsMain :: !Bool + , leMainSymbol :: String + , leRtsOptsEnabled :: !RtsOptsEnabled + , leRtsOptsSuggestions :: !Bool + , leKeepCafs :: !Bool + , leRtsOpts :: Maybe String + } + +initExecutableLinkOpts :: DynFlags -> ExecutableLinkOpts +initExecutableLinkOpts dflags = + let + platform = targetPlatform dflags + os = platformOS platform + in ExecutableLinkOpts + { leOutputFile = outputFile_ dflags + , leNameVersion = ghcNameVersion dflags + , leWays = ways dflags + , leDynLibLoader = dynLibLoader dflags + , leRelativeDynlibPaths = gopt Opt_RelativeDynlibPaths dflags + , leUseXLinkerRPath = useXLinkerRPath dflags os + , leSingleLibFolder = gopt Opt_SingleLibFolder dflags + , leWholeArchiveHsLibs = gopt Opt_WholeArchiveHsLibs dflags + , leGenManifest = gopt Opt_GenManifest dflags + , leRPath = gopt Opt_RPath dflags + , leCompactUnwind = gopt Opt_CompactUnwind dflags + , leLibraryPaths = libraryPaths dflags + , leFrameworkOpts = initFrameworkOpts dflags + , leManifestOpts = initManifestOpts dflags + , leLinkerConfig = initLinkerConfig dflags + , leCcConfig = configureCc dflags + , leOtoolConfig = configureOtool dflags + , leInstallNameConfig = configureInstallName dflags + , leInputs = ldInputs dflags + , lePieOpts = pieCCLDOpts dflags + , leTempDir = tmpDir dflags + , leVerbFlags = getVerbFlags dflags + , leNoHsMain = gopt Opt_NoHsMain dflags + , leMainSymbol = "ZCMain_main" + , leRtsOptsEnabled = rtsOptsEnabled dflags + , leRtsOptsSuggestions = rtsOptsSuggestions dflags + , leKeepCafs = gopt Opt_KeepCAFs dflags + , leRtsOpts = rtsOpts dflags + } + +leHaveRtsOptsFlags :: ExecutableLinkOpts -> Bool +leHaveRtsOptsFlags opts = + isJust (leRtsOpts opts) + || case leRtsOptsEnabled opts of + RtsOptsSafeOnly -> False + _ -> True + +linkExecutable :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkExecutable logger tmpfs opts unit_env o_files dep_units = do + let static_link = False + let platform = ue_platform unit_env + unit_state = ue_homeUnitState unit_env + verbFlags = leVerbFlags opts + arch_os = platformArchOS platform + output_fn = exeFileName arch_os static_link (leOutputFile opts) + namever = leNameVersion opts + -- For the wasm target, when ghc is invoked with -dynamic, + -- when linking the final .wasm binary we must still ensure + -- the static archives are selected. Otherwise wasm-ld would + -- fail to find and link the .so library dependencies. wasm-ld + -- can link PIC objects into static .wasm binaries fine, so we + -- only adjust the ways in the final linking step, and only + -- when linking .wasm binary (which is supposed to be fully + -- static), not when linking .so shared libraries. + ways_ + | ArchWasm32 <- platformArch platform = removeWay WayDyn $ leWays opts + | otherwise = leWays opts + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d </> output_fn) + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) + let pkg_lib_paths = collectLibraryDirs ways_ pkgs + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget (platformOS platform) && + leDynLibLoader opts == SystemDependent && + ways_ `hasWay` WayDyn + = let libpath = if leRelativeDynlibPaths opts + then "$ORIGIN" </> + (l `makeRelativeTo` full_output_fn) + else l + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + rpath = if leUseXLinkerRPath opts + then ["-Xlinker", "-rpath", "-Xlinker", libpath] + else [] + -- Solaris 11's linker does not support -rpath-link option. It silently + -- ignores it and then complains about next option which is -l<some + -- dir> as being a directory and not expected object file, E.g + -- ld: elf error: file + -- /tmp/ghc-src/libraries/base/dist-install/build: + -- elf_begin: I/O error: region read: Is a directory + rpathlink = if (platformOS platform) == OSSolaris2 + then [] + else ["-Xlinker", "-rpath-link", "-Xlinker", l] + in ["-L" ++ l] ++ rpathlink ++ rpath + | osMachOTarget (platformOS platform) && + leDynLibLoader opts == SystemDependent && + ways_ `hasWay` WayDyn && + leUseXLinkerRPath opts + = let libpath = if leRelativeDynlibPaths opts + then "@loader_path" </> + (l `makeRelativeTo` full_output_fn) + else l + in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] + | otherwise = ["-L" ++ l] + + pkg_lib_path_opts <- + if leSingleLibFolder opts + then do + libs <- getLibs namever ways_ unit_env dep_units + tmpDir <- newTempSubDir logger tmpfs (leTempDir opts) + sequence_ [ copyFile lib (tmpDir </> basename) + | (lib, basename) <- libs] + return [ "-L" ++ tmpDir ] + else pure pkg_lib_path_opts + + let + dead_strip + | leWholeArchiveHsLibs opts = [] + | otherwise = if osSubsectionsViaSymbols (platformOS platform) + then ["-Wl,-dead_strip"] + else [] + let lib_paths = leLibraryPaths opts + let lib_path_opts = map ("-L"++) lib_paths + + extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs opts unit_state + noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs opts unit_env dep_units + + let + (pre_hs_libs, post_hs_libs) + | leWholeArchiveHsLibs opts + = if platformOS platform == OSDarwin + then (["-Wl,-all_load"], []) + -- OS X does not have a flag to turn off -all_load + else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) + | otherwise + = ([],[]) + + pkg_link_opts <- do + unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units + return $ otherFlags unit_link_opts ++ dead_strip + ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs + ++ extraLibs unit_link_opts + -- -Wl,-u,<sym> contained in other_flags + -- needs to be put before -l<package>, + -- otherwise Solaris linker fails linking + -- a binary with unresolved symbols in RTS + -- which are defined in base package + -- the reason for this is a note in ld(1) about + -- '-u' option: "The placement of this option + -- on the command line is significant. + -- This option must be placed before the library + -- that defines the symbol." + + -- frameworks + pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units + let framework_opts = getFrameworkOpts (leFrameworkOpts opts) platform + + -- probably _stub.o files + let extra_ld_inputs = leInputs opts + + rc_objs <- case platformOS platform of + OSMinGW32 | leGenManifest opts -> maybeCreateManifest logger tmpfs (leManifestOpts opts) output_fn + _ -> return [] + + let linker_config = leLinkerConfig opts + let args = ( map GHC.SysTools.Option verbFlags + ++ [ GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ++ libmLinkOpts platform + ++ map GHC.SysTools.Option ( + [] + + -- See Note [No PIE when linking] + ++ lePieOpts opts + + -- Permit the linker to auto link _symbol to _imp_symbol. + -- This lets us link against DLLs without needing an "import library". + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + + -- '-no_compact_unwind' + -- C++/Objective-C exceptions cannot use optimised + -- stack unwinding code. The optimised form is the + -- default in Xcode 4 on at least x86_64, and + -- without this flag we're also seeing warnings + -- like + -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog + -- on x86. + ++ (if not (leCompactUnwind opts) && + linkerSupportsCompactUnwind (leLinkerConfig opts) && + (platformOS platform == OSDarwin) && + case platformArch platform of + ArchX86_64 -> True + ArchAArch64 -> True + _ -> False + then ["-Wl,-no_compact_unwind"] + else []) + + -- We should rather be asking does it support --gc-sections? + ++ (if linkerIsGnuLd (leLinkerConfig opts) && + not (leWholeArchiveHsLibs opts) + then ["-Wl,--gc-sections"] + else []) + + ++ o_files + ++ lib_path_opts) + ++ extra_ld_inputs + ++ map GHC.SysTools.Option ( + rc_objs + ++ framework_opts + ++ pkg_lib_path_opts + ++ extraLinkObj + ++ noteLinkObjs + -- See Note [RTS/ghc-internal interface] + -- (-u<sym> must come before -lghc-internal...!) + ++ (if ghcInternalUnitId `elem` map unitId pkgs + then [concat [ "-Wl,-u," + , ['_' | platformLeadingUnderscore platform] + , "init_ghc_hs_iface" ]] + else []) + ++ pkg_link_opts + ++ pkg_framework_opts + ++ (if platformOS platform == OSDarwin + -- dead_strip_dylibs, will remove unused dylibs, and thus save + -- space in the load commands. The -headerpad is necessary so + -- that we can inject more @rpath's later for the left over + -- libraries during runInjectRpaths phase. + -- + -- See Note [Dynamic linking on macOS]. + then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] + else []) + )) + + runLink logger tmpfs linker_config args + + -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 + when (platformOS platform == OSDarwin && leRPath opts) $ + GHC.Linker.MacOS.runInjectRPaths logger (leOtoolConfig opts) (leInstallNameConfig opts) pkg_lib_paths output_fn + +mkExtraObj :: Logger -> TmpFs -> TempDir -> CcConfig -> UnitState -> Suffix -> String -> IO FilePath +mkExtraObj logger tmpfs tmpdir cc_config unit_state extn xs + = do + -- Pass a different set of options to the C compiler depending one whether + -- we're compiling C or assembler. When compiling C, we pass the usual + -- set of include directories and PIC flags. + let cOpts = map Option (ccPicOpts cc_config) + ++ map (FileOption "-I" . ST.unpack) + (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit) + cFile <- newTempName logger tmpfs tmpdir TFL_CurrentModule extn + oFile <- newTempName logger tmpfs tmpdir TFL_GhcSession "o" + writeFile cFile xs + runCc Nothing logger tmpfs tmpdir cc_config + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ if extn /= "s" + then cOpts + else []) + return oFile + +-- | Create object containing main() entry point +-- +-- When linking a binary, we need to create a C main() function that +-- starts everything off. This used to be compiled statically as part +-- of the RTS, but that made it hard to change the -rtsopts setting, +-- so now we generate and compile a main() stub as part of every +-- binary and pass the -rtsopts setting directly to the RTS (#5373) +mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitState -> IO (Maybe FilePath) +mkExtraObjToLinkIntoBinary logger tmpfs opts unit_state = do + when (leNoHsMain opts && leHaveRtsOptsFlags opts) $ + logInfo logger $ withPprStyle defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + if leNoHsMain opts + -- Don't try to build the extra object if it is not needed. Compiling the + -- extra object assumes the presence of the RTS in the unit database + -- (because the extra object imports Rts.h) but GHC's build system may try + -- to build some helper programs before building and registering the RTS! + -- See #18938 for an example where hp2ps failed to build because of a failed + -- (unsafe) lookup for the RTS in the unit db. + then pure Nothing + else mk_extra_obj exeMain + + where + tmpdir = leTempDir opts + cc_config = leCcConfig opts + mk_extra_obj = fmap Just . mkExtraObj logger tmpfs tmpdir cc_config unit_state "c" . renderWithContext defaultSDocContext + + exeMain = vcat [ + text "#include <Rts.h>", + text "extern StgClosure " <> text (leMainSymbol opts) <> text "_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (leRtsOptsEnabled opts)) <> semi, + text " __conf.rts_opts_suggestions = " + <> (if leRtsOptsSuggestions opts + then text "true" + else text "false") <> semi, + text "__conf.keep_cafs = " + <> (if leKeepCafs opts + then text "true" + else text "false") <> semi, + case leRtsOpts opts of + Nothing -> Outputable.empty + Just rts_opts -> text " __conf.rts_opts= " <> + text (show rts_opts) <> semi, + text " __conf.rts_hs_main = true;", + text " return hs_main(argc,argv,&" <> text (leMainSymbol opts) <> text "_closure,__conf);", + char '}', + char '\n' -- final newline, to keep gcc happy + ] + +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary logger tmpfs opts unit_env dep_packages = do + link_info <- initLinkInfo opts unit_env dep_packages + + if (platformSupportsSavingLinkOpts (platformOS platform )) + then fmap (:[]) $ mkExtraObj logger tmpfs tmpdir cc_config unit_state "s" (renderWithContext defaultSDocContext (link_opts link_info)) + else return [] + + where + unit_state = ue_homeUnitState unit_env + platform = ue_platform unit_env + tmpdir = leTempDir opts + cc_config = leCcConfig opts + link_opts info = hcat + [ -- "link info" section (see Note [LinkInfo section]) + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 (show info) + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- "GHC.CmmToAsm" for another instance + -- where we need to do this. + , if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\"," + <> sectionType platform "progbits" <> char '\n' + else Outputable.empty + ] + +data LinkInfo = LinkInfo + { liPkgLinkOpts :: UnitLinkOpts + , liPkgFrameworks :: [String] + , liRtsOpts :: Maybe String + , liRtsOptsEnabled :: !RtsOptsEnabled + , liNoHsMain :: !Bool + , liLdInputs :: [String] + , liLdOpts :: [String] + } + deriving (Show) + + +-- | Return the "link info" +-- +-- See Note [LinkInfo section] +initLinkInfo :: ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO LinkInfo +initLinkInfo opts unit_env dep_packages = do + package_link_opts <- getUnitLinkOpts (leNameVersion opts) (leWays opts) unit_env dep_packages + pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) + then return [] + else do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) + return (collectFrameworks ps) + pure $ LinkInfo + { liPkgLinkOpts = package_link_opts + , liPkgFrameworks = pkg_frameworks + , liRtsOpts = leRtsOpts opts + , liRtsOptsEnabled = leRtsOptsEnabled opts + , liNoHsMain = leNoHsMain opts + , liLdInputs = map showOpt (leInputs opts) + , liLdOpts = map showOpt (linkerOptionsPost (leLinkerConfig opts)) + } + +platformSupportsSavingLinkOpts :: OS -> Bool +platformSupportsSavingLinkOpts os + | os == OSSolaris2 = False -- see #5382 + | otherwise = osElfTarget os + +-- See Note [LinkInfo section] +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default + +-- Identifier for the note (see Note [LinkInfo section]) +ghcLinkInfoNoteName :: String +ghcLinkInfoNoteName = "GHC link info" + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: Logger -> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo logger opts unit_env pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- initLinkInfo opts unit_env pkg_deps + debugTraceMsg logger 3 $ text ("Link info: " ++ show link_info) + m_exe_link_info <- readElfNoteAsString logger exe_file + ghcLinkInfoSectionName ghcLinkInfoNoteName + let sameLinkInfo = (Just (show link_info) == m_exe_link_info) + debugTraceMsg logger 3 $ case m_exe_link_info of + Nothing -> text "Exe link info: Not found" + Just s + | sameLinkInfo -> text ("Exe link info is the same") + | otherwise -> text ("Exe link info is different: " ++ s) + return (not sameLinkInfo) + +{- Note [LinkInfo section] + ~~~~~~~~~~~~~~~~~~~~~~~ + +The "link info" is a string representing the parameters of the link. We save +this information in the binary, and the next time we link, if nothing else has +changed, we use the link info stored in the existing binary to decide whether +to re-link or not. + +The "link info" string is stored in a ELF section called ".debug-ghc-link-info" +(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to +not follow the specified record-based format (see #11022). + +-} + +{- +Note [-Xlinker -rpath vs -Wl,-rpath] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-Wl takes a comma-separated list of options which in the case of +-Wl,-rpath -Wl,some,path,with,commas parses the path with commas +as separate options. +Buck, the build system, produces paths with commas in them. + +-Xlinker doesn't have this disadvantage and as far as I can tell +it is supported by both gcc and clang. Anecdotally nvcc supports +-Xlinker, but not -Wl. +-} + ===================================== compiler/GHC/Linker/ExtraObj.hs deleted ===================================== @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHC Extra object linking code --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ - -module GHC.Linker.ExtraObj - ( mkExtraObj - , mkExtraObjToLinkIntoBinary - , mkNoteObjsToLinkIntoBinary - , checkLinkInfo - , getLinkInfo - , ghcLinkInfoSectionName - , ghcLinkInfoNoteName - , platformSupportsSavingLinkOpts - , haveRtsOptsFlags - ) -where - -import GHC.Prelude -import GHC.Platform - -import GHC.Unit -import GHC.Unit.Env - -import GHC.Utils.Asm -import GHC.Utils.Error -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Logger -import GHC.Utils.TmpFs - -import GHC.Driver.Session -import GHC.Driver.Ppr - -import qualified GHC.Data.ShortText as ST - -import GHC.SysTools.Elf -import GHC.SysTools.Tasks -import GHC.Linker.Unit - -import Control.Monad -import Data.Maybe - -mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath -mkExtraObj logger tmpfs dflags unit_state extn xs - = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn - oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o" - writeFile cFile xs - runCc Nothing logger tmpfs dflags - ([Option "-c", - FileOption "" cFile, - Option "-o", - FileOption "" oFile] - ++ if extn /= "s" - then cOpts - else []) - return oFile - where - -- Pass a different set of options to the C compiler depending one whether - -- we're compiling C or assembler. When compiling C, we pass the usual - -- set of include directories and PIC flags. - cOpts = map Option (picCCOpts dflags) - ++ map (FileOption "-I" . ST.unpack) - (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit) - --- When linking a binary, we need to create a C main() function that --- starts everything off. This used to be compiled statically as part --- of the RTS, but that made it hard to change the -rtsopts setting, --- so now we generate and compile a main() stub as part of every --- binary and pass the -rtsopts setting directly to the RTS (#5373) --- --- On Windows, when making a shared library we also may need a DllMain. --- -mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) -mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ - logInfo logger $ withPprStyle defaultUserStyle - (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - case ghcLink dflags of - -- Don't try to build the extra object if it is not needed. Compiling the - -- extra object assumes the presence of the RTS in the unit database - -- (because the extra object imports Rts.h) but GHC's build system may try - -- to build some helper programs before building and registering the RTS! - -- See #18938 for an example where hp2ps failed to build because of a failed - -- (unsafe) lookup for the RTS in the unit db. - _ | gopt Opt_NoHsMain dflags - -> return Nothing - - LinkDynLib - | OSMinGW32 <- platformOS (targetPlatform dflags) - -> mk_extra_obj dllMain - - | otherwise - -> return Nothing - - _ -> mk_extra_obj exeMain - - where - mk_extra_obj = fmap Just . mkExtraObj logger tmpfs dflags unit_state "c" . showSDoc dflags - - exeMain = vcat [ - text "#include <Rts.h>", - text "extern StgClosure ZCMain_main_closure;", - text "int main(int argc, char *argv[])", - char '{', - text " RtsConfig __conf = defaultRtsConfig;", - text " __conf.rts_opts_enabled = " - <> text (show (rtsOptsEnabled dflags)) <> semi, - text " __conf.rts_opts_suggestions = " - <> (if rtsOptsSuggestions dflags - then text "true" - else text "false") <> semi, - text "__conf.keep_cafs = " - <> (if gopt Opt_KeepCAFs dflags - then text "true" - else text "false") <> semi, - case rtsOpts dflags of - Nothing -> Outputable.empty - Just opts -> text " __conf.rts_opts= " <> - text (show opts) <> semi, - text " __conf.rts_hs_main = true;", - text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", - char '}', - char '\n' -- final newline, to keep gcc happy - ] - - dllMain = vcat [ - text "#include <Rts.h>", - text "#include <windows.h>", - text "#include <stdbool.h>", - char '\n', - text "bool", - text "WINAPI", - text "DllMain ( HINSTANCE hInstance STG_UNUSED", - text " , DWORD reason STG_UNUSED", - text " , LPVOID reserved STG_UNUSED", - text " )", - text "{", - text " return true;", - text "}", - char '\n' -- final newline, to keep gcc happy - ] - --- Write out the link info section into a new assembly file. Previously --- this was included as inline assembly in the main.c file but this --- is pretty fragile. gas gets upset trying to calculate relative offsets --- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_packages = do - link_info <- getLinkInfo dflags unit_env dep_packages - - if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info)) - else return [] - - where - unit_state = ue_homeUnitState unit_env - platform = ue_platform unit_env - link_opts info = hcat - [ -- "link info" section (see Note [LinkInfo section]) - makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info - - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- "GHC.CmmToAsm" for another instance - -- where we need to do this. - , if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," - <> sectionType platform "progbits" <> char '\n' - else Outputable.empty - ] - --- | Return the "link info" string --- --- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String -getLinkInfo dflags unit_env dep_packages = do - package_link_opts <- getUnitLinkOpts (ghcNameVersion dflags) (ways dflags) unit_env dep_packages - pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) - then return [] - else do - ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) - return (collectFrameworks ps) - let link_info = - ( package_link_opts - , pkg_frameworks - , rtsOpts dflags - , rtsOptsEnabled dflags - , gopt Opt_NoHsMain dflags - , map showOpt (ldInputs dflags) - , getOpts dflags opt_l - ) - return (show link_info) - -platformSupportsSavingLinkOpts :: OS -> Bool -platformSupportsSavingLinkOpts os - | os == OSSolaris2 = False -- see #5382 - | otherwise = osElfTarget os - --- See Note [LinkInfo section] -ghcLinkInfoSectionName :: String -ghcLinkInfoSectionName = ".debug-ghc-link-info" - -- if we use the ".debug" prefix, then strip will strip it by default - --- Identifier for the note (see Note [LinkInfo section]) -ghcLinkInfoNoteName :: String -ghcLinkInfoNoteName = "GHC link info" - --- Returns 'False' if it was, and we can avoid linking, because the --- previous binary was linked with "the same options". -checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool -checkLinkInfo logger dflags unit_env pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) - -- ToDo: Windows and OS X do not use the ELF binary format, so - -- readelf does not work there. We need to find another way to do - -- this. - = return False -- conservatively we should return True, but not - -- linking in this case was the behaviour for a long - -- time so we leave it as-is. - | otherwise - = do - link_info <- getLinkInfo dflags unit_env pkg_deps - debugTraceMsg logger 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString logger exe_file - ghcLinkInfoSectionName ghcLinkInfoNoteName - let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg logger 3 $ case m_exe_link_info of - Nothing -> text "Exe link info: Not found" - Just s - | sameLinkInfo -> text ("Exe link info is the same") - | otherwise -> text ("Exe link info is different: " ++ s) - return (not sameLinkInfo) - -{- Note [LinkInfo section] - ~~~~~~~~~~~~~~~~~~~~~~~ - -The "link info" is a string representing the parameters of the link. We save -this information in the binary, and the next time we link, if nothing else has -changed, we use the link info stored in the existing binary to decide whether -to re-link or not. - -The "link info" string is stored in a ELF section called ".debug-ghc-link-info" -(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to -not follow the specified record-based format (see #11022). - --} - -haveRtsOptsFlags :: DynFlags -> Bool -haveRtsOptsFlags dflags = - isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of - RtsOptsSafeOnly -> False - _ -> True ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -406,6 +406,7 @@ loadCmdLineLibs'' interp hsc_env pls = , libraryPaths = lib_paths_base}) = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let ld_config = configureLd dflags -- (c) Link libraries from the command-line let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] @@ -421,7 +422,7 @@ loadCmdLineLibs'' interp hsc_env pls = OSMinGW32 -> "pthread" : minus_ls_1 _ -> minus_ls_1 -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths logger dflags os + gcc_paths <- getGCCPaths logger platform ld_config lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base @@ -1254,6 +1255,7 @@ loadPackage interp hsc_env pkgs = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + ld_config = configureLd dflags platform = targetPlatform dflags is_dyn = interpreterDynamic interp dirs | is_dyn = [map ST.unpack $ Packages.unitLibraryDynDirs pkg | pkg <- pkgs] @@ -1281,7 +1283,7 @@ loadPackage interp hsc_env pkgs extra_libs = zipWith (++) extdeplibs linkerlibs -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths logger dflags (platformOS platform) + gcc_paths <- getGCCPaths logger platform ld_config dirs_env <- traverse (addEnvPaths "LIBRARY_PATH") dirs hs_classifieds @@ -1507,6 +1509,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env diag_opts = initDiagOpts dflags + ld_config = configureLd dflags dirs = lib_dirs ++ gcc_dirs gcc = False user = True @@ -1570,7 +1573,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary interp so_name #endif - tryGcc = let search = searchForLibUsingGcc logger dflags + tryGcc = let search = searchForLibUsingGcc logger ld_config #if defined(CAN_LOAD_DLL) dllpath = liftM (fmap DLLPath) short = dllpath $ search so_name lib_dirs @@ -1624,11 +1627,11 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 #endif os = platformOS platform -searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) -searchForLibUsingGcc logger dflags so dirs = do +searchForLibUsingGcc :: Logger -> LdConfig -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc logger ld_config so dirs = do -- GCC does not seem to extend the library search path (using -L) when using -- --print-file-name. So instead pass it a new base location. - str <- askLd logger dflags (map (FileOption "-B") dirs + str <- askLd logger ld_config (map (FileOption "-B") dirs ++ [Option "--print-file-name", Option so]) let file = case lines str of [] -> "" @@ -1640,10 +1643,10 @@ searchForLibUsingGcc logger dflags so dirs = do -- | Retrieve the list of search directory GCC and the System use to find -- libraries and components. See Note [Fork/Exec Windows]. -getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath] -getGCCPaths logger dflags os - | os == OSMinGW32 || platformArch (targetPlatform dflags) == ArchWasm32 = - do gcc_dirs <- getGccSearchDirectory logger dflags "libraries" +getGCCPaths :: Logger -> Platform -> LdConfig -> IO [FilePath] +getGCCPaths logger platform ld_config + | platformOS platform == OSMinGW32 || platformArch platform == ArchWasm32 = + do gcc_dirs <- getGccSearchDirectory logger ld_config "libraries" sys_dirs <- getSystemDirectories return $ nub $ gcc_dirs ++ sys_dirs | otherwise = return [] @@ -1663,8 +1666,8 @@ gccSearchDirCache = unsafePerformIO $ newIORef [] -- which hopefully is written in an optimized manner to take advantage of -- caching. At the very least we remove the overhead of the fork/exec and waits -- which dominate a large percentage of startup time on Windows. -getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath] -getGccSearchDirectory logger dflags key = do +getGccSearchDirectory :: Logger -> LdConfig -> String -> IO [FilePath] +getGccSearchDirectory logger ld_config key = do #if defined(wasm32_HOST_ARCH) pure [] #else @@ -1672,7 +1675,7 @@ getGccSearchDirectory logger dflags key = do case lookup key cache of Just x -> return x Nothing -> do - str <- askLd logger dflags [Option "--print-search-dirs"] + str <- askLd logger ld_config [Option "--print-search-dirs"] let line = dropWhile isSpace str name = key ++ ": =" if null line ===================================== compiler/GHC/Linker/MacOS.hs ===================================== @@ -17,7 +17,6 @@ import GHC.Unit.Types import GHC.Unit.State import GHC.Unit.Env -import GHC.Settings import GHC.SysTools.Tasks import GHC.Runtime.Interpreter @@ -49,13 +48,13 @@ import Text.ParserCombinators.ReadP as Parser -- dynamic library through @-add_rpath@. -- -- See Note [Dynamic linking on macOS] -runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO () -runInjectRPaths logger toolSettings lib_paths dylib = do - info <- lines <$> askOtool logger toolSettings Nothing [Option "-L", Option dylib] +runInjectRPaths :: Logger -> OtoolConfig -> InstallNameConfig -> [FilePath] -> FilePath -> IO () +runInjectRPaths logger otool_opts install_name_opts lib_paths dylib = do + info <- lines <$> askOtool logger otool_opts Nothing [Option "-L", Option dylib] -- filter the output for only the libraries. And then drop the @rpath prefix. let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info -- find any pre-existing LC_PATH items - info <- lines <$> askOtool logger toolSettings Nothing [Option "-l", Option dylib] + info <- lines <$> askOtool logger otool_opts Nothing [Option "-l", Option dylib] let paths = mapMaybe get_rpath info lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ] -- only find those rpaths, that aren't already in the library. @@ -63,7 +62,7 @@ runInjectRPaths logger toolSettings lib_paths dylib = do -- inject the rpaths case rpaths of [] -> return () - _ -> runInstallNameTool logger toolSettings $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] + _ -> runInstallNameTool logger install_name_opts $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] get_rpath :: String -> Maybe FilePath get_rpath l = case readP_to_S rpath_parser l of ===================================== compiler/GHC/Linker/Static.hs ===================================== @@ -1,12 +1,10 @@ module GHC.Linker.Static - ( linkBinary - , linkStaticLib + ( linkStaticLib ) where import GHC.Prelude import GHC.Platform -import GHC.Platform.Ways import GHC.Settings import GHC.SysTools @@ -19,24 +17,15 @@ import GHC.Unit.State import GHC.Utils.Logger import GHC.Utils.Monad -import GHC.Utils.Misc -import GHC.Utils.TmpFs -import GHC.Linker.MacOS import GHC.Linker.Unit -import GHC.Linker.Dynamic -import GHC.Linker.ExtraObj -import GHC.Linker.External -import GHC.Linker.Windows import GHC.Linker.Static.Utils -import GHC.Driver.Config.Linker import GHC.Driver.Session import System.FilePath import System.Directory import Control.Monad -import Data.Maybe ----------------------------------------------------------------------------- -- Static linking, of .o files @@ -51,225 +40,6 @@ import Data.Maybe -- read any interface files), so the user must explicitly specify all -- the packages. -{- -Note [-Xlinker -rpath vs -Wl,-rpath] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --Wl takes a comma-separated list of options which in the case of --Wl,-rpath -Wl,some,path,with,commas parses the path with commas -as separate options. -Buck, the build system, produces paths with commas in them. - --Xlinker doesn't have this disadvantage and as far as I can tell -it is supported by both gcc and clang. Anecdotally nvcc supports --Xlinker, but not -Wl. --} - -linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary = linkBinary' False - -linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do - let platform = ue_platform unit_env - unit_state = ue_homeUnitState unit_env - toolSettings' = toolSettings dflags - verbFlags = getVerbFlags dflags - arch_os = platformArchOS platform - output_fn = exeFileName arch_os staticLink (outputFile_ dflags) - namever = ghcNameVersion dflags - -- For the wasm target, when ghc is invoked with -dynamic, - -- when linking the final .wasm binary we must still ensure - -- the static archives are selected. Otherwise wasm-ld would - -- fail to find and link the .so library dependencies. wasm-ld - -- can link PIC objects into static .wasm binaries fine, so we - -- only adjust the ways in the final linking step, and only - -- when linking .wasm binary (which is supposed to be fully - -- static), not when linking .so shared libraries. - ways_ - | ArchWasm32 <- platformArch platform = removeWay WayDyn $ targetWays_ dflags - | otherwise = ways dflags - - full_output_fn <- if isAbsolute output_fn - then return output_fn - else do d <- getCurrentDirectory - return $ normalise (d </> output_fn) - - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. - pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) - let pkg_lib_paths = collectLibraryDirs ways_ pkgs - let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths - get_pkg_lib_path_opts l - | osElfTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - ways_ `hasWay` WayDyn - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "$ORIGIN" </> - (l `makeRelativeTo` full_output_fn) - else l - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - rpath = if useXLinkerRPath dflags (platformOS platform) - then ["-Xlinker", "-rpath", "-Xlinker", libpath] - else [] - -- Solaris 11's linker does not support -rpath-link option. It silently - -- ignores it and then complains about next option which is -l<some - -- dir> as being a directory and not expected object file, E.g - -- ld: elf error: file - -- /tmp/ghc-src/libraries/base/dist-install/build: - -- elf_begin: I/O error: region read: Is a directory - rpathlink = if (platformOS platform) == OSSolaris2 - then [] - else ["-Xlinker", "-rpath-link", "-Xlinker", l] - in ["-L" ++ l] ++ rpathlink ++ rpath - | osMachOTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - ways_ `hasWay` WayDyn && - useXLinkerRPath dflags (platformOS platform) - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "@loader_path" </> - (l `makeRelativeTo` full_output_fn) - else l - in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] - | otherwise = ["-L" ++ l] - - pkg_lib_path_opts <- - if gopt Opt_SingleLibFolder dflags - then do - libs <- getLibs namever ways_ unit_env dep_units - tmpDir <- newTempSubDir logger tmpfs (tmpDir dflags) - sequence_ [ copyFile lib (tmpDir </> basename) - | (lib, basename) <- libs] - return [ "-L" ++ tmpDir ] - else pure pkg_lib_path_opts - - let - dead_strip - | gopt Opt_WholeArchiveHsLibs dflags = [] - | otherwise = if osSubsectionsViaSymbols (platformOS platform) - then ["-Wl,-dead_strip"] - else [] - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state - noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_units - - let - (pre_hs_libs, post_hs_libs) - | gopt Opt_WholeArchiveHsLibs dflags - = if platformOS platform == OSDarwin - then (["-Wl,-all_load"], []) - -- OS X does not have a flag to turn off -all_load - else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) - | otherwise - = ([],[]) - - pkg_link_opts <- do - unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units - return $ otherFlags unit_link_opts ++ dead_strip - ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs - ++ extraLibs unit_link_opts - -- -Wl,-u,<sym> contained in other_flags - -- needs to be put before -l<package>, - -- otherwise Solaris linker fails linking - -- a binary with unresolved symbols in RTS - -- which are defined in base package - -- the reason for this is a note in ld(1) about - -- '-u' option: "The placement of this option - -- on the command line is significant. - -- This option must be placed before the library - -- that defines the symbol." - - -- frameworks - pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units - let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform - - -- probably _stub.o files - let extra_ld_inputs = ldInputs dflags - - rc_objs <- case platformOS platform of - OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn - _ -> return [] - - let linker_config = initLinkerConfig dflags - let link dflags args = do - runLink logger tmpfs linker_config args - -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 - when (platformOS platform == OSDarwin && gopt Opt_RPath dflags) $ - GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn - - link dflags ( - map GHC.SysTools.Option verbFlags - ++ [ GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ] - ++ libmLinkOpts platform - ++ map GHC.SysTools.Option ( - [] - - -- See Note [No PIE when linking] - ++ pieCCLDOpts dflags - - -- Permit the linker to auto link _symbol to _imp_symbol. - -- This lets us link against DLLs without needing an "import library". - ++ (if platformOS platform == OSMinGW32 - then ["-Wl,--enable-auto-import"] - else []) - - -- '-no_compact_unwind' - -- C++/Objective-C exceptions cannot use optimised - -- stack unwinding code. The optimised form is the - -- default in Xcode 4 on at least x86_64, and - -- without this flag we're also seeing warnings - -- like - -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog - -- on x86. - ++ (if not (gopt Opt_CompactUnwind dflags) && - toolSettings_ldSupportsCompactUnwind toolSettings' && - (platformOS platform == OSDarwin) && - case platformArch platform of - ArchX86_64 -> True - ArchAArch64 -> True - _ -> False - then ["-Wl,-no_compact_unwind"] - else []) - - -- We should rather be asking does it support --gc-sections? - ++ (if toolSettings_ldIsGnuLd toolSettings' && - not (gopt Opt_WholeArchiveHsLibs dflags) - then ["-Wl,--gc-sections"] - else []) - - ++ o_files - ++ lib_path_opts) - ++ extra_ld_inputs - ++ map GHC.SysTools.Option ( - rc_objs - ++ framework_opts - ++ pkg_lib_path_opts - ++ extraLinkObj - ++ noteLinkObjs - -- See Note [RTS/ghc-internal interface] - -- (-u<sym> must come before -lghc-internal...!) - ++ (if ghcInternalUnitId `elem` map unitId pkgs - then [concat [ "-Wl,-u," - , ['_' | platformLeadingUnderscore platform] - , "init_ghc_hs_iface" ]] - else []) - ++ pkg_link_opts - ++ pkg_framework_opts - ++ (if platformOS platform == OSDarwin - -- dead_strip_dylibs, will remove unused dylibs, and thus save - -- space in the load commands. The -headerpad is necessary so - -- that we can inject more @rpath's later for the left over - -- libraries during runInjectRpaths phase. - -- - -- See Note [Dynamic linking on macOS]. - then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] - else []) - )) - -- | Linking a static lib will not really link anything. It will merely produce -- a static archive of all dependent static libraries. The resulting library -- will still need to be linked with any remaining link flags. @@ -309,4 +79,5 @@ linkStaticLib logger dflags unit_env o_files dep_units = do else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar -- run ranlib over the archive. write*Ar does *not* create the symbol index. - runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn] + let ranlib_opts = configureRanlib dflags + runRanlib logger ranlib_opts [GHC.SysTools.FileOption "" output_fn] ===================================== compiler/GHC/Linker/Windows.hs ===================================== @@ -1,5 +1,7 @@ module GHC.Linker.Windows - ( maybeCreateManifest + ( ManifestOpts (..) + , initManifestOpts + , maybeCreateManifest ) where @@ -12,13 +14,28 @@ import GHC.Utils.Logger import System.FilePath import System.Directory +data ManifestOpts = ManifestOpts + { manifestEmbed :: !Bool -- ^ Should the manifest be embedded in the binary with Windres + , manifestTempdir :: TempDir + , manifestWindresConfig :: WindresConfig + , manifestObjectSuf :: String + } + +initManifestOpts :: DynFlags -> ManifestOpts +initManifestOpts dflags = ManifestOpts + { manifestEmbed = gopt Opt_EmbedManifest dflags + , manifestTempdir = tmpDir dflags + , manifestWindresConfig = configureWindres dflags + , manifestObjectSuf = objectSuf dflags + } + maybeCreateManifest :: Logger -> TmpFs - -> DynFlags + -> ManifestOpts -> FilePath -- ^ filename of executable -> IO [FilePath] -- ^ extra objects to embed, maybe -maybeCreateManifest logger tmpfs dflags exe_filename = do +maybeCreateManifest logger tmpfs opts exe_filename = do let manifest_filename = exe_filename <.> "manifest" manifest = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ @@ -42,18 +59,18 @@ maybeCreateManifest logger tmpfs dflags exe_filename = do -- foo.exe.manifest. However, for extra robustness, and so that -- we can move the binary around, we can embed the manifest in -- the binary itself using windres: - if not (gopt Opt_EmbedManifest dflags) + if not (manifestEmbed opts) then return [] else do - rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc" + rc_filename <- newTempName logger tmpfs (manifestTempdir opts) TFL_CurrentModule "rc" rc_obj_filename <- - newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags) + newTempName logger tmpfs (manifestTempdir opts) TFL_GhcSession (manifestObjectSuf opts) writeFile rc_filename $ "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n" -- magic numbers :-) - runWindres logger dflags $ map GHC.SysTools.Option $ + runWindres logger (manifestWindresConfig opts) $ map GHC.SysTools.Option $ ["--input="++rc_filename, "--output="++rc_obj_filename, "--output-format=coff"] ===================================== compiler/GHC/Runtime/Interpreter/C.hs ===================================== @@ -0,0 +1,85 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | External interpreter program +module GHC.Runtime.Interpreter.C + ( generateIservC + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Data.FastString +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Unit.Types +import GHC.Unit.Env +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Utils.Panic.Plain +import GHC.Linker.Executable +import GHC.Linker.Config +import GHC.Utils.CliOption + +-- | Generate iserv program for the target +generateIservC :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> IO FilePath +generateIservC logger tmpfs opts unit_env = do + -- get the unit-id of the ghci package. We need this to load the + -- interpreter code. + let unit_state = ue_homeUnitState unit_env + ghci_unit_id <- case lookupPackageName unit_state (PackageName (fsLit "ghci")) of + Nothing -> cmdLineErrorIO "C interpreter: couldn't find \"ghci\" package" + Just i -> pure i + + -- generate a temporary name for the iserv program + let tmpdir = leTempDir opts + exe_file <- newTempName logger tmpfs tmpdir TFL_GhcSession "iserv" + + let platform = ue_platform unit_env + let os = platformOS platform + + -- we inherit ExecutableLinkOpts for the target code (i.e. derived from + -- DynFlags specified by the user and from settings). We need to adjust these + -- options to generate the iserv program we want. Some settings are to be + -- shared (e.g. ways, platform, etc.) but some other must be set specifically + -- for iserv. + let opts' = opts + { -- write iserv program in some temporary directory + leOutputFile = Just exe_file + + -- we need GHC to generate a main entry point... + , leNoHsMain = False + + -- ...however the main symbol must be the iserv server + , leMainSymbol = zString (zEncodeFS (unitIdFS ghci_unit_id)) ++ "_GHCiziServer_defaultServer" + + -- we need to reset inputs, otherwise one of them may be defining + -- `main` too (with -no-hs-main). + , leInputs = [] + + -- we never know what symbols GHC will look up in the future, so we + -- must retain CAFs for running interpreted code. + , leKeepCafs = True + + -- enable all rts options + , leRtsOptsEnabled = RtsOptsAll + + -- Add -Wl,--export-dynamic enables GHCi to load dynamic objects that + -- refer to the RTS. This is harmless if you don't use it (adds a bit + -- of overhead to startup and increases the binary sizes) but if you + -- need it there's no alternative. + -- + -- The Solaris linker does not support --export-dynamic option. It also + -- does not need it since it exports all dynamic symbols by default + , leLinkerConfig = if + | osElfTarget os + , os /= OSFreeBSD + , os /= OSSolaris2 + -> (leLinkerConfig opts) + { linkerOptionsPost = linkerOptionsPost (leLinkerConfig opts) ++ [Option "-Wl,--export-dynamic"] + } + | otherwise + -> leLinkerConfig opts + } + linkExecutable logger tmpfs opts' unit_env [] [ghci_unit_id] + + pure exe_file ===================================== compiler/GHC/Runtime/Interpreter/Init.hs ===================================== @@ -0,0 +1,162 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Runtime.Interpreter.Init + ( initInterpreter + , InterpOpts (..) + ) +where + + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways +import GHC.Settings +import GHC.Unit.Finder +import GHC.Unit.Env +import GHC.Utils.TmpFs +import GHC.SysTools.Tasks + +import GHC.Linker.Executable +import qualified GHC.Linker.Loader as Loader +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.C +import GHC.StgToJS.Types (StgToJSConfig) + +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.Utils.Error +import Control.Concurrent +import System.Process + +data InterpOpts = InterpOpts + { interpExternal :: !Bool + , interpProg :: String + , interpOpts :: [String] + , interpWays :: Ways + , interpNameVer :: GhcNameVersion + , interpLdConfig :: LdConfig + , interpCcConfig :: CcConfig + , interpJsInterp :: FilePath + , interpTmpDir :: TempDir + , interpFinderOpts :: FinderOpts + , interpJsCodegenCfg :: StgToJSConfig + , interpVerbosity :: Int + , interpCreateProcess :: Maybe (CreateProcess -> IO ProcessHandle) -- create iserv process hook + , interpWasmDyld :: FilePath + , interpBrowser :: Bool + , interpBrowserHost :: String + , interpBrowserPort :: Int + , interpBrowserRedirectWasiConsole :: Bool + , interpBrowserPuppeteerLaunchOpts :: Maybe String + , interpBrowserPlaywrightBrowserType :: Maybe String + , interpBrowserPlaywrightLaunchOpts :: Maybe String + , interpExecutableLinkOpts :: ExecutableLinkOpts + } + +-- | Initialize code interpreter +initInterpreter + :: TmpFs + -> Logger + -> Platform + -> FinderCache + -> UnitEnv + -> InterpOpts + -> IO (Maybe Interp) +initInterpreter tmpfs logger platform finder_cache unit_env opts = do + + lookup_cache <- liftIO $ mkInterpSymbolCache + + -- see Note [Target code interpreter] + if +#if !defined(wasm32_HOST_ARCH) + -- Wasm dynamic linker + | ArchWasm32 <- platformArch platform + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger (interpLdConfig opts) "libraries" + let profiled = interpWays opts `hasWay` WayProf + way_tag = if profiled then "_p" else "" + let cfg = + WasmInterpConfig + { wasmInterpDyLD = interpWasmDyld opts + , wasmInterpLibDir = libdir + , wasmInterpOpts = interpOpts opts + , wasmInterpBrowser = interpBrowser opts + , wasmInterpBrowserHost = interpBrowserHost opts + , wasmInterpBrowserPort = interpBrowserPort opts + , wasmInterpBrowserRedirectWasiConsole = interpBrowserRedirectWasiConsole opts + , wasmInterpBrowserPuppeteerLaunchOpts = interpBrowserPuppeteerLaunchOpts opts + , wasmInterpBrowserPlaywrightBrowserType = interpBrowserPlaywrightBrowserType opts + , wasmInterpBrowserPlaywrightLaunchOpts = interpBrowserPlaywrightLaunchOpts opts + , wasmInterpTargetPlatform = platform + , wasmInterpProfiled = profiled + , wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (interpNameVer opts) + , wasmInterpUnitState = ue_homeUnitState unit_env + } + pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache +#endif + + -- JavaScript interpreter + | ArchJavaScript <- platformArch platform + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + let cfg = JSInterpConfig + { jsInterpNodeConfig = defaultNodeJsSettings + , jsInterpScript = interpJsInterp opts + , jsInterpTmpFs = tmpfs + , jsInterpTmpDir = interpTmpDir opts + , jsInterpLogger = logger + , jsInterpCodegenCfg = interpJsCodegenCfg opts + , jsInterpUnitEnv = unit_env + , jsInterpFinderOpts = interpFinderOpts opts + , jsInterpFinderCache = finder_cache + } + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) + + -- external interpreter + | interpExternal opts + -> do + let + profiled = interpWays opts `hasWay` WayProf + dynamic = interpWays opts `hasWay` WayDyn + prog <- case interpProg opts of + -- build iserv program if none specified + "" -> generateIservC logger tmpfs (interpExecutableLinkOpts opts) unit_env + _ -> pure (interpProg opts ++ flavour) + where + flavour + | profiled && dynamic = "-prof-dyn" + | profiled = "-prof" + | dynamic = "-dyn" + | otherwise = "" + let msg = text "Starting " <> text prog + tr <- if interpVerbosity opts >= 3 + then return (logInfo logger $ withPprStyle defaultDumpStyle msg) + else return (pure ()) + let + conf = IServConfig + { iservConfProgram = prog + , iservConfOpts = interpOpts opts + , iservConfProfiled = profiled + , iservConfDynamic = dynamic + , iservConfHook = interpCreateProcess opts + , iservConfTrace = tr + } + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) + + -- Internal interpreter + | otherwise + -> +#if defined(HAVE_INTERNAL_INTERPRETER) + do + loader <- liftIO Loader.uninitializedLoader + return (Just (Interp InternalInterp loader lookup_cache)) +#else + return Nothing +#endif ===================================== compiler/GHC/SysTools/Tasks.hs ===================================== @@ -13,7 +13,11 @@ module GHC.SysTools.Tasks , runSourceCodePreprocessor , runPp , runCc + , configureCc + , CcConfig (..) + , configureLd , askLd + , LdConfig(..) , runAs , runLlvmOpt , runLlvmLlc @@ -22,10 +26,20 @@ module GHC.SysTools.Tasks , figureLlvmVersion , runMergeObjects , runAr + , ArConfig (..) + , configureAr , askOtool + , configureOtool + , OtoolConfig (..) , runInstallNameTool + , InstallNameConfig (..) + , configureInstallName , runRanlib + , RanlibConfig (..) + , configureRanlib , runWindres + , WindresConfig (..) + , configureWindres ) where import GHC.Prelude @@ -207,15 +221,32 @@ runPp logger dflags args = traceSystoolCommand logger "pp" $ do opts = map Option (getOpts dflags opt_F) runSomething logger "Haskell pre-processor" prog (args ++ opts) +data CcConfig = CcConfig + { ccProg :: String + , cxxProg :: String + , ccOpts :: [String] + , cxxOpts :: [String] + , ccPicOpts :: [String] + } + +configureCc :: DynFlags -> CcConfig +configureCc dflags = CcConfig + { ccProg = pgm_c dflags + , cxxProg = pgm_cxx dflags + , ccOpts = getOpts dflags opt_c + , cxxOpts = getOpts dflags opt_cxx + , ccPicOpts = picCCOpts dflags + } + -- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do +runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> TempDir -> CcConfig -> [Option] -> IO () +runCc mLanguage logger tmpfs tmpdir opts args = traceSystoolCommand logger "cc" $ do let args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 -- We take care to pass -optc flags in args1 last to ensure that the -- user can override flags passed by GHC. See #14452. mb_env <- getGccEnv args2 - runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter dbgstring prog args2 + runSomethingResponseFile logger tmpfs tmpdir cc_filter dbgstring prog args2 mb_env where -- force the C compiler to interpret this file as C when @@ -223,38 +254,49 @@ runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do -- Also useful for plain .c files, just in case GHC saw a -- -x c option. (languageOptions, userOpts, prog, dbgstring) = case mLanguage of - Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler") - Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr) + Nothing -> ([], ccOpts opts, ccProg opts, "C Compiler") + Just language -> ([Option "-x", Option languageName], copts, prog, dbgstr) where - (languageName, opts, prog, dbgstr) = case language of - LangC -> ("c", userOpts_c - ,pgm_c dflags, "C Compiler") - LangCxx -> ("c++", userOpts_cxx - ,pgm_cxx dflags , "C++ Compiler") - LangObjc -> ("objective-c", userOpts_c - ,pgm_c dflags , "Objective C Compiler") - LangObjcxx -> ("objective-c++", userOpts_cxx - ,pgm_cxx dflags, "Objective C++ Compiler") + (languageName, copts, prog, dbgstr) = case language of + LangC -> ("c", ccOpts opts + ,ccProg opts, "C Compiler") + LangCxx -> ("c++", cxxOpts opts + ,cxxProg opts, "C++ Compiler") + LangObjc -> ("objective-c", ccOpts opts + ,ccProg opts, "Objective C Compiler") + LangObjcxx -> ("objective-c++", cxxOpts opts + ,cxxProg opts, "Objective C++ Compiler") LangAsm -> ("assembler", [] - ,pgm_c dflags, "Asm Compiler") + ,ccProg opts, "Asm Compiler") RawObject -> ("c", [] - ,pgm_c dflags, "C Compiler") -- claim C for lack of a better idea + ,ccProg opts, "C Compiler") -- claim C for lack of a better idea --JS backend shouldn't reach here, so we just pass -- strings to satisfy the totality checker LangJs -> ("js", [] - ,pgm_c dflags, "JS Backend Compiler") - userOpts_c = getOpts dflags opt_c - userOpts_cxx = getOpts dflags opt_cxx + ,ccProg opts, "JS Backend Compiler") isContainedIn :: String -> String -> Bool xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) --- | Run the linker with some arguments and return the output -askLd :: Logger -> DynFlags -> [Option] -> IO String -askLd logger dflags args = traceSystoolCommand logger "linker" $ do +data LdConfig = LdConfig + { ldProg :: String -- ^ LD program path + , ldOpts :: [Option] -- ^ LD program arguments + } + +configureLd :: DynFlags -> LdConfig +configureLd dflags = let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 ++ args + in LdConfig + { ldProg = p + , ldOpts = args0 ++ args1 + } + +-- | Run the linker with some arguments and return the output +askLd :: Logger -> LdConfig -> [Option] -> IO String +askLd logger ld_config args = traceSystoolCommand logger "linker" $ do + let p = ldProg ld_config + args2 = ldOpts ld_config ++ args mb_env <- getGccEnv args2 runSomethingWith logger "gcc" p args2 $ \real_args -> readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } @@ -373,31 +415,80 @@ runMergeObjects logger tmpfs dflags args = else do runSomething logger "Merge objects" p args2 -runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do - let ar = pgm_ar dflags +newtype ArConfig = ArConfig + { arProg :: String + } + +configureAr :: DynFlags -> ArConfig +configureAr dflags = ArConfig + { arProg = pgm_ar dflags + } + +runAr :: Logger -> ArConfig -> Maybe FilePath -> [Option] -> IO () +runAr logger opts cwd args = traceSystoolCommand logger "ar" $ do + let ar = arProg opts runSomethingFiltered logger id "Ar" ar args cwd Nothing -askOtool :: Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO String -askOtool logger toolSettings mb_cwd args = do - let otool = toolSettings_pgm_otool toolSettings +newtype OtoolConfig = OtoolConfig + { otoolProg :: String + } + +configureOtool :: DynFlags -> OtoolConfig +configureOtool dflags = OtoolConfig + { otoolProg = toolSettings_pgm_otool (toolSettings dflags) + } + +askOtool :: Logger -> OtoolConfig -> Maybe FilePath -> [Option] -> IO String +askOtool logger opts mb_cwd args = do + let otool = otoolProg opts runSomethingWith logger "otool" otool args $ \real_args -> readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } -runInstallNameTool :: Logger -> ToolSettings -> [Option] -> IO () -runInstallNameTool logger toolSettings args = do - let tool = toolSettings_pgm_install_name_tool toolSettings +newtype InstallNameConfig = InstallNameConfig + { installNameProg :: String + } + +configureInstallName :: DynFlags -> InstallNameConfig +configureInstallName dflags = InstallNameConfig + { installNameProg = toolSettings_pgm_install_name_tool (toolSettings dflags) + } + +runInstallNameTool :: Logger -> InstallNameConfig -> [Option] -> IO () +runInstallNameTool logger opts args = do + let tool = installNameProg opts runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing -runRanlib :: Logger -> DynFlags -> [Option] -> IO () -runRanlib logger dflags args = traceSystoolCommand logger "ranlib" $ do - let ranlib = pgm_ranlib dflags +newtype RanlibConfig = RanlibConfig + { ranlibProg :: String + } + +configureRanlib :: DynFlags -> RanlibConfig +configureRanlib dflags = RanlibConfig + { ranlibProg = pgm_ranlib dflags + } + +runRanlib :: Logger -> RanlibConfig -> [Option] -> IO () +runRanlib logger opts args = traceSystoolCommand logger "ranlib" $ do + let ranlib = ranlibProg opts runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing -runWindres :: Logger -> DynFlags -> [Option] -> IO () -runWindres logger dflags args = traceSystoolCommand logger "windres" $ do - let cc_args = map Option (sOpt_c (settings dflags)) - windres = pgm_windres dflags - opts = map Option (getOpts dflags opt_windres) +data WindresConfig = WindresConfig + { windresProg :: String + , windresOpts :: [Option] + , windresCOpts :: [Option] + } + +configureWindres :: DynFlags -> WindresConfig +configureWindres dflags = WindresConfig + { windresProg = pgm_windres dflags + , windresOpts = map Option (getOpts dflags opt_windres) + , windresCOpts = map Option (sOpt_c (settings dflags)) + } + +runWindres :: Logger -> WindresConfig -> [Option] -> IO () +runWindres logger opts args = traceSystoolCommand logger "windres" $ do + let cc_args = windresCOpts opts + windres = windresProg opts + wopts = windresOpts opts mb_env <- getGccEnv cc_args - runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env + runSomethingFiltered logger id "Windres" windres (wopts ++ args) Nothing mb_env ===================================== compiler/ghc.cabal.in ===================================== @@ -515,6 +515,7 @@ Library GHC.Driver.Config.HsToCore GHC.Driver.Config.HsToCore.Ticks GHC.Driver.Config.HsToCore.Usage + GHC.Driver.Config.Interpreter GHC.Driver.Config.Linker GHC.Driver.Config.Logger GHC.Driver.Config.Parser @@ -650,7 +651,7 @@ Library GHC.Linker.Deps GHC.Linker.Dynamic GHC.Linker.External - GHC.Linker.ExtraObj + GHC.Linker.Executable GHC.Linker.Loader GHC.Linker.MacOS GHC.Linker.Static @@ -723,6 +724,8 @@ Library GHC.Runtime.Heap.Inspect GHC.Runtime.Heap.Layout GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.C + GHC.Runtime.Interpreter.Init GHC.Runtime.Interpreter.JS GHC.Runtime.Interpreter.Process GHC.Runtime.Interpreter.Types ===================================== testsuite/tests/bytecode/T23973.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LinearTypes #-} + +module Main (main) where + +data Ur a where + Ur :: a -> Ur a + +unur :: Ur a -> a +unur (Ur a) = a + +segvGHCi :: Ur () +segvGHCi = Ur $ () + +main :: IO () +main = print (unur segvGHCi) + ===================================== testsuite/tests/bytecode/T23973.script ===================================== @@ -0,0 +1,2 @@ +:l T23973.hs +main ===================================== testsuite/tests/bytecode/T23973.stdout ===================================== @@ -0,0 +1 @@ +() ===================================== testsuite/tests/bytecode/T26565.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes #-} +module Test where + +data Ur a where + Ur :: a -> Ur a + ===================================== testsuite/tests/bytecode/T26565.script ===================================== @@ -0,0 +1,3 @@ +:l T26565 +Ur y = (\x -> Ur $ replicate 5 'a') 3 +y ===================================== testsuite/tests/bytecode/T26565.stdout ===================================== @@ -0,0 +1 @@ +"aaaaa" ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -6,6 +6,8 @@ test('T25975', extra_ways(ghci_ways), compile_and_run, # Some of the examples work more robustly with these flags ['-fno-break-points -fno-full-laziness']) +test('T26565', extra_files(["T26565.hs"]), ghci_script, ['T26565.script']) +test('T23973', extra_files(["T23973.hs"]), ghci_script, ['T23973.script']) + # Nullary data constructors test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) - ===================================== testsuite/tests/driver/T24731.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module T24731 where + +foo :: Int +foo = $([|10|]) ===================================== testsuite/tests/driver/all.T ===================================== @@ -333,3 +333,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('T24731', [only_ways(['ext-interp'])], compile, ['-fexternal-interpreter -pgmi ""']) ===================================== utils/iserv/iserv.cabal.in ===================================== @@ -30,15 +30,6 @@ Executable iserv C-Sources: cbits/iservmain.c Hs-Source-Dirs: src include-dirs: . - Build-Depends: array >= 0.5 && < 0.6, - base >= 4 && < 5, - binary >= 0.7 && < 0.11, - bytestring >= 0.10 && < 0.13, - containers >= 0.5 && < 0.9, - deepseq >= 1.4 && < 1.6, - ghci == @ProjectVersionMunged@ - - if os(windows) - Cpp-Options: -DWINDOWS - else - Build-Depends: unix >= 2.7 && < 2.9 + Build-Depends: + base >= 4 && < 5, + ghci == @ProjectVersionMunged@ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50dfc3a02d07d7da3a85b6a9f2151c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50dfc3a02d07d7da3a85b6a9f2151c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/nubOrd] 4 commits: Make PmLit be in Ord, and use it in Map
by Bodigrim (＠Bodigrim) 19 Nov '25

19 Nov '25

Bodigrim pushed to branch wip/nubOrd at Glasgow Haskell Compiler / GHC Commits: c12fa73e by Simon Peyton Jones at 2025-11-19T02:55:01-05:00 Make PmLit be in Ord, and use it in Map This MR addresses #26514, by changing from data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] to data PmAltConSet = PACS !(UniqDSet ConLike) !(Map PmLit PmLit) This matters when doing pattern-match overlap checking, when there is a very large set of patterns. For most programs it makes no difference at all. For the N=5000 case of the repro case in #26514, compiler mutator time (with `-fno-code`) goes from 1.9s to 0.43s. All for the price for an Ord instance for PmLit - - - - - 41b84f40 by sheaf at 2025-11-19T02:55:52-05:00 Add passing tests for #26311 and #26072 This commit adds two tests cases that now pass since landing the changes to typechecking of data constructors in b33284c7. Fixes #26072 #26311 - - - - - 1faa758a by sheaf at 2025-11-19T02:55:52-05:00 mkCast: weaken bad cast warning for multiplicity This commit weakens the warning message emitted when constructing a bad cast in mkCast to ignore multiplicity. Justification: since b33284c7, GHC uses sub-multiplicity coercions to typecheck data constructors. The coercion optimiser is free to discard these coercions, both for performance reasons, and because GHC's Core simplifier does not (yet) preserve linearity. We thus weaken 'mkCast' to use 'eqTypeIgnoringMultiplicity' instead of 'eqType', to avoid getting many spurious warnings about mismatched multiplicities. - - - - - bddcf63d by Andrew Lelechenko at 2025-11-19T22:28:46+00:00 Add nubOrd / nubOrdBy to Data.List and Data.List.NonEmpty As per https://github.com/haskell/core-libraries-committee/issues/336 - - - - - 19 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Types/SourceText.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/base/src/Data/List.hs - libraries/base/src/Data/List/NonEmpty.hs - + libraries/base/src/Data/List/NubOrdSet.hs - libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs - 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/linear/should_run/T26311.hs - + testsuite/tests/linear/should_run/T26311.stdout - testsuite/tests/linear/should_run/all.T - testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr - + testsuite/tests/rep-poly/T26072b.hs - testsuite/tests/rep-poly/all.T Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -78,7 +78,7 @@ import GHC.Core.Type as Type import GHC.Core.Predicate( isEqPred ) import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.FamInstEnv -import GHC.Core.TyCo.Compare( eqType, eqTypeX ) +import GHC.Core.TyCo.Compare( eqType, eqTypeX, eqTypeIgnoringMultiplicity ) import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.TyCon @@ -275,7 +275,7 @@ mkCast expr co = assertPpr (coercionRole co == Representational) (text "coercion" <+> ppr co <+> text "passed to mkCast" <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $ - warnPprTrace (not (coercionLKind co `eqType` exprType expr)) "Bad cast" + warnPprTrace (not (coercionLKind co `eqTypeIgnoringMultiplicity` exprType expr)) "Bad cast" (vcat [ text "Coercion LHS kind does not match enclosed expression type" , text "co:" <+> ppr co , text "coercionLKind:" <+> ppr (coercionLKind co) ===================================== compiler/GHC/HsToCore/Pmc/Solver/Types.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} -- | Domain types used in "GHC.HsToCore.Pmc.Solver". -- The ultimate goal is to define 'Nabla', which models normalised refinement @@ -32,7 +33,7 @@ module GHC.HsToCore.Pmc.Solver.Types ( PmEquality(..), eqPmAltCon, -- *** Operations on 'PmLit' - literalToPmLit, negatePmLit, overloadPmLit, + literalToPmLit, negatePmLit, pmLitAsStringLit, coreExprAsPmLit ) where @@ -51,13 +52,12 @@ import GHC.Core.ConLike import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import GHC.Utils.Misc (lastMaybe) -import GHC.Data.List.SetOps (unionLists) import GHC.Data.Maybe import GHC.Core.Type import GHC.Core.TyCon import GHC.Types.Literal import GHC.Core -import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCo.Compare( eqType, nonDetCmpType ) import GHC.Core.Map.Expr import GHC.Core.Utils (exprType) import GHC.Builtin.Names @@ -69,15 +69,14 @@ import GHC.Types.CompleteMatch import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit , fractionalLitFromRational , FractionalExponentBase(..)) + import Numeric (fromRat) -import Data.Foldable (find) import Data.Ratio +import Data.List( find ) +import qualified Data.Map as FM import GHC.Real (Ratio(..)) -import qualified Data.Semigroup as Semi - --- import GHC.Driver.Ppr +import qualified Data.Semigroup as S --- -- * Normalised refinement types -- @@ -358,6 +357,13 @@ lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of | Just sol <- find isDataConSolution pos -> Just sol | otherwise -> Just x + +{- ********************************************************************* +* * + PmLit and PmLitValue +* * +********************************************************************* -} + -------------------------------------------------------------------------------- -- The rest is just providing an IR for (overloaded!) literals and AltCons that -- sits between Hs and Core. We need a reliable way to detect and determine @@ -376,13 +382,64 @@ data PmLitValue = PmLitInt Integer | PmLitRat Rational | PmLitChar Char - -- We won't actually see PmLitString in the oracle since we desugar strings to - -- lists | PmLitString FastString + -- We won't actually see PmLitString in the oracle + -- since we desugar strings to lists + + -- Overloaded literals | PmLitOverInt Int {- How often Negated? -} Integer | PmLitOverRat Int {- How often Negated? -} FractionalLit | PmLitOverString FastString +-- | Syntactic equality. +-- We want (Ord PmLit) so that we can use (Map PmLit x) in `PmAltConSet` +instance Eq PmLit where + a == b = (a `compare` b) == EQ +instance Ord PmLit where + compare = cmpPmLit + +cmpPmLit :: PmLit -> PmLit -> Ordering +-- This function does "syntactic comparison": +-- For overloaded literals, compare the type and value +-- For non-overloaded literals, just compare the values +-- But it treats (say) +-- (PmLit Bool (PmLitOverInt 1)) +-- (PmLit Bool (PmLitOverInt 2)) +-- as un-equal, even through (fromInteger @Bool 1) +-- could be the same as (fromInteger @Bool 2) +cmpPmLit (PmLit { pm_lit_ty = t1, pm_lit_val = val1 }) + (PmLit { pm_lit_ty = t2, pm_lit_val = val2 }) + = case (val1,val2) of + (PmLitInt i1, PmLitInt i2) -> i1 `compare` i2 + (PmLitRat r1, PmLitRat r2) -> r1 `compare` r2 + (PmLitChar c1, PmLitChar c2) -> c1 `compare` c2 + (PmLitString s1, PmLitString s2) -> s1 `uniqCompareFS` s2 + (PmLitOverInt n1 i1, PmLitOverInt n2 i2) -> (n1 `compare` n2) S.<> + (i1 `compare` i2) S.<> + (t1 `nonDetCmpType` t2) + (PmLitOverRat n1 r1, PmLitOverRat n2 r2) -> (n1 `compare` n2) S.<> + (r1 `compare` r2) S.<> + (t1 `nonDetCmpType` t2) + (PmLitOverString s1, PmLitOverString s2) -> (s1 `uniqCompareFS` s2) S.<> + (t1 `nonDetCmpType` t2) + (PmLitInt {}, _) -> LT + (PmLitRat {}, PmLitInt {}) -> GT + (PmLitRat {}, _) -> LT + (PmLitChar {}, PmLitInt {}) -> GT + (PmLitChar {}, PmLitRat {}) -> GT + (PmLitChar {}, _) -> LT + (PmLitString {}, PmLitInt {}) -> GT + (PmLitString {}, PmLitRat {}) -> GT + (PmLitString {}, PmLitChar {}) -> GT + (PmLitString {}, _) -> LT + + (PmLitOverString {}, _) -> GT + (PmLitOverRat {}, PmLitOverString{}) -> LT + (PmLitOverRat {}, _) -> GT + (PmLitOverInt {}, PmLitOverString{}) -> LT + (PmLitOverInt {}, PmLitOverRat{}) -> LT + (PmLitOverInt {}, _) -> GT + -- | Undecidable semantic equality result. -- See Note [Undecidable Equality for PmAltCons] data PmEquality @@ -406,7 +463,10 @@ eqPmLit :: PmLit -> PmLit -> PmEquality eqPmLit (PmLit t1 v1) (PmLit t2 v2) -- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined | not (t1 `eqType` t2) = Disjoint - | otherwise = go v1 v2 + | otherwise = eqPmLitValue v1 v2 + +eqPmLitValue :: PmLitValue -> PmLitValue -> PmEquality +eqPmLitValue v1 v2 = go v1 v2 where go (PmLitInt i1) (PmLitInt i2) = decEquality (i1 == i2) go (PmLitRat r1) (PmLitRat r2) = decEquality (r1 == r2) @@ -420,10 +480,6 @@ eqPmLit (PmLit t1 v1) (PmLit t2 v2) | s1 == s2 = Equal go _ _ = PossiblyOverlap --- | Syntactic equality. -instance Eq PmLit where - a == b = eqPmLit a b == Equal - -- | Type of a 'PmLit' pmLitType :: PmLit -> Type pmLitType (PmLit ty _) = ty @@ -445,34 +501,47 @@ eqConLike (PatSynCon psc1) (PatSynCon psc2) = Equal eqConLike _ _ = PossiblyOverlap + +{- ********************************************************************* +* * + PmAltCon and PmAltConSet +* * +********************************************************************* -} + -- | Represents the head of a match against a 'ConLike' or literal. -- Really similar to 'GHC.Core.AltCon'. data PmAltCon = PmAltConLike ConLike | PmAltLit PmLit -data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] +data PmAltConSet = PACS !(UniqDSet ConLike) + !(FM.Map PmLit PmLit) +-- We use a (FM.Map PmLit PmLit) here, at the cost of requiring an Ord +-- instance for PmLit, because in extreme cases the set of PmLits can be +-- very large. See #26514. emptyPmAltConSet :: PmAltConSet -emptyPmAltConSet = PACS emptyUniqDSet [] +emptyPmAltConSet = PACS emptyUniqDSet FM.empty isEmptyPmAltConSet :: PmAltConSet -> Bool -isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits +isEmptyPmAltConSet (PACS cls lits) + = isEmptyUniqDSet cls && FM.null lits -- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to -- the given 'PmAltCon' according to 'eqPmAltCon'. elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls -elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits +elemPmAltConSet (PmAltLit lit) (PACS _ lits) = isJust (FM.lookup lit lits) extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet extendPmAltConSet (PACS cls lits) (PmAltConLike cl) = PACS (addOneToUniqDSet cls cl) lits extendPmAltConSet (PACS cls lits) (PmAltLit lit) - = PACS cls (unionLists lits [lit]) + = PACS cls (FM.insert lit lit lits) pmAltConSetElems :: PmAltConSet -> [PmAltCon] pmAltConSetElems (PACS cls lits) - = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits + = map PmAltConLike (uniqDSetToList cls) ++ + FM.foldr ((:) . PmAltLit) [] lits instance Outputable PmAltConSet where ppr = ppr . pmAltConSetElems ===================================== compiler/GHC/Types/SourceText.hs ===================================== @@ -188,6 +188,7 @@ data FractionalLit = FL } deriving (Data, Show) -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on + -- Eq and Ord instances are done explicitly -- See Note [FractionalLit representation] in GHC.HsToCore.Match.Literal data FractionalExponentBase ===================================== libraries/base/base.cabal.in ===================================== @@ -303,6 +303,7 @@ Library , GHC.JS.Foreign.Callback other-modules: + Data.List.NubOrdSet System.CPUTime.Unsupported System.CPUTime.Utils if os(windows) ===================================== libraries/base/changelog.md ===================================== @@ -10,6 +10,7 @@ * Fix bug where `naturalAndNot` was incorrectly truncating results ([CLC proposal #350](github.com/haskell/core-libraries-committee/issues/350)) * Remove extra laziness from `Data.Bifunctor.Bifunctor` instances for all tuples to have the same laziness as their `Data.Functor.Functor` counterparts (i.e. they became more strict than before) ([CLC proposal #339](https://github.com/haskell/core-libraries-committee/issues/339)) * Adjust the strictness of `Data.List.iterate'` to be more reasonable: every element of the output list is forced to WHNF when the `(:)` containing it is forced. ([CLC proposal #335)](https://github.com/haskell/core-libraries-committee/issues/335) + * Add `nubOrd` / `nubOrdBy` to `Data.List` and `Data.List.NonEmpty`. ([CLC proposal #336](https://github.com/haskell/core-libraries-committee/issues/336)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/src/Data/List.hs ===================================== @@ -137,6 +137,7 @@ module Data.List unwords, -- ** \"Set\" operations nub, + nubOrd, delete, (\\), union, @@ -157,6 +158,7 @@ module Data.List -- *** User-supplied equality (replacing an @Eq@ context) -- | The predicate is assumed to define an equivalence. nubBy, + nubOrdBy, deleteBy, deleteFirstsBy, unionBy, @@ -180,12 +182,14 @@ module Data.List ) where import GHC.Internal.Data.Bool (otherwise) +import GHC.Internal.Data.Function (const) import GHC.Internal.Data.List import GHC.Internal.Data.List.NonEmpty (NonEmpty(..)) -import GHC.Internal.Data.Ord (Ordering(..), (<), (>)) +import GHC.Internal.Data.Ord (Ord, compare, Ordering(..), (<), (>)) import GHC.Internal.Int (Int) import GHC.Internal.Num ((-)) import GHC.List (build) +import qualified Data.List.NubOrdSet as NubOrdSet inits1, tails1 :: [a] -> [NonEmpty a] @@ -282,3 +286,24 @@ compareLength xs n (\m -> if m > 0 then LT else EQ) xs n + +-- | Same as 'nub', but asymptotically faster, taking only /O/(/n/ log /n/) time. +-- +-- @since 4.23.0.0 +nubOrd :: Ord a => [a] -> [a] +nubOrd = nubOrdBy compare +{-# INLINE nubOrd #-} + +-- | Overloaded version of 'Data.List.nubOrd'. +-- +-- The supplied comparison relation is supposed to be reflexive, transitive +-- and antisymmetric, same as for 'sortBy'. +-- +-- @since 4.23.0.0 +nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a] +nubOrdBy cmp xs = foldr + (\x acc seen -> if NubOrdSet.member cmp x seen then acc seen else x : acc (NubOrdSet.insert cmp x seen)) + (const []) + xs + NubOrdSet.empty +{-# INLINE nubOrdBy #-} ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -94,7 +94,9 @@ module Data.List.NonEmpty ( , isPrefixOf -- :: Eq a => [a] -> NonEmpty a -> Bool -- * \"Set\" operations , nub -- :: Eq a => NonEmpty a -> NonEmpty a + , nubOrd -- :: Ord a => NonEmpty a -> NonEmpty a , nubBy -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a + , nubOrdBy -- :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a -- * Indexing streams , (!!) -- :: NonEmpty a -> Int -> a -- * Zipping and unzipping streams @@ -119,6 +121,7 @@ import qualified Prelude import Control.Applicative (Applicative (..), Alternative (many)) import qualified Data.List as List +import qualified Data.List.NubOrdSet as NubOrdSet import qualified Data.Maybe as List (mapMaybe) import GHC.Internal.Data.Foldable hiding (length, toList) import qualified GHC.Internal.Data.Foldable as Foldable @@ -577,6 +580,24 @@ nub = nubBy (==) nubBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a nubBy eq (a :| as) = a :| List.nubBy eq (List.filter (\b -> not (eq a b)) as) +-- | Same as 'nub', but asymptotically faster, taking only /O/(/n/ log /n/) time. +-- +-- @since 4.23.0.0 +nubOrd :: Ord a => NonEmpty a -> NonEmpty a +nubOrd = nubOrdBy compare +{-# INLINE nubOrd #-} + +-- | Overloaded version of 'Data.List.NonEmpty.nubOrd'. +-- +-- @since 4.23.0.0 +nubOrdBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a +nubOrdBy cmp (y :| ys) = y :| foldr + (\x acc seen -> if NubOrdSet.member cmp x seen then acc seen else x : acc (NubOrdSet.insert cmp x seen)) + (const []) + ys + (NubOrdSet.insert cmp y NubOrdSet.empty) +{-# INLINE nubOrdBy #-} + -- | 'transpose' for 'NonEmpty', behaves the same as 'GHC.Internal.Data.List.transpose' -- The rows/columns need not be the same length, in which case -- > transpose . transpose /= id ===================================== libraries/base/src/Data/List/NubOrdSet.hs ===================================== @@ -0,0 +1,81 @@ +-- This is an internal module with a naive set implementation, +-- solely for the purposes of `Data.List.{,NonEmpty.}nubOrd{,By}`. + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Data.List.NubOrdSet ( + NubOrdSet, + empty, + member, + insert, +) where + +import GHC.Internal.Data.Bool (Bool(..)) +import GHC.Internal.Data.Function ((.)) +import GHC.Internal.Data.Ord (Ordering(..)) + +-- | Implemented as a red-black tree, a la Okasaki. +data NubOrdSet a + = Empty + | NodeRed !(NubOrdSet a) !a !(NubOrdSet a) + | NodeBlack !(NubOrdSet a) !a !(NubOrdSet a) + +empty :: NubOrdSet a +empty = Empty + +member :: (a -> a -> Ordering) -> a -> NubOrdSet a -> Bool +member cmp = member' + where + member' !x = go + where + go = \case + Empty -> False + NodeRed left center right -> chooseWay left center right + NodeBlack left center right -> chooseWay left center right + + chooseWay left center right = case cmp x center of + LT -> go left + EQ -> True + GT -> go right +{-# INLINE member #-} + +insert :: (a -> a -> Ordering) -> a -> NubOrdSet a -> NubOrdSet a +insert cmp = insert' + where + insert' !x = blacken . go + where + go node = case node of + Empty -> NodeRed Empty x Empty + NodeRed left center right -> case cmp x center of + LT -> NodeRed (go left) center right + EQ -> node + GT -> NodeRed left center (go right) + NodeBlack left center right -> case cmp x center of + LT -> balanceBlackLeft (go left) center right + EQ -> node + GT -> balanceBlackRight left center (go right) + + blacken node = case node of + Empty -> Empty + NodeRed left center right -> NodeBlack left center right + NodeBlack{} -> node +{-# INLINE insert #-} + +balanceBlackLeft :: NubOrdSet a -> a -> NubOrdSet a -> NubOrdSet a +balanceBlackLeft (NodeRed (NodeRed a b c) d e) f g = + NodeRed (NodeBlack a b c) d (NodeBlack e f g) +balanceBlackLeft (NodeRed a b (NodeRed c d e)) f g = + NodeRed (NodeBlack a b c) d (NodeBlack e f g) +balanceBlackLeft left center right = + NodeBlack left center right +{-# INLINE balanceBlackLeft #-} + +balanceBlackRight :: NubOrdSet a -> a -> NubOrdSet a -> NubOrdSet a +balanceBlackRight a b (NodeRed (NodeRed c d e) f g) = + NodeRed (NodeBlack a b c) d (NodeBlack e f g) +balanceBlackRight a b (NodeRed c d (NodeRed e f g)) = + NodeRed (NodeBlack a b c) d (NodeBlack e f g) +balanceBlackRight left center right = + NodeBlack left center right +{-# INLINE balanceBlackRight #-} ===================================== libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs ===================================== @@ -499,16 +499,7 @@ isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) -- name 'nub' means \`essence\'.) It is a special case of 'nubBy', which allows -- the programmer to supply their own equality test. -- --- --- If there exists @instance Ord a@, it's faster to use `nubOrd` from the `containers` package --- ([link to the latest online documentation](https://hackage.haskell.org/package/containers/docs/Data-Con…) --- which takes only $\mathcal{O}(n \log d)$ time where `d` is the number of --- distinct elements in the list. --- --- Another approach to speed up 'nub' is to use --- 'map' @Data.List.NonEmpty.@'Data.List.NonEmpty.head' . @Data.List.NonEmpty.@'Data.List.NonEmpty.group' . 'sort', --- which takes $\mathcal{O}(n \log n)$ time, requires @instance Ord a@ and doesn't --- preserve the order. +-- If there exists @instance Ord a@, it's faster to use 'Data.List.nubOrd'. -- -- ==== __Examples__ -- ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1379,6 +1379,8 @@ module Data.List where notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a] nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a] + nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a] + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a] null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a]) @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a + nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a]) permutations :: forall a. [a] -> NonEmpty [a] permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a) ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1379,6 +1379,8 @@ module Data.List where notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a] nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a] + nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a] + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a] null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a]) @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a + nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a]) permutations :: forall a. [a] -> NonEmpty [a] permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a) ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1379,6 +1379,8 @@ module Data.List where notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a] nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a] + nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a] + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a] null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a]) @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a + nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a]) permutations :: forall a. [a] -> NonEmpty [a] permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a) ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1379,6 +1379,8 @@ module Data.List where notElem :: forall (t :: * -> *) a. (GHC.Internal.Data.Foldable.Foldable t, GHC.Internal.Classes.Eq a) => a -> t a -> GHC.Internal.Types.Bool nub :: forall a. GHC.Internal.Classes.Eq a => [a] -> [a] nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> [a] -> [a] + nubOrd :: forall a. GHC.Internal.Classes.Ord a => [a] -> [a] + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> [a] -> [a] null :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t a -> GHC.Internal.Types.Bool or :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool partition :: forall a. (a -> GHC.Internal.Types.Bool) -> [a] -> ([a], [a]) @@ -1473,6 +1475,8 @@ module Data.List.NonEmpty where nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a + nubOrd :: forall a. GHC.Internal.Classes.Ord a => NonEmpty a -> NonEmpty a + nubOrdBy :: forall a. (a -> a -> GHC.Internal.Types.Ordering) -> NonEmpty a -> NonEmpty a partition :: forall a. (a -> GHC.Internal.Types.Bool) -> NonEmpty a -> ([a], [a]) permutations :: forall a. [a] -> NonEmpty [a] permutations1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a) ===================================== testsuite/tests/linear/should_run/T26311.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts ( Int# ) + +expensive :: Int -> Int# +expensive 0 = 2# +expensive i = expensive (i-1) + +data D = MkD Int# Int + +f :: a -> Bool +f _ = False +{-# NOINLINE f #-} + +{-# RULES "f/MkD" forall x. f (MkD x) = True #-} + +bar :: Bool +bar = f (MkD (expensive 10)) + +main :: IO () +main = print bar ===================================== testsuite/tests/linear/should_run/T26311.stdout ===================================== @@ -0,0 +1 @@ +True ===================================== testsuite/tests/linear/should_run/all.T ===================================== @@ -1,2 +1,3 @@ test('LinearTypeable', normal, compile_and_run, ['']) +test('T26311', normal, compile_and_run, ['-O1']) test('LinearGhci', normal, ghci_script, ['LinearGhci.script']) ===================================== testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr ===================================== @@ -1,4 +1,3 @@ - pmcOrPats.hs:10:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘g’: Patterns of type ‘T’, ‘U’ not matched: A W @@ -18,7 +17,7 @@ pmcOrPats.hs:15:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] pmcOrPats.hs:17:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘z’: - Patterns of type ‘a’ not matched: p where p is not one of {3, 1, 2} + Patterns of type ‘a’ not matched: p where p is not one of {1, 2, 3} pmcOrPats.hs:19:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] Pattern match is redundant @@ -43,3 +42,4 @@ pmcOrPats.hs:21:1: warning: [GHC-61505] • Patterns reported as unmatched might actually be matched Suggested fix: Increase the limit or resolve the warnings to suppress this message. + ===================================== testsuite/tests/rep-poly/T26072b.hs ===================================== @@ -0,0 +1,78 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +module T26072b where + +-- base +import Data.Kind +import GHC.TypeNats +import GHC.Exts + ( TYPE, RuntimeRep(..), LiftedRep + , proxy# + ) + +-------------------------------------------------------------------------------- + +-- Stub for functions in 'primitive' (to avoid dependency) +type PrimArray :: Type -> Type +data PrimArray a = MkPrimArray + +indexPrimArray :: PrimArray a -> Int -> a +indexPrimArray _ _ = error "unimplemented" +{-# NOINLINE indexPrimArray #-} + +-------------------------------------------------------------------------------- + +int :: forall n. KnownNat n => Int +int = fromIntegral ( natVal' @n proxy# ) + +type Fin :: Nat -> Type +newtype Fin n = Fin { getFin :: Int } + +-- Vector +type V :: Nat -> Type -> Type +newtype V n a = V ( PrimArray a ) + +-- Matrix +type M :: Nat -> Type -> Type +newtype M n a = M ( PrimArray a ) + +type IndexRep :: (Type -> Type) -> RuntimeRep +type family IndexRep f +class Ix f where + type Index f :: TYPE (IndexRep f) + (!) :: f a -> Index f -> a + infixl 9 ! + +type instance IndexRep ( V n ) = LiftedRep +instance Ix ( V n ) where + type Index ( V n ) = Fin n + V v ! Fin !i = indexPrimArray v i + {-# INLINE (!) #-} + +type instance IndexRep ( M m ) = TupleRep [ LiftedRep, LiftedRep ] + +instance KnownNat n => Ix ( M n ) where + type Index ( M n ) = (# Fin n, Fin n #) + M m ! (# Fin !i, Fin !j #) = indexPrimArray m ( i + j * int @n ) + {-# INLINE (!) #-} + +rowCol :: forall n a. ( KnownNat n, Num a ) => Fin n -> M n a -> V n a -> a +rowCol i m v = go 0 ( Fin 0 ) + where + n = int @n + go :: a -> Fin n -> a + go !acc j@( Fin !j_ ) + | j_ >= n + = acc + | otherwise + = go ( acc + m ! (# i , j #) * v ! j ) ( Fin ( j_ + 1 ) ) ===================================== testsuite/tests/rep-poly/all.T ===================================== @@ -127,6 +127,7 @@ test('T17536b', normal, compile, ['']) ## test('T21650_a', js_broken(26578), compile, ['-Wno-deprecated-flags']) ## test('T21650_b', js_broken(26578), compile, ['-Wno-deprecated-flags']) ## test('T26072', js_broken(26578), compile, ['']) ## +test('T26072b', js_broken(26578), compile, ['']) ## test('RepPolyArgument2', normal, compile, ['']) ## test('RepPolyCase2', js_broken(26578), compile, ['']) ## test('RepPolyRule3', normal, compile, ['']) ## View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/de697b64482f93063f01b760ab898f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/de697b64482f93063f01b760ab898f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/imp-exp-whole-namespace] Namespace-specified wildcards in import/export lists (#25901)
by Vladislav Zavialov (＠int-index) 19 Nov '25

19 Nov '25

Vladislav Zavialov pushed to branch wip/int-index/imp-exp-whole-namespace at Glasgow Haskell Compiler / GHC Commits: 37c94802 by Vladislav Zavialov at 2025-11-19T23:47:32+03:00 Namespace-specified wildcards in import/export lists (#25901) This change adds support for top-level namespace-specified wildcards `type ..` and `data ..` to import and export lists. Examples: import M (type ..) -- imports all type and class constructors from M import M (data ..) -- imports all data constructors and terms from M module M (type .., f) where -- exports all type and class constructors defined in M, -- plus the function 'f' The primary intended usage of this feature is in combination with module aliases, allowing namespace disambiguation: import Data.Proxy as T (type ..) -- T.Proxy is unambiguously the type constructor import Data.Proxy as D (data ..) -- D.Proxy is unambiguously the data constructor The patch accounts for the interactions of wildcards with: * Imports with `hiding` clauses * Import warnings -Wunused-imports, -Wdodgy-imports * Export warnings -Wduplicate-exports, -Wdodgy-exports Summary of the changes: 1. Move the NamespaceSpecifier type from GHC.Hs.Binds to GHC.Hs.Basic, making it possible to use it in more places in the AST. 2. Extend the AST (type: IE) with a representation of `..`, `type ..`, and `data ..` (constructor: IEWholeNamespace). Per the proposal, the plain `..` is always rejected with a dedicated error message. 3. Extend the grammar in Parser.y with productions for `..`, `type ..`, and `data ..` in both import and export lists. 4. Implement wildcard imports by updating the `filterImports` function in GHC.Rename.Names; the logic for IEWholeNamespace is roughly modeled after the Nothing (no explicit import list) case. 5. Implement wildcard exports by updating the `exports_from_avail` function in GHC.Tc.Gen.Export; the logic for IEWholeNamespace is closely modeled after the IEModuleContents case. 6. Refactor and extend diagnostics to report the new warnings and errors. See PsErrPlainWildcardImport, DodgyImportsWildcard, PsErrPlainWildcardExport, DodgyExportsWildcard, TcRnDupeWildcardExport. Note that this patch is specifically about top-level import/export items. Subordinate import/export items are left unchanged. - - - - - 79 changed files: - compiler/GHC/Hs/Basic.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - docs/users_guide/9.16.1-notes.rst - docs/users_guide/exts/explicit_namespaces.rst - + testsuite/tests/module/T25901_exp_plain_wc.hs - + testsuite/tests/module/T25901_exp_plain_wc.stderr - + testsuite/tests/module/T25901_imp_plain_wc.hs - + testsuite/tests/module/T25901_imp_plain_wc.stderr - testsuite/tests/module/all.T - + testsuite/tests/rename/should_compile/T25901_exp_1.hs - + testsuite/tests/rename/should_compile/T25901_exp_1_helper.hs - + testsuite/tests/rename/should_compile/T25901_exp_2.hs - + testsuite/tests/rename/should_compile/T25901_exp_2_helper.hs - + testsuite/tests/rename/should_compile/T25901_imp_hq.hs - + testsuite/tests/rename/should_compile/T25901_imp_hu.hs - + testsuite/tests/rename/should_compile/T25901_imp_sq.hs - + testsuite/tests/rename/should_compile/T25901_imp_su.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T25901_exp_fail_1.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_1.stderr - + testsuite/tests/rename/should_fail/T25901_exp_fail_1_helper.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_2.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_2.stderr - + testsuite/tests/rename/should_fail/T25901_exp_fail_2_helper.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.stderr - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.stderr - + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.hs - + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.stderr - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.hs - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.stderr - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.hs - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.stderr - + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.hs - + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.stderr - testsuite/tests/rename/should_fail/all.T - + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.stderr - + testsuite/tests/warnings/should_compile/T25901_helper_1.hs - + testsuite/tests/warnings/should_compile/T25901_helper_2.hs - + testsuite/tests/warnings/should_compile/T25901_helper_3.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.stderr - testsuite/tests/warnings/should_compile/all.T - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37c94802a3e5f928227caaa363223f4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37c94802a3e5f928227caaa363223f4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/imp-exp-whole-namespace] 56 commits: Refactor fundep solving
by Vladislav Zavialov (＠int-index) 19 Nov '25

19 Nov '25

Vladislav Zavialov pushed to branch wip/int-index/imp-exp-whole-namespace at Glasgow Haskell Compiler / GHC Commits: fcf6331e by Richard Eisenberg at 2025-11-03T08:33:05+00:00 Refactor fundep solving This commit is a large-scale refactor of the increasingly-messy code that handles functional dependencies. It has virtually no effect on what compiles but improves error messages a bit. And it does the groundwork for #23162. The big picture is described in Note [Overview of functional dependencies in type inference] in GHC.Tc.Solver.FunDeps * New module GHC.Tc.Solver.FunDeps contains all the fundep-handling code for the constraint solver. * Fundep-equalities are solved in a nested scope; they may generate unifications but otherwise have no other effect. See GHC.Tc.Solver.FunDeps.solveFunDeps The nested needs to start from the Givens in the inert set, but not the Wanteds; hence a new function `resetInertCans`, used in `nestFunDepsTcS`. * That in turn means that fundep equalities never show up in error messages, so the complicated FunDepOrigin tracking can all disappear. * We need to be careful about tracking unifications, so we kick out constraints from the inert set after doing unifications. Unification tracking has been majorly reformed: see Note [WhatUnifications] in GHC.Tc.Utils.Unify. A good consequence is that the hard-to-grok `resetUnificationFlag` has been replaced with a simpler use of `reportCoarseGrainUnifications` Smaller things: * Rename `FunDepEqn` to `FunDepEqns` since it contains multiple type equalities. Some compile time improvement Metrics: compile_time/bytes allocated Baseline Test value New value Change ---------------------- -------------------------------------- T5030(normal) 173,839,232 148,115,248 -14.8% GOOD hard_hole_fits(normal) 286,768,048 284,015,416 -1.0% geo. mean -0.2% minimum -14.8% maximum +0.3% Metric Decrease: T5030 - - - - - 231adc30 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00 QuickLook's tcInstFun should make instantiation variables directly tcInstFun must make "instantiation variables", not regular unification variables, when instantiating function types. That was previously implemented by a hack: set the /ambient/ level to QLInstTyVar. But the hack finally bit me, when I was refactoring WhatUnifications. And it was always wrong: see the now-expunged (TCAPP2) note. This commit does it right, by making tcInstFun call its own instantiation functions. That entails a small bit of duplication, but the result is much, much cleaner. - - - - - 39d4a24b by Simon Peyton Jones at 2025-11-03T08:33:05+00:00 Build implication for constraints from (static e) This commit addresses #26466, by buiding an implication for the constraints arising from a (static e) form. The implication has a special ic_info field of StaticFormSkol, which tells the constraint solver to use an empty set of Givens. See (SF3) in Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable This commit also reinstates an `assert` in GHC.Tc.Solver.Equality. The test `StaticPtrTypeFamily` was failing with an assertion failure, but it now works. - - - - - 2e2aec1e by Simon Peyton Jones at 2025-11-03T08:33:05+00:00 Comments about defaulting representation equalities - - - - - 52a4d1da by Simon Peyton Jones at 2025-11-03T08:33:05+00:00 Improve tracking of rewriter-sets This refactor substantially improves the treatment of so-called "rewriter-sets" in the constraint solver. The story is described in the rewritten Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint Some highlights * Trace the free coercion holes of a filled CoercionHole, in CoercionPlusHoles. See Note [Coercion holes] (COH5) This avoids taking having to take the free coercion variables of a coercion when zonking a rewrriter-set * Many knock on changes * Make fillCoercionHole take CoercionPlusHoles as its argument rather than to separate arguments. * Similarly setEqIfWanted, setWantedE, wrapUnifierAndEmit. * Be more careful about passing the correct CoHoleSet to `rewriteEqEvidence` and friends * Make kickOurAfterFillingCoercionHole more clever. See new Note [Kick out after filling a coercion hole] Smaller matters * Rename RewriterSet to CoHoleSet * Add special-case helper `rewriteEqEvidenceSwapOnly` - - - - - 3e78e1ba by Simon Peyton Jones at 2025-11-03T08:33:05+00:00 Tidy up constraint solving for foralls * In `can_eq_nc_forall` make sure to track Givens that are used in the nested solve step. * Tiny missing-swap bug-fix in `lookup_eq_in_qcis` * Fix some leftover mess from commit 14123ee646f2b9738a917b7cec30f9d3941c13de Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Wed Aug 20 00:35:48 2025 +0100 Solve forall-constraints via an implication, again Specifically, trySolveImplication is now dead. - - - - - 973f2c25 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00 Do not treat CoercionHoles as free variables in coercions This fixes a long-standing wart in the free-variable finder; now CoercionHoles are no longer treated as a "free variable" of a coercion. I got big and unexpected performance regressions when making this change. Turned out that CallArity didn't discover that the free variable finder could be eta-expanded, which gave very poor code. So I re-used Note [The one-shot state monad trick] for Endo, resulting in GHC.Utils.EndoOS. Very simple, big win. - - - - - c2b8a0f9 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00 Update debug-tracing in CallArity No effect on behaviour, and commented out anyway - - - - - 9aa5ee99 by Simon Peyton Jones at 2025-11-03T08:33:28+00:00 Comments only -- remove dangling Note references - - - - - 6683f183 by Simon Peyton Jones at 2025-11-03T08:33:28+00:00 Accept error message wibbles - - - - - 3ba3d9f9 by Luite Stegeman at 2025-11-04T00:59:41-05:00 rts: fix eager black holes: record mutated closure and fix assertion This fixes two problems with handling eager black holes, introduced by a1de535f762bc23d4cf23a5b1853591dda12cdc9. - the closure mutation must be recorded even for eager black holes, since the mutator has mutated it before calling threadPaused - The assertion that an unmarked eager black hole must be owned by the TSO calling threadPaused is incorrect, since multiple threads can race to claim the black hole. fixes #26495 - - - - - b5508f2c by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00 build: Relax ghc/ghc-boot Cabal bound to 3.16 Fixes #26202 - - - - - c5b3541f by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00 cabal-reinstall: Use haddock-api +in-tree-ghc Fixes #26202 - - - - - c6d4b945 by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00 cabal-reinstall: Pass --strict to Happy This is necessary to make the generated Parser build successfully This mimics Hadrian, which always passes --strict to happy. Fixes #26202 - - - - - 79df1e0e by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00 genprimopcode: Require higher happy version I've bumped the happy version to forbid deprecated Happy versions which don't successfully compile. - - - - - fa5d33de by Simon Peyton Jones at 2025-11-05T08:35:40-05:00 Add a HsWrapper optimiser This MR addresses #26349, by introduceing optSubTypeHsWrapper. There is a long Note [Deep subsumption and WpSubType] in GHC.Tc.Types.Evidence that explains what is going on. - - - - - ea58cae5 by Simon Peyton Jones at 2025-11-05T08:35:40-05:00 Improve mkWpFun_FRR This commit ensures that `mkWpFun_FRR` directly produces a `FunCo` in the cases where it can. (Previously called `mkWpFun` which in turn optimised to a `FunCo`, but that made the smarts in `mkWpFun` /essential/ rather than (as they should be) optional. - - - - - 5cdcfaed by Ben Gamari at 2025-11-06T09:01:36-05:00 compiler: Exclude units with no exposed modules from unused package check Such packages cannot be "used" in the Haskell sense of the word yet are nevertheless necessary as they may provide, e.g., C object code or link flags. Fixes #24120. - - - - - 74b8397a by Brandon Chinn at 2025-11-06T09:02:19-05:00 Replace deprecated argparse.FileType - - - - - 36ddf988 by Ben Gamari at 2025-11-06T09:03:01-05:00 Bump unix submodule to 2.8.8.0 Closes #26474. - - - - - c32b3a29 by fendor at 2025-11-06T09:03:43-05:00 Fix assertion in `postStringLen` to account for \0 byte We fix the assertion to handle trailing \0 bytes in `postStringLen`. Before this change, the assertion looked like this: ASSERT(eb->begin + eb->size > eb->pos + len + 1); Let's assume some values to see why this is actually off by one: eb->begin = 0 eb->size = 1 eb->pos = 0 len = 1 then the assertion would trigger correctly: 0 + 1 > 0 + 1 + 1 => 1 > 2 => false as there is not enough space for the \0 byte (which is the trailing +1). However, if we change `eb->size = 2`, then we do have enough space for a string of length 1, but the assertion still fails: 0 + 2 > 0 + 1 + 1 => 2 > 2 => false Which causes the assertion to fail if there is exactly enough space for the string with a trailing \0 byte. Clearly, the assertion should be `>=`! If we switch around the operand, it should become more obvious that `<=` is the correct comparison: ASSERT(eb->pos + len + 1 <= eb->begin + eb->size); This is expresses more naturally that the current position plus the length of the string (and the null byte) must be smaller or equal to the overall size of the buffer. This change also is in line with the implementation in `hasRoomForEvent` and `hasRoomForVariableEvent`: ``` StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum) { uint32_t size = ...; if (eb->pos + size > eb->begin + eb->size) ... ``` the check `eb->pos + size > eb->begin + eb->size` is identical to `eb->pos + size <= eb->begin + eb->size` plus a negation. - - - - - 3034a6f2 by Ben Gamari at 2025-11-06T09:04:24-05:00 Bump os-string submodule to 2.0.8 - - - - - 39567e85 by Cheng Shao at 2025-11-06T09:05:06-05:00 rts: use computed goto for instruction dispatch in the bytecode interpreter This patch uses computed goto for instruction dispatch in the bytecode interpreter. Previously instruction dispatch is done by a classic switch loop, so executing the next instruction requires two jumps: one to the start of the switch loop and another to the case block based on the instruction tag. By using computed goto, we can build a jump table consisted of code addresses indexed by the instruction tags themselves, so executing the next instruction requires only one jump, to the destination directly fetched from the jump table. Closes #12953. - - - - - 93fc7265 by sheaf at 2025-11-06T21:33:24-05:00 Correct hasFixedRuntimeRep in matchExpectedFunTys This commit fixes a bug in the representation-polymormorphism check in GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put the coercion resulting from hasFixedRuntimeRep in the wrong place, leading to the Core Lint error reported in #26528. The change is that we have to be careful when using 'mkWpFun': it expects **both** the expected and actual argument types to have a syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT] in GHC.Tc.Types.Evidence. On the way, this patch improves some of the commentary relating to other usages of 'mkWpFun' in the compiler, in particular in the view pattern case of 'tc_pat'. No functional changes, but some stylistic changes to make the code more readable, and make it easier to understand how we are upholding the WpFun-FRR-INVARIANT. Fixes #26528 - - - - - c052c724 by Simon Peyton Jones at 2025-11-06T21:34:06-05:00 Fix a horrible shadowing bug in implicit parameters Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts where we now do /not/ delete /Wanted/ implicit-parameeter constraints. This bug has been in GHC since 9.8! But it's quite hard to provoke; I contructed a tests in T26451, but it was hard to do so. - - - - - b253013e by Georgios Karachalias at 2025-11-07T17:21:57-05:00 Remove the `CoreBindings` constructor from `LinkablePart` Adjust HscRecompStatus to disallow unhydrated WholeCoreBindings from being passed as input to getLinkDeps (which would previously panic in this case). Fixes #26497 - - - - - ac7b737e by Sylvain Henry at 2025-11-07T17:22:51-05:00 Testsuite: pass ext-interp test way (#26552) Note that some tests are still marked as broken with the ext-interp way (see #26552 and #14335) - - - - - 3c2f4bb4 by sheaf at 2025-11-11T11:47:28-05:00 Preserve user-written kinds in data declarations This commit ensures that we preserve the user-written kind for data declarations, e.g. in type T2T = Type -> Type type D :: T2T data D a where { .. } that we preserve the user-written kind of D as 'T2T', instead of expanding the type synonym 'T2T' during kind checking. We do this by storing 'tyConKind' separately from 'tyConResKind'. This means that 'tyConKind' is not necessarily equal to 'mkTyConKind binders res_kind', as e.g. in the above example the former is 'T2T' while the latter is 'Type -> Type'. This is explained in Note [Preserve user-written TyCon kind] in GHC.Core.TyCon. This is particularly important for Haddock, as the kinds stored in interface files affect the generated documentation, and we want to preserve the user-written types as much as possible. - - - - - 19859584 by sheaf at 2025-11-11T11:47:28-05:00 Store user-written datacon tvs in interface files This commit ensures we store the user-written quantified type variables of data constructors in interface files, e.g. in data D a where MkD1 :: forall x. x -> D x MkD2 :: forall u v. u -> v -> D v The previous behaviour was to rename the universal variables to match the universal variables of the data constructor. This was undesirable because the names that end up in interface files end up mattering for generated Haddock documentation; it's better to preserve the user-written type variables. Moreover, the universal variables may not have been user-written at all, e.g. in an example such as: type T2T = Type -> Type data G :: T2T where MkG :: forall x. D x Here GHC will invent the type variable name 'a' for the first binder of the TyCon G. We really don't want to then rename the user-written 'x' into the generated 'a'. - - - - - 034b2056 by sheaf at 2025-11-11T11:47:28-05:00 DataCon univ_tvs names: pick TyCon over inferred This commit changes how we compute the names of universal type variables in GADT data constructors. This augments the existing logic that chose which type variable name to use, in GHC.Tc.TyCl.mkGADTVars. We continue to prefer DataCon tv names for user-written binders, but we now prefer TyCon tv names for inferred (non-user-written) DataCon binders. This makes a difference in examples such as: type (:~~:) :: k1 -> k2 -> Type data a :~~: b where HRefl :: a :~~: a Before this patch, we ended up giving HRefl the type: forall {k2}. forall (a :: k2). a :~~: a whereas we now give it the type: forall {k1}. forall (a :: k1). a :~~: a The important part isn't really 'k1' or 'k2', but more that the inferred type variable names of the DataCon can be arbitrary/unpredictable (as they are chosen by GHC and depend on how unification proceeds), so it's much better to use the more predictable TyCon type variable names. - - - - - 95078d00 by sheaf at 2025-11-11T11:47:28-05:00 Backpack Rename: use explicit record construction This commit updates the Backpack boilerplate in GHC.Iface.Rename to use explicit record construction rather than record update. This makes sure that the code stays up to date when the underlying constructors change (e.g. new fields are added). The rationale is further explained in Note [Prefer explicit record construction]. - - - - - 2bf36263 by sheaf at 2025-11-11T11:47:28-05:00 Store # eta binders in TyCon and use for Haddock This commit stores the number of TyCon binders that were introduced by eta-expansion (by the function GHC.Tc.Gen.HsType.splitTyConKind). This is then used to pretty-print the TyCon as the user wrote it, e.g. for type Effect :: (Type -> Type) -> Type -> Type data State s :: Effect where {..} -- arity 3 GHC will eta-expand the data declaration to data State s a b where {..} but also store in the 'TyCon' that the number of binders introduced by this eta expansion is 2. This allows us, in 'Haddock.Convert.synifyTyConKindSig', to recover the original user-written syntax, preserving the user's intent in Haddock documentation. See Note [Inline kind signatures with GADTSyntax] in Haddock.Convert. - - - - - 6c91582f by Matthew Pickering at 2025-11-11T11:48:12-05:00 driver: Properly handle errors during LinkNode steps Previously we were not properly catching errors during the LinkNode step (see T9930fail test). This is fixed by wrapping the `LinkNode` action in `wrapAction`, the same handler which is used for module compilation. Fixes #26496 - - - - - e1e1eb32 by Matthew Pickering at 2025-11-11T11:48:54-05:00 driver: Remove unecessary call to hscInsertHPT This call was left-over from e9445c013fbccf9318739ca3d095a3e0a2e1be8a If you follow the functions which call `upsweep_mod`, they immediately add the interface to the HomePackageTable when `upsweep_mod` returns. - - - - - b22777d4 by ARATA Mizuki at 2025-11-11T11:49:44-05:00 LLVM backend: Pass the +evex512 attribute to LLVM 18+ if -mavx512f is set The newer LLVM requires the +evex512 attribute to enable use of ZMM registers. LLVM exhibits a backward-compatible behavior if the cpu is `x86-64`, but not if `penryn`. Therefore, on macOS, where the cpu is set to `penryn`, we need to explicitly pass +evex512. Fixes #26410 - - - - - 6ead7d06 by Vladislav Zavialov at 2025-11-11T11:50:26-05:00 Comments only in GHC.Parser.PostProcess.Haddock Remove outdated Note [Register keyword location], as the issue it describes was addressed by commit 05eb50dff2fcc78d025e77b9418ddb369db49b9f. - - - - - 43fa8be8 by sheaf at 2025-11-11T11:51:18-05:00 localRegistersConflict: account for assignment LHS This commit fixes a serious oversight in GHC.Cmm.Sink.conflicts, specifically the code that computes which local registers conflict between an assignment and a Cmm statement. If we have: assignment: <local_reg> = <expr> node: <local_reg> = <other_expr> then clearly the two conflict, because we cannot move one statement past the other, as they assign two different values to the same local register. (Recall that 'conflicts (local_reg,expr) node' is False if and only if the assignment 'local_reg = expr' can be safely commuted past the statement 'node'.) The fix is to update 'GHC.Cmm.Sink.localRegistersConflict' to take into account the following two situations: (1) 'node' defines the LHS local register of the assignment, (2) 'node' defines a local register used in the RHS of the assignment. The bug is precisely that we were previously missing condition (1). Fixes #26550 - - - - - 79dfcfe0 by sheaf at 2025-11-11T11:51:18-05:00 Update assigned register format when spilling When we come to spilling a register to put new data into it, in GHC.CmmToAsm.Reg.Linear.allocRegsAndSpill_spill, we need to: 1. Spill the data currently in the register. That is, do a spill with a format that matches what's currently in the register. 2. Update the register assignment, allocating a virtual register to this real register, but crucially **updating the format** of this assignment. Due to shadowing in the Haskell code for allocRegsAndSpill_spill, we were mistakenly re-using the old format. This could lead to a situation where: a. We were using xmm6 to store a Double#. b. We want to store a DoubleX2# into xmm6, so we spill the current content of xmm6 to the stack using a scalar move (correct). c. We update the register assignment, but we fail to update the format of the assignment, so we continue to think that xmm6 stores a Double# and not a DoubleX2#. d. Later on, we need to spill xmm6 because it is getting clobbered by another instruction. We then decide to only spill the lower 64 bits of the register, because we still think that xmm6 only stores a Double# and not a DoubleX2#. Fixes #26542 - - - - - aada5db9 by ARATA Mizuki at 2025-11-11T11:52:07-05:00 Fix the order of spill/reload instructions The AArch64 NCG could emit multiple instructions for a single spill/reload, but their order was not consistent between the definition and a use. Fixes #26537 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - 64ec82ff by Andreas Klebinger at 2025-11-11T11:52:48-05:00 Add hpc to release script - - - - - 741da00c by Ben Gamari at 2025-11-12T03:38:20-05:00 template-haskell: Better describe getQ semantics Clarify that the state is a type-indexed map, as suggested by #26484. - - - - - 8b080e04 by ARATA Mizuki at 2025-11-12T03:39:11-05:00 Fix incorrect markups in the User's Guide * Correct markup for C--: "C-\-" in reST * Fix internal links * Fix code highlighting * Fix inline code: Use ``code`` rather than `code` * Remove extra backslashes Fixes #16812 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - a00840ea by Simon Peyton Jones at 2025-11-14T15:23:56+00:00 Make TYPE and CONSTRAINT apart again This patch finally fixes #24279. * The story started with #11715 * Then #21623 articulated a plan, which made Type and Constraint not-apart; a horrible hack but it worked. The main patch was commit 778c6adca2c995cd8a1b84394d4d5ca26b915dac Author: Simon Peyton Jones <simonpj(a)microsoft.com> Date: Wed Nov 9 10:33:22 2022 +0000 Type vs Constraint: finally nailed * #24279 reported a bug in the above big commit; this small patch fixes it commit af6932d6c068361c6ae300d52e72fbe13f8e1f18 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Mon Jan 8 10:49:49 2024 +0000 Make TYPE and CONSTRAINT not-apart Issue #24279 showed up a bug in the logic in GHC.Core.Unify.unify_ty which is supposed to make TYPE and CONSTRAINT be not-apart. * Then !10479 implemented "unary classes". * That change in turn allows us to make Type and Constraint apart again, cleaning up the compiler and allowing a little bit more expressiveness. It fixes the original hope in #24279, namely that `Type` and `Constraint` should be distinct throughout. - - - - - c0a1e574 by Georgios Karachalias at 2025-11-15T05:14:31-05:00 Report all missing modules with -M We now report all missing modules at once in GHC.Driver.Makefile.processDeps, as opposed to only reporting a single missing module. Fixes #26551. - - - - - c9fa3449 by Sylvain Henry at 2025-11-15T05:15:26-05:00 JS: fix array index for registers We used to store R32 in h$regs[-1]. While it's correct in JavaScript, fix this to store R32 in h$regs[0] instead. - - - - - 9e469909 by Sylvain Henry at 2025-11-15T05:15:26-05:00 JS: support more than 128 registers (#26558) The JS backend only supported 128 registers (JS variables/array slots used to pass function arguments). It failed in T26537 when 129 registers were required. This commit adds support for more than 128 registers: it is now limited to maxBound :: Int (compiler's Int). If we ever go above this threshold the compiler now panics with a more descriptive message. A few built-in JS functions were assuming 128 registers and have been rewritten to use loops. Note that loops are only used for "high" registers that are stored in an array: the 31 "low" registers are still handled with JS global variables and with explicit switch-cases to maintain good performance in the most common cases (i.e. few registers used). Adjusting the number of low registers is now easy: just one constant to adjust (GHC.StgToJS.Regs.lowRegsCount). No new test added: T26537 is used as a regression test instead. - - - - - 0a64a78b by Sven Tennie at 2025-11-15T20:31:10-05:00 AArch64: Simplify CmmAssign and CmmStore The special handling for floats was fake: The general case is always used. So, the additional code path isn't needed (and only adds complexity for the reader.) - - - - - 15b311be by sheaf at 2025-11-15T20:32:02-05:00 SimpleOpt: refactor & push coercions into lambdas This commit improves the simple optimiser (in GHC.Core.SimpleOpt) in a couple of ways: - The logic to push coercion lambdas is shored up. The function 'pushCoercionIntoLambda' used to be called in 'finish_app', but this meant we could not continue to optimise the program after performing this transformation. Now, we call 'pushCoercionIntoLambda' as part of 'simple_app'. Doing so can be important when dealing with unlifted newtypes, as explained in Note [Desugaring unlifted newtypes]. - The code is re-structured to avoid duplication and out-of-sync code paths. Now, 'simple_opt_expr' defers to 'simple_app' for the 'App', 'Var', 'Cast' and 'Lam' cases. This means all the logic for those is centralised in a single place (e.g. the 'go_lam' helper function). To do this, the general structure is brought a bit closer to the full-blown simplifier, with a notion of 'continuation' (see 'SimpleContItem'). This commit also modifies GHC.Core.Opt.Arity.pushCoercionIntoLambda to apply a substitution (a slight generalisation of its existing implementation). - - - - - b33284c7 by sheaf at 2025-11-15T20:32:02-05:00 Improve typechecking of data constructors This commit changes the way in which we perform typecheck data constructors, in particular how we make multiplicities line up. Now, impedance matching occurs as part of the existing subsumption machinery. See the revamped Note [Typechecking data constructors] in GHC.Tc.Gen.App, as well as Note [Polymorphisation of linear fields] in GHC.Core.Multiplicity. This allows us to get rid of a fair amount of hacky code that was added with the introduction of LinearTypes; in particular the logic of GHC.Tc.Gen.Head.tcInferDataCon. ------------------------- Metric Decrease: T10421 T14766 T15164 T15703 T19695 T5642 T9630 WWRec ------------------------- - - - - - b6faf5d0 by sheaf at 2025-11-15T20:32:02-05:00 Handle unsaturated rep-poly newtypes This commit allows GHC to handle unsaturated occurrences of unlifted newtype constructors. The plan is detailed in Note [Eta-expanding rep-poly unlifted newtypes] in GHC.Tc.Utils.Concrete: for unsaturated unlifted newtypes, we perform the appropriate representation-polymorphism check in tcInstFun. - - - - - 682bf979 by Mike Pilgrem at 2025-11-16T16:44:14+00:00 Fix #26293 Valid stack.yaml for hadrian - - - - - acc70c3a by Simon Peyton Jones at 2025-11-18T16:21:20-05:00 Fix a bug in defaulting Addresses #26582 Defaulting was doing some unification but then failing to iterate. Silly. I discovered that the main solver was unnecessarily iterating even if there was a unification for an /outer/ unification variable, so I fixed that too. - - - - - c12fa73e by Simon Peyton Jones at 2025-11-19T02:55:01-05:00 Make PmLit be in Ord, and use it in Map This MR addresses #26514, by changing from data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit] to data PmAltConSet = PACS !(UniqDSet ConLike) !(Map PmLit PmLit) This matters when doing pattern-match overlap checking, when there is a very large set of patterns. For most programs it makes no difference at all. For the N=5000 case of the repro case in #26514, compiler mutator time (with `-fno-code`) goes from 1.9s to 0.43s. All for the price for an Ord instance for PmLit - - - - - 41b84f40 by sheaf at 2025-11-19T02:55:52-05:00 Add passing tests for #26311 and #26072 This commit adds two tests cases that now pass since landing the changes to typechecking of data constructors in b33284c7. Fixes #26072 #26311 - - - - - 1faa758a by sheaf at 2025-11-19T02:55:52-05:00 mkCast: weaken bad cast warning for multiplicity This commit weakens the warning message emitted when constructing a bad cast in mkCast to ignore multiplicity. Justification: since b33284c7, GHC uses sub-multiplicity coercions to typecheck data constructors. The coercion optimiser is free to discard these coercions, both for performance reasons, and because GHC's Core simplifier does not (yet) preserve linearity. We thus weaken 'mkCast' to use 'eqTypeIgnoringMultiplicity' instead of 'eqType', to avoid getting many spurious warnings about mismatched multiplicities. - - - - - 7ec4323e by Vladislav Zavialov at 2025-11-19T23:25:55+03:00 Namespace-specified wildcards in import/export lists (#25901) This change adds support for top-level namespace-specified wildcards `type ..` and `data ..` to import and export lists. Examples: import M (type ..) -- imports all type and class constructors from M import M (data ..) -- imports all data constructors and terms from M module M (type .., f) where -- exports all type and class constructors defined in M, -- plus the function 'f' The primary intended usage of this feature is in combination with module aliases, allowing namespace disambiguation: import Data.Proxy as T (type ..) -- T.Proxy is unambiguously the type constructor import Data.Proxy as D (data ..) -- D.Proxy is unambiguously the data constructor The patch accounts for the interactions of wildcards with: * Imports with `hiding` clauses * Import warnings -Wunused-imports, -Wdodgy-imports * Export warnings -Wduplicate-exports, -Wdodgy-exports Summary of the changes: 1. Move the NamespaceSpecifier type from GHC.Hs.Binds to GHC.Hs.Basic, making it possible to use it in more places in the AST. 2. Extend the AST (type: IE) with a representation of `..`, `type ..`, and `data ..` (constructor: IEWholeNamespace). Per the proposal, the plain `..` is always rejected with a dedicated error message. 3. Extend the grammar in Parser.y with productions for `..`, `type ..`, and `data ..` in both import and export lists. 4. Implement wildcard imports by updating the `filterImports` function in GHC.Rename.Names; the logic for IEWholeNamespace is roughly modeled after the Nothing (no explicit import list) case. 5. Implement wildcard exports by updating the `exports_from_avail` function in GHC.Tc.Gen.Export; the logic for IEWholeNamespace is closely modeled after the IEModuleContents case. 6. Refactor and extend diagnostics to report the new warnings and errors. See PsErrPlainWildcardImport, DodgyImportsWildcard, PsErrPlainWildcardExport, DodgyExportsWildcard, TcRnDupeWildcardExport. Note that this patch is specifically about top-level import/export items. Subordinate import/export items are left unchanged. - - - - - 394 changed files: - .gitlab/rel_eng/upload_ghc_libs.py - cabal.project-reinstall - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Types/Literals.hs - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Cmm/Sink.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Multiplicity.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CallArity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/RoughMap.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Hs/Basic.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Decl.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToJS/Apply.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Regs.hs - compiler/GHC/StgToJS/Rts/Rts.hs - compiler/GHC/StgToJS/Rts/Types.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/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/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - + compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Irred.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Solver/Solve.hs-boot - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Concrete.hs - 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/Unify.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/SourceText.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Unit/Home/ModInfo.hs - compiler/GHC/Unit/Module/Status.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs - + compiler/GHC/Utils/EndoOS.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Setup.hs - compiler/ghc.cabal.in - docs/users_guide/9.16.1-notes.rst - docs/users_guide/bugs.rst - docs/users_guide/compare-flags.py - docs/users_guide/debug-info.rst - docs/users_guide/debugging.rst - docs/users_guide/extending_ghc.rst - docs/users_guide/exts/arrows.rst - docs/users_guide/exts/derive_any_class.rst - docs/users_guide/exts/deriving_extra.rst - docs/users_guide/exts/deriving_inferred.rst - docs/users_guide/exts/deriving_strategies.rst - docs/users_guide/exts/explicit_namespaces.rst - docs/users_guide/exts/gadt.rst - docs/users_guide/exts/generics.rst - docs/users_guide/exts/overloaded_labels.rst - docs/users_guide/exts/overloaded_strings.rst - docs/users_guide/exts/pattern_synonyms.rst - docs/users_guide/exts/poly_kinds.rst - docs/users_guide/exts/primitives.rst - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/rebindable_syntax.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/exts/scoped_type_variables.rst - docs/users_guide/exts/standalone_deriving.rst - docs/users_guide/exts/template_haskell.rst - docs/users_guide/exts/tuple_sections.rst - docs/users_guide/exts/type_data.rst - docs/users_guide/exts/type_defaulting.rst - docs/users_guide/gone_wrong.rst - docs/users_guide/hints.rst - docs/users_guide/javascript.rst - docs/users_guide/phases.rst - docs/users_guide/profiling.rst - docs/users_guide/separate_compilation.rst - docs/users_guide/using.rst - docs/users_guide/wasm.rst - docs/users_guide/win32-dlls.rst - hadrian/stack.yaml - hadrian/stack.yaml.lock - libraries/base/tests/all.T - libraries/ghc-boot/Setup.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/os-string - libraries/unix - rts/Interpreter.c - rts/ThreadPaused.c - rts/eventlog/EventLog.c - rts/gen_event_types.py - rts/include/rts/Bytecodes.h - testsuite/driver/runtests.py - testsuite/driver/testlib.py - testsuite/tests/backpack/should_fail/T19244a.stderr - + testsuite/tests/codeGen/should_run/T26537.hs - + testsuite/tests/codeGen/should_run/T26537.stdout - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/default/default-fail05.stderr - testsuite/tests/dependent/should_fail/T11334b.stderr - testsuite/tests/dependent/should_fail/T13135_simple.stderr - testsuite/tests/deriving/should_fail/T3621.stderr - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/Makefile - testsuite/tests/driver/T20696/all.T - + testsuite/tests/driver/T24120.hs - + testsuite/tests/driver/T26551.hs - + testsuite/tests/driver/T26551.stderr - testsuite/tests/driver/all.T - testsuite/tests/driver/fat-iface/all.T - testsuite/tests/generics/T10604/T10604_deriving.stderr - testsuite/tests/ghc-e/should_fail/T9930fail.stderr - testsuite/tests/ghc-e/should_fail/all.T - testsuite/tests/ghci.debugger/scripts/print012.stdout - testsuite/tests/ghci/scripts/T10321.stdout - testsuite/tests/ghci/scripts/T24459.stdout - testsuite/tests/ghci/scripts/T7730.stdout - testsuite/tests/ghci/scripts/T8959b.stderr - testsuite/tests/ghci/scripts/ghci051.stderr - testsuite/tests/ghci/scripts/ghci065.stdout - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/indexed-types/should_compile/T12538.stderr - testsuite/tests/indexed-types/should_fail/T14369.stderr - testsuite/tests/indexed-types/should_fail/T1897b.stderr - testsuite/tests/indexed-types/should_fail/T21092.hs - − testsuite/tests/indexed-types/should_fail/T21092.stderr - testsuite/tests/indexed-types/should_fail/all.T - 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/linear/should_compile/LinearEtaExpansions.hs - testsuite/tests/linear/should_compile/all.T - testsuite/tests/linear/should_fail/TypeClass.hs - testsuite/tests/linear/should_fail/TypeClass.stderr - testsuite/tests/linear/should_run/LinearGhci.stdout - + testsuite/tests/linear/should_run/T26311.hs - + testsuite/tests/linear/should_run/T26311.stdout - testsuite/tests/linear/should_run/all.T - testsuite/tests/linters/notes.stdout - + testsuite/tests/module/T25901_exp_plain_wc.hs - + testsuite/tests/module/T25901_exp_plain_wc.stderr - + testsuite/tests/module/T25901_imp_plain_wc.hs - + testsuite/tests/module/T25901_imp_plain_wc.stderr - testsuite/tests/module/all.T - testsuite/tests/numeric/should_compile/T16402.stderr-ws-64 - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr - testsuite/tests/parser/should_fail/T20654a.stderr - testsuite/tests/partial-sigs/should_fail/T14584a.stderr - testsuite/tests/perf/compiler/all.T - testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr - testsuite/tests/polykinds/T6068.stdout - testsuite/tests/quantified-constraints/T15359.hs - + testsuite/tests/rename/should_compile/T25901_exp_1.hs - + testsuite/tests/rename/should_compile/T25901_exp_1_helper.hs - + testsuite/tests/rename/should_compile/T25901_exp_2.hs - + testsuite/tests/rename/should_compile/T25901_exp_2_helper.hs - + testsuite/tests/rename/should_compile/T25901_imp_hq.hs - + testsuite/tests/rename/should_compile/T25901_imp_hu.hs - + testsuite/tests/rename/should_compile/T25901_imp_sq.hs - + testsuite/tests/rename/should_compile/T25901_imp_su.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T25901_exp_fail_1.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_1.stderr - + testsuite/tests/rename/should_fail/T25901_exp_fail_1_helper.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_2.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_2.stderr - + testsuite/tests/rename/should_fail/T25901_exp_fail_2_helper.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.stderr - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.stderr - + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.hs - + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.stderr - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.hs - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.stderr - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.hs - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.stderr - + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.hs - + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/rename/should_fail/rnfail055.stderr - testsuite/tests/rep-poly/RepPolyCase1.stderr - − testsuite/tests/rep-poly/RepPolyCase2.stderr - testsuite/tests/rep-poly/RepPolyNPlusK.stderr - testsuite/tests/rep-poly/RepPolyRightSection.stderr - testsuite/tests/rep-poly/RepPolyRule3.stderr - testsuite/tests/rep-poly/RepPolyTuple4.stderr - testsuite/tests/rep-poly/T13233.stderr - − testsuite/tests/rep-poly/T17021.stderr - testsuite/tests/rep-poly/T19709b.stderr - testsuite/tests/rep-poly/T20363b.stderr - − testsuite/tests/rep-poly/T21650_a.stderr - − testsuite/tests/rep-poly/T21650_b.stderr - testsuite/tests/rep-poly/T23903.stderr - + testsuite/tests/rep-poly/T26072.hs - + testsuite/tests/rep-poly/T26072b.hs - + testsuite/tests/rep-poly/T26528.hs - testsuite/tests/rep-poly/UnliftedNewtypesLevityBinder.stderr - testsuite/tests/rep-poly/all.T - testsuite/tests/saks/should_compile/saks023.stdout - testsuite/tests/saks/should_compile/saks034.stdout - testsuite/tests/saks/should_compile/saks035.stdout - testsuite/tests/showIface/Makefile - + testsuite/tests/showIface/T26246a.hs - + testsuite/tests/showIface/T26246a.stdout - testsuite/tests/showIface/all.T - + testsuite/tests/simd/should_run/T26410_ffi.hs - + testsuite/tests/simd/should_run/T26410_ffi.stdout - + testsuite/tests/simd/should_run/T26410_ffi_c.c - + testsuite/tests/simd/should_run/T26410_prim.hs - + testsuite/tests/simd/should_run/T26410_prim.stdout - + testsuite/tests/simd/should_run/T26542.hs - + testsuite/tests/simd/should_run/T26542.stdout - + testsuite/tests/simd/should_run/T26550.hs - + testsuite/tests/simd/should_run/T26550.stdout - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simplCore/should_compile/T26349.hs - + testsuite/tests/simplCore/should_compile/T26349.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/simplCore/should_compile/rule2.stderr - testsuite/tests/splice-imports/all.T - testsuite/tests/typecheck/T16127/T16127.stderr - testsuite/tests/typecheck/no_skolem_info/T13499.stderr - testsuite/tests/typecheck/should_compile/T13651.hs - − testsuite/tests/typecheck/should_compile/T13651.stderr - + testsuite/tests/typecheck/should_compile/T14745.hs - testsuite/tests/typecheck/should_compile/T22560d.stdout - + testsuite/tests/typecheck/should_compile/T26451.hs - + testsuite/tests/typecheck/should_compile/T26582.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr - testsuite/tests/typecheck/should_compile/tc126.hs - testsuite/tests/typecheck/should_fail/AmbigFDs.hs - − testsuite/tests/typecheck/should_fail/AmbigFDs.stderr - testsuite/tests/typecheck/should_fail/FD3.stderr - testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr - testsuite/tests/typecheck/should_fail/T13506.stderr - testsuite/tests/typecheck/should_fail/T15629.stderr - testsuite/tests/typecheck/should_fail/T15883e.stderr - testsuite/tests/typecheck/should_fail/T16512a.stderr - testsuite/tests/typecheck/should_fail/T18851b.hs - − testsuite/tests/typecheck/should_fail/T18851b.stderr - testsuite/tests/typecheck/should_fail/T18851c.hs - − testsuite/tests/typecheck/should_fail/T18851c.stderr - testsuite/tests/typecheck/should_fail/T19415.stderr - testsuite/tests/typecheck/should_fail/T19415b.stderr - testsuite/tests/typecheck/should_fail/T22684.stderr - + testsuite/tests/typecheck/should_fail/T23162a.hs - + testsuite/tests/typecheck/should_fail/T23162a.stderr - testsuite/tests/typecheck/should_fail/T2414.stderr - testsuite/tests/typecheck/should_fail/T24279.hs - − testsuite/tests/typecheck/should_fail/T24279.stderr - testsuite/tests/typecheck/should_fail/T25325.stderr - testsuite/tests/typecheck/should_fail/T2534.stderr - testsuite/tests/typecheck/should_fail/T5246.stderr - testsuite/tests/typecheck/should_fail/T5978.stderr - testsuite/tests/typecheck/should_fail/T7264.stderr - testsuite/tests/typecheck/should_fail/T7368a.stderr - testsuite/tests/typecheck/should_fail/T7696.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail122.stderr - testsuite/tests/typecheck/should_fail/tcfail143.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.stderr - + testsuite/tests/warnings/should_compile/T25901_helper_1.hs - + testsuite/tests/warnings/should_compile/T25901_helper_2.hs - + testsuite/tests/warnings/should_compile/T25901_helper_3.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.stderr - testsuite/tests/warnings/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/genprimopcode/genprimopcode.cabal - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug1050.html - + utils/haddock/html-test/ref/Bug26246.html - utils/haddock/html-test/ref/Bug85.html - utils/haddock/html-test/ref/Bug923.html - utils/haddock/html-test/ref/BundledPatterns.html - utils/haddock/html-test/ref/BundledPatterns2.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/GADTRecords.html - utils/haddock/html-test/ref/LinearTypes.html - utils/haddock/html-test/ref/PromotedTypes.html - + utils/haddock/html-test/src/Bug26246.hs - utils/haddock/hypsrc-test/ref/src/Classes.html - utils/haddock/hypsrc-test/ref/src/Quasiquoter.html - utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ec16c993461ebc67951f35c107008… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ec16c993461ebc67951f35c107008… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Build external interpreter program on demand (#24731)
by Marge Bot (＠marge-bot) 19 Nov '25

19 Nov '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 7c221f74 by Sylvain Henry at 2025-11-19T13:46:51-05:00 Build external interpreter program on demand (#24731) This patch teaches GHC how to build the external interpreter program when it is missing. As long as we have the `ghci` library, doing this is trivial so most of this patch is refactoring for doing it sanely. - - - - - 50dfc3a0 by Rodrigo Mesquita at 2025-11-19T13:46:52-05:00 Add tests for #23973 and #26565 These were fixed by 4af4f0f070f83f948e49ad5d7835fd91b8d3f0e6 in !10417 - - - - - 28 changed files: - compiler/GHC.hs - + compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/Config/Linker.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Linker/Config.hs - compiler/GHC/Linker/Dynamic.hs - + compiler/GHC/Linker/Executable.hs - − compiler/GHC/Linker/ExtraObj.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/MacOS.hs - compiler/GHC/Linker/Static.hs - compiler/GHC/Linker/Windows.hs - + compiler/GHC/Runtime/Interpreter/C.hs - + compiler/GHC/Runtime/Interpreter/Init.hs - compiler/GHC/SysTools/Tasks.hs - compiler/ghc.cabal.in - + testsuite/tests/bytecode/T23973.hs - + testsuite/tests/bytecode/T23973.script - + testsuite/tests/bytecode/T23973.stdout - + testsuite/tests/bytecode/T26565.hs - + testsuite/tests/bytecode/T26565.script - + testsuite/tests/bytecode/T26565.stdout - testsuite/tests/bytecode/all.T - + testsuite/tests/driver/T24731.hs - testsuite/tests/driver/all.T - utils/iserv/iserv.cabal.in Changes: ===================================== compiler/GHC.hs ===================================== @@ -337,7 +337,6 @@ module GHC ( import GHC.Prelude hiding (init) import GHC.Platform -import GHC.Platform.Ways import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename , isSourceFilename, startPhase ) @@ -351,7 +350,6 @@ import GHC.Driver.Backend import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.StgToJS (initStgToJSConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Main import GHC.Driver.Make @@ -360,10 +358,11 @@ import GHC.Driver.Monad import GHC.Driver.Ppr import GHC.ByteCode.Types -import qualified GHC.Linker.Loader as Loader import GHC.Runtime.Loader import GHC.Runtime.Eval import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Init +import GHC.Driver.Config.Interpreter import GHC.Runtime.Context import GHCi.RemoteTypes @@ -439,10 +438,8 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo import qualified GHC.Unit.Home.Graph as HUG -import GHC.Settings import Control.Applicative ((<|>)) -import Control.Concurrent import Control.Monad import Control.Monad.Catch as MC import Data.Foldable @@ -715,98 +712,16 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m () setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger - lookup_cache <- liftIO $ mkInterpSymbolCache - - -- see Note [Target code interpreter] - interp <- if -#if !defined(wasm32_HOST_ARCH) - -- Wasm dynamic linker - | ArchWasm32 <- platformArch $ targetPlatform dflags - -> do - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - dyld <- liftIO $ makeAbsolute $ topDir dflags </> "dyld.mjs" - libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger dflags "libraries" - let profiled = ways dflags `hasWay` WayProf - way_tag = if profiled then "_p" else "" - let cfg = - WasmInterpConfig - { wasmInterpDyLD = dyld, - wasmInterpLibDir = libdir, - wasmInterpOpts = getOpts dflags opt_i, - wasmInterpBrowser = gopt Opt_GhciBrowser dflags, - wasmInterpBrowserHost = ghciBrowserHost dflags, - wasmInterpBrowserPort = ghciBrowserPort dflags, - wasmInterpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags, - wasmInterpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags, - wasmInterpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags, - wasmInterpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags, - wasmInterpTargetPlatform = targetPlatform dflags, - wasmInterpProfiled = profiled, - wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags), - wasmInterpUnitState = ue_homeUnitState $ hsc_unit_env hsc_env - } - pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache -#endif - - -- JavaScript interpreter - | ArchJavaScript <- platformArch (targetPlatform dflags) - -> do - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - let cfg = JSInterpConfig - { jsInterpNodeConfig = defaultNodeJsSettings - , jsInterpScript = topDir dflags </> "ghc-interp.js" - , jsInterpTmpFs = hsc_tmpfs hsc_env - , jsInterpTmpDir = tmpDir dflags - , jsInterpLogger = hsc_logger hsc_env - , jsInterpCodegenCfg = initStgToJSConfig dflags - , jsInterpUnitEnv = hsc_unit_env hsc_env - , jsInterpFinderOpts = initFinderOpts dflags - , jsInterpFinderCache = hsc_FC hsc_env - } - return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) - - -- external interpreter - | gopt Opt_ExternalInterpreter dflags - -> do - let - prog = pgm_i dflags ++ flavour - profiled = ways dflags `hasWay` WayProf - dynamic = ways dflags `hasWay` WayDyn - flavour - | profiled && dynamic = "-prof-dyn" - | profiled = "-prof" - | dynamic = "-dyn" - | otherwise = "" - msg = text "Starting " <> text prog - tr <- if verbosity dflags >= 3 - then return (logInfo logger $ withPprStyle defaultDumpStyle msg) - else return (pure ()) - let - conf = IServConfig - { iservConfProgram = prog - , iservConfOpts = getOpts dflags opt_i - , iservConfProfiled = profiled - , iservConfDynamic = dynamic - , iservConfHook = createIservProcessHook (hsc_hooks hsc_env) - , iservConfTrace = tr - } - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) - - -- Internal interpreter - | otherwise - -> -#if defined(HAVE_INTERNAL_INTERPRETER) - do - loader <- liftIO Loader.uninitializedLoader - return (Just (Interp InternalInterp loader lookup_cache)) -#else - return Nothing -#endif - + let platform = targetPlatform dflags + let unit_env = hsc_unit_env hsc_env + let tmpfs = hsc_tmpfs hsc_env + let finder_cache = hsc_FC hsc_env + interp_opts' <- liftIO $ initInterpOpts dflags + let interp_opts = interp_opts' + { interpCreateProcess = createIservProcessHook (hsc_hooks hsc_env) + } + + interp <- liftIO $ initInterpreter tmpfs logger platform finder_cache unit_env interp_opts modifySession $ \h -> hscSetFlags dflags h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -0,0 +1,46 @@ +module GHC.Driver.Config.Interpreter + ( initInterpOpts + ) +where + +import GHC.Prelude +import GHC.Runtime.Interpreter.Init +import GHC.Driver.DynFlags +import GHC.Driver.Session +import GHC.Driver.Config.Finder +import GHC.Driver.Config.StgToJS +import GHC.SysTools.Tasks +import GHC.Linker.Executable + +import System.FilePath +import System.Directory + +initInterpOpts :: DynFlags -> IO InterpOpts +initInterpOpts dflags = do + wasm_dyld <- makeAbsolute $ topDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ topDir dflags </> "ghc-interp.js" + pure $ InterpOpts + { interpExternal = gopt Opt_ExternalInterpreter dflags + , interpProg = pgm_i dflags + , interpOpts = getOpts dflags opt_i + , interpWays = ways dflags + , interpNameVer = ghcNameVersion dflags + , interpCreateProcess = Nothing + , interpWasmDyld = wasm_dyld + , interpBrowser = gopt Opt_GhciBrowser dflags + , interpBrowserHost = ghciBrowserHost dflags + , interpBrowserPort = ghciBrowserPort dflags + , interpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags + , interpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags + , interpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags + , interpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags + , interpJsInterp = js_interp + , interpTmpDir = tmpDir dflags + , interpJsCodegenCfg = initStgToJSConfig dflags + , interpFinderOpts = initFinderOpts dflags + , interpVerbosity = verbosity dflags + , interpLdConfig = configureLd dflags + , interpCcConfig = configureCc dflags + , interpExecutableLinkOpts = initExecutableLinkOpts dflags + } + ===================================== compiler/GHC/Driver/Config/Linker.hs ===================================== @@ -10,6 +10,7 @@ import GHC.Linker.Config import GHC.Driver.DynFlags import GHC.Driver.Session +import GHC.Settings import Data.List (isPrefixOf) @@ -52,6 +53,8 @@ initLinkerConfig dflags = , linkerOptionsPost = post_args , linkerTempDir = tmpDir dflags , linkerFilter = ld_filter + , linkerSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind (toolSettings dflags) + , linkerIsGnuLd = toolSettings_ldIsGnuLd (toolSettings dflags) } {- Note [Solaris linker] ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Driver.DynFlags ( ParMakeCount(..), ways, HasDynFlags(..), ContainsDynFlags(..), - RtsOptsEnabled(..), + RtsOptsEnabled(..), haveRtsOptsFlags, GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), PackageArg(..), ModRenaming(..), @@ -902,6 +902,13 @@ data RtsOptsEnabled | RtsOptsAll deriving (Show) +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True + + -- | Are we building with @-fPIE@ or @-fPIC@ enabled? positionIndependent :: DynFlags -> Bool positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -71,7 +71,7 @@ import GHC.SysTools import GHC.SysTools.Cpp import GHC.Utils.TmpFs -import GHC.Linker.ExtraObj +import GHC.Linker.Executable import GHC.Linker.Static import GHC.Linker.Static.Utils import GHC.Linker.Types @@ -444,7 +444,9 @@ link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt case ghcLink dflags of LinkBinary | backendUseJSLinker (backend dflags) -> linkJSBinary logger tmpfs fc dflags unit_env obj_files pkg_deps - | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps + | otherwise -> do + let opts = initExecutableLinkOpts dflags + linkExecutable logger tmpfs opts unit_env obj_files pkg_deps LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps other -> panicBadLink other @@ -511,7 +513,8 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do if not (null lib_errs) || any (t <) lib_times then return $ needsRecompileBecause LibraryChanged else do - res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file + let opts = initExecutableLinkOpts dflags + res <- checkLinkInfo logger opts unit_env pkg_deps exe_file if res then return $ needsRecompileBecause FlagsChanged else return UpToDate @@ -585,7 +588,9 @@ doLink hsc_env o_files = do LinkBinary | backendUseJSLinker (backend dflags) -> linkJSBinary logger tmpfs fc dflags unit_env o_files [] - | otherwise -> linkBinary logger tmpfs dflags unit_env o_files [] + | otherwise -> do + let opts = initExecutableLinkOpts dflags + linkExecutable logger tmpfs opts unit_env o_files [] LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] LinkMergedObj ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -15,6 +15,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch import GHC.Driver.Hooks +import GHC.Driver.DynFlags import Control.Monad.Trans.Reader import GHC.Driver.Pipeline.Monad import GHC.Driver.Pipeline.Phases @@ -74,7 +75,6 @@ import GHC.CmmToLlvm.Version.Type (LlvmVersion (..)) import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) import GHC.Settings import System.IO -import GHC.Linker.ExtraObj import GHC.Linker.Dynamic import GHC.Utils.Panic import GHC.Utils.Touch @@ -416,6 +416,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do let unit_env = hsc_unit_env hsc_env let home_unit = hsc_home_unit_maybe hsc_env let tmpfs = hsc_tmpfs hsc_env + let tmpdir = tmpDir dflags let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc @@ -437,7 +438,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do let include_paths = include_paths_quote ++ include_paths_global let gcc_extra_viac_flags = extraGccViaCFlags dflags - let pic_c_flags = picCCOpts dflags + let cc_config = configureCc dflags let verbFlags = getVerbFlags dflags @@ -486,14 +487,14 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env withAtomicRename output_fn $ \temp_outputFilename -> - GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( + GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs tmpdir cc_config ( [ GHC.SysTools.Option "-c" , GHC.SysTools.FileOption "" input_fn , GHC.SysTools.Option "-o" , GHC.SysTools.FileOption "" temp_outputFilename ] ++ map GHC.SysTools.Option ( - pic_c_flags + (ccPicOpts cc_config) -- See Note [Produce big objects on Windows] ++ [ "-Wa,-mbig-obj" @@ -1149,7 +1150,8 @@ joinObjectFiles hsc_env o_files output_fn | otherwise = do withAtomicRename output_fn $ \tmp_ar -> - liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files + let ar_opts = configureAr dflags + in liftIO $ runAr logger ar_opts Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files where dashLSupported = sArSupportsDashL (settings dflags) dashL = if dashLSupported then "L" else "" ===================================== compiler/GHC/Linker/Config.hs ===================================== @@ -23,5 +23,7 @@ data LinkerConfig = LinkerConfig , linkerOptionsPost :: [Option] -- ^ Linker options (after user options) , linkerTempDir :: TempDir -- ^ Temporary directory to use , linkerFilter :: [String] -> [String] -- ^ Output filter + , linkerSupportsCompactUnwind :: !Bool -- ^ Does the linker support compact unwind + , linkerIsGnuLd :: !Bool -- ^ Is it GNU LD (used for gc-sections support) } ===================================== compiler/GHC/Linker/Dynamic.hs ===================================== @@ -12,6 +12,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule)) +import GHC.SysTools.Tasks import GHC.Driver.Config.Linker import GHC.Driver.Session @@ -207,8 +208,10 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] ) -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 - when (gopt Opt_RPath dflags) $ - runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn + when (gopt Opt_RPath dflags) $ do + let otool_opts = configureOtool dflags + let install_name_opts = configureInstallName dflags + runInjectRPaths logger otool_opts install_name_opts pkg_lib_paths output_fn _ -> do ------------------------------------------------------------------- -- Making a DSO ===================================== compiler/GHC/Linker/Executable.hs ===================================== @@ -0,0 +1,534 @@ +-- | Linking executables +module GHC.Linker.Executable + ( linkExecutable + , ExecutableLinkOpts (..) + , initExecutableLinkOpts + -- RTS Opts + , RtsOptsEnabled (..) + -- * Link info + , LinkInfo (..) + , initLinkInfo + , checkLinkInfo + , ghcLinkInfoSectionName + , ghcLinkInfoNoteName + , platformSupportsSavingLinkOpts + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Unit +import GHC.Unit.Env + +import GHC.Utils.Asm +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import GHC.Driver.Session +import GHC.Driver.Config.Linker + +import qualified GHC.Data.ShortText as ST + +import GHC.SysTools +import GHC.SysTools.Elf +import GHC.Linker.Config +import GHC.Linker.Unit +import GHC.Linker.MacOS +import GHC.Linker.Windows +import GHC.Linker.Dynamic (libmLinkOpts) +import GHC.Linker.External (runLink) +import GHC.Linker.Static.Utils (exeFileName) + +import Control.Monad +import Data.Maybe +import System.FilePath +import System.Directory + +data ExecutableLinkOpts = ExecutableLinkOpts + { leOutputFile :: Maybe FilePath + , leNameVersion :: GhcNameVersion + , leWays :: Ways + , leDynLibLoader :: DynLibLoader + , leRelativeDynlibPaths :: !Bool + , leUseXLinkerRPath :: !Bool + , leSingleLibFolder :: !Bool + , leWholeArchiveHsLibs :: !Bool + , leGenManifest :: !Bool + , leRPath :: !Bool + , leCompactUnwind :: !Bool + , leLibraryPaths :: [String] + , leFrameworkOpts :: FrameworkOpts + , leManifestOpts :: ManifestOpts + , leLinkerConfig :: LinkerConfig + , leOtoolConfig :: OtoolConfig + , leCcConfig :: CcConfig + , leInstallNameConfig :: InstallNameConfig + , leInputs :: [Option] + , lePieOpts :: [String] + , leTempDir :: TempDir + , leVerbFlags :: [String] + , leNoHsMain :: !Bool + , leMainSymbol :: String + , leRtsOptsEnabled :: !RtsOptsEnabled + , leRtsOptsSuggestions :: !Bool + , leKeepCafs :: !Bool + , leRtsOpts :: Maybe String + } + +initExecutableLinkOpts :: DynFlags -> ExecutableLinkOpts +initExecutableLinkOpts dflags = + let + platform = targetPlatform dflags + os = platformOS platform + in ExecutableLinkOpts + { leOutputFile = outputFile_ dflags + , leNameVersion = ghcNameVersion dflags + , leWays = ways dflags + , leDynLibLoader = dynLibLoader dflags + , leRelativeDynlibPaths = gopt Opt_RelativeDynlibPaths dflags + , leUseXLinkerRPath = useXLinkerRPath dflags os + , leSingleLibFolder = gopt Opt_SingleLibFolder dflags + , leWholeArchiveHsLibs = gopt Opt_WholeArchiveHsLibs dflags + , leGenManifest = gopt Opt_GenManifest dflags + , leRPath = gopt Opt_RPath dflags + , leCompactUnwind = gopt Opt_CompactUnwind dflags + , leLibraryPaths = libraryPaths dflags + , leFrameworkOpts = initFrameworkOpts dflags + , leManifestOpts = initManifestOpts dflags + , leLinkerConfig = initLinkerConfig dflags + , leCcConfig = configureCc dflags + , leOtoolConfig = configureOtool dflags + , leInstallNameConfig = configureInstallName dflags + , leInputs = ldInputs dflags + , lePieOpts = pieCCLDOpts dflags + , leTempDir = tmpDir dflags + , leVerbFlags = getVerbFlags dflags + , leNoHsMain = gopt Opt_NoHsMain dflags + , leMainSymbol = "ZCMain_main" + , leRtsOptsEnabled = rtsOptsEnabled dflags + , leRtsOptsSuggestions = rtsOptsSuggestions dflags + , leKeepCafs = gopt Opt_KeepCAFs dflags + , leRtsOpts = rtsOpts dflags + } + +leHaveRtsOptsFlags :: ExecutableLinkOpts -> Bool +leHaveRtsOptsFlags opts = + isJust (leRtsOpts opts) + || case leRtsOptsEnabled opts of + RtsOptsSafeOnly -> False + _ -> True + +linkExecutable :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkExecutable logger tmpfs opts unit_env o_files dep_units = do + let static_link = False + let platform = ue_platform unit_env + unit_state = ue_homeUnitState unit_env + verbFlags = leVerbFlags opts + arch_os = platformArchOS platform + output_fn = exeFileName arch_os static_link (leOutputFile opts) + namever = leNameVersion opts + -- For the wasm target, when ghc is invoked with -dynamic, + -- when linking the final .wasm binary we must still ensure + -- the static archives are selected. Otherwise wasm-ld would + -- fail to find and link the .so library dependencies. wasm-ld + -- can link PIC objects into static .wasm binaries fine, so we + -- only adjust the ways in the final linking step, and only + -- when linking .wasm binary (which is supposed to be fully + -- static), not when linking .so shared libraries. + ways_ + | ArchWasm32 <- platformArch platform = removeWay WayDyn $ leWays opts + | otherwise = leWays opts + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d </> output_fn) + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) + let pkg_lib_paths = collectLibraryDirs ways_ pkgs + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget (platformOS platform) && + leDynLibLoader opts == SystemDependent && + ways_ `hasWay` WayDyn + = let libpath = if leRelativeDynlibPaths opts + then "$ORIGIN" </> + (l `makeRelativeTo` full_output_fn) + else l + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + rpath = if leUseXLinkerRPath opts + then ["-Xlinker", "-rpath", "-Xlinker", libpath] + else [] + -- Solaris 11's linker does not support -rpath-link option. It silently + -- ignores it and then complains about next option which is -l<some + -- dir> as being a directory and not expected object file, E.g + -- ld: elf error: file + -- /tmp/ghc-src/libraries/base/dist-install/build: + -- elf_begin: I/O error: region read: Is a directory + rpathlink = if (platformOS platform) == OSSolaris2 + then [] + else ["-Xlinker", "-rpath-link", "-Xlinker", l] + in ["-L" ++ l] ++ rpathlink ++ rpath + | osMachOTarget (platformOS platform) && + leDynLibLoader opts == SystemDependent && + ways_ `hasWay` WayDyn && + leUseXLinkerRPath opts + = let libpath = if leRelativeDynlibPaths opts + then "@loader_path" </> + (l `makeRelativeTo` full_output_fn) + else l + in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] + | otherwise = ["-L" ++ l] + + pkg_lib_path_opts <- + if leSingleLibFolder opts + then do + libs <- getLibs namever ways_ unit_env dep_units + tmpDir <- newTempSubDir logger tmpfs (leTempDir opts) + sequence_ [ copyFile lib (tmpDir </> basename) + | (lib, basename) <- libs] + return [ "-L" ++ tmpDir ] + else pure pkg_lib_path_opts + + let + dead_strip + | leWholeArchiveHsLibs opts = [] + | otherwise = if osSubsectionsViaSymbols (platformOS platform) + then ["-Wl,-dead_strip"] + else [] + let lib_paths = leLibraryPaths opts + let lib_path_opts = map ("-L"++) lib_paths + + extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs opts unit_state + noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs opts unit_env dep_units + + let + (pre_hs_libs, post_hs_libs) + | leWholeArchiveHsLibs opts + = if platformOS platform == OSDarwin + then (["-Wl,-all_load"], []) + -- OS X does not have a flag to turn off -all_load + else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) + | otherwise + = ([],[]) + + pkg_link_opts <- do + unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units + return $ otherFlags unit_link_opts ++ dead_strip + ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs + ++ extraLibs unit_link_opts + -- -Wl,-u,<sym> contained in other_flags + -- needs to be put before -l<package>, + -- otherwise Solaris linker fails linking + -- a binary with unresolved symbols in RTS + -- which are defined in base package + -- the reason for this is a note in ld(1) about + -- '-u' option: "The placement of this option + -- on the command line is significant. + -- This option must be placed before the library + -- that defines the symbol." + + -- frameworks + pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units + let framework_opts = getFrameworkOpts (leFrameworkOpts opts) platform + + -- probably _stub.o files + let extra_ld_inputs = leInputs opts + + rc_objs <- case platformOS platform of + OSMinGW32 | leGenManifest opts -> maybeCreateManifest logger tmpfs (leManifestOpts opts) output_fn + _ -> return [] + + let linker_config = leLinkerConfig opts + let args = ( map GHC.SysTools.Option verbFlags + ++ [ GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ] + ++ libmLinkOpts platform + ++ map GHC.SysTools.Option ( + [] + + -- See Note [No PIE when linking] + ++ lePieOpts opts + + -- Permit the linker to auto link _symbol to _imp_symbol. + -- This lets us link against DLLs without needing an "import library". + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + + -- '-no_compact_unwind' + -- C++/Objective-C exceptions cannot use optimised + -- stack unwinding code. The optimised form is the + -- default in Xcode 4 on at least x86_64, and + -- without this flag we're also seeing warnings + -- like + -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog + -- on x86. + ++ (if not (leCompactUnwind opts) && + linkerSupportsCompactUnwind (leLinkerConfig opts) && + (platformOS platform == OSDarwin) && + case platformArch platform of + ArchX86_64 -> True + ArchAArch64 -> True + _ -> False + then ["-Wl,-no_compact_unwind"] + else []) + + -- We should rather be asking does it support --gc-sections? + ++ (if linkerIsGnuLd (leLinkerConfig opts) && + not (leWholeArchiveHsLibs opts) + then ["-Wl,--gc-sections"] + else []) + + ++ o_files + ++ lib_path_opts) + ++ extra_ld_inputs + ++ map GHC.SysTools.Option ( + rc_objs + ++ framework_opts + ++ pkg_lib_path_opts + ++ extraLinkObj + ++ noteLinkObjs + -- See Note [RTS/ghc-internal interface] + -- (-u<sym> must come before -lghc-internal...!) + ++ (if ghcInternalUnitId `elem` map unitId pkgs + then [concat [ "-Wl,-u," + , ['_' | platformLeadingUnderscore platform] + , "init_ghc_hs_iface" ]] + else []) + ++ pkg_link_opts + ++ pkg_framework_opts + ++ (if platformOS platform == OSDarwin + -- dead_strip_dylibs, will remove unused dylibs, and thus save + -- space in the load commands. The -headerpad is necessary so + -- that we can inject more @rpath's later for the left over + -- libraries during runInjectRpaths phase. + -- + -- See Note [Dynamic linking on macOS]. + then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] + else []) + )) + + runLink logger tmpfs linker_config args + + -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 + when (platformOS platform == OSDarwin && leRPath opts) $ + GHC.Linker.MacOS.runInjectRPaths logger (leOtoolConfig opts) (leInstallNameConfig opts) pkg_lib_paths output_fn + +mkExtraObj :: Logger -> TmpFs -> TempDir -> CcConfig -> UnitState -> Suffix -> String -> IO FilePath +mkExtraObj logger tmpfs tmpdir cc_config unit_state extn xs + = do + -- Pass a different set of options to the C compiler depending one whether + -- we're compiling C or assembler. When compiling C, we pass the usual + -- set of include directories and PIC flags. + let cOpts = map Option (ccPicOpts cc_config) + ++ map (FileOption "-I" . ST.unpack) + (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit) + cFile <- newTempName logger tmpfs tmpdir TFL_CurrentModule extn + oFile <- newTempName logger tmpfs tmpdir TFL_GhcSession "o" + writeFile cFile xs + runCc Nothing logger tmpfs tmpdir cc_config + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ if extn /= "s" + then cOpts + else []) + return oFile + +-- | Create object containing main() entry point +-- +-- When linking a binary, we need to create a C main() function that +-- starts everything off. This used to be compiled statically as part +-- of the RTS, but that made it hard to change the -rtsopts setting, +-- so now we generate and compile a main() stub as part of every +-- binary and pass the -rtsopts setting directly to the RTS (#5373) +mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitState -> IO (Maybe FilePath) +mkExtraObjToLinkIntoBinary logger tmpfs opts unit_state = do + when (leNoHsMain opts && leHaveRtsOptsFlags opts) $ + logInfo logger $ withPprStyle defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + if leNoHsMain opts + -- Don't try to build the extra object if it is not needed. Compiling the + -- extra object assumes the presence of the RTS in the unit database + -- (because the extra object imports Rts.h) but GHC's build system may try + -- to build some helper programs before building and registering the RTS! + -- See #18938 for an example where hp2ps failed to build because of a failed + -- (unsafe) lookup for the RTS in the unit db. + then pure Nothing + else mk_extra_obj exeMain + + where + tmpdir = leTempDir opts + cc_config = leCcConfig opts + mk_extra_obj = fmap Just . mkExtraObj logger tmpfs tmpdir cc_config unit_state "c" . renderWithContext defaultSDocContext + + exeMain = vcat [ + text "#include <Rts.h>", + text "extern StgClosure " <> text (leMainSymbol opts) <> text "_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (leRtsOptsEnabled opts)) <> semi, + text " __conf.rts_opts_suggestions = " + <> (if leRtsOptsSuggestions opts + then text "true" + else text "false") <> semi, + text "__conf.keep_cafs = " + <> (if leKeepCafs opts + then text "true" + else text "false") <> semi, + case leRtsOpts opts of + Nothing -> Outputable.empty + Just rts_opts -> text " __conf.rts_opts= " <> + text (show rts_opts) <> semi, + text " __conf.rts_hs_main = true;", + text " return hs_main(argc,argv,&" <> text (leMainSymbol opts) <> text "_closure,__conf);", + char '}', + char '\n' -- final newline, to keep gcc happy + ] + +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary logger tmpfs opts unit_env dep_packages = do + link_info <- initLinkInfo opts unit_env dep_packages + + if (platformSupportsSavingLinkOpts (platformOS platform )) + then fmap (:[]) $ mkExtraObj logger tmpfs tmpdir cc_config unit_state "s" (renderWithContext defaultSDocContext (link_opts link_info)) + else return [] + + where + unit_state = ue_homeUnitState unit_env + platform = ue_platform unit_env + tmpdir = leTempDir opts + cc_config = leCcConfig opts + link_opts info = hcat + [ -- "link info" section (see Note [LinkInfo section]) + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 (show info) + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- "GHC.CmmToAsm" for another instance + -- where we need to do this. + , if platformHasGnuNonexecStack platform + then text ".section .note.GNU-stack,\"\"," + <> sectionType platform "progbits" <> char '\n' + else Outputable.empty + ] + +data LinkInfo = LinkInfo + { liPkgLinkOpts :: UnitLinkOpts + , liPkgFrameworks :: [String] + , liRtsOpts :: Maybe String + , liRtsOptsEnabled :: !RtsOptsEnabled + , liNoHsMain :: !Bool + , liLdInputs :: [String] + , liLdOpts :: [String] + } + deriving (Show) + + +-- | Return the "link info" +-- +-- See Note [LinkInfo section] +initLinkInfo :: ExecutableLinkOpts -> UnitEnv -> [UnitId] -> IO LinkInfo +initLinkInfo opts unit_env dep_packages = do + package_link_opts <- getUnitLinkOpts (leNameVersion opts) (leWays opts) unit_env dep_packages + pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) + then return [] + else do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) + return (collectFrameworks ps) + pure $ LinkInfo + { liPkgLinkOpts = package_link_opts + , liPkgFrameworks = pkg_frameworks + , liRtsOpts = leRtsOpts opts + , liRtsOptsEnabled = leRtsOptsEnabled opts + , liNoHsMain = leNoHsMain opts + , liLdInputs = map showOpt (leInputs opts) + , liLdOpts = map showOpt (linkerOptionsPost (leLinkerConfig opts)) + } + +platformSupportsSavingLinkOpts :: OS -> Bool +platformSupportsSavingLinkOpts os + | os == OSSolaris2 = False -- see #5382 + | otherwise = osElfTarget os + +-- See Note [LinkInfo section] +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default + +-- Identifier for the note (see Note [LinkInfo section]) +ghcLinkInfoNoteName :: String +ghcLinkInfoNoteName = "GHC link info" + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: Logger -> ExecutableLinkOpts -> UnitEnv -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo logger opts unit_env pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- initLinkInfo opts unit_env pkg_deps + debugTraceMsg logger 3 $ text ("Link info: " ++ show link_info) + m_exe_link_info <- readElfNoteAsString logger exe_file + ghcLinkInfoSectionName ghcLinkInfoNoteName + let sameLinkInfo = (Just (show link_info) == m_exe_link_info) + debugTraceMsg logger 3 $ case m_exe_link_info of + Nothing -> text "Exe link info: Not found" + Just s + | sameLinkInfo -> text ("Exe link info is the same") + | otherwise -> text ("Exe link info is different: " ++ s) + return (not sameLinkInfo) + +{- Note [LinkInfo section] + ~~~~~~~~~~~~~~~~~~~~~~~ + +The "link info" is a string representing the parameters of the link. We save +this information in the binary, and the next time we link, if nothing else has +changed, we use the link info stored in the existing binary to decide whether +to re-link or not. + +The "link info" string is stored in a ELF section called ".debug-ghc-link-info" +(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to +not follow the specified record-based format (see #11022). + +-} + +{- +Note [-Xlinker -rpath vs -Wl,-rpath] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-Wl takes a comma-separated list of options which in the case of +-Wl,-rpath -Wl,some,path,with,commas parses the path with commas +as separate options. +Buck, the build system, produces paths with commas in them. + +-Xlinker doesn't have this disadvantage and as far as I can tell +it is supported by both gcc and clang. Anecdotally nvcc supports +-Xlinker, but not -Wl. +-} + ===================================== compiler/GHC/Linker/ExtraObj.hs deleted ===================================== @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------ --- --- GHC Extra object linking code --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ - -module GHC.Linker.ExtraObj - ( mkExtraObj - , mkExtraObjToLinkIntoBinary - , mkNoteObjsToLinkIntoBinary - , checkLinkInfo - , getLinkInfo - , ghcLinkInfoSectionName - , ghcLinkInfoNoteName - , platformSupportsSavingLinkOpts - , haveRtsOptsFlags - ) -where - -import GHC.Prelude -import GHC.Platform - -import GHC.Unit -import GHC.Unit.Env - -import GHC.Utils.Asm -import GHC.Utils.Error -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Logger -import GHC.Utils.TmpFs - -import GHC.Driver.Session -import GHC.Driver.Ppr - -import qualified GHC.Data.ShortText as ST - -import GHC.SysTools.Elf -import GHC.SysTools.Tasks -import GHC.Linker.Unit - -import Control.Monad -import Data.Maybe - -mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath -mkExtraObj logger tmpfs dflags unit_state extn xs - = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn - oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o" - writeFile cFile xs - runCc Nothing logger tmpfs dflags - ([Option "-c", - FileOption "" cFile, - Option "-o", - FileOption "" oFile] - ++ if extn /= "s" - then cOpts - else []) - return oFile - where - -- Pass a different set of options to the C compiler depending one whether - -- we're compiling C or assembler. When compiling C, we pass the usual - -- set of include directories and PIC flags. - cOpts = map Option (picCCOpts dflags) - ++ map (FileOption "-I" . ST.unpack) - (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit) - --- When linking a binary, we need to create a C main() function that --- starts everything off. This used to be compiled statically as part --- of the RTS, but that made it hard to change the -rtsopts setting, --- so now we generate and compile a main() stub as part of every --- binary and pass the -rtsopts setting directly to the RTS (#5373) --- --- On Windows, when making a shared library we also may need a DllMain. --- -mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath) -mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ - logInfo logger $ withPprStyle defaultUserStyle - (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ - text " Call hs_init_ghc() from your main() function to set these options.") - - case ghcLink dflags of - -- Don't try to build the extra object if it is not needed. Compiling the - -- extra object assumes the presence of the RTS in the unit database - -- (because the extra object imports Rts.h) but GHC's build system may try - -- to build some helper programs before building and registering the RTS! - -- See #18938 for an example where hp2ps failed to build because of a failed - -- (unsafe) lookup for the RTS in the unit db. - _ | gopt Opt_NoHsMain dflags - -> return Nothing - - LinkDynLib - | OSMinGW32 <- platformOS (targetPlatform dflags) - -> mk_extra_obj dllMain - - | otherwise - -> return Nothing - - _ -> mk_extra_obj exeMain - - where - mk_extra_obj = fmap Just . mkExtraObj logger tmpfs dflags unit_state "c" . showSDoc dflags - - exeMain = vcat [ - text "#include <Rts.h>", - text "extern StgClosure ZCMain_main_closure;", - text "int main(int argc, char *argv[])", - char '{', - text " RtsConfig __conf = defaultRtsConfig;", - text " __conf.rts_opts_enabled = " - <> text (show (rtsOptsEnabled dflags)) <> semi, - text " __conf.rts_opts_suggestions = " - <> (if rtsOptsSuggestions dflags - then text "true" - else text "false") <> semi, - text "__conf.keep_cafs = " - <> (if gopt Opt_KeepCAFs dflags - then text "true" - else text "false") <> semi, - case rtsOpts dflags of - Nothing -> Outputable.empty - Just opts -> text " __conf.rts_opts= " <> - text (show opts) <> semi, - text " __conf.rts_hs_main = true;", - text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", - char '}', - char '\n' -- final newline, to keep gcc happy - ] - - dllMain = vcat [ - text "#include <Rts.h>", - text "#include <windows.h>", - text "#include <stdbool.h>", - char '\n', - text "bool", - text "WINAPI", - text "DllMain ( HINSTANCE hInstance STG_UNUSED", - text " , DWORD reason STG_UNUSED", - text " , LPVOID reserved STG_UNUSED", - text " )", - text "{", - text " return true;", - text "}", - char '\n' -- final newline, to keep gcc happy - ] - --- Write out the link info section into a new assembly file. Previously --- this was included as inline assembly in the main.c file but this --- is pretty fragile. gas gets upset trying to calculate relative offsets --- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_packages = do - link_info <- getLinkInfo dflags unit_env dep_packages - - if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info)) - else return [] - - where - unit_state = ue_homeUnitState unit_env - platform = ue_platform unit_env - link_opts info = hcat - [ -- "link info" section (see Note [LinkInfo section]) - makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info - - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- "GHC.CmmToAsm" for another instance - -- where we need to do this. - , if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," - <> sectionType platform "progbits" <> char '\n' - else Outputable.empty - ] - --- | Return the "link info" string --- --- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String -getLinkInfo dflags unit_env dep_packages = do - package_link_opts <- getUnitLinkOpts (ghcNameVersion dflags) (ways dflags) unit_env dep_packages - pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) - then return [] - else do - ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) - return (collectFrameworks ps) - let link_info = - ( package_link_opts - , pkg_frameworks - , rtsOpts dflags - , rtsOptsEnabled dflags - , gopt Opt_NoHsMain dflags - , map showOpt (ldInputs dflags) - , getOpts dflags opt_l - ) - return (show link_info) - -platformSupportsSavingLinkOpts :: OS -> Bool -platformSupportsSavingLinkOpts os - | os == OSSolaris2 = False -- see #5382 - | otherwise = osElfTarget os - --- See Note [LinkInfo section] -ghcLinkInfoSectionName :: String -ghcLinkInfoSectionName = ".debug-ghc-link-info" - -- if we use the ".debug" prefix, then strip will strip it by default - --- Identifier for the note (see Note [LinkInfo section]) -ghcLinkInfoNoteName :: String -ghcLinkInfoNoteName = "GHC link info" - --- Returns 'False' if it was, and we can avoid linking, because the --- previous binary was linked with "the same options". -checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool -checkLinkInfo logger dflags unit_env pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) - -- ToDo: Windows and OS X do not use the ELF binary format, so - -- readelf does not work there. We need to find another way to do - -- this. - = return False -- conservatively we should return True, but not - -- linking in this case was the behaviour for a long - -- time so we leave it as-is. - | otherwise - = do - link_info <- getLinkInfo dflags unit_env pkg_deps - debugTraceMsg logger 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString logger exe_file - ghcLinkInfoSectionName ghcLinkInfoNoteName - let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg logger 3 $ case m_exe_link_info of - Nothing -> text "Exe link info: Not found" - Just s - | sameLinkInfo -> text ("Exe link info is the same") - | otherwise -> text ("Exe link info is different: " ++ s) - return (not sameLinkInfo) - -{- Note [LinkInfo section] - ~~~~~~~~~~~~~~~~~~~~~~~ - -The "link info" is a string representing the parameters of the link. We save -this information in the binary, and the next time we link, if nothing else has -changed, we use the link info stored in the existing binary to decide whether -to re-link or not. - -The "link info" string is stored in a ELF section called ".debug-ghc-link-info" -(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to -not follow the specified record-based format (see #11022). - --} - -haveRtsOptsFlags :: DynFlags -> Bool -haveRtsOptsFlags dflags = - isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of - RtsOptsSafeOnly -> False - _ -> True ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -406,6 +406,7 @@ loadCmdLineLibs'' interp hsc_env pls = , libraryPaths = lib_paths_base}) = hsc_dflags hsc_env let logger = hsc_logger hsc_env + let ld_config = configureLd dflags -- (c) Link libraries from the command-line let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] @@ -421,7 +422,7 @@ loadCmdLineLibs'' interp hsc_env pls = OSMinGW32 -> "pthread" : minus_ls_1 _ -> minus_ls_1 -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths logger dflags os + gcc_paths <- getGCCPaths logger platform ld_config lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base @@ -1254,6 +1255,7 @@ loadPackage interp hsc_env pkgs = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env + ld_config = configureLd dflags platform = targetPlatform dflags is_dyn = interpreterDynamic interp dirs | is_dyn = [map ST.unpack $ Packages.unitLibraryDynDirs pkg | pkg <- pkgs] @@ -1281,7 +1283,7 @@ loadPackage interp hsc_env pkgs extra_libs = zipWith (++) extdeplibs linkerlibs -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths logger dflags (platformOS platform) + gcc_paths <- getGCCPaths logger platform ld_config dirs_env <- traverse (addEnvPaths "LIBRARY_PATH") dirs hs_classifieds @@ -1507,6 +1509,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env diag_opts = initDiagOpts dflags + ld_config = configureLd dflags dirs = lib_dirs ++ gcc_dirs gcc = False user = True @@ -1570,7 +1573,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary interp so_name #endif - tryGcc = let search = searchForLibUsingGcc logger dflags + tryGcc = let search = searchForLibUsingGcc logger ld_config #if defined(CAN_LOAD_DLL) dllpath = liftM (fmap DLLPath) short = dllpath $ search so_name lib_dirs @@ -1624,11 +1627,11 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 #endif os = platformOS platform -searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) -searchForLibUsingGcc logger dflags so dirs = do +searchForLibUsingGcc :: Logger -> LdConfig -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc logger ld_config so dirs = do -- GCC does not seem to extend the library search path (using -L) when using -- --print-file-name. So instead pass it a new base location. - str <- askLd logger dflags (map (FileOption "-B") dirs + str <- askLd logger ld_config (map (FileOption "-B") dirs ++ [Option "--print-file-name", Option so]) let file = case lines str of [] -> "" @@ -1640,10 +1643,10 @@ searchForLibUsingGcc logger dflags so dirs = do -- | Retrieve the list of search directory GCC and the System use to find -- libraries and components. See Note [Fork/Exec Windows]. -getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath] -getGCCPaths logger dflags os - | os == OSMinGW32 || platformArch (targetPlatform dflags) == ArchWasm32 = - do gcc_dirs <- getGccSearchDirectory logger dflags "libraries" +getGCCPaths :: Logger -> Platform -> LdConfig -> IO [FilePath] +getGCCPaths logger platform ld_config + | platformOS platform == OSMinGW32 || platformArch platform == ArchWasm32 = + do gcc_dirs <- getGccSearchDirectory logger ld_config "libraries" sys_dirs <- getSystemDirectories return $ nub $ gcc_dirs ++ sys_dirs | otherwise = return [] @@ -1663,8 +1666,8 @@ gccSearchDirCache = unsafePerformIO $ newIORef [] -- which hopefully is written in an optimized manner to take advantage of -- caching. At the very least we remove the overhead of the fork/exec and waits -- which dominate a large percentage of startup time on Windows. -getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath] -getGccSearchDirectory logger dflags key = do +getGccSearchDirectory :: Logger -> LdConfig -> String -> IO [FilePath] +getGccSearchDirectory logger ld_config key = do #if defined(wasm32_HOST_ARCH) pure [] #else @@ -1672,7 +1675,7 @@ getGccSearchDirectory logger dflags key = do case lookup key cache of Just x -> return x Nothing -> do - str <- askLd logger dflags [Option "--print-search-dirs"] + str <- askLd logger ld_config [Option "--print-search-dirs"] let line = dropWhile isSpace str name = key ++ ": =" if null line ===================================== compiler/GHC/Linker/MacOS.hs ===================================== @@ -17,7 +17,6 @@ import GHC.Unit.Types import GHC.Unit.State import GHC.Unit.Env -import GHC.Settings import GHC.SysTools.Tasks import GHC.Runtime.Interpreter @@ -49,13 +48,13 @@ import Text.ParserCombinators.ReadP as Parser -- dynamic library through @-add_rpath@. -- -- See Note [Dynamic linking on macOS] -runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO () -runInjectRPaths logger toolSettings lib_paths dylib = do - info <- lines <$> askOtool logger toolSettings Nothing [Option "-L", Option dylib] +runInjectRPaths :: Logger -> OtoolConfig -> InstallNameConfig -> [FilePath] -> FilePath -> IO () +runInjectRPaths logger otool_opts install_name_opts lib_paths dylib = do + info <- lines <$> askOtool logger otool_opts Nothing [Option "-L", Option dylib] -- filter the output for only the libraries. And then drop the @rpath prefix. let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info -- find any pre-existing LC_PATH items - info <- lines <$> askOtool logger toolSettings Nothing [Option "-l", Option dylib] + info <- lines <$> askOtool logger otool_opts Nothing [Option "-l", Option dylib] let paths = mapMaybe get_rpath info lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ] -- only find those rpaths, that aren't already in the library. @@ -63,7 +62,7 @@ runInjectRPaths logger toolSettings lib_paths dylib = do -- inject the rpaths case rpaths of [] -> return () - _ -> runInstallNameTool logger toolSettings $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] + _ -> runInstallNameTool logger install_name_opts $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] get_rpath :: String -> Maybe FilePath get_rpath l = case readP_to_S rpath_parser l of ===================================== compiler/GHC/Linker/Static.hs ===================================== @@ -1,12 +1,10 @@ module GHC.Linker.Static - ( linkBinary - , linkStaticLib + ( linkStaticLib ) where import GHC.Prelude import GHC.Platform -import GHC.Platform.Ways import GHC.Settings import GHC.SysTools @@ -19,24 +17,15 @@ import GHC.Unit.State import GHC.Utils.Logger import GHC.Utils.Monad -import GHC.Utils.Misc -import GHC.Utils.TmpFs -import GHC.Linker.MacOS import GHC.Linker.Unit -import GHC.Linker.Dynamic -import GHC.Linker.ExtraObj -import GHC.Linker.External -import GHC.Linker.Windows import GHC.Linker.Static.Utils -import GHC.Driver.Config.Linker import GHC.Driver.Session import System.FilePath import System.Directory import Control.Monad -import Data.Maybe ----------------------------------------------------------------------------- -- Static linking, of .o files @@ -51,225 +40,6 @@ import Data.Maybe -- read any interface files), so the user must explicitly specify all -- the packages. -{- -Note [-Xlinker -rpath vs -Wl,-rpath] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --Wl takes a comma-separated list of options which in the case of --Wl,-rpath -Wl,some,path,with,commas parses the path with commas -as separate options. -Buck, the build system, produces paths with commas in them. - --Xlinker doesn't have this disadvantage and as far as I can tell -it is supported by both gcc and clang. Anecdotally nvcc supports --Xlinker, but not -Wl. --} - -linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary = linkBinary' False - -linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do - let platform = ue_platform unit_env - unit_state = ue_homeUnitState unit_env - toolSettings' = toolSettings dflags - verbFlags = getVerbFlags dflags - arch_os = platformArchOS platform - output_fn = exeFileName arch_os staticLink (outputFile_ dflags) - namever = ghcNameVersion dflags - -- For the wasm target, when ghc is invoked with -dynamic, - -- when linking the final .wasm binary we must still ensure - -- the static archives are selected. Otherwise wasm-ld would - -- fail to find and link the .so library dependencies. wasm-ld - -- can link PIC objects into static .wasm binaries fine, so we - -- only adjust the ways in the final linking step, and only - -- when linking .wasm binary (which is supposed to be fully - -- static), not when linking .so shared libraries. - ways_ - | ArchWasm32 <- platformArch platform = removeWay WayDyn $ targetWays_ dflags - | otherwise = ways dflags - - full_output_fn <- if isAbsolute output_fn - then return output_fn - else do d <- getCurrentDirectory - return $ normalise (d </> output_fn) - - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. - pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) - let pkg_lib_paths = collectLibraryDirs ways_ pkgs - let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths - get_pkg_lib_path_opts l - | osElfTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - ways_ `hasWay` WayDyn - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "$ORIGIN" </> - (l `makeRelativeTo` full_output_fn) - else l - -- See Note [-Xlinker -rpath vs -Wl,-rpath] - rpath = if useXLinkerRPath dflags (platformOS platform) - then ["-Xlinker", "-rpath", "-Xlinker", libpath] - else [] - -- Solaris 11's linker does not support -rpath-link option. It silently - -- ignores it and then complains about next option which is -l<some - -- dir> as being a directory and not expected object file, E.g - -- ld: elf error: file - -- /tmp/ghc-src/libraries/base/dist-install/build: - -- elf_begin: I/O error: region read: Is a directory - rpathlink = if (platformOS platform) == OSSolaris2 - then [] - else ["-Xlinker", "-rpath-link", "-Xlinker", l] - in ["-L" ++ l] ++ rpathlink ++ rpath - | osMachOTarget (platformOS platform) && - dynLibLoader dflags == SystemDependent && - ways_ `hasWay` WayDyn && - useXLinkerRPath dflags (platformOS platform) - = let libpath = if gopt Opt_RelativeDynlibPaths dflags - then "@loader_path" </> - (l `makeRelativeTo` full_output_fn) - else l - in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] - | otherwise = ["-L" ++ l] - - pkg_lib_path_opts <- - if gopt Opt_SingleLibFolder dflags - then do - libs <- getLibs namever ways_ unit_env dep_units - tmpDir <- newTempSubDir logger tmpfs (tmpDir dflags) - sequence_ [ copyFile lib (tmpDir </> basename) - | (lib, basename) <- libs] - return [ "-L" ++ tmpDir ] - else pure pkg_lib_path_opts - - let - dead_strip - | gopt Opt_WholeArchiveHsLibs dflags = [] - | otherwise = if osSubsectionsViaSymbols (platformOS platform) - then ["-Wl,-dead_strip"] - else [] - let lib_paths = libraryPaths dflags - let lib_path_opts = map ("-L"++) lib_paths - - extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state - noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_units - - let - (pre_hs_libs, post_hs_libs) - | gopt Opt_WholeArchiveHsLibs dflags - = if platformOS platform == OSDarwin - then (["-Wl,-all_load"], []) - -- OS X does not have a flag to turn off -all_load - else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) - | otherwise - = ([],[]) - - pkg_link_opts <- do - unit_link_opts <- getUnitLinkOpts namever ways_ unit_env dep_units - return $ otherFlags unit_link_opts ++ dead_strip - ++ pre_hs_libs ++ hsLibs unit_link_opts ++ post_hs_libs - ++ extraLibs unit_link_opts - -- -Wl,-u,<sym> contained in other_flags - -- needs to be put before -l<package>, - -- otherwise Solaris linker fails linking - -- a binary with unresolved symbols in RTS - -- which are defined in base package - -- the reason for this is a note in ld(1) about - -- '-u' option: "The placement of this option - -- on the command line is significant. - -- This option must be placed before the library - -- that defines the symbol." - - -- frameworks - pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units - let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform - - -- probably _stub.o files - let extra_ld_inputs = ldInputs dflags - - rc_objs <- case platformOS platform of - OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn - _ -> return [] - - let linker_config = initLinkerConfig dflags - let link dflags args = do - runLink logger tmpfs linker_config args - -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 - when (platformOS platform == OSDarwin && gopt Opt_RPath dflags) $ - GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn - - link dflags ( - map GHC.SysTools.Option verbFlags - ++ [ GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ] - ++ libmLinkOpts platform - ++ map GHC.SysTools.Option ( - [] - - -- See Note [No PIE when linking] - ++ pieCCLDOpts dflags - - -- Permit the linker to auto link _symbol to _imp_symbol. - -- This lets us link against DLLs without needing an "import library". - ++ (if platformOS platform == OSMinGW32 - then ["-Wl,--enable-auto-import"] - else []) - - -- '-no_compact_unwind' - -- C++/Objective-C exceptions cannot use optimised - -- stack unwinding code. The optimised form is the - -- default in Xcode 4 on at least x86_64, and - -- without this flag we're also seeing warnings - -- like - -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog - -- on x86. - ++ (if not (gopt Opt_CompactUnwind dflags) && - toolSettings_ldSupportsCompactUnwind toolSettings' && - (platformOS platform == OSDarwin) && - case platformArch platform of - ArchX86_64 -> True - ArchAArch64 -> True - _ -> False - then ["-Wl,-no_compact_unwind"] - else []) - - -- We should rather be asking does it support --gc-sections? - ++ (if toolSettings_ldIsGnuLd toolSettings' && - not (gopt Opt_WholeArchiveHsLibs dflags) - then ["-Wl,--gc-sections"] - else []) - - ++ o_files - ++ lib_path_opts) - ++ extra_ld_inputs - ++ map GHC.SysTools.Option ( - rc_objs - ++ framework_opts - ++ pkg_lib_path_opts - ++ extraLinkObj - ++ noteLinkObjs - -- See Note [RTS/ghc-internal interface] - -- (-u<sym> must come before -lghc-internal...!) - ++ (if ghcInternalUnitId `elem` map unitId pkgs - then [concat [ "-Wl,-u," - , ['_' | platformLeadingUnderscore platform] - , "init_ghc_hs_iface" ]] - else []) - ++ pkg_link_opts - ++ pkg_framework_opts - ++ (if platformOS platform == OSDarwin - -- dead_strip_dylibs, will remove unused dylibs, and thus save - -- space in the load commands. The -headerpad is necessary so - -- that we can inject more @rpath's later for the left over - -- libraries during runInjectRpaths phase. - -- - -- See Note [Dynamic linking on macOS]. - then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] - else []) - )) - -- | Linking a static lib will not really link anything. It will merely produce -- a static archive of all dependent static libraries. The resulting library -- will still need to be linked with any remaining link flags. @@ -309,4 +79,5 @@ linkStaticLib logger dflags unit_env o_files dep_units = do else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar -- run ranlib over the archive. write*Ar does *not* create the symbol index. - runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn] + let ranlib_opts = configureRanlib dflags + runRanlib logger ranlib_opts [GHC.SysTools.FileOption "" output_fn] ===================================== compiler/GHC/Linker/Windows.hs ===================================== @@ -1,5 +1,7 @@ module GHC.Linker.Windows - ( maybeCreateManifest + ( ManifestOpts (..) + , initManifestOpts + , maybeCreateManifest ) where @@ -12,13 +14,28 @@ import GHC.Utils.Logger import System.FilePath import System.Directory +data ManifestOpts = ManifestOpts + { manifestEmbed :: !Bool -- ^ Should the manifest be embedded in the binary with Windres + , manifestTempdir :: TempDir + , manifestWindresConfig :: WindresConfig + , manifestObjectSuf :: String + } + +initManifestOpts :: DynFlags -> ManifestOpts +initManifestOpts dflags = ManifestOpts + { manifestEmbed = gopt Opt_EmbedManifest dflags + , manifestTempdir = tmpDir dflags + , manifestWindresConfig = configureWindres dflags + , manifestObjectSuf = objectSuf dflags + } + maybeCreateManifest :: Logger -> TmpFs - -> DynFlags + -> ManifestOpts -> FilePath -- ^ filename of executable -> IO [FilePath] -- ^ extra objects to embed, maybe -maybeCreateManifest logger tmpfs dflags exe_filename = do +maybeCreateManifest logger tmpfs opts exe_filename = do let manifest_filename = exe_filename <.> "manifest" manifest = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ @@ -42,18 +59,18 @@ maybeCreateManifest logger tmpfs dflags exe_filename = do -- foo.exe.manifest. However, for extra robustness, and so that -- we can move the binary around, we can embed the manifest in -- the binary itself using windres: - if not (gopt Opt_EmbedManifest dflags) + if not (manifestEmbed opts) then return [] else do - rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc" + rc_filename <- newTempName logger tmpfs (manifestTempdir opts) TFL_CurrentModule "rc" rc_obj_filename <- - newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags) + newTempName logger tmpfs (manifestTempdir opts) TFL_GhcSession (manifestObjectSuf opts) writeFile rc_filename $ "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n" -- magic numbers :-) - runWindres logger dflags $ map GHC.SysTools.Option $ + runWindres logger (manifestWindresConfig opts) $ map GHC.SysTools.Option $ ["--input="++rc_filename, "--output="++rc_obj_filename, "--output-format=coff"] ===================================== compiler/GHC/Runtime/Interpreter/C.hs ===================================== @@ -0,0 +1,85 @@ +{-# LANGUAGE MultiWayIf #-} + +-- | External interpreter program +module GHC.Runtime.Interpreter.C + ( generateIservC + ) +where + +import GHC.Prelude +import GHC.Platform +import GHC.Data.FastString +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Unit.Types +import GHC.Unit.Env +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Utils.Panic.Plain +import GHC.Linker.Executable +import GHC.Linker.Config +import GHC.Utils.CliOption + +-- | Generate iserv program for the target +generateIservC :: Logger -> TmpFs -> ExecutableLinkOpts -> UnitEnv -> IO FilePath +generateIservC logger tmpfs opts unit_env = do + -- get the unit-id of the ghci package. We need this to load the + -- interpreter code. + let unit_state = ue_homeUnitState unit_env + ghci_unit_id <- case lookupPackageName unit_state (PackageName (fsLit "ghci")) of + Nothing -> cmdLineErrorIO "C interpreter: couldn't find \"ghci\" package" + Just i -> pure i + + -- generate a temporary name for the iserv program + let tmpdir = leTempDir opts + exe_file <- newTempName logger tmpfs tmpdir TFL_GhcSession "iserv" + + let platform = ue_platform unit_env + let os = platformOS platform + + -- we inherit ExecutableLinkOpts for the target code (i.e. derived from + -- DynFlags specified by the user and from settings). We need to adjust these + -- options to generate the iserv program we want. Some settings are to be + -- shared (e.g. ways, platform, etc.) but some other must be set specifically + -- for iserv. + let opts' = opts + { -- write iserv program in some temporary directory + leOutputFile = Just exe_file + + -- we need GHC to generate a main entry point... + , leNoHsMain = False + + -- ...however the main symbol must be the iserv server + , leMainSymbol = zString (zEncodeFS (unitIdFS ghci_unit_id)) ++ "_GHCiziServer_defaultServer" + + -- we need to reset inputs, otherwise one of them may be defining + -- `main` too (with -no-hs-main). + , leInputs = [] + + -- we never know what symbols GHC will look up in the future, so we + -- must retain CAFs for running interpreted code. + , leKeepCafs = True + + -- enable all rts options + , leRtsOptsEnabled = RtsOptsAll + + -- Add -Wl,--export-dynamic enables GHCi to load dynamic objects that + -- refer to the RTS. This is harmless if you don't use it (adds a bit + -- of overhead to startup and increases the binary sizes) but if you + -- need it there's no alternative. + -- + -- The Solaris linker does not support --export-dynamic option. It also + -- does not need it since it exports all dynamic symbols by default + , leLinkerConfig = if + | osElfTarget os + , os /= OSFreeBSD + , os /= OSSolaris2 + -> (leLinkerConfig opts) + { linkerOptionsPost = linkerOptionsPost (leLinkerConfig opts) ++ [Option "-Wl,--export-dynamic"] + } + | otherwise + -> leLinkerConfig opts + } + linkExecutable logger tmpfs opts' unit_env [] [ghci_unit_id] + + pure exe_file ===================================== compiler/GHC/Runtime/Interpreter/Init.hs ===================================== @@ -0,0 +1,162 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Runtime.Interpreter.Init + ( initInterpreter + , InterpOpts (..) + ) +where + + +import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways +import GHC.Settings +import GHC.Unit.Finder +import GHC.Unit.Env +import GHC.Utils.TmpFs +import GHC.SysTools.Tasks + +import GHC.Linker.Executable +import qualified GHC.Linker.Loader as Loader +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.C +import GHC.StgToJS.Types (StgToJSConfig) + +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Logger +import GHC.Utils.Error +import Control.Concurrent +import System.Process + +data InterpOpts = InterpOpts + { interpExternal :: !Bool + , interpProg :: String + , interpOpts :: [String] + , interpWays :: Ways + , interpNameVer :: GhcNameVersion + , interpLdConfig :: LdConfig + , interpCcConfig :: CcConfig + , interpJsInterp :: FilePath + , interpTmpDir :: TempDir + , interpFinderOpts :: FinderOpts + , interpJsCodegenCfg :: StgToJSConfig + , interpVerbosity :: Int + , interpCreateProcess :: Maybe (CreateProcess -> IO ProcessHandle) -- create iserv process hook + , interpWasmDyld :: FilePath + , interpBrowser :: Bool + , interpBrowserHost :: String + , interpBrowserPort :: Int + , interpBrowserRedirectWasiConsole :: Bool + , interpBrowserPuppeteerLaunchOpts :: Maybe String + , interpBrowserPlaywrightBrowserType :: Maybe String + , interpBrowserPlaywrightLaunchOpts :: Maybe String + , interpExecutableLinkOpts :: ExecutableLinkOpts + } + +-- | Initialize code interpreter +initInterpreter + :: TmpFs + -> Logger + -> Platform + -> FinderCache + -> UnitEnv + -> InterpOpts + -> IO (Maybe Interp) +initInterpreter tmpfs logger platform finder_cache unit_env opts = do + + lookup_cache <- liftIO $ mkInterpSymbolCache + + -- see Note [Target code interpreter] + if +#if !defined(wasm32_HOST_ARCH) + -- Wasm dynamic linker + | ArchWasm32 <- platformArch platform + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger (interpLdConfig opts) "libraries" + let profiled = interpWays opts `hasWay` WayProf + way_tag = if profiled then "_p" else "" + let cfg = + WasmInterpConfig + { wasmInterpDyLD = interpWasmDyld opts + , wasmInterpLibDir = libdir + , wasmInterpOpts = interpOpts opts + , wasmInterpBrowser = interpBrowser opts + , wasmInterpBrowserHost = interpBrowserHost opts + , wasmInterpBrowserPort = interpBrowserPort opts + , wasmInterpBrowserRedirectWasiConsole = interpBrowserRedirectWasiConsole opts + , wasmInterpBrowserPuppeteerLaunchOpts = interpBrowserPuppeteerLaunchOpts opts + , wasmInterpBrowserPlaywrightBrowserType = interpBrowserPlaywrightBrowserType opts + , wasmInterpBrowserPlaywrightLaunchOpts = interpBrowserPlaywrightLaunchOpts opts + , wasmInterpTargetPlatform = platform + , wasmInterpProfiled = profiled + , wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (interpNameVer opts) + , wasmInterpUnitState = ue_homeUnitState unit_env + } + pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache +#endif + + -- JavaScript interpreter + | ArchJavaScript <- platformArch platform + -> do + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + let cfg = JSInterpConfig + { jsInterpNodeConfig = defaultNodeJsSettings + , jsInterpScript = interpJsInterp opts + , jsInterpTmpFs = tmpfs + , jsInterpTmpDir = interpTmpDir opts + , jsInterpLogger = logger + , jsInterpCodegenCfg = interpJsCodegenCfg opts + , jsInterpUnitEnv = unit_env + , jsInterpFinderOpts = interpFinderOpts opts + , jsInterpFinderCache = finder_cache + } + return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) + + -- external interpreter + | interpExternal opts + -> do + let + profiled = interpWays opts `hasWay` WayProf + dynamic = interpWays opts `hasWay` WayDyn + prog <- case interpProg opts of + -- build iserv program if none specified + "" -> generateIservC logger tmpfs (interpExecutableLinkOpts opts) unit_env + _ -> pure (interpProg opts ++ flavour) + where + flavour + | profiled && dynamic = "-prof-dyn" + | profiled = "-prof" + | dynamic = "-dyn" + | otherwise = "" + let msg = text "Starting " <> text prog + tr <- if interpVerbosity opts >= 3 + then return (logInfo logger $ withPprStyle defaultDumpStyle msg) + else return (pure ()) + let + conf = IServConfig + { iservConfProgram = prog + , iservConfOpts = interpOpts opts + , iservConfProfiled = profiled + , iservConfDynamic = dynamic + , iservConfHook = interpCreateProcess opts + , iservConfTrace = tr + } + s <- liftIO $ newMVar InterpPending + loader <- liftIO Loader.uninitializedLoader + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) + + -- Internal interpreter + | otherwise + -> +#if defined(HAVE_INTERNAL_INTERPRETER) + do + loader <- liftIO Loader.uninitializedLoader + return (Just (Interp InternalInterp loader lookup_cache)) +#else + return Nothing +#endif ===================================== compiler/GHC/SysTools/Tasks.hs ===================================== @@ -13,7 +13,11 @@ module GHC.SysTools.Tasks , runSourceCodePreprocessor , runPp , runCc + , configureCc + , CcConfig (..) + , configureLd , askLd + , LdConfig(..) , runAs , runLlvmOpt , runLlvmLlc @@ -22,10 +26,20 @@ module GHC.SysTools.Tasks , figureLlvmVersion , runMergeObjects , runAr + , ArConfig (..) + , configureAr , askOtool + , configureOtool + , OtoolConfig (..) , runInstallNameTool + , InstallNameConfig (..) + , configureInstallName , runRanlib + , RanlibConfig (..) + , configureRanlib , runWindres + , WindresConfig (..) + , configureWindres ) where import GHC.Prelude @@ -207,15 +221,32 @@ runPp logger dflags args = traceSystoolCommand logger "pp" $ do opts = map Option (getOpts dflags opt_F) runSomething logger "Haskell pre-processor" prog (args ++ opts) +data CcConfig = CcConfig + { ccProg :: String + , cxxProg :: String + , ccOpts :: [String] + , cxxOpts :: [String] + , ccPicOpts :: [String] + } + +configureCc :: DynFlags -> CcConfig +configureCc dflags = CcConfig + { ccProg = pgm_c dflags + , cxxProg = pgm_cxx dflags + , ccOpts = getOpts dflags opt_c + , cxxOpts = getOpts dflags opt_cxx + , ccPicOpts = picCCOpts dflags + } + -- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do +runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> TempDir -> CcConfig -> [Option] -> IO () +runCc mLanguage logger tmpfs tmpdir opts args = traceSystoolCommand logger "cc" $ do let args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 -- We take care to pass -optc flags in args1 last to ensure that the -- user can override flags passed by GHC. See #14452. mb_env <- getGccEnv args2 - runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter dbgstring prog args2 + runSomethingResponseFile logger tmpfs tmpdir cc_filter dbgstring prog args2 mb_env where -- force the C compiler to interpret this file as C when @@ -223,38 +254,49 @@ runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do -- Also useful for plain .c files, just in case GHC saw a -- -x c option. (languageOptions, userOpts, prog, dbgstring) = case mLanguage of - Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler") - Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr) + Nothing -> ([], ccOpts opts, ccProg opts, "C Compiler") + Just language -> ([Option "-x", Option languageName], copts, prog, dbgstr) where - (languageName, opts, prog, dbgstr) = case language of - LangC -> ("c", userOpts_c - ,pgm_c dflags, "C Compiler") - LangCxx -> ("c++", userOpts_cxx - ,pgm_cxx dflags , "C++ Compiler") - LangObjc -> ("objective-c", userOpts_c - ,pgm_c dflags , "Objective C Compiler") - LangObjcxx -> ("objective-c++", userOpts_cxx - ,pgm_cxx dflags, "Objective C++ Compiler") + (languageName, copts, prog, dbgstr) = case language of + LangC -> ("c", ccOpts opts + ,ccProg opts, "C Compiler") + LangCxx -> ("c++", cxxOpts opts + ,cxxProg opts, "C++ Compiler") + LangObjc -> ("objective-c", ccOpts opts + ,ccProg opts, "Objective C Compiler") + LangObjcxx -> ("objective-c++", cxxOpts opts + ,cxxProg opts, "Objective C++ Compiler") LangAsm -> ("assembler", [] - ,pgm_c dflags, "Asm Compiler") + ,ccProg opts, "Asm Compiler") RawObject -> ("c", [] - ,pgm_c dflags, "C Compiler") -- claim C for lack of a better idea + ,ccProg opts, "C Compiler") -- claim C for lack of a better idea --JS backend shouldn't reach here, so we just pass -- strings to satisfy the totality checker LangJs -> ("js", [] - ,pgm_c dflags, "JS Backend Compiler") - userOpts_c = getOpts dflags opt_c - userOpts_cxx = getOpts dflags opt_cxx + ,ccProg opts, "JS Backend Compiler") isContainedIn :: String -> String -> Bool xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) --- | Run the linker with some arguments and return the output -askLd :: Logger -> DynFlags -> [Option] -> IO String -askLd logger dflags args = traceSystoolCommand logger "linker" $ do +data LdConfig = LdConfig + { ldProg :: String -- ^ LD program path + , ldOpts :: [Option] -- ^ LD program arguments + } + +configureLd :: DynFlags -> LdConfig +configureLd dflags = let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 ++ args + in LdConfig + { ldProg = p + , ldOpts = args0 ++ args1 + } + +-- | Run the linker with some arguments and return the output +askLd :: Logger -> LdConfig -> [Option] -> IO String +askLd logger ld_config args = traceSystoolCommand logger "linker" $ do + let p = ldProg ld_config + args2 = ldOpts ld_config ++ args mb_env <- getGccEnv args2 runSomethingWith logger "gcc" p args2 $ \real_args -> readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } @@ -373,31 +415,80 @@ runMergeObjects logger tmpfs dflags args = else do runSomething logger "Merge objects" p args2 -runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do - let ar = pgm_ar dflags +newtype ArConfig = ArConfig + { arProg :: String + } + +configureAr :: DynFlags -> ArConfig +configureAr dflags = ArConfig + { arProg = pgm_ar dflags + } + +runAr :: Logger -> ArConfig -> Maybe FilePath -> [Option] -> IO () +runAr logger opts cwd args = traceSystoolCommand logger "ar" $ do + let ar = arProg opts runSomethingFiltered logger id "Ar" ar args cwd Nothing -askOtool :: Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO String -askOtool logger toolSettings mb_cwd args = do - let otool = toolSettings_pgm_otool toolSettings +newtype OtoolConfig = OtoolConfig + { otoolProg :: String + } + +configureOtool :: DynFlags -> OtoolConfig +configureOtool dflags = OtoolConfig + { otoolProg = toolSettings_pgm_otool (toolSettings dflags) + } + +askOtool :: Logger -> OtoolConfig -> Maybe FilePath -> [Option] -> IO String +askOtool logger opts mb_cwd args = do + let otool = otoolProg opts runSomethingWith logger "otool" otool args $ \real_args -> readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } -runInstallNameTool :: Logger -> ToolSettings -> [Option] -> IO () -runInstallNameTool logger toolSettings args = do - let tool = toolSettings_pgm_install_name_tool toolSettings +newtype InstallNameConfig = InstallNameConfig + { installNameProg :: String + } + +configureInstallName :: DynFlags -> InstallNameConfig +configureInstallName dflags = InstallNameConfig + { installNameProg = toolSettings_pgm_install_name_tool (toolSettings dflags) + } + +runInstallNameTool :: Logger -> InstallNameConfig -> [Option] -> IO () +runInstallNameTool logger opts args = do + let tool = installNameProg opts runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing -runRanlib :: Logger -> DynFlags -> [Option] -> IO () -runRanlib logger dflags args = traceSystoolCommand logger "ranlib" $ do - let ranlib = pgm_ranlib dflags +newtype RanlibConfig = RanlibConfig + { ranlibProg :: String + } + +configureRanlib :: DynFlags -> RanlibConfig +configureRanlib dflags = RanlibConfig + { ranlibProg = pgm_ranlib dflags + } + +runRanlib :: Logger -> RanlibConfig -> [Option] -> IO () +runRanlib logger opts args = traceSystoolCommand logger "ranlib" $ do + let ranlib = ranlibProg opts runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing -runWindres :: Logger -> DynFlags -> [Option] -> IO () -runWindres logger dflags args = traceSystoolCommand logger "windres" $ do - let cc_args = map Option (sOpt_c (settings dflags)) - windres = pgm_windres dflags - opts = map Option (getOpts dflags opt_windres) +data WindresConfig = WindresConfig + { windresProg :: String + , windresOpts :: [Option] + , windresCOpts :: [Option] + } + +configureWindres :: DynFlags -> WindresConfig +configureWindres dflags = WindresConfig + { windresProg = pgm_windres dflags + , windresOpts = map Option (getOpts dflags opt_windres) + , windresCOpts = map Option (sOpt_c (settings dflags)) + } + +runWindres :: Logger -> WindresConfig -> [Option] -> IO () +runWindres logger opts args = traceSystoolCommand logger "windres" $ do + let cc_args = windresCOpts opts + windres = windresProg opts + wopts = windresOpts opts mb_env <- getGccEnv cc_args - runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env + runSomethingFiltered logger id "Windres" windres (wopts ++ args) Nothing mb_env ===================================== compiler/ghc.cabal.in ===================================== @@ -515,6 +515,7 @@ Library GHC.Driver.Config.HsToCore GHC.Driver.Config.HsToCore.Ticks GHC.Driver.Config.HsToCore.Usage + GHC.Driver.Config.Interpreter GHC.Driver.Config.Linker GHC.Driver.Config.Logger GHC.Driver.Config.Parser @@ -650,7 +651,7 @@ Library GHC.Linker.Deps GHC.Linker.Dynamic GHC.Linker.External - GHC.Linker.ExtraObj + GHC.Linker.Executable GHC.Linker.Loader GHC.Linker.MacOS GHC.Linker.Static @@ -723,6 +724,8 @@ Library GHC.Runtime.Heap.Inspect GHC.Runtime.Heap.Layout GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.C + GHC.Runtime.Interpreter.Init GHC.Runtime.Interpreter.JS GHC.Runtime.Interpreter.Process GHC.Runtime.Interpreter.Types ===================================== testsuite/tests/bytecode/T23973.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LinearTypes #-} + +module Main (main) where + +data Ur a where + Ur :: a -> Ur a + +unur :: Ur a -> a +unur (Ur a) = a + +segvGHCi :: Ur () +segvGHCi = Ur $ () + +main :: IO () +main = print (unur segvGHCi) + ===================================== testsuite/tests/bytecode/T23973.script ===================================== @@ -0,0 +1,2 @@ +:l T23973.hs +main ===================================== testsuite/tests/bytecode/T23973.stdout ===================================== @@ -0,0 +1 @@ +() ===================================== testsuite/tests/bytecode/T26565.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes #-} +module Test where + +data Ur a where + Ur :: a -> Ur a + ===================================== testsuite/tests/bytecode/T26565.script ===================================== @@ -0,0 +1,3 @@ +:l T26565 +Ur y = (\x -> Ur $ replicate 5 'a') 3 +y ===================================== testsuite/tests/bytecode/T26565.stdout ===================================== @@ -0,0 +1 @@ +"aaaaa" ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -6,6 +6,8 @@ test('T25975', extra_ways(ghci_ways), compile_and_run, # Some of the examples work more robustly with these flags ['-fno-break-points -fno-full-laziness']) +test('T26565', extra_files(["T26565.hs"]), ghci_script, ['T26565.script']) +test('T23973', extra_files(["T23973.hs"]), ghci_script, ['T23973.script']) + # Nullary data constructors test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) - ===================================== testsuite/tests/driver/T24731.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module T24731 where + +foo :: Int +foo = $([|10|]) ===================================== testsuite/tests/driver/all.T ===================================== @@ -333,3 +333,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('T24731', [only_ways(['ext-interp'])], compile, ['-fexternal-interpreter -pgmi ""']) ===================================== utils/iserv/iserv.cabal.in ===================================== @@ -30,15 +30,6 @@ Executable iserv C-Sources: cbits/iservmain.c Hs-Source-Dirs: src include-dirs: . - Build-Depends: array >= 0.5 && < 0.6, - base >= 4 && < 5, - binary >= 0.7 && < 0.11, - bytestring >= 0.10 && < 0.13, - containers >= 0.5 && < 0.9, - deepseq >= 1.4 && < 1.6, - ghci == @ProjectVersionMunged@ - - if os(windows) - Cpp-Options: -DWINDOWS - else - Build-Depends: unix >= 2.7 && < 2.9 + Build-Depends: + base >= 4 && < 5, + ghci == @ProjectVersionMunged@ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/107ac2cef10be8eb744696376b2ea3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/107ac2cef10be8eb744696376b2ea3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T26595-fragile
by sheaf (＠sheaf) 19 Nov '25

19 Nov '25

sheaf pushed new branch wip/T26595-fragile at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T26595-fragile You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps_ospath] 2 commits: remove redundant core bindings typecheck in initWholeCoreBindings
by Torsten Schmits (＠torsten.schmits) 19 Nov '25

19 Nov '25

Torsten Schmits pushed to branch wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps_ospath at Glasgow Haskell Compiler / GHC Commits: 4d6ffa22 by Torsten Schmits at 2025-11-06T16:10:01+01:00 remove redundant core bindings typecheck in initWholeCoreBindings - - - - - 75206a24 by Georgios Karachalias at 2025-11-19T13:58:58+01:00 Use OsPath in PkgDbRef and UnitDatabase, not FilePath - - - - - 8 changed files: - + compiler/GHC/Data/OsPath.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Data/OsPath.hs ===================================== @@ -0,0 +1,45 @@ +module GHC.Data.OsPath + ( + -- * OsPath initialisation and transformation + OsPath + , OsString + , encodeUtf + , decodeUtf + , unsafeDecodeUtf + , unsafeEncodeUtf + , os + -- * Common utility functions + , (</>) + , (<.>) + , splitSearchPath + , isRelative + , dropTrailingPathSeparator + , takeDirectory + , isSuffixOf + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , createDirectoryIfMissing + , pprOsPath + ) + where + +import GHC.Prelude + +import GHC.Utils.Misc (HasCallStack) +import GHC.Utils.Outputable qualified as Outputable +import GHC.Utils.Panic (panic) + +import System.OsPath +import System.OsString (isSuffixOf) +import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing) +import System.Directory.Internal (os) + +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. +-- Prefer 'decodeUtf' and gracious error handling. +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf p = + either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p) + +pprOsPath :: HasCallStack => OsPath -> Outputable.SDoc +pprOsPath = Outputable.text . unsafeDecodeUtf ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -76,6 +76,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe import GHC.Data.StringBuffer import GHC.Data.FastString +import qualified GHC.Data.OsPath as OsPath import qualified GHC.Data.EnumSet as EnumSet import qualified GHC.Data.ShortText as ST @@ -433,7 +434,7 @@ addUnit u = do Nothing -> panic "addUnit: called too early" Just dbs -> let newdb = UnitDatabase - { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" + { unitDatabasePath = OsPath.unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -96,6 +96,7 @@ import GHC.Core.Unfold import GHC.Data.Bool import GHC.Data.EnumSet (EnumSet) import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) import GHC.Builtin.Names ( mAIN_NAME ) import GHC.Driver.Backend import GHC.Driver.Flags @@ -948,7 +949,7 @@ setDynamicNow dflags0 = data PkgDbRef = GlobalPkgDb | UserPkgDb - | PkgDbPath FilePath + | PkgDbPath OsPath deriving Eq -- | Used to differentiate the scope an include needs to apply to. ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1009,11 +1009,6 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do types_var <- newIORef (md_types details) let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)]) let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv } - core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi - -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do - -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone - -- reports a bug. - let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing [] -- The bytecode generation itself is lazy because otherwise even when doing -- recompilation checking the bytecode will be generated (which slows things down a lot) -- the laziness is OK because generateByteCode just depends on things already loaded ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -255,6 +255,7 @@ import GHC.Types.SrcLoc import GHC.Types.SafeHaskell import GHC.Types.Basic ( treatZeroAsInf ) import GHC.Data.FastString +import qualified GHC.Data.OsPath as OsPath import GHC.Utils.TmpFs import GHC.Utils.Fingerprint import GHC.Utils.Outputable @@ -1962,7 +1963,7 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] package_flags_deps = [ ------- Packages ---------------------------------------------------- make_ord_flag defFlag "package-db" - (HasArg (addPkgDbRef . PkgDbPath)) + (HasArg (addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf)) , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) @@ -1972,7 +1973,7 @@ package_flags_deps = [ (NoArg (addPkgDbRef UserPkgDb)) -- backwards compat with GHC<=7.4 : , make_dep_flag defFlag "package-conf" - (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" + (HasArg $ addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf) "Use -package-db instead" , make_dep_flag defFlag "no-user-package-conf" (NoArg removeUserPkgDb) "Use -no-user-package-db instead" , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> @@ -3377,7 +3378,7 @@ parseEnvFile :: FilePath -> String -> DynP () parseEnvFile envfile = mapM_ parseEntry . lines where parseEntry str = case words str of - ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir </> db)) + ("package-db": _) -> addPkgDbRef (PkgDbPath (OsPath.unsafeEncodeUtf (envdir </> db))) -- relative package dbs are interpreted relative to the env file where envdir = takeDirectory envfile db = drop 11 str ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -54,8 +54,6 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import qualified Data.Set as Set -import qualified Data.Map as M -import Data.List (isSuffixOf) import System.FilePath import System.Directory ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -103,6 +103,8 @@ import GHC.Data.Maybe import System.Environment ( getEnv ) import GHC.Data.FastString import qualified GHC.Data.ShortText as ST +import GHC.Data.OsPath (OsPath) +import qualified GHC.Data.OsPath as OsPath import GHC.Utils.Logger import GHC.Utils.Error import GHC.Utils.Exception @@ -112,7 +114,7 @@ import System.FilePath as FilePath import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) -import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn ) +import Data.List ( intersperse, partition, sortBy, sortOn ) import Data.Set (Set) import Data.Monoid (First(..)) import qualified Data.Semigroup as Semigroup @@ -405,7 +407,7 @@ initUnitConfig dflags cached_dbs home_units = where offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag - offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset </> p)) + offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p)) offsetPackageDb _ p = p @@ -500,12 +502,12 @@ emptyUnitState = UnitState { -- | Unit database data UnitDatabase unit = UnitDatabase - { unitDatabasePath :: FilePath + { unitDatabasePath :: OsPath , unitDatabaseUnits :: [GenUnitInfo unit] } instance Outputable u => Outputable (UnitDatabase u) where - ppr (UnitDatabase fp _u) = text "DB:" <+> text fp + ppr (UnitDatabase fp _u) = text "DB:" <+> OsPath.pprOsPath fp type UnitInfoMap = UniqMap UnitId UnitInfo @@ -720,9 +722,9 @@ getUnitDbRefs cfg = do Left _ -> system_conf_refs Right path | Just (xs, x) <- snocView path, isSearchPathSeparator x - -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs | otherwise - -> map PkgDbPath (splitSearchPath path) + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) -- Apply the package DB-related flags from the command line to get the -- final list of package DBs. @@ -751,24 +753,24 @@ getUnitDbRefs cfg = do -- NB: This logic is reimplemented in Cabal, so if you change it, -- make sure you update Cabal. (Or, better yet, dump it in the -- compiler info so Cabal can use the info.) -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath) -resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg) +resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) let pkgconf = dir </> unitConfigDBName cfg exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return pkgconf else mzero + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero resolveUnitDatabase _ (PkgDbPath name) = return $ Just name -readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId) +readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) readUnitDatabase logger cfg conf_file = do - isdir <- doesDirectoryExist conf_file + isdir <- OsPath.doesDirectoryExist conf_file proto_pkg_configs <- if isdir then readDirStyleUnitInfo conf_file else do - isfile <- doesFileExist conf_file + isfile <- OsPath.doesFileExist conf_file if isfile then do mpkgs <- tryReadOldFileStyleUnitInfo @@ -776,48 +778,49 @@ readUnitDatabase logger cfg conf_file = do Just pkgs -> return pkgs Nothing -> throwGhcExceptionIO $ InstallationError $ "ghc no longer supports single-file style package " ++ - "databases (" ++ conf_file ++ + "databases (" ++ show conf_file ++ ") use 'ghc-pkg init' to create the database with " ++ "the correct format." else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ conf_file + "can't find a package database at " ++ show conf_file let -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = dropTrailingPathSeparator conf_file - top_dir = unitConfigGHCDir cfg - pkgroot = takeDirectory conf_file' + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) -- TODO: hm. + pkgroot = OsPath.takeDirectory conf_file' pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- return $ UnitDatabase conf_file' pkg_configs1 where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] readDirStyleUnitInfo conf_dir = do - let filename = conf_dir </> "package.cache" - cache_exists <- doesFileExist filename + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename if cache_exists then do - debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename - readPackageDbForGhc filename + debugTraceMsg logger 2 $ text "Using binary package database:" <+> OsPath.pprOsPath filename + readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) -- TODO: Can we help it with this one? it comes from the ghc-boot package else do -- If there is no package.cache file, we check if the database is not -- empty by inspecting if the directory contains any .conf file. If it -- does, something is wrong and we fail. Otherwise we assume that the -- database is empty. debugTraceMsg logger 2 $ text "There is no package.cache in" - <+> text conf_dir + <+> OsPath.pprOsPath conf_dir <> text ", checking if the database is empty" - db_empty <- all (not . isSuffixOf ".conf") - <$> getDirectoryContents conf_dir + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir if db_empty then do debugTraceMsg logger 3 $ text "There are no .conf files in" - <+> text conf_dir <> text ", treating" + <+> OsPath.pprOsPath conf_dir <> text ", treating" <+> text "package database as empty" return [] else throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ conf_dir ++ + "there is no package.cache in " ++ show conf_dir ++ " even though package database is not empty" @@ -830,13 +833,13 @@ readUnitDatabase logger cfg conf_file = do -- assumes it's a file and tries to overwrite with 'writeFile'. -- ghc-pkg also cooperates with this workaround. tryReadOldFileStyleUnitInfo = do - content <- readFile conf_file `catchIO` \_ -> return "" + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" if take 2 content == "[]" then do - let conf_dir = conf_file <.> "d" - direxists <- doesDirectoryExist conf_dir + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir if direxists - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> OsPath.pprOsPath conf_dir) liftM Just (readDirStyleUnitInfo conf_dir) else return (Just []) -- ghc-pkg will create it when it's updated else return Nothing @@ -846,11 +849,12 @@ distrustAllUnits pkgs = map distrust pkgs where distrust pkg = pkg{ unitIsTrusted = False } -mungeUnitInfo :: FilePath -> FilePath +-- TODO: Can we help it with this one? it comes from the ghc-boot package +mungeUnitInfo :: OsPath -> OsPath -> UnitInfo -> UnitInfo mungeUnitInfo top_dir pkgroot = mungeDynLibFields - . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot) + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) mungeDynLibFields :: UnitInfo -> UnitInfo mungeDynLibFields pkg = @@ -1388,7 +1392,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] where merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ - text "loading package database" <+> text db_path + text "loading package database" <+> OsPath.pprOsPath db_path forM_ (Set.toList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> ===================================== compiler/ghc.cabal.in ===================================== @@ -115,6 +115,7 @@ Library containers >= 0.6.2.1 && < 0.8, array >= 0.1 && < 0.6, filepath >= 1 && < 1.6, + os-string >= 2.0.1 && < 2.1, template-haskell == 2.22.*, hpc >= 0.6 && < 0.8, transformers >= 0.5 && < 0.7, @@ -430,6 +431,7 @@ Library GHC.Data.List.SetOps GHC.Data.Maybe GHC.Data.OrdList + GHC.Data.OsPath GHC.Data.Pair GHC.Data.SmallArray GHC.Data.Stream View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f166735f14fcdbbe054d15ccdd03ec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f166735f14fcdbbe054d15ccdd03ec… You're receiving this email because of your account on gitlab.haskell.org.

1 0