[Git][ghc/ghc][wip/T22725] 3 commits: Disable split sections on aarch64-deb10 build
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Jan 9 21:10:25 UTC 2023
Simon Peyton Jones pushed to branch wip/T22725 at Glasgow Haskell Compiler / GHC
Commits:
365b3045 by Matthew Pickering at 2023-01-09T02:36:20-05:00
Disable split sections on aarch64-deb10 build
See #22722
Failure on this job:
https://gitlab.haskell.org/ghc/ghc/-/jobs/1287852
```
Unexpected failures:
/builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T10828.run T10828 [exit code non-0] (ext-interp)
/builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T13123.run T13123 [exit code non-0] (ext-interp)
/builds/ghc/ghc/tmp/ghctest-s3d8g1hj/test spaces/testsuite/tests/th/T20590.run T20590 [exit code non-0] (ext-interp)
Appending 232 stats to file: /builds/ghc/ghc/performance-metrics.tsv
```
```
Compile failed (exit code 1) errors were:
data family D_0 a_1 :: * -> *
data instance D_0 GHC.Types.Int GHC.Types.Bool :: * where
DInt_2 :: D_0 GHC.Types.Int GHC.Types.Bool
data E_3 where MkE_4 :: a_5 -> E_3
data Foo_6 a_7 b_8 where
MkFoo_9, MkFoo'_10 :: a_11 -> Foo_6 a_11 b_12
newtype Bar_13 :: * -> GHC.Types.Bool -> * where
MkBar_14 :: a_15 -> Bar_13 a_15 b_16
data T10828.T (a_0 :: *) where
T10828.MkT :: forall (a_1 :: *) . a_1 -> a_1 -> T10828.T a_1
T10828.MkC :: forall (a_2 :: *) (b_3 :: *) . (GHC.Types.~) a_2
GHC.Types.Int => {T10828.foo :: a_2,
T10828.bar :: b_3} -> T10828.T GHC.Types.Int
T10828.hs:1:1: error: [GHC-87897]
Exception when trying to run compile-time code:
ghc-iserv terminated (-4)
Code: (do TyConI dec <- runQ $ reify (mkName "T")
runIO $ putStrLn (pprint dec) >> hFlush stdout
d <- runQ
$ [d| data T' a :: Type
where
MkT' :: a -> a -> T' a
MkC' :: forall a b. (a ~ Int) => {foo :: a, bar :: b} -> T' Int |]
runIO $ putStrLn (pprint d) >> hFlush stdout
....)
*** unexpected failure for T10828(ext-interp)
=====> 7000 of 9215 [0, 1, 0]
=====> 7000 of 9215 [0, 1, 0]
=====> 7000 of 9215 [0, 1, 0]
=====> 7000 of 9215 [0, 1, 0]
Compile failed (exit code 1) errors were:
T13123.hs:1:1: error: [GHC-87897]
Exception when trying to run compile-time code:
ghc-iserv terminated (-4)
Code: ([d| data GADT
where MkGADT :: forall k proxy (a :: k). proxy a -> GADT |])
*** unexpected failure for T13123(ext-interp)
=====> 7100 of 9215 [0, 2, 0]
=====> 7100 of 9215 [0, 2, 0]
=====> 7200 of 9215 [0, 2, 0]
Compile failed (exit code 1) errors were:
T20590.hs:1:1: error: [GHC-87897]
Exception when trying to run compile-time code:
ghc-iserv terminated (-4)
Code: ([d| data T where MkT :: forall a. a -> T |])
*** unexpected failure for T20590(ext-interp)
```
Looks fairly worrying to me.
- - - - -
965a2735 by Alan Zimmerman at 2023-01-09T02:36:20-05:00
EPA: exact print HsDocTy
To match ghc-exactprint
https://github.com/alanz/ghc-exactprint/pull/121
- - - - -
275cab6c by Simon Peyton Jones at 2023-01-09T21:10:48+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.
- - - - -
15 changed files:
- .gitlab/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- + testsuite/tests/printer/HsDocTy.hs
- testsuite/tests/printer/Makefile
- testsuite/tests/printer/all.T
- 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
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
.gitlab/gen_ci.hs
=====================================
@@ -813,7 +813,7 @@ jobs = Map.fromList $ concatMap flattenJobGroup $
, standardBuilds Amd64 Darwin
, allowFailureGroup (addValidateRule FreeBSDLabel (standardBuilds Amd64 FreeBSD13))
, standardBuilds AArch64 Darwin
- , standardBuilds AArch64 (Linux Debian10)
+ , standardBuildsWithConfig AArch64 (Linux Debian10) (splitSectionsBroken vanilla)
, disableValidate (standardBuildsWithConfig AArch64 (Linux Debian10) llvm)
, standardBuildsWithConfig I386 (Linux Debian9) (splitSectionsBroken vanilla)
, standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken static)
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1926,7 +1926,7 @@
"XZ_OPT": "-9"
}
},
- "release-aarch64-linux-deb10-release": {
+ "release-aarch64-linux-deb10-release+llvm": {
"after_script": [
".gitlab/ci.sh save_cache",
".gitlab/ci.sh clean",
@@ -1936,7 +1936,7 @@
"artifacts": {
"expire_in": "1 year",
"paths": [
- "ghc-aarch64-linux-deb10-release.tar.xz",
+ "ghc-aarch64-linux-deb10-release+llvm.tar.xz",
"junit.xml"
],
"reports": {
@@ -1978,15 +1978,15 @@
],
"variables": {
"BIGNUM_BACKEND": "gmp",
- "BIN_DIST_NAME": "ghc-aarch64-linux-deb10-release",
- "BUILD_FLAVOUR": "release",
+ "BIN_DIST_NAME": "ghc-aarch64-linux-deb10-release+llvm",
+ "BUILD_FLAVOUR": "release+llvm",
"CONFIGURE_ARGS": "",
"IGNORE_PERF_FAILURES": "all",
- "TEST_ENV": "aarch64-linux-deb10-release",
+ "TEST_ENV": "aarch64-linux-deb10-release+llvm",
"XZ_OPT": "-9"
}
},
- "release-aarch64-linux-deb10-release+llvm": {
+ "release-aarch64-linux-deb10-release+no_split_sections": {
"after_script": [
".gitlab/ci.sh save_cache",
".gitlab/ci.sh clean",
@@ -1996,7 +1996,7 @@
"artifacts": {
"expire_in": "1 year",
"paths": [
- "ghc-aarch64-linux-deb10-release+llvm.tar.xz",
+ "ghc-aarch64-linux-deb10-release+no_split_sections.tar.xz",
"junit.xml"
],
"reports": {
@@ -2038,11 +2038,11 @@
],
"variables": {
"BIGNUM_BACKEND": "gmp",
- "BIN_DIST_NAME": "ghc-aarch64-linux-deb10-release+llvm",
- "BUILD_FLAVOUR": "release+llvm",
+ "BIN_DIST_NAME": "ghc-aarch64-linux-deb10-release+no_split_sections",
+ "BUILD_FLAVOUR": "release+no_split_sections",
"CONFIGURE_ARGS": "",
"IGNORE_PERF_FAILURES": "all",
- "TEST_ENV": "aarch64-linux-deb10-release+llvm",
+ "TEST_ENV": "aarch64-linux-deb10-release+no_split_sections",
"XZ_OPT": "-9"
}
},
=====================================
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.
=====================================
testsuite/tests/printer/HsDocTy.hs
=====================================
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -haddock #-}
+module HsDocTy where
+
+class C1 a where
+ f1 :: a -> Int
+ -- ^ comment on Int
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -769,3 +769,9 @@ Test21355:
Test21805:
$(CHECK_PPR) $(LIBDIR) Test21805.hs
$(CHECK_EXACT) $(LIBDIR) Test21805.hs
+
+.PHONY: HsDocTy
+HsDocTy:
+ # See comment on pprWithDocString, this won't round trip
+ # $(CHECK_PPR) $(LIBDIR) HsDocTy.hs
+ $(CHECK_EXACT) $(LIBDIR) HsDocTy.hs
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -185,4 +185,5 @@ test('Test21805', [ignore_stderr, req_ppr_deps], makefile_test, ['Test21805'])
test('T22488', normal, ghci_script, ['T22488.script'])
test('T22488_docHead', normal, compile_and_run, ['-package ghc'])
test('T20531', extra_files(['T20531_defs.hs']), ghci_script, ['T20531.script'])
-test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_red_ticks.script'])
\ No newline at end of file
+test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_red_ticks.script'])
+test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
\ No newline at end of file
=====================================
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'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3898,6 +3898,10 @@ instance ExactPrint (HsType GhcPs) where
exact (HsSpliceTy a splice) = do
splice' <- markAnnotated splice
return (HsSpliceTy a splice')
+ exact (HsDocTy an ty doc) = do
+ ty' <- markAnnotated ty
+ doc' <- markAnnotated doc
+ return (HsDocTy an ty' doc')
exact (HsBangTy an (HsSrcBang mt up str) ty) = do
an0 <-
case mt of
=====================================
utils/check-exact/Main.hs
=====================================
@@ -59,7 +59,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" (Just changeAddDecl3)
-- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" (Just changeLocalDecls)
- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2)
+ -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" (Just changeWhereIn3a)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3b.hs" (Just changeWhereIn3b)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl1.hs" (Just addLocaLDecl1)
@@ -203,6 +203,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
-- "../../testsuite/tests/printer/PprArrowLambdaCase.hs" Nothing
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
+ "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- cloneT does not need a test, function can be retired
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7797c1150f6cf620b731e29076bad41cbdf5f18c...275cab6c2de7c082a7c17f32b64a6edee41a0f4e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7797c1150f6cf620b731e29076bad41cbdf5f18c...275cab6c2de7c082a7c17f32b64a6edee41a0f4e
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/20230109/cea82c8b/attachment-0001.html>
More information about the ghc-commits
mailing list