[Git][ghc/ghc][wip/romes/restore-ecwl] 7 commits: Don't store boot locations in finder cache
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu Nov 21 16:51:11 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/restore-ecwl at Glasgow Haskell Compiler / GHC
Commits:
44d909a3 by Sjoerd Visscher at 2024-11-19T14:38:24-05:00
Don't store boot locations in finder cache
Partially reverts commit fff55592a7b
Amends add(Home)ModuleToFinder so that locations for boot files are not stored in the finder cache.
Removes InstalledModule field from InstalledFound constructor since it's the same as the key that was searched for.
- - - - -
64c95292 by Sjoerd Visscher at 2024-11-19T14:38:24-05:00
Concentrate boot extension logic in Finder
With new mkHomeModLocation that takes an extra HscSource to add boot extensions if required.
- - - - -
11bad98d by ARATA Mizuki at 2024-11-19T14:39:08-05:00
Better documentation for floating-point min/max and SIMD primitives
See #25350 for floating-point min/max
Co-authored-by: sheaf <sam.derbyshire at gmail.com>
- - - - -
791a47b2 by Arnaud Spiwack at 2024-11-20T14:00:05+00:00
Add test for #25185
- - - - -
374e18e5 by Arnaud Spiwack at 2024-11-20T14:09:30+00:00
Quick look: emit the multiplicity of app heads in tcValArgs
Otherwise it's not scaled properly by the context, allowing unsound
expressions.
Fixes #25185.
- - - - -
1fc02399 by sheaf at 2024-11-20T18:11:03-05:00
x86 NCG: fix regUsageOfInstr for VMOVU & friends
This commit fixes the implementation of 'regUsageOfInstr' for vector
operations that take an 'Operand' as the destination, by ensuring that
when the destination is an address then the address should be *READ*,
and not *WRITTEN*.
Getting this wrong is a disaster, as it means the register allocator
has incorrect information, which can lead to it discard stores to
registers, segfaults ensuing.
Fixes #25486
- - - - -
bfeb8ab2 by Rodrigo Mesquita at 2024-11-21T16:50:49+00:00
Re-introduce ErrorCallWithLocation with a deprecation pragma
With the removal of the duplicate backtrace, part of CLC proposal #285,
the constructor `ErrorCallWithLocation` was removed from base.
This commit re-introduces it with a deprecation.
- - - - -
26 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/CmmToAsm/Format.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Env.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Types.hs
- libraries/ghc-internal/src/GHC/Internal/Exception.hs
- testsuite/tests/linear/should_fail/LinearConfusedDollar.stderr
- + testsuite/tests/linear/should_fail/T25185.hs
- + testsuite/tests/linear/should_fail/T25185.stderr
- testsuite/tests/linear/should_fail/all.T
- + testsuite/tests/simd/should_run/T25486.hs
- + testsuite/tests/simd/should_run/T25486.stdout
- testsuite/tests/simd/should_run/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -1095,10 +1095,18 @@ primop DoubleLeOp "<=##" Compare Double# -> Double# -> Int#
primop DoubleMinOp "minDouble#" GenPrimOp
Double# -> Double# -> Double#
+ {Return the minimum of the arguments.
+ When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)
+ or one of the arguments is not-a-number (NaN),
+ it is unspecified which one is returned.}
with commutable = True
primop DoubleMaxOp "maxDouble#" GenPrimOp
Double# -> Double# -> Double#
+ {Return the maximum of the arguments.
+ When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)
+ or one of the arguments is not-a-number (NaN),
+ it is unspecified which one is returned.}
with commutable = True
primop DoubleAddOp "+##" GenPrimOp
@@ -1269,10 +1277,18 @@ primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Int#
primop FloatMinOp "minFloat#" GenPrimOp
Float# -> Float# -> Float#
+ {Return the minimum of the arguments.
+ When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)
+ or one of the arguments is not-a-number (NaN),
+ it is unspecified which one is returned.}
with commutable = True
primop FloatMaxOp "maxFloat#" GenPrimOp
Float# -> Float# -> Float#
+ {Return the maximum of the arguments.
+ When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)
+ or one of the arguments is not-a-number (NaN),
+ it is unspecified which one is returned.}
with commutable = True
primop FloatAddOp "plusFloat#" GenPrimOp
@@ -4109,12 +4125,13 @@ primop VecPackOp "pack#" GenPrimOp
primop VecUnpackOp "unpack#" GenPrimOp
VECTOR -> VECTUPLE
- { Unpack the elements of a vector into an unboxed tuple. #}
+ { Unpack the elements of a vector into an unboxed tuple. }
with vector = ALL_VECTOR_TYPES
primop VecInsertOp "insert#" GenPrimOp
VECTOR -> SCALAR -> Int# -> VECTOR
- { Insert a scalar at the given position in a vector. }
+ { Insert a scalar at the given position in a vector.
+ The position must be a compile-time constant. }
with effect = CanFail
vector = ALL_VECTOR_TYPES
@@ -4160,40 +4177,43 @@ primop VecNegOp "negate#" GenPrimOp
primop VecIndexByteArrayOp "indexArray#" GenPrimOp
ByteArray# -> Int# -> VECTOR
- { Read a vector from specified index of immutable array. }
+ { Read a vector from the specified index of an immutable array.
+ The index is counted in units of SIMD vectors (not scalar elements). }
with effect = CanFail
vector = ALL_VECTOR_TYPES
primop VecReadByteArrayOp "readArray#" GenPrimOp
MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)
- { Read a vector from specified index of mutable array. }
+ { Read a vector from the specified index of a mutable array.
+ The index is counted in units of SIMD vectors (not scalar elements). }
with effect = ReadWriteEffect
can_fail_warning = YesWarnCanFail
vector = ALL_VECTOR_TYPES
primop VecWriteByteArrayOp "writeArray#" GenPrimOp
MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s
- { Write a vector to specified index of mutable array. }
+ { Write a vector to the specified index of a mutable array.
+ The index is counted in units of SIMD vectors (not scalar elements). }
with effect = ReadWriteEffect
can_fail_warning = YesWarnCanFail
vector = ALL_VECTOR_TYPES
primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp
Addr# -> Int# -> VECTOR
- { Reads vector; offset in bytes. }
+ { Reads vector; offset in units of SIMD vectors (not scalar elements). }
with effect = CanFail
vector = ALL_VECTOR_TYPES
primop VecReadOffAddrOp "readOffAddr#" GenPrimOp
Addr# -> Int# -> State# s -> (# State# s, VECTOR #)
- { Reads vector; offset in bytes. }
+ { Reads vector; offset in units of SIMD vectors (not scalar elements). }
with effect = ReadWriteEffect
can_fail_warning = YesWarnCanFail
vector = ALL_VECTOR_TYPES
primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp
Addr# -> Int# -> VECTOR -> State# s -> State# s
- { Write vector; offset in bytes. }
+ { Write vector; offset in units of SIMD vectors (not scalar elements). }
with effect = ReadWriteEffect
can_fail_warning = YesWarnCanFail
vector = ALL_VECTOR_TYPES
@@ -4263,7 +4283,7 @@ primop VecFNMSub "fnmsub#" GenPrimOp
primop VecShuffleOp "shuffle#" GenPrimOp
VECTOR -> VECTOR -> INTVECTUPLE -> VECTOR
{Shuffle elements of the concatenation of the input two vectors
- into the result vector.}
+ into the result vector. The indices must be compile-time constants.}
with vector = ALL_VECTOR_TYPES
primop VecMinOp "min#" GenPrimOp
=====================================
compiler/GHC/CmmToAsm/Format.hs
=====================================
@@ -273,6 +273,9 @@ instance Show RegWithFormat where
instance Uniquable RegWithFormat where
getUnique = getUnique . regWithFormat_reg
+instance Outputable VirtualRegWithFormat where
+ ppr (VirtualRegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt
+
instance Outputable RegWithFormat where
ppr (RegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt
=====================================
compiler/GHC/CmmToAsm/X86/Instr.hs
=====================================
@@ -373,8 +373,9 @@ regUsageOfInstr platform instr
| otherwise
-> usageRW fmt src dst
MOVD fmt src dst ->
- -- NB: MOVD/MOVQ always zero any remaining upper part of destination
- mkRU (use_R fmt src []) (use_R (movdOutFormat fmt) dst [])
+ -- NB: MOVD and MOVQ always zero any remaining upper part of destination,
+ -- so the destination is "written" not "modified".
+ usageRW' fmt (movdOutFormat fmt) src dst
CMOV _ fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
MOVZxL fmt src dst -> usageRW fmt src dst
MOVSxL fmt src dst -> usageRW fmt src dst
@@ -475,7 +476,7 @@ regUsageOfInstr platform instr
-- vector instructions
VBROADCAST fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]
- VEXTRACT fmt _off src dst -> mkRU [mk fmt src] (use_R fmt dst [])
+ VEXTRACT fmt _off src dst -> usageRW fmt (OpReg src) dst
INSERTPS fmt (ImmInt off) src dst
-> mkRU ((use_R fmt src []) ++ [mk fmt dst | not doesNotReadDst]) [mk fmt dst]
where
@@ -488,12 +489,12 @@ regUsageOfInstr platform instr
INSERTPS fmt _off src dst
-> mkRU ((use_R fmt src []) ++ [mk fmt dst]) [mk fmt dst]
- VMOVU fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- MOVU fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- MOVL fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- MOVH fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- MOVDQU fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
- VMOVDQU fmt src dst -> mkRU (use_R fmt src []) (use_R fmt dst [])
+ VMOVU fmt src dst -> usageRW fmt src dst
+ MOVU fmt src dst -> usageRW fmt src dst
+ MOVL fmt src dst -> usageRM fmt src dst
+ MOVH fmt src dst -> usageRM fmt src dst
+ MOVDQU fmt src dst -> usageRW fmt src dst
+ VMOVDQU fmt src dst -> usageRW fmt src dst
PXOR fmt (OpReg src) dst
| src == dst
@@ -531,11 +532,12 @@ regUsageOfInstr platform instr
-> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]
MINMAX _ _ fmt src dst
- -> mkRU (use_R fmt src $ use_R fmt dst []) (use_R fmt dst [])
+ -> usageRM fmt src dst
VMINMAX _ _ fmt src1 src2 dst
-> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]
_other -> panic "regUsage: unrecognised instr"
where
+
-- # Definitions
--
-- Written: If the operand is a register, it's written. If it's an
@@ -551,6 +553,11 @@ regUsageOfInstr platform instr
usageRW fmt op (OpAddr ea) = mkRUR (use_R fmt op $! use_EA ea [])
usageRW _ _ _ = panic "X86.RegInfo.usageRW: no match"
+ usageRW' :: HasDebugCallStack => Format -> Format -> Operand -> Operand -> RegUsage
+ usageRW' fmt1 fmt2 op (OpReg reg) = mkRU (use_R fmt1 op []) [mk fmt2 reg]
+ usageRW' fmt1 _ op (OpAddr ea) = mkRUR (use_R fmt1 op $! use_EA ea [])
+ usageRW' _ _ _ _ = panic "X86.RegInfo.usageRW: no match"
+
-- 2 operand form; first operand Read; second Modified
usageRM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage
usageRM fmt op (OpReg reg) = mkRU (use_R fmt op [mk fmt reg]) [mk fmt reg]
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -781,7 +781,7 @@ summariseRequirement pn mod_name = do
let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
let fc = hsc_FC hsc_env
- mod <- liftIO $ addHomeModuleToFinder fc home_unit (notBoot mod_name) location
+ mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location HsigFile
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
@@ -854,17 +854,14 @@ hsModuleToModSummary home_keys pn hsc_src modname
-- To add insult to injury, we don't even actually use
-- these filenames to figure out where the hi files go.
-- A travesty!
- let location0 = mkHomeModLocation2 fopts modname
+ let location = mkHomeModLocation fopts modname
(unsafeEncodeUtf $ unpackFS unit_fs </>
moduleNameSlashes modname)
- (case hsc_src of
+ (case hsc_src of
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
- _ -> location0
+ hsc_src
-- This duplicates a pile of logic in GHC.Driver.Make
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
@@ -893,7 +890,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
this_mod <- liftIO $ do
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
- addHomeModuleToFinder fc home_unit (GWIB modname (hscSourceToIsBoot hsc_src)) location
+ addHomeModuleToFinder fc home_unit modname location hsc_src
let ms = ModSummary {
ms_mod = this_mod,
ms_hsc_src = hsc_src,
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2123,38 +2123,23 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
<- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
let fopts = initFinderOpts (hsc_dflags hsc_env)
- src_path = unsafeEncodeUtf src_fn
+ (basename, extension) = splitExtension src_fn
- is_boot = case takeExtension src_fn of
- ".hs-boot" -> IsBoot
- ".lhs-boot" -> IsBoot
- _ -> NotBoot
-
- (path_without_boot, hsc_src)
- | isHaskellSigFilename src_fn = (src_path, HsigFile)
- | IsBoot <- is_boot = (removeBootSuffix src_path, HsBootFile)
- | otherwise = (src_path, HsSrcFile)
-
- -- Make a ModLocation for the Finder, who only has one entry for
- -- each @ModuleName@, and therefore needs to use the locations for
- -- the non-boot files.
- location_without_boot =
- mkHomeModLocation fopts pi_mod_name path_without_boot
+ hsc_src
+ | isHaskellSigSuffix (drop 1 extension) = HsigFile
+ | isHaskellBootSuffix (drop 1 extension) = HsBootFile
+ | otherwise = HsSrcFile
-- Make a ModLocation for this file, adding the @-boot@ suffix to
-- all paths if the original was a boot file.
- location
- | IsBoot <- is_boot
- = addBootSuffixLocn location_without_boot
- | otherwise
- = location_without_boot
+ location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src
-- 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
mod <- liftIO $ do
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
- addHomeModuleToFinder fc home_unit (GWIB pi_mod_name is_boot) location
+ addHomeModuleToFinder fc home_unit pi_mod_name location hsc_src
liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
{ nms_src_fn = src_fn
@@ -2184,14 +2169,10 @@ checkSummaryHash
-- and it was likely flushed in depanal. This is not technically
-- needed when we're called from sumariseModule but it shouldn't
-- hurt.
- -- Also, only add to finder cache for non-boot modules as the finder cache
- -- makes sure to add a boot suffix for boot files.
- _ <- do
- let fc = hsc_FC hsc_env
- gwib = GWIB (ms_mod old_summary) (isBootSummary old_summary)
- case ms_hsc_src old_summary of
- HsSrcFile -> addModuleToFinder fc gwib location
- _ -> return ()
+ let fc = hsc_FC hsc_env
+ mod = ms_mod old_summary
+ hsc_src = ms_hsc_src old_summary
+ addModuleToFinder fc mod location hsc_src
hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
@@ -2243,7 +2224,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
find_it :: IO SummariseResult
find_it = do
- found <- findImportedModule hsc_env wanted_mod mb_pkg
+ found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg
case found of
Found location mod
| isJust (ml_hs_file location) ->
@@ -2261,10 +2242,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
just_found location mod = do
-- Adjust location to point to the hs-boot source file,
-- hi file, object file, when is_boot says so
- let location' = case is_boot of
- IsBoot -> addBootSuffixLocn location
- NotBoot -> location
- src_fn = expectJust "summarise2" (ml_hs_file location')
+ let src_fn = expectJust "summarise2" (ml_hs_file location)
-- Check that it exists
-- It might have been deleted since the Finder last found it
@@ -2274,7 +2252,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
-- .hs-boot file doesn't exist.
Nothing -> return NotThere
Just h -> do
- fresult <- new_summary_cache_check location' mod src_fn h
+ fresult <- new_summary_cache_check location mod src_fn h
return $ case fresult of
Left err -> FoundHomeWithError (moduleUnitId mod, err)
Right ms -> FoundHome ms
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -292,12 +292,12 @@ findDependency :: HscEnv
findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
-- Find the module; this will be fast because
-- we've done it once during downsweep
- r <- findImportedModule hsc_env imp pkg
+ r <- findImportedModuleWithIsBoot hsc_env imp is_boot pkg
case r of
Found loc _
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Just (unsafeDecodeUtf $ addBootSuffix_maybe is_boot (ml_hi_file_ospath loc)))
+ -> return (Just (unsafeDecodeUtf $ ml_hi_file_ospath loc))
-- Not in this package: we don't need a dependency
| otherwise
=====================================
compiler/GHC/Driver/Phases.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.Driver.Phases (
isDynLibSuffix,
isHaskellUserSrcSuffix,
isHaskellSigSuffix,
+ isHaskellBootSuffix,
isSourceSuffix,
isHaskellishTarget,
@@ -234,7 +235,7 @@ phaseInputExt Js = "js"
phaseInputExt StopLn = "o"
haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,
- js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes
+ js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes
:: [String]
-- When a file with an extension in the haskellish_src_suffixes group is
-- loaded in --make mode, its imports will be loaded too.
@@ -247,7 +248,8 @@ js_suffixes = [ "js" ]
-- Will not be deleted as temp files:
haskellish_user_src_suffixes =
- haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]
+ haskellish_sig_suffixes ++ haskellish_boot_suffixes ++ [ "hs", "lhs" ]
+haskellish_boot_suffixes = [ "hs-boot", "lhs-boot" ]
haskellish_sig_suffixes = [ "hsig", "lhsig" ]
backpackish_suffixes = [ "bkp" ]
@@ -265,11 +267,12 @@ dynlib_suffixes platform = case platformOS platform of
_ -> ["so"]
isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix,
- isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix
+ isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix
:: String -> Bool
isHaskellishSuffix s = s `elem` haskellish_suffixes
isBackpackishSuffix s = s `elem` backpackish_suffixes
isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes
+isHaskellBootSuffix s = s `elem` haskellish_boot_suffixes
isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes
isCishSuffix s = s `elem` cish_suffixes
isJsSuffix s = s `elem` js_suffixes
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -734,7 +734,7 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
mod <- do
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
- addHomeModuleToFinder fc home_unit (GWIB mod_name (hscSourceToIsBoot src_flavour)) location
+ addHomeModuleToFinder fc home_unit mod_name location src_flavour
-- Make the ModSummary to hand to hscMain
let
@@ -777,24 +777,18 @@ 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 (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)
-
- -- Boot-ify it if necessary
- let location2
- | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
- | otherwise = location1
-
+ let location1 = mkHomeModLocation fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff) src_flavour
-- Take -ohi into account if present
-- 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_ospath = unsafeEncodeUtf fn }
- | otherwise = location2
+ location2 | Just fn <- ohi = location1{ ml_hi_file_ospath = unsafeEncodeUtf fn }
+ | otherwise = location1
let dynohi = dynOutputHi dflags
- location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
- | otherwise = location3
+ location3 | Just fn <- dynohi = location2{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
+ | otherwise = location2
-- Take -o into account if present
-- Very like -ohi, but we must *only* do this if we aren't linking
@@ -807,11 +801,11 @@ 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_ospath = unsafeEncodeUtf ofile
+ = location3 { 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_ospath = unsafeEncodeUtf dyn_ofile }
- | otherwise = location4
+ = location3 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
+ | otherwise = location3
return location5
where
fopts = initFinderOpts dflags
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -896,9 +896,9 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
else do
let fopts = initFinderOpts dflags
-- Look for the file
- mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)
+ mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod hi_boot_file)
case mb_found of
- InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do
+ InstalledFound loc -> do
-- See Note [Home module load error]
case mhome_unit of
Just home_unit
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -2713,7 +2713,7 @@ doShuffleOp ty (v1:v2:idxs) res
-> emitAssign (CmmLocal res) (CmmMachOp (mo is) [v1,v2])
| otherwise
-> pprPanic "doShuffleOp" $
- vcat [ text "shuffle indices must be literals, 0 <= i <" <+> ppr len ]
+ vcat [ text "shuffle indices must be literals, 0 <= i <" <+> ppr (2 * len) ]
| otherwise
= pprPanic "doShuffleOp" $
vcat [ text "non-vector argument type:" <+> ppr ty ]
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -569,6 +569,7 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
, eaql_arg_ty = sc_arg_ty
, eaql_larg = larg@(L arg_loc rn_expr)
, eaql_tc_fun = tc_head
+ , eaql_fun_ue = head_ue
, eaql_args = inst_args
, eaql_encl = arg_influences_enclosing_call
, eaql_res_rho = app_res_rho })
@@ -578,7 +579,8 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
; traceTc "tcEValArgQL {" (vcat [ text "app_res_rho:" <+> ppr app_res_rho
, text "exp_arg_ty:" <+> ppr exp_arg_ty
- , text "args:" <+> ppr inst_args ])
+ , text "args:" <+> ppr inst_args
+ , text "mult:" <+> ppr mult])
; ds_flag <- getDeepSubsumptionFlag
; (wrap, arg')
@@ -587,6 +589,9 @@ tcValArg _ (EValArgQL { eaql_wanted = wanted
do { -- Emit saved-up constraints, /under/ the tcSkolemise
-- See (QLA4) in Note [Quick Look at value arguments]
emitConstraints wanted
+ -- Emit saved-up usages /under/ the tcScalingUsage.
+ -- See (QLA5) in Note [Quick Look at value arguments]
+ ; tcEmitBindingUsage head_ue
-- Unify with context if we have not already done so
-- See (QLA4) in Note [Quick Look at value arguments]
@@ -1630,6 +1635,41 @@ This turned out to be more subtle than I expected. Wrinkles:
(kappa = [forall a. a->a]). Now we resume typechecking argument [], and
we must take advantage of what we have now discovered about `kappa`,
to typecheck [] :: [forall a. a->a]
+
+(QLA5) In the quicklook pass, we don't scale multiplicities. Since arguments
+ aren't typechecked yet, we don't know their free variable usages
+ anyway. But, in a nested call, the head of an application chain is fully
+ typechecked.
+
+ In order for the multiplicities in the head to be properly scaled, we store
+ the head's usage environment in the eaql_fun_ue field. Then, when we do the
+ full-typechecking pass, we can emit the head's usage environment where we
+ would have typechecked the head in a naive algorithm.
+
+(QLA6) `quickLookArg` is supposed to capture the result of partially typechecking
+ the argument, so it can be resumed later. "Capturing" should include all
+ generated type-class/equality constraints and Linear-Haskell usage info. There
+ are two calls in `quickLookArg1` that might generate such constraints:
+
+ - `tcInferAppHead_maybe`. This can generat Linear-Haskell usage info, via
+ the call to `tcEmitBindingUsage` in `check_local_id`, which is called
+ indirectly by `tcInferAppHead_maybe`.
+
+ In contrast, `tcInferAppHead_maybe` does not generate any type-class or
+ equality constraints, because it doesn't instantiate any functions. [But
+ see #25493 and #25494 for why this isn't quite true today.]
+
+ - `tcInstFun` generates lots of type-class and equality constraints, as it
+ instantiates the function. But it generates no usage info, because that
+ comes only from the call to `check_local_id`, whose usage info is captured
+ in the call to `tcInferAppHead_maybe` in `quickLookArg1`.
+
+ Conclusion: in quickLookArg1:
+ - capture usage information (but not constraints)
+ for the call to `tcInferAppHead_maybe`
+ - capture constraints (but not usage information)
+ for the call to `tcInstFun`
+
-}
quickLookArg :: QLFlag -> AppCtxt
@@ -1697,7 +1737,12 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
do { ((rn_fun, fun_ctxt), rn_args) <- splitHsApps arg
-- Step 1: get the type of the head of the argument
- ; mb_fun_ty <- tcInferAppHead_maybe rn_fun
+ ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun
+ -- tcCollectingUsage: the use of an Id at the head generates usage-info
+ -- See the call to `tcEmitBindingUsage` in `check_local_id`. So we must
+ -- capture and save it in the `EValArgQL`. See (QLA6) in
+ -- Note [Quick Look at value arguments]
+
; traceTc "quickLookArg {" $
vcat [ text "arg:" <+> ppr arg
, text "orig_arg_rho:" <+> ppr orig_arg_rho
@@ -1714,6 +1759,9 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
; ((inst_args, app_res_rho), wanted)
<- captureConstraints $
tcInstFun do_ql True tc_head fun_sigma rn_args
+ -- We must capture type-class and equality constraints here, but
+ -- not equality constraints. See (QLA6) in Note [Quick Look at
+ -- value arguments]
; traceTc "quickLookArg 2" $
vcat [ text "arg:" <+> ppr arg
@@ -1746,6 +1794,7 @@ quickLookArg1 ctxt larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_rho)
, eaql_arg_ty = sc_arg_ty
, eaql_larg = larg
, eaql_tc_fun = tc_head
+ , eaql_fun_ue = fun_ue
, eaql_args = inst_args
, eaql_wanted = wanted
, eaql_encl = arg_influences_enclosing_call
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Tc.Zonk.TcType
import GHC.Core.FamInstEnv ( FamInstEnvs )
-import GHC.Core.UsageEnv ( singleUsageUE )
+import GHC.Core.UsageEnv ( singleUsageUE, UsageEnv )
import GHC.Core.PatSyn( PatSyn, patSynName )
import GHC.Core.ConLike( ConLike(..) )
import GHC.Core.DataCon
@@ -178,6 +178,7 @@ data HsExprArg (p :: TcPass) where -- See Note [HsExprArg]
, eaql_larg :: LHsExpr GhcRn -- Original application, for
-- location and error msgs
, eaql_tc_fun :: (HsExpr GhcTc, AppCtxt) -- Typechecked head
+ , eaql_fun_ue :: UsageEnv -- Usage environment of the typechecked head (QLA5)
, eaql_args :: [HsExprArg 'TcpInst] -- Args: instantiated, not typechecked
, eaql_wanted :: WantedConstraints
, eaql_encl :: Bool -- True <=> we have already qlUnified
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -1412,7 +1412,7 @@ tcCollectingUsage thing_inside
tcScalingUsage :: Mult -> TcM a -> TcM a
tcScalingUsage mult thing_inside
= do { (usage, result) <- tcCollectingUsage thing_inside
- ; traceTc "tcScalingUsage" (ppr mult)
+ ; traceTc "tcScalingUsage" $ vcat [ppr mult, ppr usage]
; tcEmitBindingUsage $ scaleUE mult usage
; return result }
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -15,6 +15,7 @@ module GHC.Unit.Finder (
FinderCache(..),
initFinderCache,
findImportedModule,
+ findImportedModuleWithIsBoot,
findPluginModule,
findExactModule,
findHomeModule,
@@ -55,6 +56,7 @@ import GHC.Utils.Panic
import GHC.Linker.Types
import GHC.Types.PkgQual
+import GHC.Types.SourceFile
import GHC.Fingerprint
import Data.IORef
@@ -103,28 +105,28 @@ InstalledNotFound.
initFinderCache :: IO FinderCache
initFinderCache = do
- mod_cache <- newIORef emptyInstalledModuleWithIsBootEnv
+ mod_cache <- newIORef emptyInstalledModuleEnv
file_cache <- newIORef M.empty
let flushFinderCaches :: UnitEnv -> IO ()
flushFinderCaches ue = do
- atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleWithIsBootEnv is_ext fm, ())
+ atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
where
- is_ext mod _ = not (isUnitEnvInstalledModule ue (gwib_mod mod))
+ is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
- addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
+ addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
addToFinderCache key val =
atomicModifyIORef' mod_cache $ \c ->
- case (lookupInstalledModuleWithIsBootEnv c key, val) of
+ case (lookupInstalledModuleEnv c key, val) of
-- Don't overwrite an InstalledFound with an InstalledNotFound
-- See [Note Monotonic addToFinderCache]
(Just InstalledFound{}, InstalledNotFound{}) -> (c, ())
- _ -> (extendInstalledModuleWithIsBootEnv c key val, ())
+ _ -> (extendInstalledModuleEnv c key val, ())
- lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
+ lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
lookupFinderCache key = do
c <- readIORef mod_cache
- return $! lookupInstalledModuleWithIsBootEnv c key
+ return $! lookupInstalledModuleEnv c key
lookupFileCache :: FilePath -> IO Fingerprint
lookupFileCache key = do
@@ -156,6 +158,13 @@ findImportedModule hsc_env mod pkg_qual =
in do
findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult
+findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do
+ res <- findImportedModule hsc_env mod pkg_qual
+ case (res, is_boot) of
+ (Found loc mod, IsBoot) -> return (Found (addBootSuffixLocn loc) mod)
+ _ -> return res
+
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
@@ -228,15 +237,19 @@ findPluginModule fc fopts units Nothing mod_name =
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
-findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult
-findExactModule fc fopts other_fopts unit_state mhome_unit mod = do
- case mhome_unit of
+findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult
+findExactModule fc fopts other_fopts unit_state mhome_unit mod is_boot = do
+ res <- case mhome_unit of
Just home_unit
| isHomeInstalledModule home_unit mod
-> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)
| Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts
-> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)
_ -> findPackageModule fc unit_state fopts mod
+ case (res, is_boot) of
+ (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc))
+ _ -> return res
+
-- -----------------------------------------------------------------------------
-- Helpers
@@ -274,7 +287,7 @@ orIfNotFound this or_this = do
homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
- modLocationCache fc (notBoot mod) do_this
+ modLocationCache fc mod do_this
findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
findExposedPackageModule fc fopts units mod_name mb_pkg =
@@ -296,7 +309,7 @@ findLookupResult fc fopts r = case r of
-- with just the location of the thing that was
-- instantiated; you probably also need all of the
-- implicit locations from the instances
- InstalledFound loc _ -> return (Found loc m)
+ InstalledFound loc -> return (Found loc m)
InstalledNoPackage _ -> return (NoPackage (moduleUnit m))
InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)
, fr_pkgs_hidden = []
@@ -331,7 +344,7 @@ findLookupResult fc fopts r = case r of
, fr_unusables = []
, fr_suggestions = suggest' })
-modLocationCache :: FinderCache -> InstalledModuleWithIsBoot -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
modLocationCache fc mod do_this = do
m <- lookupFinderCache fc mod
case m of
@@ -341,17 +354,19 @@ modLocationCache fc mod do_this = do
addToFinderCache fc mod result
return result
-addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO ()
-addModuleToFinder fc mod loc = do
- let imod = fmap toUnitId <$> mod
- addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))
+addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO ()
+addModuleToFinder fc mod loc src_flavour = do
+ let imod = toUnitId <$> mod
+ unless (src_flavour == HsBootFile) $
+ addToFinderCache fc imod (InstalledFound loc)
-- This returns a module because it's more convenient for users
-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleNameWithIsBoot -> ModLocation -> IO Module
-addHomeModuleToFinder fc home_unit mod_name loc = do
- let mod = mkHomeInstalledModule home_unit <$> mod_name
- addToFinderCache fc mod (InstalledFound loc (gwib_mod mod))
- return (mkHomeModule home_unit (gwib_mod mod_name))
+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> HscSource -> IO Module
+addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do
+ let mod = mkHomeInstalledModule home_unit mod_name
+ unless (src_flavour == HsBootFile) $
+ addToFinderCache fc mod (InstalledFound loc)
+ return (mkHomeModule home_unit mod_name)
-- -----------------------------------------------------------------------------
-- The internal workers
@@ -361,7 +376,7 @@ findHomeModule fc fopts home_unit mod_name = do
let uid = homeUnitAsUnit home_unit
r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name
return $ case r of
- InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
+ InstalledFound loc -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
fr_paths = fmap unsafeDecodeUtf fps,
@@ -386,7 +401,7 @@ findHomePackageModule fc fopts home_unit mod_name = do
let uid = RealUnit (Definite home_unit)
r <- findInstalledHomeModule fc fopts home_unit mod_name
return $ case r of
- InstalledFound loc _ -> Found loc (mkModule uid mod_name)
+ InstalledFound loc -> Found loc (mkModule uid mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
fr_paths = fmap unsafeDecodeUtf fps,
@@ -456,7 +471,7 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
-- This is important only when compiling the base package (where GHC.Prim
-- is a home module).
if mod `installedModuleEq` gHC_PRIM
- then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+ then return (InstalledFound (error "GHC.Prim ModLocation"))
else searchPathExts search_dirs mod exts
-- | Prepend the working directory to the search path.
@@ -485,11 +500,11 @@ findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -
findPackageModule_ fc fopts mod pkg_conf = do
massertPpr (moduleUnit mod == unitId pkg_conf)
(ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))
- modLocationCache fc (notBoot mod) $
+ modLocationCache fc mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
if mod `installedModuleEq` gHC_PRIM
- then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+ then return (InstalledFound (error "GHC.Prim ModLocation"))
else
let
@@ -513,7 +528,7 @@ findPackageModule_ fc fopts mod pkg_conf = do
-- don't bother looking for it.
let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
loc = mk_hi_loc one basename
- in return $ InstalledFound loc mod
+ in return $ InstalledFound loc
_otherwise ->
searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
@@ -547,7 +562,7 @@ searchPathExts paths mod exts = search to_search
search ((file, loc) : rest) = do
b <- doesFileExist file
if b
- then return $ InstalledFound loc mod
+ then return $ InstalledFound loc
else search rest
mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
@@ -589,10 +604,12 @@ mkHomeModLocationSearched fopts mod suff path basename =
-- ext
-- The filename extension of the source file (usually "hs" or "lhs").
-mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation
-mkHomeModLocation dflags mod src_filename =
- let (basename,extension) = OsPath.splitExtension src_filename
- in mkHomeModLocation2 dflags mod basename extension
+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> FileExt -> HscSource -> ModLocation
+mkHomeModLocation dflags mod src_basename ext hsc_src =
+ let loc = mkHomeModLocation2 dflags mod src_basename ext
+ in case hsc_src of
+ HsBootFile -> addBootSuffixLocnOut loc
+ _ -> loc
mkHomeModLocation2 :: FinderOpts
-> ModuleName
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -30,9 +30,9 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
-- ^ remove all the home modules from the cache; package modules are
-- assumed to not move around during a session; also flush the file hash
-- cache.
- , addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
+ , addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
-- ^ Add a found location to the cache for the module.
- , lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
+ , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
-- ^ Look for a location in the cache.
, lookupFileCache :: FilePath -> IO Fingerprint
-- ^ Look for the hash of a file in the cache. This should add it to the
@@ -40,7 +40,7 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
}
data InstalledFindResult
- = InstalledFound ModLocation InstalledModule
+ = InstalledFound ModLocation
| InstalledNoPackage UnitId
| InstalledNotFound [OsPath] (Maybe UnitId)
=====================================
compiler/GHC/Unit/Module/Env.hs
=====================================
@@ -33,17 +33,6 @@ module GHC.Unit.Module.Env
, mergeInstalledModuleEnv
, plusInstalledModuleEnv
, installedModuleEnvElts
-
- -- * InstalledModuleWithIsBootEnv
- , InstalledModuleWithIsBootEnv
- , emptyInstalledModuleWithIsBootEnv
- , lookupInstalledModuleWithIsBootEnv
- , extendInstalledModuleWithIsBootEnv
- , filterInstalledModuleWithIsBootEnv
- , delInstalledModuleWithIsBootEnv
- , mergeInstalledModuleWithIsBootEnv
- , plusInstalledModuleWithIsBootEnv
- , installedModuleWithIsBootEnvElts
)
where
@@ -294,56 +283,3 @@ plusInstalledModuleEnv :: (elt -> elt -> elt)
plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) =
InstalledModuleEnv $ Map.unionWith f xm ym
-
-
---------------------------------------------------------------------
--- InstalledModuleWithIsBootEnv
---------------------------------------------------------------------
-
--- | A map keyed off of 'InstalledModuleWithIsBoot'
-newtype InstalledModuleWithIsBootEnv elt = InstalledModuleWithIsBootEnv (Map InstalledModuleWithIsBoot elt)
-
-instance Outputable elt => Outputable (InstalledModuleWithIsBootEnv elt) where
- ppr (InstalledModuleWithIsBootEnv env) = ppr env
-
-
-emptyInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a
-emptyInstalledModuleWithIsBootEnv = InstalledModuleWithIsBootEnv Map.empty
-
-lookupInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> Maybe a
-lookupInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = Map.lookup m e
-
-extendInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> a -> InstalledModuleWithIsBootEnv a
-extendInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m x = InstalledModuleWithIsBootEnv (Map.insert m x e)
-
-filterInstalledModuleWithIsBootEnv :: (InstalledModuleWithIsBoot -> a -> Bool) -> InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBootEnv a
-filterInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv e) =
- InstalledModuleWithIsBootEnv (Map.filterWithKey f e)
-
-delInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> InstalledModuleWithIsBootEnv a
-delInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = InstalledModuleWithIsBootEnv (Map.delete m e)
-
-installedModuleWithIsBootEnvElts :: InstalledModuleWithIsBootEnv a -> [(InstalledModuleWithIsBoot, a)]
-installedModuleWithIsBootEnvElts (InstalledModuleWithIsBootEnv e) = Map.assocs e
-
-mergeInstalledModuleWithIsBootEnv
- :: (elta -> eltb -> Maybe eltc)
- -> (InstalledModuleWithIsBootEnv elta -> InstalledModuleWithIsBootEnv eltc) -- map X
- -> (InstalledModuleWithIsBootEnv eltb -> InstalledModuleWithIsBootEnv eltc) -- map Y
- -> InstalledModuleWithIsBootEnv elta
- -> InstalledModuleWithIsBootEnv eltb
- -> InstalledModuleWithIsBootEnv eltc
-mergeInstalledModuleWithIsBootEnv f g h (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym)
- = InstalledModuleWithIsBootEnv $ Map.mergeWithKey
- (\_ x y -> (x `f` y))
- (coerce g)
- (coerce h)
- xm ym
-
-plusInstalledModuleWithIsBootEnv :: (elt -> elt -> elt)
- -> InstalledModuleWithIsBootEnv elt
- -> InstalledModuleWithIsBootEnv elt
- -> InstalledModuleWithIsBootEnv elt
-plusInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym) =
- InstalledModuleWithIsBootEnv $ Map.unionWith f xm ym
-
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -13,8 +13,6 @@ module GHC.Unit.Module.Location
)
, pattern ModLocation
, addBootSuffix
- , addBootSuffix_maybe
- , addBootSuffixLocn_maybe
, addBootSuffixLocn
, addBootSuffixLocnOut
, removeBootSuffix
@@ -25,7 +23,6 @@ where
import GHC.Prelude
import GHC.Data.OsPath
-import GHC.Unit.Types
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString (mkFastString)
@@ -99,26 +96,10 @@ removeBootSuffix pathWithBootSuffix =
Just path -> path
Nothing -> error "removeBootSuffix: no -boot suffix"
--- | Add the @-boot@ suffix if the @Bool@ argument is @True@
-addBootSuffix_maybe :: IsBootInterface -> OsPath -> OsPath
-addBootSuffix_maybe is_boot path = case is_boot of
- IsBoot -> addBootSuffix path
- NotBoot -> path
-
-addBootSuffixLocn_maybe :: IsBootInterface -> ModLocation -> ModLocation
-addBootSuffixLocn_maybe is_boot locn = case is_boot of
- IsBoot -> addBootSuffixLocn locn
- _ -> locn
-
-- | Add the @-boot@ suffix to all file paths associated with the module
addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn 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) }
+ = addBootSuffixLocnOut locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn) }
-- | Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -84,8 +84,6 @@ module GHC.Unit.Types
, GenWithIsBoot (..)
, ModuleNameWithIsBoot
, ModuleWithIsBoot
- , InstalledModuleWithIsBoot
- , notBoot
)
where
@@ -720,8 +718,6 @@ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
type ModuleWithIsBoot = GenWithIsBoot Module
-type InstalledModuleWithIsBoot = GenWithIsBoot InstalledModule
-
instance Binary a => Binary (GenWithIsBoot a) where
put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do
put_ bh gwib_mod
@@ -735,6 +731,3 @@ instance Outputable a => Outputable (GenWithIsBoot a) where
ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of
IsBoot -> [ text "{-# SOURCE #-}" ]
NotBoot -> []
-
-notBoot :: mod -> GenWithIsBoot mod
-notBoot gwib_mod = GWIB {gwib_mod, gwib_isBoot = NotBoot}
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception.hs
=====================================
@@ -8,6 +8,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
@@ -52,7 +53,7 @@ module GHC.Internal.Exception
, ratioZeroDenomException
, underflowException
-- ** 'ErrorCall'
- , ErrorCall(..)
+ , ErrorCall(.., ErrorCallWithLocation)
, errorCallException
, errorCallWithCallStackException
, toExceptionWithBacktrace
@@ -178,7 +179,11 @@ data ErrorCall = ErrorCall String
, Ord -- ^ @since base-4.7.0.0
)
-{-# COMPLETE ErrorCall #-}
+{-# DEPRECATED ErrorCallWithLocation "ErrorCallWithLocation has been deprecated in favour of ErrorCall (which does not have a location). Backtraces are now handled by the backtrace exception mechanisms exclusively." #-}
+pattern ErrorCallWithLocation :: String -> String -> ErrorCall
+pattern ErrorCallWithLocation err loc <- ErrorCall ((\err -> (err, error "ErrorCallWithLocation has been deprecated in favour of ErrorCall (which does not have a location). Backtraces are now handled by the backtrace exception mechanisms exclusively.")) -> (err, loc))
+ where ErrorCallWithLocation err _ = ErrorCall err
+{-# COMPLETE ErrorCallWithLocation #-}
-- | @since base-4.0.0.0
instance Exception ErrorCall
=====================================
testsuite/tests/linear/should_fail/LinearConfusedDollar.stderr
=====================================
@@ -1,3 +1,7 @@
+LinearConfusedDollar.hs:12:3: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘x’
+ • In an equation for ‘g’: g x = f $ x
LinearConfusedDollar.hs:12:7: error: [GHC-83865]
• Couldn't match type ‘One’ with ‘Many’
@@ -6,3 +10,4 @@ LinearConfusedDollar.hs:12:7: error: [GHC-83865]
• In the first argument of ‘($)’, namely ‘f’
In the expression: f $ x
In an equation for ‘g’: g x = f $ x
+
=====================================
testsuite/tests/linear/should_fail/T25185.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+
+module T25185 where
+
+f :: Int -> Int
+f x = x
+
+g :: Int %1 -> Int
+g y = f y
=====================================
testsuite/tests/linear/should_fail/T25185.stderr
=====================================
@@ -0,0 +1,5 @@
+T25185.hs:10:3: error: [GHC-18872]
+ • Couldn't match type ‘Many’ with ‘One’
+ arising from multiplicity of ‘y’
+ • In an equation for ‘g’: g y = f y
+
=====================================
testsuite/tests/linear/should_fail/all.T
=====================================
@@ -53,3 +53,4 @@ test('LinearLet9', normal, compile_fail, [''])
test('LinearLet10', normal, compile_fail, [''])
test('T25081', normal, compile_fail, [''])
test('T24961', normal, compile_fail, [''])
+test('T25185', normal, compile_fail, [''])
=====================================
testsuite/tests/simd/should_run/T25486.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+import Data.Array.Base
+import Data.Array.IO.Internals
+import Control.Monad
+import Foreign.Marshal.Array
+
+writeFloatX4OffAddr :: Ptr Float -> Int -> FloatX4# -> IO ()
+writeFloatX4OffAddr (Ptr addr) (I# i) v =
+ IO $ \s -> (# writeFloatX4OffAddr# addr i v s, () #)
+
+writeAsFloatX4OffAddr :: Ptr Float -> Int -> FloatX4# -> IO ()
+writeAsFloatX4OffAddr (Ptr addr) (I# i) v =
+ IO $ \s -> (# writeFloatOffAddrAsFloatX4# addr i v s, () #)
+
+writeFloatX4 :: IOUArray Int Float -> Int -> FloatX4# -> IO ()
+writeFloatX4 (IOUArray (STUArray l _ _ mba)) i v = case i - l of
+ I# i# -> IO $ \s -> (# writeFloatX4Array# mba i# v s, () #)
+
+writeAsFloatX4 :: IOUArray Int Float -> Int -> FloatX4# -> IO ()
+writeAsFloatX4 (IOUArray (STUArray l _ _ mba)) i v = case i - l of
+ I# i# -> IO $ \s -> (# writeFloatArrayAsFloatX4# mba i# v s, () #)
+
+main :: IO ()
+main = do
+ let v = packFloatX4# (# 0.1#, 1.1#, 2.2#, 3.3# #)
+
+ xs <- withArray ([0..15] :: [Float]) $ \ptr -> do
+ writeFloatX4OffAddr ptr 2 v
+ peekArray 16 ptr
+ print xs
+
+ ys <- withArray ([0..15] :: [Float]) $ \ptr -> do
+ writeAsFloatX4OffAddr ptr 2 v
+ peekArray 16 ptr
+ print ys
+
+ ma <- newListArray (0, 9) ([0..9] :: [Float])
+ writeFloatX4 ma 1 v
+ print =<< getElems ma
+
+ ma <- newListArray (0, 9) ([0..9] :: [Float])
+ writeAsFloatX4 ma 1 v
+ print =<< getElems ma
=====================================
testsuite/tests/simd/should_run/T25486.stdout
=====================================
@@ -0,0 +1,4 @@
+[0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,0.1,1.1,2.2,3.3,12.0,13.0,14.0,15.0]
+[0.0,1.0,0.1,1.1,2.2,3.3,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0]
+[0.0,1.0,2.0,3.0,0.1,1.1,2.2,3.3,8.0,9.0]
+[0.0,0.1,1.1,2.2,3.3,5.0,6.0,7.0,8.0,9.0]
=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -90,3 +90,4 @@ test('T25062_V64'
test('T25169', [], compile_and_run, [''])
test('T25455', [], compile_and_run, [''])
+test('T25486', [], compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/70e19389cde8b1e8a87402b908a78ff889fca56f...bfeb8ab24a8280e6f4c4fa8d0bf9cb1f39ad5c0f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/70e19389cde8b1e8a87402b908a78ff889fca56f...bfeb8ab24a8280e6f4c4fa8d0bf9cb1f39ad5c0f
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/20241121/648f4b9d/attachment-0001.html>
More information about the ghc-commits
mailing list