[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Teach tag-inference about SeqOp/seq#
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Oct 30 15:47:10 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9bc5cb92 by Matthew Craven at 2023-10-28T07:06:17-04:00
Teach tag-inference about SeqOp/seq#
Fixes the STG/tag-inference analogue of #15226.
Co-Authored-By: Simon Peyton Jones <simon.peytonjones at gmail.com>
- - - - -
34f06334 by Moritz Angermann at 2023-10-28T07:06:53-04:00
[PEi386] Mask SYM_TYPE_DUP_DISCARD in makeSymbolExtra
48e391952c17ff7eab10b0b1456e3f2a2af28a9b
introduced `SYM_TYPE_DUP_DISCARD` to the bitfield.
The linker however, failed to mask the `SYM_TYPE_DUP_DISCARD` value.
Thus `== SYM_TYPE_CODE` comparisons easily failed. This lead to us
relocating DATA lookups (GOT) into E8 (call) and E9 (jump) instructions.
- - - - -
5b51b2a2 by Mario Blažević at 2023-10-28T07:07:33-04:00
Fix and test for issue #24111, TH.Ppr output of pattern synonyms
- - - - -
201a9f92 by Alan Zimmerman at 2023-10-30T11:46:31-04:00
EPA: print doc comments as normal comments
And ignore the ones allocated in haddock processing.
It does not guarantee that every original haddock-like comment appears
in the output, as it discards ones that have no legal attachment point.
closes #23459
- - - - -
67c76540 by Simon Peyton Jones at 2023-10-30T11:46:31-04:00
Fix non-termination bug in equality solver
constraint left-to-right then right to left, forever.
Easily fixed.
- - - - -
78060ce1 by Sebastian Graf at 2023-10-30T11:46:31-04:00
ghc-toolchain: build with `-package-env=-` (#24131)
Otherwise globally installed libraries (via `cabal install --lib`)
break the build.
Fixes #24131.
- - - - -
26 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Hs/DocString.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Stg/InferTags/TagSig.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Tc/Solver/Equality.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- m4/ghc_toolchain.m4
- rts/linker/PEi386.c
- + testsuite/tests/indexed-types/should_compile/T24134.hs
- testsuite/tests/indexed-types/should_compile/all.T
- + testsuite/tests/simplStg/should_compile/T15226b.hs
- + testsuite/tests/simplStg/should_compile/T15226b.stderr
- testsuite/tests/simplStg/should_compile/all.T
- + testsuite/tests/simplStg/should_compile/inferTags003.hs
- + testsuite/tests/simplStg/should_compile/inferTags003.stderr
- + testsuite/tests/simplStg/should_compile/inferTags004.hs
- + testsuite/tests/simplStg/should_compile/inferTags004.stderr
- + testsuite/tests/th/T24111.hs
- + testsuite/tests/th/T24111.stdout
- testsuite/tests/th/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Preprocess.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3640,7 +3640,7 @@ primop SparkOp "spark#" GenPrimOp
with effect = ReadWriteEffect
code_size = { primOpCodeSizeForeignCall }
--- See Note [seq# magic] in GHC.Core.Op.ConstantFold
+-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
primop SeqOp "seq#" GenPrimOp
a -> State# s -> (# State# s, a #)
with
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -2108,6 +2108,9 @@ Implementing seq#. The compiler has magic for SeqOp in
- Simplify.addEvals records evaluated-ness for the result; see
Note [Adding evaluatedness info to pattern-bound variables]
in GHC.Core.Opt.Simplify.Iteration
+
+- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a
+ properly-tagged pointer inside of its unboxed-tuple result.
-}
seqRule :: RuleM CoreExpr
=====================================
compiler/GHC/Hs/DocString.hs
=====================================
@@ -21,6 +21,7 @@ module GHC.Hs.DocString
, renderHsDocStrings
, exactPrintHsDocString
, pprWithDocString
+ , printDecorator
) where
import GHC.Prelude
=====================================
compiler/GHC/Stg/InferTags.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Types.Basic ( CbvMark (..) )
import GHC.Types.Unique.Supply (mkSplitUniqSupply)
import GHC.Types.RepType (dataConRuntimeRepStrictness)
import GHC.Core (AltCon(..))
+import GHC.Builtin.PrimOps ( PrimOp(..) )
import Data.List (mapAccumL)
import GHC.Utils.Outputable
import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )
@@ -319,14 +320,6 @@ inferTagExpr env (StgApp fun args)
| otherwise
= --pprTrace "inferAppUnknown" (ppr fun) $
TagDunno
--- TODO:
--- If we have something like:
--- let x = thunk in
--- f g = case g of g' -> (# x, g' #)
--- then we *do* know that g' will be properly tagged,
--- so we should return TagTagged [TagDunno,TagProper] but currently we infer
--- TagTagged [TagDunno,TagDunno] because of the unknown arity case in inferTagExpr.
--- Seems not to matter much but should be changed eventually.
inferTagExpr env (StgConApp con cn args tys)
= (inferConTag env con args, StgConApp con cn args tys)
@@ -340,9 +333,21 @@ inferTagExpr env (StgTick tick body)
(info, body') = inferTagExpr env body
inferTagExpr _ (StgOpApp op args ty)
- = -- Do any primops guarantee to return a properly tagged value?
- -- I think not. Ditto foreign calls.
- (TagDunno, StgOpApp op args ty)
+ | StgPrimOp SeqOp <- op
+ -- Recall seq# :: a -> State# s -> (# State# s, a #)
+ -- However the output State# token has been unarised away,
+ -- so we now effectively have
+ -- seq# :: a -> State# s -> (# a #)
+ -- The key point is the result of `seq#` is guaranteed evaluated and properly
+ -- tagged (because that result comes directly from evaluating the arg),
+ -- and we want tag inference to reflect that knowledge (#15226).
+ -- Hence `TagTuple [TagProper]`.
+ -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
+ = (TagTuple [TagProper], StgOpApp op args ty)
+ -- Do any other primops guarantee to return a properly tagged value?
+ -- Probably not, and that is the conservative assumption anyway.
+ -- (And foreign calls definitely need not make promises.)
+ | otherwise = (TagDunno, StgOpApp op args ty)
inferTagExpr env (StgLet ext bind body)
= (info, StgLet ext bind' body')
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -217,7 +217,7 @@ withLcl fv act = do
When compiling bytecode we call myCoreToStg to get STG code first.
myCoreToStg in turn calls out to stg2stg which runs the STG to STG
passes followed by free variables analysis and the tag inference pass including
-it's rewriting phase at the end.
+its rewriting phase at the end.
Running tag inference is important as it upholds Note [Strict Field Invariant].
While code executed by GHCi doesn't take advantage of the SFI it can call into
compiled code which does. So it must still make sure that the SFI is upheld.
@@ -400,13 +400,11 @@ rewriteExpr :: InferStgExpr -> RM TgStgExpr
rewriteExpr (e at StgCase {}) = rewriteCase e
rewriteExpr (e at StgLet {}) = rewriteLet e
rewriteExpr (e at StgLetNoEscape {}) = rewriteLetNoEscape e
-rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e
+rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e
rewriteExpr e@(StgConApp {}) = rewriteConApp e
-rewriteExpr e@(StgApp {}) = rewriteApp e
-rewriteExpr (StgLit lit) = return $! (StgLit lit)
-rewriteExpr (StgOpApp op@(StgPrimOp DataToTagOp) args res_ty) = do
- (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
-rewriteExpr (StgOpApp op args res_ty) = return $! (StgOpApp op args res_ty)
+rewriteExpr e@(StgOpApp {}) = rewriteOpApp e
+rewriteExpr e@(StgApp {}) = rewriteApp e
+rewriteExpr (StgLit lit) = return $! (StgLit lit)
rewriteCase :: InferStgExpr -> RM TgStgExpr
@@ -488,6 +486,33 @@ rewriteApp (StgApp f args)
rewriteApp (StgApp f args) = return $ StgApp f args
rewriteApp _ = panic "Impossible"
+{-
+Note [Rewriting primop arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given an application `op# x y`, is it worth applying `rewriteArg` to
+`x` and `y`? All that will do will be to set the `tagSig` for that
+occurrence of `x` and `y` to record whether it is evaluated and
+properly tagged. For the vast majority of primops that's a waste of
+time: the argument is an `Int#` or something.
+
+But code generation for `seq#` and `dataToTag#` /does/ consult that
+tag, to statically avoid generating an eval:
+* `seq#`: uses `getCallMethod` on its first argument, which looks at the `tagSig`
+* `dataToTag#`: checks `tagSig` directly in the `DataToTagOp` case of `cgExpr`.
+
+So for these we should call `rewriteArgs`.
+
+-}
+
+rewriteOpApp :: InferStgExpr -> RM TgStgExpr
+rewriteOpApp (StgOpApp op args res_ty) = case op of
+ op@(StgPrimOp primOp)
+ | primOp == SeqOp || primOp == DataToTagOp
+ -- see Note [Rewriting primop arguments]
+ -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
+ _ -> pure $! StgOpApp op args res_ty
+rewriteOpApp _ = panic "Impossible"
+
-- `mkSeq` x x' e generates `case x of x' -> e`
-- We could also substitute x' for x in e but that's so rarely beneficial
-- that we don't bother.
=====================================
compiler/GHC/Stg/InferTags/TagSig.hs
=====================================
@@ -5,7 +5,7 @@
-- We export this type from this module instead of GHC.Stg.InferTags.Types
-- because it's used by more than the analysis itself. For example in interface
-- files where we record a tag signature for bindings.
--- By putting the sig into it's own module we can avoid module loops.
+-- By putting the sig into its own module we can avoid module loops.
module GHC.Stg.InferTags.TagSig
where
@@ -78,4 +78,4 @@ seqTagInfo :: TagInfo -> ()
seqTagInfo TagTagged = ()
seqTagInfo TagDunno = ()
seqTagInfo TagProper = ()
-seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis
\ No newline at end of file
+seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -140,7 +140,7 @@ shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of
--
-- In more complex cases, there is a foreign call (out of line) fallback. This
-- might happen e.g. if there's enough static information, such as statically
--- know arguments.
+-- known arguments.
emitPrimOp
:: StgToCmmConfig
-> PrimOp -- ^ The primop
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -1721,12 +1721,16 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
swap_for_size = typesSize fun_args2 > typesSize fun_args1
-- See Note [Orienting TyFamLHS/TyFamLHS]
- swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&
+ meta_tv_lhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs1
+ meta_tv_rhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs2
+ swap_for_rewriting = meta_tv_rhs && not meta_tv_lhs
-- See Note [Put touchable variables on the left]
- not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1)
-- This second check is just to avoid unfruitful swapping
- ; if swap_for_rewriting || swap_for_size
+ -- It's important that we don't flip-flop (#T24134)
+ -- So swap_for_rewriting "wins", and we only try swap_for_size
+ -- if swap_for_rewriting doesn't care either way
+ ; if swap_for_rewriting || (meta_tv_lhs == meta_tv_rhs && swap_for_size)
then finish_with_swapping
else finish_without_swapping } }
where
@@ -1945,7 +1949,9 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
-- If we had F a ~ G (F a), which gives an occurs check,
-- then swap it to G (F a) ~ F a, which does not
-- However `swap_for_size` above will orient it with (G (F a)) on
- -- the left anwyway, so the next four lines of code are redundant
+ -- the left anwyway. `swap_for_rewriting` "wins", but that doesn't
+ -- matter: in the occurs check case swap_for_rewriting will be moot.
+ -- TL;DR: the next four lines of code are redundant
-- I'm leaving them here in case they become relevant again
-- | TyFamLHS {} <- lhs
-- , Just can_rhs <- canTyFamEqLHS_maybe rhs
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -14,7 +14,7 @@ import Language.Haskell.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr)
import GHC.Show ( showMultiLineString )
-import GHC.Lexeme( startsVarSym )
+import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
import Data.Foldable ( toList )
import Prelude hiding ((<>))
@@ -122,8 +122,8 @@ isSymOcc :: Name -> Bool
isSymOcc n
= case nameBase n of
[] -> True -- Empty name; weird
- (c:_) -> startsVarSym c
- -- c.f. OccName.startsVarSym in GHC itself
+ (c:_) -> isVarSymChar c
+ -- c.f. isVarSymChar in GHC itself
pprInfixExp :: Exp -> Doc
pprInfixExp (VarE v) = pprName' Infix v
@@ -471,7 +471,8 @@ ppr_dec _ (PatSynD name args dir pat)
pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2
| otherwise = pprName' Applied name <+> ppr args
pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where")
- nestDepth (pprName' Applied name <+> ppr cls)
+ nestDepth
+ (vcat $ (pprName' Applied name <+>) . ppr <$> cls)
| otherwise = ppr pat
ppr_dec _ (PatSynSigD name ty)
= pprPatSynSig name ty
=====================================
m4/ghc_toolchain.m4
=====================================
@@ -148,6 +148,7 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[
-ilibraries/ghc-platform/src -iutils/ghc-toolchain/src \
-XNoImplicitPrelude \
-odir actmp-ghc-toolchain -hidir actmp-ghc-toolchain \
+ -package-env=- \
utils/ghc-toolchain/exe/Main.hs -o acghc-toolchain || AC_MSG_ERROR([Could not compile ghc-toolchain])
GHC_TOOLCHAIN_BIN="./acghc-toolchain"
;;
=====================================
rts/linker/PEi386.c
=====================================
@@ -1939,29 +1939,32 @@ static size_t
makeSymbolExtra_PEi386( ObjectCode* oc, uint64_t index STG_UNUSED, size_t s, char* symbol STG_UNUSED, SymType type )
{
SymbolExtra *extra;
-
- if (type == SYM_TYPE_CODE) {
- // jmp *-14(%rip)
- extra = m32_alloc(oc->rx_m32, sizeof(SymbolExtra), 8);
- CHECK(extra);
- extra->addr = (uint64_t)s;
- static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
- memcpy(extra->jumpIsland, jmp, 6);
- IF_DEBUG(linker_verbose, debugBelch("makeSymbolExtra(code): %s -> %p\n", symbol, &extra->jumpIsland));
- return (size_t)&extra->jumpIsland;
- } else if (type == SYM_TYPE_INDIRECT_DATA) {
- extra = m32_alloc(oc->rw_m32, sizeof(SymbolExtra), 8);
- CHECK(extra);
- void *v = *(void**) s;
- extra->addr = (uint64_t)v;
- IF_DEBUG(linker_verbose, debugBelch("makeSymbolExtra(data): %s -> %p\n", symbol, &extra->addr));
- return (size_t)&extra->addr;
- } else {
- extra = m32_alloc(oc->rw_m32, sizeof(SymbolExtra), 8);
- CHECK(extra);
- extra->addr = (uint64_t)s;
- IF_DEBUG(linker_verbose, debugBelch("makeSymbolExtra(indirect-data): %s -> %p\n", symbol, &extra->addr));
- return (size_t)&extra->addr;
+ switch(type & ~SYM_TYPE_DUP_DISCARD) {
+ case SYM_TYPE_CODE: {
+ // jmp *-14(%rip)
+ extra = m32_alloc(oc->rx_m32, sizeof(SymbolExtra), 8);
+ CHECK(extra);
+ extra->addr = (uint64_t)s;
+ static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF };
+ memcpy(extra->jumpIsland, jmp, 6);
+ IF_DEBUG(linker_verbose, debugBelch("makeSymbolExtra(code): %s -> %p\n", symbol, &extra->jumpIsland));
+ return (size_t)&extra->jumpIsland;
+ }
+ case SYM_TYPE_INDIRECT_DATA: {
+ extra = m32_alloc(oc->rw_m32, sizeof(SymbolExtra), 8);
+ CHECK(extra);
+ void *v = *(void**) s;
+ extra->addr = (uint64_t)v;
+ IF_DEBUG(linker_verbose, debugBelch("makeSymbolExtra(data): %s -> %p\n", symbol, &extra->addr));
+ return (size_t)&extra->addr;
+ }
+ default: {
+ extra = m32_alloc(oc->rw_m32, sizeof(SymbolExtra), 8);
+ CHECK(extra);
+ extra->addr = (uint64_t)s;
+ IF_DEBUG(linker_verbose, debugBelch("makeSymbolExtra(indirect-data): %s -> %p\n", symbol, &extra->addr));
+ return (size_t)&extra->addr;
+ }
}
}
=====================================
testsuite/tests/indexed-types/should_compile/T24134.hs
=====================================
@@ -0,0 +1,54 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module M where
+import Data.Kind (Type)
+
+type F :: Type -> Type
+type family F
+
+type Prod :: Type -> Type -> Type
+type family Prod (a :: Type) (b :: Type) :: Type
+
+und :: F Int
+und = und
+
+f :: a -> Prod (F Int) a -> Prod a a
+f = f
+
+repMap :: Prod (F Int) (F Int) -> Prod (F Int) (F Int)
+repMap = f und
+
+
+{- This is what went wrong in GHC 9.8
+
+Inert: [W] Prod (F Int) a ~ Prod a a
+Work: [W] Prod (F Int) (F Int) ~ Prof (F Int) a
+
+---> rewrite with inert
+ [W] Prod (F Int) (F Int) ~ Prod a a
+---> swap (meta-var to left)
+ [W] Prod a a ~ Prod (F Int) (F Int)
+
+Kick out the inert
+
+Inert: [W] Prod a a ~ Prod (F Int) (F Int)
+Work: [W] Prod (F Int) a ~ Prod a a
+
+--> rewrite with inert
+ [W] Prod (F Int) a ~ Prod (F Int) (F Int)
+--> swap (size)
+ [W] Prod (F Int) (F Int) ~ Prod (F Int) a
+
+Kick out the inert
+
+Inert: [W] Prod (F Int) (F Int) ~ Prod (F Int) a
+Work: [W] Prod a a ~ Prod (F Int) (F Int)
+
+--> rewrite with inert
+ [W] Prod a a ~ Prod (F Int) a
+--> swap (size)
+ [W] Prof (F Int) a ~ Prod a a
+
+
+-}
=====================================
testsuite/tests/indexed-types/should_compile/all.T
=====================================
@@ -309,3 +309,4 @@ test('T22547', normal, compile, [''])
test('T22717', normal, makefile_test, ['T22717'])
test('T22717_fam_orph', normal, multimod_compile, ['T22717_fam_orph', '-v0'])
test('T23408', normal, compile, [''])
+test('T24134', normal, compile, [''])
=====================================
testsuite/tests/simplStg/should_compile/T15226b.hs
=====================================
@@ -0,0 +1,11 @@
+module T15226b where
+
+import Control.Exception
+
+data StrictPair a b = MkStrictPair !a !b
+
+testFun :: a -> b -> IO (StrictPair a b)
+testFun x y = do
+ x' <- evaluate x
+ evaluate (MkStrictPair x' y)
+ -- tag inference should not insert an eval for x' in making the strict pair
=====================================
testsuite/tests/simplStg/should_compile/T15226b.stderr
=====================================
@@ -0,0 +1,48 @@
+
+==================== Final STG: ====================
+T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE]
+ :: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b
+[GblId[DataConWrapper], Arity=2, Str=<SL><SL>, Unf=OtherCon []] =
+ {} \r [conrep conrep1]
+ case conrep of conrep2 [Occ=Once1] {
+ __DEFAULT ->
+ case conrep1 of conrep3 [Occ=Once1] {
+ __DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3];
+ };
+ };
+
+T15226b.testFun1
+ :: forall a b.
+ a
+ -> b
+ -> GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #)
+[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []] =
+ {} \r [x y void]
+ case seq# [x GHC.Prim.void#] of {
+ Solo# ipv1 [Occ=Once1] ->
+ let {
+ sat [Occ=Once1] :: T15226b.StrictPair a b
+ [LclId] =
+ {ipv1, y} \u []
+ case y of conrep [Occ=Once1] {
+ __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep];
+ };
+ } in seq# [sat GHC.Prim.void#];
+ };
+
+T15226b.testFun
+ :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b)
+[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []] =
+ {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#;
+
+T15226b.MkStrictPair [InlPrag=CONLIKE]
+ :: forall {a} {b}. a %1 -> b %1 -> T15226b.StrictPair a b
+[GblId[DataCon], Arity=2, Caf=NoCafRefs, Unf=OtherCon []] =
+ {} \r [eta eta]
+ case eta of eta {
+ __DEFAULT ->
+ case eta of eta { __DEFAULT -> T15226b.MkStrictPair [eta eta]; };
+ };
+
+
=====================================
testsuite/tests/simplStg/should_compile/all.T
=====================================
@@ -18,3 +18,8 @@ test('T22840', [extra_files(
[ 'T22840A.hs'
, 'T22840B.hs'
]), when(not(have_dynamic()),skip)], multimod_compile, ['T22840', '-dynamic-too -dtag-inference-checks'])
+test('T15226b', normal, compile, ['-O -ddump-stg-final -dsuppress-uniques -dno-typeable-binds'])
+test('inferTags003', [ only_ways(['optasm']),
+ grep_errmsg(r'(call stg\_ap\_0)', [1])
+ ], compile, ['-ddump-cmm -dno-typeable-binds -O'])
+test('inferTags004', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques'])
=====================================
testsuite/tests/simplStg/should_compile/inferTags003.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+module M where
+
+import GHC.Exts
+import GHC.IO
+
+data T a = MkT !Bool !a
+
+fun :: T a -> IO a
+{-# OPAQUE fun #-}
+fun (MkT _ x) = IO $ \s -> noinline seq# x s
+-- evaluate/seq# should not produce its own eval for x
+-- since it is properly tagged (from a strict field)
+
+-- uses noinline to prevent caseRules from eliding the seq# in Core
=====================================
testsuite/tests/simplStg/should_compile/inferTags003.stderr
=====================================
@@ -0,0 +1,177 @@
+
+==================== Output Cmm ====================
+[M.$WMkT_entry() { // [R3, R2]
+ { info_tbls: [(cEx,
+ label: block_cEx_info
+ rep: StackRep [False]
+ srt: Nothing),
+ (cEA,
+ label: M.$WMkT_info
+ rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} }
+ srt: Nothing),
+ (cED,
+ label: block_cED_info
+ rep: StackRep [False]
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cEA: // global
+ if ((Sp + -16) < SpLim) (likely: False) goto cEG; else goto cEH; // CmmCondBranch
+ cEG: // global
+ R1 = M.$WMkT_closure; // CmmAssign
+ call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; // CmmCall
+ cEH: // global
+ I64[Sp - 16] = cEx; // CmmStore
+ R1 = R2; // CmmAssign
+ P64[Sp - 8] = R3; // CmmStore
+ Sp = Sp - 16; // CmmAssign
+ if (R1 & 7 != 0) goto cEx; else goto cEy; // CmmCondBranch
+ cEy: // global
+ call (I64[R1])(R1) returns to cEx, args: 8, res: 8, upd: 8; // CmmCall
+ cEx: // global
+ // slowCall
+ I64[Sp] = cED; // CmmStore
+ _sEi::P64 = R1; // CmmAssign
+ R1 = P64[Sp + 8]; // CmmAssign
+ P64[Sp + 8] = _sEi::P64; // CmmStore
+ call stg_ap_0_fast(R1) returns to cED, args: 8, res: 8, upd: 8; // CmmCall
+ cED: // global
+ // slow_call for _sEh::P64 with pat stg_ap_0
+ Hp = Hp + 24; // CmmAssign
+ if (Hp > HpLim) (likely: False) goto cEL; else goto cEK; // CmmCondBranch
+ cEL: // global
+ HpAlloc = 24; // CmmAssign
+ call stg_gc_unpt_r1(R1) returns to cED, args: 8, res: 8, upd: 8; // CmmCall
+ cEK: // global
+ // allocHeapClosure
+ I64[Hp - 16] = M.MkT_con_info; // CmmStore
+ P64[Hp - 8] = P64[Sp + 8]; // CmmStore
+ P64[Hp] = R1; // CmmStore
+ R1 = Hp - 15; // CmmAssign
+ Sp = Sp + 16; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ },
+ section ""data" . M.$WMkT_closure" {
+ M.$WMkT_closure:
+ const M.$WMkT_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.fun_entry() { // [R2]
+ { info_tbls: [(cEV,
+ label: block_cEV_info
+ rep: StackRep []
+ srt: Nothing),
+ (cEY,
+ label: M.fun_info
+ rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 5} }
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cEY: // global
+ if ((Sp + -8) < SpLim) (likely: False) goto cEZ; else goto cF0; // CmmCondBranch
+ cEZ: // global
+ R1 = M.fun_closure; // CmmAssign
+ call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall
+ cF0: // global
+ I64[Sp - 8] = cEV; // CmmStore
+ R1 = R2; // CmmAssign
+ Sp = Sp - 8; // CmmAssign
+ if (R1 & 7 != 0) goto cEV; else goto cEW; // CmmCondBranch
+ cEW: // global
+ call (I64[R1])(R1) returns to cEV, args: 8, res: 8, upd: 8; // CmmCall
+ cEV: // global
+ R1 = P64[R1 + 15]; // CmmAssign
+ Sp = Sp + 8; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ },
+ section ""data" . M.fun_closure" {
+ M.fun_closure:
+ const M.fun_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.MkT_entry() { // [R3, R2]
+ { info_tbls: [(cFc,
+ label: block_cFc_info
+ rep: StackRep [False]
+ srt: Nothing),
+ (cFf,
+ label: M.MkT_info
+ rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} }
+ srt: Nothing),
+ (cFi,
+ label: block_cFi_info
+ rep: StackRep [False]
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cFf: // global
+ if ((Sp + -16) < SpLim) (likely: False) goto cFl; else goto cFm; // CmmCondBranch
+ cFl: // global
+ R1 = M.MkT_closure; // CmmAssign
+ call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; // CmmCall
+ cFm: // global
+ I64[Sp - 16] = cFc; // CmmStore
+ R1 = R2; // CmmAssign
+ P64[Sp - 8] = R3; // CmmStore
+ Sp = Sp - 16; // CmmAssign
+ if (R1 & 7 != 0) goto cFc; else goto cFd; // CmmCondBranch
+ cFd: // global
+ call (I64[R1])(R1) returns to cFc, args: 8, res: 8, upd: 8; // CmmCall
+ cFc: // global
+ // slowCall
+ I64[Sp] = cFi; // CmmStore
+ _tEq::P64 = R1; // CmmAssign
+ R1 = P64[Sp + 8]; // CmmAssign
+ P64[Sp + 8] = _tEq::P64; // CmmStore
+ call stg_ap_0_fast(R1) returns to cFi, args: 8, res: 8, upd: 8; // CmmCall
+ cFi: // global
+ // slow_call for _B1::P64 with pat stg_ap_0
+ Hp = Hp + 24; // CmmAssign
+ if (Hp > HpLim) (likely: False) goto cFq; else goto cFp; // CmmCondBranch
+ cFq: // global
+ HpAlloc = 24; // CmmAssign
+ call stg_gc_unpt_r1(R1) returns to cFi, args: 8, res: 8, upd: 8; // CmmCall
+ cFp: // global
+ // allocHeapClosure
+ I64[Hp - 16] = M.MkT_con_info; // CmmStore
+ P64[Hp - 8] = P64[Sp + 8]; // CmmStore
+ P64[Hp] = R1; // CmmStore
+ R1 = Hp - 15; // CmmAssign
+ Sp = Sp + 16; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ },
+ section ""data" . M.MkT_closure" {
+ M.MkT_closure:
+ const M.MkT_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.MkT_con_entry() { // []
+ { info_tbls: [(cFw,
+ label: M.MkT_con_info
+ rep: HeapRep 2 ptrs { Con {tag: 0 descr:"main:M.MkT"} }
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cFw: // global
+ R1 = R1 + 1; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ }]
+
+
=====================================
testsuite/tests/simplStg/should_compile/inferTags004.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE BangPatterns, UnboxedTuples #-}
+module InferTags004 where
+
+x :: Int
+x = x
+
+f :: a -> (# Int, a #)
+-- Adapted from a TODO in InferTags.
+-- f's tag signature should indicate that the second component
+-- of its result is properly tagged: TagTuple[TagDunno,TagProper]
+f g = case g of !g' -> (# x, g' #)
=====================================
testsuite/tests/simplStg/should_compile/inferTags004.stderr
=====================================
@@ -0,0 +1,13 @@
+
+==================== CodeGenAnal STG: ====================
+Rec {
+(InferTags004.x, <TagDunno>) = {} \u [] InferTags004.x;
+end Rec }
+
+(InferTags004.f, <TagTuple[TagDunno, TagProper]>) =
+ {} \r [(g, <TagDunno>)]
+ case g of (g', <TagProper>) {
+ __DEFAULT -> (#,#) [InferTags004.x g'];
+ };
+
+
=====================================
testsuite/tests/th/T24111.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE Haskell2010, PatternSynonyms, TemplateHaskell, ViewPatterns #-}
+
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main = do
+ runQ [d|pattern (:+) :: Int -> Int -> (Int, Int);
+ pattern x :+ y = (x, y)|] >>= putStrLn . pprint
+ runQ [d|pattern A :: Int -> String;
+ pattern A n <- (read -> n) where {
+ A 0 = "hi";
+ A 1 = "bye"}|] >>= putStrLn . pprint
=====================================
testsuite/tests/th/T24111.stdout
=====================================
@@ -0,0 +1,7 @@
+pattern (:+_0) :: GHC.Types.Int ->
+ GHC.Types.Int -> (GHC.Types.Int, GHC.Types.Int)
+pattern x_1 :+_0 y_2 = (x_1, y_2)
+pattern A_0 :: GHC.Types.Int -> GHC.Base.String
+pattern A_0 n_1 <- (Text.Read.read -> n_1) where
+ A_0 0 = "hi"
+ A_0 1 = "bye"
=====================================
testsuite/tests/th/all.T
=====================================
@@ -597,3 +597,4 @@ test('T23962', normal, compile_and_run, [''])
test('T23968', normal, compile_and_run, [''])
test('T23971', normal, compile_and_run, [''])
test('T23986', normal, compile_and_run, [''])
+test('T24111', normal, compile_and_run, [''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -32,6 +32,7 @@ module ExactPrint
) where
import GHC
+import GHC.Base (NonEmpty(..))
import GHC.Core.Coercion.Axiom (Role(..))
import GHC.Data.Bag
import qualified GHC.Data.BooleanFormula as BF
@@ -366,7 +367,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
when (flush == NoFlushComments) $ do
when ((getFollowingComments cs) /= []) $ do
debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
- mapM_ printOneComment (map tokComment $ getFollowingComments cs)
+ mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs)
debugM $ "ending trailing comments"
eof <- getEofPos
@@ -393,7 +394,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
-- ---------------------------------------------------------------------
addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()
-addCommentsA csNew = addComments (map tokComment csNew)
+addCommentsA csNew = addComments (concatMap tokComment csNew)
{-
TODO: When we addComments, some may have an anchor that is no longer
@@ -547,7 +548,7 @@ printStringAtAAC :: (Monad m, Monoid w)
=> CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s
printStringAtAAC capture (EpaDelta d cs) s = do
- mapM_ (printOneComment . tokComment) cs
+ mapM_ printOneComment $ concatMap tokComment cs
pe1 <- getPriorEndD
p1 <- getPosP
printStringAtLsDelta d s
@@ -1357,7 +1358,7 @@ instance ExactPrint (HsModule GhcPs) where
exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod
exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do
- mbDoc' <- markAnnotated mbDoc
+ let mbDoc' = mbDoc
(an0, mmn' , mdeprec', mexports') <-
case mmn of
@@ -1382,7 +1383,7 @@ instance ExactPrint (HsModule GhcPs) where
am_decls' <- markTrailing (am_decls $ anns an0)
imports' <- markTopLevelList imports
- decls' <- markTopLevelList decls
+ decls' <- markTopLevelList (filter removeDocDecl decls)
lo1 <- case lo0 of
ExplicitBraces open close -> do
@@ -1402,6 +1403,11 @@ instance ExactPrint (HsModule GhcPs) where
return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls')
+
+removeDocDecl :: LHsDecl GhcPs -> Bool
+removeDocDecl (L _ DocD{}) = False
+removeDocDecl _ = True
+
-- ---------------------------------------------------------------------
instance ExactPrint ModuleName where
@@ -1533,9 +1539,27 @@ instance ExactPrint (ImportDecl GhcPs) where
instance ExactPrint HsDocString where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ = a
- exact ds = do
- (printStringAdvance . exactPrintHsDocString) ds
- return ds
+
+ exact (MultiLineDocString decorator (x :| xs)) = do
+ printStringAdvance ("-- " ++ printDecorator decorator)
+ pe <- getPriorEndD
+ debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x)
+ x' <- markAnnotated x
+ xs' <- markAnnotated (map dedentDocChunk xs)
+ return (MultiLineDocString decorator (x' :| xs'))
+ exact x = do
+ -- TODO: can this happen?
+ debugM $ "Not exact printing:" ++ showAst x
+ return x
+
+
+instance ExactPrint HsDocStringChunk where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+ exact chunk = do
+ printStringAdvance ("--" ++ unpackHDSC chunk)
+ return chunk
+
instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where
getAnnotationEntry _ = NoEntryVal
@@ -1895,11 +1919,8 @@ instance ExactPrint (DocDecl GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ = a
- exact v = case v of
- (DocCommentNext ds) -> DocCommentNext <$> exact ds
- (DocCommentPrev ds) -> DocCommentPrev <$> exact ds
- (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds
- (DocGroup i ds) -> DocGroup i <$> exact ds
+ -- We print these as plain comments instead, do a NOP here.
+ exact v = return v
-- ---------------------------------------------------------------------
@@ -3936,8 +3957,7 @@ instance ExactPrint (HsType GhcPs) where
return (HsSpliceTy a splice')
exact (HsDocTy an ty doc) = do
ty' <- markAnnotated ty
- doc' <- markAnnotated doc
- return (HsDocTy an ty' doc')
+ return (HsDocTy an ty' doc)
exact (HsBangTy an (HsSrcBang mt up str) ty) = do
an0 <-
case mt of
@@ -4246,7 +4266,6 @@ instance ExactPrint (ConDecl GhcPs) where
, con_mb_cxt = mcxt
, con_args = args
, con_doc = doc }) = do
- doc' <- mapM markAnnotated doc
an0 <- if has_forall
then markEpAnnL an lidl AnnForall
else return an
@@ -4266,11 +4285,11 @@ instance ExactPrint (ConDecl GhcPs) where
, con_ex_tvs = ex_tvs'
, con_mb_cxt = mcxt'
, con_args = args'
- , con_doc = doc' })
+ , con_doc = doc })
where
- -- -- In ppr_details: let's not print the multiplicities (they are always 1, by
- -- -- definition) as they do not appear in an actual declaration.
+ -- In ppr_details: let's not print the multiplicities (they are always 1, by
+ -- definition) as they do not appear in an actual declaration.
exact_details (InfixCon t1 t2) = do
t1' <- markAnnotated t1
con' <- markAnnotated con
@@ -4294,7 +4313,6 @@ instance ExactPrint (ConDecl GhcPs) where
, con_bndrs = bndrs
, con_mb_cxt = mcxt, con_g_args = args
, con_res_ty = res_ty, con_doc = doc }) = do
- doc' <- mapM markAnnotated doc
cons' <- mapM markAnnotated cons
dcol' <- markUniToken dcol
an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]
@@ -4323,7 +4341,7 @@ instance ExactPrint (ConDecl GhcPs) where
, con_dcolon = dcol'
, con_bndrs = bndrs'
, con_mb_cxt = mcxt', con_g_args = args'
- , con_res_ty = res_ty', con_doc = doc' })
+ , con_res_ty = res_ty', con_doc = doc })
-- ---------------------------------------------------------------------
@@ -4359,8 +4377,8 @@ instance ExactPrint (ConDeclField GhcPs) where
names' <- markAnnotated names
an0 <- markEpAnnL an lidl AnnDcolon
ftype' <- markAnnotated ftype
- mdoc' <- mapM markAnnotated mdoc
- return (ConDeclField an0 names' ftype' mdoc')
+ -- mdoc' <- mapM markAnnotated mdoc
+ return (ConDeclField an0 names' ftype' mdoc)
-- ---------------------------------------------------------------------
@@ -4563,7 +4581,14 @@ instance ExactPrint (IE GhcPs) where
m' <- markAnnotated m
return (IEModuleContents (depr', an0) m')
- exact x = error $ "missing match for IE:" ++ showAst x
+ -- These three exist to not error out, but are no-ops The contents
+ -- appear as "normal" comments too, which we process instead.
+ exact (IEGroup x lev doc) = do
+ return (IEGroup x lev doc)
+ exact (IEDoc x doc) = do
+ return (IEDoc x doc)
+ exact (IEDocNamed x str) = do
+ return (IEDocNamed x str)
-- ---------------------------------------------------------------------
=====================================
utils/check-exact/Preprocess.hs
=====================================
@@ -124,8 +124,9 @@ getCppTokensAsComments cppOptions sourceFile = do
goodComment :: GHC.LEpaComment -> Bool
goodComment c = isGoodComment (tokComment c)
where
- isGoodComment :: Comment -> Bool
- isGoodComment (Comment "" _ _ _) = False
+ isGoodComment :: [Comment] -> Bool
+ isGoodComment [] = False
+ isGoodComment [Comment "" _ _ _] = False
isGoodComment _ = True
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -36,6 +36,7 @@ import GHC.Types.SrcLoc
import GHC.Driver.Ppr
import GHC.Data.FastString
import qualified GHC.Data.Strict as Strict
+import GHC.Base (NonEmpty(..))
import Data.Data hiding ( Fixity )
import Data.List (sortBy, elemIndex)
@@ -236,8 +237,47 @@ ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = ""
-tokComment :: LEpaComment -> Comment
-tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c)
+tokComment :: LEpaComment -> [Comment]
+tokComment t@(L lt c) =
+ case c of
+ (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc
+ _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]
+
+hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment]
+hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) =
+ let
+ decStr = printDecorator dec
+ L lx x' = dedentDocChunkBy (3 + length decStr) x
+ str = "-- " ++ decStr ++ unpackHDSC x'
+ docChunk _ [] = []
+ docChunk pt' (L l chunk:cs)
+ = Comment ("--" ++ unpackHDSC chunk) (spanAsAnchor l) pt' Nothing : docChunk (rs l) cs
+ in
+ (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs))
+hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk))
+ = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+hsDocStringComments anc pt (NestedDocString dec (L _ chunk))
+ = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]
+
+hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code
+
+-- At the moment the locations of the 'HsDocStringChunk's are from the start of
+-- the string part, leaving aside the "--". So we need to subtract 2 columns from it
+dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk
+dedentDocChunk chunk = dedentDocChunkBy 2 chunk
+
+dedentDocChunkBy :: Int -> LHsDocStringChunk -> LHsDocStringChunk
+dedentDocChunkBy dedent (L (RealSrcSpan l mb) c) = L (RealSrcSpan l' mb) c
+ where
+ f = srcSpanFile l
+ sl = srcSpanStartLine l
+ sc = srcSpanStartCol l
+ el = srcSpanEndLine l
+ ec = srcSpanEndCol l
+ l' = mkRealSrcSpan (mkRealSrcLoc f sl (sc - dedent))
+ (mkRealSrcLoc f el (ec - dedent))
+
+dedentDocChunkBy _ x = x
mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments
mkEpaComments priorCs []
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f6930dc9193ed6916815c9597a693a5379b2563a...78060ce1fbfbda1ac76b3095f1f9e9bf6d95e8e5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f6930dc9193ed6916815c9597a693a5379b2563a...78060ce1fbfbda1ac76b3095f1f9e9bf6d95e8e5
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/20231030/eac00d5e/attachment-0001.html>
More information about the ghc-commits
mailing list