[Git][ghc/ghc][wip/T15226-stg] Teach tag-inference about SeqOp/seq#
Matthew Craven (@clyring)
gitlab at gitlab.haskell.org
Sun Oct 15 14:46:10 UTC 2023
Matthew Craven pushed to branch wip/T15226-stg at Glasgow Haskell Compiler / GHC
Commits:
f4889f47 by Matthew Craven at 2023-10-15T10:45:15-04:00
Teach tag-inference about SeqOp/seq#
Fixes the STG/tag-inference analogue of #15226.
- - - - -
10 changed files:
- 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
- + 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
Changes:
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -2108,6 +2108,11 @@ 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.
+ (The TagTuple has only one component because the state token in the
+ result has already been unarised out of existence.)
-}
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 )
@@ -340,9 +341,12 @@ 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 -- 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,17 @@ rewriteApp (StgApp f args)
rewriteApp (StgApp f args) = return $ StgApp f args
rewriteApp _ = panic "Impossible"
+rewriteOpApp :: InferStgExpr -> RM TgStgExpr
+rewriteOpApp (StgOpApp op args res_ty) = case op of
+ op@(StgPrimOp primOp)
+ | primOp == SeqOp || primOp == DataToTagOp
+ -- These primops evaluate an argument and can use a tag annotation
+ -- to elide that eval. Foreign calls and other primops make no
+ -- use of tag info, so we don't bother annotating them.
+ -> (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
=====================================
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,7 @@ 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('(call stg\_ap\_0)', [1])
+ ], compile, ['-ddump-cmm -dno-typeable-binds -O'])
=====================================
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
+ }
+ }]
+
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4889f473c3a4033f2ad270386346f18783c7f48
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4889f473c3a4033f2ad270386346f18783c7f48
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/20231015/6047d92c/attachment-0001.html>
More information about the ghc-commits
mailing list