summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSebastian Graf <sebastian.graf@kit.edu>2021-03-01 21:40:22 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-03-26 23:02:15 -0400
commit57d21e6a522f5522ba238675e74f510ab8e5d300 (patch)
tree4132fca9afc4c2ee8ca0d23266919c77fec27201
parent5741caeb0454c1bee9ca865ce6c3dfdd980ecf3e (diff)
downloadhaskell-57d21e6a522f5522ba238675e74f510ab8e5d300.tar.gz
Rubbish literals for all representations (#18983)
This patch cleans up the complexity around WW's `mk_absent_let` by broadening the scope of `LitRubbish`. Rubbish literals now store the `PrimRep` they represent and are ultimately lowered in Cmm. This in turn allows absent literals of `VecRep` or `VoidRep`. The latter allows absent literals for unlifted coercions, as requested in #18983. I took the liberty to rewrite and clean up `Note [Absent fillers]` and `Note [Rubbish values]` to account for the new implementation and to make them more orthogonal in their description. I didn't add a new regression test, as `T18982` already contains the test in the ticket and its test output changes as expected. Fixes #18983.
-rw-r--r--compiler/GHC/Builtin/Types/Prim.hs15
-rw-r--r--compiler/GHC/Cmm/LayoutStack.hs3
-rw-r--r--compiler/GHC/Cmm/Parser.y1
-rw-r--r--compiler/GHC/Core/Make.hs2
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap/Utils.hs222
-rw-r--r--compiler/GHC/Core/TyCon.hs86
-rw-r--r--compiler/GHC/Core/Utils.hs9
-rw-r--r--compiler/GHC/CoreToStg.hs10
-rw-r--r--compiler/GHC/Stg/Unarise.hs32
-rw-r--r--compiler/GHC/StgToCmm/ArgRep.hs2
-rw-r--r--compiler/GHC/StgToCmm/Env.hs20
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs7
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs-boot7
-rw-r--r--compiler/GHC/StgToCmm/Foreign.hs1
-rw-r--r--compiler/GHC/StgToCmm/Heap.hs1
-rw-r--r--compiler/GHC/StgToCmm/Layout.hs22
-rw-r--r--compiler/GHC/StgToCmm/Lit.hs105
-rw-r--r--compiler/GHC/StgToCmm/Monad.hs6
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs1
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs1
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs1
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs63
-rw-r--r--compiler/GHC/Types/Literal.hs242
-rw-r--r--compiler/GHC/Types/RepType.hs24
-rw-r--r--compiler/GHC/Utils/Misc.hs14
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--testsuite/tests/stranal/should_compile/T18982.stderr30
27 files changed, 538 insertions, 390 deletions
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index 29bb386001..115c76516d 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -35,7 +35,7 @@ module GHC.Builtin.Types.Prim(
tYPETyCon, tYPETyConName,
-- Kinds
- tYPE, primRepToRuntimeRep,
+ tYPE, primRepToRuntimeRep, primRepsToRuntimeRep,
functionWithMultiplicity,
funTyCon, funTyConName,
@@ -587,7 +587,7 @@ pcPrimTyCon name roles rep
-- Defined here to avoid (more) module loops
primRepToRuntimeRep :: PrimRep -> Type
primRepToRuntimeRep rep = case rep of
- VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]
+ VoidRep -> mkTupleRep []
LiftedRep -> liftedRepTy
UnliftedRep -> unliftedRepTy
IntRep -> intRepDataConTy
@@ -626,6 +626,17 @@ primRepToRuntimeRep rep = case rep of
FloatElemRep -> floatElemRepDataConTy
DoubleElemRep -> doubleElemRepDataConTy
+-- | Given a list of types representing 'RuntimeRep's @reps@, construct
+-- @'TupleRep' reps@.
+mkTupleRep :: [Type] -> Type
+mkTupleRep reps = TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy reps]
+
+-- | Convert a list of 'PrimRep's to a 'Type' of kind RuntimeRep
+-- Defined here to avoid (more) module loops
+primRepsToRuntimeRep :: [PrimRep] -> Type
+primRepsToRuntimeRep [rep] = primRepToRuntimeRep rep
+primRepsToRuntimeRep reps = mkTupleRep $ map primRepToRuntimeRep reps
+
pcPrimTyCon0 :: Name -> PrimRep -> TyCon
pcPrimTyCon0 name rep
= pcPrimTyCon name [] rep
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index 9e86ab58c5..ac46f23f1f 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -8,7 +8,8 @@ import GHC.Prelude hiding ((<*>))
import GHC.Platform
import GHC.Platform.Profile
-import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation
+import GHC.StgToCmm.Monad ( newTemp ) -- XXX layering violation
+import GHC.StgToCmm.Utils ( callerSaveVolatileRegs ) -- XXX layering violation
import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation
import GHC.Types.Basic
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 8a972b91d5..666441a687 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -218,6 +218,7 @@ import qualified GHC.StgToCmm.Monad as F
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Foreign
import GHC.StgToCmm.Expr
+import GHC.StgToCmm.Lit
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Layout hiding (ArgRep(..))
import GHC.StgToCmm.Ticky
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 42a1b78c0c..60ae13bee7 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -1024,7 +1024,7 @@ aBSENT_ERROR_ID
where
absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany addrPrimTy alphaTy)
-- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
- -- lifted-type things; see Note [Absent errors] in GHC.Core.Opt.WorkWrap.Utils
+ -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils
arity_info = vanillaIdInfo `setArityInfo` 1
-- NB: no bottoming strictness info, unlike other error-ids.
-- See Note [aBSENT_ERROR_ID]
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 5223e66817..f51e716c38 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -20,7 +20,7 @@ import GHC.Prelude
import GHC.Core
import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase
- , dataConRepFSInstPat )
+ , bindNonRec, dataConRepFSInstPat )
import GHC.Types.Id
import GHC.Types.Id.Info ( JoinArity )
import GHC.Core.DataCon
@@ -29,14 +29,14 @@ import GHC.Types.Cpr
import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup
, mkCoreApp, mkCoreLet )
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
-import GHC.Builtin.Types ( tupleDataCon, unboxedUnitTy )
-import GHC.Types.Literal ( absentLiteralOf, rubbishLit )
+import GHC.Builtin.Types ( tupleDataCon )
+import GHC.Types.Literal ( mkLitRubbish )
import GHC.Types.Var.Env ( mkInScopeSet )
import GHC.Types.Var.Set ( VarSet )
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Predicate ( isClassPred )
-import GHC.Types.RepType ( isVoidTy, typePrimRep )
+import GHC.Types.RepType ( isVoidTy, typeMonoPrimRep_maybe )
import GHC.Core.Coercion
import GHC.Core.FamInstEnv
import GHC.Types.Basic ( Boxity(..) )
@@ -895,9 +895,9 @@ mkWWstr_one dflags fam_envs has_inlineable_prag arg
= return (False, [arg], nop_fn, nop_fn)
| isAbsDmd dmd
- , Just work_fn <- mk_absent_let dflags fam_envs arg dmd
- -- Absent case. We can't always handle absence for arbitrary
- -- unlifted types, so we need to choose just the cases we can
+ , Just work_fn <- mk_absent_let dflags arg dmd
+ -- Absent case. We can't always handle absence for rep-polymorphic
+ -- types, so we need to choose just the cases we can
-- (that's what mk_absent_let does)
= return (True, [], nop_fn, work_fn)
@@ -1281,70 +1281,74 @@ part of the function (post transformation) anyway.
* *
************************************************************************
-Note [Absent errors]
-~~~~~~~~~~~~~~~~~~~~
+Note [Absent fillers]
+~~~~~~~~~~~~~~~~~~~~~
Consider
- data T = MkT [Int] [Int] ![Int]
- f :: T -> Int# -> blah
- f ps w = case ps of MkT xs _ _ -> <body mentioning xs>
-Then f gets a strictness sig of <S(L,A,A)><A>. We make worker $wf thus:
-
-$wf :: [Int] -> blah
-$wf xs = case ps of MkT xs _ _ -> <body mentioning xs>
- where
- ys = absentError "ys :: [Int]"
- zs = LitRubbish True
- ps = MkT xs ys zs
- w = 0#
-
-We make a let-binding for Absent arguments, such as ys and w, that are not even
-passed to the worker. They should, of course, never be used. We distinguish four
-cases:
-
-1. Ordinary boxed, lifted arguments, like 'ys' We make a new binding for Ids
- that are marked absent, thus
- let ys = absentError "ys :: [Int]"
- The idea is that this binding will never be used; but if it
- buggily is used we'll get a runtime error message.
-
-2. Boxed, lifted types, with a strict demand, like 'zs'. You may ask: how the
- demand be both absent and strict? That's exactly what happens for 'zs': it
- is not used, so its demand is Absent, but then during w/w, in
- addDataConStrictness, we strictify the demand. So it gets cardinality C_10,
- the empty interval.
-
- We don't want to use an error-thunk for 'zs' because MkT's third argument has
- a bang, and hence should be always evaluated. This turned out to be
- important when fixing #16970, which establishes the invariant that strict
- constructor arguments are always evaluated. So we use LitRubbish instead
- of an error thunk -- see #19133.
-
- These first two cases are distinguished by isStrictDmd in lifted_rhs.
-
-3. Unboxed types, like 'w', with a type like Float#, Int#. Coping with absence
- for unboxed types is important; see, for example, #4306 and #15627. We
- simply find a suitable literal, using Literal.absentLiteralOf. We don't have
- literals for every primitive type, so the function is partial.
-
-4. Boxed, unlifted types, like (Array# t). We can't use absentError because
- unlifted bindings ares strict. So we use LitRubbish, which we need to apply
- to the required type.
-
-Case (2) and (4) crucially use LitRubbish as the placeholder: see Note [Rubbish
-literals] in GHC.Types.Literal. We could do that in case (1) as well, but we
-get slightly better self-checking with an error thunk.
-Suppose we use LitRubbish and absence analysis is Wrong, so that the "absent"
-value is used after all. Then in case (2) we could get a seg-fault, because we
-may have replaced, say, a [Either Int Bool] by (), and that will fail if we do
-case analysis on it. Similarly with boxed unlifted types, case (4).
-
-In case (3), if absence analysis is wrong we could conceivably get an exception,
-from a divide-by-zero with the absent value. But it's very unlikely.
+ data T = MkT [Int] [Int] ![Int] -- NB: last field is strict
+ f :: T -> Int# -> blah
+ f ps w = case ps of MkT xs ys zs -> <body mentioning xs>
-Only in case (1) can we guarantee a civilised runtime error. Not much we can do
-about this; we really rely on absence analysis to be correct.
+Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:
+ $wf :: [Int] -> blah
+ $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>
+ where
+ ys = absentError "ys :: [Int]"
+ zs = RUBBISH[LiftedRep] @[Int]
+ ps = MkT xs ys zs
+ w = RUBBISH[IntRep] @Int#
+
+The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.
+And neither should they! They are never used, their value is irrelevant (hence
+they are *dead code*) and they are probably discarded after the next run of the
+Simplifier (when they are in fact *unreachable code*). Yet, we have to come up
+with "filler" values that we bind the absent arg Ids to.
+
+That is exactly what Note [Rubbish values] are for: A convenient way to
+conjure filler values at any type (and any representation or levity!).
+
+Needless to say, there are some wrinkles:
+
+ 1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk
+ instead. If absence analysis was wrong (e.g., #11126) and the binding
+ in fact is used, then we get a nice panic message instead of undefined
+ runtime behavior (See Modes of failure from Note [Rubbish values]).
+
+ Obviously, we can't use an error-thunk if the value is of unlifted rep
+ (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.
+
+ 2. We also mustn't put an error-thunk (that fills in for an absent value of
+ lifted rep) in a strict field, because #16970 establishes the invariant
+ that strict fields are always evaluated, by (re-)evaluating what is put in
+ a strict field. That's the reason why 'zs' binds a rubbish literal instead
+ of an error-thunk, see #19133.
+
+ How do we detect when we are about to put an error-thunk in a strict field?
+ Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but
+ it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'.
+ So we rather look out for a necessary condition for strict fields:
+ Note [Add demands for strict constructors] makes it so that the demand on
+ 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty
+ interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees
+ we never fill in an error-thunk for an absent strict field.
+ But that also means we emit a rubbish lit for other args that have
+ cardinality 'C_10' (say, the arg to a bottoming function) where we could've
+ used an error-thunk, but that's a small price to pay for simplicity.
+
+ 3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g.
+ of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.
+ Why? Because if we don't know its representation (e.g. size in memory,
+ register class), we don't know what or how much rubbish to emit in codegen.
+ 'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall
+ back to passing the original parameter to the worker.
+
+ Note that currently this case should not occur, because binders always
+ have to be representation monomorphic. But in the future, we might allow
+ levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.
+
+While (1) and (2) are simply an optimisation in terms of compiler debugging
+experience, (3) should be irrelevant in most programs, if not all.
Historical note: I did try the experiment of using an error thunk for unlifted
things too, relying on the simplifier to drop it as dead code. But this is
@@ -1368,66 +1372,46 @@ fragile
--
-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding
-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be
--- found (currently only happens for bindings of 'VecRep' representation).
-mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
-mk_absent_let dflags fam_envs arg dmd
-
- -- The lifted case: Bind 'absentError'
- -- See Note [Absent errors]
- | not (isUnliftedType arg_ty)
- = Just (Let (NonRec lifted_arg lifted_rhs))
- -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@
- -- See Note [Absent errors]
-
- | [UnliftedRep] <- typePrimRep arg_ty
- = Just (Let (NonRec arg unlifted_rhs))
-
- -- The monomorphic unlifted cases: Bind to some literal, if possible
- -- See Note [Absent errors]
- | Just tc <- tyConAppTyCon_maybe nty
- , Just lit <- absentLiteralOf tc
- = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co)))
-
- | nty `eqType` unboxedUnitTy
- = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co)))
-
- | otherwise
+-- found.
+mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
+mk_absent_let dflags arg dmd
+ -- The lifted case: Bind 'absentError' for a nice panic message if we are
+ -- wrong (like we were in #11126). See (1) in Note [Absent fillers]
+ | Just [LiftedRep] <- mb_mono_prim_reps
+ , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers]
+ = Just (Let (NonRec arg panic_rhs))
+
+ -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@
+ -- See Note [Absent fillers], the main part
+ | Just prim_reps <- mb_mono_prim_reps
+ = Just (bindNonRec arg (mkTyApps (Lit (mkLitRubbish prim_reps)) [arg_ty]))
+
+ -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep.
+ -- See (3) in Note [Absent fillers]
+ | Nothing <- mb_mono_prim_reps
= WARN( True, text "No absent value for" <+> ppr arg_ty )
- Nothing -- Can happen for 'State#' and things of 'VecRep'
+ Nothing
where
- lifted_arg = arg `setIdStrictness` botSig `setIdCprInfo` mkCprSig 0 botCpr
- -- Note in strictness signature that this is bottoming
- -- (for the sake of the "empty case scrutinee not known to
- -- diverge for sure lint" warning)
-
- lifted_rhs | isStrictDmd dmd = mkTyApps (Lit (rubbishLit True)) [arg_ty]
- | otherwise = mkAbsentErrorApp arg_ty msg
- unlifted_rhs = mkTyApps (Lit (rubbishLit False)) [arg_ty]
-
- arg_ty = idType arg
-
- -- Normalise the type to have best chance of finding an absent literal
- -- e.g. (#17852) data unlifted N = MkN Int#
- -- f :: N -> a -> a
- -- f _ x = x
- (co, nty) = topNormaliseType_maybe fam_envs arg_ty
- `orElse` (mkRepReflCo arg_ty, arg_ty)
-
- msg = showSDoc (gopt_set dflags Opt_SuppressUniques)
- (vcat
- [ text "Arg:" <+> ppr arg
- , text "Type:" <+> ppr arg_ty
- , file_msg
- ])
- file_msg = case outputFile dflags of
- Nothing -> empty
- Just f -> text "In output file " <+> quotes (text f)
+ arg_ty = idType arg
+ mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty
+
+ panic_rhs = mkAbsentErrorApp arg_ty msg
+
+ msg = showSDoc (gopt_set dflags Opt_SuppressUniques)
+ (vcat
+ [ text "Arg:" <+> ppr arg
+ , text "Type:" <+> ppr arg_ty
+ , file_msg
+ ])
-- We need to suppress uniques here because otherwise they'd
-- end up in the generated code as strings. This is bad for
-- determinism, because with different uniques the strings
-- will have different lengths and hence different costs for
-- the inliner leading to different inlining.
-- See also Note [Unique Determinism] in GHC.Types.Unique
+ file_msg = case outputFile dflags of
+ Nothing -> empty
+ Just f -> text "In output file " <+> quotes (text f)
ww_prefix :: FastString
ww_prefix = fsLit "ww"
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index 87b7336a76..a460116c3b 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-
(c) The University of Glasgow 2006
@@ -121,6 +122,7 @@ module GHC.Core.TyCon(
-- * Primitive representations of Types
PrimRep(..), PrimElemRep(..),
+ primElemRepToPrimRep,
isVoidRep, isGcPtrRep,
primRepSizeB,
primElemRepSizeB,
@@ -1480,7 +1482,7 @@ data PrimRep
| FloatRep
| DoubleRep
| VecRep Int PrimElemRep -- ^ A vector
- deriving( Eq, Show )
+ deriving( Data.Data, Eq, Ord, Show )
data PrimElemRep
= Int8ElemRep
@@ -1493,7 +1495,7 @@ data PrimElemRep
| Word64ElemRep
| FloatElemRep
| DoubleElemRep
- deriving( Eq, Show )
+ deriving( Data.Data, Eq, Ord, Show, Enum )
instance Outputable PrimRep where
ppr r = text (show r)
@@ -1501,6 +1503,50 @@ instance Outputable PrimRep where
instance Outputable PrimElemRep where
ppr r = text (show r)
+instance Binary PrimRep where
+ put_ bh VoidRep = putByte bh 0
+ put_ bh LiftedRep = putByte bh 1
+ put_ bh UnliftedRep = putByte bh 2
+ put_ bh Int8Rep = putByte bh 3
+ put_ bh Int16Rep = putByte bh 4
+ put_ bh Int32Rep = putByte bh 5
+ put_ bh Int64Rep = putByte bh 6
+ put_ bh IntRep = putByte bh 7
+ put_ bh Word8Rep = putByte bh 8
+ put_ bh Word16Rep = putByte bh 9
+ put_ bh Word32Rep = putByte bh 10
+ put_ bh Word64Rep = putByte bh 11
+ put_ bh WordRep = putByte bh 12
+ put_ bh AddrRep = putByte bh 13
+ put_ bh FloatRep = putByte bh 14
+ put_ bh DoubleRep = putByte bh 15
+ put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> pure VoidRep
+ 1 -> pure LiftedRep
+ 2 -> pure UnliftedRep
+ 3 -> pure Int8Rep
+ 4 -> pure Int16Rep
+ 5 -> pure Int32Rep
+ 6 -> pure Int64Rep
+ 7 -> pure IntRep
+ 8 -> pure Word8Rep
+ 9 -> pure Word16Rep
+ 10 -> pure Word32Rep
+ 11 -> pure Word64Rep
+ 12 -> pure WordRep
+ 13 -> pure AddrRep
+ 14 -> pure FloatRep
+ 15 -> pure DoubleRep
+ 16 -> VecRep <$> get bh <*> get bh
+ _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h))
+
+instance Binary PrimElemRep where
+ put_ bh per = putByte bh (fromIntegral (fromEnum per))
+ get bh = toEnum . fromIntegral <$> getByte bh
+
isVoidRep :: PrimRep -> Bool
isVoidRep VoidRep = True
isVoidRep _other = False
@@ -1552,19 +1598,22 @@ primRepSizeB platform = \case
LiftedRep -> platformWordSizeInBytes platform
UnliftedRep -> platformWordSizeInBytes platform
VoidRep -> 0
- (VecRep len rep) -> len * primElemRepSizeB rep
-
-primElemRepSizeB :: PrimElemRep -> Int
-primElemRepSizeB Int8ElemRep = 1
-primElemRepSizeB Int16ElemRep = 2
-primElemRepSizeB Int32ElemRep = 4
-primElemRepSizeB Int64ElemRep = 8
-primElemRepSizeB Word8ElemRep = 1
-primElemRepSizeB Word16ElemRep = 2
-primElemRepSizeB Word32ElemRep = 4
-primElemRepSizeB Word64ElemRep = 8
-primElemRepSizeB FloatElemRep = 4
-primElemRepSizeB DoubleElemRep = 8
+ (VecRep len rep) -> len * primElemRepSizeB platform rep
+
+primElemRepSizeB :: Platform -> PrimElemRep -> Int
+primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep
+
+primElemRepToPrimRep :: PrimElemRep -> PrimRep
+primElemRepToPrimRep Int8ElemRep = Int8Rep
+primElemRepToPrimRep Int16ElemRep = Int16Rep
+primElemRepToPrimRep Int32ElemRep = Int32Rep
+primElemRepToPrimRep Int64ElemRep = Int64Rep
+primElemRepToPrimRep Word8ElemRep = Word8Rep
+primElemRepToPrimRep Word16ElemRep = Word16Rep
+primElemRepToPrimRep Word32ElemRep = Word32Rep
+primElemRepToPrimRep Word64ElemRep = Word64Rep
+primElemRepToPrimRep FloatElemRep = FloatRep
+primElemRepToPrimRep DoubleElemRep = DoubleRep
-- | Return if Rep stands for floating type,
-- returns Nothing for vector types.
@@ -1574,7 +1623,6 @@ primRepIsFloat DoubleRep = Just True
primRepIsFloat (VecRep _ _) = Nothing
primRepIsFloat _ = Just False
-
{-
************************************************************************
* *
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 3f228f747d..6b779ef1aa 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -1609,11 +1609,14 @@ expr_ok primop_ok (Case scrut bndr _ alts)
expr_ok primop_ok other_expr
| (expr, args) <- collectArgs other_expr
= case stripTicksTopE (not . tickishCounts) expr of
- Var f -> app_ok primop_ok f args
+ Var f -> app_ok primop_ok f args
-- 'LitRubbish' is the only literal that can occur in the head of an
-- application and will not be matched by the above case (Var /= Lit).
- Lit lit -> ASSERT( isRubbishLit lit ) True
- _ -> False
+ Lit LitRubbish{} -> True
+#if defined(DEBUG)
+ Lit _ -> pprPanic "Non-rubbish lit in app head" (ppr other_expr)
+#endif
+ _ -> False
-----------------------------
app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index d8a6dd0e95..1158fcde39 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -39,7 +39,7 @@ import GHC.Types.Var.Env
import GHC.Unit.Module
import GHC.Types.Name ( isExternalName, nameModule_maybe )
import GHC.Types.Basic ( Arity )
-import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId )
+import GHC.Builtin.Types ( unboxedUnitDataCon )
import GHC.Types.Literal
import GHC.Utils.Outputable
import GHC.Utils.Monad
@@ -388,12 +388,8 @@ coreToStgExpr
-- CorePrep should have converted them all to a real core representation.
coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger"
coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural"
-coreToStgExpr (Lit l) = return (StgLit l)
-coreToStgExpr (App (Lit lit) _some_boxed_type)
- | isRubbishLit lit
- -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
- -- a STG to Cmm pass. Doesn't matter whether it is lifted or unlifted
- = coreToStgExpr (Var unitDataConId)
+coreToStgExpr (Lit l) = return (StgLit l)
+coreToStgExpr (App l@(Lit LitRubbish{}) Type{}) = coreToStgExpr l
coreToStgExpr (Var v) = coreToStgApp v [] []
coreToStgExpr (Coercion _)
-- See Note [Coercion tokens]
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index c9160ff72a..03c2deb03e 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -193,6 +193,9 @@ STG programs after unarisation have these invariants:
This means that it's safe to wrap `StgArg`s of DataCon applications with
`GHC.StgToCmm.Env.NonVoid`, for example.
+ * Similar to unboxed tuples, Note [Rubbish values] of TupleRep may only
+ appear in return position.
+
* Alt binders (binders in patterns) are always non-void.
* Binders always have zero (for void arguments) or one PrimRep.
@@ -207,6 +210,7 @@ import GHC.Prelude
import GHC.Types.Basic
import GHC.Core
import GHC.Core.DataCon
+import GHC.Core.TyCon ( isVoidRep )
import GHC.Data.FastString (FastString, mkFastString)
import GHC.Types.Id
import GHC.Types.Literal
@@ -349,6 +353,11 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts)
, Just args' <- unariseMulti_maybe rho dc args ty_args
= elimCase rho args' bndr alt_ty alts
+ -- See (3) of Note [Rubbish values] in GHC.Types.Literal
+ | StgLit lit <- scrut
+ , Just args' <- unariseRubbish_maybe lit
+ = elimCase rho args' bndr alt_ty alts
+
-- general case
| otherwise
= do scrut' <- unariseExpr rho scrut
@@ -379,6 +388,22 @@ unariseMulti_maybe rho dc args ty_args
| otherwise
= Nothing
+-- Doesn't return void args.
+unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
+unariseRubbish_maybe lit
+ | LitRubbish preps <- lit
+ , [prep] <- preps
+ , not (isVoidRep prep)
+ -- Single, non-void PrimRep. Nothing to do!
+ = Nothing
+
+ | LitRubbish preps <- lit
+ -- Multiple reps, possibly with VoidRep. Eliminate!
+ = Just [ StgLitArg (LitRubbish [prep]) | prep <- preps, not (isVoidRep prep) ]
+
+ | otherwise
+ = Nothing
+
--------------------------------------------------------------------------------
elimCase :: UnariseEnv
@@ -719,8 +744,11 @@ unariseConArg rho (StgVarArg x) =
-- Here realWorld# is not in the envt, but
-- is a void, and so should be eliminated
| otherwise -> [StgVarArg x]
-unariseConArg _ arg@(StgLitArg lit) =
- ASSERT(not (isVoidTy (literalType lit))) -- We have no void literals
+unariseConArg _ arg@(StgLitArg lit)
+ | Just as <- unariseRubbish_maybe lit
+ = as
+ | otherwise
+ = ASSERT(not (isVoidTy (literalType lit))) -- We have no non-rubbish void literals
[arg]
unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs
index 8fc1796d6f..2ec0e177e8 100644
--- a/compiler/GHC/StgToCmm/ArgRep.hs
+++ b/compiler/GHC/StgToCmm/ArgRep.hs
@@ -87,7 +87,7 @@ toArgRep platform rep = case rep of
PW8 -> N
FloatRep -> F
DoubleRep -> D
- (VecRep len elem) -> case len*primElemRepSizeB elem of
+ (VecRep len elem) -> case len*primElemRepSizeB platform elem of
16 -> V16
32 -> V32
64 -> V64
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index ebfff0185f..5f4ef641c4 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -17,7 +17,6 @@ module GHC.StgToCmm.Env (
bindArgsToRegs, bindToReg, rebindToReg,
bindArgToReg, idToReg,
- getArgAmode, getNonVoidArgAmodes,
getCgIdInfo,
maybeLetNoEscape,
) where
@@ -26,10 +25,8 @@ module GHC.StgToCmm.Env (
import GHC.Prelude
-import GHC.Core.TyCon
import GHC.Platform
import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.Cmm.CLabel
@@ -40,7 +37,6 @@ import GHC.Cmm.Utils
import GHC.Types.Id
import GHC.Cmm.Graph
import GHC.Types.Name
-import GHC.Stg.Syntax
import GHC.Core.Type
import GHC.Builtin.Types.Prim
import GHC.Types.Unique.FM
@@ -162,22 +158,6 @@ cgLookupPanic id
])
---------------------
-getArgAmode :: NonVoid StgArg -> FCode CmmExpr
-getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
-getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit
-
-getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
--- NB: Filters out void args,
--- so the result list may be shorter than the argument list
-getNonVoidArgAmodes [] = return []
-getNonVoidArgAmodes (arg:args)
- | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
- | otherwise = do { amode <- getArgAmode (NonVoid arg)
- ; amodes <- getNonVoidArgAmodes args
- ; return ( amode : amodes ) }
-
-
------------------------------------------------------------------------
-- Interface functions for binding and re-binding names
------------------------------------------------------------------------
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 1b57fc3813..dbc2a9ea06 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -10,7 +10,7 @@
--
-----------------------------------------------------------------------------
-module GHC.StgToCmm.Expr ( cgExpr ) where
+module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where
#include "HsVersions.h"
@@ -24,6 +24,7 @@ import GHC.StgToCmm.Env
import GHC.StgToCmm.DataCon
import GHC.StgToCmm.Prof (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)
import GHC.StgToCmm.Layout
+import GHC.StgToCmm.Lit
import GHC.StgToCmm.Prim
import GHC.StgToCmm.Hpc
import GHC.StgToCmm.Ticky
@@ -115,8 +116,8 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
cgExpr (StgOpApp op args ty) = cgOpApp op args ty
cgExpr (StgConApp con mn args _) = cgConApp con mn args
cgExpr (StgTick t e) = cgTick t >> cgExpr e
-cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
- emitReturn [CmmLit cmm_lit]
+cgExpr (StgLit lit) = do cmm_expr <- cgLit lit
+ emitReturn [cmm_expr]
cgExpr (StgLet _ binds expr) = do { cgBind binds; cgExpr expr }
cgExpr (StgLetNoEscape _ binds expr) =
diff --git a/compiler/GHC/StgToCmm/Expr.hs-boot b/compiler/GHC/StgToCmm/Expr.hs-boot
new file mode 100644
index 0000000000..5dd63a81dc
--- /dev/null
+++ b/compiler/GHC/StgToCmm/Expr.hs-boot
@@ -0,0 +1,7 @@
+module GHC.StgToCmm.Expr where
+
+import GHC.Cmm.Expr
+import GHC.StgToCmm.Monad
+import GHC.Types.Literal
+
+cgLit :: Literal -> FCode CmmExpr
diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs
index 21c85d569c..95fa21d648 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs
+++ b/compiler/GHC/StgToCmm/Foreign.hs
@@ -27,7 +27,6 @@ import GHC.Platform.Profile
import GHC.Stg.Syntax
import GHC.StgToCmm.Prof (storeCurCCS, ccsType)
-import GHC.StgToCmm.Env
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs
index 62b9785ed6..16161cb028 100644
--- a/compiler/GHC/StgToCmm/Heap.hs
+++ b/compiler/GHC/StgToCmm/Heap.hs
@@ -32,7 +32,6 @@ import GHC.StgToCmm.Monad
import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr)
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Env
import GHC.Cmm.Graph
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index e45955d119..d10d7f6345 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -26,7 +26,8 @@ module GHC.StgToCmm.Layout (
mkVirtConstrSizes,
getHpRelOffset,
- ArgRep(..), toArgRep, argRepSizeW -- re-exported from GHC.StgToCmm.ArgRep
+ ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
+ getArgAmode, getNonVoidArgAmodes
) where
@@ -42,6 +43,7 @@ import GHC.StgToCmm.Env
import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Monad
+import GHC.StgToCmm.Lit
import GHC.StgToCmm.Utils
import GHC.Cmm.Graph
@@ -591,6 +593,24 @@ stdPattern reps
_ -> Nothing
-------------------------------------------------------------------------
+-- Amodes for arguments
+-------------------------------------------------------------------------
+
+getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
+getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit
+
+getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
+-- NB: Filters out void args,
+-- so the result list may be shorter than the argument list
+getNonVoidArgAmodes [] = return []
+getNonVoidArgAmodes (arg:args)
+ | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
+ | otherwise = do { amode <- getArgAmode (NonVoid arg)
+ ; amodes <- getNonVoidArgAmodes args
+ ; return ( amode : amodes ) }
+
+-------------------------------------------------------------------------
--
-- Generating the info table and code for a closure
--
diff --git a/compiler/GHC/StgToCmm/Lit.hs b/compiler/GHC/StgToCmm/Lit.hs
new file mode 100644
index 0000000000..244a593f9a
--- /dev/null
+++ b/compiler/GHC/StgToCmm/Lit.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE CPP, LambdaCase #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation: literals
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module GHC.StgToCmm.Lit (
+ cgLit, mkSimpleLit,
+ newStringCLit, newByteStringCLit
+ ) where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.StgToCmm.Monad
+import GHC.StgToCmm.Env
+import GHC.Cmm
+import GHC.Cmm.CLabel
+import GHC.Cmm.Utils
+
+import GHC.Types.Literal
+import GHC.Builtin.Types ( unitDataConId )
+import GHC.Core.TyCon
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS8
+import Data.Char (ord)
+
+newStringCLit :: String -> FCode CmmLit
+-- ^ Make a global definition for the string,
+-- and return its label
+newStringCLit str = newByteStringCLit (BS8.pack str)
+
+newByteStringCLit :: ByteString -> FCode CmmLit
+newByteStringCLit bytes
+ = do { uniq <- newUnique
+ ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
+ ; emitDecl decl
+ ; return lit }
+
+cgLit :: Literal -> FCode CmmExpr
+cgLit (LitString s) =
+ CmmLit <$> newByteStringCLit s
+ -- not unpackFS; we want the UTF-8 byte stream.
+cgLit (LitRubbish preps) =
+ case expectOnly "cgLit:Rubbish" preps of -- Note [Post-unarisation invariants]
+ VoidRep -> panic "cgLit:VoidRep" -- dito
+ LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId
+ UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId
+ AddrRep -> cgLit LitNullAddr
+ VecRep n elem -> do
+ platform <- getPlatform
+ let elem_lit = mkSimpleLit platform (num_rep_lit (primElemRepToPrimRep elem))
+ pure (CmmLit (CmmVec (replicate n elem_lit)))
+ prep -> cgLit (num_rep_lit prep)
+ where
+ num_rep_lit IntRep = mkLitIntUnchecked 0
+ num_rep_lit Int8Rep = mkLitInt8Unchecked 0
+ num_rep_lit Int16Rep = mkLitInt16Unchecked 0
+ num_rep_lit Int32Rep = mkLitInt32Unchecked 0
+ num_rep_lit Int64Rep = mkLitInt64Unchecked 0
+ num_rep_lit WordRep = mkLitWordUnchecked 0
+ num_rep_lit Word8Rep = mkLitWord8Unchecked 0
+ num_rep_lit Word16Rep = mkLitWord16Unchecked 0
+ num_rep_lit Word32Rep = mkLitWord32Unchecked 0
+ num_rep_lit Word64Rep = mkLitWord64Unchecked 0
+ num_rep_lit FloatRep = LitFloat 0
+ num_rep_lit DoubleRep = LitDouble 0
+ num_rep_lit other = pprPanic "num_rep_lit: Not a num lit" (ppr other)
+cgLit other_lit = do
+ platform <- getPlatform
+ pure (CmmLit (mkSimpleLit platform other_lit))
+
+mkSimpleLit :: Platform -> Literal -> CmmLit
+mkSimpleLit platform = \case
+ (LitChar c) -> CmmInt (fromIntegral (ord c))
+ (wordWidth platform)
+ LitNullAddr -> zeroCLit platform
+ (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform)
+ (LitNumber LitNumInt8 i) -> CmmInt i W8
+ (LitNumber LitNumInt16 i) -> CmmInt i W16
+ (LitNumber LitNumInt32 i) -> CmmInt i W32
+ (LitNumber LitNumInt64 i) -> CmmInt i W64
+ (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform)
+ (LitNumber LitNumWord8 i) -> CmmInt i W8
+ (LitNumber LitNumWord16 i) -> CmmInt i W16
+ (LitNumber LitNumWord32 i) -> CmmInt i W32
+ (LitNumber LitNumWord64 i) -> CmmInt i W64
+ (LitFloat r) -> CmmFloat r W32
+ (LitDouble r) -> CmmFloat r W64
+ (LitLabel fs ms fod)
+ -> let -- TODO: Literal labels might not actually be in the current package...
+ labelSrc = ForeignLabelInThisPackage
+ in CmmLabel (mkForeignLabel fs ms labelSrc fod)
+ other -> pprPanic "mkSimpleLit" (ppr other)
+
diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs
index 98720a2f50..c2c3b93125 100644
--- a/compiler/GHC/StgToCmm/Monad.hs
+++ b/compiler/GHC/StgToCmm/Monad.hs
@@ -24,6 +24,8 @@ module GHC.StgToCmm.Monad (
emitOutOfLine, emitAssign, emitStore,
emitComment, emitTick, emitUnwind,
+ newTemp,
+
getCmm, aGraphToGraph, getPlatform, getProfile,
getCodeR, getCode, getCodeScoped, getHeapUsage,
getCallOpts, getPtrOpts,
@@ -479,6 +481,10 @@ newUnique = do
setState $ state { cgs_uniqs = us' }
return u
+newTemp :: MonadUnique m => CmmType -> m LocalReg
+newTemp rep = do { uniq <- getUniqueM
+ ; return (LocalReg uniq rep) }
+
------------------
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 484863d37a..fbd08b55a9 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -25,7 +25,6 @@ import GHC.Platform.Profile
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Foreign
-import GHC.StgToCmm.Env
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Ticky
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
index f0b9b2ae8c..08a06f3242 100644
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ b/compiler/GHC/StgToCmm/Prof.hs
@@ -36,6 +36,7 @@ import GHC.Platform.Profile
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Monad
+import GHC.StgToCmm.Lit
import GHC.Runtime.Heap.Layout
import GHC.Cmm.Graph
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index 44a99a0cae..e9e67f6b83 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -109,6 +109,7 @@ import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString )
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Monad
+import GHC.StgToCmm.Lit ( newStringCLit )
import GHC.Stg.Syntax
import GHC.Cmm.Expr
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index 86d8a8d842..35af67cc54 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
--
@@ -10,11 +9,10 @@
-----------------------------------------------------------------------------
module GHC.StgToCmm.Utils (
- cgLit, mkSimpleLit,
emitDataLits, emitRODataLits,
emitDataCon,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
- assignTemp, newTemp,
+ assignTemp,
newUnboxedTupleRegs,
@@ -38,7 +36,6 @@ module GHC.StgToCmm.Utils (
cmmUntag, cmmIsTagged,
addToMem, addToMemE, addToMemLblE, addToMemLbl,
- newStringCLit, newByteStringCLit,
-- * Update remembered set operations
whenUpdRemSetEnabled,
@@ -55,6 +52,7 @@ import GHC.Prelude
import GHC.Platform
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Closure
+import GHC.StgToCmm.Lit (mkSimpleLit)
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Graph as CmmGraph
@@ -74,7 +72,6 @@ import GHC.Types.Literal
import GHC.Data.Graph.Directed
import GHC.Utils.Misc
import GHC.Types.Unique
-import GHC.Types.Unique.Supply (MonadUnique(..))
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Outputable
@@ -83,10 +80,7 @@ import GHC.Types.RepType
import GHC.Types.CostCentre
import GHC.Types.IPE
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
-import Data.Char
import Data.List (sortBy)
import Data.Ord
import GHC.Types.Unique.Map
@@ -98,42 +92,6 @@ import GHC.Types.Unique.FM
import GHC.Data.Maybe
import Control.Monad
--------------------------------------------------------------------------
---
--- Literals
---
--------------------------------------------------------------------------
-
-cgLit :: Literal -> FCode CmmLit
-cgLit (LitString s) = newByteStringCLit s
- -- not unpackFS; we want the UTF-8 byte stream.
-cgLit other_lit = do platform <- getPlatform
- return (mkSimpleLit platform other_lit)
-
-mkSimpleLit :: Platform -> Literal -> CmmLit
-mkSimpleLit platform = \case
- (LitChar c) -> CmmInt (fromIntegral (ord c))
- (wordWidth platform)
- LitNullAddr -> zeroCLit platform
- (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform)
- (LitNumber LitNumInt8 i) -> CmmInt i W8
- (LitNumber LitNumInt16 i) -> CmmInt i W16
- (LitNumber LitNumInt32 i) -> CmmInt i W32
- (LitNumber LitNumInt64 i) -> CmmInt i W64
- (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform)
- (LitNumber LitNumWord8 i) -> CmmInt i W8
- (LitNumber LitNumWord16 i) -> CmmInt i W16
- (LitNumber LitNumWord32 i) -> CmmInt i W32
- (LitNumber LitNumWord64 i) -> CmmInt i W64
- (LitFloat r) -> CmmFloat r W32
- (LitDouble r) -> CmmFloat r W64
- (LitLabel fs ms fod)
- -> let -- TODO: Literal labels might not actually be in the current package...
- labelSrc = ForeignLabelInThisPackage
- in CmmLabel (mkForeignLabel fs ms labelSrc fod)
- -- NB: LitRubbish should have been lowered in "CoreToStg"
- other -> pprPanic "mkSimpleLit" (ppr other)
-
--------------------------------------------------------------------------
--
-- Incrementing a memory location
@@ -302,18 +260,6 @@ emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon lbl itbl ccs payload =
emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))
-newStringCLit :: String -> FCode CmmLit
--- Make a global definition for the string,
--- and return its label
-newStringCLit str = newByteStringCLit (BS8.pack str)
-
-newByteStringCLit :: ByteString -> FCode CmmLit
-newByteStringCLit bytes
- = do { uniq <- newUnique
- ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
- ; emitDecl decl
- ; return lit }
-
-------------------------------------------------------------------------
--
-- Assigning expressions to temporaries
@@ -335,10 +281,6 @@ assignTemp e = do { platform <- getPlatform
; emitAssign (CmmLocal reg) e
; return reg }
-newTemp :: MonadUnique m => CmmType -> m LocalReg
-newTemp rep = do { uniq <- getUniqueM
- ; return (LocalReg uniq rep) }
-
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
-- Choose suitable local regs to use for the components
-- of an unboxed tuple that we are about to return to
@@ -605,7 +547,6 @@ assignTemp' e
emitAssign reg e
return (CmmReg reg)
-
---------------------------------------------------------------------------
-- Pushing to the update remembered set
---------------------------------------------------------------------------
diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs
index be23f2405e..3d41444848 100644
--- a/compiler/GHC/Types/Literal.hs
+++ b/compiler/GHC/Types/Literal.hs
@@ -20,23 +20,23 @@ module GHC.Types.Literal
-- ** Creating Literals
, mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked
- , mkLitWord, mkLitWordWrap, mkLitWordWrapC
- , mkLitInt8, mkLitInt8Wrap
- , mkLitWord8, mkLitWord8Wrap
- , mkLitInt16, mkLitInt16Wrap
- , mkLitWord16, mkLitWord16Wrap
- , mkLitInt32, mkLitInt32Wrap
- , mkLitWord32, mkLitWord32Wrap
- , mkLitInt64, mkLitInt64Wrap
- , mkLitWord64, mkLitWord64Wrap
+ , mkLitWord, mkLitWordWrap, mkLitWordWrapC, mkLitWordUnchecked
+ , mkLitInt8, mkLitInt8Wrap, mkLitInt8Unchecked
+ , mkLitWord8, mkLitWord8Wrap, mkLitWord8Unchecked
+ , mkLitInt16, mkLitInt16Wrap, mkLitInt16Unchecked
+ , mkLitWord16, mkLitWord16Wrap, mkLitWord16Unchecked
+ , mkLitInt32, mkLitInt32Wrap, mkLitInt32Unchecked
+ , mkLitWord32, mkLitWord32Wrap, mkLitWord32Unchecked
+ , mkLitInt64, mkLitInt64Wrap, mkLitInt64Unchecked
+ , mkLitWord64, mkLitWord64Wrap, mkLitWord64Unchecked
, mkLitFloat, mkLitDouble
, mkLitChar, mkLitString
, mkLitInteger, mkLitNatural
, mkLitNumber, mkLitNumberWrap
+ , mkLitRubbish
-- ** Operations on Literals
, literalType
- , absentLiteralOf
, pprLiteral
, litNumIsSigned
, litNumCheckRange
@@ -61,7 +61,6 @@ module GHC.Types.Literal
, charToIntLit, intToCharLit
, floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit
, nullAddrLit, floatToDoubleLit, doubleToFloatLit
- , rubbishLit, isRubbishLit
) where
#include "HsVersions.h"
@@ -70,7 +69,6 @@ import GHC.Prelude
import GHC.Builtin.Types.Prim
import {-# SOURCE #-} GHC.Builtin.Types
-import GHC.Builtin.Names
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Utils.Outputable
@@ -79,7 +77,6 @@ import GHC.Types.Basic
import GHC.Utils.Binary
import GHC.Settings.Constants
import GHC.Platform
-import GHC.Types.Unique.FM
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -114,8 +111,7 @@ import Numeric ( fromRat )
-- * The literal derived from the label mentioned in a \"foreign label\"
-- declaration ('LitLabel')
--
--- * A 'LitRubbish' to be used in place of values of 'UnliftedRep'
--- (i.e. 'MutVar#') when the value is never used.
+-- * A 'LitRubbish' to be used in place of values that are never used.
--
-- * A character
-- * A string
@@ -138,10 +134,13 @@ data Literal
-- that can be represented as a Literal. Create
-- with 'nullAddrLit'
- | LitRubbish Bool -- ^ A nonsense value; always boxed, but
- -- True <=> lifted, False <=> unlifted
- -- Used when a binding is absent.
- -- See Note [Rubbish literals]
+ | LitRubbish [PrimRep] -- ^ A nonsense value of the given
+ -- representation. See Note [Rubbish values].
+ --
+ -- The @[PrimRep]@ of a 'Type' can be obtained
+ -- from 'typeMonoPrimRep_maybe'. The field
+ -- becomes empty or singleton post-unarisation,
+ -- see Note [Post-unarisation invariants].
| LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat'
| LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble'
@@ -194,6 +193,12 @@ litNumIsSigned nt = case nt of
LitNumWord32 -> False
LitNumWord64 -> False
+instance Binary LitNumType where
+ put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
+ get bh = do
+ h <- getByte bh
+ return (toEnum (fromIntegral h))
+
{-
Note [BigNum literals]
~~~~~~~~~~~~~~~~~~~~~~
@@ -225,12 +230,6 @@ for more details.
-}
-instance Binary LitNumType where
- put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
- get bh = do
- h <- getByte bh
- return (toEnum (fromIntegral h))
-
instance Binary Literal where
put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa
put_ bh (LitString ab) = do putByte bh 1; put_ bh ab
@@ -272,9 +271,10 @@ instance Binary Literal where
nt <- get bh
i <- get bh
return (LitNumber nt i)
- _ -> do
+ 7 -> do
b <- get bh
return (LitRubbish b)
+ _ -> pprPanic "Binary:Literal" (int (fromIntegral h))
instance Outputable Literal where
ppr = pprLiteral id
@@ -555,6 +555,12 @@ mkLitNatural :: Integer -> Literal
mkLitNatural x = ASSERT2( inNaturalRange x, integer x )
(LitNumber LitNumNatural x)
+-- | Create a rubbish literal of the given representation.
+-- The representation of a 'Type' can be obtained via 'typeMonoPrimRep_maybe'.
+-- See Note [Rubbish values].
+mkLitRubbish :: [PrimRep] -> Literal
+mkLitRubbish = LitRubbish
+
inNaturalRange :: Integer -> Bool
inNaturalRange x = x >= 0
@@ -694,14 +700,6 @@ doubleToFloatLit l = pprPanic "doubleToFloatLit" (ppr l)
nullAddrLit :: Literal
nullAddrLit = LitNullAddr
--- | A rubbish literal; see Note [Rubbish literals]
-rubbishLit :: Bool -> Literal
-rubbishLit is_lifted = LitRubbish is_lifted
-
-isRubbishLit :: Literal -> Bool
-isRubbishLit (LitRubbish {}) = True
-isRubbishLit _ = False
-
{-
Predicates
~~~~~~~~~~
@@ -797,7 +795,8 @@ litIsLifted (LitNumber nt _) = case nt of
LitNumWord16 -> False
LitNumWord32 -> False
LitNumWord64 -> False
-litIsLifted _ = False
+litIsLifted _ = False
+ -- Even RUBBISH[LiftedRep] is unlifted, as rubbish values are always evaluated.
{-
Types
@@ -825,40 +824,10 @@ literalType (LitNumber lt _) = case lt of
LitNumWord16 -> word16PrimTy
LitNumWord32 -> word32PrimTy
LitNumWord64 -> word64PrimTy
-literalType (LitRubbish is_lifted) = mkForAllTy a Inferred (mkTyVarTy a)
+literalType (LitRubbish preps) = mkForAllTy a Inferred (mkTyVarTy a)
where
- -- See Note [Rubbish literals]
- a | is_lifted = alphaTyVar
- | otherwise = alphaTyVarUnliftedRep
-
-absentLiteralOf :: TyCon -> Maybe Literal
--- Return a literal of the appropriate primitive
--- TyCon, to use as a placeholder when it doesn't matter
--- Rubbish literals are handled in GHC.Core.Opt.WorkWrap.Utils, because
--- 1. Looking at the TyCon is not enough, we need the actual type
--- 2. This would need to return a type application to a literal
-absentLiteralOf tc = lookupUFM absent_lits tc
-
--- We do not use TyConEnv here to avoid import cycles.
-absent_lits :: UniqFM TyCon Literal
-absent_lits = listToUFM_Directly
- -- Explicitly construct the mape from the known
- -- keys of these tyCons.
- [ (addrPrimTyConKey, LitNullAddr)
- , (charPrimTyConKey, LitChar 'x')
- , (intPrimTyConKey, mkLitIntUnchecked 0)
- , (int8PrimTyConKey, mkLitInt8Unchecked 0)
- , (int16PrimTyConKey, mkLitInt16Unchecked 0)
- , (int32PrimTyConKey, mkLitInt32Unchecked 0)
- , (int64PrimTyConKey, mkLitInt64Unchecked 0)
- , (wordPrimTyConKey, mkLitWordUnchecked 0)
- , (word8PrimTyConKey, mkLitWord8Unchecked 0)
- , (word16PrimTyConKey, mkLitWord16Unchecked 0)
- , (word32PrimTyConKey, mkLitWord32Unchecked 0)
- , (word64PrimTyConKey, mkLitWord64Unchecked 0)
- , (floatPrimTyConKey, LitFloat 0)
- , (doublePrimTyConKey, LitDouble 0)
- ]
+ -- See Note [Rubbish values]
+ a = head $ mkTemplateTyVars [tYPE (primRepsToRuntimeRep preps)]
{-
Comparison
@@ -910,9 +879,8 @@ pprLiteral add_par (LitLabel l mb fod) =
where b = case mb of
Nothing -> pprHsString l
Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
-pprLiteral _ (LitRubbish is_lifted)
- = text "__RUBBISH"
- <> parens (if is_lifted then text "lifted" else text "unlifted")
+pprLiteral _ (LitRubbish reps)
+ = text "RUBBISH" <> ppr reps
pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc
-- See Note [Printing of literals in Core].
@@ -954,61 +922,77 @@ LitFloat -1.0#
LitDouble -1.0##
LitInteger -1 (-1)
LitLabel "__label" ... ("__label" ...)
-LitRubbish "__RUBBISH"
-
-Note [Rubbish literals]
-~~~~~~~~~~~~~~~~~~~~~~~
-During worker/wrapper after demand analysis, where an argument
-is unused (absent) we do the following w/w split (supposing that
-y is absent):
-
- f x y z = e
-===>
- f x y z = $wf x z
- $wf x z = let y = <absent value>
- in e
-
-Usually the binding for y is ultimately optimised away, and
-even if not it should never be evaluated -- but that's the
-way the w/w split starts off.
-
-What is <absent value>?
-* For lifted values <absent value> can be a call to 'error'.
-* For primitive types like Int# or Word# we can use any random
- value of that type.
-* But what about /unlifted/ but /boxed/ types like MutVar# or
- Array#? Or /lifted/ but /strict/ values, such as a field of
- a strict data constructor. For these we use LitRubbish.
- See Note [Absent errors] in GHC.Core.Opt.WorkWrap.Utils.hs
-
-The literal (LitRubbish is_lifted)
-has type
- LitRubbish :: forall (a :: TYPE LiftedRep). a if is_lifted
- LitRubbish :: forall (a :: TYPE UnliftedRep). a otherwise
-
-So we might see a w/w split like
- $wf x z = let y :: Array# Int = (LitRubbish False) @(Array# Int)
- in e
-
-Here are the moving parts, but see also Note [Absent errors] in
-GHC.Core.Opt.WorkWrap.Utils
-
-* We define LitRubbish as a constructor in GHC.Types.Literal.Literal
-
-* It is given its polymorphic type by Literal.literalType
-
-* GHC.Core.Opt.WorkWrap.Utils.mk_absent_let introduces a LitRubbish for absent
- arguments of boxed, unlifted type; or boxed, lifted arguments of strict data
- constructors.
-
-* In CoreToSTG we convert (RubishLit @t) to just (). STG is untyped, so this
- will work OK for both lifted and unlifted (but boxed) values. The important
- thing is that it is a heap pointer, which the garbage collector can follow if
- it encounters it.
-
- We considered maintaining LitRubbish in STG, and lowering it in the code
- generators, but it seems simpler to do it once and for all in CoreToSTG.
-
- In GHC.ByteCode.Asm we just lower it as a 0 literal, because it's all boxed to
- the host GC anyway.
--}
+LitRubbish "RUBBISH[...]"
+
+Note [Rubbish values]
+~~~~~~~~~~~~~~~~~~~~~
+Sometimes, we need to cough up a rubbish value of a certain type that is used
+in place of dead code we thus aim to eliminate. The value of a dead occurrence
+has no effect on the dynamic semantics of the program, so we can pick any value
+of the same representation.
+Exploiting the results of absence analysis in worker/wrapper is a scenario where
+we need such a rubbish value, see Note [Absent fillers] for examples.
+
+It's completely undefined what the *value* of a rubbish value is, e.g., we could
+pick @0#@ for @Int#@ or @42#@; it mustn't matter where it's inserted into a Core
+program. We embed these rubbish values in the 'LitRubbish' case of the 'Literal'
+data type. Here are the moving parts:
+
+ 1. Source Haskell: No way to produce rubbish lits in source syntax. Purely
+ an IR feature.
+
+ 2. Core: 'LitRubbish' carries a @[PrimRep]@ which represents the monomorphic
+ 'RuntimeRep' of the type it is substituting for.
+ We have it that @RUBBISH[IntRep]@ has type @forall (a :: TYPE IntRep). a@,
+ and the type application @RUBBISH[IntRep] \@Int# :: Int#@ represents
+ a rubbish value of type @Int#@. Rubbish lits are completely opaque in Core.
+ In general, @RUBBISH[preps] :: forall (a :: TYPE rep). a@, where @rep@
+ is the 'RuntimeRep' corresponding to @preps :: [PrimRep]@
+ (via 'primRepsToRuntimeRep'). See 'literalType'.
+ Why not encode a 'RuntimeRep' via a @Type@? Thus
+ > data Literal = ... | LitRubbish Type | ...
+ Because
+ * We have to provide an Eq and Ord instance and @Type@ has none
+ * The encoded @Type@ might be polymorphic and we can only emit code for
+ monomorphic 'RuntimeRep's anyway.
+
+ 3. STG: The type app in @RUBBISH[IntRep] \@Int# :: Int#@ is erased and we get
+ the (untyped) 'StgLit' @RUBBISH[IntRep] :: Int#@ in STG.
+ It's treated mostly opaque, with the exception of the Unariser, where we
+ take apart a case scrutinisation on, or arg occurrence of, e.g.,
+ @RUBBISH[IntRep,DoubleRep]@ (which may stand in for @(# Int#, Double# #)@)
+ into its sub-parts @RUBBISH[IntRep]@ and @RUBBISH[DoubleRep]@, similar to
+ unboxed tuples. @RUBBISH[VoidRep]@ is erased.
+ See 'unariseRubbish_maybe' and also Note [Post-unarisation invariants].
+
+ 4. Cmm: We translate 'LitRubbish' to their actual rubbish value in 'cgLit'.
+ The particulars are boring, and only matter when debugging illicit use of
+ a rubbish value; see Modes of failure below.
+
+ 5. Bytecode: In GHC.ByteCode.Asm we just lower it as a 0 literal, because it's
+ all boxed to the host GC anyway.
+
+Why not lower LitRubbish in CoreToStg? Because it enables us to use RubbishLit
+when unarising unboxed sums in the future, and it allows rubbish values of e.g.
+VecRep, for which we can't cough up dummy values in STG.
+
+Modes of failure
+----------------
+Suppose there is a bug in GHC, and a rubbish value is used after all. That is
+undefined behavior, of course, but let us list a few examples for failure modes:
+
+ a) For an value of unboxed numeric type like @Int#@, we just use a silly
+ value like 42#. The error might propoagate indefinitely, hence we better
+ pick a rather unique literal. Same for Word, Floats, Char and VecRep.
+ b) For AddrRep (like String lits), we mit a null pointer, resulting in a
+ definitive segfault when accessed.
+ c) For boxed values, unlifted or not, we use a pointer to a fixed closure,
+ like @()@, so that the GC has a pointer to follow.
+ If we use that pointer as an 'Array#', we will likely access fields of the
+ array that don't exist, and a seg-fault is likely, but not guaranteed.
+ If we use that pointer as @Either Int Bool@, we might try to access the
+ 'Int' field of the 'Left' constructor (which has the same ConTag as '()'),
+ which doesn't exists. In the best case, we'll find an invalid pointer in its
+ position and get a seg-fault, in the worst case the error manifests only one
+ or two indirections later.
+ -}
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index 2957dddb5d..017b7cc3da 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -11,7 +11,7 @@ module GHC.Types.RepType
isVoidTy,
-- * Type representation for the code generator
- typePrimRep, typePrimRep1,
+ typePrimRep, typePrimRep1, typeMonoPrimRep_maybe,
runtimeRepPrimRep, typePrimRepArgs,
PrimRep(..), primRepToType,
countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1,
@@ -34,7 +34,7 @@ import GHC.Core.TyCon.RecWalk
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Builtin.Types.Prim
-import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind )
+import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind, runtimeRepTy )
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -493,6 +493,14 @@ typePrimRep1 ty = case typePrimRep ty of
[rep] -> rep
_ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty))
+-- | Like 'typePrimRep', but returns 'Nothing' instead of panicking, when
+--
+-- * The @ty@ was not of form @TYPE rep@
+-- * @rep@ was not monomorphic
+--
+typeMonoPrimRep_maybe :: Type -> Maybe [PrimRep]
+typeMonoPrimRep_maybe ty = getRuntimeRep_maybe ty >>= runtimeRepMonoPrimRep_maybe
+
-- | Find the runtime representation of a 'TyCon'. Defined here to
-- avoid module loops. Returns a list of the register shapes necessary.
-- See also Note [Getting from RuntimeRep to PrimRep]
@@ -526,6 +534,18 @@ kindPrimRep doc ki
= pprPanic "kindPrimRep" (ppr ki $$ doc)
-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
+-- it encodes if it's a monomorphic rep. Otherwise returns 'Nothing'.
+-- See also Note [Getting from RuntimeRep to PrimRep]
+runtimeRepMonoPrimRep_maybe :: HasDebugCallStack => Type -> Maybe [PrimRep]
+runtimeRepMonoPrimRep_maybe rr_ty
+ | Just (rr_dc, args) <- splitTyConApp_maybe rr_ty
+ , ASSERT2( runtimeRepTy `eqType` typeKind rr_ty, ppr rr_ty ) True
+ , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc
+ = Just (fun args)
+ | otherwise
+ = Nothing -- not mono rep
+
+-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
-- it encodes. See also Note [Getting from RuntimeRep to PrimRep]
runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
runtimeRepPrimRep doc rr_ty
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index f7168190e4..abd85b6b66 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -43,7 +43,7 @@ module GHC.Utils.Misc (
listLengthCmp, atLength,
equalLength, compareLength, leLength, ltLength,
- isSingleton, only, GHC.Utils.Misc.singleton,
+ isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,
notNull, snocView,
isIn, isn'tIn,
@@ -563,6 +563,18 @@ only (a:_) = a
#endif
only _ = panic "Util: only"
+-- | Extract the single element of a list and panic with the given message if
+-- there are more elements or the list was empty.
+-- Like 'expectJust', but for lists.
+expectOnly :: HasCallStack => String -> [a] -> a
+{-# INLINE expectOnly #-}
+#if defined(DEBUG)
+expectOnly _ [a] = a
+#else
+expectOnly _ (a:_) = a
+#endif
+expectOnly msg _ = panic ("expectOnly: " ++ msg)
+
-- Debugging/specialising versions of \tr{elem} and \tr{notElem}
# if !defined(DEBUG)
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index c8b959137c..29137a146f 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -549,6 +549,7 @@ Library
GHC.StgToCmm.Heap
GHC.StgToCmm.Hpc
GHC.StgToCmm.Layout
+ GHC.StgToCmm.Lit
GHC.StgToCmm.Monad
GHC.StgToCmm.Prim
GHC.StgToCmm.Prof
diff --git a/testsuite/tests/stranal/should_compile/T18982.stderr b/testsuite/tests/stranal/should_compile/T18982.stderr
index 3e6074e759..310eed5cc3 100644
--- a/testsuite/tests/stranal/should_compile/T18982.stderr
+++ b/testsuite/tests/stranal/should_compile/T18982.stderr
@@ -1,8 +1,8 @@
==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 311, types: 249, coercions: 4, joins: 0/0}
+Result size of Tidy Core = {terms: 315, types: 214, coercions: 2, joins: 0/0}
--- RHS size: {terms: 8, types: 11, coercions: 1, joins: 0/0}
+-- RHS size: {terms: 8, types: 9, coercions: 1, joins: 0/0}
T18982.$WExGADT :: forall e. (e ~ Int) => e %1 -> Int %1 -> ExGADT Int
T18982.$WExGADT = \ (@e) (dt :: e ~ Int) (dt :: e) (dt :: Int) -> T18982.ExGADT @Int @e @~(<Int>_N :: Int GHC.Prim.~# Int) dt dt dt
@@ -10,7 +10,7 @@ T18982.$WExGADT = \ (@e) (dt :: e ~ Int) (dt :: e) (dt :: Int) -> T18982.ExGADT
T18982.$WGADT :: Int %1 -> GADT Int
T18982.$WGADT = \ (dt :: Int) -> T18982.GADT @Int @~(<Int>_N :: Int GHC.Prim.~# Int) dt
--- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 7, types: 6, coercions: 0, joins: 0/0}
T18982.$WEx :: forall e a. e %1 -> a %1 -> Ex a
T18982.$WEx = \ (@e) (@a) (dt :: e) (dt :: a) -> T18982.Ex @a @e dt dt
@@ -210,27 +210,27 @@ T18982.$tc'ExGADT2 = GHC.Types.TrNameS T18982.$tc'ExGADT3
T18982.$tc'ExGADT :: GHC.Types.TyCon
T18982.$tc'ExGADT = GHC.Types.TyCon 8468257409157161049## 5503123603717080600## T18982.$trModule T18982.$tc'ExGADT2 1# T18982.$tc'ExGADT1
--- RHS size: {terms: 11, types: 14, coercions: 0, joins: 0/0}
-T18982.$wi :: forall {a} {e}. (a GHC.Prim.~# Int) -> e -> GHC.Prim.Int# -> GHC.Prim.Int#
-T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) (ww1 :: e) (ww2 :: GHC.Prim.Int#) -> case ww1 of { __DEFAULT -> GHC.Prim.+# ww2 1# }
+-- RHS size: {terms: 13, types: 15, coercions: 0, joins: 0/0}
+T18982.$wi :: forall {a} {e}. e -> GHC.Prim.Int# -> GHC.Prim.Int#
+T18982.$wi = \ (@a) (@e) (ww :: e) (ww1 :: GHC.Prim.Int#) -> case RUBBISH[] @(a GHC.Prim.~# Int) of ww2 { __DEFAULT -> case ww of { __DEFAULT -> GHC.Prim.+# ww1 1# } }
--- RHS size: {terms: 15, types: 27, coercions: 1, joins: 0/0}
+-- RHS size: {terms: 15, types: 22, coercions: 0, joins: 0/0}
i :: forall a. ExGADT a -> Int
-i = \ (@a) (w :: ExGADT a) -> case w of { ExGADT @e ww1 ww2 ww3 ww4 -> case ww4 of { GHC.Types.I# ww6 -> case T18982.$wi @a @e @~(ww1 :: a GHC.Prim.~# Int) ww3 ww6 of ww7 { __DEFAULT -> GHC.Types.I# ww7 } } }
+i = \ (@a) (w :: ExGADT a) -> case w of { ExGADT @e ww1 ww2 ww3 ww4 -> case ww4 of { GHC.Types.I# ww6 -> case T18982.$wi @a @e ww3 ww6 of ww7 { __DEFAULT -> GHC.Types.I# ww7 } } }
--- RHS size: {terms: 6, types: 10, coercions: 0, joins: 0/0}
-T18982.$wh :: forall {a}. (a GHC.Prim.~# Int) -> GHC.Prim.Int# -> GHC.Prim.Int#
-T18982.$wh = \ (@a) (ww :: a GHC.Prim.~# Int) (ww1 :: GHC.Prim.Int#) -> GHC.Prim.+# ww1 1#
+-- RHS size: {terms: 8, types: 12, coercions: 0, joins: 0/0}
+T18982.$wh :: forall {a}. GHC.Prim.Int# -> GHC.Prim.Int#
+T18982.$wh = \ (@a) (ww :: GHC.Prim.Int#) -> case RUBBISH[] @(a GHC.Prim.~# Int) of ww1 { __DEFAULT -> GHC.Prim.+# ww 1# }
--- RHS size: {terms: 14, types: 18, coercions: 1, joins: 0/0}
+-- RHS size: {terms: 14, types: 15, coercions: 0, joins: 0/0}
h :: forall a. GADT a -> Int
-h = \ (@a) (w :: GADT a) -> case w of { GADT ww1 ww2 -> case ww2 of { GHC.Types.I# ww4 -> case T18982.$wh @a @~(ww1 :: a GHC.Prim.~# Int) ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } }
+h = \ (@a) (w :: GADT a) -> case w of { GADT ww1 ww2 -> case ww2 of { GHC.Types.I# ww4 -> case T18982.$wh @a ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } }
--- RHS size: {terms: 9, types: 5, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 9, types: 4, coercions: 0, joins: 0/0}
T18982.$wg :: forall {e}. e -> GHC.Prim.Int# -> GHC.Prim.Int#
T18982.$wg = \ (@e) (ww :: e) (ww1 :: GHC.Prim.Int#) -> case ww of { __DEFAULT -> GHC.Prim.+# ww1 1# }
--- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 14, types: 11, coercions: 0, joins: 0/0}
g :: Ex Int -> Int
g = \ (w :: Ex Int) -> case w of { Ex @e ww1 ww2 -> case ww2 of { GHC.Types.I# ww4 -> case T18982.$wg @e ww1 ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } }