- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] Remove stg_decodeStackzh
by Hannes Siebenhandl (＠fendor) 26 Aug '25

26 Aug '25

Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC Commits: 5dbb3e43 by fendor at 2025-08-26T11:31:14+02:00 Remove stg_decodeStackzh - - - - - 5 changed files: - libraries/ghc-internal/cbits/StackCloningDecoding.cmm - libraries/ghc-internal/jsbits/base.js - rts/CloneStack.c - rts/CloneStack.h - rts/RtsSymbols.c Changes: ===================================== libraries/ghc-internal/cbits/StackCloningDecoding.cmm ===================================== @@ -17,10 +17,3 @@ stg_sendCloneStackMessagezh (gcptr threadId, gcptr mVarStablePtr) { return (); } - -stg_decodeStackzh (gcptr stgStack) { - gcptr stackEntries; - ("ptr" stackEntries) = ccall decodeClonedStack(MyCapability() "ptr", stgStack "ptr"); - - return (stackEntries); -} ===================================== libraries/ghc-internal/jsbits/base.js ===================================== @@ -1245,7 +1245,7 @@ function h$mkdir(path, path_offset, mode) { // It is required by Google Closure Compiler to be at least defined if // somewhere it is used -var h$stg_cloneMyStackzh, h$stg_decodeStackzh, +var h$stg_cloneMyStackzh, h$advanceStackFrameLocationzh, h$getStackFieldszh, h$getStackClosurezh, h$getWordzh, h$getStackInfoTableAddrzh, h$getRetFunSmallBitmapzh, h$getRetFunLargeBitmapzh, h$isArgGenBigRetFunTypezh, @@ -1253,7 +1253,6 @@ var h$stg_cloneMyStackzh, h$stg_decodeStackzh, h$getInfoTableAddrszh, h$getLargeBitmapzh, h$getSmallBitmapzh, h$getBCOLargeBitmapzh h$stg_cloneMyStackzh - = h$stg_decodeStackzh = h$advanceStackFrameLocationzh = h$getStackFieldszh = h$getStackClosurezh = h$getWordzh, h$getStackInfoTableAddrzh = h$getRetFunSmallBitmapzh = h$getRetFunLargeBitmapzh ===================================== rts/CloneStack.c ===================================== @@ -26,11 +26,6 @@ #include <string.h> -static StgWord getStackFrameCount(StgStack* stack); -static StgWord getStackChunkClosureCount(StgStack* stack); -static StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes); -static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack); - static StgStack* cloneStackChunk(Capability* capability, const StgStack* stack) { StgWord spOffset = stack->sp - stack->stack; @@ -112,94 +107,3 @@ void sendCloneStackMessage(StgTSO *tso STG_UNUSED, HsStablePtr mvar STG_UNUSED) } #endif // end !defined(THREADED_RTS) - -// Creates a MutableArray# (Haskell representation) that contains a -// InfoProvEnt* for every stack frame on the given stack. Thus, the size of the -// array is the count of stack frames. -// Each InfoProvEnt* is looked up by lookupIPE(). If there's no IPE for a stack -// frame it's represented by null. -StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack) { - StgWord closureCount = getStackFrameCount(stack); - - StgArrBytes* array = allocateByteArray(cap, sizeof(StgInfoTable*) * closureCount); - - copyPtrsToArray(array, stack); - - return array; -} - -// Count the stack frames that are on the given stack. -// This is the sum of all stack frames in all stack chunks of this stack. -StgWord getStackFrameCount(StgStack* stack) { - StgWord closureCount = 0; - StgStack *last_stack = stack; - while (true) { - closureCount += getStackChunkClosureCount(last_stack); - - // check whether the stack ends in an underflow frame - StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack - + last_stack->stack_size - sizeofW(StgUnderflowFrame)); - if (frame->info == &stg_stack_underflow_frame_d_info - ||frame->info == &stg_stack_underflow_frame_v16_info - ||frame->info == &stg_stack_underflow_frame_v32_info - ||frame->info == &stg_stack_underflow_frame_v64_info) { - last_stack = frame->next_chunk; - } else { - break; - } - } - return closureCount; -} - -StgWord getStackChunkClosureCount(StgStack* stack) { - StgWord closureCount = 0; - StgPtr sp = stack->sp; - StgPtr spBottom = stack->stack + stack->stack_size; - for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { - closureCount++; - } - - return closureCount; -} - -// Allocate and initialize memory for a ByteArray# (Haskell representation). -StgArrBytes* allocateByteArray(Capability *cap, StgWord bytes) { - // Idea stolen from PrimOps.cmm:stg_newArrayzh() - StgWord words = sizeofW(StgArrBytes) + bytes; - - StgArrBytes* array = (StgArrBytes*) allocate(cap, words); - - SET_HDR(array, &stg_ARR_WORDS_info, CCS_SYSTEM); - array->bytes = bytes; - return array; -} - -static void copyPtrsToArray(StgArrBytes* arr, StgStack* stack) { - StgWord index = 0; - StgStack *last_stack = stack; - const StgInfoTable **result = (const StgInfoTable **) arr->payload; - while (true) { - StgPtr sp = last_stack->sp; - StgPtr spBottom = last_stack->stack + last_stack->stack_size; - for (; sp < spBottom; sp += stack_frame_sizeW((StgClosure *)sp)) { - const StgInfoTable* infoTable = ((StgClosure *)sp)->header.info; - result[index] = infoTable; - index++; - } - - // Ensure that we didn't overflow the result array - ASSERT(index-1 < arr->bytes / sizeof(StgInfoTable*)); - - // check whether the stack ends in an underflow frame - StgUnderflowFrame *frame = (StgUnderflowFrame *) (last_stack->stack - + last_stack->stack_size - sizeofW(StgUnderflowFrame)); - if (frame->info == &stg_stack_underflow_frame_d_info - ||frame->info == &stg_stack_underflow_frame_v16_info - ||frame->info == &stg_stack_underflow_frame_v32_info - ||frame->info == &stg_stack_underflow_frame_v64_info) { - last_stack = frame->next_chunk; - } else { - break; - } - } -} ===================================== rts/CloneStack.h ===================================== @@ -15,8 +15,6 @@ StgStack* cloneStack(Capability* capability, const StgStack* stack); void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar); -StgArrBytes* decodeClonedStack(Capability *cap, StgStack* stack); - #include "BeginPrivate.h" #if defined(THREADED_RTS) ===================================== rts/RtsSymbols.c ===================================== @@ -951,7 +951,6 @@ extern char **environ; SymI_HasProto(lookupIPE) \ SymI_HasProto(sendCloneStackMessage) \ SymI_HasProto(cloneStack) \ - SymI_HasProto(decodeClonedStack) \ SymI_HasProto(stg_newPromptTagzh) \ SymI_HasProto(stg_promptzh) \ SymI_HasProto(stg_control0zh) \ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5dbb3e43e6e4bec76743b2518bb9fd2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5dbb3e43e6e4bec76743b2518bb9fd2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/gdc-files] 4 commits: testsuite: Use ghci_ways to set ways in PackedDataCon/UnboxedTuples/UnliftedDataTypeInterp tests
by Matthew Pickering (＠mpickering) 26 Aug '25

26 Aug '25

Matthew Pickering pushed to branch wip/gdc-files at Glasgow Haskell Compiler / GHC Commits: 1a77d303 by Matthew Pickering at 2025-08-26T09:58:52+01:00 testsuite: Use ghci_ways to set ways in PackedDataCon/UnboxedTuples/UnliftedDataTypeInterp tests These tests reimplemented the logic from `valid_way` in order to determine what ways to run. It's easier to use this combination of `only_ways` and `extra_ways` to only run in GHCi ways and always run in GHCi ways. - - - - - 2e87f1d7 by Matthew Pickering at 2025-08-26T09:58:52+01:00 Rename interpreterBackend to bytecodeBackend - - - - - f0d63f12 by Cheng Shao at 2025-08-26T09:58:52+01:00 compiler: implement and test bytecode serialization logic - - - - - 63e8e333 by Matthew Pickering at 2025-08-26T10:25:05+01:00 Add support for generating bytecode objects This commit adds the `-fwrite-byte-code` option which makes GHC emit a `.gbc` file which contains a serialised representation of bytecode. The bytecode can be loaded by the compiler to avoid having to reinterpret a module when using the bytecode interpreter (for example, in GHCi). There are also the new options: * -gbcdir=<DIR>: Specify the directory to place the gbc files * -gbcsuf=<suffix>: Specify the suffix for gbc files The option `-fbyte-code-and-object-code` now implies `-fwrite-byte-code`. - - - - - 56 changed files: - compiler/GHC.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/Breakpoints.hs - + compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Data/FlatBag.hs - compiler/GHC/Data/SmallArray.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/Backend/Internal.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/ByteCode.hs - compiler/GHC/Driver/Config/Finder.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Types/SptEntry.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Location.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Utils/Binary.hs - compiler/ghc.cabal.in - docs/users_guide/phases.rst - docs/users_guide/separate_compilation.rst - ghc/Main.hs - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - + testsuite/tests/driver/bytecode-object/A.hs - + testsuite/tests/driver/bytecode-object/BytecodeMain.hs - + testsuite/tests/driver/bytecode-object/BytecodeTest.hs - + testsuite/tests/driver/bytecode-object/Makefile - + testsuite/tests/driver/bytecode-object/all.T - + testsuite/tests/driver/bytecode-object/bytecode_object12.stderr - + testsuite/tests/driver/bytecode-object/bytecode_object13.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object14.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object15.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object16.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object17.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object18.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object19.script - + testsuite/tests/driver/bytecode-object/bytecode_object19.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object4.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object5.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object6.stdout The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6f56a971247344abcc822509635805… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6f56a971247344abcc822509635805… 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: compiler: use zero cost coerce in hoopl setElems/mapToList
by Marge Bot (＠marge-bot) 26 Aug '25

26 Aug '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: fd24a551 by Cheng Shao at 2025-08-26T04:39:02-04:00 compiler: use zero cost coerce in hoopl setElems/mapToList This patch is a follow-up of !14680 and changes setElems/mapToList in GHC/Cmm/Dataflow/Label to use coerce instead of mapping mkHooplLabel over the keys. - - - - - 32f8482d by Ryan Scott at 2025-08-26T04:39:02-04:00 Reject infix promoted data constructors without DataKinds In the rename, make sure to apply the same `DataKinds` checks for both `HsTyVar` (for prefix promoted data constructors) and `HsOpTy` (for infix promoted data constructors) alike. Fixes #26318. - - - - - 6 changed files: - compiler/GHC/Cmm/Dataflow/Label.hs - compiler/GHC/Rename/HsType.hs - docs/users_guide/9.16.1-notes.rst - + testsuite/tests/typecheck/should_fail/T26318.hs - + testsuite/tests/typecheck/should_fail/T26318.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== compiler/GHC/Cmm/Dataflow/Label.hs ===================================== @@ -83,6 +83,7 @@ import GHC.Data.Word64Map.Strict (Word64Map) import qualified GHC.Data.Word64Map.Strict as M import GHC.Data.TrieMap +import Data.Coerce import Data.Word (Word64) @@ -164,7 +165,7 @@ setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s {-# INLINE setElems #-} setElems :: LabelSet -> [Label] -setElems (LS s) = map mkHooplLabel (S.elems s) +setElems (LS s) = coerce $ S.elems s {-# INLINE setFromList #-} setFromList :: [Label] -> LabelSet @@ -272,7 +273,7 @@ mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m) {-# INLINE mapToList #-} mapToList :: LabelMap b -> [(Label, b)] -mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m] +mapToList (LM m) = coerce $ M.toList m {-# INLINE mapFromList #-} mapFromList :: [(Label, v)] -> LabelMap v ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -547,15 +547,7 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name)) ; this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalTyName name - ; when (isDataConName name && not (isKindName name)) $ - -- Any use of a promoted data constructor name (that is not - -- specifically exempted by isKindName) is illegal without the use - -- of DataKinds. See Note [Checking for DataKinds] in - -- GHC.Tc.Validity. - checkDataKinds env tv - ; when (isDataConName name && not (isPromoted ip)) $ - -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar. - addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name) + ; checkPromotedDataConName env tv Prefix ip name ; return (HsTyVar noAnn ip (L loc $ WithUserRdr rdr_name name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) @@ -567,8 +559,7 @@ rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2 ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2' - ; when (isDataConName op_name && not (isPromoted prom)) $ - addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) + ; checkPromotedDataConName env ty Infix prom op_name ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi env (HsParTy _ ty) @@ -1670,6 +1661,30 @@ checkDataKinds env thing type_or_kind | isRnKindLevel env = KindLevel | otherwise = TypeLevel +-- | If a 'Name' is that of a promoted data constructor, perform various +-- validity checks on it. +checkPromotedDataConName :: + RnTyKiEnv -> + -- | The type that the 'Name' belongs to. This will always be an 'HsTyVar' + -- (for 'Prefix' names) or an 'HsOpTy' (for 'Infix' names). + HsType GhcPs -> + -- | Whether the type is written 'Prefix' or 'Infix'. + LexicalFixity -> + -- | Whether the name was written with an explicit promotion tick or not. + PromotionFlag -> + -- | The name to check. + Name -> + TcM () +checkPromotedDataConName env ty fixity ip name + = do when (isDataConName name && not (isKindName name)) $ + -- Any use of a promoted data constructor name (that is not + -- specifically exempted by isKindName) is illegal without the use + -- of DataKinds. See Note [Checking for DataKinds] in + -- GHC.Tc.Validity. + checkDataKinds env ty + when (isDataConName name && not (isPromoted ip)) $ + addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor fixity name) + warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tvb) used_names = ===================================== docs/users_guide/9.16.1-notes.rst ===================================== @@ -11,6 +11,11 @@ for specific guidance on migrating programs to this release. Language ~~~~~~~~ +- Fix a bug introduced in GHC 9.10 where GHC would erroneously accept infix uses + of promoted data constructors without enabling :extension:`DataKinds`. As a + result, you may need to enable :extension:`DataKinds` in code that did not + previously require it. + Compiler ~~~~~~~~ ===================================== testsuite/tests/typecheck/should_fail/T26318.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE NoDataKinds #-} +module T26318 where + +class C1 l +instance C1 (x : xs) + +class C2 l +instance C2 (x ': xs) + +class C3 l +instance C3 ((:) x xs) + +class C4 l +instance C4 ('(:) x xs) ===================================== testsuite/tests/typecheck/should_fail/T26318.stderr ===================================== @@ -0,0 +1,20 @@ +T26318.hs:6:16: error: [GHC-68567] + Illegal type: ‘x : xs’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:9:16: error: [GHC-68567] + Illegal type: ‘x ': xs’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:12:14: error: [GHC-68567] + Illegal type: ‘(:)’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:15:14: error: [GHC-68567] + Illegal type: ‘'(:)’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -741,3 +741,4 @@ test('T25325', normal, compile_fail, ['']) test('T25004', normal, compile_fail, ['']) test('T25004k', normal, compile_fail, ['']) test('T26004', normal, compile_fail, ['']) +test('T26318', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/04fbc92cfff2e7f2f10e1e26efc754… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/04fbc92cfff2e7f2f10e1e26efc754… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/remove-stg_stackDecode] 3 commits: Move stack decoding logic from ghc-heap to ghc-internal
by Hannes Siebenhandl (＠fendor) 26 Aug '25

26 Aug '25

Hannes Siebenhandl pushed to branch wip/fendor/remove-stg_stackDecode at Glasgow Haskell Compiler / GHC Commits: 9ea55b0d by fendor at 2025-08-26T09:17:04+02:00 Move stack decoding logic from ghc-heap to ghc-internal The stack decoding logic in `ghc-heap` is more sophisticated than the one currently employed in `CloneStack`. We want to use the stack decoding implementation from `ghc-heap` in `base`. We cannot simply depend on `ghc-heap` in `base` due do bootstrapping issues. Thus, we move the code that is necessary to implement stack decoding to `ghc-internal`. This is the right location, as we don't want to add a new API to `base`. Moving the stack decoding logic and re-exposing it in ghc-heap is insufficient, though, as we have a dependency cycle between. * ghc-heap depends on stage1:ghc-internal * stage0:ghc depends on stage0:ghc-heap To fix this, we remove ghc-heap from the set of `stage0` dependencies. This is not entirely straight-forward, as a couple of boot dependencies, such as `ghci` depend on `ghc-heap`. Luckily, the boot compiler of GHC is now >=9.10, so we can migrate `ghci` to use `ghc-internal` instead of `ghc-heap`, which already exports the relevant modules. However, we cannot 100% remove ghc's dependency on `ghc-heap`, since when we compile `stage0:ghc`, `stage1:ghc-internal` is not yet available. Thus, when we compile with the boot-compiler, we still depend on an older version of `ghc-heap`, and only use the modules from `ghc-internal`, if the `ghc-internal` version is recent enough. ------------------------- Metric Increase: T24602_perf_size T25046_perf_size_gzip T25046_perf_size_unicode T25046_perf_size_unicode_gzip size_hello_artifact size_hello_artifact_gzip size_hello_unicode size_hello_unicode_gzip ------------------------- These metric increases are unfortunate, they are most likely caused by the larger (literally in terms of lines of code) stack decoder implementation that are now linked into hello-word binaries. On linux, it is almost a 10% increase, which is considerable. - - - - - fbb7ae1d by fendor at 2025-08-26T09:17:07+02:00 Implement `decode` in terms of `decodeStackWithIpe` Uses the more efficient stack decoder implementation. - - - - - fd1ef199 by fendor at 2025-08-26T09:17:29+02:00 Remove stg_decodeStackzh - - - - - 52 changed files: - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/ghc.cabal.in - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings/Default.hs - libraries/base/src/GHC/Stack/CloneStack.hs - libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs - libraries/ghc-heap/GHC/Exts/Heap/Closures.hs - + libraries/ghc-heap/GHC/Exts/Heap/Constants.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hs - + libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hs - libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs - + libraries/ghc-heap/GHC/Exts/Stack/Constants.hs - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/ghc-heap.cabal.in - libraries/ghc-heap/cbits/HeapPrim.cmm → libraries/ghc-internal/cbits/HeapPrim.cmm - libraries/ghc-heap/cbits/Stack.cmm → libraries/ghc-internal/cbits/Stack.cmm - libraries/ghc-internal/cbits/StackCloningDecoding.cmm - libraries/ghc-heap/cbits/Stack_c.c → libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs - libraries/ghc-heap/GHC/Exts/Heap/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc - libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc → libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs - libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs - libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc → libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc - + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-heap/tests/stack-annotation/Makefile → libraries/ghc-internal/tests/stack-annotation/Makefile - libraries/ghc-heap/tests/stack-annotation/TestUtils.hs → libraries/ghc-internal/tests/stack-annotation/TestUtils.hs - libraries/ghc-heap/tests/stack-annotation/all.T → libraries/ghc-internal/tests/stack-annotation/all.T - libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame001.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame001.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame001.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame002.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame003.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame003.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame003.stdout - libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs → libraries/ghc-internal/tests/stack-annotation/ann_frame004.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame004.stdout → libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout - libraries/ghci/GHCi/Message.hs - libraries/ghci/ghci.cabal.in - rts/CloneStack.c - rts/CloneStack.h - 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 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b03931447bf30389df4b624826d758… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b03931447bf30389df4b624826d758… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sol/use-logInfo
by Simon Hengel (＠sol) 26 Aug '25

26 Aug '25

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

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Marge Bot (＠marge-bot) 25 Aug '25

25 Aug '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 5b5d9d47 by Ben Gamari at 2025-08-25T14:29:35-04:00 Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)" This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd - - - - - 10f06163 by Cheng Shao at 2025-08-25T14:30:16-04:00 wasm: ensure setKeepCAFs() is called in ghci This patch is a critical bugfix for #26106, see comment and linked issue for details. - - - - - 6dfa209e by Cheng Shao at 2025-08-25T19:02:15-04:00 compiler: use zero cost coerce in hoopl setElems/mapToList This patch is a follow-up of !14680 and changes setElems/mapToList in GHC/Cmm/Dataflow/Label to use coerce instead of mapping mkHooplLabel over the keys. - - - - - 04fbc92c by Ryan Scott at 2025-08-25T19:02:15-04:00 Reject infix promoted data constructors without DataKinds In the rename, make sure to apply the same `DataKinds` checks for both `HsTyVar` (for prefix promoted data constructors) and `HsOpTy` (for infix promoted data constructors) alike. Fixes #26318. - - - - - 13 changed files: - compiler/GHC/Cmm/Dataflow/Label.hs - compiler/GHC/Rename/HsType.hs - docs/users_guide/9.16.1-notes.rst - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/STM.c - − testsuite/tests/lib/stm/T26028.hs - − testsuite/tests/lib/stm/T26028.stdout - − testsuite/tests/lib/stm/all.T - + testsuite/tests/typecheck/should_fail/T26318.hs - + testsuite/tests/typecheck/should_fail/T26318.stderr - testsuite/tests/typecheck/should_fail/all.T - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/Cmm/Dataflow/Label.hs ===================================== @@ -83,6 +83,7 @@ import GHC.Data.Word64Map.Strict (Word64Map) import qualified GHC.Data.Word64Map.Strict as M import GHC.Data.TrieMap +import Data.Coerce import Data.Word (Word64) @@ -164,7 +165,7 @@ setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s {-# INLINE setElems #-} setElems :: LabelSet -> [Label] -setElems (LS s) = map mkHooplLabel (S.elems s) +setElems (LS s) = coerce $ S.elems s {-# INLINE setFromList #-} setFromList :: [Label] -> LabelSet @@ -272,7 +273,7 @@ mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m) {-# INLINE mapToList #-} mapToList :: LabelMap b -> [(Label, b)] -mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m] +mapToList (LM m) = coerce $ M.toList m {-# INLINE mapFromList #-} mapFromList :: [(Label, v)] -> LabelMap v ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -547,15 +547,7 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name)) ; this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalTyName name - ; when (isDataConName name && not (isKindName name)) $ - -- Any use of a promoted data constructor name (that is not - -- specifically exempted by isKindName) is illegal without the use - -- of DataKinds. See Note [Checking for DataKinds] in - -- GHC.Tc.Validity. - checkDataKinds env tv - ; when (isDataConName name && not (isPromoted ip)) $ - -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar. - addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name) + ; checkPromotedDataConName env tv Prefix ip name ; return (HsTyVar noAnn ip (L loc $ WithUserRdr rdr_name name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) @@ -567,8 +559,7 @@ rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2 ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2' - ; when (isDataConName op_name && not (isPromoted prom)) $ - addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) + ; checkPromotedDataConName env ty Infix prom op_name ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi env (HsParTy _ ty) @@ -1670,6 +1661,30 @@ checkDataKinds env thing type_or_kind | isRnKindLevel env = KindLevel | otherwise = TypeLevel +-- | If a 'Name' is that of a promoted data constructor, perform various +-- validity checks on it. +checkPromotedDataConName :: + RnTyKiEnv -> + -- | The type that the 'Name' belongs to. This will always be an 'HsTyVar' + -- (for 'Prefix' names) or an 'HsOpTy' (for 'Infix' names). + HsType GhcPs -> + -- | Whether the type is written 'Prefix' or 'Infix'. + LexicalFixity -> + -- | Whether the name was written with an explicit promotion tick or not. + PromotionFlag -> + -- | The name to check. + Name -> + TcM () +checkPromotedDataConName env ty fixity ip name + = do when (isDataConName name && not (isKindName name)) $ + -- Any use of a promoted data constructor name (that is not + -- specifically exempted by isKindName) is illegal without the use + -- of DataKinds. See Note [Checking for DataKinds] in + -- GHC.Tc.Validity. + checkDataKinds env ty + when (isDataConName name && not (isPromoted ip)) $ + addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor fixity name) + warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tvb) used_names = ===================================== docs/users_guide/9.16.1-notes.rst ===================================== @@ -11,6 +11,11 @@ for specific guidance on migrating programs to this release. Language ~~~~~~~~ +- Fix a bug introduced in GHC 9.10 where GHC would erroneously accept infix uses + of promoted data constructors without enabling :extension:`DataKinds`. As a + result, you may need to enable :extension:`DataKinds` in code that did not + previously require it. + Compiler ~~~~~~~~ ===================================== rts/PrimOps.cmm ===================================== @@ -1211,27 +1211,16 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME, gcptr trec, outer, arg; trec = StgTSO_trec(CurrentTSO); - if (running_alt_code != 1) { - // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup - // the nested transaction. - // See Note [catchRetry# implementation] - outer = StgTRecHeader_enclosing_trec(trec); - (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr"); - if (r != 0) { - // Succeeded in first branch - StgTSO_trec(CurrentTSO) = outer; - return (ret); - } else { - // Did not commit: abort and restart. - StgTSO_trec(CurrentTSO) = outer; - jump stg_abort(); - } - } - else { - // nothing to do in the rhs code of catchRetry# lhs rhs, it's already - // using the parent transaction (not a nested one). - // See Note [catchRetry# implementation] - return (ret); + outer = StgTRecHeader_enclosing_trec(trec); + (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr"); + if (r != 0) { + // Succeeded (either first branch or second branch) + StgTSO_trec(CurrentTSO) = outer; + return (ret); + } else { + // Did not commit: abort and restart. + StgTSO_trec(CurrentTSO) = outer; + jump stg_abort(); } } @@ -1464,26 +1453,21 @@ retry_pop_stack: outer = StgTRecHeader_enclosing_trec(trec); if (frame_type == CATCH_RETRY_FRAME) { - // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME - + // The retry reaches a CATCH_RETRY_FRAME before the atomic frame + ASSERT(outer != NO_TREC); + // Abort the transaction attempting the current branch + ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr"); + ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); if (!StgCatchRetryFrame_running_alt_code(frame) != 0) { - // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested - // transaction. See Note [catchRetry# implementation] - - // check that we have a parent transaction - ASSERT(outer != NO_TREC); - - // Abort the nested transaction - ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr"); - ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); - - // As we are retrying in the lhs code, we must now try the rhs code - StgTSO_trec(CurrentTSO) = outer; + // Retry in the first branch: try the alternative + ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr"); + StgTSO_trec(CurrentTSO) = trec; StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true; R1 = StgCatchRetryFrame_alt_code(frame); jump stg_ap_v_fast [R1]; } else { - // Retry in the rhs code: propagate the retry + // Retry in the alternative code: propagate the retry + StgTSO_trec(CurrentTSO) = outer; Sp = Sp + SIZEOF_StgCatchRetryFrame; goto retry_pop_stack; } ===================================== rts/RaiseAsync.c ===================================== @@ -1043,7 +1043,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, } case CATCH_STM_FRAME: - // CATCH_STM frame within an atomically block: abort the + case CATCH_RETRY_FRAME: + // CATCH frames within an atomically block: abort the // inner transaction and continue. Eventually we will // hit the outer transaction that will get frozen (see // above). @@ -1055,40 +1056,14 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, { StgTRecHeader *trec = tso -> trec; StgTRecHeader *outer = trec -> enclosing_trec; - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame"); + debugTraceCap(DEBUG_stm, cap, + "found atomically block delivering async exception"); stmAbortTransaction(cap, trec); stmFreeAbortedTRec(cap, trec); tso -> trec = outer; break; }; - case CATCH_RETRY_FRAME: - // CATCH_RETY frame within an atomically block: if we're executing - // the lhs code, abort the inner transaction and continue; if we're - // executing thr rhs, continue (no nested transaction to abort. See - // Note [catchRetry# implementation]). Eventually we will hit the - // outer transaction that will get frozen (see above). - // - // As for the CATCH_STM_FRAME case above, we do not care - // whether the transaction is valid or not because its - // possible validity cannot have caused the exception - // and will not be visible after the abort. - { - if (!((StgCatchRetryFrame *)frame) -> running_alt_code) { - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)"); - StgTRecHeader *trec = tso -> trec; - StgTRecHeader *outer = trec -> enclosing_trec; - stmAbortTransaction(cap, trec); - stmFreeAbortedTRec(cap, trec); - tso -> trec = outer; - } - else - { - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)"); - } - break; - }; - default: // see Note [Update async masking state on unwind] in Schedule.c if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) { ===================================== rts/STM.c ===================================== @@ -1505,30 +1505,3 @@ void stmWriteTVar(Capability *cap, } /*......................................................................*/ - - - -/* - -Note [catchRetry# implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -catchRetry# creates a nested transaction for its lhs: -- if the lhs transaction succeeds: - - the lhs transaction is committed - - its read-variables are merged with those of the parent transaction - - the rhs code is ignored -- if the lhs transaction retries: - - the lhs transaction is aborted - - its read-variables are merged with those of the parent transaction - - the rhs code is executed directly in the parent transaction (see #26028). - -So note that: -- lhs code uses a nested transaction -- rhs code doesn't use a nested transaction - -We have to take which case we're in into account (using the running_alt_code -field of the catchRetry frame) in catchRetry's entry code, in retry# -implementation, and also when an async exception is received (to cleanup the -right number of transactions). - -*/ ===================================== testsuite/tests/lib/stm/T26028.hs deleted ===================================== @@ -1,23 +0,0 @@ -module Main where - -import GHC.Conc - -forever :: IO String -forever = delay 10 >> forever - -terminates :: IO String -terminates = delay 1 >> pure "terminates" - -delay s = threadDelay (1000000 * s) - -async :: IO a -> IO (STM a) -async a = do - var <- atomically (newTVar Nothing) - forkIO (a >>= atomically . writeTVar var . Just) - pure (readTVar var >>= maybe retry pure) - -main :: IO () -main = do - x <- mapM async $ terminates : replicate 50000 forever - r <- atomically (foldr1 orElse x) - print r ===================================== testsuite/tests/lib/stm/T26028.stdout deleted ===================================== @@ -1 +0,0 @@ -"terminates" ===================================== testsuite/tests/lib/stm/all.T deleted ===================================== @@ -1 +0,0 @@ -test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2']) ===================================== testsuite/tests/typecheck/should_fail/T26318.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE NoDataKinds #-} +module T26318 where + +class C1 l +instance C1 (x : xs) + +class C2 l +instance C2 (x ': xs) + +class C3 l +instance C3 ((:) x xs) + +class C4 l +instance C4 ('(:) x xs) ===================================== testsuite/tests/typecheck/should_fail/T26318.stderr ===================================== @@ -0,0 +1,20 @@ +T26318.hs:6:16: error: [GHC-68567] + Illegal type: ‘x : xs’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:9:16: error: [GHC-68567] + Illegal type: ‘x ': xs’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:12:14: error: [GHC-68567] + Illegal type: ‘(:)’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + +T26318.hs:15:14: error: [GHC-68567] + Illegal type: ‘'(:)’ + Suggested fix: + Perhaps you intended to use the ‘DataKinds’ extension (implied by ‘UnliftedDatatypes’) + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -741,3 +741,4 @@ test('T25325', normal, compile_fail, ['']) test('T25004', normal, compile_fail, ['']) test('T25004k', normal, compile_fail, ['']) test('T26004', normal, compile_fail, ['']) +test('T26318', normal, compile_fail, ['']) ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1105,6 +1105,20 @@ class DyLD { if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) { this.rts_init(); delete this.rts_init; + + // At this point the RTS symbols in linear memory are fixed + // and constructors are run, especially the one in JSFFI.c + // that does GHC RTS initialization for any code that links + // JSFFI.o. Luckily no Haskell computation or gc has taken + // place yet, so we must set keepCAFs=1 right now! Otherwise, + // any BCO created by later TH splice or ghci expression may + // refer to any CAF that's not reachable from GC roots (here + // our only entry point is defaultServer) and the CAF could + // have been GC'ed! (#26106) + // + // We call it here instead of in RTS C code, since we only + // want keepCAFs=1 for ghci, not user code. + this.exportFuncs.setKeepCAFs(); } init(); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b69a9c35fc31b044bcac49ba80bc0f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b69a9c35fc31b044bcac49ba80bc0f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] wasm: ensure setKeepCAFs() is called in ghci
by Marge Bot (＠marge-bot) 25 Aug '25

25 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 10f06163 by Cheng Shao at 2025-08-25T14:30:16-04:00 wasm: ensure setKeepCAFs() is called in ghci This patch is a critical bugfix for #26106, see comment and linked issue for details. - - - - - 1 changed file: - utils/jsffi/dyld.mjs Changes: ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1105,6 +1105,20 @@ class DyLD { if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) { this.rts_init(); delete this.rts_init; + + // At this point the RTS symbols in linear memory are fixed + // and constructors are run, especially the one in JSFFI.c + // that does GHC RTS initialization for any code that links + // JSFFI.o. Luckily no Haskell computation or gc has taken + // place yet, so we must set keepCAFs=1 right now! Otherwise, + // any BCO created by later TH splice or ghci expression may + // refer to any CAF that's not reachable from GC roots (here + // our only entry point is defaultServer) and the CAF could + // have been GC'ed! (#26106) + // + // We call it here instead of in RTS C code, since we only + // want keepCAFs=1 for ghci, not user code. + this.exportFuncs.setKeepCAFs(); } init(); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10f06163d9adcb3b6e6438f1524faac… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10f06163d9adcb3b6e6438f1524faac… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Marge Bot (＠marge-bot) 25 Aug '25

25 Aug '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 5b5d9d47 by Ben Gamari at 2025-08-25T14:29:35-04:00 Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)" This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd - - - - - 6 changed files: - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/STM.c - − testsuite/tests/lib/stm/T26028.hs - − testsuite/tests/lib/stm/T26028.stdout - − testsuite/tests/lib/stm/all.T Changes: ===================================== rts/PrimOps.cmm ===================================== @@ -1211,27 +1211,16 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME, gcptr trec, outer, arg; trec = StgTSO_trec(CurrentTSO); - if (running_alt_code != 1) { - // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup - // the nested transaction. - // See Note [catchRetry# implementation] - outer = StgTRecHeader_enclosing_trec(trec); - (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr"); - if (r != 0) { - // Succeeded in first branch - StgTSO_trec(CurrentTSO) = outer; - return (ret); - } else { - // Did not commit: abort and restart. - StgTSO_trec(CurrentTSO) = outer; - jump stg_abort(); - } - } - else { - // nothing to do in the rhs code of catchRetry# lhs rhs, it's already - // using the parent transaction (not a nested one). - // See Note [catchRetry# implementation] - return (ret); + outer = StgTRecHeader_enclosing_trec(trec); + (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr"); + if (r != 0) { + // Succeeded (either first branch or second branch) + StgTSO_trec(CurrentTSO) = outer; + return (ret); + } else { + // Did not commit: abort and restart. + StgTSO_trec(CurrentTSO) = outer; + jump stg_abort(); } } @@ -1464,26 +1453,21 @@ retry_pop_stack: outer = StgTRecHeader_enclosing_trec(trec); if (frame_type == CATCH_RETRY_FRAME) { - // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME - + // The retry reaches a CATCH_RETRY_FRAME before the atomic frame + ASSERT(outer != NO_TREC); + // Abort the transaction attempting the current branch + ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr"); + ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); if (!StgCatchRetryFrame_running_alt_code(frame) != 0) { - // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested - // transaction. See Note [catchRetry# implementation] - - // check that we have a parent transaction - ASSERT(outer != NO_TREC); - - // Abort the nested transaction - ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr"); - ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); - - // As we are retrying in the lhs code, we must now try the rhs code - StgTSO_trec(CurrentTSO) = outer; + // Retry in the first branch: try the alternative + ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr"); + StgTSO_trec(CurrentTSO) = trec; StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true; R1 = StgCatchRetryFrame_alt_code(frame); jump stg_ap_v_fast [R1]; } else { - // Retry in the rhs code: propagate the retry + // Retry in the alternative code: propagate the retry + StgTSO_trec(CurrentTSO) = outer; Sp = Sp + SIZEOF_StgCatchRetryFrame; goto retry_pop_stack; } ===================================== rts/RaiseAsync.c ===================================== @@ -1043,7 +1043,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, } case CATCH_STM_FRAME: - // CATCH_STM frame within an atomically block: abort the + case CATCH_RETRY_FRAME: + // CATCH frames within an atomically block: abort the // inner transaction and continue. Eventually we will // hit the outer transaction that will get frozen (see // above). @@ -1055,40 +1056,14 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, { StgTRecHeader *trec = tso -> trec; StgTRecHeader *outer = trec -> enclosing_trec; - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame"); + debugTraceCap(DEBUG_stm, cap, + "found atomically block delivering async exception"); stmAbortTransaction(cap, trec); stmFreeAbortedTRec(cap, trec); tso -> trec = outer; break; }; - case CATCH_RETRY_FRAME: - // CATCH_RETY frame within an atomically block: if we're executing - // the lhs code, abort the inner transaction and continue; if we're - // executing thr rhs, continue (no nested transaction to abort. See - // Note [catchRetry# implementation]). Eventually we will hit the - // outer transaction that will get frozen (see above). - // - // As for the CATCH_STM_FRAME case above, we do not care - // whether the transaction is valid or not because its - // possible validity cannot have caused the exception - // and will not be visible after the abort. - { - if (!((StgCatchRetryFrame *)frame) -> running_alt_code) { - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)"); - StgTRecHeader *trec = tso -> trec; - StgTRecHeader *outer = trec -> enclosing_trec; - stmAbortTransaction(cap, trec); - stmFreeAbortedTRec(cap, trec); - tso -> trec = outer; - } - else - { - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)"); - } - break; - }; - default: // see Note [Update async masking state on unwind] in Schedule.c if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) { ===================================== rts/STM.c ===================================== @@ -1505,30 +1505,3 @@ void stmWriteTVar(Capability *cap, } /*......................................................................*/ - - - -/* - -Note [catchRetry# implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -catchRetry# creates a nested transaction for its lhs: -- if the lhs transaction succeeds: - - the lhs transaction is committed - - its read-variables are merged with those of the parent transaction - - the rhs code is ignored -- if the lhs transaction retries: - - the lhs transaction is aborted - - its read-variables are merged with those of the parent transaction - - the rhs code is executed directly in the parent transaction (see #26028). - -So note that: -- lhs code uses a nested transaction -- rhs code doesn't use a nested transaction - -We have to take which case we're in into account (using the running_alt_code -field of the catchRetry frame) in catchRetry's entry code, in retry# -implementation, and also when an async exception is received (to cleanup the -right number of transactions). - -*/ ===================================== testsuite/tests/lib/stm/T26028.hs deleted ===================================== @@ -1,23 +0,0 @@ -module Main where - -import GHC.Conc - -forever :: IO String -forever = delay 10 >> forever - -terminates :: IO String -terminates = delay 1 >> pure "terminates" - -delay s = threadDelay (1000000 * s) - -async :: IO a -> IO (STM a) -async a = do - var <- atomically (newTVar Nothing) - forkIO (a >>= atomically . writeTVar var . Just) - pure (readTVar var >>= maybe retry pure) - -main :: IO () -main = do - x <- mapM async $ terminates : replicate 50000 forever - r <- atomically (foldr1 orElse x) - print r ===================================== testsuite/tests/lib/stm/T26028.stdout deleted ===================================== @@ -1 +0,0 @@ -"terminates" ===================================== testsuite/tests/lib/stm/all.T deleted ===================================== @@ -1 +0,0 @@ -test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b5d9d474631f14380cf05acb9c66af… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b5d9d474631f14380cf05acb9c66af… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/TTG-bytestring
by recursion-ninja (＠recursion-ninja) 25 Aug '25

25 Aug '25

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

1 0

[Git][ghc/ghc][wip/14554-wasm-fix] Read Toolchain.Target files rather than 'settings'
by Cheng Shao (＠TerrorJack) 25 Aug '25

25 Aug '25

Cheng Shao pushed to branch wip/14554-wasm-fix at Glasgow Haskell Compiler / GHC Commits: c5f031f3 by Rodrigo Mesquita at 2025-08-23T19:21:31+02:00 Read Toolchain.Target files rather than 'settings' This commit makes GHC read `lib/targets/default.target`, a file with a serialized value of `ghc-toolchain`'s `GHC.Toolchain.Target`. Moreover, it removes all the now-redundant entries from `lib/settings` that are configured as part of a `Target` but were being written into `settings`. This makes it easier to support multiple targets from the same compiler (aka runtime retargetability). `ghc-toolchain` can be re-run many times standalone to produce a `Target` description for different targets, and, in the future, GHC will be able to pick at runtime amongst different `Target` files. This commit only makes it read the default `Target` configured in-tree or configured when installing the bindist. The remaining bits of `settings` need to be moved to `Target` in follow up commits, but ultimately they all should be moved since they are per-target relevant. Fixes #24212 On Windows, the constant overhead of parsing a slightly more complex data structure causes some small-allocation tests to wiggle around 1 to 2 extra MB (1-2% in these cases). ------------------------- Metric Increase: MultiLayerModulesTH_OneShot T10421 T10547 T12234 T12425 T13035 T18140 T18923 T9198 TcPlugin_RewritePerf ------------------------- - - - - - 30 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - compiler/GHC/SysTools/BaseDir.hs - compiler/ghc.cabal.in - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Base.hs - hadrian/src/Rules/Generate.hs - libraries/ghc-boot/GHC/Settings/Utils.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs - − m4/fp_settings.m4 - m4/fp_setup_windows_toolchain.m4 - + m4/subst_tooldir.m4 - mk/hsc2hs.in - testsuite/tests/ghc-api/T20757.hs - testsuite/tests/ghc-api/settings-escape/T24265.hs - testsuite/tests/ghc-api/settings-escape/T24265.stderr - + testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in - utils/ghc-toolchain/exe/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -146,6 +146,7 @@ import qualified Data.Set as Set import GHC.Types.Unique.Set import qualified GHC.LanguageExtensions as LangExt +import GHC.Toolchain.Target (Target) -- ----------------------------------------------------------------------------- -- DynFlags @@ -179,6 +180,7 @@ data DynFlags = DynFlags { toolSettings :: {-# UNPACK #-} !ToolSettings, platformMisc :: {-# UNPACK #-} !PlatformMisc, rawSettings :: [(String, String)], + rawTarget :: Target, tmpDir :: TempDir, llvmOptLevel :: Int, -- ^ LLVM optimisation level @@ -657,6 +659,7 @@ defaultDynFlags mySettings = targetPlatform = sTargetPlatform mySettings, platformMisc = sPlatformMisc mySettings, rawSettings = sRawSettings mySettings, + rawTarget = sRawTarget mySettings, tmpDir = panic "defaultDynFlags: uninitialized tmpDir", ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -280,6 +280,9 @@ import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..)) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) +import GHC.Toolchain +import GHC.Toolchain.Program + import Data.IORef import Control.Arrow ((&&&)) import Control.Monad @@ -404,6 +407,7 @@ settings dflags = Settings , sToolSettings = toolSettings dflags , sPlatformMisc = platformMisc dflags , sRawSettings = rawSettings dflags + , sRawTarget = rawTarget dflags } pgm_L :: DynFlags -> String @@ -3455,9 +3459,58 @@ compilerInfo dflags -- Next come the settings, so anything else can be overridden -- in the settings file (as "lookup" uses the first match for the -- key) - : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) - (rawSettings dflags) - ++ [("Project version", projectVersion dflags), + : map (fmap expandDirectories) + (rawSettings dflags) + ++ + [("C compiler command", queryCmd $ ccProgram . tgtCCompiler), + ("C compiler flags", queryFlags $ ccProgram . tgtCCompiler), + ("C++ compiler command", queryCmd $ cxxProgram . tgtCxxCompiler), + ("C++ compiler flags", queryFlags $ cxxProgram . tgtCxxCompiler), + ("C compiler link flags", queryFlags $ ccLinkProgram . tgtCCompilerLink), + ("C compiler supports -no-pie", queryBool $ ccLinkSupportsNoPie . tgtCCompilerLink), + ("CPP command", queryCmd $ cppProgram . tgtCPreprocessor), + ("CPP flags", queryFlags $ cppProgram . tgtCPreprocessor), + ("Haskell CPP command", queryCmd $ hsCppProgram . tgtHsCPreprocessor), + ("Haskell CPP flags", queryFlags $ hsCppProgram . tgtHsCPreprocessor), + ("JavaScript CPP command", queryCmdMaybe jsCppProgram tgtJsCPreprocessor), + ("JavaScript CPP flags", queryFlagsMaybe jsCppProgram tgtJsCPreprocessor), + ("C-- CPP command", queryCmd $ cmmCppProgram . tgtCmmCPreprocessor), + ("C-- CPP flags", queryFlags $ cmmCppProgram . tgtCmmCPreprocessor), + ("C-- CPP supports -g0", queryBool $ cmmCppSupportsG0 . tgtCmmCPreprocessor), + ("ld supports compact unwind", queryBool $ ccLinkSupportsCompactUnwind . tgtCCompilerLink), + ("ld supports filelist", queryBool $ ccLinkSupportsFilelist . tgtCCompilerLink), + ("ld supports single module", queryBool $ ccLinkSupportsSingleModule . tgtCCompilerLink), + ("ld is GNU ld", queryBool $ ccLinkIsGnu . tgtCCompilerLink), + ("Merge objects command", queryCmdMaybe mergeObjsProgram tgtMergeObjs), + ("Merge objects flags", queryFlagsMaybe mergeObjsProgram tgtMergeObjs), + ("Merge objects supports response files", queryBool $ maybe False mergeObjsSupportsResponseFiles . tgtMergeObjs), + ("ar command", queryCmd $ arMkArchive . tgtAr), + ("ar flags", queryFlags $ arMkArchive . tgtAr), + ("ar supports at file", queryBool $ arSupportsAtFile . tgtAr), + ("ar supports -L", queryBool $ arSupportsDashL . tgtAr), + ("ranlib command", queryCmdMaybe ranlibProgram tgtRanlib), + ("otool command", queryCmdMaybe id tgtOtool), + ("install_name_tool command", queryCmdMaybe id tgtInstallNameTool), + ("windres command", queryCmd $ fromMaybe (Program "/bin/false" []) . tgtWindres), + ("cross compiling", queryBool (not . tgtLocallyExecutable)), + ("target platform string", query targetPlatformTriple), + ("target os", query (show . archOS_OS . tgtArchOs)), + ("target arch", query (show . archOS_arch . tgtArchOs)), + ("target word size", query $ show . wordSize2Bytes . tgtWordSize), + ("target word big endian", queryBool $ (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness), + ("target has GNU nonexec stack", queryBool tgtSupportsGnuNonexecStack), + ("target has .ident directive", queryBool tgtSupportsIdentDirective), + ("target has subsections via symbols", queryBool tgtSupportsSubsectionsViaSymbols), + ("Unregisterised", queryBool tgtUnregisterised), + ("LLVM target", query tgtLlvmTarget), + ("LLVM llc command", queryCmdMaybe id tgtLlc), + ("LLVM opt command", queryCmdMaybe id tgtOpt), + ("LLVM llvm-as command", queryCmdMaybe id tgtLlvmAs), + ("LLVM llvm-as flags", queryFlagsMaybe id tgtLlvmAs), + ("Tables next to code", queryBool tgtTablesNextToCode), + ("Leading underscore", queryBool tgtSymbolsHaveLeadingUnderscore) + ] ++ + [("Project version", projectVersion dflags), ("Project Git commit id", cProjectGitCommitId), ("Project Version Int", cProjectVersionInt), ("Project Patch Level", cProjectPatchLevel), @@ -3514,9 +3567,16 @@ compilerInfo dflags showBool False = "NO" platform = targetPlatform dflags isWindows = platformOS platform == OSMinGW32 - useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags - expandDirectories :: FilePath -> Maybe FilePath -> String -> String - expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd + expandDirectories = expandToolDir (toolDir dflags) . expandTopDir (topDir dflags) + query :: (Target -> a) -> a + query f = f (rawTarget dflags) + queryFlags f = query (unwords . map escapeArg . prgFlags . f) + queryCmd f = expandDirectories (query (prgPath . f)) + queryBool = showBool . query + + queryCmdMaybe, queryFlagsMaybe :: (a -> Program) -> (Target -> Maybe a) -> String + queryCmdMaybe p f = expandDirectories (query (maybe "" (prgPath . p) . f)) + queryFlagsMaybe p f = query (maybe "" (unwords . map escapeArg . prgFlags . p) . f) -- Note [Special unit-ids] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -3844,3 +3904,19 @@ updatePlatformConstants dflags mconstants = do let platform1 = (targetPlatform dflags) { platform_constants = mconstants } let dflags1 = dflags { targetPlatform = platform1 } return dflags1 + +-- ---------------------------------------------------------------------------- +-- Escape Args helpers +-- ---------------------------------------------------------------------------- + +-- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs ===================================== compiler/GHC/Settings.hs ===================================== @@ -23,7 +23,6 @@ module GHC.Settings , sMergeObjsSupportsResponseFiles , sLdIsGnuLd , sGccSupportsNoPie - , sUseInplaceMinGW , sArSupportsDashL , sPgm_L , sPgm_P @@ -75,6 +74,7 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform import GHC.Unit.Types +import GHC.Toolchain.Target data Settings = Settings { sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion @@ -87,6 +87,10 @@ data Settings = Settings -- You shouldn't need to look things up in rawSettings directly. -- They should have their own fields instead. , sRawSettings :: [(String, String)] + + -- Store the target to print out information about the raw target description + -- (e.g. in --info) + , sRawTarget :: Target } data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId } @@ -102,7 +106,6 @@ data ToolSettings = ToolSettings , toolSettings_mergeObjsSupportsResponseFiles :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool - , toolSettings_useInplaceMinGW :: Bool , toolSettings_arSupportsDashL :: Bool , toolSettings_cmmCppSupportsG0 :: Bool @@ -221,8 +224,6 @@ sLdIsGnuLd :: Settings -> Bool sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool sGccSupportsNoPie = toolSettings_ccSupportsNoPie . sToolSettings -sUseInplaceMinGW :: Settings -> Bool -sUseInplaceMinGW = toolSettings_useInplaceMinGW . sToolSettings sArSupportsDashL :: Settings -> Bool sArSupportsDashL = toolSettings_arSupportsDashL . sToolSettings ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -1,4 +1,4 @@ - +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,18 +16,20 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform import GHC.Utils.Panic -import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir import GHC.Unit.Types import Control.Monad.Trans.Except import Control.Monad.IO.Class -import Data.Char import qualified Data.Map as Map import System.FilePath import System.Directory +import GHC.Toolchain.Program +import GHC.Toolchain +import GHC.Data.Maybe +import Data.Bifunctor (Bifunctor(second)) data SettingsError = SettingsError_MissingData String @@ -44,6 +46,7 @@ initSettings top_dir = do libexec :: FilePath -> FilePath libexec file = top_dir </> ".." </> "bin" </> file settingsFile = installed "settings" + targetFile = installed $ "targets" </> "default.target" readFileSafe :: FilePath -> ExceptT SettingsError m String readFileSafe path = liftIO (doesFileExist path) >>= \case @@ -55,85 +58,72 @@ initSettings top_dir = do Just s -> pure s Nothing -> throwE $ SettingsError_BadData $ "Can't parse " ++ show settingsFile + targetStr <- readFileSafe targetFile + target <- case maybeReadFuzzy @Target targetStr of + Just s -> pure s + Nothing -> throwE $ SettingsError_BadData $ + "Can't parse as Target " ++ show targetFile let mySettings = Map.fromList settingsList getBooleanSetting :: String -> ExceptT SettingsError m Bool getBooleanSetting key = either pgmError pure $ getRawBooleanSetting settingsFile mySettings key - -- On Windows, by mingw is often distributed with GHC, - -- so we look in TopDir/../mingw/bin, - -- as well as TopDir/../../mingw/bin for hadrian. - -- But we might be disabled, in which we we don't do that. - useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain" - -- see Note [topdir: How GHC finds its files] -- NB: top_dir is assumed to be in standard Unix -- format, '/' separated - mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir + mtool_dir <- liftIO $ findToolDir top_dir -- see Note [tooldir: How GHC finds mingw on Windows] - -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally - -- introduce unescaped spaces. See #24265 and #25204. - let escaped_top_dir = escapeArg top_dir - escaped_mtool_dir = fmap escapeArg mtool_dir - - getSetting_raw key = either pgmError pure $ + let getSetting_raw key = either pgmError pure $ getRawSetting settingsFile mySettings key getSetting_topDir top key = either pgmError pure $ getRawFilePathSetting top settingsFile mySettings key getSetting_toolDir top tool key = - expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key - - getSetting :: String -> ExceptT SettingsError m String + expandToolDir tool <$> getSetting_topDir top key getSetting key = getSetting_topDir top_dir key - getToolSetting :: String -> ExceptT SettingsError m String getToolSetting key = getSetting_toolDir top_dir mtool_dir key - getFlagsSetting :: String -> ExceptT SettingsError m [String] - getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key - -- Make sure to unescape, as we have escaped top_dir and tool_dir. + + expandDirVars top tool = expandToolDir tool . expandTopDir top + + getToolPath :: (Target -> Program) -> String + getToolPath key = expandDirVars top_dir mtool_dir (prgPath . key $ target) + + getMaybeToolPath :: (Target -> Maybe Program) -> String + getMaybeToolPath key = getToolPath (fromMaybe (Program "" []) . key) + + getToolFlags :: (Target -> Program) -> [String] + getToolFlags key = expandDirVars top_dir mtool_dir <$> (prgFlags . key $ target) + + getTool :: (Target -> Program) -> (String, [String]) + getTool key = (getToolPath key, getToolFlags key) -- See Note [Settings file] for a little more about this file. We're -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light. - targetPlatformString <- getSetting_raw "target platform string" - cc_prog <- getToolSetting "C compiler command" - cxx_prog <- getToolSetting "C++ compiler command" - cc_args0 <- getFlagsSetting "C compiler flags" - cxx_args <- getFlagsSetting "C++ compiler flags" - gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" - cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0" - cpp_prog <- getToolSetting "CPP command" - cpp_args <- map Option <$> getFlagsSetting "CPP flags" - hs_cpp_prog <- getToolSetting "Haskell CPP command" - hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags" - js_cpp_prog <- getToolSetting "JavaScript CPP command" - js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags" - cmmCpp_prog <- getToolSetting "C-- CPP command" - cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags" - - platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings - - let unreg_cc_args = if platformUnregisterised platform - then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] - else [] - cc_args = cc_args0 ++ unreg_cc_args - - -- The extra flags we need to pass gcc when we invoke it to compile .hc code. - -- - -- -fwrapv is needed for gcc to emit well-behaved code in the presence of - -- integer wrap around (#952). - extraGccViaCFlags = if platformUnregisterised platform - -- configure guarantees cc support these flags - then ["-fwrapv", "-fno-builtin"] - else [] - - ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" - ldSupportsFilelist <- getBooleanSetting "ld supports filelist" - ldSupportsSingleModule <- getBooleanSetting "ld supports single module" - mergeObjsSupportsResponseFiles <- getBooleanSetting "Merge objects supports response files" - ldIsGnuLd <- getBooleanSetting "ld is GNU ld" - arSupportsDashL <- getBooleanSetting "ar supports -L" - + targetHasLibm <- getBooleanSetting "target has libm" + let + (cc_prog, cc_args0) = getTool (ccProgram . tgtCCompiler) + (cxx_prog, cxx_args) = getTool (cxxProgram . tgtCxxCompiler) + (cpp_prog, cpp_args) = getTool (cppProgram . tgtCPreprocessor) + (hs_cpp_prog, hs_cpp_args) = getTool (hsCppProgram . tgtHsCPreprocessor) + (js_cpp_prog, js_cpp_args) = getTool (maybe (Program "" []) jsCppProgram . tgtJsCPreprocessor) + (cmmCpp_prog, cmmCpp_args) = getTool (cmmCppProgram . tgtCmmCPreprocessor) + + platform = getTargetPlatform targetHasLibm target + + unreg_cc_args = if platformUnregisterised platform + then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] + else [] + cc_args = cc_args0 ++ unreg_cc_args + + -- The extra flags we need to pass gcc when we invoke it to compile .hc code. + -- + -- -fwrapv is needed for gcc to emit well-behaved code in the presence of + -- integer wrap around (#952). + extraGccViaCFlags = if platformUnregisterised platform + -- configure guarantees cc support these flags + then ["-fwrapv", "-fno-builtin"] + else [] -- The package database is either a relative path to the location of the settings file -- OR an absolute path. @@ -148,41 +138,20 @@ initSettings top_dir = do -- architecture-specific stuff is done when building Config.hs unlit_path <- getToolSetting "unlit command" - windres_path <- getToolSetting "windres command" - ar_path <- getToolSetting "ar command" - otool_path <- getToolSetting "otool command" - install_name_tool_path <- getToolSetting "install_name_tool command" - ranlib_path <- getToolSetting "ranlib command" - - -- HACK, see setPgmP below. We keep 'words' here to remember to fix - -- Config.hs one day. - - - -- Other things being equal, 'as' and 'ld' are simply 'gcc' - cc_link_args <- getFlagsSetting "C compiler link flags" - let as_prog = cc_prog - as_args = map Option cc_args - ld_prog = cc_prog - ld_args = map Option (cc_args ++ cc_link_args) - ld_r_prog <- getToolSetting "Merge objects command" - ld_r_args <- getFlagsSetting "Merge objects flags" - let ld_r - | null ld_r_prog = Nothing - | otherwise = Just (ld_r_prog, map Option ld_r_args) - - llvmTarget <- getSetting_raw "LLVM target" - - -- We just assume on command line - lc_prog <- getToolSetting "LLVM llc command" - lo_prog <- getToolSetting "LLVM opt command" - las_prog <- getToolSetting "LLVM llvm-as command" - las_args <- map Option <$> getFlagsSetting "LLVM llvm-as flags" - - let iserv_prog = libexec "ghc-iserv" + -- Other things being equal, 'as' is simply 'gcc' + let (cc_link, cc_link_args) = getTool (ccLinkProgram . tgtCCompilerLink) + as_prog = cc_prog + as_args = map Option cc_args + ld_prog = cc_link + ld_args = map Option (cc_args ++ cc_link_args) + ld_r = do + ld_r_prog <- tgtMergeObjs target + let (ld_r_path, ld_r_args) = getTool (mergeObjsProgram . const ld_r_prog) + pure (ld_r_path, map Option ld_r_args) + iserv_prog = libexec "ghc-iserv" targetRTSLinkerOnlySupportsSharedLibs <- getBooleanSetting "target RTS linker only supports shared libraries" ghcWithInterpreter <- getBooleanSetting "Use interpreter" - useLibFFI <- getBooleanSetting "Use LibFFI" baseUnitId <- getSetting_raw "base unit-id" @@ -206,36 +175,38 @@ initSettings top_dir = do } , sToolSettings = ToolSettings - { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind - , toolSettings_ldSupportsFilelist = ldSupportsFilelist - , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule - , toolSettings_mergeObjsSupportsResponseFiles = mergeObjsSupportsResponseFiles - , toolSettings_ldIsGnuLd = ldIsGnuLd - , toolSettings_ccSupportsNoPie = gccSupportsNoPie - , toolSettings_useInplaceMinGW = useInplaceMinGW - , toolSettings_arSupportsDashL = arSupportsDashL - , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 - - , toolSettings_pgm_L = unlit_path - , toolSettings_pgm_P = (hs_cpp_prog, hs_cpp_args) - , toolSettings_pgm_JSP = (js_cpp_prog, js_cpp_args) - , toolSettings_pgm_CmmP = (cmmCpp_prog, cmmCpp_args) - , toolSettings_pgm_F = "" - , toolSettings_pgm_c = cc_prog - , toolSettings_pgm_cxx = cxx_prog - , toolSettings_pgm_cpp = (cpp_prog, cpp_args) - , toolSettings_pgm_a = (as_prog, as_args) - , toolSettings_pgm_l = (ld_prog, ld_args) - , toolSettings_pgm_lm = ld_r - , toolSettings_pgm_windres = windres_path - , toolSettings_pgm_ar = ar_path - , toolSettings_pgm_otool = otool_path - , toolSettings_pgm_install_name_tool = install_name_tool_path - , toolSettings_pgm_ranlib = ranlib_path - , toolSettings_pgm_lo = (lo_prog,[]) - , toolSettings_pgm_lc = (lc_prog,[]) - , toolSettings_pgm_las = (las_prog, las_args) - , toolSettings_pgm_i = iserv_prog + { toolSettings_ldSupportsCompactUnwind = ccLinkSupportsCompactUnwind $ tgtCCompilerLink target + , toolSettings_ldSupportsFilelist = ccLinkSupportsFilelist $ tgtCCompilerLink target + , toolSettings_ldSupportsSingleModule = ccLinkSupportsSingleModule $ tgtCCompilerLink target + , toolSettings_ldIsGnuLd = ccLinkIsGnu $ tgtCCompilerLink target + , toolSettings_ccSupportsNoPie = ccLinkSupportsNoPie $ tgtCCompilerLink target + , toolSettings_mergeObjsSupportsResponseFiles + = maybe False mergeObjsSupportsResponseFiles + $ tgtMergeObjs target + , toolSettings_arSupportsDashL = arSupportsDashL $ tgtAr target + , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 $ tgtCmmCPreprocessor target + + , toolSettings_pgm_L = unlit_path + , toolSettings_pgm_P = (hs_cpp_prog, map Option hs_cpp_args) + , toolSettings_pgm_JSP = (js_cpp_prog, map Option js_cpp_args) + , toolSettings_pgm_CmmP = (cmmCpp_prog, map Option cmmCpp_args) + , toolSettings_pgm_F = "" + , toolSettings_pgm_c = cc_prog + , toolSettings_pgm_cxx = cxx_prog + , toolSettings_pgm_cpp = (cpp_prog, map Option cpp_args) + , toolSettings_pgm_a = (as_prog, as_args) + , toolSettings_pgm_l = (ld_prog, ld_args) + , toolSettings_pgm_lm = ld_r + , toolSettings_pgm_windres = getMaybeToolPath tgtWindres + , toolSettings_pgm_ar = getToolPath (arMkArchive . tgtAr) + , toolSettings_pgm_otool = getMaybeToolPath tgtOtool + , toolSettings_pgm_install_name_tool = getMaybeToolPath tgtInstallNameTool + , toolSettings_pgm_ranlib = getMaybeToolPath (fmap ranlibProgram . tgtRanlib) + , toolSettings_pgm_lo = (getMaybeToolPath tgtOpt,[]) + , toolSettings_pgm_lc = (getMaybeToolPath tgtLlc,[]) + , toolSettings_pgm_las = second (map Option) $ + getTool (fromMaybe (Program "" []) . tgtLlvmAs) + , toolSettings_pgm_i = iserv_prog , toolSettings_opt_L = [] , toolSettings_opt_P = [] , toolSettings_opt_JSP = [] @@ -260,65 +231,30 @@ initSettings top_dir = do , sTargetPlatform = platform , sPlatformMisc = PlatformMisc - { platformMisc_targetPlatformString = targetPlatformString + { platformMisc_targetPlatformString = targetPlatformTriple target , platformMisc_ghcWithInterpreter = ghcWithInterpreter - , platformMisc_libFFI = useLibFFI - , platformMisc_llvmTarget = llvmTarget + , platformMisc_libFFI = tgtUseLibffiForAdjustors target + , platformMisc_llvmTarget = tgtLlvmTarget target , platformMisc_targetRTSLinkerOnlySupportsSharedLibs = targetRTSLinkerOnlySupportsSharedLibs } , sRawSettings = settingsList + , sRawTarget = target } -getTargetPlatform - :: FilePath -- ^ Settings filepath (for error messages) - -> RawSettings -- ^ Raw settings file contents - -> Either String Platform -getTargetPlatform settingsFile settings = do - let - getBooleanSetting = getRawBooleanSetting settingsFile settings - readSetting :: (Show a, Read a) => String -> Either String a - readSetting = readRawSetting settingsFile settings - - targetArchOS <- getTargetArchOS settingsFile settings - targetWordSize <- readSetting "target word size" - targetWordBigEndian <- getBooleanSetting "target word big endian" - targetLeadingUnderscore <- getBooleanSetting "Leading underscore" - targetUnregisterised <- getBooleanSetting "Unregisterised" - targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack" - targetHasIdentDirective <- getBooleanSetting "target has .ident directive" - targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols" - targetHasLibm <- getBooleanSetting "target has libm" - crossCompiling <- getBooleanSetting "cross compiling" - tablesNextToCode <- getBooleanSetting "Tables next to code" - - pure $ Platform - { platformArchOS = targetArchOS - , platformWordSize = targetWordSize - , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian - , platformUnregisterised = targetUnregisterised - , platformHasGnuNonexecStack = targetHasGnuNonexecStack - , platformHasIdentDirective = targetHasIdentDirective - , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols - , platformIsCrossCompiling = crossCompiling - , platformLeadingUnderscore = targetLeadingUnderscore - , platformTablesNextToCode = tablesNextToCode +getTargetPlatform :: Bool {-^ Does target have libm -} -> Target -> Platform +getTargetPlatform targetHasLibm Target{..} = Platform + { platformArchOS = tgtArchOs + , platformWordSize = case tgtWordSize of WS4 -> PW4 + WS8 -> PW8 + , platformByteOrder = tgtEndianness + , platformUnregisterised = tgtUnregisterised + , platformHasGnuNonexecStack = tgtSupportsGnuNonexecStack + , platformHasIdentDirective = tgtSupportsIdentDirective + , platformHasSubsectionsViaSymbols = tgtSupportsSubsectionsViaSymbols + , platformIsCrossCompiling = not tgtLocallyExecutable + , platformLeadingUnderscore = tgtSymbolsHaveLeadingUnderscore + , platformTablesNextToCode = tgtTablesNextToCode , platformHasLibm = targetHasLibm , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit } - --- ---------------------------------------------------------------------------- --- Escape Args helpers --- ---------------------------------------------------------------------------- - --- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base. -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs ===================================== compiler/GHC/SysTools/BaseDir.hs ===================================== @@ -90,13 +90,10 @@ the build system finds and wires through the toolchain information. 3) The next step is to generate the settings file: The file `cfg/system.config.in` is preprocessed by configure and the output written to `system.config`. This serves the same purpose as `config.mk` but it rewrites - the values that were exported. As an example `SettingsCCompilerCommand` is - rewritten to `settings-c-compiler-command`. + the values that were exported. Next up is `src/Oracles/Settings.hs` which makes from some Haskell ADT to - the settings `keys` in the `system.config`. As an example, - `settings-c-compiler-command` is mapped to - `SettingsFileSetting_CCompilerCommand`. + the settings `keys` in the `system.config`. The last part of this is the `generateSettings` in `src/Rules/Generate.hs` which produces the desired settings file out of Hadrian. This is the @@ -122,15 +119,13 @@ play nice with the system compiler instead. -- | Expand occurrences of the @$tooldir@ interpolation in a string -- on Windows, leave the string untouched otherwise. expandToolDir - :: Bool -- ^ whether we use the ambient mingw toolchain - -> Maybe FilePath -- ^ tooldir + :: Maybe FilePath -- ^ tooldir -> String -> String #if defined(mingw32_HOST_OS) -expandToolDir False (Just tool_dir) s = expandPathVar "tooldir" tool_dir s -expandToolDir False Nothing _ = panic "Could not determine $tooldir" -expandToolDir True _ s = s +expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s +expandToolDir Nothing _ = panic "Could not determine $tooldir" #else -expandToolDir _ _ s = s +expandToolDir _ s = s #endif -- | Returns a Unix-format path pointing to TopDir. @@ -164,13 +159,13 @@ tryFindTopDir Nothing -- Returns @Nothing@ when not on Windows. -- When called on Windows, it either throws an error when the -- tooldir can't be located, or returns @Just tooldirpath@. --- If the distro toolchain is being used we treat Windows the same as Linux +-- If the distro toolchain is being used, there will be no variables to +-- substitute for anyway, so this is a no-op. findToolDir - :: Bool -- ^ whether we use the ambient mingw toolchain - -> FilePath -- ^ topdir + :: FilePath -- ^ topdir -> IO (Maybe FilePath) #if defined(mingw32_HOST_OS) -findToolDir False top_dir = go 0 (top_dir </> "..") [] +findToolDir top_dir = go 0 (top_dir </> "..") [] where maxDepth = 3 go :: Int -> FilePath -> [FilePath] -> IO (Maybe FilePath) go k path tried @@ -183,7 +178,6 @@ findToolDir False top_dir = go 0 (top_dir </> "..") [] if oneLevel then return (Just path) else go (k+1) (path </> "..") tried' -findToolDir True _ = return Nothing #else -findToolDir _ _ = return Nothing +findToolDir _ = return Nothing #endif ===================================== compiler/ghc.cabal.in ===================================== @@ -131,6 +131,7 @@ Library semaphore-compat, stm, rts, + ghc-toolchain, ghc-boot == @ProjectVersionMunged@, ghc-heap == @ProjectVersionMunged@, ghci == @ProjectVersionMunged@ ===================================== configure.ac ===================================== @@ -132,6 +132,7 @@ AC_ARG_ENABLE(distro-toolchain, [FP_CAPITALIZE_YES_NO(["$enableval"], [EnableDistroToolchain])], [EnableDistroToolchain=NO] ) +AC_SUBST([EnableDistroToolchain]) if test "$EnableDistroToolchain" = "YES"; then TarballsAutodownload=NO @@ -760,8 +761,6 @@ FP_PROG_AR_NEEDS_RANLIB dnl ** Check to see whether ln -s works AC_PROG_LN_S -FP_SETTINGS - dnl ** Find the path to sed AC_PATH_PROGS(SedCmd,gsed sed,sed) ===================================== distrib/configure.ac.in ===================================== @@ -89,8 +89,9 @@ AC_ARG_ENABLE(distro-toolchain, [AS_HELP_STRING([--enable-distro-toolchain], [Do not use bundled Windows toolchain binaries.])], [FP_CAPITALIZE_YES_NO(["$enableval"], [EnableDistroToolchain])], - [EnableDistroToolchain=@SettingsUseDistroMINGW@] + [EnableDistroToolchain=@EnableDistroToolchain@] ) +AC_SUBST([EnableDistroToolchain]) if test "$HostOS" = "mingw32" -a "$EnableDistroToolchain" = "NO"; then FP_SETUP_WINDOWS_TOOLCHAIN([$hardtop/mingw/], [\$\$topdir/../mingw/]) @@ -384,8 +385,6 @@ fi AC_SUBST(BaseUnitId) -FP_SETTINGS - # We get caught by # http://savannah.gnu.org/bugs/index.php?1516 # $(eval ...) inside conditionals causes errors @@ -418,6 +417,34 @@ AC_OUTPUT VALIDATE_GHC_TOOLCHAIN([default.target],[default.target.ghc-toolchain]) +if test "$EnableDistroToolchain" = "YES"; then + # If the user specified --enable-distro-toolchain then we just use the + # executable names, not paths. We do this by finding strings of paths to + # programs and keeping the basename only: + cp default.target default.target.bak + + while IFS= read -r line; do + if echo "$line" | grep -q 'prgPath = "'; then + path=$(echo "$line" | sed -E 's/.*prgPath = "([[^"]]+)".*/\1/') + base=$(basename "$path") + echo "$line" | sed "s|$path|$base|" + else + echo "$line" + fi + done < default.target.bak > default.target + echo "Applied --enable-distro-toolchain basename substitution to default.target:" + cat default.target +fi + +if test "$windows" = YES -a "$EnableDistroToolchain" = "NO"; then + # Handle the Windows toolchain installed in FP_SETUP_WINDOWS_TOOLCHAIN. + # We need to issue a substitution to use $tooldir, + # See Note [tooldir: How GHC finds mingw on Windows] + SUBST_TOOLDIR([default.target]) + echo "Applied tooldir substitution to default.target:" + cat default.target +fi + rm -Rf acargs acghc-toolchain actmp-ghc-toolchain echo "****************************************************" ===================================== hadrian/bindist/Makefile ===================================== @@ -85,67 +85,22 @@ WrapperBinsDir=${bindir} # N.B. this is duplicated from includes/ghc.mk. lib/settings : config.mk @rm -f $@ - @echo '[("C compiler command", "$(SettingsCCompilerCommand)")' >> $@ - @echo ',("C compiler flags", "$(SettingsCCompilerFlags)")' >> $@ - @echo ',("C++ compiler command", "$(SettingsCxxCompilerCommand)")' >> $@ - @echo ',("C++ compiler flags", "$(SettingsCxxCompilerFlags)")' >> $@ - @echo ',("C compiler link flags", "$(SettingsCCompilerLinkFlags)")' >> $@ - @echo ',("C compiler supports -no-pie", "$(SettingsCCompilerSupportsNoPie)")' >> $@ - @echo ',("CPP command", "$(SettingsCPPCommand)")' >> $@ - @echo ',("CPP flags", "$(SettingsCPPFlags)")' >> $@ - @echo ',("Haskell CPP command", "$(SettingsHaskellCPPCommand)")' >> $@ - @echo ',("Haskell CPP flags", "$(SettingsHaskellCPPFlags)")' >> $@ - @echo ',("JavaScript CPP command", "$(SettingsJavaScriptCPPCommand)")' >> $@ - @echo ',("JavaScript CPP flags", "$(SettingsJavaScriptCPPFlags)")' >> $@ - @echo ',("C-- CPP command", "$(SettingsCmmCPPCommand)")' >> $@ - @echo ',("C-- CPP flags", "$(SettingsCmmCPPFlags)")' >> $@ - @echo ',("C-- CPP supports -g0", "$(SettingsCmmCPPSupportsG0)")' >> $@ - @echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@ - @echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@ - @echo ',("ld supports single module", "$(LdHasSingleModule)")' >> $@ - @echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@ - @echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@ - @echo ',("Merge objects flags", "$(SettingsMergeObjectsFlags)")' >> $@ - @echo ',("Merge objects supports response files", "$(MergeObjsSupportsResponseFiles)")' >> $@ - @echo ',("ar command", "$(SettingsArCommand)")' >> $@ - @echo ',("ar flags", "$(ArArgs)")' >> $@ - @echo ',("ar supports at file", "$(ArSupportsAtFile)")' >> $@ - @echo ',("ar supports -L", "$(ArSupportsDashL)")' >> $@ - @echo ',("ranlib command", "$(SettingsRanlibCommand)")' >> $@ - @echo ',("otool command", "$(SettingsOtoolCommand)")' >> $@ - @echo ',("install_name_tool command", "$(SettingsInstallNameToolCommand)")' >> $@ - @echo ',("windres command", "$(SettingsWindresCommand)")' >> $@ + @echo '[("target has libm", "$(TargetHasLibm)")' >> $@ @echo ',("unlit command", "$$topdir/../bin/$(CrossCompilePrefix)unlit")' >> $@ - @echo ',("cross compiling", "$(CrossCompiling)")' >> $@ - @echo ',("target platform string", "$(TARGETPLATFORM)")' >> $@ - @echo ',("target os", "$(HaskellTargetOs)")' >> $@ - @echo ',("target arch", "$(HaskellTargetArch)")' >> $@ - @echo ',("target word size", "$(TargetWordSize)")' >> $@ - @echo ',("target word big endian", "$(TargetWordBigEndian)")' >> $@ - @echo ',("target has GNU nonexec stack", "$(TargetHasGnuNonexecStack)")' >> $@ - @echo ',("target has .ident directive", "$(TargetHasIdentDirective)")' >> $@ - @echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@ - @echo ',("target has libm", "$(TargetHasLibm)")' >> $@ - @echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@ - @echo ',("LLVM target", "$(LLVMTarget)")' >> $@ - @echo ',("LLVM llc command", "$(SettingsLlcCommand)")' >> $@ - @echo ',("LLVM opt command", "$(SettingsOptCommand)")' >> $@ - @echo ',("LLVM llvm-as command", "$(SettingsLlvmAsCommand)")' >> $@ - @echo ',("LLVM llvm-as flags", "$(SettingsLlvmAsFlags)")' >> $@ - @echo ',("Use inplace MinGW toolchain", "$(SettingsUseDistroMINGW)")' >> $@ - @echo @echo ',("target RTS linker only supports shared libraries", "$(TargetRTSLinkerOnlySupportsSharedLibs)")' >> $@ @echo ',("Use interpreter", "$(GhcWithInterpreter)")' >> $@ @echo ',("Support SMP", "$(GhcWithSMP)")' >> $@ @echo ',("RTS ways", "$(GhcRTSWays)")' >> $@ - @echo ',("Tables next to code", "$(TablesNextToCode)")' >> $@ - @echo ',("Leading underscore", "$(LeadingUnderscore)")' >> $@ - @echo ',("Use LibFFI", "$(UseLibffiForAdjustors)")' >> $@ @echo ',("RTS expects libdw", "$(GhcRtsWithLibdw)")' >> $@ @echo ',("Relative Global Package DB", "package.conf.d")' >> $@ @echo ',("base unit-id", "$(BaseUnitId)")' >> $@ @echo "]" >> $@ +lib/targets/default.target : config.mk default.target + @rm -f $@ + @echo "Copying the bindist-configured default.target to lib/targets/default.target" + cp default.target $@ + # We need to install binaries relative to libraries. BINARIES = $(wildcard ./bin/*) .PHONY: install_bin_libdir @@ -167,7 +122,7 @@ install_bin_direct: $(INSTALL_PROGRAM) ./bin/* "$(DESTDIR)$(WrapperBinsDir)/" .PHONY: install_lib -install_lib: lib/settings +install_lib: lib/settings lib/targets/default.target @echo "Copying libraries to $(DESTDIR)$(ActualLibsDir)" $(INSTALL_DIR) "$(DESTDIR)$(ActualLibsDir)" ===================================== hadrian/bindist/config.mk.in ===================================== @@ -133,7 +133,7 @@ INSTALL_DIR = $(INSTALL) -m 755 -d CrossCompiling = @CrossCompiling@ CrossCompilePrefix = @CrossCompilePrefix@ GhcUnregisterised = @Unregisterised@ -EnableDistroToolchain = @SettingsUseDistroMINGW@ +EnableDistroToolchain = @EnableDistroToolchain@ BaseUnitId = @BaseUnitId@ # The THREADED_RTS requires `BaseReg` to be in a register and the @@ -205,31 +205,3 @@ TargetHasLibm = @TargetHasLibm@ TablesNextToCode = @TablesNextToCode@ LeadingUnderscore = @LeadingUnderscore@ LlvmTarget = @LlvmTarget@ - -SettingsCCompilerCommand = @SettingsCCompilerCommand@ -SettingsCxxCompilerCommand = @SettingsCxxCompilerCommand@ -SettingsCPPCommand = @SettingsCPPCommand@ -SettingsCPPFlags = @SettingsCPPFlags@ -SettingsHaskellCPPCommand = @SettingsHaskellCPPCommand@ -SettingsHaskellCPPFlags = @SettingsHaskellCPPFlags@ -SettingsJavaScriptCPPCommand = @SettingsJavaScriptCPPCommand@ -SettingsJavaScriptCPPFlags = @SettingsJavaScriptCPPFlags@ -SettingsCmmCPPCommand = @SettingsCmmCPPCommand@ -SettingsCmmCPPFlags = @SettingsCmmCPPFlags@ -SettingsCmmCPPSupportsG0 = @SettingsCmmCPPSupportsG0@ -SettingsCCompilerFlags = @SettingsCCompilerFlags@ -SettingsCxxCompilerFlags = @SettingsCxxCompilerFlags@ -SettingsCCompilerLinkFlags = @SettingsCCompilerLinkFlags@ -SettingsCCompilerSupportsNoPie = @SettingsCCompilerSupportsNoPie@ -SettingsMergeObjectsCommand = @SettingsMergeObjectsCommand@ -SettingsMergeObjectsFlags = @SettingsMergeObjectsFlags@ -SettingsArCommand = @SettingsArCommand@ -SettingsOtoolCommand = @SettingsOtoolCommand@ -SettingsInstallNameToolCommand = @SettingsInstallNameToolCommand@ -SettingsRanlibCommand = @SettingsRanlibCommand@ -SettingsWindresCommand = @SettingsWindresCommand@ -SettingsLibtoolCommand = @SettingsLibtoolCommand@ -SettingsLlcCommand = @SettingsLlcCommand@ -SettingsOptCommand = @SettingsOptCommand@ -SettingsLlvmAsCommand = @SettingsLlvmAsCommand@ -SettingsUseDistroMINGW = @SettingsUseDistroMINGW@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -79,7 +79,7 @@ project-git-commit-id = @ProjectGitCommitId@ # generated by configure, to generated being by the build system. Many of these # might become redundant. # See Note [tooldir: How GHC finds mingw on Windows] -settings-use-distro-mingw = @SettingsUseDistroMINGW@ +settings-use-distro-mingw = @EnableDistroToolchain@ target-has-libm = @TargetHasLibm@ ===================================== hadrian/src/Base.hs ===================================== @@ -151,6 +151,7 @@ ghcLibDeps stage iplace = do , "llvm-passes" , "ghc-interp.js" , "settings" + , "targets" -/- "default.target" , "ghc-usage.txt" , "ghci-usage.txt" , "dyld.mjs" ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -10,7 +10,7 @@ import qualified Data.Set as Set import Base import qualified Context import Expression -import Hadrian.Oracles.TextFile (lookupSystemConfig) +import Hadrian.Oracles.TextFile (lookupSystemConfig, getTargetTarget) import Oracles.Flag hiding (arSupportsAtFile, arSupportsDashL) import Oracles.ModuleFiles import Oracles.Setting @@ -24,7 +24,6 @@ import Target import Utilities import GHC.Toolchain as Toolchain hiding (HsCpp(HsCpp)) -import GHC.Toolchain.Program import GHC.Platform.ArchOS import Settings.Program (ghcWithInterpreter) @@ -263,6 +262,7 @@ generateRules = do let prefix = root -/- stageString stage -/- "lib" go gen file = generate file (semiEmptyTarget (succStage stage)) gen (prefix -/- "settings") %> \out -> go (generateSettings out) out + (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr getTargetTarget) out where file <~+ gen = file %> \out -> generate out emptyTarget gen >> makeExecutable out @@ -425,7 +425,7 @@ bindistRules = do , interpolateSetting "LlvmMinVersion" LlvmMinVersion , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget , interpolateSetting "ProjectVersion" ProjectVersion - , interpolateVar "SettingsUseDistroMINGW" $ lookupSystemConfig "settings-use-distro-mingw" + , interpolateVar "EnableDistroToolchain" $ lookupSystemConfig "settings-use-distro-mingw" , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm" , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple @@ -483,62 +483,12 @@ generateSettings settingsFile = do let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path settings <- traverse sequence $ - [ ("C compiler command", queryTarget ccPath) - , ("C compiler flags", queryTarget ccFlags) - , ("C++ compiler command", queryTarget cxxPath) - , ("C++ compiler flags", queryTarget cxxFlags) - , ("C compiler link flags", queryTarget clinkFlags) - , ("C compiler supports -no-pie", queryTarget linkSupportsNoPie) - , ("CPP command", queryTarget cppPath) - , ("CPP flags", queryTarget cppFlags) - , ("Haskell CPP command", queryTarget hsCppPath) - , ("Haskell CPP flags", queryTarget hsCppFlags) - , ("JavaScript CPP command", queryTarget jsCppPath) - , ("JavaScript CPP flags", queryTarget jsCppFlags) - , ("C-- CPP command", queryTarget cmmCppPath) - , ("C-- CPP flags", queryTarget cmmCppFlags) - , ("C-- CPP supports -g0", queryTarget cmmCppSupportsG0') - , ("ld supports compact unwind", queryTarget linkSupportsCompactUnwind) - , ("ld supports filelist", queryTarget linkSupportsFilelist) - , ("ld supports single module", queryTarget linkSupportsSingleModule) - , ("ld is GNU ld", queryTarget linkIsGnu) - , ("Merge objects command", queryTarget mergeObjsPath) - , ("Merge objects flags", queryTarget mergeObjsFlags) - , ("Merge objects supports response files", queryTarget mergeObjsSupportsResponseFiles') - , ("ar command", queryTarget arPath) - , ("ar flags", queryTarget arFlags) - , ("ar supports at file", queryTarget arSupportsAtFile') - , ("ar supports -L", queryTarget arSupportsDashL') - , ("ranlib command", queryTarget ranlibPath) - , ("otool command", queryTarget otoolPath) - , ("install_name_tool command", queryTarget installNameToolPath) - , ("windres command", queryTarget (maybe "/bin/false" prgPath . tgtWindres)) -- TODO: /bin/false is not available on many distributions by default, but we keep it as it were before the ghc-toolchain patch. Fix-me. - , ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) - , ("cross compiling", expr $ yesNo <$> flag CrossCompiling) - , ("target platform string", queryTarget targetPlatformTriple) - , ("target os", queryTarget (show . archOS_OS . tgtArchOs)) - , ("target arch", queryTarget (show . archOS_arch . tgtArchOs)) - , ("target word size", queryTarget wordSize) - , ("target word big endian", queryTarget isBigEndian) - , ("target has GNU nonexec stack", queryTarget (yesNo . Toolchain.tgtSupportsGnuNonexecStack)) - , ("target has .ident directive", queryTarget (yesNo . Toolchain.tgtSupportsIdentDirective)) - , ("target has subsections via symbols", queryTarget (yesNo . Toolchain.tgtSupportsSubsectionsViaSymbols)) + [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) , ("target has libm", expr $ lookupSystemConfig "target-has-libm") - , ("Unregisterised", queryTarget (yesNo . tgtUnregisterised)) - , ("LLVM target", queryTarget tgtLlvmTarget) - , ("LLVM llc command", queryTarget llcPath) - , ("LLVM opt command", queryTarget optPath) - , ("LLVM llvm-as command", queryTarget llvmAsPath) - , ("LLVM llvm-as flags", queryTarget llvmAsFlags) - , ("Use inplace MinGW toolchain", expr $ lookupSystemConfig "settings-use-distro-mingw") - , ("target RTS linker only supports shared libraries", expr $ yesNo <$> targetRTSLinkerOnlySupportsSharedLibs) , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) , ("Support SMP", expr $ yesNo <$> targetSupportsSMP) , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays) - , ("Tables next to code", queryTarget (yesNo . tgtTablesNextToCode)) - , ("Leading underscore", queryTarget (yesNo . tgtSymbolsHaveLeadingUnderscore)) - , ("Use LibFFI", expr $ yesNo <$> useLibffiForAdjustors) , ("RTS expects libdw", yesNo <$> getFlag UseLibdw) , ("Relative Global Package DB", pure rel_pkg_db) , ("base unit-id", pure base_unit_id) @@ -550,40 +500,6 @@ generateSettings settingsFile = do ("[" ++ showTuple s) : ((\s' -> "," ++ showTuple s') <$> ss) ++ ["]"] - where - ccPath = prgPath . ccProgram . tgtCCompiler - ccFlags = escapeArgs . prgFlags . ccProgram . tgtCCompiler - cxxPath = prgPath . cxxProgram . tgtCxxCompiler - cxxFlags = escapeArgs . prgFlags . cxxProgram . tgtCxxCompiler - clinkFlags = escapeArgs . prgFlags . ccLinkProgram . tgtCCompilerLink - linkSupportsNoPie = yesNo . ccLinkSupportsNoPie . tgtCCompilerLink - cppPath = prgPath . cppProgram . tgtCPreprocessor - cppFlags = escapeArgs . prgFlags . cppProgram . tgtCPreprocessor - hsCppPath = prgPath . hsCppProgram . tgtHsCPreprocessor - hsCppFlags = escapeArgs . prgFlags . hsCppProgram . tgtHsCPreprocessor - jsCppPath = maybe "" (prgPath . jsCppProgram) . tgtJsCPreprocessor - jsCppFlags = maybe "" (escapeArgs . prgFlags . jsCppProgram) . tgtJsCPreprocessor - cmmCppPath = prgPath . cmmCppProgram . tgtCmmCPreprocessor - cmmCppFlags = escapeArgs . prgFlags . cmmCppProgram . tgtCmmCPreprocessor - cmmCppSupportsG0' = yesNo . cmmCppSupportsG0 . tgtCmmCPreprocessor - mergeObjsPath = maybe "" (prgPath . mergeObjsProgram) . tgtMergeObjs - mergeObjsFlags = maybe "" (escapeArgs . prgFlags . mergeObjsProgram) . tgtMergeObjs - linkSupportsSingleModule = yesNo . ccLinkSupportsSingleModule . tgtCCompilerLink - linkSupportsFilelist = yesNo . ccLinkSupportsFilelist . tgtCCompilerLink - linkSupportsCompactUnwind = yesNo . ccLinkSupportsCompactUnwind . tgtCCompilerLink - linkIsGnu = yesNo . ccLinkIsGnu . tgtCCompilerLink - llcPath = maybe "" prgPath . tgtLlc - optPath = maybe "" prgPath . tgtOpt - llvmAsPath = maybe "" prgPath . tgtLlvmAs - llvmAsFlags = escapeArgs . maybe [] prgFlags . tgtLlvmAs - arPath = prgPath . arMkArchive . tgtAr - arFlags = escapeArgs . prgFlags . arMkArchive . tgtAr - arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr - arSupportsDashL' = yesNo . arSupportsDashL . tgtAr - otoolPath = maybe "" prgPath . tgtOtool - installNameToolPath = maybe "" prgPath . tgtInstallNameTool - ranlibPath = maybe "" (prgPath . ranlibProgram) . tgtRanlib - mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs isBigEndian, wordSize :: Toolchain.Target -> String isBigEndian = yesNo . (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness ===================================== libraries/ghc-boot/GHC/Settings/Utils.hs ===================================== @@ -10,6 +10,8 @@ import GHC.BaseDir import GHC.Platform.ArchOS import System.FilePath +import GHC.Toolchain.Target + maybeRead :: Read a => String -> Maybe a maybeRead str = case reads str of [(x, "")] -> Just x @@ -36,19 +38,17 @@ type RawSettings = Map String String -- | Read target Arch/OS from the settings getTargetArchOS - :: FilePath -- ^ Settings filepath (for error messages) - -> RawSettings -- ^ Raw settings file contents - -> Either String ArchOS -getTargetArchOS settingsFile settings = - ArchOS <$> readRawSetting settingsFile settings "target arch" - <*> readRawSetting settingsFile settings "target os" + :: Target -- ^ The 'Target' from which to read the 'ArchOS' + -> ArchOS +getTargetArchOS target = tgtArchOs target getGlobalPackageDb :: FilePath -> RawSettings -> Either String FilePath getGlobalPackageDb settingsFile settings = do rel_db <- getRawSetting settingsFile settings "Relative Global Package DB" return (dropFileName settingsFile </> rel_db) - +-------------------------------------------------------------------------------- +-- lib/settings getRawSetting :: FilePath -> RawSettings -> String -> Either String String @@ -70,10 +70,3 @@ getRawBooleanSetting settingsFile settings key = do "NO" -> Right False xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs -readRawSetting - :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a -readRawSetting settingsFile settings key = case Map.lookup key settings of - Just xs -> case maybeRead xs of - Just v -> Right v - Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs - Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile ===================================== libraries/ghc-boot/ghc-boot.cabal.in ===================================== @@ -82,7 +82,8 @@ Library directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.6, deepseq >= 1.4 && < 1.6, - ghc-platform >= 0.1, + ghc-platform >= 0.1, + ghc-toolchain >= 0.1 -- reexport modules from ghc-boot-th so that packages -- don't have to import all of ghc-boot and ghc-boot-th. ===================================== libraries/ghc-internal/src/GHC/Internal/ResponseFile.hs ===================================== @@ -20,7 +20,7 @@ module GHC.Internal.ResponseFile ( getArgsWithResponseFiles, unescapeArgs, - escapeArgs, + escapeArgs, escapeArg, expandResponse ) where ===================================== m4/fp_settings.m4 deleted ===================================== @@ -1,171 +0,0 @@ -dnl Note [How we configure the bundled windows toolchain] -dnl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -dnl As per Note [tooldir: How GHC finds mingw on Windows], when using the -dnl bundled windows toolchain, the GHC settings file must refer to the -dnl toolchain through a path relative to $tooldir (binary distributions on -dnl Windows should work without configure, so the paths must be relative to the -dnl installation). However, hadrian expects the configured toolchain to use -dnl full paths to the executable. -dnl -dnl This is how the bundled windows toolchain is configured, to define the -dnl toolchain with paths to the executables, while still writing into GHC -dnl settings the paths relative to $tooldir: -dnl -dnl * If using the bundled toolchain, FP_SETUP_WINDOWS_TOOLCHAIN will be invoked -dnl -dnl * FP_SETUP_WINDOWS_TOOLCHAIN will set the toolchain variables to paths -dnl to the bundled toolchain (e.g. CFLAGS=/full/path/to/mingw/bin/gcc) -dnl -dnl * Later on, in FP_SETTINGS, we substitute occurrences of the path to the -dnl mingw tooldir by $tooldir (see SUBST_TOOLDIR). -dnl The reason is the Settings* variants of toolchain variables are used by the bindist configure to -dnl create the settings file, which needs the windows bundled toolchain to be relative to $tooldir. -dnl -dnl * Finally, hadrian will also substitute the mingw prefix by $tooldir before writing the toolchain to the settings file (see generateSettings) -dnl -dnl The ghc-toolchain program isn't concerned with any of these complications: -dnl it is passed either the full paths to the toolchain executables, or the bundled -dnl mingw path is set first on $PATH before invoking it. And ghc-toolchain -dnl will, as always, output target files with full paths to the executables. -dnl -dnl Hadrian accounts for this as it does for the toolchain executables -dnl configured by configure -- in fact, hadrian doesn't need to know whether -dnl the toolchain description file was generated by configure or by -dnl ghc-toolchain. - -# SUBST_TOOLDIR -# ---------------------------------- -# $1 - the variable where to search for occurrences of the path to the -# inplace mingw, and update by substituting said occurrences by -# the value of $mingw_install_prefix, where the mingw toolchain will be at -# install time -# -# See Note [How we configure the bundled windows toolchain] -AC_DEFUN([SUBST_TOOLDIR], -[ - dnl and Note [How we configure the bundled windows toolchain] - $1=`echo "$$1" | sed 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g'` -]) - -# FP_SETTINGS -# ---------------------------------- -# Set the variables used in the settings file -AC_DEFUN([FP_SETTINGS], -[ - SettingsUseDistroMINGW="$EnableDistroToolchain" - - SettingsCCompilerCommand="$CC" - SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2" - SettingsCxxCompilerCommand="$CXX" - SettingsCxxCompilerFlags="$CONF_CXX_OPTS_STAGE2" - SettingsCPPCommand="$CPPCmd" - SettingsCPPFlags="$CONF_CPP_OPTS_STAGE2" - SettingsHaskellCPPCommand="$HaskellCPPCmd" - SettingsHaskellCPPFlags="$HaskellCPPArgs" - SettingsJavaScriptCPPCommand="$JavaScriptCPPCmd" - SettingsJavaScriptCPPFlags="$JavaScriptCPPArgs" - SettingsCmmCPPCommand="$CmmCPPCmd" - SettingsCmmCPPFlags="$CmmCPPArgs" - SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2" - SettingsArCommand="$ArCmd" - SettingsRanlibCommand="$RanlibCmd" - SettingsMergeObjectsCommand="$MergeObjsCmd" - SettingsMergeObjectsFlags="$MergeObjsArgs" - - AS_CASE( - ["$CmmCPPSupportsG0"], - [True], [SettingsCmmCPPSupportsG0=YES], - [False], [SettingsCmmCPPSupportsG0=NO], - [AC_MSG_ERROR(Unknown CPPSupportsG0 value $CmmCPPSupportsG0)] - ) - - if test -z "$WindresCmd"; then - SettingsWindresCommand="/bin/false" - else - SettingsWindresCommand="$WindresCmd" - fi - - # LLVM backend tools - SettingsLlcCommand="$LlcCmd" - SettingsOptCommand="$OptCmd" - SettingsLlvmAsCommand="$LlvmAsCmd" - SettingsLlvmAsFlags="$LlvmAsFlags" - - if test "$EnableDistroToolchain" = "YES"; then - # If the user specified --enable-distro-toolchain then we just use the - # executable names, not paths. - SettingsCCompilerCommand="$(basename $SettingsCCompilerCommand)" - SettingsHaskellCPPCommand="$(basename $SettingsHaskellCPPCommand)" - SettingsCmmCPPCommand="$(basename $SettingsCmmCPPCommand)" - SettingsJavaScriptCPPCommand="$(basename $SettingsJavaScriptCPPCommand)" - SettingsLdCommand="$(basename $SettingsLdCommand)" - SettingsMergeObjectsCommand="$(basename $SettingsMergeObjectsCommand)" - SettingsArCommand="$(basename $SettingsArCommand)" - SettingsWindresCommand="$(basename $SettingsWindresCommand)" - SettingsLlcCommand="$(basename $SettingsLlcCommand)" - SettingsOptCommand="$(basename $SettingsOptCommand)" - SettingsLlvmAsCommand="$(basename $SettingsLlvmAsCommand)" - fi - - if test "$windows" = YES -a "$EnableDistroToolchain" = "NO"; then - # Handle the Windows toolchain installed in FP_SETUP_WINDOWS_TOOLCHAIN. - # We need to issue a substitution to use $tooldir, - # See Note [tooldir: How GHC finds mingw on Windows] - SUBST_TOOLDIR([SettingsCCompilerCommand]) - SUBST_TOOLDIR([SettingsCCompilerFlags]) - SUBST_TOOLDIR([SettingsCxxCompilerCommand]) - SUBST_TOOLDIR([SettingsCxxCompilerFlags]) - SUBST_TOOLDIR([SettingsCCompilerLinkFlags]) - SUBST_TOOLDIR([SettingsCPPCommand]) - SUBST_TOOLDIR([SettingsCPPFlags]) - SUBST_TOOLDIR([SettingsHaskellCPPCommand]) - SUBST_TOOLDIR([SettingsHaskellCPPFlags]) - SUBST_TOOLDIR([SettingsCmmCPPCommand]) - SUBST_TOOLDIR([SettingsCmmCPPFlags]) - SUBST_TOOLDIR([SettingsJavaScriptCPPCommand]) - SUBST_TOOLDIR([SettingsJavaScriptCPPFlags]) - SUBST_TOOLDIR([SettingsMergeObjectsCommand]) - SUBST_TOOLDIR([SettingsMergeObjectsFlags]) - SUBST_TOOLDIR([SettingsArCommand]) - SUBST_TOOLDIR([SettingsRanlibCommand]) - SUBST_TOOLDIR([SettingsWindresCommand]) - SUBST_TOOLDIR([SettingsLlcCommand]) - SUBST_TOOLDIR([SettingsOptCommand]) - SUBST_TOOLDIR([SettingsLlvmAsCommand]) - SUBST_TOOLDIR([SettingsLlvmAsFlags]) - fi - - # Mac-only tools - SettingsOtoolCommand="$OtoolCmd" - SettingsInstallNameToolCommand="$InstallNameToolCmd" - - SettingsCCompilerSupportsNoPie="$CONF_GCC_SUPPORTS_NO_PIE" - - AC_SUBST(SettingsCCompilerCommand) - AC_SUBST(SettingsCxxCompilerCommand) - AC_SUBST(SettingsCPPCommand) - AC_SUBST(SettingsCPPFlags) - AC_SUBST(SettingsHaskellCPPCommand) - AC_SUBST(SettingsHaskellCPPFlags) - AC_SUBST(SettingsCmmCPPCommand) - AC_SUBST(SettingsCmmCPPFlags) - AC_SUBST(SettingsCmmCPPSupportsG0) - AC_SUBST(SettingsJavaScriptCPPCommand) - AC_SUBST(SettingsJavaScriptCPPFlags) - AC_SUBST(SettingsCCompilerFlags) - AC_SUBST(SettingsCxxCompilerFlags) - AC_SUBST(SettingsCCompilerLinkFlags) - AC_SUBST(SettingsCCompilerSupportsNoPie) - AC_SUBST(SettingsMergeObjectsCommand) - AC_SUBST(SettingsMergeObjectsFlags) - AC_SUBST(SettingsArCommand) - AC_SUBST(SettingsRanlibCommand) - AC_SUBST(SettingsOtoolCommand) - AC_SUBST(SettingsInstallNameToolCommand) - AC_SUBST(SettingsWindresCommand) - AC_SUBST(SettingsLlcCommand) - AC_SUBST(SettingsOptCommand) - AC_SUBST(SettingsLlvmAsCommand) - AC_SUBST(SettingsLlvmAsFlags) - AC_SUBST(SettingsUseDistroMINGW) -]) ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -77,6 +77,7 @@ AC_DEFUN([FP_INSTALL_WINDOWS_TOOLCHAIN],[ # $2 the location that the windows toolchain will be installed in relative to the libdir AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[ + # TODO: UPDATE COMMENT # N.B. The parameters which get plopped in the `settings` file used by the # resulting compiler are computed in `FP_SETTINGS`. Specifically, we use # $$topdir-relative paths instead of fullpaths to the toolchain, by replacing ===================================== m4/subst_tooldir.m4 ===================================== @@ -0,0 +1,45 @@ +dnl Note [How we configure the bundled windows toolchain] +dnl ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +dnl As per Note [tooldir: How GHC finds mingw on Windows], when using the +dnl bundled windows toolchain, the GHC settings file must refer to the +dnl toolchain through a path relative to $tooldir (binary distributions on +dnl Windows should work without configure, so the paths must be relative to the +dnl installation). However, hadrian expects the configured toolchain to use +dnl full paths to the executable. +dnl +dnl This is how the bundled windows toolchain is configured, to define the +dnl toolchain with paths to the executables, while still writing into GHC +dnl settings the paths relative to $tooldir: +dnl +dnl * If using the bundled toolchain, FP_SETUP_WINDOWS_TOOLCHAIN will be invoked +dnl +dnl * FP_SETUP_WINDOWS_TOOLCHAIN will set the toolchain variables to paths +dnl to the bundled toolchain (e.g. CFLAGS=/full/path/to/mingw/bin/gcc) +dnl +dnl * Later on, at the end of distrib/configure.ac, we substitute occurrences of the path to the +dnl mingw tooldir by $tooldir (see SUBST_TOOLDIR). +dnl The reason is the Settings* variants of toolchain variables are used by the bindist configure to +dnl create the settings file, which needs the windows bundled toolchain to be relative to $tooldir. +dnl +dnl The ghc-toolchain program isn't concerned with any of these complications: +dnl it is passed either the full paths to the toolchain executables, or the bundled +dnl mingw path is set first on $PATH before invoking it. And ghc-toolchain +dnl will, as always, output target files with full paths to the executables. +dnl +dnl Hadrian accounts for this as it does for the toolchain executables +dnl configured by configure -- in fact, hadrian doesn't need to know whether +dnl the toolchain description file was generated by configure or by +dnl ghc-toolchain. + +# SUBST_TOOLDIR +# ---------------------------------- +# $1 - the filepath where to search for occurrences of the path to the +# inplace mingw, and update by substituting said occurrences by +# the value of $mingw_install_prefix, where the mingw toolchain will be at +# install time +# +# See Note [How we configure the bundled windows toolchain] +AC_DEFUN([SUBST_TOOLDIR], +[ + sed -i.bkp $1 's%'"$mingw_prefix"'%'"$mingw_install_prefix"'%g' +]) ===================================== mk/hsc2hs.in ===================================== @@ -1,6 +1,6 @@ -HSC2HS_C="@SettingsCCompilerFlags@" +HSC2HS_C="@CONF_CC_OPTS_STAGE2@" -HSC2HS_L="@SettingsCCompilerLinkFlags@" +HSC2HS_L="@CONF_GCC_LINKER_OPTS_STAGE2@" tflag="--template=$libdir/template-hsc.h" Iflag="-I$includedir/include/" ===================================== testsuite/tests/ghc-api/T20757.hs ===================================== @@ -3,4 +3,4 @@ module Main where import GHC.SysTools.BaseDir main :: IO () -main = findToolDir False "/" >>= print +main = findToolDir "/" >>= print ===================================== testsuite/tests/ghc-api/settings-escape/T24265.hs ===================================== @@ -16,6 +16,13 @@ import System.Environment import System.IO (hPutStrLn, stderr) import System.Exit (exitWith, ExitCode(ExitFailure)) +import GHC.Toolchain +import GHC.Toolchain.Program +import GHC.Toolchain.Tools.Cc +import GHC.Toolchain.Tools.Cpp +import GHC.Toolchain.Tools.Cxx +import GHC.Toolchain.Lens + -- Precondition: this test case must be executed in a directory with a space. -- -- First we get the current settings file and amend it with extra arguments that we *know* @@ -30,35 +37,29 @@ main :: IO () main = do libdir:_args <- getArgs - (rawSettingOpts, originalSettings) <- runGhc (Just libdir) $ do + (rawSettingOpts, rawTargetOpts, originalSettings) <- runGhc (Just libdir) $ do dflags <- hsc_dflags <$> getSession - pure (rawSettings dflags, settings dflags) + pure (rawSettings dflags, rawTarget dflags, settings dflags) top_dir <- makeAbsolute "./ghc-install-folder/lib with spaces" - let argsWithSpaces = "\"-some option\" -some\\ other" - numberOfExtraArgs = length $ unescapeArgs argsWithSpaces - -- These are all options that can have multiple 'String' or 'Option' values. - -- We explicitly do not add 'C compiler link flags' here, as 'initSettings' - -- already adds the options of "C compiler flags" to this config field. - multipleArguments = Set.fromList - [ "Haskell CPP flags" - , "JavaScript CPP flags" - , "C-- CPP flags" - , "C compiler flags" - , "C++ compiler flags" - , "CPP flags" - , "Merge objects flags" + let argsWithSpaces l = over l (++["-some option", "-some\\ other"]) + numberOfExtraArgs = 2 + -- Test it on a handfull of list of flags + multipleArguments = + [ _tgtHsCpp % _hsCppProg % _prgFlags -- "Haskell CPP flags" + , _tgtCC % _ccProgram % _prgFlags -- "C compiler flags" + , _tgtCxx % _cxxProgram % _prgFlags -- "C++ compiler flags" + , _tgtCpp % _cppProg % _prgFlags -- "CPP flags" ] - let rawSettingOptsWithExtraArgs = - map (\(name, args) -> if Set.member name multipleArguments - then (name, args ++ " " ++ argsWithSpaces) - else (name, args)) rawSettingOpts + targetWithExtraArgs = foldr argsWithSpaces rawTargetOpts multipleArguments -- write out the modified settings. We try to keep it legible writeFile (top_dir ++ "/settings") $ - "[" ++ (intercalate "\n," (map show rawSettingOptsWithExtraArgs)) ++ "]" + "[" ++ (intercalate "\n," (map show rawSettingOpts)) ++ "]" + writeFile (top_dir ++ "/targets/default.target") $ + show targetWithExtraArgs settingsm <- runExceptT $ initSettings top_dir @@ -113,12 +114,6 @@ main = do -- Setting 'Haskell CPP flags' contains '$topdir' reference. -- Resolving those while containing spaces, should not introduce more options. recordSetting "Haskell CPP flags" (map showOpt . snd . toolSettings_pgm_P . sToolSettings) - -- Setting 'JavaScript CPP flags' contains '$topdir' reference. - -- Resolving those while containing spaces, should not introduce more options. - recordSetting "JavaScript CPP flags" (map showOpt . snd . toolSettings_pgm_JSP . sToolSettings) - -- Setting 'C-- CPP flags' contains '$topdir' reference. - -- Resolving those while containing spaces, should not introduce more options. - recordSetting "C-- CPP flags" (map showOpt . snd . toolSettings_pgm_CmmP . sToolSettings) -- Setting 'C compiler flags' contains strings with spaces. -- GHC should not split these by word. recordSetting "C compiler flags" (toolSettings_opt_c . sToolSettings) @@ -133,10 +128,6 @@ main = do -- Setting 'CPP flags' contains strings with spaces. -- GHC should not split these by word. recordSetting "CPP flags" (map showOpt . snd . toolSettings_pgm_cpp . sToolSettings) - -- Setting 'Merge objects flags' contains strings with spaces. - -- GHC should not split these by word. - -- If 'Nothing', ignore this test, otherwise the same assertion holds as before. - recordSettingM "Merge objects flags" (fmap (map showOpt . snd) . toolSettings_pgm_lm . sToolSettings) -- Setting 'C compiler command' contains '$topdir' reference. -- Spaces in the final filepath should not be escaped. recordFpSetting "C compiler" (toolSettings_pgm_c . sToolSettings) ===================================== testsuite/tests/ghc-api/settings-escape/T24265.stderr ===================================== @@ -1,9 +1,5 @@ === 'Haskell CPP flags' contains 2 new entries: True Contains spaces: True -=== 'JavaScript CPP flags' contains 2 new entries: True - Contains spaces: True -=== 'C-- CPP flags' contains 2 new entries: True - Contains spaces: True === 'C compiler flags' contains 2 new entries: True Contains spaces: True === 'C compiler link flags' contains 2 new entries: True @@ -12,5 +8,4 @@ Contains spaces: True === 'CPP flags' contains 2 new entries: True Contains spaces: True -=== 'Merge objects flags' contains expected entries: True === FilePath 'C compiler' contains escaped spaces: False ===================================== testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/targets/.gitkeep ===================================== ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -96,6 +96,8 @@ import System.Posix hiding (fdToHandle) import qualified System.Info(os) #endif +import GHC.Toolchain.Target + -- | Short-circuit 'any' with a \"monadic predicate\". anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool anyM _ [] = return False @@ -583,9 +585,20 @@ readFromSettingsFile settingsFile f = do -- It's excusable to not have a settings file (for now at -- least) but completely inexcusable to have a malformed one. Nothing -> Left $ "Can't parse settings file " ++ show settingsFile - case f settingsFile mySettings of - Right archOS -> Right archOS - Left e -> Left e + f settingsFile mySettings + +readFromTargetFile :: FilePath + -> (Target -> b) + -> IO (Either String b) +readFromTargetFile targetFile f = do + targetStr <- readFile targetFile + pure $ do + target <- case maybeReadFuzzy targetStr of + Just t -> Right t + -- It's excusable to not have a settings file (for now at + -- least) but completely inexcusable to have a malformed one. + Nothing -> Left $ "Can't parse .target file " ++ show targetFile + Right (f target) getPkgDatabases :: Verbosity -> GhcPkg.DbOpenMode mode DbModifySelector @@ -618,6 +631,7 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do Nothing -> die err_msg Just dir -> do -- Look for where it is given in the settings file, if marked there. + -- See Note [Settings file] about this file, and why we need GHC to share it with us. let settingsFile = dir </> "settings" exists_settings_file <- doesFileExist settingsFile erel_db <- @@ -652,16 +666,15 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do case [ f | FlagUserConfig f <- my_flags ] of _ | no_user_db -> return Nothing [] -> do - -- See Note [Settings file] about this file, and why we need GHC to share it with us. - let settingsFile = top_dir </> "settings" - exists_settings_file <- doesFileExist settingsFile + let targetFile = top_dir </> "targets" </> "default.target" + exists_settings_file <- doesFileExist targetFile targetArchOS <- case exists_settings_file of False -> do - warn $ "WARNING: settings file doesn't exist " ++ show settingsFile + warn $ "WARNING: target file doesn't exist " ++ show targetFile warn "cannot know target platform so guessing target == host (native compiler)." pure hostPlatformArchOS True -> - readFromSettingsFile settingsFile getTargetArchOS >>= \case + readFromTargetFile targetFile getTargetArchOS >>= \case Right v -> pure v Left e -> die e ===================================== utils/ghc-pkg/ghc-pkg.cabal.in ===================================== @@ -29,6 +29,7 @@ Executable ghc-pkg Cabal-syntax, binary, ghc-boot, + ghc-toolchain, bytestring if !os(windows) Build-Depends: unix ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -534,4 +534,3 @@ mkTarget opts = do } return t ---- ROMES:TODO: fp_settings.m4 in general which I don't think was ported completely (e.g. the basenames and windows llvm-XX and such) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Target.hs ===================================== @@ -7,6 +7,9 @@ module GHC.Toolchain.Target , WordSize(..), wordSize2Bytes + -- ** Lenses + , _tgtCC, _tgtCxx, _tgtCpp, _tgtHsCpp + -- * Re-exports , ByteOrder(..) ) where @@ -137,3 +140,29 @@ instance Show Target where , ", tgtInstallNameTool = " ++ show tgtInstallNameTool , "}" ] + +-------------------------------------------------------------------------------- +-- Lenses +-------------------------------------------------------------------------------- + +_tgtCC :: Lens Target Cc +_tgtCC = Lens tgtCCompiler (\x o -> o {tgtCCompiler = x}) + +_tgtCxx :: Lens Target Cxx +_tgtCxx = Lens tgtCxxCompiler (\x o -> o {tgtCxxCompiler = x}) + +_tgtCpp :: Lens Target Cpp +_tgtCpp = Lens tgtCPreprocessor (\x o -> o {tgtCPreprocessor = x}) + +_tgtHsCpp :: Lens Target HsCpp +_tgtHsCpp = Lens tgtHsCPreprocessor (\x o -> o {tgtHsCPreprocessor = x}) + +_tgtJsCpp :: Lens Target (Maybe JsCpp) +_tgtJsCpp = Lens tgtJsCPreprocessor (\x o -> o {tgtJsCPreprocessor = x}) + +_tgtCmmCpp :: Lens Target CmmCpp +_tgtCmmCpp = Lens tgtCmmCPreprocessor (\x o -> o {tgtCmmCPreprocessor = x}) + +_tgtMergeObjs :: Lens Target (Maybe MergeObjs) +_tgtMergeObjs = Lens tgtMergeObjs (\x o -> o {tgtMergeObjs = x}) + ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs ===================================== @@ -5,6 +5,9 @@ module GHC.Toolchain.Tools.Cpp , Cpp(..), findCpp , JsCpp(..), findJsCpp , CmmCpp(..), findCmmCpp + + -- * Lenses + , _cppProg, _hsCppProg, _jsCppProg, _cmmCppProg ) where import Control.Monad @@ -188,3 +191,18 @@ findCpp progOpt cc = checking "for C preprocessor" $ do let cppProgram = addFlagIfNew "-E" cpp2 return Cpp{cppProgram} +-------------------------------------------------------------------------------- +-- Lenses +-------------------------------------------------------------------------------- + +_cppProg :: Lens Cpp Program +_cppProg = Lens cppProgram (\x o -> o{cppProgram = x}) + +_hsCppProg :: Lens HsCpp Program +_hsCppProg = Lens hsCppProgram (\x o -> o{hsCppProgram = x}) + +_jsCppProg :: Lens JsCpp Program +_jsCppProg = Lens jsCppProgram (\x o -> o{jsCppProgram = x}) + +_cmmCppProg :: Lens CmmCpp Program +_cmmCppProg = Lens cmmCppProgram (\x o -> o{cmmCppProgram = x}) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cxx.hs ===================================== @@ -4,7 +4,7 @@ module GHC.Toolchain.Tools.Cxx ( Cxx(..) , findCxx -- * Helpful utilities - , compileCxx + , compileCxx, _cxxProgram ) where import System.FilePath View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5f031f3ba575ea14235b13865c19c7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5f031f3ba575ea14235b13865c19c7… You're receiving this email because of your account on gitlab.haskell.org.

1 0