[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Teach tag-inference about SeqOp/seq#
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Oct 28 08:46:26 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
82af4235 by Matthew Craven at 2023-10-28T04:46:09-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>
- - - - -
8ff6bf97 by Moritz Angermann at 2023-10-28T04:46:09-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.
- - - - -
f6930dc9 by Mario Blažević at 2023-10-28T04:46:11-04:00
Fix and test for issue #24111, TH.Ppr output of pattern synonyms
- - - - -
18 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Stg/InferTags.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Stg/InferTags/TagSig.hs
- compiler/GHC/StgToCmm/Prim.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- rts/linker/PEi386.c
- + 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
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/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
=====================================
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
=====================================
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/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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84fd105440a80bfb224c3566cc4f8060c4d6bacc...f6930dc9193ed6916815c9597a693a5379b2563a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84fd105440a80bfb224c3566cc4f8060c4d6bacc...f6930dc9193ed6916815c9597a693a5379b2563a
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/20231028/81ff004f/attachment-0001.html>
More information about the ghc-commits
mailing list