[Git][ghc/ghc][wip/fix-bytecode-hpc] 4 commits: Add test for #25185
Cheng Shao (@TerrorJack)
gitlab at gitlab.haskell.org
Thu Nov 21 02:36:59 UTC 2024
Cheng Shao pushed to branch wip/fix-bytecode-hpc at Glasgow Haskell Compiler / GHC
Commits:
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
- - - - -
fdc0d695 by Cheng Shao at 2024-11-21T02:35:51+00:00
driver: fix hpc undefined symbol issue in TH with -fprefer-byte-code
This commit fixes an undefined symbol error in RTS linker when
attempting to compile home modules with -fhpc and
-fbyte-code-and-object-code/-fprefer-byte-code, see #25510 for
detailed description and analysis of the bug.
Also adds T25510/T25510c regression tests to test make mode/oneshot
mode of the bug.
- - - - -
26 changed files:
- compiler/GHC/CmmToAsm/Format.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/Driver/Config/StgToCmm.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/HsToCore/Coverage.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Config.hs
- compiler/GHC/StgToCmm/Hpc.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Module/ModGuts.hs
- + testsuite/tests/bytecode/T25510/Makefile
- + testsuite/tests/bytecode/T25510/T25510A.hs
- + testsuite/tests/bytecode/T25510/T25510B.hs
- + testsuite/tests/bytecode/T25510/all.T
- 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
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
Changes:
=====================================
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/Config/StgToCmm.hs
=====================================
@@ -38,7 +38,6 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
-- flags
, stgToCmmLoopification = gopt Opt_Loopification dflags
, stgToCmmAlignCheck = gopt Opt_AlignmentSanitisation dflags
- , stgToCmmOptHpc = gopt Opt_Hpc dflags
, stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags
, stgToCmmSCCProfiling = sccProfilingEnabled dflags
, stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -48,7 +48,6 @@ import GHC.Types.Basic
import GHC.Types.CostCentre
import GHC.Types.IPE
import GHC.Types.Meta
-import GHC.Types.HpcInfo
import GHC.Unit.Module
import GHC.Unit.Module.ModSummary
@@ -149,7 +148,7 @@ data Hooks = Hooks
-> IO (Either Type (HValue, [Linkable], PkgsLoaded))))
, createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))
, stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs
- -> [CgStgTopBinding] -> HpcInfo -> CgStream CmmGroup ModuleLFInfos))
+ -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos))
, cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a
-> IO (CgStream RawCmmGroup a)))
}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -248,7 +248,6 @@ import GHC.Types.Name.Cache ( initNameCache )
import GHC.Types.Name.Reader
import GHC.Types.Name.Ppr
import GHC.Types.TyThing
-import GHC.Types.HpcInfo
import GHC.Types.Unique.Supply (uniqFromTag)
import GHC.Types.Unique.Set
@@ -1980,7 +1979,6 @@ hscGenHardCode hsc_env cgguts location output_filename = do
cg_foreign = foreign_stubs0,
cg_foreign_files = foreign_files,
cg_dep_pkgs = dependencies,
- cg_hpc_info = hpc_info,
cg_spt_entries = spt_entries,
cg_binds = late_binds,
cg_ccs = late_local_ccs
@@ -2084,7 +2082,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
cmms <- {-# SCC "StgToCmm" #-}
doCodeGen hsc_env this_mod denv data_tycons
cost_centre_info
- stg_binds hpc_info
+ stg_binds
------------------ Code output -----------------------
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
@@ -2291,13 +2289,12 @@ This reduces residency towards the end of the CodeGen phase significantly
doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
- -> HpcInfo
-> IO (CgStream CmmGroupSRTs CmmCgInfos)
-- Note we produce a 'Stream' of CmmGroups, so that the
-- backend can be run incrementally. Otherwise it generates all
-- the C-- up front, which has a significant space cost.
doCodeGen hsc_env this_mod denv data_tycons
- cost_centre_info stg_binds_w_fvs hpc_info = do
+ cost_centre_info stg_binds_w_fvs = do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
@@ -2308,14 +2305,14 @@ doCodeGen hsc_env this_mod denv data_tycons
putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
(pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)
- let stg_to_cmm dflags mod a b c d e = case stgToCmmHook hooks of
- Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d e
- Just h -> (,emptyDetUFM) <$> h (initStgToCmmConfig dflags mod) a b c d e
+ let stg_to_cmm dflags mod a b c d = case stgToCmmHook hooks of
+ Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d
+ Just h -> (,emptyDetUFM) <$> h (initStgToCmmConfig dflags mod) a b c d
let cmm_stream :: CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
-- See Note [Forcing of stg_binds]
cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
- stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
+ stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs
-- codegen consumes a stream of CmmGroup, and produces a new
-- stream of CmmGroup (not necessarily synchronised: one
=====================================
compiler/GHC/HsToCore/Coverage.hs
=====================================
@@ -117,7 +117,7 @@ hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
= initializerCStub platform fn_name decls body
where
fn_name = mkInitializerStubLabel this_mod (fsLit "hpc")
- decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi
+ decls = text "StgWord64 " <> tickboxes <> brackets (int tickCount) <> semi
body = text "hs_hpc_module" <>
parens (hcat (punctuate comma [
doubleQuotes full_name_str,
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -407,7 +407,6 @@ tidyProgram opts (ModGuts { mg_module = mod
, mg_deps = deps
, mg_foreign = foreign_stubs
, mg_foreign_files = foreign_files
- , mg_hpc_info = hpc_info
, mg_modBreaks = modBreaks
, mg_boot_exports = boot_exports
}) = do
@@ -480,7 +479,6 @@ tidyProgram opts (ModGuts { mg_module = mod
, cg_foreign = all_foreign_stubs
, cg_foreign_files = foreign_files
, cg_dep_pkgs = dep_direct_pkgs deps
- , cg_hpc_info = hpc_info
, cg_modBreaks = modBreaks
, cg_spt_entries = spt_entries
}
@@ -1567,4 +1565,3 @@ mustExposeTyCon no_trim_types exports tc
exported_con con = any (`elemNameSet` exports)
(dataConName con : dataConFieldLabels con)
-}
-
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -24,7 +24,6 @@ import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Config
-import GHC.StgToCmm.Hpc
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Types (ModuleLFInfos)
import GHC.StgToCmm.CgUtils (CgStream)
@@ -38,7 +37,6 @@ import GHC.Stg.Syntax
import GHC.Types.CostCentre
import GHC.Types.IPE
-import GHC.Types.HpcInfo
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.RepType
@@ -52,7 +50,6 @@ import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Multiplicity
-import GHC.Unit.Module
import GHC.Utils.Error
import GHC.Utils.Outputable
@@ -77,13 +74,12 @@ codeGen :: Logger
-> [TyCon]
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [CgStgTopBinding] -- Bindings to convert
- -> HpcInfo
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM) -- See Note [Deterministic Uniques in the CG] on CgStream
-- Output as a stream, so codegen can
-- be interleaved with output
codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) data_tycons
- cost_centre_info stg_binds hpc_info
+ cost_centre_info stg_binds
= do { -- cg: run the code generator, and yield the resulting CmmGroup
-- Using an IORef to store the state is a bit crude, but otherwise
-- we would need to add a state monad layer which regresses
@@ -118,7 +114,7 @@ codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) data_tycons
yield cmm
return a
- ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info)
+ ; cg (mkModuleInit cost_centre_info)
; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds
-- Put datatype_stuff after code_stuff, because the
@@ -281,13 +277,10 @@ cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body _typ)
mkModuleInit
:: CollectedCCs -- cost centre info
- -> Module
- -> HpcInfo
-> FCode ()
-mkModuleInit cost_centre_info this_mod hpc_info
- = do { initHpc this_mod hpc_info
- ; initCostCentres cost_centre_info
+mkModuleInit cost_centre_info
+ = do { initCostCentres cost_centre_info
}
=====================================
compiler/GHC/StgToCmm/Config.hs
=====================================
@@ -46,7 +46,6 @@ data StgToCmmConfig = StgToCmmConfig
---------------------------------- Flags --------------------------------------
, stgToCmmLoopification :: !Bool -- ^ Loopification enabled (cf @-floopification@)
, stgToCmmAlignCheck :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@)
- , stgToCmmOptHpc :: !Bool -- ^ perform code generation for code coverage
, stgToCmmFastPAPCalls :: !Bool -- ^
, stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled
, stgToCmmEagerBlackHole :: !Bool -- ^
=====================================
compiler/GHC/StgToCmm/Hpc.hs
=====================================
@@ -6,13 +6,11 @@
--
-----------------------------------------------------------------------------
-module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where
+module GHC.StgToCmm.Hpc ( mkTickBox ) where
import GHC.Prelude
import GHC.Platform
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
import GHC.Cmm.Graph
import GHC.Cmm.Expr
@@ -20,9 +18,7 @@ import GHC.Cmm.CLabel
import GHC.Cmm.Utils
import GHC.Unit.Module
-import GHC.Types.HpcInfo
-import Control.Monad
mkTickBox :: Platform -> Module -> Int -> CmmAGraph
mkTickBox platform mod n
@@ -34,16 +30,3 @@ mkTickBox platform mod n
tick_box = cmmIndex platform W64
(CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
n
-
--- | Emit top-level tables for HPC and return code to initialise
-initHpc :: Module -> HpcInfo -> FCode ()
-initHpc _ NoHpcInfo{}
- = return ()
-initHpc this_mod (HpcInfo tickCount _hashNo)
- = do do_hpc <- stgToCmmOptHpc <$> getStgToCmmConfig
- when do_hpc $
- emitDataLits (mkHpcTicksLabel this_mod)
- [ CmmInt 0 W64
- | _ <- take tickCount [0 :: Int ..]
- ]
-
=====================================
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/Module/ModGuts.hs
=====================================
@@ -141,7 +141,6 @@ data CgGuts
cg_foreign_files :: ![(ForeignSrcLang, FilePath)],
cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to
-- generate #includes for C code gen
- cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints
cg_spt_entries :: [SptEntry]
-- ^ Static pointer table entries for static forms defined in
=====================================
testsuite/tests/bytecode/T25510/Makefile
=====================================
@@ -0,0 +1,7 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T25510c:
+ '$(TEST_HC)' $(ghcThWayFlags) -fhpc -fbyte-code-and-object-code -c T25510A.hs
+ '$(TEST_HC)' $(ghcThWayFlags) -fhpc -fprefer-byte-code -c T25510B.hs
=====================================
testsuite/tests/bytecode/T25510/T25510A.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module T25510A where
+
+import Language.Haskell.TH
+
+a :: Q Exp
+a = [| 114514 |]
=====================================
testsuite/tests/bytecode/T25510/T25510B.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module T25510B where
+
+import T25510A
+
+b = $(a)
=====================================
testsuite/tests/bytecode/T25510/all.T
=====================================
@@ -0,0 +1,10 @@
+test('T25510', [
+ req_th,
+ js_skip
+], multimod_compile, ['T25510B', '-fhpc -fbyte-code-and-object-code -fprefer-byte-code -v0'])
+
+test('T25510c', [
+ extra_files(['T25510A.hs', 'T25510B.hs']),
+ req_th,
+ js_skip
+], makefile_test, ['T25510c ghcThWayFlags=' + config.ghc_th_way_flags])
=====================================
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, [''])
=====================================
testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
=====================================
@@ -34,7 +34,6 @@ import GHC.Stg.FVs
import GHC.Stg.Syntax
import GHC.StgToCmm (codeGen)
import GHC.Types.CostCentre (emptyCollectedCCs)
-import GHC.Types.HpcInfo (emptyHpcInfo)
import GHC.Types.IPE (emptyInfoTableProvMap)
import GHC.Types.Unique.DSM
import GHC.Unit.Home
@@ -70,14 +69,12 @@ cmmOfSummary summ = do
tycons = []
ccs = emptyCollectedCCs
stg' = fmap fst (depSortWithAnnotStgPgm (ms_mod summ) stg)
- hpcinfo = emptyHpcInfo False
tmpfs = hsc_tmpfs env
- stg_to_cmm dflags mod = codeGen logger tmpfs (initStgToCmmConfig dflags mod)
(groups, _infos) <-
liftIO $ fmap fst $
runUDSMT (initDUniqSupply 't' 0) $
collectAll $
- stg_to_cmm dflags (ms_mod summ) infotable tycons ccs stg' hpcinfo
+ codeGen logger tmpfs (initStgToCmmConfig dflags (ms_mod summ)) infotable tycons ccs stg'
return groups
frontend :: DynFlags -> HscEnv -> ModSummary -> IO ModGuts
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/07a3e51fa2394f89266d4cf8e86762d88a0568a7...fdc0d695a80079aa239674f58e1680bfb01f5003
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/07a3e51fa2394f89266d4cf8e86762d88a0568a7...fdc0d695a80079aa239674f58e1680bfb01f5003
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/20241120/d451a97f/attachment-0001.html>
More information about the ghc-commits
mailing list