- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] EPA: remove LocatedLI / SrcSpanAnnLI
by Alan Zimmerman (＠alanz) 29 May '26

29 May '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: a8a869da by Alan Zimmerman at 2026-05-28T23:41:26+01:00 EPA: remove LocatedLI / SrcSpanAnnLI WIP. Compiles, next step is exact printing update. - - - - - 8 changed files: - compiler/GHC/Hs.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Module.hs Changes: ===================================== compiler/GHC/Hs.hs ===================================== @@ -82,17 +82,18 @@ deriving instance Data (HsModule GhcPs) data AnnsModule = AnnsModule { - am_sig :: EpToken "signature", - am_mod :: EpToken "module", - am_where :: EpToken "where", - am_decls :: [TrailingAnn], -- ^ Semis before the start of top decls - am_cs :: [LEpaComment], -- ^ Comments before start of top decl, + am_sig :: EpToken "signature", + am_mod :: EpToken "module", + am_where :: EpToken "where", + am_exports :: Maybe (EpToken "(", EpToken ")", [EpToken ","]), + am_decls :: [TrailingAnn], -- ^ Semis before the start of top decls + am_cs :: [LEpaComment], -- ^ Comments before start of top decl, -- used in exact printing only am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- ^ End of file and end of prior token } deriving (Data, Eq) instance NoAnn AnnsModule where - noAnn = AnnsModule NoEpTok NoEpTok NoEpTok [] [] Nothing + noAnn = AnnsModule NoEpTok NoEpTok NoEpTok Nothing [] [] Nothing instance Outputable (HsModule GhcPs) where ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc } ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -74,7 +74,7 @@ type instance XCImportDecl GhcRn = XImportDeclPass type instance XCImportDecl GhcTc = DataConCantHappen data XImportDeclPass = XImportDeclPass - { ideclAnn :: EpAnn EpAnnImportDecl + { ideclAnn :: EpAnnImportDecl , ideclSourceText :: SourceText -- Note [Pragma source text] in "GHC.Types.SourceText" , ideclGenerated :: Bool -- ^ See Note [Generated imports] } @@ -93,7 +93,8 @@ Plugins may also introduce generated imports. type instance XXImportDecl (GhcPass _) = DataConCantHappen type instance Anno ModuleName = SrcSpanAnnA -type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnLI +-- type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnLI +type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnA deriving instance Data (IEWrappedName GhcPs) deriving instance Data (IEWrappedName GhcRn) @@ -115,6 +116,8 @@ deriving instance Eq (NamespaceSpecifier GhcTc) -- API Annotations types +type AnnListImportDecl = AnnList (EpToken "hiding", [EpToken ","]) + data EpAnnImportDecl = EpAnnImportDecl { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively @@ -123,11 +126,12 @@ data EpAnnImportDecl = EpAnnImportDecl , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword + , importDeclImportList :: Maybe AnnListImportDecl } deriving (Data) instance NoAnn EpAnnImportDecl where - noAnn = EpAnnImportDecl noAnn Nothing Nothing noAnn Nothing Nothing Nothing + noAnn = EpAnnImportDecl noAnn Nothing Nothing noAnn Nothing Nothing Nothing Nothing data EpAnnLevel = EpAnnLevelSplice (EpToken "splice") | EpAnnLevelQuote (EpToken "quote") ===================================== compiler/GHC/Parser.y ===================================== @@ -879,12 +879,12 @@ unitdecl :: { LHsUnitDecl PackageName } NotBoot -> HsSrcFile IsBoot -> HsBootFile) (reLoc $3) - (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7))) } + (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) (snd $5) (fst $ sndOf3 $7) (snd $ sndOf3 $7))) } | 'signature' modid maybe_warning_pragma maybeexports 'where' body { sL1 $1 $ DeclD HsigFile (reLoc $2) - (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $6) $3 Nothing) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6))) } + (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $6) $3 Nothing) (Just $2) (snd $4) (fst $ sndOf3 $6) (snd $ sndOf3 $6))) } | 'dependency' unitid mayberns { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 , idModRenaming = $3 @@ -908,9 +908,9 @@ signature :: { Located (HsModule GhcPs) } : 'signature' modid maybe_warning_pragma maybeexports 'where' body {% fileSrcSpan >>= \ loc -> acs loc (\loc cs-> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule (epTok $1) NoEpTok (epTok $5) (fstOf3 $6) [] Nothing) cs) + (EpAnn (spanAsAnchor loc) (AnnsModule (epTok $1) NoEpTok (epTok $5) (fst $4) (fstOf3 $6) [] Nothing) cs) (thdOf3 $6) $3 Nothing) - (Just $2) $4 (fst $ sndOf3 $6) + (Just $2) (snd $4) (fst $ sndOf3 $6) (snd $ sndOf3 $6))) ) } @@ -918,15 +918,15 @@ module :: { Located (HsModule GhcPs) } : 'module' modid maybe_warning_pragma maybeexports 'where' body {% fileSrcSpan >>= \ loc -> acsFinal (\cs eof -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok $1) (epTok $5) (fstOf3 $6) [] eof) cs) + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok $1) (epTok $5) (fst $4) (fstOf3 $6) [] eof) cs) (thdOf3 $6) $3 Nothing) - (Just $2) $4 (fst $ sndOf3 $6) + (Just $2) (snd $4) (fst $ sndOf3 $6) (snd $ sndOf3 $6)) )) } | body2 {% fileSrcSpan >>= \ loc -> acsFinal (\cs eof -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok NoEpTok NoEpTok (fstOf3 $1) [] eof) cs) + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok NoEpTok NoEpTok Nothing (fstOf3 $1) [] eof) cs) (thdOf3 $1) Nothing Nothing) Nothing Nothing (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) } @@ -966,16 +966,16 @@ header :: { Located (HsModule GhcPs) } : 'module' modid maybe_warning_pragma maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> acs loc (\loc cs -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok $1) (epTok $5) [] [] Nothing) cs) + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok $1) (epTok $5) (fst $4) [] [] Nothing) cs) EpNoLayout $3 Nothing) - (Just $2) $4 $6 [] + (Just $2) (snd $4) $6 [] ))) } | 'signature' modid maybe_warning_pragma maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> acs loc (\loc cs -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok $1) (epTok $5) [] [] Nothing) cs) + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok $1) (epTok $5) (fst $4) [] [] Nothing) cs) EpNoLayout $3 Nothing) - (Just $2) $4 $6 [] + (Just $2) (snd $4) $6 [] ))) } | header_body2 {% fileSrcSpan >>= \ loc -> @@ -999,10 +999,10 @@ header_top_importdecls :: { [LImportDecl GhcPs] } ----------------------------------------------------------------------------- -- The Export List -maybeexports :: { (Maybe (LocatedLI [LIE GhcPs])) } - : '(' exportlist ')' {% fmap Just $ amsr (sLL $1 $> (fromOL $ snd $2)) - (AnnList Nothing (ListParens (epTok $1) (epTok $3)) [] (noAnn,fst $2) []) } - | {- empty -} { Nothing } +maybeexports :: { (Maybe (EpToken "(", EpToken ")", [EpToken ","]), Maybe (LocatedA [LIE GhcPs])) } + : '(' exportlist ')' { (Just ((epTok $1),(epTok $3) ,fst $2) + , Just (sLLa $1 $> (fromOL $ snd $2))) } + | {- empty -} { (Nothing, Nothing) } exportlist :: { ([EpToken ","], OrdList (LIE GhcPs)) } : exportlist1 { ([], $1) } @@ -1149,17 +1149,18 @@ importdecl :: { LImportDecl GhcPs } , importDeclAnnQualified = fst $ qualSpec , importDeclAnnPackage = fst $6 , importDeclAnnAs = fst $10 + , importDeclImportList = fst $ unLoc $11 } ; let loc = (comb6 $1 $7 $8 $9 (snd $10) $11); - ; fmap reLoc $ acs loc (\loc cs -> L loc $ - ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst $2) False + ; amsA' $ L loc $ + ImportDecl { ideclExt = XImportDeclPass anns (snd $ fst $2) False , ideclName = $7, ideclPkgQual = snd $6 , ideclSource = snd $2 , ideclLevelSpec = snd $ levelSpec , ideclSafe = snd $4 , ideclQualified = snd $ qualSpec , ideclAs = unLoc (snd $10) - , ideclImportList = unLoc $11 }) + , ideclImportList = snd $ unLoc $11 } } } @@ -1195,17 +1196,19 @@ maybeas :: { (Maybe (EpToken "as"),Located (Maybe (LocatedA ModuleName))) } ,sLL $1 $> (Just $2)) } | {- empty -} { (Nothing,noLoc Nothing) } -maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs])) } - : impspec { fmap Just $1 } - | {- empty -} { noLoc Nothing } - -impspec :: { Located (ImportListInterpretation, LocatedLI [LIE GhcPs]) } - : '(' importlist ')' {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $2) - (AnnList Nothing (ListParens (epTok $1) (epTok $3)) [] (noAnn,fst $2) []) - ; return $ sLL $1 $> (Exactly, es)} } - | 'hiding' '(' importlist ')' {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $3) - (AnnList Nothing (ListParens (epTok $2) (epTok $4)) [] (epTok $1,fst $3) []) - ; return $ sLL $1 $> (EverythingBut, es)} } +maybeimpspec :: { Located (Maybe AnnListImportDecl, Maybe (ImportListInterpretation, LocatedA [LIE GhcPs])) } + : impspec { sL1 $1 (Just (fst $ unLoc $1), Just (snd $ unLoc $1)) } + | {- empty -} { noLoc (Nothing, Nothing) } + +impspec :: { Located (AnnListImportDecl, (ImportListInterpretation, LocatedA [LIE GhcPs])) } + : '(' importlist ')' {% do { es <- amsA' (sLL $1 $> $ fromOL $ snd $2) + ; return $ sLL $1 $> + (AnnList Nothing (ListParens (epTok $1) (epTok $3)) [] (noAnn,fst $2) [], + (Exactly , es))} } + | 'hiding' '(' importlist ')' {% do { es <- amsA' (sLL $1 $> $ fromOL $ snd $3) + ; return $ sLL $1 $> + (AnnList Nothing (ListParens (epTok $2) (epTok $4)) [] (epTok $1,fst $3) [], + (EverythingBut , es))} } importlist :: { ([EpToken ","], OrdList (LIE GhcPs)) } : importlist1 { ([], $1) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -28,9 +28,9 @@ module GHC.Parser.Annotation ( -- ** Annotations in 'GenLocated' LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP, - LocatedLC, LocatedLS, LocatedLW, LocatedLI, + LocatedLC, LocatedLS, LocatedLW, SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, - SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, SrcSpanAnnLI, + SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, LocatedE, -- ** Annotation data types used in 'GenLocated' @@ -433,7 +433,7 @@ type LocatedL = GenLocated SrcSpanAnnL type LocatedLC = GenLocated SrcSpanAnnLC type LocatedLS = GenLocated SrcSpanAnnLS type LocatedLW = GenLocated SrcSpanAnnLW -type LocatedLI = GenLocated SrcSpanAnnLI +-- type LocatedLI = GenLocated SrcSpanAnnLI type LocatedP = GenLocated SrcSpanAnnP type LocatedC = GenLocated SrcSpanAnnC @@ -444,7 +444,7 @@ type SrcSpanAnnL = EpAnn (AnnList ()) type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","]) type SrcSpanAnnLS = EpAnn (AnnList ()) type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where")) -type SrcSpanAnnLI = EpAnn (AnnList (EpToken "hiding", [EpToken ","])) +-- type SrcSpanAnnLI = EpAnn (AnnList (EpToken "hiding", [EpToken ","])) type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnC = EpAnn AnnContext ===================================== compiler/GHC/Parser/PostProcess/Haddock.hs ===================================== @@ -303,7 +303,7 @@ lexLHsDocString = fmap lexHsDocString -- import I (a, b, c) -- do not use here! -- -- Imports cannot have documentation comments anyway. -instance HasHaddock (LocatedLI [LocatedA (IE GhcPs)]) where +instance HasHaddock (LocatedA [LocatedA (IE GhcPs)]) where addHaddock (L l_exports exports) = extendHdkA (locA l_exports) $ do exports' <- addHaddockInterleaveItems EpNoLayout mkDocIE exports ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -1188,9 +1188,9 @@ filterImports -> ModIface -> ImpDeclSpec -- ^ Import spec - -> Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs]) + -> Maybe (ImportListInterpretation, LocatedA [LIE GhcPs]) -- ^ Whether this is a "hiding" import list - -> RnM (Maybe (ImportListInterpretation, LocatedLI [LIE GhcRn]), -- Import spec w/ Names + -> RnM (Maybe (ImportListInterpretation, LocatedA [LIE GhcRn]), -- Import spec w/ Names ImpUserList, -- same, but designed for storage in interfaces GlobalRdrEnv) -- Same again, but in GRE form filterImports hsc_env iface decl_spec Nothing ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -193,7 +193,7 @@ type ExportOccMap = OccEnv (Name, IE GhcPs) -- that have the same occurrence name rnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedLI [LIE GhcPs]) -- Nothing => no explicit export list + -> Maybe (LocatedA [LIE GhcPs]) -- Nothing => no explicit export list -> RnM TcGblEnv -- Complains if two distinct exports have same OccName @@ -302,7 +302,7 @@ the default export. In the latter case the warning text is stored in the of a user-defined warning on default. -} -exports_from_avail :: Maybe (LocatedLI [LIE GhcPs]) +exports_from_avail :: Maybe (LocatedA [LIE GhcPs]) -- ^ 'Nothing' means no explicit export list -> GlobalRdrEnv -> ImportAvails ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -559,7 +559,7 @@ tcRnImports hsc_env import_decls -} tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedLI [LIE GhcPs]) + -> Maybe (LocatedA [LIE GhcPs]) -> [LHsDecl GhcPs] -- Declarations -> TcM TcGblEnv tcRnSrcDecls explicit_mod_hdr export_ies decls @@ -1885,7 +1885,7 @@ checkMainType tcg_env ; return lie } } } } checkMain :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedLI [LIE GhcPs]) -- Export specs of Main module + -> Maybe (LocatedA [LIE GhcPs]) -- Export specs of Main module -> TcM TcGblEnv -- If we are in module Main, check that 'main' is exported, -- and generate the runMainIO binding that calls it View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8a869da4677588fdb808ee85dc2318… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8a869da4677588fdb808ee85dc2318… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/az/exactprint-annotation-rationalisation
by Alan Zimmerman (＠alanz) 29 May '26

29 May '26

Alan Zimmerman pushed new branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/exactprint-annotation-rati… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/mangoiv/ghc-9.12-bp] 2 commits: Fixes for black holes
by Magnus (＠MangoIV) 28 May '26

28 May '26

Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: dddf7bea by Luite Stegeman at 2026-05-28T22:50:24+02:00 Fixes for black holes - suspend duplicate work for eager black holes - detect eager black holes in checkBlockingQueues - don't overwrite existing black holes even if they're not in an eager blackhole frame - don't deadlock on self when thunk is already blackholed Fixes #26936 (cherry picked from commit 63ce5770da1712f0da54665d8755772bf38ba51e) - - - - - 4433f73d by Tom McLaughlin at 2026-05-28T22:51:40+02:00 Event/Windows.hsc: rethrow exceptions in overlapped IO This prevents the WinIO manager from swallowing exceptions in overlapped IO. It was added to make WinIO support possible in the `network` library. See https://gitlab.haskell.org/ghc/ghc/-/issues/27283. We also bump __IO_MANAGER_WINIO__ to 2 so libraries can gate on this using CPP. (cherry picked from commit 037a80dc65d3975adf4a35d46876850e644bc80e) - - - - - 9 changed files: - + changelog.d/fix-blackhole-handling - + changelog.d/windows-rethrow-overlapped-exception - compiler/GHC/SysTools/Cpp.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - rts/Messages.c - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.h - rts/include/rts/storage/ClosureMacros.h Changes: ===================================== changelog.d/fix-blackhole-handling ===================================== @@ -0,0 +1,6 @@ +section: rts +synopsis: Fix several black hole handling bugs that could lead to deadlocks + or crashes in multithreaded programs. These could show up as the program + hanging or "END_TSO_QUEUE object entered" errors. +issues: #26922 #26936 +mrs: !15640 ===================================== changelog.d/windows-rethrow-overlapped-exception ===================================== @@ -0,0 +1,8 @@ +section: rts +synopsis: Rethrow exceptions in overlapped IO when using the WinIO IO manager. +issues: #27283 +mrs: !15887 + +description: { + This change was made to support WinIO in the network library; see https://github.com/haskell/network/issues/602. +} ===================================== compiler/GHC/SysTools/Cpp.hs ===================================== @@ -149,7 +149,7 @@ doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do -- and BUILD is the same as our HOST. let io_manager_defs = - [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++ + [ "-D__IO_MANAGER_WINIO__=2" | isWindows ] ++ [ "-D__IO_MANAGER_MIO__=1" ] let sse_defs = ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc ===================================== @@ -687,7 +687,11 @@ withOverlappedEx mgr fname h async offset startCB completionCB = do -- can go into an unbounded alertable wait. delay <- runExpiredTimeouts mgr registerAlertableWait delay - return $ IOFailed Nothing + -- Re-throw the original exception rather than + -- returning IOFailed. This ensures that async + -- exceptions (e.g. Timeout from System.Timeout) + -- propagate correctly to their handlers. + E.throw e let runner = do debugIO $ (dbgMsg ":: waiting ") ++ " | " ++ show lpol res <- readIOPort signal `catch` cancel debugIO $ dbgMsg ":: signaled " ===================================== rts/Messages.c ===================================== @@ -176,10 +176,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // BLACKHOLE has already been updated, and GC has shorted out the // indirection, so the pointer no longer points to a BLACKHOLE at // all. - if (bh_info != &stg_BLACKHOLE_info && - bh_info != &stg_CAF_BLACKHOLE_info && - bh_info != &__stg_EAGER_BLACKHOLE_info && - bh_info != &stg_WHITEHOLE_info) { + if (!IS_BLACKHOLE_OR_WHITEHOLE_INFO(bh_info)) { return 0; } @@ -338,10 +335,7 @@ StgTSO * blackHoleOwner (StgClosure *bh) info = RELAXED_LOAD(&bh->header.info); - if (info != &stg_BLACKHOLE_info && - info != &stg_CAF_BLACKHOLE_info && - info != &__stg_EAGER_BLACKHOLE_info && - info != &stg_WHITEHOLE_info) { + if (!IS_BLACKHOLE_OR_WHITEHOLE_INFO(info)) { return NULL; } ===================================== rts/ThreadPaused.c ===================================== @@ -183,6 +183,30 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) } } +/* + * Check whether tso is the owner of the black hole bh. + * + * We must call this from the capability that runs tso, + * since that guarantees that the writes to bh->indirectee + * by tso claiming ownership have been visible. If another + * tso has claimed it again afterwards we can safely suspend + * our work. + */ +static bool +threadPausedBlackHoleOwner(StgTSO *tso, StgClosure *bh) +{ + StgClosure *ind = RELAXED_LOAD(&((StgInd*)bh)->indirectee); + if (ind == (StgClosure*)tso) { + return true; + } + const StgInfoTable *ind_info = GET_INFO(UNTAG_CLOSURE(ind)); + if (ind_info == &stg_BLOCKING_QUEUE_CLEAN_info + || ind_info == &stg_BLOCKING_QUEUE_DIRTY_info) { + return ((StgBlockingQueue*)UNTAG_CLOSURE(ind))->owner == tso; + } + return false; +} + /* ----------------------------------------------------------------------------- * Pausing a thread * @@ -255,11 +279,10 @@ threadPaused(Capability *cap, StgTSO *tso) // Note [suspend duplicate work] // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ // If the info table is a WHITEHOLE or a BLACKHOLE, then - // another thread has claimed it (via the SET_INFO() - // below), or is in the process of doing so. In that case - // we want to suspend the work that the current thread has - // done on this thunk and wait until the other thread has - // finished. + // some thread has claimed it, or is in the process of doing + // so. In that case we want to suspend the work that the + // current thread has done on this thunk and wait until the + // other thread has finished. // // If eager blackholing is taking place, it could be the // case that the blackhole points to the current @@ -287,8 +310,8 @@ threadPaused(Capability *cap, StgTSO *tso) // Note that great care is required when entering computations // suspended by this mechanism. See Note [AP_STACKs must be eagerly // blackholed] for details. - if (((bh_info == &stg_BLACKHOLE_info) - && (RELAXED_LOAD(&((StgInd*)bh)->indirectee) != (StgClosure*)tso)) + if ((IS_BLACKHOLE_INFO(bh_info) + && !threadPausedBlackHoleOwner(tso, bh)) || (bh_info == &stg_WHITEHOLE_info)) { debugTrace(DEBUG_squeeze, @@ -318,14 +341,14 @@ threadPaused(Capability *cap, StgTSO *tso) // If we have a frame that is already eagerly blackholed, we // shouldn't overwrite its payload: There may already be a blocking // queue (see #26324). - if(frame_info == &stg_bh_upd_frame_info) { - // eager black hole: we do nothing - - // it should be a black hole that we own - ASSERT(bh_info == &stg_BLACKHOLE_info || - bh_info == &__stg_EAGER_BLACKHOLE_info || - bh_info == &stg_CAF_BLACKHOLE_info); - ASSERT(blackHoleOwner(bh) == tso || blackHoleOwner(bh) == NULL); + if(frame_info == &stg_bh_upd_frame_info + || IS_BLACKHOLE_INFO(bh_info)) { + // already a black hole: we do nothing + + // it should be a black hole (but we may not own it, as another + // thread could have raced us to claim it) + ASSERT(IS_BLACKHOLE_INFO(bh_info)); + } else { // lazy black hole ===================================== rts/Threads.c ===================================== @@ -439,7 +439,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) // thing the result would be the same in almost all cases. See #20093. p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); - if (pinfo != &stg_BLACKHOLE_info || + if (!IS_BLACKHOLE_INFO(pinfo) || (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); @@ -463,10 +463,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) const StgInfoTable *i; i = ACQUIRE_LOAD(&thunk->header.info); - if (i != &stg_BLACKHOLE_info && - i != &stg_CAF_BLACKHOLE_info && - i != &__stg_EAGER_BLACKHOLE_info && - i != &stg_WHITEHOLE_info) { + if (!IS_BLACKHOLE_OR_WHITEHOLE_INFO(i)) { updateWithIndirection(cap, thunk, val); return; } ===================================== rts/Updates.h ===================================== @@ -190,9 +190,9 @@ * frame is encountered, it checks the info table of the updatee and: * * - if it is `BLACKHOLE`, then the thunk has already been claimed for evaluation - * by another thread, and the yielding thread is instead added to the - * `BLACKHOLE`'s blocking queue (see Note [suspend duplicate work] in - * `ThreadPaused.c`). + * by some thread. If that's not the yielding thread itself, the yielding thread + * is added to the `BLACKHOLE`'s blocking queue (see Note [suspend duplicate + * work] in `ThreadPaused.c`). * * - if not, then it blackholes the thunk as done in eager blackholing (but * using the `BLACKHOLE_info` info table instead of `EAGER_BLACKHOLE_info`). ===================================== rts/include/rts/storage/ClosureMacros.h ===================================== @@ -374,6 +374,18 @@ EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void ); EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void ) { return sizeofW(StgInd); } // a BLACKHOLE is a kind of indirection +/* ----------------------------------------------------------------------------- + Blackhole predicates + -------------------------------------------------------------------------- */ + +#define IS_BLACKHOLE_INFO(info) \ + ((info) == &stg_BLACKHOLE_info || \ + (info) == &__stg_EAGER_BLACKHOLE_info || \ + (info) == &stg_CAF_BLACKHOLE_info) + +#define IS_BLACKHOLE_OR_WHITEHOLE_INFO(info) \ + (IS_BLACKHOLE_INFO(info) || (info) == &stg_WHITEHOLE_info) + /* -------------------------------------------------------------------------- Sizes of closures ------------------------------------------------------------------------*/ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/007b39e6469126a4e3269a28cabedc… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/007b39e6469126a4e3269a28cabedc… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Prevent dictionary-passing in checkTyEqRhs
by Marge Bot (＠marge-bot) 28 May '26

28 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b8ba7e61 by Simon Jakobi at 2026-05-28T17:32:23-04:00 Prevent dictionary-passing in checkTyEqRhs ...by pre-specializing it to TcM. Previously, wherever checkTyEqRhs was used in other modules, the Core showed dictionary passing ($fMonadIOEnv). The added SPECIALIZE pragma prevents this. - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -4240,6 +4240,8 @@ checkTyEqRhs flags rhs = recurseIntoFamTyConApp flags tc tys | otherwise = check_ty_eq_rhs flags rhs +-- Prevent dictionary-passing when checkTyEqRhs is used in TcM in other modules: +{-# SPECIALIZE checkTyEqRhs :: TyEqFlags TcM a -> TcType -> TcM (PuResult a Reduction) #-} {- Note [Special case for top-level of Given equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8ba7e61ef3d076cf14cdac4fd0c470… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8ba7e61ef3d076cf14cdac4fd0c470… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] foundation test: skip signed minBound `quot` (-1) (#27222)
by Marge Bot (＠marge-bot) 28 May '26

28 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4ce251e4 by Sylvain Henry at 2026-05-28T17:31:39-04:00 foundation test: skip signed minBound `quot` (-1) (#27222) `minBound `quot` (-1)` for fixed-width signed integers is platform dependent: the mathematical result -minBound is not representable in the type. On x86, IDIV traps; LLVM's sdiv is undefined behaviour in this case; on AArch64/RISC-V, SDIV wraps to minBound. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply(a)anthropic.com> - - - - - 2 changed files: - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/numeric/should_run/foundation.hs Changes: ===================================== testsuite/tests/MiniQuickCheck.hs ===================================== @@ -27,6 +27,7 @@ module MiniQuickCheck , (===) , propertyCompare , propertyAnd + , propertyTrue , getCheck -- * QuickCheck test tree @@ -144,6 +145,10 @@ infix 4 === propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck propertyAnd = PropertyAnd +-- | A property check that trivially holds. Useful to mark a case to skip. +propertyTrue :: PropertyCheck +propertyTrue = PropertyBinaryOp True "trivially" "" "" + -------------------------------------------------------------------------------- -- Test tree ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -82,11 +82,10 @@ testMultiplicative _ = Group "Multiplicative" testDivisible :: forall a . (Show a, Eq a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a) => Proxy a -> Test testDivisible _ = Group "Divisible" - [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) -> - -- See Note [Skipping minBound `div` (-1)]. - if (minBound :: a) < 0 && a == minBound && b == (-1) - then True === True - else a === (a `div` b) * b + (a `mod` b) + [ Property "(x `div` y) * y + (x `mod` y) == x" $ + -- 'safeDivArgs' skips (minBound, -1) for signed types; see + -- Note [Skipping signed quot/rem on minBound `quot` (-1)]. + safeDivArgs (\(a :: a) b -> a === (a `div` b) * b + (a `mod` b)) ] -- | Divisibility test for unbounded Integral types (Integer). No overflow @@ -98,21 +97,6 @@ testDivisibleUnbounded _ = Group "Divisible" a === (a `div` b) * b + (a `mod` b) ] --- Note [Skipping minBound `div` (-1)] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- For a fixed-width *signed* Integral type, `minBound `div` (-1)` raises --- ArithException(Overflow) because `-minBound` is not representable in the --- type (e.g., for Int8, `-(-128)` would be 128, out of range). The div/mod --- identity property cannot hold there, so we skip exactly that one pair. --- --- We detect "signed Bounded" with `(minBound :: a) < 0`: True for Int{N}, --- False for Word{N}. This way unsigned Bounded types lose no coverage, --- and only the genuine overflow sample is skipped for signed types. --- --- For the unbounded `Integer`, no overflow can occur and we use a separate --- 'testDivisibleUnbounded' (without the Bounded constraint or the skip). --- See #27222. - testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a) => Proxy a -> Test testOperatorPrecedence _ = Group "Precedence" @@ -263,8 +247,29 @@ instance TestPrimop LowerBitsAreDefined where valR = wWord# (undefinedBehavior r x0) .&. mask in valL === valR -twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b -twoNonZero f x (NonZero y) = f x y +-- | Discharge a property over a non-zero divisor. For signed types, also +-- skip the @(minBound, -1)@ pair, where signed quot/rem is platform +-- dependent. For unsigned types (where @minBound = 0@), no additional skip +-- happens. +-- See Note [Skipping signed quot/rem on minBound `quot` (-1)]. +safeDivArgs + :: (Bounded a, Ord a, Num a) + => (a -> a -> PropertyCheck) + -> a -> NonZero a -> PropertyCheck +safeDivArgs f x (NonZero y) + | x == minBound, x < 0, y == (-1) = propertyTrue + | otherwise = f x y + +-- Note [Skipping signed quot/rem on minBound `quot` (-1)] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For a fixed-width signed integer type, `minBound `quot` (-1)` is platform +-- dependent: the mathematical result `-minBound` is not representable in the +-- type. On x86, IDIV traps; LLVM's sdiv is undefined behavior in this case; on +-- AArch64/RISC-V, SDIV wraps to minBound. +-- +-- Without the skip quickcheck eventually picks `(minBound, -1)` and the test +-- crashes on the affected primops on platforms where signed quot/rem traps. +-- See #27222. main :: IO () main = runTestsMain (Iterations 1000) (Group "ALL" [testNumberRefs, testPrimops]) @@ -535,7 +540,7 @@ instance TestPrimop (Char# -> Int#) where instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShiftAmount @Int shift) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift)) -- | Compare two 'mulIntMayOflo#'-like primops only on whether their result @@ -565,11 +570,11 @@ testPrimopMayOflo s l r = instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) instance TestPrimop (Int# -> Int# -> (# Int#,Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1)) instance TestPrimop (Int# -> Char#) where testPrimop s l r = Property s $ \ (uInt#-> x0) -> wChar# (l x0) === wChar# (r x0) @@ -598,15 +603,15 @@ instance TestPrimop (Int16# -> Int# -> Int16#) where instance TestPrimop (Int16# -> Int16# -> Int#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int16# -> Int16# -> Int16#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1) instance TestPrimop (Int16# -> Int16# -> (# Int16#,Int16# #)) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1)) instance TestPrimop (Int16# -> Int#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -623,15 +628,15 @@ instance TestPrimop (Int32# -> Int# -> Int32#) where instance TestPrimop (Int32# -> Int32# -> Int#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int32# -> Int32# -> Int32#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1) instance TestPrimop (Int32# -> Int32# -> (# Int32#,Int32# #)) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1)) instance TestPrimop (Int32# -> Int#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -648,11 +653,11 @@ instance TestPrimop (Int64# -> Int# -> Int64#) where instance TestPrimop (Int64# -> Int64# -> Int#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int64# -> Int64# -> Int64#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1) instance TestPrimop (Int64# -> Int#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -669,15 +674,15 @@ instance TestPrimop (Int8# -> Int# -> Int8#) where instance TestPrimop (Int8# -> Int8# -> Int#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Int8# -> Int8# -> Int8#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1) instance TestPrimop (Int8# -> Int8# -> (# Int8#,Int8# #)) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1)) instance TestPrimop (Int8# -> Int#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -694,19 +699,19 @@ instance TestPrimop (Word# -> Int# -> Word#) where instance TestPrimop (Word# -> Word# -> Int#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word# -> Word# -> Word#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) instance TestPrimop (Word# -> Word# -> (# Word#,Int# #)) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1)) instance TestPrimop (Word# -> Word# -> (# Word#,Word# #)) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1)) instance TestPrimop (Word# -> Int#) where testPrimop s l r = Property s $ \ (uWord#-> x0) -> wInt# (l x0) === wInt# (r x0) @@ -732,15 +737,15 @@ instance TestPrimop (Word16# -> Int# -> Word16#) where instance TestPrimop (Word16# -> Word16# -> Int#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word16# -> Word16# -> Word16#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1) instance TestPrimop (Word16# -> Word16# -> (# Word16#,Word16# #)) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1)) instance TestPrimop (Word16# -> Int16#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wInt16# (l x0) === wInt16# (r x0) @@ -757,15 +762,15 @@ instance TestPrimop (Word32# -> Int# -> Word32#) where instance TestPrimop (Word32# -> Word32# -> Int#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word32# -> Word32# -> Word32#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1) instance TestPrimop (Word32# -> Word32# -> (# Word32#,Word32# #)) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1)) instance TestPrimop (Word32# -> Int32#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wInt32# (l x0) === wInt32# (r x0) @@ -782,11 +787,11 @@ instance TestPrimop (Word64# -> Int# -> Word64#) where instance TestPrimop (Word64# -> Word64# -> Int#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word64# -> Word64# -> Word64#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1) instance TestPrimop (Word64# -> Int64#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wInt64# (l x0) === wInt64# (r x0) @@ -803,15 +808,15 @@ instance TestPrimop (Word8# -> Int# -> Word8#) where instance TestPrimop (Word8# -> Word8# -> Int#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) instance TestPrimop (Word8# -> Word8# -> Word8#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1) instance TestPrimop (Word8# -> Word8# -> (# Word8#,Word8# #)) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1)) - testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1)) + testPrimopDivLike s l r = Property s $ safeDivArgs $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1)) instance TestPrimop (Word8# -> Int8#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wInt8# (l x0) === wInt8# (r x0) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ce251e48cd03bb856437d2c8794fa6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4ce251e48cd03bb856437d2c8794fa6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Add optional config setting for LibDir (#19174)
by Marge Bot (＠marge-bot) 28 May '26

28 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ed29a5e6 by Sven Tennie at 2026-05-28T17:30:36-04:00 Add optional config setting for LibDir (#19174) Previously, the `libDir` was derived from `topDir`. This won't work for inplace stage2 cross-compilers where binaries and libraries are in different stage dirs (`_build/stage1/` for executables and `_build/stage2` for libraries). `LibDir` is set in the inplace `settings` files. For bindists, we generate a new `settings` file with no `LibDir` entry. GHC then defaults to use `topDir` as `libDir` again. This keeps the bindist relocatable. If `LibDir` is a relative path, it is interpreted relatively to `topDir`. The global package db is part of the `lib/` folder. If we want to point for inplace cross-compilers to the succeeding stage's folder, this is done by setting `LibDir`. Thus, the global package db must be found relative to `libDir`` (which may default to `topDir` or be set by `LibDir`). The complexity of settings becomes scary. So, add a test to ensure `LibDir` works as expected. - - - - - 8339cf8f by Sven Tennie at 2026-05-28T17:30:36-04:00 Add Haddock to FileSettings Helping to understand the fields' meanings without deeper analyses. - - - - - 12 changed files: - + changelog.d/libdir-setting - compiler/GHC/Driver/Config/Interpreter.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/Generate.hs - libraries/ghc-boot/GHC/Settings/Utils.hs - + testsuite/tests/ghc-api/settings/LibDir.hs - + testsuite/tests/ghc-api/settings/LibDir.stdout - + testsuite/tests/ghc-api/settings/all.T Changes: ===================================== changelog.d/libdir-setting ===================================== @@ -0,0 +1,18 @@ +section: packaging +synopsis: Added a new optional configuration setting for `LibDir` to support inplace + stage2 cross-compilers where binaries and libraries are in different stage + directories. +issues: #19174 +mrs: !15716 + +description: { + Previously, `libDir` was always derived from `topDir`, which does not work + for inplace stage2 cross-compilers where executables live in `_build/stage1/` + but libraries live in `_build/stage2/`. A new optional `LibDir` setting in the + `settings` file allows overriding this. When absent (e.g. in bindists), + `libDir` defaults to `topDir`, preserving relocatability. + + The global package database path is now resolved relative to `libDir` + (which may differ from `topDir` when `LibDir` is set). This affects inplace + cross-compiler builds but is transparent to normal and bindist builds. +} ===================================== compiler/GHC/Driver/Config/Interpreter.hs ===================================== @@ -17,8 +17,8 @@ import System.Directory initInterpOpts :: DynFlags -> IO InterpOpts initInterpOpts dflags = do - wasm_dyld <- makeAbsolute $ topDir dflags </> "dyld.mjs" - js_interp <- makeAbsolute $ topDir dflags </> "ghc-interp.js" + wasm_dyld <- makeAbsolute $ libDir dflags </> "dyld.mjs" + js_interp <- makeAbsolute $ libDir dflags </> "ghc-interp.js" pure $ InterpOpts { interpExternal = gopt Opt_ExternalInterpreter dflags , interpProg = pgm_i dflags ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -61,7 +61,7 @@ module GHC.Driver.DynFlags ( -- ** System tool settings and locations programName, projectVersion, - ghcUsagePath, ghciUsagePath, topDir, toolDir, + ghcUsagePath, ghciUsagePath, topDir, libDir, toolDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, @@ -1516,6 +1516,8 @@ ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags topDir :: DynFlags -> FilePath topDir dflags = fileSettings_topDir $ fileSettings dflags +libDir :: DynFlags -> FilePath +libDir dflags = fileSettings_libDir $ fileSettings dflags toolDir :: DynFlags -> Maybe FilePath toolDir dflags = fileSettings_toolDir $ fileSettings dflags extraGccViaCFlags :: DynFlags -> [String] ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3551,9 +3551,9 @@ compilerInfo dflags ("Project name", cProjectName) -- Next come the settings, so anything else can be overridden -- in the settings file (as "lookup" uses the first match for the - -- key) + -- key). We filter out LibDir from rawSettings to avoid duplication. : map (fmap expandDirectories) - (rawSettings dflags) + (filter ((/= "LibDir") . fst) (rawSettings dflags)) ++ [("C compiler command", queryCmd $ ccProgram . tgtCCompiler), ("C compiler flags", queryFlags $ ccProgram . tgtCCompiler), @@ -3656,7 +3656,7 @@ compilerInfo dflags -- Whether or not GHC was compiled using -prof ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), - ("LibDir", topDir dflags), + ("LibDir", libDir dflags), -- This is always an absolute path, unlike "Relative Global Package DB" which is -- in the settings file. ("Global Package DB", globalPackageDatabasePath dflags) ===================================== compiler/GHC/Settings.hs ===================================== @@ -179,11 +179,24 @@ data ToolSettings = ToolSettings -- | Paths to various files and directories used by GHC, including those that -- provide more settings. data FileSettings = FileSettings - { fileSettings_ghcUsagePath :: FilePath -- ditto - , fileSettings_ghciUsagePath :: FilePath -- ditto - , fileSettings_toolDir :: Maybe FilePath -- ditto - , fileSettings_topDir :: FilePath -- ditto + { fileSettings_ghcUsagePath :: FilePath + -- ^ Path to @ghc-usage.txt@, displayed by @ghc --help@ + , fileSettings_ghciUsagePath :: FilePath + -- ^ Path to @ghci-usage.txt@, displayed by @ghci --help@ + , fileSettings_toolDir :: Maybe FilePath + -- ^ Directory containing the mingw toolchain (Windows only); + -- see Note [tooldir: How GHC finds mingw on Windows] in `GHC.SysTools.BaseDir` + , fileSettings_topDir :: FilePath + -- ^ GHC's top directory: the root from which GHC locates its support files + -- (e.g. settings). + -- See Note [topdir: How GHC finds its files] in `GHC.SysTools.BaseDir` , fileSettings_globalPackageDatabase :: FilePath + -- ^ Path to the global package database, relative to `libDir` + , fileSettings_libDir :: FilePath + -- ^ Directory containing GHC's library packages and the global package + -- database. Defaults to 'fileSettings_topDir' but can differ in inplace + -- builds used for cross-compilation testing (the "stage2 cross-compiler" + -- scenario). } ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -28,6 +28,7 @@ import GHC.Toolchain.Program import GHC.Toolchain import GHC.Data.Maybe import Data.Bifunctor (Bifunctor(second)) +import Data.Either (fromRight) data SettingsError = SettingsError_MissingData String @@ -117,12 +118,6 @@ initSettings top_dir = do then ["-fwrapv", "-fno-builtin"] else [] - -- The package database is either a relative path to the location of the settings file - -- OR an absolute path. - -- In case the path is absolute then top_dir </> abs_path == abs_path - -- the path is relative then top_dir </> rel_path == top_dir </> rel_path - globalpkgdb_path <- installed <$> getSetting "Relative Global Package DB" - let ghc_usage_msg_path = installed "ghc-usage.txt" ghci_usage_msg_path = installed "ghci-usage.txt" @@ -148,6 +143,19 @@ initSettings top_dir = do baseUnitId <- getSetting_raw "base unit-id" + -- LibDir is optional. If not set, derive it from topDir. This allows + -- bindists to work without explicitly setting LibDir, but gives us the + -- option to override it for inplace test compilers (the "stage2 + -- cross-compiler" scenario). If LibDir is a relative path, it is + -- interpreted relative to topDir. + let lib_dir = installed $ fromRight "." $ + getRawFilePathSetting top_dir settingsFile mySettings "LibDir" + + -- The package database is either a relative path to lib_dir OR an absolute path. + -- In case the path is absolute then lib_dir </> abs_path == abs_path + -- the path is relative then lib_dir </> rel_path == lib_dir </> rel_path + globalpkgdb_path <- (lib_dir </>) <$> getSetting "Relative Global Package DB" + return $ Settings { sGhcNameVersion = GhcNameVersion { ghcNameVersion_programName = "ghc" @@ -159,6 +167,7 @@ initSettings top_dir = do , fileSettings_ghciUsagePath = ghci_usage_msg_path , fileSettings_toolDir = mtool_dir , fileSettings_topDir = top_dir + , fileSettings_libDir = lib_dir , fileSettings_globalPackageDatabase = globalpkgdb_path } ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -14,6 +14,7 @@ import qualified System.Directory.Extra as IO import Data.Either import qualified Data.Set as Set import Oracles.Flavour +import Rules.Generate (generateSettings) {- Note [Binary distributions] @@ -218,6 +219,17 @@ bindistRules = do IO.createFileLink version_prog versioned_runhaskell_path copyDirectory (ghcBuildDir -/- "lib") bindistFilesDir + + -- Regenerate settings file without LibDir. For bindists, LibDir should + -- be derived from topdir at runtime such that the GHC binary is + -- relocatable. The package DB is always at "package.conf.d" relative to + -- the lib dir, matching the known bindist layout. + let bindistSettings = bindistFilesDir -/- "lib" -/- "settings" + bindistContext = vanillaContext Stage1 compiler + bindistSettingsContent <- interpretInContext bindistContext $ + generateSettings bindistSettings False "package.conf.d" + writeFile' bindistSettings bindistSettingsContent + copyDirectory (rtsIncludeDir) bindistFilesDir when windowsHost $ createGhcii (bindistFilesDir -/- "bin") ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -1,7 +1,7 @@ module Rules.Generate ( isGeneratedCmmFile, compilerDependencies, generatePackageCode, generateRules, copyRules, generatedDependencies, - templateRules + templateRules, generateSettings ) where import Development.Shake.FilePath @@ -256,8 +256,21 @@ generateRules = do forM_ allStages $ \stage -> do let prefix = root -/- stageString stage -/- "lib" - go gen file = generate file (semiEmptyTarget (succStage stage)) gen - (prefix -/- "settings") %> \out -> go (generateSettings out) out + -- Stage0 compiler builds Stage1, Stage1 -> Stage2, etc. + buildStage = succStage stage + go gen file = generate file (semiEmptyTarget buildStage) gen + (prefix -/- "settings") %> \out -> do + let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final) + pkgDb <- case buildStage of + Stage0 {} -> error "Unable to generate settings for stage0. This should never be reached." + Stage1 -> get_pkg_db Stage1 + Stage2 -> get_pkg_db Stage1 + Stage3 -> get_pkg_db Stage2 + -- addTrailingPathSeparator needed: makeRelativeNoSysLink uses + -- splitPath where "lib" and "lib/" are distinct components. + let lib_topDir = addTrailingPathSeparator prefix + relPkgDb = makeRelativeNoSysLink lib_topDir pkgDb + go (generateSettings out True relPkgDb) out (prefix -/- "targets" -/- "default.target") %> \out -> go (show <$> expr getTargetTarget) out where @@ -460,19 +473,17 @@ ghcWrapper stage = do return $ unwords $ map show $ [ ghcPath ] ++ [ "$@" ] -generateSettings :: FilePath -> Expr String -generateSettings settingsFile = do +-- | Generate settings file, optionally including @LibDir@. +-- +-- @rel_pkg_db@: package DB path relative to the lib dir (e.g. +-- "package.conf.d"). Callers supply the correct relative path. For bindists +-- the layout is known statically; for in-tree builds callers compute it. For +-- bindists, we omit @LibDir@ so it defaults to @topDir@ at runtime. +generateSettings :: FilePath -> Bool -> FilePath -> Expr String +generateSettings settingsFile includeLibDir rel_pkg_db = do ctx <- getContext stage <- getStage - package_db_path <- expr $ do - let get_pkg_db stg = packageDbPath (PackageDbLoc stg Final) - case stage of - Stage0 {} -> error "Unable to generate settings for stage0" - Stage1 -> get_pkg_db Stage1 - Stage2 -> get_pkg_db Stage1 - Stage3 -> get_pkg_db Stage2 - -- The unit-id of the base package which is always linked against (#25382) base_unit_id <- expr $ do case stage of @@ -481,15 +492,24 @@ generateSettings settingsFile = do Stage2 -> pkgUnitId Stage1 base Stage3 -> pkgUnitId Stage2 base - let rel_pkg_db = makeRelativeNoSysLink (dropFileName settingsFile) package_db_path + let -- E.g. the Stage2 compiler lives in _build/stage1 + -- So, we need to decrement the stage to get the correct directory + stage_dir_stage = predStage stage + + -- addTrailingPathSeparator is needed because makeRelativeNoSysLink uses + -- splitPath internally, where "lib" and "lib/" are distinct components. + lib_topDir :: FilePath <- expr $ addTrailingPathSeparator <$> stageLibPath stage_dir_stage + let rel_lib_topDir = makeRelativeNoSysLink (dropFileName settingsFile) lib_topDir settings <- traverse sequence $ - [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) - , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) - , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays) - , ("Relative Global Package DB", pure rel_pkg_db) - , ("base unit-id", pure base_unit_id) - ] + [ ("unlit command", ("$topdir/../bin/" <>) <$> expr (programName (ctx { Context.package = unlit }))) + , ("Use interpreter", expr $ yesNo <$> ghcWithInterpreter (predStage stage)) + , ("RTS ways", escapeArgs . map show . Set.toList <$> getRtsWays) + , ("Relative Global Package DB", pure rel_pkg_db) + , ("base unit-id", pure base_unit_id) + ] + ++ ([("LibDir", pure rel_lib_topDir) | includeLibDir]) + let showTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")" pure $ case settings of [] -> "[]" ===================================== libraries/ghc-boot/GHC/Settings/Utils.hs ===================================== @@ -3,6 +3,7 @@ module GHC.Settings.Utils where import Prelude -- See Note [Why do we import Prelude here?] import Data.Char (isSpace) +import Data.Either (fromRight) import Data.Map (Map) import qualified Data.Map as Map @@ -45,7 +46,10 @@ 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) + let top_dir = dropFileName settingsFile + lib_dir = (top_dir </>) $ fromRight "." $ + getRawFilePathSetting top_dir settingsFile settings "LibDir" + return (lib_dir </> rel_db) -------------------------------------------------------------------------------- -- lib/settings ===================================== testsuite/tests/ghc-api/settings/LibDir.hs ===================================== @@ -0,0 +1,130 @@ +module Main where + +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Data.List (intercalate) +import GHC +import GHC.Driver.DynFlags +import GHC.Driver.Env (hsc_dflags) +import GHC.Settings +import System.Directory +import System.Environment +import System.Exit (ExitCode (ExitFailure), exitWith) +import System.FilePath +import System.IO (hPutStrLn, stderr) +import System.Process (readProcess) +import Unsafe.Coerce (unsafeCoerce) + +-- Verify that a LibDir setting in the settings file is respected: +-- 1. fileSettings_libDir and fileSettings_globalPackageDatabase reflect the +-- configured LibDir path (not topDir) +-- 2. GHC can still compile with a LibDir that differs from topDir +-- 3. --print-libdir and --print-global-package-db output the correct paths +-- +-- We create a symlink to the real lib dir so that the package DB remains +-- findable, but use a separate topDir so that topDir ≠ libDir, proving +-- the LibDir setting is actually used. +-- +-- Tested for both relative and absolute LibDir values. +main :: IO () +main = do + libdir : ghcBin : _ <- getArgs + + (rawSettingOpts, rawTargetOpts, realLibDir) <- runGhc (Just libdir) $ do + dflags <- hsc_dflags <$> getSession + pure (rawSettings dflags, rawTarget dflags, fileSettings_libDir (fileSettings dflags)) + + tmpDir <- getTemporaryDirectory + let topDir = tmpDir </> "T19174_top" + symlinkLib = tmpDir </> "T19174_lib" + -- Remove stale dirs from prior runs; createDirectoryLink fails if path exists. + removePathForcibly topDir + removePathForcibly symlinkLib + createDirectoryIfMissing True (topDir </> "targets") + createDirectoryLink realLibDir symlinkLib + + let testWithLibDir libDirValue = do + writeTopDirFiles topDir rawSettingOpts rawTargetOpts libDirValue + runGhc (Just topDir) $ do + assertSettings topDir symlinkLib + compileAndRunTestExpr + assertGhcFlags ghcBin topDir symlinkLib + + testWithLibDir (".." </> takeFileName symlinkLib) + testWithLibDir symlinkLib + + putStrLn "OK" + +writeTopDirFiles :: + (Show a) => + FilePath -> + [(String, String)] -> + a -> + String -> + IO () +writeTopDirFiles topDir rawSettingOpts rawTargetOpts libDirValue = do + let settings = filter ((/= "LibDir") . fst) rawSettingOpts ++ [("LibDir", libDirValue)] + writeFile (topDir </> "settings") $ + "[" ++ intercalate "\n," (map show settings) ++ "]" + writeFile (topDir </> "targets" </> "default.target") $ + show rawTargetOpts + +assertSettings :: FilePath -> FilePath -> Ghc () +assertSettings topDir expectedLib = do + dflags <- hsc_dflags <$> getSession + let fs = fileSettings dflags + actualLib = fileSettings_libDir fs + actualPkgDb = fileSettings_globalPackageDatabase fs + normActualLib <- liftIO $ canonicalizePath actualLib + normExpected <- liftIO $ canonicalizePath expectedLib + normTopDir <- liftIO $ canonicalizePath topDir + normActualPkgDb <- liftIO $ canonicalizePath actualPkgDb + normExpectedPkgDb <- liftIO $ canonicalizePath (expectedLib </> "package.conf.d") + liftIO $ do + when (normActualLib /= normExpected) $ + die + [ "FAIL: libDir should be " ++ normExpected, + " got " ++ normActualLib + ] + when (normActualLib == normTopDir) $ + die ["FAIL: libDir equals topDir — LibDir setting was ignored"] + when (normActualPkgDb /= normExpectedPkgDb) $ + die + [ "FAIL: globalPackageDB should be " ++ normExpectedPkgDb, + " got " ++ normActualPkgDb + ] + +assertGhcFlags :: FilePath -> FilePath -> FilePath -> IO () +assertGhcFlags ghcBin topDir expectedLib = do + normExpectedLib <- canonicalizePath expectedLib + normExpectedPkgDb <- canonicalizePath (expectedLib </> "package.conf.d") + + printedLibDir <- trim <$> readProcess ghcBin ["-B" ++ topDir, "--print-libdir"] "" + normPrintedLib <- canonicalizePath printedLibDir + when (normPrintedLib /= normExpectedLib) $ + die + [ "FAIL: --print-libdir should be " ++ normExpectedLib, + " got " ++ normPrintedLib + ] + + printedPkgDb <- trim <$> readProcess ghcBin ["-B" ++ topDir, "--print-global-package-db"] "" + normPrintedPkgDb <- canonicalizePath printedPkgDb + when (normPrintedPkgDb /= normExpectedPkgDb) $ + die + [ "FAIL: --print-global-package-db should be " ++ normExpectedPkgDb, + " got " ++ normPrintedPkgDb + ] + +compileAndRunTestExpr :: Ghc () +compileAndRunTestExpr = do + dflags <- getSessionDynFlags + _ <- setSessionDynFlags dflags + setContext [IIDecl (simpleImportDecl (mkModuleName "Prelude"))] + result <- compileExpr "length [1,2,3 :: Int]" + liftIO $ print (unsafeCoerce result :: Int) + +trim :: String -> String +trim = reverse . dropWhile (== '\n') . reverse + +die :: [String] -> IO () +die msgs = mapM_ (hPutStrLn stderr) msgs >> exitWith (ExitFailure 1) ===================================== testsuite/tests/ghc-api/settings/LibDir.stdout ===================================== @@ -0,0 +1,3 @@ +3 +3 +OK ===================================== testsuite/tests/ghc-api/settings/all.T ===================================== @@ -0,0 +1,12 @@ +test('LibDir', + [ extra_run_opts('"' + config.libdir + '" "' + config.compiler + '"') + , req_interp + # createDirectoryLink uses CreateSymbolicLink on Windows (requires developer + # mode or admin); also GHC searches for mingw relative to topDir, which our + # artificial topDir doesn't provide. + , when(opsys('mingw32'), skip) + # TODO: wasm CI image lacks permission to create symlinks in temp dir (`/tmp`). + , when(arch('wasm32'), skip) + ] + , compile_and_run + , ['-package ghc -package directory -package filepath']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f4fbb5832f210f7e1240f626880ad7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f4fbb5832f210f7e1240f626880ad7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/int-index/visible-forall-gadts
by Vladislav Zavialov (＠int-index) 28 May '26

28 May '26

Vladislav Zavialov deleted branch wip/int-index/visible-forall-gadts at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/int-index/t25960
by Vladislav Zavialov (＠int-index) 28 May '26

28 May '26

Vladislav Zavialov deleted branch wip/int-index/t25960 at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/int-index/retry-tyclds-tests
by Vladislav Zavialov (＠int-index) 28 May '26

28 May '26

Vladislav Zavialov deleted branch wip/int-index/retry-tyclds-tests at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/int-index/retry-tyclds
by Vladislav Zavialov (＠int-index) 28 May '26

28 May '26

Vladislav Zavialov deleted branch wip/int-index/retry-tyclds at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0