Jana Chadt pushed to branch wip/VeryMilkyJoe/no-mod-loc-pat at Glasgow Haskell Compiler / GHC Commits: b2c52978 by Jana Chadt at 2026-02-25T19:07:50+01:00 Remove backwards compatability pattern synonym `ModLocation` * Introduce utility to create ShortByteString from an OsString. * Introduce utility to create StringBuffer for a given OsPath. * Add mkFastStringOsString, which returns a FastString for a given OsString. Fixes #24932 - - - - - 12 changed files: - compiler/GHC.hs - compiler/GHC/Cmm/DebugBlock.hs - compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/Data/FastString.hs - compiler/GHC/Data/OsPath.hs - compiler/GHC/Data/StringBuffer.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/Unit/Module/Location.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/ghc.cabal.in - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -79,7 +79,13 @@ module GHC ( ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, mgLookupModule, ModSummary(..), ms_mod_name, ModLocation(..), - pattern ModLocation, + ml_hs_file, + ml_hi_file, + ml_dyn_hi_file, + ml_obj_file, + ml_dyn_obj_file, + ml_hie_file, + ml_bytecode_file, getModSummary, getModuleGraph, isLoaded, @@ -457,6 +463,7 @@ import System.Environment ( getEnv, getProgName ) import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath import System.IO.Error ( isDoesNotExistError ) +import GHC.Data.OsPath (OsPath) #if defined(HAVE_INTERNAL_INTERPRETER) import Foreign.C @@ -1575,12 +1582,12 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) -- a module by using 'getModSummary' -- -- XXX: Explain pre-conditions -getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags) +getModuleSourceAndFlags :: ModSummary -> IO (OsPath, StringBuffer, DynFlags) getModuleSourceAndFlags m = do - case ml_hs_file $ ms_location m of + case ml_hs_file_ospath $ ms_location m of Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m)) Just sourceFile -> do - source <- hGetStringBuffer sourceFile + source <- hGetStringBufferOsPath sourceFile return (sourceFile, source, ms_hspp_opts m) @@ -1592,7 +1599,7 @@ getModuleSourceAndFlags m = do getTokenStream :: ModSummary -> IO [Located Token] getTokenStream mod = do (sourceFile, source, dflags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + let startLoc = mkRealSrcLoc (mkFastStringOsString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return ts PFailed pst -> throwErrors (initSourceErrorContext dflags) (GhcPsMessage <$> getPsErrorMessages pst) @@ -1603,7 +1610,7 @@ getTokenStream mod = do getRichTokenStream :: ModSummary -> IO [(Located Token, String)] getRichTokenStream mod = do (sourceFile, source, dflags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + let startLoc = mkRealSrcLoc (mkFastStringOsString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return $ addSourceToTokens startLoc source ts PFailed pst -> throwErrors (initSourceErrorContext dflags) (GhcPsMessage <$> getPsErrorMessages pst) ===================================== compiler/GHC/Cmm/DebugBlock.hs ===================================== @@ -33,7 +33,7 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse ) import GHC.Cmm.Utils -import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString ) +import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastStringOsString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic @@ -156,7 +156,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes rangeRating (span, _) | srcSpanFile span == thisFile = 1 | otherwise = 2 :: Int - thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + thisFile = maybe nilFS mkFastStringOsString $ ml_hs_file_ospath modLoc -- Returns block tree for this scope as well as all nested -- scopes. Note that if there are multiple blocks in the (exact) ===================================== compiler/GHC/CoreToStg/AddImplicitBinds.hs ===================================== @@ -135,15 +135,16 @@ tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr -- If we want to generate debug info, we put a source note on the -- worker. This is useful, especially for heap profiling. tick_it generate_debug_info mod_loc name - | not generate_debug_info = id + | not generate_debug_info = id | RealSrcSpan span _ <- nameSrcSpan name = tick span - | Just file <- ml_hs_file mod_loc = tick (span1 file) - | otherwise = tick (span1 "???") + | Just file <- ml_hs_file_ospath mod_loc = tick (span2 file) + | otherwise = tick (span1 "???") where tick span = Tick $ SourceNote span $ LexicalFastString $ mkFastString $ renderWithContext defaultSDocContext $ ppr name - span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 + span1 str = realSrcLocSpan $ mkRealSrcLoc (mkFastString str) 1 1 + span2 file = realSrcLocSpan $ mkRealSrcLoc (mkFastStringOsString file) 1 1 ===================================== compiler/GHC/Data/FastString.hs ===================================== @@ -77,6 +77,7 @@ module GHC.Data.FastString mkFastStringBytes, mkFastStringByteList, mkFastString#, + mkFastStringOsString, -- ** Deconstruction unpackFS, -- :: FastString -> String @@ -134,12 +135,14 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Short as SBS -import GHC.Data.ShortText (ShortText(..)) -import Foreign.C -import System.IO import Data.Data import Data.IORef import Data.Semigroup as Semi +import Data.Type.Coercion (coerceWith) +import Foreign.C +import GHC.Data.ShortText (ShortText (..)) +import System.IO +import System.OsString.Internal.Types import Foreign @@ -547,6 +550,14 @@ mkFastStringShortByteString :: ShortByteString -> FastString mkFastStringShortByteString sbs = inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs +-- | Create a 'FastString' from an 'OsString', without copying. +mkFastStringOsString :: OsString -> FastString +mkFastStringOsString os = mkFastStringShortByteString $ + -- Using 'OsPath''s 'unOS' here will unfortunately lead to cyclic dependencies + case coercionToPlatformTypes of + Left (_, windowsStringEv) -> unWS $ coerceWith windowsStringEv os + Right (_, posixStringEv) -> unPS $ coerceWith posixStringEv os + -- | Creates a UTF-8 encoded 'FastString' from a 'String' mkFastString :: String -> FastString {-# NOINLINE[1] mkFastString #-} ===================================== compiler/GHC/Data/OsPath.hs ===================================== @@ -8,6 +8,7 @@ module GHC.Data.OsPath , unsafeDecodeUtf , unsafeEncodeUtf , os + , unOS -- * Common utility functions , () , (<.>) @@ -28,13 +29,22 @@ import GHC.Prelude import GHC.Utils.Misc (HasCallStack) import GHC.Utils.Panic (panic) +import Data.ByteString.Short (ShortByteString) +import Data.Type.Coercion (coerceWith) +import System.Directory.Internal (os) +import System.Directory.OsPath (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getDirectoryContents) import System.OsPath import System.OsString (isSuffixOf) -import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing) -import System.Directory.Internal (os) +import System.OsString.Internal.Types (coercionToPlatformTypes, unPS, unWS) -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. -- Prefer 'decodeUtf' and gracious error handling. unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath unsafeDecodeUtf p = either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p) + +-- | Extracts underlying 'ShortByteString' from the given 'OsString', taking care of platform specifics. +unOS :: OsString -> ShortByteString +unOS os = case coercionToPlatformTypes of + Left (_, windowsStringEv) -> unWS $ coerceWith windowsStringEv os + Right (_, posixStringEv) -> unPS $ coerceWith posixStringEv os ===================================== compiler/GHC/Data/StringBuffer.hs ===================================== @@ -21,6 +21,7 @@ module GHC.Data.StringBuffer -- * Creation\/destruction hGetStringBuffer, hGetStringBufferBlock, + hGetStringBufferOsPath, hPutStringBuffer, appendStringBuffers, stringToStringBuffer, @@ -56,17 +57,19 @@ module GHC.Data.StringBuffer import GHC.Prelude import GHC.Data.FastString +import GHC.Data.OsPath (OsPath) +import GHC.Fingerprint import GHC.Utils.Encoding +import GHC.Utils.Exception (bracket_) import GHC.Utils.IO.Unsafe import GHC.Utils.Panic.Plain -import GHC.Utils.Exception ( bracket_ ) -import GHC.Fingerprint import Data.Maybe +import GHC.IO.Encoding.Failure (CodingFailureMode (IgnoreCodingFailure)) +import GHC.IO.Encoding.UTF8 (mkUTF8) +import System.File.OsPath qualified as FileIO import System.IO -import System.IO.Unsafe ( unsafePerformIO ) -import GHC.IO.Encoding.UTF8 ( mkUTF8 ) -import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) +import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Internal as BS import qualified Data.ByteString as BS @@ -111,6 +114,15 @@ instance Show StringBuffer where hGetStringBuffer :: FilePath -> IO StringBuffer hGetStringBuffer fname = do h <- openBinaryFile fname ReadMode + hGetStringBufferHandle h + +hGetStringBufferOsPath :: OsPath -> IO StringBuffer +hGetStringBufferOsPath fname = do + h <- FileIO.openBinaryFile fname ReadMode + hGetStringBufferHandle h + +hGetStringBufferHandle :: Handle -> IO StringBuffer +hGetStringBufferHandle h = do size_i <- hFileSize h offset_i <- skipBOM h size_i 0 -- offset is 0 initially let size = fromIntegral $ size_i - offset_i ===================================== compiler/GHC/Stg/Debug.hs ===================================== @@ -87,7 +87,7 @@ recordInfo :: Id -> StgExpr -> M () recordInfo bndr new_rhs = do modLoc <- asks rModLocation let - thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + thisFile = maybe nilFS mkFastStringOsString $ ml_hs_file_ospath modLoc -- A span from the ticks surrounding the new_rhs best_span = quickSourcePos thisFile new_rhs -- A back-up span if the bndr had a source position, many do not (think internally generated ids) ===================================== compiler/GHC/Unit/Module/Location.hs ===================================== @@ -2,31 +2,28 @@ {-# LANGUAGE ViewPatterns #-} -- | Module location module GHC.Unit.Module.Location - ( ModLocation - ( .. - , ml_hs_file - , ml_hi_file - , ml_dyn_hi_file - , ml_obj_file - , ml_dyn_obj_file - , ml_hie_file - , ml_bytecode_file - ) - , pattern ModLocation + ( ModLocation(..) , addBootSuffix , addBootSuffixLocn , addBootSuffixLocnOut , removeBootSuffix , mkFileSrcSpan + , ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file + , ml_bytecode_file ) where import GHC.Prelude +import GHC.Data.FastString (mkFastStringOsString) import GHC.Data.OsPath import GHC.Types.SrcLoc import GHC.Utils.Outputable -import GHC.Data.FastString (mkFastString) import qualified System.OsString as OsString @@ -120,41 +117,38 @@ addBootSuffixLocnOut locn -- | Compute a 'SrcSpan' from a 'ModLocation'. mkFileSrcSpan :: ModLocation -> SrcSpan mkFileSrcSpan mod_loc - = case ml_hs_file mod_loc of - Just file_path -> mkGeneralSrcSpan (mkFastString file_path) + = case ml_hs_file_ospath mod_loc of + Just file_path -> mkGeneralSrcSpan (mkFastStringOsString file_path) Nothing -> interactiveSrcSpan -- Presumably -- ---------------------------------------------------------------------------- -- Helpers for backwards compatibility -- ---------------------------------------------------------------------------- -{-# COMPLETE ModLocation #-} - -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation -pattern ModLocation - { ml_hs_file - , ml_hi_file - , ml_dyn_hi_file - , ml_obj_file - , ml_dyn_obj_file - , ml_hie_file - , ml_bytecode_file - } <- OsPathModLocation - { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file) - , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file) - , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file) - , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file) - , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file) - , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file) - , ml_bytecode_file_ospath = (unsafeDecodeUtf -> ml_bytecode_file) - } where - ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file ml_bytecode_file - = OsPathModLocation - { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file - , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file - , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file - , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file - , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file - , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file - , ml_bytecode_file_ospath = unsafeEncodeUtf ml_bytecode_file - } +ml_hs_file :: ModLocation -> Maybe FilePath +{-# INLINE ml_hs_file #-} +ml_hs_file = fmap unsafeDecodeUtf . ml_hs_file_ospath + +ml_hi_file :: ModLocation -> FilePath +{-# INLINE ml_hi_file #-} +ml_hi_file = unsafeDecodeUtf . ml_hi_file_ospath + +ml_dyn_hi_file :: ModLocation -> FilePath +{-# INLINE ml_dyn_hi_file #-} +ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_ospath + +ml_obj_file :: ModLocation -> FilePath +{-# INLINE ml_obj_file #-} +ml_obj_file = unsafeDecodeUtf . ml_obj_file_ospath + +ml_dyn_obj_file :: ModLocation -> FilePath +{-# INLINE ml_dyn_obj_file #-} +ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_ospath + +ml_hie_file :: ModLocation -> FilePath +{-# INLINE ml_hie_file #-} +ml_hie_file = unsafeDecodeUtf . ml_hie_file_ospath + +ml_bytecode_file :: ModLocation -> FilePath +{-# INLINE ml_bytecode_file #-} +ml_bytecode_file = unsafeDecodeUtf . ml_bytecode_file_ospath ===================================== compiler/GHC/Unit/Module/ModSummary.hs ===================================== @@ -46,7 +46,7 @@ import GHC.Types.PkgQual import GHC.Types.Basic import GHC.Data.Maybe -import GHC.Data.OsPath (OsPath) +import GHC.Data.OsPath ( OsPath ) import GHC.Data.StringBuffer ( StringBuffer ) import GHC.Utils.Fingerprint @@ -214,7 +214,7 @@ findTarget ms ts = = ms_mod_name summary == m && ms_unitid summary == unitId summary `matches` Target { targetId = TargetFile f _, targetUnitId = unitid } | Just f' <- ml_hs_file (ms_location summary) - = f == f' && ms_unitid summary == unitid + = f == f' && ms_unitid summary == unitid _ `matches` _ = False ===================================== compiler/ghc.cabal.in ===================================== @@ -125,6 +125,7 @@ Library containers >= 0.6.2.1 && < 0.9, array >= 0.1 && < 0.6, filepath >= 1.5 && < 1.6, + file-io >= 0.1.5 && < 0.3, os-string >= 2.0.1 && < 2.1, hpc >= 0.6 && < 0.8, transformers >= 0.5 && < 0.7, ===================================== testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs ===================================== @@ -31,7 +31,7 @@ convertToFixed (ModuleNodeCompile ms) = -- with the module summary information let modName = ms_mod_name ms modLoc = ms_location ms - in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing} + in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing } -- | Load a module graph and report the result ===================================== testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs ===================================== @@ -29,7 +29,7 @@ convertToFixed :: ModuleNodeInfo -> ModuleNodeInfo convertToFixed (ModuleNodeCompile ms) = let modName = ms_mod_name ms modLoc = ms_location ms - in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file = Nothing} + in ModuleNodeFixed (msKey ms) (ms_location ms) { ml_hs_file_ospath = Nothing } -- | Test a module graph and report if it matches expected invariant violations testModuleGraph :: String -> ModuleGraph -> [ModuleGraphInvariantError] -> Ghc () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2c529781d420016794d9529608b7e34... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b2c529781d420016794d9529608b7e34... You're receiving this email because of your account on gitlab.haskell.org.