[Git][ghc/ghc][wip/andreask/sse_macro_docs] 3 commits: isIrrefutableHsPat: look up ConLikes in the HscEnv
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Fri Aug 16 16:53:04 UTC 2024
Andreas Klebinger pushed to branch wip/andreask/sse_macro_docs at Glasgow Haskell Compiler / GHC
Commits:
bdd77b9e by sheaf at 2024-08-16T12:47:11-04:00
isIrrefutableHsPat: look up ConLikes in the HscEnv
At GhcRn stage, in isIrrefutableHsPat we only looked up data constructors
in the RdrEnv, which meant that we lacked fallibility information for
out-of-scope constructors (which can arise from Template Haskell splices).
Instead, we use 'lookupGREInfo', which looks up the information in
the type environment. This was the correct function to call all along,
but was not used in 572fbc44 due to import cycle reasons. The appropriate
functions, 'irrefutableConLike{Rn,Tc}' have been moved to 'GHC.Rename.Env',
which avoids import cycles.
Fixes #25164
- - - - -
4bee377c by Sylvain Henry at 2024-08-16T12:47:53-04:00
Linker: some refactoring to prepare for #24886
- Rename LoadedBCOs into LazyBCOs
- Bundle SptEntries with CompiledByteCode and removed [SptEntry] field
from the BCOs constructor
- Rename Linkable's LM constructor into Linkable: in the past we had LM
and LP for Module and Package, now we only have the former.
- Rename Unlinked into LinkablePart (and linkableUnlinked into
linkableParts)
- Use NonEmpty to encode invariant in Linkable's linkableParts type
- Add helpers: linkableLibs, linkableBCOs, etc.
- Add documentation
- Remove partial nameOfObject
- Rename nameOfObject_maybe into linkablePartPath
- Rename byteCodeOfObject into linkablePartAllBCOs.
- Refactor linkablePartAllBCOs to avoid a panic if a LazyBCO has a C
stub. Document the fact that LazyBCOs are returned in this case
(contrary to linkableBCOs which only returns non-lazy ones)
Refactoring done while trying to understand how to adapt the linker code
to support the JS backend too (cf #24886).
- - - - -
f1382aa0 by Andreas Klebinger at 2024-08-16T18:36:42+02:00
Document the (x86) SIMD macros.
Fixes #25021.
- - - - -
30 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Gen/Do.hs
- compiler/GHC/Tc/Gen/Match.hs
- + compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- compiler/ghc.cabal.in
- docs/users_guide/phases.rst
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- + testsuite/tests/pmcheck/should_compile/T25164.hs
- + testsuite/tests/pmcheck/should_compile/T25164_aux.hs
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -28,6 +28,7 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Literal
import GHC.Types.Unique.DSet
+import GHC.Types.SptEntry
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -94,8 +95,9 @@ assembleBCOs
-> [TyCon]
-> AddrEnv
-> Maybe ModBreaks
+ -> [SptEntry]
-> IO CompiledByteCode
-assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
+assembleBCOs interp profile proto_bcos tycons top_strs modbreaks spt_entries = do
-- TODO: the profile should be bundled with the interpreter: the rts ways are
-- fixed for an interpreter
itblenv <- mkITbls interp profile tycons
@@ -107,6 +109,7 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
, bc_ffis = concatMap protoBCOFFIs proto_bcos
, bc_strs = top_strs
, bc_breaks = modbreaks
+ , bc_spt_entries = spt_entries
}
-- Note [Allocating string literals]
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -32,6 +32,7 @@ import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
+import GHC.Types.SptEntry
import GHC.Types.SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
@@ -54,12 +55,25 @@ import Language.Haskell.Syntax.Module.Name (ModuleName)
-- Compiled Byte Code
data CompiledByteCode = CompiledByteCode
- { bc_bcos :: FlatBag UnlinkedBCO -- Bunch of interpretable bindings
- , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls
- , bc_ffis :: [FFIInfo] -- ffi blocks we allocated
- , bc_strs :: AddrEnv -- malloc'd top-level strings
- , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
- -- creating breakpoints, for some reason)
+ { bc_bcos :: FlatBag UnlinkedBCO
+ -- ^ Bunch of interpretable bindings
+
+ , bc_itbls :: ItblEnv
+ -- ^ Mapping from DataCons to their info tables
+
+ , bc_ffis :: [FFIInfo]
+ -- ^ ffi blocks we allocated
+
+ , bc_strs :: AddrEnv
+ -- ^ top-level strings (heap allocated)
+
+ , bc_breaks :: Maybe ModBreaks
+ -- ^ breakpoint info (Nothing if breakpoints are disabled)
+
+ , bc_spt_entries :: ![SptEntry]
+ -- ^ Static pointer table entries which should be loaded along with the
+ -- BCOs. See Note [Grand plan for static forms] in
+ -- "GHC.Iface.Tidy.StaticPtrTable".
}
-- ToDo: we're not tracking strings that we malloc'd
newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -346,8 +346,7 @@ buildUnit session cid insts lunit = do
linkables = map (expectJust "bkp link" . homeModInfoObject)
. filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
$ home_mod_infos
- getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)
- obj_files = concatMap getOfiles linkables
+ obj_files = concatMap linkableFiles linkables
state = hsc_units hsc_env
let compat_fs = unitIdFS cid
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -944,7 +944,7 @@ checkObjects dflags mb_old_linkable summary = do
| obj_date >= if_date ->
case mb_old_linkable of
Just old_linkable
- | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date
+ | linkableIsNativeCodeOnly old_linkable, linkableTime old_linkable == obj_date
-> return $ UpToDateItem old_linkable
_ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date
_ -> return $ outOfDateItemBecause MissingObjectFile Nothing
@@ -956,7 +956,7 @@ checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated
checkByteCode iface mod_sum mb_old_linkable =
case mb_old_linkable of
Just old_linkable
- | not (isObjectLinkable old_linkable)
+ | not (linkableIsNativeCodeOnly old_linkable)
-> return $ (UpToDateItem old_linkable)
_ -> loadByteCode iface mod_sum
@@ -968,7 +968,7 @@ loadByteCode iface mod_sum = do
case mi_extra_decls iface of
Just extra_decls -> do
let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)
- return (UpToDateItem (LM if_date this_mod [CoreBindings fi]))
+ return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
--------------------------------------------------------------
-- Compilers
@@ -991,7 +991,7 @@ initModDetails hsc_env iface =
-- Hydrate any WholeCoreBindings linkables into BCOs
initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time this_mod <$> mapM go uls
+initWholeCoreBindings hsc_env mod_iface details (Linkable utc_time this_mod uls) = Linkable utc_time this_mod <$> mapM go uls
where
go (CoreBindings fi) = do
let act hpt = addToHpt hpt (moduleName $ mi_module mod_iface)
@@ -1003,7 +1003,7 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM
-- recompilation checking the bytecode will be generated (which slows things down a lot)
-- the laziness is OK because generateByteCode just depends on things already loaded
-- in the interface file.
- LoadedBCOs <$> (unsafeInterleaveIO $ do
+ LazyBCOs <$> (unsafeInterleaveIO $ do
core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
-- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
-- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
@@ -1990,7 +1990,7 @@ mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_modBre
hscInteractive :: HscEnv
-> CgInteractiveGuts
-> ModLocation
- -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
+ -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode
hscInteractive hsc_env cgguts location = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
@@ -2028,18 +2028,19 @@ hscInteractive hsc_env cgguts location = do
let (stg_binds,_stg_deps) = unzip stg_binds_with_deps
----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks
+ comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks spt_entries
+
------------------ Create f-x-dynamic C-side stuff -----
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs
- return (istub_c_exists, comp_bc, spt_entries)
+ return (istub_c_exists, comp_bc)
generateByteCode :: HscEnv
-> CgInteractiveGuts
-> ModLocation
- -> IO [Unlinked]
+ -> IO (NonEmpty LinkablePart)
generateByteCode hsc_env cgguts mod_location = do
- (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location
+ (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
stub_o <- case hasStub of
Nothing -> return []
@@ -2047,8 +2048,7 @@ generateByteCode hsc_env cgguts mod_location = do
stub_o <- compileForeign hsc_env LangC stub_c
return [DotO stub_o]
- let hs_unlinked = [BCOs comp_bc spt_entries]
- return (hs_unlinked ++ stub_o)
+ return (BCOs comp_bc :| stub_o)
generateFreshByteCode :: HscEnv
-> ModuleName
@@ -2056,10 +2056,9 @@ generateFreshByteCode :: HscEnv
-> ModLocation
-> IO Linkable
generateFreshByteCode hsc_env mod_name cgguts mod_location = do
- ul <- generateByteCode hsc_env cgguts mod_location
- unlinked_time <- getCurrentTime
- let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) ul
- return linkable
+ bco_time <- getCurrentTime
+ bco <- generateByteCode hsc_env cgguts mod_location
+ return $! Linkable bco_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) bco
------------------------------
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
@@ -2381,7 +2380,9 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
let !CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
- cg_modBreaks = mod_breaks } = tidy_cg
+ cg_modBreaks = mod_breaks,
+ cg_spt_entries = spt_entries
+ } = tidy_cg
!ModDetails { md_insts = cls_insts
, md_fam_insts = fam_insts } = mod_details
@@ -2413,7 +2414,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
{- Generate byte code -}
cbc <- liftIO $ byteCodeGen hsc_env this_mod
- stg_binds data_tycons mod_breaks
+ stg_binds data_tycons mod_breaks spt_entries
let src_span = srcLocSpan interactiveSrcLoc
_ <- liftIO $ loadDecls interp hsc_env src_span cbc
@@ -2690,7 +2691,9 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
bcos <- byteCodeGen hsc_env
this_mod
stg_binds
- [] Nothing
+ []
+ Nothing -- modbreaks
+ [] -- spt entries
{- load it -}
(fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan bcos
@@ -2749,7 +2752,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
deps <- getLinkDeps link_opts interp pls srcspan needed_mods
-- We update the LinkerState even if the JS interpreter maintains its linker
-- state independently to load new objects here.
- let (objs, _bcos) = partition isObjectLinkable
+ let (objs, _bcos) = partition linkableIsNativeCodeOnly
(concatMap partitionLinkable (ldNeededLinkables deps))
let (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -68,6 +68,7 @@ import GHC.Driver.Main
import GHC.Driver.MakeSem
import GHC.Parser.Header
+import GHC.ByteCode.Types
import GHC.Iface.Load ( cannotFindModule )
import GHC.IfaceToCore ( typecheckIface )
@@ -1322,10 +1323,9 @@ addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
addSptEntries hsc_env mlinkable =
hscAddSptEntries hsc_env
[ spt
- | Just linkable <- [mlinkable]
- , unlinked <- linkableUnlinked linkable
- , BCOs _ spts <- pure unlinked
- , spt <- spts
+ | linkable <- maybeToList mlinkable
+ , bco <- linkableBCOs linkable
+ , spt <- bc_spt_entries bco
]
{- Note [-fno-code mode]
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -117,6 +117,8 @@ import Control.Monad
import qualified Control.Monad.Catch as MC (handle)
import Data.Maybe
import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..))
import Data.Time ( getCurrentTime )
import GHC.Iface.Recomp
@@ -421,8 +423,7 @@ link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt
return Succeeded
else do
- let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)
- obj_files = concatMap getOfiles linkables
+ let obj_files = concatMap linkableObjs linkables
platform = targetPlatform dflags
arch_os = platformArchOS platform
exe_file = exeFileName arch_os staticLink (outputFile_ dflags)
@@ -815,9 +816,9 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
-- No object file produced, bytecode or NoBackend
Nothing -> return mlinkable
Just o_fp -> do
- unlinked_time <- liftIO (liftIO getCurrentTime)
- final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
- let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]
+ part_time <- liftIO (liftIO getCurrentTime)
+ final_part <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
+ let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton final_part)
-- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.
return (mlinkable { homeMod_object = Just linkable })
return (miface, final_linkable)
@@ -929,7 +930,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
as :: P m => Bool -> m (Maybe FilePath)
as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
- objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk
+ objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk :| []))) = Just lnk
objFromLinkable _ = Nothing
fromPhase :: P m => Phase -> m (Maybe FilePath)
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -46,7 +46,7 @@ module GHC.Hs.Pat (
looksLazyPatBind,
isBangedLPat,
gParPat, patNeedsParens, parenthesizePat,
- isIrrefutableHsPat, irrefutableConLikeRn, irrefutableConLikeTc,
+ isIrrefutableHsPat,
isBoringHsPat,
@@ -76,15 +76,10 @@ import GHC.Types.SourceText
-- others:
import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
import GHC.Builtin.Types
-import GHC.Types.CompleteMatch
-import GHC.Types.TyThing (tyThingGREInfo)
-import GHC.Types.Unique.DSet
import GHC.Types.Var
import GHC.Types.Name.Reader
-import GHC.Types.GREInfo
import GHC.Core.ConLike
import GHC.Core.DataCon
-import GHC.Core.TyCon
import GHC.Utils.Outputable
import GHC.Core.Type
import GHC.Types.SrcLoc
@@ -696,64 +691,6 @@ isIrrefutableHsPat is_strict irref_conLike pat = go (unLoc pat)
CoPat _ pat _ -> go pat
ExpansionPat _ pat -> go pat
--- | Check irrefutability of a 'ConLike' in a 'ConPat GhcRn'
--- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]).
-irrefutableConLikeRn :: GlobalRdrEnv
- -> CompleteMatches -- ^ in-scope COMPLETE pragmas
- -> Name -- ^ the 'Name' of the 'ConLike'
- -> Bool
-irrefutableConLikeRn rdr_env comps con_nm =
- case mbInfo of
- Just (IAmConLike conInfo) ->
- case conLikeInfo conInfo of
- ConIsData { conLikeDataCons = tc_cons } ->
- length tc_cons == 1
- ConIsPatSyn ->
- in_single_complete_match con_nm comps
- _ -> False
- where
- -- Sorry: it's horrible to manually call 'wiredInNameTyThing_maybe' here,
- -- but import cycles make calling the right function, namely 'lookupGREInfo',
- -- quite difficult from within this module.
- mbInfo = case tyThingGREInfo <$> wiredInNameTyThing_maybe con_nm of
- Nothing -> greInfo <$> lookupGRE_Name rdr_env con_nm
- Just nfo -> Just nfo
-
--- | Check irrefutability of the 'ConLike' in a 'ConPat GhcTc'
--- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]),
--- given all in-scope COMPLETE pragmas ('CompleteMatches' in the typechecker,
--- 'DsCompleteMatches' in the desugarer).
-irrefutableConLikeTc :: NamedThing con
- => [CompleteMatchX con]
- -- ^ in-scope COMPLETE pragmas
- -> ConLike
- -> Bool
-irrefutableConLikeTc comps con =
- case con of
- RealDataCon dc -> length (tyConDataCons (dataConTyCon dc)) == 1
- PatSynCon {} -> in_single_complete_match con_nm comps
- where
- con_nm = conLikeName con
-
--- | Internal helper function: check whether a 'ConLike' is the single member
--- of a COMPLETE set without a result 'TyCon'.
---
--- Why 'without a result TyCon'? See Wrinkle [Irrefutability and COMPLETE pragma result TyCons]
--- in Note [Irrefutability of ConPat].
-in_single_complete_match :: NamedThing con => Name -> [CompleteMatchX con] -> Bool
-in_single_complete_match con_nm = go
- where
- go [] = False
- go (comp:comps)
- | Nothing <- cmResultTyCon comp
- -- conservative, as we don't have enough info to compute
- -- 'completeMatchAppliesAtType'
- , let comp_nms = mapUniqDSet getName $ cmConLikes comp
- , comp_nms == mkUniqDSet [con_nm]
- = True
- | otherwise
- = go comps
-
-- | Is the pattern any of combination of:
--
-- - (pat)
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -42,6 +42,7 @@ import Data.List (sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NE
import GHC.Linker.Types
import GHC.Unit.Finder
@@ -171,14 +172,14 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
(plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins
concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)
where
- linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls
+ linkableToUsage (Linkable _ m uls) = mapM (partToUsage m) (NE.toList uls)
msg m = moduleNameString (moduleName m) ++ "[TH] changed"
fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg
- unlinkedToUsage m ul =
- case nameOfObject_maybe ul of
+ partToUsage m part =
+ case linkablePartPath part of
Just fn -> fing (Just (msg m)) fn
Nothing -> do
-- This should only happen for home package things but oneshot puts
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -86,6 +86,7 @@ import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Rename.Env ( irrefutableConLikeTc )
import GHC.Tc.Types.Evidence
import Control.Monad ( unless, zipWithM )
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -293,13 +293,14 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
adjust_linkable lnk
| Just new_osuf <- maybe_normal_osuf = do
- new_uls <- mapM (adjust_ul new_osuf)
- (linkableUnlinked lnk)
- return lnk{ linkableUnlinked=new_uls }
+ new_parts <- mapM (adjust_part new_osuf)
+ (linkableParts lnk)
+ return lnk{ linkableParts=new_parts }
| otherwise =
return lnk
- adjust_ul new_osuf (DotO file) = do
+ adjust_part new_osuf part = case part of
+ DotO file -> do
massert (osuf `isSuffixOf` file)
let file_base = fromJust (stripExtension osuf file)
new_file = file_base <.> new_osuf
@@ -309,11 +310,11 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
text "cannot find object file "
<> quotes (text new_file) $$ while_linking_expr
else return (DotO new_file)
- adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
- adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
- adjust_ul _ l@(BCOs {}) = return l
- adjust_ul _ l at LoadedBCOs{} = return l
- adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod)
+ DotA fp -> panic ("adjust_ul DotA " ++ show fp)
+ DotDLL fp -> panic ("adjust_ul DotDLL " ++ show fp)
+ BCOs {} -> pure part
+ LazyBCOs{} -> pure part
+ CoreBindings (WholeCoreBindings _ mod _) -> pprPanic "Unhydrated core bindings" (ppr mod)
{-
Note [Using Byte Code rather than Object Code for Template Haskell]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -99,6 +99,8 @@ import Data.List (intercalate, isPrefixOf, nub, partition)
import Data.Maybe
import Control.Concurrent.MVar
import qualified Control.Monad.Catch as MC
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty(..))
import System.FilePath
import System.Directory
@@ -725,7 +727,7 @@ loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (Load
loadModuleLinkables interp hsc_env pls linkables
= mask_ $ do -- don't want to be interrupted by ^C in here
- let (objs, bcos) = partition isObjectLinkable
+ let (objs, bcos) = partition linkableIsNativeCodeOnly
(concatMap partitionLinkable linkables)
-- Load objects first; they can't depend on BCOs
@@ -740,15 +742,11 @@ loadModuleLinkables interp hsc_env pls linkables
-- HACK to support f-x-dynamic in the interpreter; no other purpose
partitionLinkable :: Linkable -> [Linkable]
-partitionLinkable li
- = let li_uls = linkableUnlinked li
- li_uls_obj = filter isObject li_uls
- li_uls_bco = filter isInterpretable li_uls
- in
- case (li_uls_obj, li_uls_bco) of
- (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
- li {linkableUnlinked=li_uls_bco}]
- _ -> [li]
+partitionLinkable li = case linkablePartitionParts li of
+ (o:os, bco:bcos) -> [ li { linkableParts = o :| os }
+ , li { linkableParts = bco :| bcos }
+ ]
+ _ -> [li]
linkableInSet :: Linkable -> LinkableSet -> Bool
linkableInSet l objs_loaded =
@@ -776,8 +774,7 @@ loadObjects
loadObjects interp hsc_env pls objs = do
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
- unlinkeds = concatMap linkableUnlinked new_objs
- wanted_objs = map nameOfObject unlinkeds
+ wanted_objs = concatMap linkableFiles new_objs
if interpreterDynamic interp
then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs
@@ -893,11 +890,12 @@ dynLinkBCOs interp pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
- unlinkeds :: [Unlinked]
- unlinkeds = concatMap linkableUnlinked new_bcos
+
+ parts :: [LinkablePart]
+ parts = concatMap (NE.toList . linkableParts) new_bcos
cbcs :: [CompiledByteCode]
- cbcs = concatMap byteCodeOfObject unlinkeds
+ cbcs = concatMap linkablePartAllBCOs parts
le1 = linker_env pls
@@ -1004,7 +1002,7 @@ unload_wkr interp keep_linkables pls at LoaderState{..} = do
-- we're unloading some code. -fghci-leak-check with the tests in
-- testsuite/ghci can detect space leaks here.
- let (objs_to_keep', bcos_to_keep') = partition isObjectLinkable keep_linkables
+ let (objs_to_keep', bcos_to_keep') = partition linkableIsNativeCodeOnly keep_linkables
objs_to_keep = mkLinkableSet objs_to_keep'
bcos_to_keep = mkLinkableSet bcos_to_keep'
@@ -1045,9 +1043,9 @@ unload_wkr interp keep_linkables pls at LoaderState{..} = do
-- not much benefit.
| otherwise
- = mapM_ (unloadObj interp) [f | DotO f <- linkableUnlinked lnk]
+ = mapM_ (unloadObj interp) (linkableObjs lnk)
-- The components of a BCO linkable may contain
- -- dot-o files. Which is very confusing.
+ -- dot-o files (generated from C stubs).
--
-- But the BCO parts can be unlinked just by
-- letting go of them (plus of course depopulating
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -1,3 +1,6 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE LambdaCase #-}
+
-----------------------------------------------------------------------------
--
-- Types for the linkers and the loader
@@ -5,7 +8,6 @@
-- (c) The University of Glasgow 2019
--
-----------------------------------------------------------------------------
-{-# LANGUAGE TypeApplications #-}
module GHC.Linker.Types
( Loader (..)
, LoaderState (..)
@@ -16,47 +18,54 @@ module GHC.Linker.Types
, ClosureEnv
, emptyClosureEnv
, extendClosureEnv
- , Linkable(..)
, LinkableSet
, mkLinkableSet
, unionLinkableSet
, ObjFile
- , Unlinked(..)
, SptEntry(..)
- , isObjectLinkable
- , linkableObjs
- , isObject
- , nameOfObject
- , nameOfObject_maybe
- , isInterpretable
- , byteCodeOfObject
, LibrarySpec(..)
, LoadedPkgInfo(..)
, PkgsLoaded
+
+ -- * Linkable
+ , Linkable(..)
+ , LinkablePart(..)
+ , linkableIsNativeCodeOnly
+ , linkableObjs
+ , linkableLibs
+ , linkableFiles
+ , linkableBCOs
+ , linkableNativeParts
+ , linkablePartitionParts
+ , linkablePartPath
+ , linkablePartAllBCOs
+ , isNativeCode
+ , isNativeLib
+ , isInterpretable
)
where
import GHC.Prelude
import GHC.Unit ( UnitId, Module )
import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode )
-import GHC.Fingerprint.Type ( Fingerprint )
import GHCi.RemoteTypes ( ForeignHValue, RemotePtr )
import GHCi.Message ( LoadedDLL )
-import GHC.Types.Var ( Id )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )
import GHC.Types.Name ( Name )
+import GHC.Types.SptEntry
import GHC.Utils.Outputable
-import GHC.Utils.Panic
import Control.Concurrent.MVar
import Data.Time ( UTCTime )
-import Data.Maybe
import GHC.Unit.Module.Env
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Unit.Module.WholeCoreBindings
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (mapMaybe)
+import qualified Data.List.NonEmpty as NE
{- **********************************************************************
@@ -162,7 +171,7 @@ data LinkerEnv = LinkerEnv
, itbl_env :: !ItblEnv
-- ^ The current global mapping from RdrNames of DataCons to
-- info table addresses.
- -- When a new Unlinked is linked into the running image, or an existing
+ -- When a new LinkablePart is linked into the running image, or an existing
-- module in the image is replaced, the itbl_env must be updated
-- appropriately.
@@ -208,15 +217,17 @@ instance Outputable LoadedPkgInfo where
-- | Information we can use to dynamically link modules into the compiler
-data Linkable = LM {
- linkableTime :: !UTCTime, -- ^ Time at which this linkable was built
- -- (i.e. when the bytecodes were produced,
- -- or the mod date on the files)
- linkableModule :: !Module, -- ^ The linkable module itself
- linkableUnlinked :: [Unlinked]
- -- ^ Those files and chunks of code we have yet to link.
- --
- -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.
+data Linkable = Linkable
+ { linkableTime :: !UTCTime
+ -- ^ Time at which this linkable was built
+ -- (i.e. when the bytecodes were produced,
+ -- or the mod date on the files)
+
+ , linkableModule :: !Module
+ -- ^ The linkable module itself
+
+ , linkableParts :: NonEmpty LinkablePart
+ -- ^ Files and chunks of code to link.
}
type LinkableSet = ModuleEnv Linkable
@@ -224,6 +235,9 @@ type LinkableSet = ModuleEnv Linkable
mkLinkableSet :: [Linkable] -> LinkableSet
mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls]
+-- | Union of LinkableSets.
+--
+-- In case of conflict, keep the most recent Linkable (as per linkableTime)
unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet
unionLinkableSet = plusModuleEnv_C go
where
@@ -232,85 +246,122 @@ unionLinkableSet = plusModuleEnv_C go
| otherwise = l2
instance Outputable Linkable where
- ppr (LM when_made mod unlinkeds)
- = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
- $$ nest 3 (ppr unlinkeds)
+ ppr (Linkable when_made mod parts)
+ = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod)
+ $$ nest 3 (ppr parts)
type ObjFile = FilePath
-- | Objects which have yet to be linked by the compiler
-data Unlinked
- = DotO ObjFile -- ^ An object file (.o)
- | DotA FilePath -- ^ Static archive file (.a)
- | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib)
- | CoreBindings WholeCoreBindings -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend
- -- See Note [Interface Files with Core Definitions]
- | LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid
- -- being too strict.
+data LinkablePart
+ = DotO ObjFile
+ -- ^ An object file (.o)
+
+ | DotA FilePath
+ -- ^ Static archive file (.a)
+
+ | DotDLL FilePath
+ -- ^ Dynamically linked library file (.so, .dll, .dylib)
+
+ | CoreBindings WholeCoreBindings
+ -- ^ Serialised core which we can turn into BCOs (or object files), or
+ -- used by some other backend See Note [Interface Files with Core
+ -- Definitions]
+
+ | LazyBCOs (NonEmpty LinkablePart)
+ -- ^ Some BCOs generated on-demand when forced. This is used for
+ -- WholeCoreBindings, see Note [Interface Files with Core Definitions]
+ --
+ -- We use `NonEmpty LinkablePart` instead of `CompiledByteCode` because the list
+ -- also contains the stubs objects (DotO) for the BCOs.
+
| BCOs CompiledByteCode
- [SptEntry] -- ^ A byte-code object, lives only in memory. Also
- -- carries some static pointer table entries which
- -- should be loaded along with the BCOs.
- -- See Note [Grand plan for static forms] in
- -- "GHC.Iface.Tidy.StaticPtrTable".
-
-instance Outputable Unlinked where
- ppr (DotO path) = text "DotO" <+> text path
- ppr (DotA path) = text "DotA" <+> text path
- ppr (DotDLL path) = text "DotDLL" <+> text path
- ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt
- ppr (LoadedBCOs{}) = text "LoadedBCOs"
- ppr (CoreBindings {}) = text "FI"
-
--- | An entry to be inserted into a module's static pointer table.
--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
-data SptEntry = SptEntry Id Fingerprint
-
-instance Outputable SptEntry where
- ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
-
-
-isObjectLinkable :: Linkable -> Bool
-isObjectLinkable l = not (null unlinked) && all isObject unlinked
- where unlinked = linkableUnlinked l
- -- A linkable with no Unlinked's is treated as a BCO. We can
- -- generate a linkable with no Unlinked's as a result of
- -- compiling a module in NoBackend mode, and this choice
- -- happens to work well with checkStability in module GHC.
+ -- ^ A byte-code object, lives only in memory.
+
+instance Outputable LinkablePart where
+ ppr (DotO path) = text "DotO" <+> text path
+ ppr (DotA path) = text "DotA" <+> text path
+ ppr (DotDLL path) = text "DotDLL" <+> text path
+ ppr (BCOs bco) = text "BCOs" <+> ppr bco
+ ppr (LazyBCOs{}) = text "LazyBCOs"
+ ppr (CoreBindings {}) = text "CoreBindings"
+-- | Return true if the linkable only consists of native code (no BCO)
+linkableIsNativeCodeOnly :: Linkable -> Bool
+linkableIsNativeCodeOnly l = all isNativeCode (NE.toList (linkableParts l))
+
+-- | List the BCOs parts of a linkable.
+--
+-- This excludes the LazyBCOs and the CoreBindings parts
+linkableBCOs :: Linkable -> [CompiledByteCode]
+linkableBCOs l = [ cbc | BCOs cbc <- NE.toList (linkableParts l) ]
+
+-- | List the native linkable parts (.o/.so/.dll) of a linkable
+linkableNativeParts :: Linkable -> [LinkablePart]
+linkableNativeParts l = NE.filter isNativeCode (linkableParts l)
+
+-- | Split linkable parts into (native code parts, BCOs parts)
+linkablePartitionParts :: Linkable -> ([LinkablePart],[LinkablePart])
+linkablePartitionParts l = NE.partition isNativeCode (linkableParts l)
+
+-- | List the native objects (.o) of a linkable
linkableObjs :: Linkable -> [FilePath]
-linkableObjs l = [ f | DotO f <- linkableUnlinked l ]
+linkableObjs l = [ f | DotO f <- NE.toList (linkableParts l) ]
+
+-- | List the native libraries (.so/.dll) of a linkable
+linkableLibs :: Linkable -> [LinkablePart]
+linkableLibs l = NE.filter isNativeLib (linkableParts l)
+
+-- | List the paths of the native objects and libraries (.o/.so/.dll)
+linkableFiles :: Linkable -> [FilePath]
+linkableFiles l = mapMaybe linkablePartPath (NE.toList (linkableParts l))
-------------------------------------------
--- | Is this an actual file on disk we can link in somehow?
-isObject :: Unlinked -> Bool
-isObject (DotO _) = True
-isObject (DotA _) = True
-isObject (DotDLL _) = True
-isObject _ = False
+-- | Is the part a native object or library? (.o/.so/.dll)
+isNativeCode :: LinkablePart -> Bool
+isNativeCode = \case
+ DotO {} -> True
+ DotA {} -> True
+ DotDLL {} -> True
+ BCOs {} -> False
+ LazyBCOs{} -> False
+ CoreBindings {} -> False
+
+-- | Is the part a native library? (.so/.dll)
+isNativeLib :: LinkablePart -> Bool
+isNativeLib = \case
+ DotO {} -> False
+ DotA {} -> True
+ DotDLL {} -> True
+ BCOs {} -> False
+ LazyBCOs{} -> False
+ CoreBindings {} -> False
-- | Is this a bytecode linkable with no file on disk?
-isInterpretable :: Unlinked -> Bool
-isInterpretable = not . isObject
-
-nameOfObject_maybe :: Unlinked -> Maybe FilePath
-nameOfObject_maybe (DotO fn) = Just fn
-nameOfObject_maybe (DotA fn) = Just fn
-nameOfObject_maybe (DotDLL fn) = Just fn
-nameOfObject_maybe (CoreBindings {}) = Nothing
-nameOfObject_maybe (LoadedBCOs{}) = Nothing
-nameOfObject_maybe (BCOs {}) = Nothing
-
--- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object
-nameOfObject :: Unlinked -> FilePath
-nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o)
-
--- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable
-byteCodeOfObject :: Unlinked -> [CompiledByteCode]
-byteCodeOfObject (BCOs bc _) = [bc]
-byteCodeOfObject (LoadedBCOs ul) = concatMap byteCodeOfObject ul
-byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
+isInterpretable :: LinkablePart -> Bool
+isInterpretable = not . isNativeCode
+
+-- | Get the FilePath of linkable part (if applicable)
+linkablePartPath :: LinkablePart -> Maybe FilePath
+linkablePartPath = \case
+ DotO fn -> Just fn
+ DotA fn -> Just fn
+ DotDLL fn -> Just fn
+ CoreBindings {} -> Nothing
+ LazyBCOs {} -> Nothing
+ BCOs {} -> Nothing
+
+-- | Retrieve the compiled byte-code from the linkable part.
+--
+-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs.
+--
+-- Warning: this may force byte-code for LazyBCOs.
+linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode]
+linkablePartAllBCOs = \case
+ BCOs bco -> [bco]
+ LazyBCOs ps -> concatMap linkablePartAllBCOs (NE.toList ps)
+ _ -> []
{- **********************************************************************
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -41,6 +41,8 @@ module GHC.Rename.Env (
lookupConstructorInfo, lookupConstructorFields,
lookupGREInfo,
+ irrefutableConLikeRn, irrefutableConLikeTc,
+
lookupGreAvailRn,
-- Rebindable Syntax
@@ -92,6 +94,7 @@ import GHC.Types.TyThing ( tyThingGREInfo )
import GHC.Types.SrcLoc as SrcLoc
import GHC.Utils.Outputable as Outputable
import GHC.Types.Unique.FM
+import GHC.Types.Unique.DSet
import GHC.Types.Unique.Set
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -104,6 +107,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Rename.Unbound
import GHC.Rename.Utils
import GHC.Data.Bag
+import GHC.Types.CompleteMatch
import GHC.Types.PkgQual
import GHC.Types.GREInfo
@@ -2007,8 +2011,9 @@ lookupGREInfo hsc_env nm
mod ImportBySystem
mb_ty_thing <- lookupType hsc_env nm
case mb_ty_thing of
- Nothing -> pprPanic "lookupGREInfo" $
- vcat [ text "lookup failed:" <+> ppr nm ]
+ Nothing -> do
+ pprPanic "lookupGREInfo" $
+ vcat [ text "lookup failed:" <+> ppr nm ]
Just ty_thing -> return $ tyThingGREInfo ty_thing
{-
@@ -2392,3 +2397,67 @@ lookupQualifiedDoName ctxt std_name
= case qualifiedDoModuleName_maybe ctxt of
Nothing -> lookupSyntaxName std_name
Just modName -> lookupNameWithQualifier std_name modName
+
+--------------------------------------------------------------------------------
+-- Helper functions for 'isIrrefutableHsPat'.
+--
+-- (Defined here to avoid import cycles.)
+
+-- | Check irrefutability of a 'ConLike' in a 'ConPat GhcRn'
+-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]).
+irrefutableConLikeRn :: HasDebugCallStack
+ => HscEnv
+ -> GlobalRdrEnv
+ -> CompleteMatches -- ^ in-scope COMPLETE pragmas
+ -> Name -- ^ the 'Name' of the 'ConLike'
+ -> Bool
+irrefutableConLikeRn hsc_env rdr_env comps con_nm
+ | Just gre <- lookupGRE_Name rdr_env con_nm
+ = go $ greInfo gre
+ | otherwise
+ = go $ lookupGREInfo hsc_env con_nm
+ where
+ go ( IAmConLike conInfo ) =
+ case conLikeInfo conInfo of
+ ConIsData { conLikeDataCons = tc_cons } ->
+ length tc_cons == 1
+ ConIsPatSyn ->
+ in_single_complete_match con_nm comps
+ go _ = False
+
+-- | Check irrefutability of the 'ConLike' in a 'ConPat GhcTc'
+-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]),
+-- given all in-scope COMPLETE pragmas ('CompleteMatches' in the typechecker,
+-- 'DsCompleteMatches' in the desugarer).
+irrefutableConLikeTc :: NamedThing con
+ => [CompleteMatchX con]
+ -- ^ in-scope COMPLETE pragmas
+ -> ConLike
+ -> Bool
+irrefutableConLikeTc comps con =
+ case con of
+ RealDataCon dc -> length (tyConDataCons (dataConTyCon dc)) == 1
+ PatSynCon {} -> in_single_complete_match con_nm comps
+ where
+ con_nm = conLikeName con
+
+-- | Internal helper function: check whether a 'ConLike' is the single member
+-- of a COMPLETE set without a result 'TyCon'.
+--
+-- Why 'without a result TyCon'? See Wrinkle [Irrefutability and COMPLETE pragma result TyCons]
+-- in Note [Irrefutability of ConPat].
+in_single_complete_match :: NamedThing con => Name -> [CompleteMatchX con] -> Bool
+in_single_complete_match con_nm = go
+ where
+ go [] = False
+ go (comp:comps)
+ | Nothing <- cmResultTyCon comp
+ -- conservative, as we don't have enough info to compute
+ -- 'completeMatchAppliesAtType'
+ , let comp_nms = mapUniqDSet getName $ cmConLikes comp
+ , comp_nms == mkUniqDSet [con_nm]
+ = True
+ | otherwise
+ = go comps
+
+--------------------------------------------------------------------------------
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -85,6 +85,7 @@ import Control.Arrow (first)
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
+import GHC.Driver.Env (HscEnv)
{- Note [Handling overloaded and rebindable constructs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2211,6 +2212,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
return (stmts2, fvs1 `plusFV` fvs2)
stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
+ hscEnv <- getTopEnv
rdrEnv <- getGlobalRdrEnv
comps <- getCompleteMatchesTcM
pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
@@ -2218,7 +2220,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
let (stmts', fvss) = unzip pairs
let (need_join, tail') =
-- See Note [ApplicativeDo and refutable patterns]
- if any (hasRefutablePattern strict rdrEnv comps) stmts'
+ if any (hasRefutablePattern strict hscEnv rdrEnv comps) stmts'
then (True, tail)
else needJoin monad_names tail Nothing
@@ -2410,13 +2412,14 @@ of a refutable pattern, in order for the types to work out.
-}
hasRefutablePattern :: Bool -- ^ is -XStrict enabled?
+ -> HscEnv
-> GlobalRdrEnv
-> CompleteMatches
-> ApplicativeArg GhcRn -> Bool
-hasRefutablePattern is_strict rdr_env comps arg =
+hasRefutablePattern is_strict hsc_env rdr_env comps arg =
case arg of
ApplicativeArgOne { app_arg_pattern = pat, is_body_stmt = False}
- -> not (isIrrefutableHsPat is_strict (irrefutableConLikeRn rdr_env comps) pat)
+ -> not (isIrrefutableHsPat is_strict (irrefutableConLikeRn hsc_env rdr_env comps) pat)
_ -> False
isLetStmt :: LStmt (GhcPass a) b -> Bool
@@ -2725,11 +2728,12 @@ monadFailOp :: LPat GhcRn
-> RnM (FailOperator GhcRn, FreeVars)
monadFailOp pat ctxt = do
strict <- xoptM LangExt.Strict
+ hscEnv <- getTopEnv
rdrEnv <- getGlobalRdrEnv
comps <- getCompleteMatchesTcM
-- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
-- we should not need to fail.
- if | isIrrefutableHsPat strict (irrefutableConLikeRn rdrEnv comps) pat
+ if | isIrrefutableHsPat strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat
-> return (Nothing, emptyFVs)
-- For non-monadic contexts (e.g. guard patterns, list
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -685,15 +685,11 @@ fromEvalResult (EvalSuccess a) = return a
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
| Just linkable <- homeModInfoByteCode hmi,
- [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable
+ -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
+ [cbc] <- linkableBCOs linkable
= fromMaybe emptyModBreaks (bc_breaks cbc)
| otherwise
= emptyModBreaks -- probably object code
- where
- -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
- onlyBCOs :: Unlinked -> Maybe CompiledByteCode
- onlyBCOs (BCOs cbc _) = Just cbc
- onlyBCOs _ = Nothing
-- | Interpreter uses Profiling way
interpreterProfiled :: Interp -> Bool
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -66,6 +66,7 @@ import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
+import GHC.Types.SptEntry
import Data.List ( genericReplicate, genericLength, intersperse
, partition, scanl', sortBy, zip4, zip6 )
@@ -99,8 +100,9 @@ byteCodeGen :: HscEnv
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
+ -> [SptEntry]
-> IO CompiledByteCode
-byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
= withTiming logger
(text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
(const ()) $ do
@@ -127,10 +129,10 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
"Proto-BCOs" FormatByteCode
(vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
- cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs
- (case modBreaks of
+ let mod_breaks = case modBreaks of
Nothing -> Nothing
- Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
+ Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }
+ cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs mod_breaks spt_entries
-- Squash space leaks in the CompiledByteCode. This is really
-- important, because when loading a set of modules into GHCi
=====================================
compiler/GHC/StgToJS/Linker/Linker.hs
=====================================
@@ -56,7 +56,7 @@ import GHC.SysTools.Cpp
import GHC.SysTools
import GHC.Linker.Static.Utils (exeFileName)
-import GHC.Linker.Types (Unlinked(..), linkableUnlinked)
+import GHC.Linker.Types (linkableObjs)
import GHC.Linker.External
import GHC.StgToJS.Linker.Types
@@ -506,17 +506,13 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache
Nothing -> pprPanic "getDeps: Couldn't find object file for home-module: " (pprModule mod)
Just lnk -> pure lnk
- case linkableUnlinked linkable of
- [DotO p] -> do
- (bis, req_b) <- loadObjBlockInfo [p]
- -- Store new required blocks in IORef
- modifyIORef new_required_blocks_var ((++) req_b)
- case M.lookup mod bis of
- Nothing -> pprPanic "getDeps: Didn't load any block info for home-module: " (pprModule mod)
- Just bi -> pure bi
- ul -> pprPanic "getDeps: Unrecognized linkable for home-module: "
- (vcat [ pprModule mod
- , ppr ul])
+ -- load block infos from the object files
+ (bis, req_b) <- loadObjBlockInfo (linkableObjs linkable)
+ -- Store new required blocks in IORef
+ modifyIORef new_required_blocks_var ((++) req_b)
+ case M.lookup mod bis of
+ Nothing -> pprPanic "getDeps: Didn't load any block info for home-module: " (pprModule mod)
+ Just bi -> pure bi
-- required blocks have no dependencies, so don't have to use them as roots in
-- the traversal
=====================================
compiler/GHC/Tc/Gen/Do.hs
=====================================
@@ -23,6 +23,7 @@ import GHC.Prelude
import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet,
genHsLamDoExp, genHsCaseAltDoExp, genWildPat )
+import GHC.Rename.Env ( irrefutableConLikeRn )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType
@@ -196,9 +197,10 @@ expand_do_stmts _ stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr
mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
mk_failable_expr doFlav pat@(L loc _) expr fail_op =
do { is_strict <- xoptM LangExt.Strict
+ ; hscEnv <- getTopEnv
; rdrEnv <- getGlobalRdrEnv
; comps <- getCompleteMatchesTcM
- ; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn rdrEnv comps) pat
+ ; let irrf_pat = isIrrefutableHsPat is_strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat
; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat
, text "isIrrefutable:" <+> ppr irrf_pat
])
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -55,6 +55,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Utils.Unify
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence
+import GHC.Rename.Env ( irrefutableConLikeTc )
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
=====================================
compiler/GHC/Types/SptEntry.hs
=====================================
@@ -0,0 +1,17 @@
+module GHC.Types.SptEntry
+ ( SptEntry(..)
+ )
+where
+
+import GHC.Types.Var ( Id )
+import GHC.Fingerprint.Type ( Fingerprint )
+import GHC.Utils.Outputable
+
+-- | An entry to be inserted into a module's static pointer table.
+-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
+data SptEntry = SptEntry Id Fingerprint
+
+instance Outputable SptEntry where
+ ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+
+
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -68,6 +68,7 @@ import GHC.Driver.Env
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified System.OsPath as OsPath
+import qualified Data.List.NonEmpty as NE
type FileExt = OsString -- Filename extension
type BaseName = OsPath -- Basename of file
@@ -747,7 +748,7 @@ findObjectLinkableMaybe mod locn
-- Make an object linkable when we know the object file exists, and we know
-- its modification time.
findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable
-findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
+findObjectLinkable mod obj_fn obj_time = return (Linkable obj_time mod (NE.singleton (DotO obj_fn)))
-- We used to look for _stub.o files here, but that was a bug (#706)
-- Now GHC merges the stub.o into the main .o (#3687)
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -35,7 +35,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module
-import GHC.Linker.Types ( Linkable(..), isObjectLinkable )
+import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly )
import GHC.Types.Unique
import GHC.Types.Unique.DFM
@@ -91,17 +91,17 @@ instance Outputable HomeModLinkable where
justBytecode :: Linkable -> HomeModLinkable
justBytecode lm =
- assertPpr (not (isObjectLinkable lm)) (ppr lm)
+ assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
$ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm }
justObjects :: Linkable -> HomeModLinkable
justObjects lm =
- assertPpr (isObjectLinkable lm) (ppr lm)
+ assertPpr (linkableIsNativeCodeOnly lm) (ppr lm)
$ emptyHomeModInfoLinkable { homeMod_object = Just lm }
bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable
bytecodeAndObjects bc o =
- assertPpr (not (isObjectLinkable bc) && isObjectLinkable o) (ppr bc $$ ppr o)
+ assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
(HomeModLinkable (Just bc) (Just o))
=====================================
compiler/GHC/Unit/Module/WholeCoreBindings.hs
=====================================
@@ -24,14 +24,14 @@ The lifecycle of a WholeCoreBindings typically proceeds as follows:
the WholeCoreBindings into a proper Linkable (if we ever do that). The CoreBindings constructor also
allows us to convert the WholeCoreBindings into multiple different linkables if we so desired.
-2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCO linkable. This step combines together
+2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCOs linkable. This step combines together
all the necessary information from a ModIface, ModDetails and WholeCoreBindings in order to
- create the linkable. The linkable created is a "LoadedBCOs" linkable, which
- was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazilly.
+ create the linkable. The linkable created is a "LazyBCOs" linkable, which
+ was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazily.
Using the `BCOs` constructor directly here leads to the bytecode being forced
too eagerly.
-3. Then when bytecode is needed, the LoadedBCOs value is inspected and unpacked and
+3. Then when bytecode is needed, the LazyBCOs value is inspected and unpacked and
the linkable is used as before.
The flag `-fwrite-if-simplified-core` determines whether the extra information is written
=====================================
compiler/ghc.cabal.in
=====================================
@@ -889,6 +889,7 @@ Library
GHC.Types.SourceError
GHC.Types.SourceFile
GHC.Types.SourceText
+ GHC.Types.SptEntry
GHC.Types.SrcLoc
GHC.Types.Target
GHC.Types.Tickish
=====================================
docs/users_guide/phases.rst
=====================================
@@ -523,7 +523,7 @@ defined by your local GHC installation, the following trick is useful:
``arch_HOST_ARCH=1``
This define allows conditional compilation based on the host
architecture, where⟨arch⟩ is the name of the current architecture
- (eg. ``i386``, ``x86_64``, ``powerpc``, ``sparc``, etc.).
+ (eg. ``i386``, ``x86_64``, ``aarch64``, ``powerpc``, ``sparc``, etc.).
``VERSION_pkgname``
This macro is available starting GHC 8.0. It is defined for every
@@ -539,6 +539,16 @@ defined by your local GHC installation, the following trick is useful:
later. It is identical in behavior to the ``MIN_VERSION_pkgname``
macros that Cabal defines.
+SIMD macros
+ .. index::
+ single: SIMD Macros
+
+ These are defined conditionally based on the SIMD
+ flags used for compilation:
+
+ ``__SSE__``, ``__SSE2__``, ``__SSE4_2__``, ``__FMA__``,
+ ``__AVX__``, ``__AVX2__``, ``__AVX512CD__``, ``__AVX512ER__``, ``__AVX512F__``, ``__AVX512PF__``,
+
.. _cpp-string-gaps:
CPP and string gaps
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -143,7 +143,6 @@ GHC.Tc.Zonk.Monad
GHC.Types.Annotations
GHC.Types.Avail
GHC.Types.Basic
-GHC.Types.CompleteMatch
GHC.Types.CostCentre
GHC.Types.CostCentre.State
GHC.Types.Cpr
@@ -173,6 +172,7 @@ GHC.Types.RepType
GHC.Types.SafeHaskell
GHC.Types.SourceFile
GHC.Types.SourceText
+GHC.Types.SptEntry
GHC.Types.SrcLoc
GHC.Types.Tickish
GHC.Types.TyThing
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -192,6 +192,7 @@ GHC.Types.RepType
GHC.Types.SafeHaskell
GHC.Types.SourceFile
GHC.Types.SourceText
+GHC.Types.SptEntry
GHC.Types.SrcLoc
GHC.Types.Target
GHC.Types.Tickish
=====================================
testsuite/tests/pmcheck/should_compile/T25164.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T25164 where
+
+import T25164_aux ( genDoBlock )
+
+$( genDoBlock )
=====================================
testsuite/tests/pmcheck/should_compile/T25164_aux.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module T25164_aux where
+
+-- base
+import Data.Functor.Identity
+
+-- template-haskell
+import Language.Haskell.TH.Syntax
+
+--------------------------------------------------------------------------------
+
+newtype Value a = Value { getValue :: a }
+
+genDoBlock :: Q [ Dec ]
+genDoBlock = do
+ funNm <- newName "fun"
+ argNm <- newName "arg"
+ let doBlock =
+ DoE Nothing
+ [ BindS
+ ( ConP 'Value [ ] [ VarP argNm ] )
+ ( AppE ( ConE 'Identity ) ( AppE ( ConE 'Value ) ( ConE '() ) ) )
+ , NoBindS $
+ AppE ( VarE 'pure ) ( VarE argNm )
+ ]
+
+ {-
+ fun :: Identity ()
+ fun = do { Value arg <- Identity ( Value () )
+ ; pure arg }
+ -}
+
+ pure $
+ [ SigD funNm ( AppT ( ConT ''Identity ) ( ConT ''() ) )
+ , FunD funNm [ Clause [ ] ( NormalB doBlock ) [ ] ]
+ ]
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -92,6 +92,7 @@ test('T20642', normal, compile, [overlapping_incomplete])
test('T21360', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
test('T21360b', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
test('T23520', normal, compile, [overlapping_incomplete+'-Wincomplete-record-updates'])
+test('T25164', [extra_files(['T25164_aux.hs']), req_th], multimod_compile, ['T25164', '-v0'])
# Other tests
test('pmc001', [], compile, [overlapping_incomplete])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/879dd01e3130c8a5975685fef4a5b8e5a66c7470...f1382aa0551e317239c239a5aa061291e6387a6d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/879dd01e3130c8a5975685fef4a5b8e5a66c7470...f1382aa0551e317239c239a5aa061291e6387a6d
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/20240816/85c3fbd0/attachment-0001.html>
More information about the ghc-commits
mailing list