[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Improve performance of genericWordQuotRem2Op (#22966)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jun 3 10:13:35 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
4998a6ed by Alex Mason at 2024-06-03T02:09:29-04:00
Improve performance of genericWordQuotRem2Op (#22966)
Implements the algorithm from compiler-rt's udiv128by64to64default. This
rewrite results in a roughly 24x improvement in runtime on AArch64 (and
likely any other arch that uses it).
- - - - -
ae50a8eb by Cheng Shao at 2024-06-03T02:10:05-04:00
testsuite: mark T7773 as fragile on wasm
- - - - -
26c13ceb by Fendor at 2024-06-03T06:13:03-04:00
Migrate `Finder` component to `OsPath`, fixed #24616
For each module in a GHCi session, we keep alive one `ModLocation`.
A `ModLocation` is fairly inefficiently packed, as `String`s are
expensive in memory usage.
While benchmarking the agda codebase, we concluded that we keep alive
around 11MB of `FilePath`'s, solely retained by `ModLocation`.
We provide a more densely packed encoding of `ModLocation`, by moving
from `FilePath` to `OsPath`. Further, we migrate the full `Finder`
component to `OsPath` to avoid unnecessary transformations.
As the `Finder` component is well-encapsulated, this requires only a
minimal amount of changes in other modules.
We introduce pattern synonym for 'ModLocation' which maintains backwards
compatibility and avoids breaking consumers of 'ModLocation'.
- - - - -
6c3a5604 by Cheng Shao at 2024-06-03T06:13:06-04:00
compiler: emit NaturallyAligned when element type & index type are the same width
This commit fixes a subtle mistake in alignmentFromTypes that used to
generate Unaligned when element type & index type are the same width.
Fixes #24930.
- - - - -
24 changed files:
- compiler/GHC.hs
- + compiler/GHC/Data/OsPath.hs
- compiler/GHC/Data/Strict.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Config/Finder.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Errors.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- libraries/base/tests/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/numeric/should_run/all.T
- + testsuite/tests/numeric/should_run/quotRem2Large.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
-- -----------------------------------------------------------------------------
--
@@ -76,6 +77,7 @@ module GHC (
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
+ pattern ModLocation,
getModSummary,
getModuleGraph,
isLoaded,
=====================================
compiler/GHC/Data/OsPath.hs
=====================================
@@ -0,0 +1,29 @@
+module GHC.Data.OsPath
+ (
+ -- * OsPath initialisation and transformation
+ OsPath
+ , OsString
+ , encodeUtf
+ , decodeUtf
+ , unsafeDecodeUtf
+ , unsafeEncodeUtf
+ , os
+ -- * Common utility functions
+ , (</>)
+ , (<.>)
+ )
+ where
+
+import GHC.Prelude
+
+import GHC.Utils.Misc (HasCallStack)
+import GHC.Utils.Panic (panic)
+
+import System.OsPath
+import System.Directory.Internal (os)
+
+-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
+-- Prefer 'decodeUtf' and gracious error handling.
+unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
+unsafeDecodeUtf p =
+ either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
=====================================
compiler/GHC/Data/Strict.hs
=====================================
@@ -9,8 +9,8 @@
module GHC.Data.Strict (
Maybe(Nothing, Just),
fromMaybe,
+ GHC.Data.Strict.maybe,
Pair(And),
-
-- Not used at the moment:
--
-- Either(Left, Right),
@@ -18,6 +18,7 @@ module GHC.Data.Strict (
) where
import GHC.Prelude hiding (Maybe(..), Either(..))
+
import Control.Applicative
import Data.Semigroup
import Data.Data
@@ -29,6 +30,10 @@ fromMaybe :: a -> Maybe a -> a
fromMaybe d Nothing = d
fromMaybe _ (Just x) = x
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe d _ Nothing = d
+maybe _ f (Just x) = f x
+
apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b
apMaybe (Just f) (Just x) = Just (f x)
apMaybe _ _ = Nothing
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -74,6 +74,7 @@ import GHC.Linker.Types
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
+import GHC.Data.OsPath (unsafeEncodeUtf, os)
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.Data.EnumSet as EnumSet
@@ -772,7 +773,7 @@ summariseRequirement pn mod_name = do
let PackageName pn_fs = pn
let location = mkHomeModLocation2 fopts mod_name
- (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
+ (unsafeEncodeUtf $ unpackFS pn_fs </> moduleNameSlashes mod_name) (os "hsig")
env <- getBkpEnv
src_hash <- liftIO $ getFileHash (bkp_filename env)
@@ -855,12 +856,12 @@ hsModuleToModSummary home_keys pn hsc_src modname
-- these filenames to figure out where the hi files go.
-- A travesty!
let location0 = mkHomeModLocation2 fopts modname
- (unpackFS unit_fs </>
+ (unsafeEncodeUtf $ unpackFS unit_fs </>
moduleNameSlashes modname)
(case hsc_src of
- HsigFile -> "hsig"
- HsBootFile -> "hs-boot"
- HsSrcFile -> "hs")
+ HsigFile -> os "hsig"
+ HsBootFile -> os "hs-boot"
+ HsSrcFile -> os "hs")
-- DANGEROUS: bootifying can POISON the module finder cache
let location = case hsc_src of
HsBootFile -> addBootSuffixLocnOut location0
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Driver.LlvmConfigCache (LlvmConfigCache)
import GHC.Driver.Ppr
import GHC.Driver.Backend
+import GHC.Data.OsPath
import qualified GHC.Data.ShortText as ST
import GHC.Data.Stream ( Stream )
import qualified GHC.Data.Stream as Stream
@@ -259,7 +260,7 @@ outputForeignStubs
Maybe FilePath) -- C file created
outputForeignStubs logger tmpfs dflags unit_state mod location stubs
= do
- let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location
+ let stub_h = unsafeDecodeUtf $ mkStubPaths (initFinderOpts dflags) (moduleName mod) location
stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
case stubs of
=====================================
compiler/GHC/Driver/Config/Finder.hs
=====================================
@@ -8,27 +8,27 @@ import GHC.Prelude
import GHC.Driver.DynFlags
import GHC.Unit.Finder.Types
import GHC.Data.FastString
-
+import GHC.Data.OsPath
-- | Create a new 'FinderOpts' from DynFlags.
initFinderOpts :: DynFlags -> FinderOpts
initFinderOpts flags = FinderOpts
- { finder_importPaths = importPaths flags
+ { finder_importPaths = fmap unsafeEncodeUtf $ importPaths flags
, finder_lookupHomeInterfaces = isOneShot (ghcMode flags)
, finder_bypassHiFileCheck = MkDepend == (ghcMode flags)
, finder_ways = ways flags
, finder_enableSuggestions = gopt Opt_HelpfulErrors flags
- , finder_workingDirectory = workingDirectory flags
+ , finder_workingDirectory = fmap unsafeEncodeUtf $ workingDirectory flags
, finder_thisPackageName = mkFastString <$> thisPackageName flags
, finder_hiddenModules = hiddenModules flags
, finder_reexportedModules = reexportedModules flags
- , finder_hieDir = hieDir flags
- , finder_hieSuf = hieSuf flags
- , finder_hiDir = hiDir flags
- , finder_hiSuf = hiSuf_ flags
- , finder_dynHiSuf = dynHiSuf_ flags
- , finder_objectDir = objectDir flags
- , finder_objectSuf = objectSuf_ flags
- , finder_dynObjectSuf = dynObjectSuf_ flags
- , finder_stubDir = stubDir flags
+ , finder_hieDir = fmap unsafeEncodeUtf $ hieDir flags
+ , finder_hieSuf = unsafeEncodeUtf $ hieSuf flags
+ , finder_hiDir = fmap unsafeEncodeUtf $ hiDir flags
+ , finder_hiSuf = unsafeEncodeUtf $ hiSuf_ flags
+ , finder_dynHiSuf = unsafeEncodeUtf $ dynHiSuf_ flags
+ , finder_objectDir = fmap unsafeEncodeUtf $ objectDir flags
+ , finder_objectSuf = unsafeEncodeUtf $ objectSuf_ flags
+ , finder_dynObjectSuf = unsafeEncodeUtf $ dynObjectSuf_ flags
+ , finder_stubDir = fmap unsafeEncodeUtf $ stubDir flags
}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -264,6 +264,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString
import GHC.Data.Bag
+import GHC.Data.OsPath (unsafeEncodeUtf)
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
@@ -2111,12 +2112,13 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
rawCmms
return stub_c_exists
where
- no_loc = ModLocation{ ml_hs_file = Just original_filename,
- ml_hi_file = panic "hscCompileCmmFile: no hi file",
- ml_obj_file = panic "hscCompileCmmFile: no obj file",
- ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",
- ml_dyn_hi_file = panic "hscCompileCmmFile: no dyn obj file",
- ml_hie_file = panic "hscCompileCmmFile: no hie file"}
+ no_loc = OsPathModLocation
+ { ml_hs_file_ospath = Just $ unsafeEncodeUtf original_filename,
+ ml_hi_file_ospath = panic "hscCompileCmmFile: no hi file",
+ ml_obj_file_ospath = panic "hscCompileCmmFile: no obj file",
+ ml_dyn_obj_file_ospath = panic "hscCompileCmmFile: no dyn obj file",
+ ml_dyn_hi_file_ospath = panic "hscCompileCmmFile: no dyn obj file",
+ ml_hie_file_ospath = panic "hscCompileCmmFile: no hie file"}
-------------------- Stuff for new code gen ---------------------
@@ -2351,12 +2353,13 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
{- Desugar it -}
-- We use a basically null location for iNTERACTIVE
- let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
- ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file",
- ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",
- ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",
- ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" }
+ let iNTERACTIVELoc = OsPathModLocation
+ { ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = panic "hsDeclsWithLocation:ml_hi_file_ospath",
+ ml_obj_file_ospath = panic "hsDeclsWithLocation:ml_obj_file_ospath",
+ ml_dyn_obj_file_ospath = panic "hsDeclsWithLocation:ml_dyn_obj_file_ospath",
+ ml_dyn_hi_file_ospath = panic "hsDeclsWithLocation:ml_dyn_hi_file_ospath",
+ ml_hie_file_ospath = panic "hsDeclsWithLocation:ml_hie_file_ospath" }
ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
{- Simplify -}
@@ -2635,12 +2638,13 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- Lint if necessary -}
lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr
- let this_loc = ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
- ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
- ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",
- ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file",
- ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
+ let this_loc = OsPathModLocation
+ { ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = panic "hscCompileCoreExpr':ml_hi_file_ospath",
+ ml_obj_file_ospath = panic "hscCompileCoreExpr':ml_obj_file_ospath",
+ ml_dyn_obj_file_ospath = panic "hscCompileCoreExpr': ml_obj_file_ospath",
+ ml_dyn_hi_file_ospath = panic "hscCompileCoreExpr': ml_dyn_hi_file_ospath",
+ ml_hie_file_ospath = panic "hscCompileCoreExpr':ml_hie_file_ospath" }
-- Ensure module uniqueness by giving it a name like "GhciNNNN".
-- This uniqueness is needed by the JS linker. Without it we break the 1-1
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -76,6 +76,7 @@ import GHC.Data.Bag ( listToBag )
import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
+import GHC.Data.OsPath ( unsafeEncodeUtf )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt
@@ -1837,7 +1838,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
let dyn_tn = tn -<.> dynsuf
addFilesToClean tmpfs dynLife [dyn_tn]
- return (tn, dyn_tn)
+ return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn)
-- We don't want to create .o or .hi files unless we have been asked
-- to by the user. But we need them, so we patch their locations in
-- the ModSummary with temporary files.
@@ -1846,8 +1847,8 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
-- If ``-fwrite-interface` is specified, then the .o and .hi files
-- are written into `-odir` and `-hidir` respectively. #16670
if gopt Opt_WriteInterface dflags
- then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)
- , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))
+ then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location)
+ , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location))
else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
<*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
let new_dflags = case enable_spec of
@@ -1856,10 +1857,10 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
let ms' = ms
{ ms_location =
- ms_location { ml_hi_file = hi_file
- , ml_obj_file = o_file
- , ml_dyn_hi_file = dyn_hi_file
- , ml_dyn_obj_file = dyn_o_file }
+ ms_location { ml_hi_file_ospath = hi_file
+ , ml_obj_file_ospath = o_file
+ , ml_dyn_hi_file_ospath = dyn_hi_file
+ , ml_dyn_obj_file_ospath = dyn_o_file }
, ms_hspp_opts = updOptLevel 0 $ new_dflags
}
-- Recursive call to catch the other cases
@@ -2044,7 +2045,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
let fopts = initFinderOpts (hsc_dflags hsc_env)
-- Make a ModLocation for this file
- let location = mkHomeModLocation fopts pi_mod_name src_fn
+ let location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf src_fn)
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -24,6 +24,7 @@ import GHC.Driver.Env
import GHC.Driver.Errors.Types
import qualified GHC.SysTools as SysTools
import GHC.Data.Graph.Directed ( SCC(..) )
+import GHC.Data.OsPath (unsafeDecodeUtf)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SourceError
@@ -252,7 +253,7 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node))
-- files if the module has a corresponding .hs-boot file (#14482)
; when (isBootSummary node == IsBoot) $ do
let hi_boot = msHiFilePath node
- let obj = removeBootSuffix (msObjFilePath node)
+ let obj = unsafeDecodeUtf $ removeBootSuffix (msObjFileOsPath node)
forM_ extra_suffixes $ \suff -> do
let way_obj = insertSuffixes obj [suff]
let way_hi_boot = insertSuffixes hi_boot [suff]
@@ -297,7 +298,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
Found loc _
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
+ -> return (Just (unsafeDecodeUtf $ addBootSuffix_maybe is_boot (ml_hi_file_ospath loc)))
-- Not in this package: we don't need a dependency
| otherwise
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Iface.Make
import GHC.Driver.Config.Parser
import GHC.Parser.Header
import GHC.Data.StringBuffer
+import GHC.Data.OsPath (unsafeEncodeUtf)
import GHC.Types.SourceError
import GHC.Unit.Finder
import Data.IORef
@@ -772,7 +773,7 @@ mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO Mod
mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
let PipeEnv{ src_basename=basename,
src_suffix=suff } = pipe_env
- let location1 = mkHomeModLocation2 fopts mod_name basename suff
+ let location1 = mkHomeModLocation2 fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)
-- Boot-ify it if necessary
let location2
@@ -784,11 +785,11 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
-- This can't be done in mkHomeModuleLocation because
-- it only applies to the module being compiles
let ohi = outputHi dflags
- location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
+ location3 | Just fn <- ohi = location2{ ml_hi_file_ospath = unsafeEncodeUtf fn }
| otherwise = location2
let dynohi = dynOutputHi dflags
- location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }
+ location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
| otherwise = location3
-- Take -o into account if present
@@ -802,10 +803,10 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
location5 | Just ofile <- expl_o_file
, let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
, isNoLink (ghcLink dflags)
- = location4 { ml_obj_file = ofile
- , ml_dyn_obj_file = dyn_ofile }
+ = location4 { ml_obj_file_ospath = unsafeEncodeUtf ofile
+ , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
| Just dyn_ofile <- expl_dyn_o_file
- = location4 { ml_dyn_obj_file = dyn_ofile }
+ = location4 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
| otherwise = location4
return location5
where
=====================================
compiler/GHC/Iface/Errors.hs
=====================================
@@ -14,6 +14,7 @@ import GHC.Utils.Panic.Plain
import GHC.Driver.DynFlags
import GHC.Driver.Env
import GHC.Data.Maybe
+import GHC.Data.OsPath
import GHC.Prelude
import GHC.Unit
import GHC.Unit.Env
@@ -55,13 +56,13 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
InstalledNotFound files mb_pkg
| Just pkg <- mb_pkg
, notHomeUnitId mhome_unit pkg
- -> not_found_in_package pkg files
+ -> not_found_in_package pkg $ fmap unsafeDecodeUtf files
| null files
-> NotAModule
| otherwise
- -> CouldntFindInFiles files
+ -> CouldntFindInFiles $ fmap unsafeDecodeUtf files
_ -> panic "cantFindInstalledErr"
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1894,53 +1894,179 @@ genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]
(CmmMachOp (MO_U_Rem width) [arg_x, arg_y])
genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
+-- Based on the algorithm from LLVM's compiler-rt:
+-- https://github.com/llvm/llvm-project/blob/7339f7ba3053db7595ece1ca5f49bd2e4c3c8305/compiler-rt/lib/builtins/udivmodti4.c#L23
+-- See that file for licensing and copyright.
genericWordQuotRem2Op :: Platform -> GenericOp
-genericWordQuotRem2Op platform [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
- = emit =<< f (widthInBits (wordWidth platform)) zero arg_x_high arg_x_low
- where ty = cmmExprType platform arg_x_high
- shl x i = CmmMachOp (MO_Shl (wordWidth platform)) [x, i]
- shr x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i]
- or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]
- ge x y = CmmMachOp (MO_U_Ge (wordWidth platform)) [x, y]
- ne x y = CmmMachOp (MO_Ne (wordWidth platform)) [x, y]
- minus x y = CmmMachOp (MO_Sub (wordWidth platform)) [x, y]
- times x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]
- zero = lit 0
- one = lit 1
- negone = lit (fromIntegral (platformWordSizeInBits platform) - 1)
- lit i = CmmLit (CmmInt i (wordWidth platform))
-
- f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
- f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
- mkAssign (CmmLocal res_r) high)
- f i acc high low =
- do roverflowedBit <- newTemp ty
- rhigh' <- newTemp ty
- rhigh'' <- newTemp ty
- rlow' <- newTemp ty
- risge <- newTemp ty
- racc' <- newTemp ty
- let high' = CmmReg (CmmLocal rhigh')
- isge = CmmReg (CmmLocal risge)
- overflowedBit = CmmReg (CmmLocal roverflowedBit)
- let this = catAGraphs
- [mkAssign (CmmLocal roverflowedBit)
- (shr high negone),
- mkAssign (CmmLocal rhigh')
- (or (shl high one) (shr low negone)),
- mkAssign (CmmLocal rlow')
- (shl low one),
- mkAssign (CmmLocal risge)
- (or (overflowedBit `ne` zero)
- (high' `ge` arg_y)),
- mkAssign (CmmLocal rhigh'')
- (high' `minus` (arg_y `times` isge)),
- mkAssign (CmmLocal racc')
- (or (shl acc one) isge)]
- rest <- f (i - 1) (CmmReg (CmmLocal racc'))
- (CmmReg (CmmLocal rhigh''))
- (CmmReg (CmmLocal rlow'))
- return (this <*> rest)
+genericWordQuotRem2Op platform [res_q, res_r] [arg_u1, arg_u0, arg_v]
+ = do
+ -- v gets modified below based on clz v
+ v <- newTemp ty
+ emit $ mkAssign (CmmLocal v) arg_v
+ go arg_u1 arg_u0 v
+ where ty = cmmExprType platform arg_u1
+ shl x i = CmmMachOp (MO_Shl (wordWidth platform)) [x, i]
+ shr x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i]
+ or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]
+ ge x y = CmmMachOp (MO_U_Ge (wordWidth platform)) [x, y]
+ le x y = CmmMachOp (MO_U_Le (wordWidth platform)) [x, y]
+ eq x y = CmmMachOp (MO_Eq (wordWidth platform)) [x, y]
+ plus x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]
+ minus x y = CmmMachOp (MO_Sub (wordWidth platform)) [x, y]
+ times x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]
+ udiv x y = CmmMachOp (MO_U_Quot (wordWidth platform)) [x, y]
+ and x y = CmmMachOp (MO_And (wordWidth platform)) [x, y]
+ lit i = CmmLit (CmmInt i (wordWidth platform))
+ one = lit 1
+ zero = lit 0
+ masklow = lit ((1 `shiftL` (platformWordSizeInBits platform `div` 2)) - 1)
+ gotoIf pred target = emit =<< mkCmmIfGoto pred target
+ mkTmp ty = do
+ t <- newTemp ty
+ pure (t, CmmReg (CmmLocal t))
+ infixr 8 .=
+ r .= e = emit $ mkAssign (CmmLocal r) e
+
+ go :: CmmActual -> CmmActual -> LocalReg -> FCode ()
+ go u1 u0 v = do
+ -- Computes (ret,r) = (u1<<WORDSIZE*8+u0) `divMod` v
+ -- du_int udiv128by64to64default(du_int u1, du_int u0, du_int v, du_int *r)
+ -- const unsigned n_udword_bits = sizeof(du_int) * CHAR_BIT;
+ let n_udword_bits' = widthInBits (wordWidth platform)
+ n_udword_bits = fromIntegral n_udword_bits'
+ -- const du_int b = (1ULL << (n_udword_bits / 2)); // Number base (32 bits)
+ b = 1 `shiftL` (n_udword_bits' `div` 2)
+ v' = CmmReg (CmmLocal v)
+ -- du_int un1, un0; // Norm. dividend LSD's
+ (un1, un1') <- mkTmp ty
+ (un0, un0') <- mkTmp ty
+ -- du_int vn1, vn0; // Norm. divisor digits
+ (vn1, vn1') <- mkTmp ty
+ (vn0, vn0') <- mkTmp ty
+ -- du_int q1, q0; // Quotient digits
+ (q1, q1') <- mkTmp ty
+ (q0, q0') <- mkTmp ty
+ -- du_int un64, un21, un10; // Dividend digit pairs
+ (un64, un64') <- mkTmp ty
+ (un21, un21') <- mkTmp ty
+ (un10, un10') <- mkTmp ty
+
+ -- du_int rhat; // A remainder
+ (rhat, rhat') <- mkTmp ty
+ -- si_int s; // Shift amount for normalization
+ (s, s') <- mkTmp ty
+
+ -- s = __builtin_clzll(v);
+ -- clz(0) in GHC returns N on N bit systems, whereas
+ -- __builtin_clzll returns 0 (or is undefined)
+ emitClzCall s v' (wordWidth platform)
+
+ if_else <- newBlockId
+ if_done <- newBlockId
+ -- if (s > 0) {
+ -- actually if (s > 0 && s /= wordSizeInBits) {
+ gotoIf (s' `eq` zero) if_else
+ gotoIf (s' `eq` lit n_udword_bits) if_else
+ do
+ -- // Normalize the divisor.
+ -- v = v << s;
+ v .= shl v' s'
+ -- un64 = (u1 << s) | (u0 >> (n_udword_bits - s));
+ un64 .= (u1 `shl` s') `or` (u0 `shr` (lit n_udword_bits `minus` s'))
+ -- un10 = u0 << s; // Shift dividend left
+ un10 .= shl u0 s'
+ emit $ mkBranch if_done
+ -- } else {
+ do
+ -- // Avoid undefined behavior of (u0 >> 64).
+ emitLabel if_else
+ -- un64 = u1;
+ un64 .= u1
+ -- un10 = u0;
+ un10 .= u0
+ s .= lit 0 -- Otherwise leads to >>/<< 64
+ -- }
+ emitLabel if_done
+
+ -- // Break divisor up into two 32-bit digits.
+ -- vn1 = v >> (n_udword_bits / 2);
+ vn1 .= v' `shr` lit (n_udword_bits `div` 2)
+ -- vn0 = v & 0xFFFFFFFF;
+ vn0 .= v' `and` masklow
+
+ -- // Break right half of dividend into two digits.
+ -- un1 = un10 >> (n_udword_bits / 2);
+ un1 .= un10' `shr` lit (n_udword_bits `div` 2)
+ -- un0 = un10 & 0xFFFFFFFF;
+ un0 .= un10' `and` masklow
+
+ -- // Compute the first quotient digit, q1.
+ -- q1 = un64 / vn1;
+ q1 .= un64' `udiv` vn1'
+ -- rhat = un64 - q1 * vn1;
+ rhat .= un64' `minus` times q1' vn1'
+
+ while_1_entry <- newBlockId
+ while_1_body <- newBlockId
+ while_1_done <- newBlockId
+ -- // q1 has at most error 2. No more than 2 iterations.
+ -- while (q1 >= b || q1 * vn0 > b * rhat + un1) {
+ emitLabel while_1_entry
+ gotoIf (q1' `ge` lit b) while_1_body
+ gotoIf (le (times q1' vn0')
+ (times (lit b) rhat' `plus` un1'))
+ while_1_done
+ do
+ emitLabel while_1_body
+ -- q1 = q1 - 1;
+ q1 .= q1' `minus` one
+ -- rhat = rhat + vn1;
+ rhat .= rhat' `plus` vn1'
+ -- if (rhat >= b)
+ -- break;
+ gotoIf (rhat' `ge` lit b)
+ while_1_done
+ emit $ mkBranch while_1_entry
+ -- }
+ emitLabel while_1_done
+
+ -- un21 = un64 * b + un1 - q1 * v;
+ un21 .= (times un64' (lit b) `plus` un1') `minus` times q1' v'
+
+ -- // Compute the second quotient digit.
+ -- q0 = un21 / vn1;
+ q0 .= un21' `udiv` vn1'
+ -- rhat = un21 - q0 * vn1;
+ rhat .= un21' `minus` times q0' vn1'
+
+ -- // q0 has at most error 2. No more than 2 iterations.
+ while_2_entry <- newBlockId
+ while_2_body <- newBlockId
+ while_2_done <- newBlockId
+ emitLabel while_2_entry
+ -- while (q0 >= b || q0 * vn0 > b * rhat + un0) {
+ gotoIf (q0' `ge` lit b)
+ while_2_body
+ gotoIf (le (times q0' vn0')
+ (times (lit b) rhat' `plus` un0'))
+ while_2_done
+ do
+ emitLabel while_2_body
+ -- q0 = q0 - 1;
+ q0 .= q0' `minus` one
+ -- rhat = rhat + vn1;
+ rhat .= rhat' `plus` vn1'
+ -- if (rhat >= b)
+ -- break;
+ gotoIf (rhat' `ge` lit b) while_2_done
+ emit $ mkBranch while_2_entry
+ -- }
+ emitLabel while_2_done
+
+ -- r = (un21 * b + un0 - q0 * v) >> s;
+ res_r .= ((times un21' (lit b) `plus` un0') `minus` times q0' v') `shr` s'
+ -- return q1 * b + q0;
+ res_q .= times q1' (lit b) `plus` q0'
genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"
genericWordAdd2Op :: GenericOp
@@ -2176,8 +2302,8 @@ alignmentFromTypes :: CmmType -- ^ element type
-> CmmType -- ^ index type
-> AlignmentSpec
alignmentFromTypes ty idx_ty
- | typeWidth ty < typeWidth idx_ty = NaturallyAligned
- | otherwise = Unaligned
+ | typeWidth ty <= typeWidth idx_ty = NaturallyAligned
+ | otherwise = Unaligned
doIndexOffAddrOp :: Maybe MachOp
-> CmmType
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -42,6 +42,9 @@ import GHC.Platform.Ways
import GHC.Builtin.Names ( gHC_PRIM )
+import GHC.Data.Maybe ( expectJust )
+import GHC.Data.OsPath
+
import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.Module
@@ -49,7 +52,6 @@ import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
-import GHC.Data.Maybe ( expectJust )
import qualified GHC.Data.ShortText as ST
import GHC.Utils.Misc
@@ -61,8 +63,7 @@ import GHC.Types.PkgQual
import GHC.Fingerprint
import Data.IORef
-import System.Directory
-import System.FilePath
+import System.Directory.OsPath
import Control.Monad
import Data.Time
import qualified Data.Map as M
@@ -70,9 +71,10 @@ import GHC.Driver.Env
( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
+import qualified System.OsPath as OsPath
-type FileExt = String -- Filename extension
-type BaseName = String -- Basename of file
+type FileExt = OsString -- Filename extension
+type BaseName = OsPath -- Basename of file
-- -----------------------------------------------------------------------------
-- The Finder
@@ -286,7 +288,7 @@ findLookupResult fc fopts r = case r of
-- implicit locations from the instances
InstalledFound loc _ -> return (Found loc m)
InstalledNoPackage _ -> return (NoPackage (moduleUnit m))
- InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)
+ InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)
, fr_pkgs_hidden = []
, fr_mods_hidden = []
, fr_unusables = []
@@ -357,7 +359,7 @@ findHomeModule fc fopts home_unit mod_name = do
InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
- fr_paths = fps,
+ fr_paths = fmap unsafeDecodeUtf fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
@@ -382,7 +384,7 @@ findHomePackageModule fc fopts home_unit mod_name = do
InstalledFound loc _ -> Found loc (mkModule uid mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
- fr_paths = fps,
+ fr_paths = fmap unsafeDecodeUtf fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
@@ -418,17 +420,17 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
hi_dir_path =
case finder_hiDir fopts of
Just hiDir -> case maybe_working_dir of
- Nothing -> [hiDir]
- Just fp -> [fp </> hiDir]
+ Nothing -> [hiDir]
+ Just fp -> [fp </> hiDir]
Nothing -> home_path
hisuf = finder_hiSuf fopts
mod = mkModule home_unit mod_name
source_exts =
- [ ("hs", mkHomeModLocationSearched fopts mod_name "hs")
- , ("lhs", mkHomeModLocationSearched fopts mod_name "lhs")
- , ("hsig", mkHomeModLocationSearched fopts mod_name "hsig")
- , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")
+ [ (os "hs", mkHomeModLocationSearched fopts mod_name $ os "hs")
+ , (os "lhs", mkHomeModLocationSearched fopts mod_name $ os "lhs")
+ , (os "hsig", mkHomeModLocationSearched fopts mod_name $ os "hsig")
+ , (os "lhsig", mkHomeModLocationSearched fopts mod_name $ os "lhsig")
]
-- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that
@@ -453,10 +455,11 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
else searchPathExts search_dirs mod exts
-- | Prepend the working directory to the search path.
-augmentImports :: FilePath -> [FilePath] -> [FilePath]
+augmentImports :: OsPath -> [OsPath] -> [OsPath]
augmentImports _work_dir [] = []
-augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps
- | otherwise = (work_dir </> fp) : augmentImports work_dir fps
+augmentImports work_dir (fp:fps)
+ | OsPath.isAbsolute fp = fp : augmentImports work_dir fps
+ | otherwise = (work_dir </> fp) : augmentImports work_dir fps
-- | Search for a module in external packages only.
findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult
@@ -488,14 +491,14 @@ findPackageModule_ fc fopts mod pkg_conf = do
tag = waysBuildTag (finder_ways fopts)
-- hi-suffix for packages depends on the build tag.
- package_hisuf | null tag = "hi"
- | otherwise = tag ++ "_hi"
+ package_hisuf | null tag = os "hi"
+ | otherwise = os (tag ++ "_hi")
- package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
+ package_dynhisuf = os $ waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf
- import_dirs = map ST.unpack $ unitImportDirs pkg_conf
+ import_dirs = map (unsafeEncodeUtf . ST.unpack) $ unitImportDirs pkg_conf
-- we never look for a .hi-boot file in an external package;
-- .hi-boot files only make sense for the home package.
in
@@ -503,7 +506,7 @@ findPackageModule_ fc fopts mod pkg_conf = do
[one] | finder_bypassHiFileCheck fopts ->
-- there's only one place that this .hi file can be, so
-- don't bother looking for it.
- let basename = moduleNameSlashes (moduleName mod)
+ let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
loc = mk_hi_loc one basename
in return $ InstalledFound loc mod
_otherwise ->
@@ -512,24 +515,24 @@ findPackageModule_ fc fopts mod pkg_conf = do
-- -----------------------------------------------------------------------------
-- General path searching
-searchPathExts :: [FilePath] -- paths to search
+searchPathExts :: [OsPath] -- paths to search
-> InstalledModule -- module name
-> [ (
- FileExt, -- suffix
- FilePath -> BaseName -> ModLocation -- action
+ FileExt, -- suffix
+ OsPath -> BaseName -> ModLocation -- action
)
]
-> IO InstalledFindResult
searchPathExts paths mod exts = search to_search
where
- basename = moduleNameSlashes (moduleName mod)
+ basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
- to_search :: [(FilePath, ModLocation)]
+ to_search :: [(OsPath, ModLocation)]
to_search = [ (file, fn path basename)
| path <- paths,
(ext,fn) <- exts,
- let base | path == "." = basename
+ let base | path == os "." = basename
| otherwise = path </> basename
file = base <.> ext
]
@@ -543,7 +546,7 @@ searchPathExts paths mod exts = search to_search
else search rest
mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
- -> FilePath -> BaseName -> ModLocation
+ -> OsPath -> BaseName -> ModLocation
mkHomeModLocationSearched fopts mod suff path basename =
mkHomeModLocation2 fopts mod (path </> basename) suff
@@ -581,18 +584,18 @@ mkHomeModLocationSearched fopts mod suff path basename =
-- ext
-- The filename extension of the source file (usually "hs" or "lhs").
-mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation
+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation
mkHomeModLocation dflags mod src_filename =
- let (basename,extension) = splitExtension src_filename
+ let (basename,extension) = OsPath.splitExtension src_filename
in mkHomeModLocation2 dflags mod basename extension
mkHomeModLocation2 :: FinderOpts
-> ModuleName
- -> FilePath -- Of source module, without suffix
- -> String -- Suffix
+ -> OsPath -- Of source module, without suffix
+ -> FileExt -- Suffix
-> ModLocation
mkHomeModLocation2 fopts mod src_basename ext =
- let mod_basename = moduleNameSlashes mod
+ let mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod
obj_fn = mkObjPath fopts src_basename mod_basename
dyn_obj_fn = mkDynObjPath fopts src_basename mod_basename
@@ -600,51 +603,51 @@ mkHomeModLocation2 fopts mod src_basename ext =
dyn_hi_fn = mkDynHiPath fopts src_basename mod_basename
hie_fn = mkHiePath fopts src_basename mod_basename
- in (ModLocation{ ml_hs_file = Just (src_basename <.> ext),
- ml_hi_file = hi_fn,
- ml_dyn_hi_file = dyn_hi_fn,
- ml_obj_file = obj_fn,
- ml_dyn_obj_file = dyn_obj_fn,
- ml_hie_file = hie_fn })
+ in (OsPathModLocation{ ml_hs_file_ospath = Just (src_basename <.> ext),
+ ml_hi_file_ospath = hi_fn,
+ ml_dyn_hi_file_ospath = dyn_hi_fn,
+ ml_obj_file_ospath = obj_fn,
+ ml_dyn_obj_file_ospath = dyn_obj_fn,
+ ml_hie_file_ospath = hie_fn })
mkHomeModHiOnlyLocation :: FinderOpts
-> ModuleName
- -> FilePath
+ -> OsPath
-> BaseName
-> ModLocation
mkHomeModHiOnlyLocation fopts mod path basename =
- let loc = mkHomeModLocation2 fopts mod (path </> basename) ""
- in loc { ml_hs_file = Nothing }
+ let loc = mkHomeModLocation2 fopts mod (path </> basename) mempty
+ in loc { ml_hs_file_ospath = Nothing }
-- This function is used to make a ModLocation for a package module. Hence why
-- we explicitly pass in the interface file suffixes.
-mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String
+mkHiOnlyModLocation :: FinderOpts -> FileExt -> FileExt -> OsPath -> OsPath
-> ModLocation
mkHiOnlyModLocation fopts hisuf dynhisuf path basename
= let full_basename = path </> basename
obj_fn = mkObjPath fopts full_basename basename
dyn_obj_fn = mkDynObjPath fopts full_basename basename
hie_fn = mkHiePath fopts full_basename basename
- in ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = full_basename <.> hisuf,
- -- Remove the .hi-boot suffix from
- -- hi_file, if it had one. We always
- -- want the name of the real .hi file
- -- in the ml_hi_file field.
- ml_dyn_obj_file = dyn_obj_fn,
- -- MP: TODO
- ml_dyn_hi_file = full_basename <.> dynhisuf,
- ml_obj_file = obj_fn,
- ml_hie_file = hie_fn
+ in OsPathModLocation{ ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = full_basename <.> hisuf,
+ -- Remove the .hi-boot suffix from
+ -- hi_file, if it had one. We always
+ -- want the name of the real .hi file
+ -- in the ml_hi_file field.
+ ml_dyn_obj_file_ospath = dyn_obj_fn,
+ -- MP: TODO
+ ml_dyn_hi_file_ospath = full_basename <.> dynhisuf,
+ ml_obj_file_ospath = obj_fn,
+ ml_hie_file_ospath = hie_fn
}
-- | Constructs the filename of a .o file for a given source file.
-- Does /not/ check whether the .o file exists
mkObjPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkObjPath fopts basename mod_basename = obj_basename <.> osuf
where
odir = finder_objectDir fopts
@@ -657,9 +660,9 @@ mkObjPath fopts basename mod_basename = obj_basename <.> osuf
-- Does /not/ check whether the .dyn_o file exists
mkDynObjPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
where
odir = finder_objectDir fopts
@@ -673,9 +676,9 @@ mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
-- Does /not/ check whether the .hi file exists
mkHiPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkHiPath fopts basename mod_basename = hi_basename <.> hisuf
where
hidir = finder_hiDir fopts
@@ -688,9 +691,9 @@ mkHiPath fopts basename mod_basename = hi_basename <.> hisuf
-- Does /not/ check whether the .dyn_hi file exists
mkDynHiPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf
where
hidir = finder_hiDir fopts
@@ -703,9 +706,9 @@ mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf
-- Does /not/ check whether the .hie file exists
mkHiePath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf
where
hiedir = finder_hieDir fopts
@@ -726,23 +729,23 @@ mkStubPaths
:: FinderOpts
-> ModuleName
-> ModLocation
- -> FilePath
+ -> OsPath
mkStubPaths fopts mod location
= let
stubdir = finder_stubDir fopts
- mod_basename = moduleNameSlashes mod
- src_basename = dropExtension $ expectJust "mkStubPaths"
- (ml_hs_file location)
+ mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod
+ src_basename = OsPath.dropExtension $ expectJust "mkStubPaths"
+ (ml_hs_file_ospath location)
stub_basename0
| Just dir <- stubdir = dir </> mod_basename
| otherwise = src_basename
- stub_basename = stub_basename0 ++ "_stub"
+ stub_basename = stub_basename0 `mappend` os "_stub"
in
- stub_basename <.> "h"
+ stub_basename <.> os "h"
-- -----------------------------------------------------------------------------
-- findLinkable isn't related to the other stuff in here,
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -9,6 +9,7 @@ where
import GHC.Prelude
import GHC.Unit
+import GHC.Data.OsPath
import qualified Data.Map as M
import GHC.Fingerprint
import GHC.Platform.Ways
@@ -31,7 +32,7 @@ data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState)
data InstalledFindResult
= InstalledFound ModLocation InstalledModule
| InstalledNoPackage UnitId
- | InstalledNotFound [FilePath] (Maybe UnitId)
+ | InstalledNotFound [OsPath] (Maybe UnitId)
-- | The result of searching for an imported module.
--
@@ -70,7 +71,7 @@ data FindResult
--
-- Should be taken from 'DynFlags' via 'initFinderOpts'.
data FinderOpts = FinderOpts
- { finder_importPaths :: [FilePath]
+ { finder_importPaths :: [OsPath]
-- ^ Where are we allowed to look for Modules and Source files
, finder_lookupHomeInterfaces :: Bool
-- ^ When looking up a home module:
@@ -88,17 +89,17 @@ data FinderOpts = FinderOpts
, finder_enableSuggestions :: Bool
-- ^ If we encounter unknown modules, should we suggest modules
-- that have a similar name.
- , finder_workingDirectory :: Maybe FilePath
+ , finder_workingDirectory :: Maybe OsPath
, finder_thisPackageName :: Maybe FastString
, finder_hiddenModules :: Set.Set ModuleName
, finder_reexportedModules :: Set.Set ModuleName
- , finder_hieDir :: Maybe FilePath
- , finder_hieSuf :: String
- , finder_hiDir :: Maybe FilePath
- , finder_hiSuf :: String
- , finder_dynHiSuf :: String
- , finder_objectDir :: Maybe FilePath
- , finder_objectSuf :: String
- , finder_dynObjectSuf :: String
- , finder_stubDir :: Maybe FilePath
+ , finder_hieDir :: Maybe OsPath
+ , finder_hieSuf :: OsString
+ , finder_hiDir :: Maybe OsPath
+ , finder_hiSuf :: OsString
+ , finder_dynHiSuf :: OsString
+ , finder_objectDir :: Maybe OsPath
+ , finder_objectSuf :: OsString
+ , finder_dynObjectSuf :: OsString
+ , finder_stubDir :: Maybe OsPath
} deriving Show
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -1,6 +1,17 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
-- | Module location
module GHC.Unit.Module.Location
- ( ModLocation(..)
+ ( ModLocation
+ ( ..
+ , ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ )
+ , pattern ModLocation
, addBootSuffix
, addBootSuffix_maybe
, addBootSuffixLocn_maybe
@@ -11,15 +22,19 @@ module GHC.Unit.Module.Location
where
import GHC.Prelude
+
+import GHC.Data.OsPath
import GHC.Unit.Types
import GHC.Utils.Outputable
+import qualified System.OsString as OsString
+
-- | Module Location
--
-- Where a module lives on the file system: the actual locations
-- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them.
--
--- For a module in another unit, the ml_hs_file and ml_obj_file components of
+-- For a module in another unit, the ml_hs_file_ospath and ml_obj_file_ospath components of
-- ModLocation are undefined.
--
-- The locations specified by a ModLocation may or may not
@@ -38,31 +53,31 @@ import GHC.Utils.Outputable
-- boot suffixes in mkOneShotModLocation.
data ModLocation
- = ModLocation {
- ml_hs_file :: Maybe FilePath,
+ = OsPathModLocation {
+ ml_hs_file_ospath :: Maybe OsPath,
-- ^ The source file, if we have one. Package modules
-- probably don't have source files.
- ml_hi_file :: FilePath,
+ ml_hi_file_ospath :: OsPath,
-- ^ Where the .hi file is, whether or not it exists
-- yet. Always of form foo.hi, even if there is an
-- hi-boot file (we add the -boot suffix later)
- ml_dyn_hi_file :: FilePath,
+ ml_dyn_hi_file_ospath :: OsPath,
-- ^ Where the .dyn_hi file is, whether or not it exists
-- yet.
- ml_obj_file :: FilePath,
+ ml_obj_file_ospath :: OsPath,
-- ^ Where the .o file is, whether or not it exists yet.
-- (might not exist either because the module hasn't
-- been compiled yet, or because it is part of a
-- unit with a .a file)
- ml_dyn_obj_file :: FilePath,
+ ml_dyn_obj_file_ospath :: OsPath,
-- ^ Where the .dy file is, whether or not it exists
-- yet.
- ml_hie_file :: FilePath
+ ml_hie_file_ospath :: OsPath
-- ^ Where the .hie file is, whether or not it exists
-- yet.
} deriving Show
@@ -71,18 +86,18 @@ instance Outputable ModLocation where
ppr = text . show
-- | Add the @-boot@ suffix to .hs, .hi and .o files
-addBootSuffix :: FilePath -> FilePath
-addBootSuffix path = path ++ "-boot"
+addBootSuffix :: OsPath -> OsPath
+addBootSuffix path = path `mappend` os "-boot"
-- | Remove the @-boot@ suffix to .hs, .hi and .o files
-removeBootSuffix :: FilePath -> FilePath
-removeBootSuffix "-boot" = []
-removeBootSuffix (x:xs) = x : removeBootSuffix xs
-removeBootSuffix [] = error "removeBootSuffix: no -boot suffix"
-
+removeBootSuffix :: OsPath -> OsPath
+removeBootSuffix pathWithBootSuffix =
+ case OsString.stripSuffix (os "-boot") pathWithBootSuffix of
+ Just path -> path
+ Nothing -> error "removeBootSuffix: no -boot suffix"
-- | Add the @-boot@ suffix if the @Bool@ argument is @True@
-addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath
+addBootSuffix_maybe :: IsBootInterface -> OsPath -> OsPath
addBootSuffix_maybe is_boot path = case is_boot of
IsBoot -> addBootSuffix path
NotBoot -> path
@@ -95,22 +110,50 @@ addBootSuffixLocn_maybe is_boot locn = case is_boot of
-- | Add the @-boot@ suffix to all file paths associated with the module
addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn
- = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
- , ml_hi_file = addBootSuffix (ml_hi_file locn)
- , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)
- , ml_obj_file = addBootSuffix (ml_obj_file locn)
- , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)
- , ml_hie_file = addBootSuffix (ml_hie_file locn) }
+ = locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn)
+ , ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn)
+ , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)
+ , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)
+ , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)
+ , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn) }
-- | Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
addBootSuffixLocnOut :: ModLocation -> ModLocation
addBootSuffixLocnOut locn
- = locn { ml_hi_file = addBootSuffix (ml_hi_file locn)
- , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)
- , ml_obj_file = addBootSuffix (ml_obj_file locn)
- , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)
- , ml_hie_file = addBootSuffix (ml_hie_file locn)
+ = locn { ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn)
+ , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)
+ , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)
+ , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)
+ , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn)
}
-
+-- ----------------------------------------------------------------------------
+-- Helpers for backwards compatibility
+-- ----------------------------------------------------------------------------
+
+pattern ModLocation :: Maybe 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
+ } <- 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)
+ } where
+ ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_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
+ }
=====================================
compiler/GHC/Unit/Module/ModSummary.hs
=====================================
@@ -17,6 +17,11 @@ module GHC.Unit.Module.ModSummary
, msHsFilePath
, msObjFilePath
, msDynObjFilePath
+ , msHsFileOsPath
+ , msHiFileOsPath
+ , msDynHiFileOsPath
+ , msObjFileOsPath
+ , msDynObjFileOsPath
, msDeps
, isBootSummary
, findTarget
@@ -38,6 +43,7 @@ import GHC.Types.Target
import GHC.Types.PkgQual
import GHC.Data.Maybe
+import GHC.Data.OsPath (OsPath)
import GHC.Data.StringBuffer ( StringBuffer )
import GHC.Utils.Fingerprint
@@ -146,6 +152,13 @@ msDynHiFilePath ms = ml_dyn_hi_file (ms_location ms)
msObjFilePath ms = ml_obj_file (ms_location ms)
msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms)
+msHsFileOsPath, msDynHiFileOsPath, msHiFileOsPath, msObjFileOsPath, msDynObjFileOsPath :: ModSummary -> OsPath
+msHsFileOsPath ms = expectJust "msHsFilePath" (ml_hs_file_ospath (ms_location ms))
+msHiFileOsPath ms = ml_hi_file_ospath (ms_location ms)
+msDynHiFileOsPath ms = ml_dyn_hi_file_ospath (ms_location ms)
+msObjFileOsPath ms = ml_obj_file_ospath (ms_location ms)
+msDynObjFileOsPath ms = ml_dyn_obj_file_ospath (ms_location ms)
+
-- | Did this 'ModSummary' originate from a hs-boot file?
isBootSummary :: ModSummary -> IsBootInterface
isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot
=====================================
compiler/ghc.cabal.in
=====================================
@@ -123,7 +123,8 @@ Library
time >= 1.4 && < 1.15,
containers >= 0.6.2.1 && < 0.8,
array >= 0.1 && < 0.6,
- filepath >= 1 && < 1.6,
+ filepath >= 1.5 && < 1.6,
+ os-string >= 2.0.1 && < 2.1,
hpc >= 0.6 && < 0.8,
transformers >= 0.5 && < 0.7,
exceptions == 0.10.*,
@@ -444,6 +445,7 @@ Library
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+ GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Stream
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -36,7 +36,7 @@ Executable ghc
bytestring >= 0.9 && < 0.13,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
- filepath >= 1 && < 1.6,
+ filepath >= 1.5 && < 1.6,
containers >= 0.5 && < 0.8,
transformers >= 0.5 && < 0.7,
ghc-boot == @ProjectVersionMunged@,
=====================================
libraries/base/tests/all.T
=====================================
@@ -176,6 +176,7 @@ test('T7457', normal, compile_and_run, [''])
test('T7773',
[when(opsys('mingw32'), skip),
js_broken(22261),
+ when(arch('wasm32'), fragile(24928)),
expect_broken_for(23272, ['ghci-opt']) # unclear
],
compile_and_run,
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -70,6 +70,7 @@ GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Strict
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -71,6 +71,7 @@ GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Strict
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -52,6 +52,7 @@ test('add2', normal, compile_and_run, ['-fobject-code'])
test('mul2', normal, compile_and_run, ['-fobject-code'])
test('mul2int', normal, compile_and_run, ['-fobject-code'])
test('quotRem2', normal, compile_and_run, ['-fobject-code'])
+test('quotRem2Large', normal, compile_and_run, ['-fobject-code'])
test('T5863', normal, compile_and_run, [''])
test('T7014', js_skip, makefile_test, [])
=====================================
testsuite/tests/numeric/should_run/quotRem2Large.hs
=====================================
The diff for this file was not included because it is too large.
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -93,10 +93,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
-- pragmas in the modules source code. Used to infer
-- safety of module.
ms_hspp_opts
- , ms_location =
- ModLocation
- { ml_hie_file
- }
+ , ms_location = modl
} = mod_sum
dflags = ms_hspp_opts
@@ -228,7 +225,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
Interface
{ ifaceMod = mdl
, ifaceIsSig = is_sig
- , ifaceHieFile = ml_hie_file
+ , ifaceHieFile = ml_hie_file modl
, ifaceInfo = info
, ifaceDoc = Documentation header_doc mod_warning
, ifaceRnDoc = Documentation Nothing Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8303b6fda3e0daa15c76b7bcece977a2cd63ed60...6c3a56046193bca66ca43fa4f9c63801a019852d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8303b6fda3e0daa15c76b7bcece977a2cd63ed60...6c3a56046193bca66ca43fa4f9c63801a019852d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240603/341f7c9b/attachment-0001.html>
More information about the ghc-commits
mailing list