[Git][ghc/ghc][wip/T24124] 6 commits: Teach tag-inference about SeqOp/seq#
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Sat Oct 28 12:52:45 UTC 2023
Sebastian Graf pushed to branch wip/T24124 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
- - - - -
92b6a902 by Sebastian Graf at 2023-10-28T14:40:47+02:00
ghc-toolchain: build with `-package-env=-` (#24131)
Otherwise globally installed libraries (via `cabal install --lib`)
break the build.
Fixes #24131.
- - - - -
aafbf775 by Sebastian Graf at 2023-10-28T14:40:47+02:00
CorePrep: Attach evaldUnfolding to floats to detect more values
See `Note [Pin evaluatedness on floats]`.
- - - - -
9690fdab by Sebastian Graf at 2023-10-28T14:52:25+02:00
CorePrep: Treat seq# and dataToTag# as strict functions (#24124)
See the new `Note [seq# magic]`.
I also implemented a new `Note [Flatten case-bind]`.
Fixes #24124.
- - - - -
26 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/CoreToStg/Prep.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
- m4/ghc_toolchain.m4
- rts/linker/PEi386.c
- + testsuite/tests/core-to-stg/T24124.hs
- + testsuite/tests/core-to-stg/T24124.stderr
- testsuite/tests/core-to-stg/all.T
- testsuite/tests/ghci/should_run/T21052.stdout
- testsuite/tests/simplCore/should_compile/T23083.stderr
- + testsuite/tests/simplStg/should_compile/T15226b.hs
- + testsuite/tests/simplStg/should_compile/T15226b.stderr
- testsuite/tests/simplStg/should_compile/T19717.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
=====================================
@@ -2028,6 +2028,9 @@ is:
case e of <transformed alts>
by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]
+* Similar to Note [seq# magic], we case-bind the arg of dataToTag# in
+ GHC.CoreToStg.Prep.
+
See #15696 for a long saga.
-}
@@ -2103,11 +2106,26 @@ Implementing seq#. The compiler has magic for SeqOp in
- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)
+- GHC.CoreToStg.Prep: Case-bind the arg of seq#, e.g.,
+
+ case seq# (f 13) s of (# r, s' #) -> ...
+ ==>
+ case f 13 of sat of __DEFAULT ->
+ case seq# sat s of (# r, s' #) -> ...,
+
+ encoding its call-by-value nature (as implemented in StgToCmm below).
+ Note that strictness analysis and the Simplifier will never see this case
+ binding, so #5129 as above is not an issue. Plus, CorePrep never case-binds an
+ argument variable anyway.
+
- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#
- 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/CoreToStg/Prep.hs
=====================================
@@ -70,6 +70,7 @@ import GHC.Types.Unique.Supply
import Data.List ( unfoldr )
import Control.Monad
+import GHC.Builtin.PrimOps
{-
Note [CorePrep Overview]
@@ -679,9 +680,11 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
- ; let float = mkNonRecFloat env topDmd False v rhs2
+ ; let float@(Float (NonRec v' _) _ _) =
+ mkNonRecFloat env topDmd False v rhs2
+ -- v' has demand info and possibly evaldUnfolding
; return ( snocFloat floats2 float
- , cpeEtaExpand arity (Var v)) })
+ , cpeEtaExpand arity (Var v')) })
-- Wrap floating ticks
; let (floats4, rhs4) = wrapTicks floats3 rhs3
@@ -848,7 +851,12 @@ cpeRhsE env (Case scrut bndr ty alts)
where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"
; alts'' <- mapM (sat_alt env') alts'
- ; return (floats, Case scrut' bndr2 ty alts'') }
+ ; case alts'' of
+ [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]
+ | float <- mkNonRecFloat env evalDmd True bndr2 scrut'
+ -- True: is_unlifted, so that we don't float to top-level
+ -> return (snocFloat floats float, rhs)
+ _ -> return (floats, Case scrut' bndr2 ty alts'') }
where
sat_alt env (Alt con bs rhs)
= do { (env2, bs') <- cpCloneBndrs env bs
@@ -1087,16 +1095,24 @@ cpeApp top_env expr
; mb_saturate hd app floats unsat_ticks depth }
where
depth = val_args args
- stricts = case idDmdSig v of
- DmdSig (DmdType _ demands)
- | listLengthCmp demands depth /= GT -> demands
- -- length demands <= depth
- | otherwise -> []
- -- If depth < length demands, then we have too few args to
- -- satisfy strictness info so we have to ignore all the
- -- strictness info, e.g. + (error "urk")
- -- Here, we can't evaluate the arg strictly, because this
- -- partial application might be seq'd
+ stricts
+ | PrimOpId op _ <- idDetails v
+ , Just demands <- case op of
+ SeqOp -> Just [evalDmd,topDmd] -- See Note [seq# magic]
+ DataToTagOp -> Just [evalDmd] -- See Note [dataToTag# magic]
+ _ -> Nothing
+ , listLengthCmp demands depth /= GT -- length demands <= depth
+ = pprTrace "here" (ppr op $$ ppr args) demands
+
+ | DmdSig (DmdType _ demands) <- idDmdSig v
+ , listLengthCmp demands depth /= GT -- length demands <= depth
+ = demands
+ | otherwise
+ = [] -- If depth < length demands, then we have too few args to
+ -- satisfy strictness info so we have to ignore all the
+ -- strictness info, e.g. + (error "urk")
+ -- Here, we can't evaluate the arg strictly, because this
+ -- partial application might be seq'd
-- We inlined into something that's not a var and has no args.
-- Bounce it back up to cpeRhsE.
@@ -1484,8 +1500,10 @@ cpeArg env dmd arg
else do { v <- newVar arg_ty
-- See Note [Eta expansion of arguments in CorePrep]
; let arg3 = cpeEtaExpandArg env arg2
- arg_float = mkNonRecFloat env dmd is_unlifted v arg3
- ; return (snocFloat floats2 arg_float, varToCoreExpr v) }
+ arg_float@(Float (NonRec v' _) _ _) =
+ mkNonRecFloat env dmd is_unlifted v arg3
+ -- v' has demand info and possibly evaldUnfolding
+ ; return (snocFloat floats2 arg_float, varToCoreExpr v') }
}
cpeEtaExpandArg :: CorePrepEnv -> CoreArg -> CoreArg
@@ -1704,6 +1722,81 @@ Note [Pin demand info on floats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We pin demand info on floated lets, so that we can see the one-shot thunks.
+Note [Pin evaluatedness on floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a call to a CBV function, such as a DataCon worker with strict fields:
+
+ data T a = T !a
+ ... f (T e) ...
+
+During ANFisation, we will `mkNonRecFloat` for `e`, binding it to a
+fresh binder `sat`.
+Now there are two interesting cases:
+
+ 1. When `e=Just y` is a value, we will float `sat=Just y` as far as possible,
+ to top-level, even. It is important that we mark `sat` as evaluated (via
+ setting its unfolding to `evaldUnfolding`), otherwise we get a superfluous
+ thunk to carry out the field seq on T's field, because
+ `exprIsHNF sat == False`:
+
+ let sat = Just y in
+ let sat2 = case sat of x { __DEFAULT } -> T x in
+ -- NONONO, want just `sat2 = T x`
+ f sat2
+
+ This happened in $walexGetByte, where the thunk caused additional
+ allocation.
+
+ 2. Similarly, when `e` is not a value, we still know that it is strictly
+ evaluated. Hence it is going to be case-bound, and we anticipate that `sat`
+ will be a case binder which is *always* evaluated.
+ Hence in this case, we also mark `sat` as evaluated via its unfolding.
+ This happened in GHC.Linker.Deps.$wgetLinkDeps, where without
+ `evaldUnfolding` we ended up with this:
+
+ Word64Map = ... | Bin ... ... !Word64Map !Word64Map
+ case ... of { Word64Map.Bin a b l r ->
+ case insert ... of sat { __DEFAULT ->
+ case Word64Map.Bin a b l sat of sat2 { __DEFAULT ->
+ f sat2
+ }}}
+
+ Note that *the DataCon app `Bin a b l sat` was case-bound*, because it was
+ not detected to be a value according to `exprIsHNF`.
+ That is because the strict field `sat` lacked the `evaldUnfolding`,
+ although it ended up being case-bound.
+
+ There is one small wrinkle: It could be that `sat=insert ...` floats to
+ top-level, where it is not eagerly evaluated. In this case, we may not
+ give `sat` an `evaldUnfolding`. We detect this case by looking at the
+ `FloatInfo` of `sat=insert ...`: If it says `TopLvlFloatable`, we are
+ conservative and will not give `sat` an `evaldUnfolding`.
+
+TLDR; when creating a new float `sat=e` in `mkNonRecFloat`, propagate `sat` with
+an `evaldUnfolding` if either
+
+ 1. `e` is a value, or
+ 2. `sat=e` is case-bound, but won't float to top-level.
+
+Note [Flatten case-binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following program involving seq#:
+
+ data T a = T !a
+ ... seq# (case x of y { __DEFAULT -> T y }) s ...
+ ==> {ANFise, exploiting CbV-ness as in Note [seq# magic] and cpe_app}
+ ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> seq# sat s }
+
+(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy;
+see Note [seq# magic].)
+Note the case-of-case. This is not bad per sé, but we can easily flatten
+this situation by calling `mkNonRecFloat` to create strict binding `y=x`:
+
+ ... case x of y { __DEFAULT -> let sat = T y in seq# sat s } ...
+
+where `T y` is simply let-bound, thus far less likely to confuse passes
+downstream.
+
Note [Speculative evaluation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since call-by-value is much cheaper than call-by-need, we case-bind arguments
@@ -1984,9 +2077,8 @@ zipManyFloats = foldr zipFloats emptyFloats
mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $
- Float (NonRec bndr' rhs) bound info
+ Float (NonRec bndr2 rhs) bound info
where
- bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats]
(bound,info)
| is_lifted, is_hnf = (LetBound, TopLvlFloatable)
-- is_lifted: We currently don't allow unlifted values at the
@@ -2017,6 +2109,14 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr
is_rec_call = (`elemUnVarSet` cpe_rec_ids env)
is_data_con = isJust . isDataConId_maybe
+ bndr1 = bndr `setIdDemandInfo` dmd -- See Note [Pin demand info on floats]
+ bndr2
+ | is_hnf || (bound == CaseBound && info /= TopLvlFloatable)
+ -- See Note [Pin evaluatedness on floats]
+ = bndr1 `setIdUnfolding` evaldUnfolding
+ | otherwise
+ = bndr1
+
-- | Wrap floats around an expression
wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds floats body
=====================================
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
=====================================
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/core-to-stg/T24124.hs
=====================================
@@ -0,0 +1,11 @@
+module T24124 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)
+ -- CorePrep should evaluate `MkStrictPair` and its fields strictly
=====================================
testsuite/tests/core-to-stg/T24124.stderr
=====================================
@@ -0,0 +1,193 @@
+
+==================== CorePrep ====================
+Result size of CorePrep
+ = {terms: 119, types: 108, coercions: 22, joins: 0/1}
+
+-- RHS size: {terms: 13, types: 8, coercions: 0, joins: 0/0}
+T24124.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE]
+ :: forall a b. a %1 -> b %1 -> T24124.StrictPair a b
+[GblId[DataConWrapper], Arity=2, Str=<SL><SL>, Unf=OtherCon []]
+T24124.$WMkStrictPair
+ = \ (@a)
+ (@b)
+ (conrep [Occ=Once1] :: a)
+ (conrep1 [Occ=Once1] :: b) ->
+ case conrep of conrep2 [Occ=Once1, Dmd=SL] { __DEFAULT ->
+ case conrep1 of conrep3 [Occ=Once1, Dmd=SL] { __DEFAULT ->
+ T24124.MkStrictPair @a @b conrep2 conrep3
+ }
+ }
+
+-- RHS size: {terms: 20, types: 27, coercions: 0, joins: 0/1}
+T24124.testFun1
+ :: forall a b.
+ a
+ -> b
+ -> GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, T24124.StrictPair a b #)
+[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []]
+T24124.testFun1
+ = \ (@a)
+ (@b)
+ (x [Occ=Once1] :: a)
+ (y [Occ=Once1, OS=OneShot] :: b)
+ (s [Occ=Once1, OS=OneShot]
+ :: GHC.Prim.State# GHC.Prim.RealWorld) ->
+ case GHC.Prim.seq# @a @GHC.Prim.RealWorld x s of
+ { (# ipv [Occ=Once1], ipv1 [Occ=Once1] #) ->
+ case y of conrep [Occ=Once1, Dmd=SL] { __DEFAULT ->
+ let {
+ sat [Occ=Once1, Dmd=SL] :: T24124.StrictPair a b
+ [LclId, Unf=OtherCon []]
+ sat = T24124.MkStrictPair @a @b ipv1 conrep } in
+ GHC.Prim.seq# @(T24124.StrictPair a b) @GHC.Prim.RealWorld sat ipv
+ }
+ }
+
+-- RHS size: {terms: 9, types: 8, coercions: 15, joins: 0/0}
+T24124.testFun
+ :: forall a b. a -> b -> GHC.Types.IO (T24124.StrictPair a b)
+[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []]
+T24124.testFun
+ = (\ (@a)
+ (@b)
+ (eta [Occ=Once1] :: a)
+ (eta [Occ=Once1] :: b)
+ (eta [Occ=Once1] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
+ T24124.testFun1 @a @b eta eta eta)
+ `cast` (forall (a :: <*>_N) (b :: <*>_N).
+ <a>_R
+ %<'GHC.Types.Many>_N ->_R <b>_R
+ %<'GHC.Types.Many>_N ->_R Sym (GHC.Types.N:IO[0]
+ <T24124.StrictPair a b>_R)
+ :: (forall a b.
+ a
+ -> b
+ -> GHC.Prim.State# GHC.Prim.RealWorld
+ -> (# GHC.Prim.State# GHC.Prim.RealWorld, T24124.StrictPair a b #))
+ ~R# (forall a b. a -> b -> GHC.Types.IO (T24124.StrictPair a b)))
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule4 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T24124.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule3 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T24124.$trModule3 = GHC.Types.TrNameS T24124.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T24124.$trModule2 = "T24124"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule1 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T24124.$trModule1 = GHC.Types.TrNameS T24124.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T24124.$trModule :: GHC.Types.Module
+[GblId, Unf=OtherCon []]
+T24124.$trModule
+ = GHC.Types.Module T24124.$trModule3 T24124.$trModule1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep = GHC.Types.KindRepVar 1#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep1 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep1 = GHC.Types.KindRepVar 0#
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T24124.$tcStrictPair2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T24124.$tcStrictPair2 = "StrictPair"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T24124.$tcStrictPair1 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T24124.$tcStrictPair1 = GHC.Types.TrNameS T24124.$tcStrictPair2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T24124.$tcStrictPair :: GHC.Types.TyCon
+[GblId, Unf=OtherCon []]
+T24124.$tcStrictPair
+ = GHC.Types.TyCon
+ 9300255393514929474#Word64
+ 9110283622559092784#Word64
+ T24124.$trModule
+ T24124.$tcStrictPair1
+ 0#
+ GHC.Types.krep$*->*->*
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep2 :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep2
+ = GHC.Types.:
+ @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep3 :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep3 = GHC.Types.: @GHC.Types.KindRep $krep1 $krep2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep4 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep4 = GHC.Types.KindRepTyConApp T24124.$tcStrictPair $krep3
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep5 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep5 = GHC.Types.KindRepFun $krep $krep4
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T24124.$tc'MkStrictPair1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+T24124.$tc'MkStrictPair1 = GHC.Types.KindRepFun $krep1 $krep5
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T24124.$tc'MkStrictPair3 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+T24124.$tc'MkStrictPair3 = "'MkStrictPair"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T24124.$tc'MkStrictPair2 :: GHC.Types.TrName
+[GblId, Unf=OtherCon []]
+T24124.$tc'MkStrictPair2
+ = GHC.Types.TrNameS T24124.$tc'MkStrictPair3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T24124.$tc'MkStrictPair :: GHC.Types.TyCon
+[GblId, Unf=OtherCon []]
+T24124.$tc'MkStrictPair
+ = GHC.Types.TyCon
+ 2381261223169708323#Word64
+ 3151447712495713176#Word64
+ T24124.$trModule
+ T24124.$tc'MkStrictPair2
+ 2#
+ T24124.$tc'MkStrictPair1
+
+-- RHS size: {terms: 7, types: 6, coercions: 7, joins: 0/0}
+T24124.MkStrictPair [InlPrag=CONLIKE]
+ :: forall {a} {b}. a %1 -> b %1 -> T24124.StrictPair a b
+[GblId[DataCon], Arity=2, Caf=NoCafRefs, Unf=OtherCon []]
+T24124.MkStrictPair
+ = (\ (@a[sk:1])
+ (@b[sk:1])
+ (eta [Occ=Once1] :: a)
+ (eta [Occ=Once1] :: b) ->
+ T24124.MkStrictPair @a[sk:1] @b[sk:1] eta eta)
+ `cast` (<forall {a} {b}. a %1 -> b %1 -> T24124.StrictPair a b>_R
+ :: (forall {a} {b}. a %1 -> b %1 -> T24124.StrictPair a b)
+ ~R# (forall {a} {b}. a %1 -> b %1 -> T24124.StrictPair a b))
+
+
+
=====================================
testsuite/tests/core-to-stg/all.T
=====================================
@@ -3,3 +3,4 @@
test('T19700', normal, compile, ['-O'])
test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep'])
test('T23914', normal, compile, ['-O'])
+test('T24124', [grep_errmsg(r'= .*MkStrictPair.*in')], compile, ['-O -dsuppress-uniques -ddump-prep'])
=====================================
testsuite/tests/ghci/should_run/T21052.stdout
=====================================
@@ -5,7 +5,7 @@ BCO_toplevel :: GHC.Types.IO [GHC.Types.Any]
{} \u []
let {
sat :: [GHC.Types.Any]
- [LclId] =
+ [LclId, Unf=OtherCon []] =
:! [GHC.Tuple.Prim.() GHC.Types.[]];
} in GHC.Base.returnIO sat;
=====================================
testsuite/tests/simplCore/should_compile/T23083.stderr
=====================================
@@ -14,8 +14,8 @@ T23083.g
= \ (f [Occ=Once1!] :: (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) (h [Occ=OnceL1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) ->
let {
sat [Occ=Once1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer
- [LclId]
- sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> T23083.$$ @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in
+ [LclId, Unf=OtherCon []]
+ sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1, Dmd=SL] { __DEFAULT -> T23083.$$ @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in
f sat
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
=====================================
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/T19717.stderr
=====================================
@@ -3,15 +3,15 @@
Foo.f :: forall {a}. a -> [GHC.Maybe.Maybe a]
[GblId, Arity=1, Str=<1L>, Unf=OtherCon []] =
{} \r [x]
- case x of x1 {
+ case x of x1 [Dmd=SL] {
__DEFAULT ->
let {
sat [Occ=Once1] :: GHC.Maybe.Maybe a
- [LclId] =
+ [LclId, Unf=OtherCon []] =
GHC.Maybe.Just! [x1]; } in
let {
sat [Occ=Once1] :: [GHC.Maybe.Maybe a]
- [LclId] =
+ [LclId, Unf=OtherCon []] =
:! [sat GHC.Types.[]];
} in : [sat sat];
};
=====================================
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/5c80ed4aae6ea2861b7a4eacb242ce103a0ea203...9690fdab0f8572af03de952e2656ecb45b74faed
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c80ed4aae6ea2861b7a4eacb242ce103a0ea203...9690fdab0f8572af03de952e2656ecb45b74faed
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/0336a760/attachment-0001.html>
More information about the ghc-commits
mailing list