[Git][ghc/ghc][wip/T15226-stg] Teach tag-inference about SeqOp/seq#
Matthew Craven (@clyring)
gitlab at gitlab.haskell.org
Wed Oct 18 17:25:00 UTC 2023
Matthew Craven pushed to branch wip/T15226-stg at Glasgow Haskell Compiler / GHC
Commits:
3c0528ed by Matthew Craven at 2023-10-18T13:24:14-04:00
Teach tag-inference about SeqOp/seq#
Fixes the STG/tag-inference analogue of #15226.
- - - - -
12 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
- + testsuite/tests/simplStg/should_compile/inferTags004.hs
- + testsuite/tests/simplStg/should_compile/inferTags004.stderr
Changes:
=====================================
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,15 @@ 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
+ -- The inner result of seq# comes directly from evaluating its
+ -- argument, hence TagProper. (The State# token was unarised out of
+ -- existence.) 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,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'];
+ };
+
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c0528eda983de66fd2361baf7ed52640aea2b8f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c0528eda983de66fd2361baf7ed52640aea2b8f
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/20231018/0de46309/attachment-0001.html>
More information about the ghc-commits
mailing list