diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2021-03-01 21:40:22 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-26 23:02:15 -0400 |
commit | 57d21e6a522f5522ba238675e74f510ab8e5d300 (patch) | |
tree | 4132fca9afc4c2ee8ca0d23266919c77fec27201 | |
parent | 5741caeb0454c1bee9ca865ce6c3dfdd980ecf3e (diff) | |
download | haskell-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.
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 } } } |