diff options
| -rw-r--r-- | compiler/GHC/ByteCode/Asm.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 105 | ||||
| -rw-r--r-- | compiler/GHC/Core/Utils.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/CoreToByteCode.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 41 | ||||
| -rw-r--r-- | compiler/GHC/Types/Literal.hs | 81 |
7 files changed, 172 insertions, 77 deletions
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index 17db8a2691..3f88187960 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -473,10 +473,11 @@ assembleI platform i = case i of LitNumWord64 -> int64 (fromIntegral i) LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger" LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural" + -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most -- likely to elicit a crash (rather than corrupt memory) in case absence -- analysis messed up. - literal LitRubbish = int 0 + literal (LitRubbish {}) = int 0 litlabel fs = lit [BCONPtrLbl fs] addr (RemotePtr a) = words [fromIntegral a] diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 7fd73b2cfc..0a7ef0f3a5 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -593,7 +593,7 @@ 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 + , 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 -- (that's what mk_absent_let does) @@ -1255,21 +1255,72 @@ part of the function (post transformation) anyway. Note [Absent errors] ~~~~~~~~~~~~~~~~~~~~ -We make a new binding for Ids that are marked absent, thus - let x = absentError "x :: Int" -The idea is that this binding will never be used; but if it -buggily is used we'll get a runtime error message. - -Coping with absence for *unlifted* types is important; see, for -example, #4306 and #15627. In the UnliftedRep case, we can -use LitRubbish, which we need to apply to the required type. -For the unlifted types of singleton kind like Float#, Addr#, etc. we -also find a suitable literal, using Literal.absentLiteralOf. We don't -have literals for every primitive type, so the function is partial. - -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 fragile +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. + +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. + + +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 +fragile - It fails when profiling is on, which disables various optimisations @@ -1281,10 +1332,8 @@ But this is fragile pass that component to the worker for 'f', which reconstructs 'p' to pass it to 'g'. Alas we can't say ...f (MkT a (absentError Int# "blah"))... - bacause `MkT` is strict in its Int# argument, so we get an absentError + because `MkT` is strict in its Int# argument, so we get an absentError exception when we shouldn't. Very annoying! - -So absentError is only used for lifted types. -} -- | Tries to find a suitable dummy RHS to bind the given absent identifier to. @@ -1292,23 +1341,28 @@ So absentError is only used for lifted types. -- 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 -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let dflags fam_envs arg +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 abs_rhs)) + = 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 = WARN( True, text "No absent value for" <+> ppr arg_ty ) Nothing -- Can happen for 'State#' and things of 'VecRep' @@ -1317,6 +1371,11 @@ mk_absent_let dflags fam_envs arg -- 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 @@ -1326,7 +1385,6 @@ mk_absent_let dflags fam_envs arg (co, nty) = topNormaliseType_maybe fam_envs arg_ty `orElse` (mkRepReflCo arg_ty, arg_ty) - abs_rhs = mkAbsentErrorApp arg_ty msg msg = showSDoc (gopt_set dflags Opt_SuppressUniques) (vcat [ text "Arg:" <+> ppr arg @@ -1342,7 +1400,6 @@ mk_absent_let dflags fam_envs arg -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in GHC.Types.Unique - unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] ww_prefix :: FastString ww_prefix = fsLit "ww" diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 2e40ddc659..afebee0678 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -1611,7 +1611,7 @@ expr_ok primop_ok other_expr 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( lit == rubbishLit ) True + Lit lit -> ASSERT( isRubbishLit lit ) True _ -> False ----------------------------- diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index e993688db9..31c40a9282 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -1655,13 +1655,13 @@ pushAtom _ _ (AnnLit lit) = do _ -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes) case lit of - LitLabel _ _ _ -> code AddrRep - LitFloat _ -> code FloatRep - LitDouble _ -> code DoubleRep - LitChar _ -> code WordRep + LitLabel {} -> code AddrRep + LitFloat {} -> code FloatRep + LitDouble {} -> code DoubleRep + LitChar {} -> code WordRep LitNullAddr -> code AddrRep - LitString _ -> code AddrRep - LitRubbish -> code WordRep + LitString {} -> code AddrRep + LitRubbish {} -> code WordRep LitNumber nt _ -> case nt of LitNumInt -> code IntRep LitNumWord -> code WordRep diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index ea59a84602..8082023ae7 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -374,9 +374,10 @@ coreToStgExpr coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l) = return (StgLit l) -coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type) +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. + -- a STG to Cmm pass. Doesn't matter whether it is lifted or unlifted = coreToStgExpr (Var unitDataConId) coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _) diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index ba5e5266c9..c2e4770da6 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -26,7 +26,7 @@ module GHC.Types.Demand ( multCard, multDmd, multSubDmd, -- ** Predicates on @Card@inalities and @Demand@s isAbs, isUsedOnce, isStrict, - isAbsDmd, isUsedOnceDmd, isStrUsedDmd, + isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd, isTopDmd, isSeqDmd, isWeakDmd, -- ** Special demands evalDmd, @@ -106,12 +106,32 @@ import GHC.Utils.Panic ************************************************************************ -} +{- Note [Evaluation cardinalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand analyser uses an /evaluation cardinality/ of type Card, +to specify how many times a term is evaluated. A cardinality C_lu +represents an /interval/ [l..u], meaning + C_lu means evaluated /at least/ 'l' times and + /at most/ 'u' times + +* The lower bound corresponds to /strictness/ + Hence 'l' is either 0 (lazy) + or 1 (strict) + +* The upper bound corresponds to /usage/ + Hence 'u' is either 0 (not used at all), + or 1 (used at most once) + or n (no information) + +Intervals describe sets, so the underlying lattice is the powerset lattice. + +Usually l<=u, but we also have C_10, the interval [1,0], the empty interval, +denoting the empty set. This is the bottom element of the lattice. +-} + + -- | Describes an interval of /evaluation cardinalities/. --- @C_lu@ means "evaluated /at least/ @l@ and /at most/ @u@ times". --- The lower bound corresponds to /strictness/ (hence @l@ is either @0@ or @1@), --- the upper bound corresponds to /usage/ (@u@ is one of @0@, @1@, @n@). --- --- Intervals describe sets, so the underlying lattice is the powerset lattice. +-- See Note [Evaluation cardinalities] data Card = C_00 -- ^ {0} Absent. | C_01 -- ^ {0,1} Used at most once. @@ -435,6 +455,10 @@ isTopDmd dmd = dmd == topDmd isAbsDmd :: Demand -> Bool isAbsDmd (n :* _) = isAbs n +-- | Contrast with isStrictUsedDmd. See Note [Strict demands] +isStrictDmd :: Demand -> Bool +isStrictDmd (n :* _) = isStrict n + -- | Not absent and used strictly. See Note [Strict demands] isStrUsedDmd :: Demand -> Bool isStrUsedDmd (n :* _) = isStrict n && not (isAbs n) @@ -601,8 +625,9 @@ saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd) 'isStrUsedDmd' returns true only of demands that are both strict and used -In particular, it is False for <B>, which can and does -arise in, say (#7319) + +In particular, it is False for <B> (i.e. strict and not used, +cardinality C_10), which can and does arise in, say (#7319) f x = raise# <some exception> Then 'x' is not used, so f gets strictness <B> -> . Now the w/w generates diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index 879f87180e..206abfea8a 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -58,7 +58,8 @@ module GHC.Types.Literal , extendIntLit, extendWordLit , charToIntLit, intToCharLit , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit - , nullAddrLit, rubbishLit, floatToDoubleLit, doubleToFloatLit + , nullAddrLit, floatToDoubleLit, doubleToFloatLit + , rubbishLit, isRubbishLit ) where #include "HsVersions.h" @@ -134,11 +135,10 @@ data Literal -- that can be represented as a Literal. Create -- with 'nullAddrLit' - | LitRubbish -- ^ A nonsense value, used when an unlifted - -- binding is absent and has type - -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. - -- May be lowered by code-gen to any possible - -- value. Also see Note [Rubbish literals] + | LitRubbish Bool -- ^ A nonsense value; always boxed, but + -- True <=> lifted, False <=> unlifted + -- Used when a binding is absent. + -- See Note [Rubbish literals] | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' @@ -243,7 +243,7 @@ instance Binary Literal where = do putByte bh 6 put_ bh nt put_ bh i - put_ bh (LitRubbish) = putByte bh 7 + put_ bh (LitRubbish b) = do putByte bh 7; put_ bh b get bh = do h <- getByte bh case h of @@ -269,7 +269,9 @@ instance Binary Literal where nt <- get bh i <- get bh return (LitNumber nt i) - _ -> return (LitRubbish) + _ -> do + b <- get bh + return (LitRubbish b) instance Outputable Literal where ppr = pprLiteral id @@ -682,9 +684,13 @@ doubleToFloatLit l = pprPanic "doubleToFloatLit" (ppr l) nullAddrLit :: Literal nullAddrLit = LitNullAddr --- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. -rubbishLit :: Literal -rubbishLit = LitRubbish +-- | 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 @@ -809,9 +815,11 @@ literalType (LitNumber lt _) = case lt of LitNumWord16 -> word16PrimTy LitNumWord32 -> word32PrimTy LitNumWord64 -> word64PrimTy -literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) +literalType (LitRubbish is_lifted) = mkForAllTy a Inferred (mkTyVarTy a) where - a = alphaTyVarUnliftedRep + -- See Note [Rubbish literals] + a | is_lifted = alphaTyVar + | otherwise = alphaTyVarUnliftedRep absentLiteralOf :: TyCon -> Maybe Literal -- Return a literal of the appropriate primitive @@ -851,7 +859,7 @@ cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `uniqCompareFS` b cmpLit (LitNumber nt1 a) (LitNumber nt2 b) | nt1 == nt2 = a `compare` b | otherwise = nt1 `compare` nt2 -cmpLit (LitRubbish) (LitRubbish) = EQ +cmpLit (LitRubbish b1) (LitRubbish b2) = b1 `compare` b2 cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT | otherwise = GT @@ -864,7 +872,7 @@ litTag (LitFloat _) = 4 litTag (LitDouble _) = 5 litTag (LitLabel _ _ _) = 6 litTag (LitNumber {}) = 7 -litTag (LitRubbish) = 8 +litTag (LitRubbish {}) = 8 {- Printing @@ -897,7 +905,9 @@ 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) = text "__RUBBISH" +pprLiteral _ (LitRubbish is_lifted) + = text "__RUBBISH" + <> parens (if is_lifted then text "lifted" else text "unlifted") pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc -- See Note [Printing of literals in Core]. @@ -962,37 +972,38 @@ What is <absent value>? * 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#? We need a literal value of that type. + 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 -That is 'LitRubbish'. Since we need a rubbish literal for -many boxed, unlifted types, we say that LitRubbish has type - LitRubbish :: forall (a :: TYPE UnliftedRep). a +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 @(Array# Int) + $wf x z = let y :: Array# Int = (LitRubbish False) @(Array# Int) in e -Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted -heap pointers. - -Here are the moving parts: +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. + 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 it doesn't matter that it points to a lifted - value. The important thing is that it is a heap pointer, - which the garbage collector can follow if it encounters it. +* 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. + 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 and lifted to the host GC anyway. + In GHC.ByteCode.Asm we just lower it as a 0 literal, because it's all boxed to + the host GC anyway. -} |