[Git][ghc/ghc][wip/T22725] 9 commits: Remove RTS hack for configuring
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Jan 10 10:12:10 UTC 2023
Simon Peyton Jones pushed to branch wip/T22725 at Glasgow Haskell Compiler / GHC
Commits:
5d65773e by John Ericson at 2023-01-09T20:39:27-05:00
Remove RTS hack for configuring
See the brand new Note [Undefined symbols in the RTS] for additional
details.
- - - - -
e3fff751 by Sebastian Graf at 2023-01-09T20:40:02-05:00
Handle shadowing in DmdAnal (#22718)
Previously, when we had a shadowing situation like
```hs
f x = ... -- demand signature <1L><1L>
main = ... \f -> f 1 ...
```
we'd happily use the shadowed demand signature at the call site inside the
lambda. Of course, that's wrong and solution is simply to remove the demand
signature from the `AnalEnv` when we enter the lambda.
This patch does so for all binding constructs Core.
In #22718 the issue was caused by LetUp not shadowing away the existing demand
signature for the let binder in the let body. The resulting absent error is
fickle to reproduce; hence no reproduction test case. #17478 would help.
Fixes #22718.
It appears that TcPlugin_Rewrite regresses by ~40% on Darwin. It is likely that
DmdAnal was exploiting ill-scoped analysis results.
Metric increase ['bytes allocated'] (test_env=x86_64-darwin-validate):
TcPlugin_Rewrite
- - - - -
d53f6f4d by Oleg Grenrus at 2023-01-09T21:11:02-05:00
Add safe list indexing operator: !?
With Joachim's amendments.
Implements https://github.com/haskell/core-libraries-committee/issues/110
- - - - -
cfaf1ad7 by Nicolas Trangez at 2023-01-09T21:11:03-05:00
rts, tests: limit thread name length to 15 bytes
On Linux, `pthread_setname_np` (or rather, the kernel) only allows for
thread names up to 16 bytes, including the terminating null byte.
This commit adds a note pointing this out in `createOSThread`, and fixes
up two instances where a thread name of more than 15 characters long was
used (in the RTS, and in a test-case).
Fixes: #22366
Fixes: https://gitlab.haskell.org/ghc/ghc/-/issues/22366
See: https://gitlab.haskell.org/ghc/ghc/-/issues/22366#note_460796
- - - - -
64286132 by Matthew Pickering at 2023-01-09T21:11:03-05:00
Store bootstrap_llvm_target and use it to set LlvmTarget in bindists
This mirrors some existing logic for the bootstrap_target which
influences how TargetPlatform is set.
As described on #21970 not storing this led to `LlvmTarget` being set incorrectly
and hence the wrong `--target` flag being passed to the C compiler.
Towards #21970
- - - - -
4724e8d1 by Matthew Pickering at 2023-01-09T21:11:04-05:00
Check for FP_LD_NO_FIXUP_CHAINS in installation configure script
Otherwise, when installing from a bindist the C flag isn't passed to the
C compiler.
This completes the fix for #22429
- - - - -
2e926b88 by Georgi Lyubenov at 2023-01-09T21:11:07-05:00
Fix outdated link to Happy section on sequences
- - - - -
146a1458 by Matthew Pickering at 2023-01-09T21:11:07-05:00
Revert "NCG(x86): Compile add+shift as lea if possible."
This reverts commit 20457d775885d6c3df020d204da9a7acfb3c2e5a.
See #22666 and #21777
- - - - -
8fa3edde by Simon Peyton Jones at 2023-01-10T10:09:54+00:00
Fix void-arg-adding mechanism for worker/wrapper
As #22725 shows, in worker/wrapper we must add the void argument
/last/, not first. See GHC.Core.Opt.WorkWrap.Utils
Note [Worker/wrapper needs to add void arg last].
That led me to to study GHC.Core.Opt.SpecConstr
Note [SpecConstr needs to add void args first] which suggests the
opposite! And indeed I think it's the other way round for SpecConstr
-- or more precisely the void arg must precede the "extra_bndrs".
That led me to some refactoring of GHC.Core.Opt.SpecConstr.calcSpecInfo.
- - - - -
27 changed files:
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Parser.y
- configure.ac
- distrib/configure.ac.in
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Rules/Register.hs
- libraries/base/Data/List.hs
- libraries/base/Data/OldList.hs
- libraries/base/GHC/List.hs
- libraries/base/changelog.md
- m4/ghc_llvm_target.m4
- rts/posix/OSThreads.c
- rts/rts.cabal.in
- rts/sm/NonMoving.c
- − testsuite/tests/codeGen/should_gen_asm/AddMulX86.asm
- − testsuite/tests/codeGen/should_gen_asm/AddMulX86.hs
- testsuite/tests/codeGen/should_gen_asm/all.T
- testsuite/tests/rts/pause-resume/pause_resume.c
- testsuite/tests/simplCore/should_compile/T13143.stderr
- testsuite/tests/simplCore/should_compile/T18328.stderr
- + testsuite/tests/simplCore/should_compile/T22725.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -1048,29 +1048,10 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
--------------------
add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
- -- x + imm
add_code rep x (CmmLit (CmmInt y _))
| is32BitInteger y
, rep /= W8 -- LEA doesn't support byte size (#18614)
= add_int rep x y
- -- x + (y << imm)
- add_code rep x y
- -- Byte size is not supported and 16bit size is slow when computed via LEA
- | rep /= W8 && rep /= W16
- -- 2^3 = 8 is the highest multiplicator supported by LEA.
- , Just (x,y,shift_bits) <- get_shift x y
- = add_shiftL rep x y (fromIntegral shift_bits)
- where
- -- x + (y << imm)
- get_shift x (CmmMachOp (MO_Shl _w) [y, CmmLit (CmmInt shift_bits _)])
- | shift_bits <= 3
- = Just (x, y, shift_bits)
- -- (y << imm) + x
- get_shift (CmmMachOp (MO_Shl _w) [y, CmmLit (CmmInt shift_bits _)]) x
- | shift_bits <= 3
- = Just (x, y, shift_bits)
- get_shift _ _
- = Nothing
add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y
where format = intFormat rep
-- TODO: There are other interesting patterns we want to replace
@@ -1085,7 +1066,6 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y
-- our three-operand add instruction:
- add_int :: (Width -> CmmExpr -> Integer -> NatM Register)
add_int width x y = do
(x_reg, x_code) <- getSomeReg x
let
@@ -1099,22 +1079,6 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
--
return (Any format code)
- -- x + (y << shift_bits) using LEA
- add_shiftL :: (Width -> CmmExpr -> CmmExpr -> Int -> NatM Register)
- add_shiftL width x y shift_bits = do
- (x_reg, x_code) <- getSomeReg x
- (y_reg, y_code) <- getSomeReg y
- let
- format = intFormat width
- imm = ImmInt 0
- code dst
- = (x_code `appOL` y_code) `snocOL`
- LEA format
- (OpAddr (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg (2 ^ shift_bits)) imm))
- (OpReg dst)
- --
- return (Any format code)
-
----------------------
-- See Note [DIV/IDIV for bytes]
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -333,7 +333,8 @@ dmdAnalBindLetUp :: TopLevelFlag
-> WithDmdType (DmdResult CoreBind a)
dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))
where
- WithDmdType body_ty body' = anal_body env
+ WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id)
+ -- See Note [Bringing a new variable into scope]
WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id
-- See Note [Finalising boxity for demand signatures]
@@ -473,7 +474,8 @@ dmdAnal' env dmd (App fun arg)
dmdAnal' env dmd (Lam var body)
| isTyVar var
= let
- WithDmdType body_ty body' = dmdAnal env dmd body
+ WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body
+ -- See Note [Bringing a new variable into scope]
in
WithDmdType body_ty (Lam var body')
@@ -481,7 +483,8 @@ dmdAnal' env dmd (Lam var body)
= let (n, body_dmd) = peelCallDmd dmd
-- body_dmd: a demand to analyze the body
- WithDmdType body_ty body' = dmdAnal env body_dmd body
+ WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body
+ -- See Note [Bringing a new variable into scope]
WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var
new_dmd_type = multDmdType n lam_ty
in
@@ -493,7 +496,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs])
-- can consider its field demands when analysing the scrutinee.
| want_precise_field_dmds alt_con
= let
- WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs
+ rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)
+ -- See Note [Bringing a new variable into scope]
+ WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs
WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs
WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr
!case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd
@@ -629,7 +634,9 @@ dmdAnalSumAlts env dmd case_bndr (alt:alts)
dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt
dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)
- | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs
+ | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)
+ -- See Note [Bringing a new variable into scope]
+ , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs
, WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs
, let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr
-- See Note [Demand on case-alternative binders]
@@ -2399,7 +2406,7 @@ enterDFun bind env
emptySigEnv :: SigEnv
emptySigEnv = emptyVarEnv
--- | Extend an environment with the strictness IDs attached to the id
+-- | Extend an environment with the strictness sigs attached to the Ids
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
extendAnalEnvs top_lvl env vars
= env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
@@ -2418,6 +2425,12 @@ extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag)
lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
+addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv
+addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }
+
+addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv
+addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }
+
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin env = env { ae_virgin = False }
@@ -2456,7 +2469,18 @@ findBndrDmd env dmd_ty id
fam_envs = ae_fam_envs env
-{- Note [Making dictionary parameters strict]
+{- Note [Bringing a new variable into scope]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ f x = blah
+ g = ...(\f. ...f...)...
+
+In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,
+not the top-level `f` (which will be in `ae_sigs`). So it's very important
+to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.
+Otherwise chaos results (#22718).
+
+Note [Making dictionary parameters strict]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries. Why?
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Unit.Module.ModGuts
import GHC.Types.Literal ( litIsLifted )
import GHC.Types.Id
import GHC.Types.Id.Info ( IdDetails(..) )
+import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
@@ -1924,23 +1925,9 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
-- And build the results
; (qvars', pats') <- generaliseDictPats qvars pats
- ; let spec_body_ty = exprType spec_body
- (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)
- = calcSpecInfo fn call_pat extra_bndrs
- -- Annotate the variables with the strictness information from
- -- the function (see Note [Strictness information in worker binders])
- add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1
- (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)
- | add_void_arg
- -- See Note [SpecConstr needs to add void args first]
- , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []
- -- needsVoidWorkerArg: usual w/w hack to avoid generating
- -- a spec_rhs of unlifted type and no args.
- , !spec_arity <- spec_arity1 + 1
- , !spec_join_arity <- fmap (+ 1) spec_join_arity1
- = (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)
- | otherwise
- = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1)
+ ; let spec_body_ty = exprType spec_body
+ (spec_lam_args, spec_call_args, spec_sig, spec_arity, spec_join_arity)
+ = calcSpecInfo fn arg_bndrs call_pat extra_bndrs
spec_id = asWorkerLikeId $
mkLocalId spec_name ManyTy
@@ -1953,11 +1940,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
-- Conditionally use result of new worker-wrapper transform
spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)
- rule_rhs = mkVarApps (Var spec_id) $
- -- This will give us all the arguments we quantify over
- -- in the rule plus the void argument if present
- -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`
- dropTail (length extra_bndrs) spec_call_args
+ rule_rhs = mkVarApps (Var spec_id) spec_call_args
inline_act = idInlineActivation fn
this_mod = sc_module $ sc_opts env
rule = mkRule this_mod True {- Auto -} True {- Local -}
@@ -2023,30 +2006,41 @@ mkSeqs seqees res_ty rhs =
{- Note [SpecConstr needs to add void args first]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a function
+ f :: Bool -> forall t. blah
f start @t = e
We want to specialize for a partially applied call `f True`.
See also Note [SpecConstr call patterns], second Wrinkle.
Naively we would expect to get
+ $sf :: forall t. blah
$sf @t = $se
RULE: f True = $sf
-The specialized function only takes a single type argument
-so we add a void argument to prevent it from turning into
-a thunk. See Note [Protecting the last value argument] for details
-why. Normally we would add the void argument after the
-type argument giving us:
+The specialized function only takes a single type argument so we add a
+void argument to prevent it from turning into a thunk. See Note
+[Protecting the last value argument] for details why. Normally we
+would add the void argument after the type argument giving us:
+
$sf :: forall t. Void# -> bla
$sf @t void = $se
RULE: f True = $sf void# (wrong)
-But if you look closely this wouldn't typecheck!
-If we substitute `f True` with `$sf void#` we expect the type argument to be applied first
-but we apply void# first.
-The easiest fix seems to be just to add the void argument to the front of the arguments.
-Now we get:
+
+But if you look closely this wouldn't typecheck! If we substitute `f
+True` with `$sf void#` we expect the type argument to be applied first
+but we apply void# first. The easiest fix seems to be just to add the
+void argument to the front of the arguments. Now we get:
+
$sf :: Void# -> forall t. bla
$sf void @t = $se
RULE: f True = $sf void#
+
And now we can substitute `f True` with `$sf void#` with everything working out nicely!
+More preisely, we need the void arg to precede the `extra_bndrs` in
+calcSpecInfo, but it's fine it put it before /all/ the arguments.
+
+Note that putting the extra arg first is exactly from what is needed
+in worker/wrapper; see Note [Worker/wrapper needs to add void arg last]
+in GHC.Core.Opt.WorkWrap.Utils.
+
Note [generaliseDictPats]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider these two rules (#21831, item 2):
@@ -2076,35 +2070,49 @@ And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new
-}
calcSpecInfo :: Id -- The original function
+ -> [InVar] -- Lambda binders of original RHS
-> CallPat -- Call pattern
-> [Var] -- Extra bndrs
- -> ( [Var] -- Demand-decorated binders
+ -> ( [Var] -- Demand-decorated lambda binders
+ -- for RHS of specialised function
+ , [Var] -- Args for call site
, DmdSig -- Strictness of specialised thing
, Arity, Maybe JoinArity ) -- Arities of specialised thing
-- Calculate bits of IdInfo for the specialised function
-- See Note [Transfer strictness]
-- See Note [Strictness information in worker binders]
-calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
- | isJoinId fn -- Join points have strictness and arity for LHS only
- = ( bndrs_w_dmds
- , mkClosedDmdSig qvar_dmds div
- , count isId qvars
- , Just (length qvars) )
+calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
+ | needsVoidWorkerArg fn arg_bndrs spec_lam_bndrs_w_dmds
+ = -- Usual w/w hack to avoid generating
+ -- a spec_rhs of unlifted type and no args.
+ -- See Note [SpecConstr needs to add void args first]
+ ( voidArgId : spec_lam_bndrs_w_dmds
+ , voidPrimId : qvars_w_dmds
+ , mkClosedDmdSig (topDmd : all_dmds) div
+ , arity + 1
+ , if isJoinId fn then Just (length qvars + 1) else Nothing )
+
| otherwise
- = ( bndrs_w_dmds
- , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div
- , count isId qvars + count isId extra_bndrs
- , Nothing )
+ = ( spec_lam_bndrs_w_dmds
+ , qvars_w_dmds
+ , mkClosedDmdSig all_dmds div
+ , arity
+ , if isJoinId fn then Just (length qvars) else Nothing )
where
DmdSig (DmdType _ fn_dmds div) = idDmdSig fn
+ arity = count isId qvars + count isId extra_bndrs
+ all_dmds = qvar_dmds ++ extra_dmds
val_pats = filterOut isTypeArg pats -- value args at call sites, used to determine how many demands to drop
-- from the original functions demand and for setting up dmd_env.
qvar_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
extra_dmds = dropList val_pats fn_dmds
- bndrs_w_dmds = set_dmds qvars qvar_dmds
- ++ set_dmds extra_bndrs extra_dmds
+ -- Annotate the variables with the strictness information from
+ -- the function (see Note [Strictness information in worker binders])
+ qvars_w_dmds = set_dmds qvars qvar_dmds
+ extras_w_dmds = set_dmds extra_bndrs extra_dmds
+ spec_lam_bndrs_w_dmds = qvars_w_dmds ++ extras_w_dmds
set_dmds :: [Var] -> [Demand] -> [Var]
set_dmds [] _ = []
@@ -2127,7 +2135,6 @@ calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
= go env ds args
go_one env _ _ = env
-
{-
Note [spec_usg includes rhs_usg]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -9,7 +9,7 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser
module GHC.Core.Opt.WorkWrap.Utils
( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one
- , needsVoidWorkerArg, addVoidWorkerArg
+ , needsVoidWorkerArg
, DataConPatContext(..)
, UnboxingDecision(..), canUnboxArg
, findTypeShape, IsRecDataConResult(..), isRecDataCon
@@ -377,25 +377,34 @@ We use the state-token type which generates no code.
-- Note [Preserving float barriers].
needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool
needsVoidWorkerArg fn_id wrap_args work_args
- = not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]
- || needs_float_barrier -- See Note [Preserving float barriers]
+ = thunk_problem -- See Note [Protecting the last value argument]
+ || needs_float_barrier -- See Note [Preserving float barriers]
where
- no_value_arg = all (not . isId) work_args
+ -- thunk_problem: see Note [Protecting the last value argument]
+ -- For join points we are only worried about (4), not (1-4).
+ -- And (4) can't happen if (null work_args)
+ -- (We could be more clever, by looking at the result type, but
+ -- this approach is simple and conservative.)
+ thunk_problem | isJoinId fn_id = no_value_arg && not (null work_args)
+ | otherwise = no_value_arg
+ no_value_arg = not (any isId work_args)
+
+ -- needs_float_barrier: see Note [Preserving float barriers]
+ needs_float_barrier = wrap_had_barrier && not work_has_barrier
is_float_barrier v = isId v && hasNoOneShotInfo (idOneShotInfo v)
wrap_had_barrier = any is_float_barrier wrap_args
work_has_barrier = any is_float_barrier work_args
- needs_float_barrier = wrap_had_barrier && not work_has_barrier
--- | Inserts a `Void#` arg before the first argument.
---
--- Why as the first argument? See Note [SpecConstr needs to add void args first]
--- in SpecConstr.
+-- | Inserts a `Void#` arg as the last argument.
+-- Why last? See Note [Worker/wrapper needs to add void arg last]
addVoidWorkerArg :: [Var] -> [StrictnessMark]
- -> ([Var], -- Lambda bound args
- [Var], -- Args at call site
- [StrictnessMark]) -- str semantics for the worker args.
+ -> ( [Var] -- Lambda bound args
+ , [Var] -- Args at call site
+ , [StrictnessMark]) -- str semantics for the worker args
addVoidWorkerArg work_args str_marks
- = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:str_marks)
+ = ( work_args ++ [voidArgId]
+ , work_args ++ [voidPrimId]
+ , str_marks ++ [NotMarkedStrict] )
{-
Note [Protecting the last value argument]
@@ -403,8 +412,8 @@ Note [Protecting the last value argument]
If the user writes (\_ -> E), they might be intentionally disallowing
the sharing of E. Since absence analysis and worker-wrapper are keen
to remove such unused arguments, we add in a void argument to prevent
-the function from becoming a thunk. Three reasons why turning a function
-into a thunk might be bad:
+the function from becoming a thunk. Here are several reasons why turning
+a function into a thunk might be bad:
1) It can create a space leak. e.g.
f x = let y () = [1..x]
@@ -423,7 +432,19 @@ into a thunk might be bad:
g = \x. 30#
Removing the \x would leave an unlifted binding.
-NB: none of these apply to a join point.
+4) It can create a worker of ill-kinded type (#22275). Consider
+ f :: forall r (a :: TYPE r). () -> a
+ f x = f x
+ Here `x` is absent, but if we simply drop it we'd end up with
+ $wf :: forall r (a :: TYPE r). a
+ But alas $wf's type is ill-kinded: the kind of (/\r (a::TYPE r).a)
+ is (TYPE r), which mentions the bound variable `r`. See also
+ Note [Worker/wrapper needs to add void arg last]
+
+See also Note [Preserving float barriers]
+
+NB: Of these, only (1-3) don't apply to a join point, which can be
+unlifted even if the RHS is not ok-for-speculation.
Note [Preserving float barriers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -457,7 +478,7 @@ which some are absent or one-shot and the resulting worker arguments:
* \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...
Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#
- * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...
+p * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...
Worker arg `c` is a float barrier.
* \a.\b{Abs}.\c{os}... ==> \a.\c{os}...
Worker arg `a` is a float barrier.
@@ -469,6 +490,28 @@ which some are absent or one-shot and the resulting worker arguments:
Executable examples in T21150.
+Note [Worker/wrapper needs to add void arg last]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider point (4) of Note [Protecting the last value argument]
+
+ f :: forall r (a :: TYPE r). () -> a
+ f x = f x
+
+As pointed out in (4) we need to add a void argument. But if we add
+it /first/ we'd get
+
+ $wf :: Void# -> forall r (a :: TYPE r). a
+ $wf = ...
+
+But alas $wf's type is /still/ still-kinded, just as before in (4).
+Solution is simple: put the void argument /last/:
+
+ $wf :: forall r (a :: TYPE r). Void# -> a
+ $wf = ...
+
+Notice that this is exactly backwards from GHC.Core.Opt.SpecConstr
+Note [SpecConstr needs to add void args first].
+
Note [Join points and beta-redexes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Originally, the worker would invoke the original function by calling it with
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -1337,7 +1337,7 @@ ty_con_app_fun_maybe many_ty_co tc args
| otherwise
= Nothing
-mkFunctionType :: Mult -> Type -> Type -> Type
+mkFunctionType :: HasDebugCallStack => Mult -> Type -> Type -> Type
-- ^ This one works out the FunTyFlag from the argument type
-- See GHC.Types.Var Note [FunTyFlag]
mkFunctionType mult arg_ty res_ty
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -158,7 +158,7 @@ coreAltsType :: [CoreAlt] -> Type
coreAltsType (alt:_) = coreAltType alt
coreAltsType [] = panic "coreAltsType"
-mkLamType :: Var -> Type -> Type
+mkLamType :: HasDebugCallStack => Var -> Type -> Type
-- ^ Makes a @(->)@ type or an implicit forall type, depending
-- on whether it is given a type variable or a term variable.
-- This is used, for example, when producing the type of a lambda.
=====================================
compiler/GHC/Parser.y
=====================================
@@ -540,8 +540,9 @@ importdecls
This might seem like an awfully roundabout way to declare a list; plus, to add
insult to injury you have to reverse the results at the end. The answer is that
left recursion prevents us from running out of stack space when parsing long
-sequences. See: https://www.haskell.org/happy/doc/html/sec-sequences.html for
-more guidance.
+sequences. See:
+https://haskell-happy.readthedocs.io/en/latest/using.html#parsing-sequences
+for more guidance.
By adding/removing branches, you can affect what lists are accepted. Here
are the most common patterns, rewritten as regular expressions for clarity:
=====================================
configure.ac
=====================================
@@ -667,6 +667,8 @@ GHC_LLVM_TARGET_SET_VAR
# we intend to pass trough --targets to llvm as is.
LLVMTarget_CPP=` echo "$LlvmTarget"`
AC_SUBST(LLVMTarget_CPP)
+# The target is substituted into the distrib/configure.ac file
+AC_SUBST(LlvmTarget)
dnl ** See whether cc supports --target=<triple> and set
dnl CONF_CC_OPTS_STAGE[012] accordingly.
=====================================
distrib/configure.ac.in
=====================================
@@ -18,6 +18,8 @@ dnl--------------------------------------------------------------------
dnl Various things from the source distribution configure
bootstrap_target=@TargetPlatform@
+bootstrap_llvm_target=@LlvmTarget@
+
TargetHasRTSLinker=@TargetHasRTSLinker@
AC_SUBST(TargetHasRTSLinker)
@@ -169,6 +171,11 @@ FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAG
# Stage 3 won't be supported by cross-compilation
FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE2],[CONF_GCC_LINKER_OPTS_STAGE2],[CONF_LD_LINKER_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2])
+FP_LD_NO_FIXUP_CHAINS([target], [LDFLAGS])
+FP_LD_NO_FIXUP_CHAINS([build], [CONF_GCC_LINKER_OPTS_STAGE0])
+FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE1])
+FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE2])
+
AC_SUBST(CONF_CC_OPTS_STAGE0)
AC_SUBST(CONF_CC_OPTS_STAGE1)
AC_SUBST(CONF_CC_OPTS_STAGE2)
=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -148,6 +148,8 @@ configurePackage context at Context {..} = do
-- Figure out what hooks we need.
hooks <- case C.buildType (C.flattenPackageDescription gpd) of
C.Configure -> pure C.autoconfUserHooks
+ C.Simple -> pure C.simpleUserHooks
+ C.Make -> fail "build-type: Make is not supported"
-- The 'time' package has a 'C.Custom' Setup.hs, but it's actually
-- 'C.Configure' plus a @./Setup test@ hook. However, Cabal is also
-- 'C.Custom', but doesn't have a configure script.
@@ -155,12 +157,6 @@ configurePackage context at Context {..} = do
configureExists <- doesFileExist $
replaceFileName (pkgCabalFile package) "configure"
pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
- -- Not quite right, but good enough for us:
- _ | package == rts ->
- -- Don't try to do post configuration validation for 'rts'. This
- -- will simply not work, due to the @ld-options@ and @Stg.h at .
- pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () }
- | otherwise -> pure C.simpleUserHooks
-- Compute the list of flags, and the Cabal configuration arguments
flavourArgs <- args <$> flavour
=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -45,6 +45,14 @@ configurePackageRules = do
isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend
when isGmp $
need [buildP -/- "include/ghc-gmp.h"]
+ when (pkg == rts) $ do
+ -- Rts.h is a header listed in the cabal file, and configuring
+ -- therefore wants to ensure that the header "works" post-configure.
+ -- But it (transitively) includes these, so we must ensure they exist
+ -- for that check to work.
+ need [ buildP -/- "include/ghcautoconf.h"
+ , buildP -/- "include/ghcplatform.h"
+ ]
Cabal.configurePackage ctx
root -/- "**/autogen/cabal_macros.h" %> \out -> do
=====================================
libraries/base/Data/List.hs
=====================================
@@ -127,6 +127,7 @@ module Data.List
-- | These functions treat a list @xs@ as a indexed collection,
-- with indices ranging from 0 to @'length' xs - 1 at .
+ , (!?)
, (!!)
, elemIndex
=====================================
libraries/base/Data/OldList.hs
=====================================
@@ -127,6 +127,7 @@ module Data.OldList
-- | These functions treat a list @xs@ as a indexed collection,
-- with indices ranging from 0 to @'length' xs - 1 at .
+ , (!?)
, (!!)
, elemIndex
=====================================
libraries/base/GHC/List.hs
=====================================
@@ -31,7 +31,7 @@ module GHC.List (
-- Other functions
foldl1', concat, concatMap,
map, (++), filter, lookup,
- head, last, tail, init, uncons, (!!),
+ head, last, tail, init, uncons, (!?), (!!),
scanl, scanl1, scanl', scanr, scanr1,
iterate, iterate', repeat, replicate, cycle,
take, drop, splitAt, takeWhile, dropWhile, span, break, reverse,
@@ -49,7 +49,7 @@ import GHC.Num (Num(..))
import GHC.Num.Integer (Integer)
import GHC.Stack.Types (HasCallStack)
-infixl 9 !!
+infixl 9 !?, !!
infix 4 `elem`, `notElem`
-- $setup
@@ -1370,9 +1370,10 @@ concat = foldr (++) []
-- >>> ['a', 'b', 'c'] !! (-1)
-- *** Exception: Prelude.!!: negative index
--
--- WARNING: This function is partial. You can use
--- <https://hackage.haskell.org/package/safe/docs/Safe.html#v:atMay atMay>
--- instead.
+-- WARNING: This function is partial, and should only be used if you are
+-- sure that the indexing will not fail. Otherwise, use 'Data.List.!?'.
+--
+-- WARNING: This function takes linear time in the index.
#if defined(USE_REPORT_PRELUDE)
(!!) :: [a] -> Int -> a
xs !! n | n < 0 = errorWithoutStackTrace "Prelude.!!: negative index"
@@ -1401,6 +1402,30 @@ xs !! n
_ -> r (k-1)) tooLarge xs n
#endif
+-- | List index (subscript) operator, starting from 0. Returns 'Nothing'
+-- if the index is out of bounds
+--
+-- >>> ['a', 'b', 'c'] !? 0
+-- Just 'a'
+-- >>> ['a', 'b', 'c'] !? 2
+-- Just 'c'
+-- >>> ['a', 'b', 'c'] !? 3
+-- Nothing
+-- >>> ['a', 'b', 'c'] !? (-1)
+-- Nothing
+--
+-- This is the total variant of the partial '!!' operator.
+--
+-- WARNING: This function takes linear time in the index.
+(!?) :: [a] -> Int -> Maybe a
+
+{-# INLINABLE (!?) #-}
+xs !? n
+ | n < 0 = Nothing
+ | otherwise = foldr (\x r k -> case k of
+ 0 -> Just x
+ _ -> r (k-1)) (const Nothing) xs n
+
--------------------------------------------------------------
-- The zip family
--------------------------------------------------------------
=====================================
libraries/base/changelog.md
=====================================
@@ -58,6 +58,8 @@
freeing a `Pool`. (#14762) (#18338)
* `Type.Reflection.Unsafe` is now marked as unsafe.
* Add `Data.Typeable.heqT`, a kind-heterogeneous version of `Data.Typeable.eqT`.
+ * Add `Data.List.!?` per
+ [CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110).
## 4.17.0.0 *August 2022*
=====================================
m4/ghc_llvm_target.m4
=====================================
@@ -50,5 +50,10 @@ AC_DEFUN([GHC_LLVM_TARGET], [
# require it.
AC_DEFUN([GHC_LLVM_TARGET_SET_VAR], [
AC_REQUIRE([FPTOOLS_SET_PLATFORMS_VARS])
- GHC_LLVM_TARGET([$target],[$target_cpu],[$target_vendor],[$target_os],[LlvmTarget])
+ if test "$bootstrap_llvm_target" != ""
+ then
+ LlvmTarget=$bootstrap_llvm_target
+ else
+ GHC_LLVM_TARGET([$target],[$target_cpu],[$target_vendor],[$target_os],[LlvmTarget])
+ fi
])
=====================================
rts/posix/OSThreads.c
=====================================
@@ -218,6 +218,12 @@ start_thread (void *param)
return startProc(startParam);
}
+/* Note: at least on Linux/Glibc, `pthread_setname_np` restricts the name of
+ * a thread to 16 bytes, including the terminating null byte. Hence, make sure
+ * to only pass in names of up to 15 characters. Otherwise,
+ * `pthread_setname_np` when called in `start_thread` will fail with `ERANGE`,
+ * which is not checked for, and the thread won't be named at all.
+ */
int
createOSThread (OSThreadId* pId, const char *name,
OSThreadProc *startProc, void *param)
=====================================
rts/rts.cabal.in
=====================================
@@ -275,6 +275,8 @@ library
stg/SMP.h
stg/Ticky.h
stg/Types.h
+
+ -- See Note [Undefined symbols in the RTS]
if flag(64bit)
if flag(leading-underscore)
ld-options:
@@ -474,6 +476,8 @@ library
ld-options: "-Wl,-search_paths_first"
-- See Note [fd_set_overflow]
"-Wl,-U,___darwin_check_fd_set_overflow"
+ -- See Note [Undefined symbols in the RTS]
+ "-Wl,-undefined,dynamic_lookup"
if !arch(x86_64) && !arch(aarch64)
ld-options: -read_only_relocs warning
@@ -714,3 +718,35 @@ library
-- , https://github.com/sitsofe/fio/commit/b6a1e63a1ff607692a3caf3c2db2c3d575ba2320
-- The issue was originally reported in #19950
+
+
+-- Note [Undefined symbols in the RTS]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The RTS is built with a number of `-u` flags. This is to handle cyclic
+-- dependencies between the RTS and other libraries which we normally think of as
+-- downstream from the RTS. "Regular" dependencies from usages in those libraries
+-- to definitions in the RTS are handled normally. "Reverse" dependencies from
+-- usages in the RTS to definitions in those libraries get the `-u` flag in the
+-- RTS.
+--
+-- The symbols are specified literally, but follow C ABI conventions (as all 3 of
+-- C, C--, and Haskell do currently). Thus, we have to be careful to include a
+-- leading underscore or not based on those conventions for the given platform in
+-- question.
+--
+-- A tricky part is that different linkers have different policies regarding
+-- undefined symbols (not defined in the current binary, or found in a shared
+-- library that could be loaded at run time). GNU Binutils' linker is fine with
+-- undefined symbols by default, but Apple's "cctools" linker is not. To appease
+-- that linker we either need to do a blanket `-undefined dynamic_lookup` or
+-- whitelist each such symbol with an additional `-U` (see the man page for more
+-- details).
+--
+-- GHC already does `-undefined dynamic_lookup`, so we just do that for now, but
+-- we might try to get more precise with `-U` in the future.
+--
+-- Note that the RTS also `-u`s some atomics symbols that *are* defined --- and
+-- defined within the RTS! It is not immediately clear why this is needed. This
+-- dates back to c06e3f46d24ef69f3a3d794f5f604cb8c2a40cbc which mentions a build
+-- failure that it was suggested that this fix, but the precise reasoning is not
+-- explained.
=====================================
rts/sm/NonMoving.c
=====================================
@@ -1015,7 +1015,7 @@ void nonmovingCollect(StgWeak **dead_weaks, StgTSO **resurrected_threads)
nonmoving_write_barrier_enabled = true;
debugTrace(DEBUG_nonmoving_gc, "Starting concurrent mark thread");
OSThreadId thread;
- if (createOSThread(&thread, "non-moving mark thread",
+ if (createOSThread(&thread, "nonmoving-mark",
nonmovingConcurrentMark, mark_queue) != 0) {
barf("nonmovingCollect: failed to spawn mark thread: %s", strerror(errno));
}
=====================================
testsuite/tests/codeGen/should_gen_asm/AddMulX86.asm deleted
=====================================
@@ -1,46 +0,0 @@
-.section .text
-.align 8
-.align 8
- .quad 8589934604
- .quad 0
- .long 14
- .long 0
-.globl AddMulX86_f_info
-.type AddMulX86_f_info, @function
-AddMulX86_f_info:
-.LcAx:
- leaq (%r14,%rsi,8),%rbx
- jmp *(%rbp)
- .size AddMulX86_f_info, .-AddMulX86_f_info
-.section .data
-.align 8
-.align 1
-.globl AddMulX86_f_closure
-.type AddMulX86_f_closure, @object
-AddMulX86_f_closure:
- .quad AddMulX86_f_info
-.section .text
-.align 8
-.align 8
- .quad 8589934604
- .quad 0
- .long 14
- .long 0
-.globl AddMulX86_g_info
-.type AddMulX86_g_info, @function
-AddMulX86_g_info:
-.LcAL:
- leaq (%r14,%rsi,8),%rbx
- jmp *(%rbp)
- .size AddMulX86_g_info, .-AddMulX86_g_info
-.section .data
-.align 8
-.align 1
-.globl AddMulX86_g_closure
-.type AddMulX86_g_closure, @object
-AddMulX86_g_closure:
- .quad AddMulX86_g_info
-.section .note.GNU-stack,"", at progbits
-.ident "GHC 9.3.20220228"
-
-
=====================================
testsuite/tests/codeGen/should_gen_asm/AddMulX86.hs deleted
=====================================
@@ -1,12 +0,0 @@
-{-# LANGUAGE MagicHash #-}
-
-module AddMulX86 where
-
-import GHC.Exts
-
-f :: Int# -> Int# -> Int#
-f x y =
- x +# (y *# 8#) -- Should result in a lea instruction, which we grep the assembly output for.
-
-g x y =
- (y *# 8#) +# x -- Should result in a lea instruction, which we grep the assembly output for.
=====================================
testsuite/tests/codeGen/should_gen_asm/all.T
=====================================
@@ -10,4 +10,3 @@ test('memset-unroll', is_amd64_codegen, compile_cmp_asm, ['cmm', ''])
test('bytearray-memset-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True, ''])
test('bytearray-memcpy-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True, ''])
test('T18137', [when(opsys('darwin'), skip), only_ways(llvm_ways)], compile_grep_asm, ['hs', False, '-fllvm -split-sections'])
-test('AddMulX86', is_amd64_codegen, compile_cmp_asm, ['hs', '-dno-typeable-binds'])
=====================================
testsuite/tests/rts/pause-resume/pause_resume.c
=====================================
@@ -187,7 +187,7 @@ void pauseAndResumeViaThread
)
{
OSThreadId threadId;
- createOSThread(&threadId, "Pause and resume thread", &pauseAndResumeViaThread_helper, (void *)count);
+ createOSThread(&threadId, "pause-resume", &pauseAndResumeViaThread_helper, (void *)count);
}
const int TIMEOUT = 1000000; // 1 second
=====================================
testsuite/tests/simplCore/should_compile/T13143.stderr
=====================================
@@ -1,14 +1,14 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 71, types: 41, coercions: 0, joins: 0/0}
+ = {terms: 71, types: 40, coercions: 0, joins: 0/0}
Rec {
-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker]
- :: (# #) -> forall {a}. a
+ :: forall {a}. (# #) -> a
[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []]
-T13143.$wf = \ _ [Occ=Dead] (@a) -> T13143.$wf GHC.Prim.(##) @a
+T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##)
end Rec }
-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
@@ -17,55 +17,60 @@ f [InlPrag=NOINLINE[final]] :: forall a. Int -> a
Arity=1,
Str=<B>b,
Cpr=b,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)
- Tmpl= \ (@a) _ [Occ=Dead] -> T13143.$wf GHC.Prim.(##) @a}]
-f = \ (@a) _ [Occ=Dead] -> T13143.$wf GHC.Prim.(##) @a
+ Tmpl= \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##)}]
+f = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##)
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T13143.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T13143.$trModule3 = GHC.Types.TrNameS T13143.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T13143.$trModule2 = "T13143"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T13143.$trModule1 = GHC.Types.TrNameS T13143.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T13143.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T13143.$trModule
= GHC.Types.Module T13143.$trModule3 T13143.$trModule1
--- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
-lvl :: forall {a}. a
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+lvl :: Int
[GblId, Str=b, Cpr=b]
-lvl = T13143.$wf GHC.Prim.(##)
+lvl = T13143.$wf @Int GHC.Prim.(##)
Rec {
--- RHS size: {terms: 28, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 28, types: 7, coercions: 0, joins: 0/0}
T13143.$wg [InlPrag=[2], Occ=LoopBreaker]
:: Bool -> Bool -> GHC.Prim.Int# -> GHC.Prim.Int#
[GblId[StrictWorker([!, !])],
@@ -94,8 +99,8 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int
Arity=3,
Str=<1L><1L><1!P(L)>,
Cpr=1,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
Tmpl= \ (ds [Occ=Once1] :: Bool)
(ds1 [Occ=Once1] :: Bool)
=====================================
testsuite/tests/simplCore/should_compile/T18328.stderr
=====================================
@@ -1,84 +1,90 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 65, types: 53, coercions: 0, joins: 1/1}
+ = {terms: 69, types: 55, coercions: 0, joins: 1/1}
--- RHS size: {terms: 38, types: 23, coercions: 0, joins: 1/1}
+-- RHS size: {terms: 42, types: 25, coercions: 0, joins: 1/1}
T18328.$wf [InlPrag=[2]]
:: forall {a}. GHC.Prim.Int# -> [a] -> [a] -> [a]
-[GblId,
+[GblId[StrictWorker([~, !])],
Arity=3,
Str=<SL><SL><ML>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [176 0 0] 306 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [176 0 0] 306 0}]
T18328.$wf
- = \ (@a) (ww :: GHC.Prim.Int#) (w :: [a]) (w1 :: [a]) ->
+ = \ (@a) (ww :: GHC.Prim.Int#) (ys :: [a]) (eta :: [a]) ->
join {
- $wj [InlPrag=NOINLINE, Dmd=ML] :: forall {p}. [a]
- [LclId[JoinId(1)]]
- $wj (@p)
+ $wj [InlPrag=NOINLINE, Dmd=MC(1,L)] :: forall {p}. (# #) -> [a]
+ [LclId[JoinId(2)(Nothing)], Arity=1, Str=<A>, Unf=OtherCon []]
+ $wj (@p) _ [Occ=Dead, OS=OneShot]
= case ww of {
- __DEFAULT -> ++ @a w (++ @a w (++ @a w w1));
- 3# -> ++ @a w (++ @a w (++ @a w (++ @a w w1)))
+ __DEFAULT -> ++ @a ys (++ @a ys (++ @a ys eta));
+ 3# -> ++ @a ys (++ @a ys (++ @a ys (++ @a ys eta)))
} } in
case ww of {
- __DEFAULT -> ++ @a w w1;
- 1# -> jump $wj @Integer;
- 2# -> jump $wj @Integer;
- 3# -> jump $wj @Integer
+ __DEFAULT -> ++ @a ys eta;
+ 1# -> jump $wj @Integer GHC.Prim.(##);
+ 2# -> jump $wj @Integer GHC.Prim.(##);
+ 3# -> jump $wj @Integer GHC.Prim.(##)
}
-- RHS size: {terms: 11, types: 9, coercions: 0, joins: 0/0}
f [InlPrag=[2]] :: forall a. Int -> [a] -> [a] -> [a]
[GblId,
Arity=3,
- Str=<1P(SL)><SL><ML>,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Str=<1!P(SL)><SL><ML>,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
Tmpl= \ (@a)
- (w [Occ=Once1!] :: Int)
- (w1 [Occ=Once1] :: [a])
- (w2 [Occ=Once1] :: [a]) ->
- case w of { GHC.Types.I# ww [Occ=Once1] ->
- T18328.$wf @a ww w1 w2
+ (x [Occ=Once1!] :: Int)
+ (ys [Occ=Once1] :: [a])
+ (eta [Occ=Once1] :: [a]) ->
+ case x of { GHC.Types.I# ww [Occ=Once1] ->
+ T18328.$wf @a ww ys eta
}}]
-f = \ (@a) (w :: Int) (w1 :: [a]) (w2 :: [a]) ->
- case w of { GHC.Types.I# ww -> T18328.$wf @a ww w1 w2 }
+f = \ (@a) (x :: Int) (ys :: [a]) (eta :: [a]) ->
+ case x of { GHC.Types.I# ww -> T18328.$wf @a ww ys eta }
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T18328.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18328.$trModule3 = GHC.Types.TrNameS T18328.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T18328.$trModule2 = "T18328"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18328.$trModule1 = GHC.Types.TrNameS T18328.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T18328.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T18328.$trModule
= GHC.Types.Module T18328.$trModule3 T18328.$trModule1
=====================================
testsuite/tests/simplCore/should_compile/T22725.hs
=====================================
@@ -0,0 +1,6 @@
+module M where
+
+import GHC.Exts (TYPE)
+
+f :: forall r (a :: TYPE r). () -> a
+f x = f x
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -462,3 +462,4 @@ test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings
test('T22459', normal, compile, [''])
test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
test('T22662', normal, compile, [''])
+test('T22725', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c66b095151d28feded5e0d595842fc8bb82941c...8fa3eddea469c7c44ce15a8304f12c566ac946a2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2c66b095151d28feded5e0d595842fc8bb82941c...8fa3eddea469c7c44ce15a8304f12c566ac946a2
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/20230110/a280d8f9/attachment-0001.html>
More information about the ghc-commits
mailing list