diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2018-10-14 20:32:40 +0200 |
---|---|---|
committer | Krzysztof Gogolewski <krz.gogolewski@gmail.com> | 2018-10-14 20:32:41 +0200 |
commit | 448b77b93b369745e9bfbc8b46a5b87bb73dd379 (patch) | |
tree | 8fd12e8698217f022651fe84a3ae9bf3d3e546a9 /compiler | |
parent | 68a747c702d2432cc90d2a79a6aba0e67ac3e2c0 (diff) | |
download | haskell-448b77b93b369745e9bfbc8b46a5b87bb73dd379.tar.gz |
Add RubbishLit for absent bindings of UnliftedRep
Summary:
Trac #9279 reminded us that the worker wrapper transformation copes
really badly with absent unlifted boxed bindings.
As `Note [Absent errors]` in WwLib.hs points out, we can't just use
`absentError` for unlifted bindings because there is no bottom to hide
the error in.
So instead, we synthesise a new `RubbishLit` of type
`forall (a :: TYPE 'UnliftedRep). a`, which code-gen may subsitute for
any boxed value. We choose `()`, so that there is a good chance that
the program crashes instead instead of leading to corrupt data, should
absence analysis have been too optimistic (#11126).
Reviewers: simonpj, hvr, goldfire, bgamari, simonmar
Reviewed By: simonpj
Subscribers: osa1, rwbarton, carter
GHC Trac Issues: #15627, #9279, #4306, #11126
Differential Revision: https://phabricator.haskell.org/D5153
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/basicTypes/Literal.hs | 87 | ||||
-rw-r--r-- | compiler/codeGen/StgCmmUtils.hs | 1 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 11 | ||||
-rw-r--r-- | compiler/ghci/ByteCodeAsm.hs | 4 | ||||
-rw-r--r-- | compiler/ghci/ByteCodeGen.hs | 1 | ||||
-rw-r--r-- | compiler/prelude/TysPrim.hs | 13 | ||||
-rw-r--r-- | compiler/prelude/TysWiredIn.hs | 2 | ||||
-rw-r--r-- | compiler/stgSyn/CoreToStg.hs | 10 | ||||
-rw-r--r-- | compiler/stranal/WwLib.hs | 36 |
9 files changed, 145 insertions, 20 deletions
diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index 21f4a92290..0bf3897da3 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -44,7 +44,7 @@ module Literal , narrow8WordLit, narrow16WordLit, narrow32WordLit , char2IntLit, int2CharLit , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , nullAddrLit, float2DoubleLit, double2FloatLit + , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit ) where #include "HsVersions.h" @@ -96,6 +96,9 @@ import Numeric ( fromRat ) -- -- * The literal derived from the label mentioned in a \"foreign label\" -- declaration ('MachLabel') +-- +-- * A 'RubbishLit' to be used in place of values of 'UnliftedRep' +-- (i.e. 'MutVar#') when the the value is never used. data Literal = ------------------ -- First the primitive guys @@ -114,6 +117,12 @@ data Literal -- that can be represented as a Literal. Create -- with 'nullAddrLit' + | RubbishLit -- ^ 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 [RubbishLit] + | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat' | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble' @@ -195,6 +204,7 @@ instance Binary Literal where = do putByte bh 6 put_ bh nt put_ bh i + put_ bh (RubbishLit) = do putByte bh 7 get bh = do h <- getByte bh case h of @@ -217,7 +227,7 @@ instance Binary Literal where mb <- get bh fod <- get bh return (MachLabel aj mb fod) - _ -> do + 6 -> do nt <- get bh i <- get bh let t = case nt of @@ -232,6 +242,8 @@ instance Binary Literal where LitNumNatural -> panic "Evaluated the place holder for mkNatural" return (LitNumber nt i t) + _ -> do + return (RubbishLit) instance Outputable Literal where ppr lit = pprLiteral (\d -> d) lit @@ -240,6 +252,8 @@ instance Eq Literal where a == b = case (a `compare` b) of { EQ -> True; _ -> False } a /= b = case (a `compare` b) of { EQ -> False; _ -> True } +-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in +-- 'TrieMap.CoreMap'. instance Ord Literal where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } @@ -518,6 +532,10 @@ double2FloatLit l = pprPanic "double2FloatLit" (ppr l) nullAddrLit :: Literal nullAddrLit = MachNullAddr +-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. +rubbishLit :: Literal +rubbishLit = RubbishLit + {- Predicates ~~~~~~~~~~ @@ -610,10 +628,16 @@ literalType (MachFloat _) = floatPrimTy literalType (MachDouble _) = doublePrimTy literalType (MachLabel _ _ _) = addrPrimTy literalType (LitNumber _ _ t) = t +literalType (RubbishLit) = mkForAllTy a Inferred (mkTyVarTy a) + where + a = alphaTyVarUnliftedRep absentLiteralOf :: TyCon -> Maybe Literal -- Return a literal of the appropriate primitive -- TyCon, to use as a placeholder when it doesn't matter +-- RubbishLits are handled in WwLib, 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 (tyConName tc) absent_lits :: UniqFM Literal @@ -642,6 +666,7 @@ cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) | nt1 == nt2 = a `compare` b | otherwise = nt1 `compare` nt2 +cmpLit (RubbishLit) (RubbishLit) = EQ cmpLit lit1 lit2 | litTag lit1 < litTag lit2 = LT | otherwise = GT @@ -654,6 +679,7 @@ litTag (MachFloat _) = 4 litTag (MachDouble _) = 5 litTag (MachLabel _ _ _) = 6 litTag (LitNumber {}) = 7 +litTag (RubbishLit) = 8 {- Printing @@ -679,6 +705,7 @@ pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr where b = case mb of Nothing -> pprHsString l Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) +pprLiteral _ (RubbishLit) = text "__RUBBISH" pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc -- See Note [Printing of literals in Core]. @@ -720,4 +747,60 @@ MachFloat -1.0# MachDouble -1.0## LitInteger -1 (-1) MachLabel "__label" ... ("__label" ...) +RubbishLit "__RUBBISH" + +Note [RubbishLit] +~~~~~~~~~~~~~~~~~ +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#? We need a literal value of that type. + +That is 'RubbishLit'. Since we need a rubbish literal for +many boxed, unlifted types, we say that RubbishLit has type + RubbishLit :: forall (a :: TYPE UnliftedRep). a + +So we might see a w/w split like + $wf x z = let y :: Array# Int = RubbishLit @(Array# Int) + in e + +Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted +heap pointers. + +Here are the moving parts: + +* We define RubbishLit as a constructor in Literal.Literal + +* It is given its polymoprhic type by Literal.literalType + +* WwLib.mk_absent_let introduces a RubbishLit for absent + arguments of boxed, unliftd type. + +* 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. + + We considered maintaining RubbishLit in STG, and lowering + it in the code genreators, but it seems simpler to do it + once and for all in CoreToSTG. + + In ByteCodeAsm we just lower it as a 0 literal, because + it's all boxed and lifted to the host GC anyway. -} diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 99fa550b83..94e19e47fd 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -105,6 +105,7 @@ mkSimpleLit _ (MachLabel fs ms fod) where -- TODO: Literal labels might not actually be in the current package... labelSrc = ForeignLabelInThisPackage +-- NB: RubbishLit should have been lowered in "CoreToStg" mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) -------------------------------------------------------------------------- diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 6dfb1df462..55609cf4b1 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -1525,10 +1525,13 @@ expr_ok primop_ok (Case scrut bndr _ alts) && altsAreExhaustive alts expr_ok primop_ok other_expr - = case collectArgs other_expr of - (expr, args) | Var f <- stripTicksTopE (not . tickishCounts) expr - -> app_ok primop_ok f args - _ -> False + | (expr, args) <- collectArgs other_expr + = case stripTicksTopE (not . tickishCounts) expr of + Var f -> app_ok primop_ok f args + -- 'RubbishLit' 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 + _ -> False ----------------------------- app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index 476a9b2efd..4473a9e9b2 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -460,6 +460,10 @@ assembleI dflags i = case i of LitNumWord64 -> int64 (fromIntegral i) LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger" LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural" + -- We can lower 'RubbishLit' to an arbitrary constant, but @NULL@ is most + -- likely to elicit a crash (rather than corrupt memory) in case absence + -- analysis messed up. + literal RubbishLit = int 0 litlabel fs = lit [BCONPtrLbl fs] addr (RemotePtr a) = words [fromIntegral a] diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 022fe89306..9aaaa7db64 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -1539,6 +1539,7 @@ pushAtom _ _ (AnnLit lit) = do -- representation. LitNumInteger -> panic "pushAtom: LitInteger" LitNumNatural -> panic "pushAtom: LitNatural" + RubbishLit -> code N pushAtom _ _ expr = pprPanic "ByteCodeGen.pushAtom" diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 4a69df8e3e..339913b683 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -20,6 +20,8 @@ module TysPrim( alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTys, alphaTy, betaTy, gammaTy, deltaTy, + alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep, + alphaTysUnliftedRep, alphaTyUnliftedRep, runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, @@ -315,6 +317,17 @@ alphaTys = mkTyVarTys alphaTyVars alphaTy, betaTy, gammaTy, deltaTy :: Type (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys +alphaTyVarsUnliftedRep :: [TyVar] +alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepDataConTy) + +alphaTyVarUnliftedRep :: TyVar +(alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep + +alphaTysUnliftedRep :: [Type] +alphaTysUnliftedRep = mkTyVarTys alphaTyVarsUnliftedRep +alphaTyUnliftedRep :: Type +(alphaTyUnliftedRep:_) = alphaTysUnliftedRep + runtimeRep1TyVar, runtimeRep2TyVar :: TyVar (runtimeRep1TyVar : runtimeRep2TyVar : _) = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r' diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 20c7d2792a..78a8d8c25f 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -1234,7 +1234,7 @@ liftedRepDataConTyCon = promoteDataCon liftedRepDataCon -- The type ('LiftedRep) liftedRepTy :: Type -liftedRepTy = mkTyConTy liftedRepDataConTyCon +liftedRepTy = liftedRepDataConTy {- ********************************************************************* * * diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index fdd8d5bef3..8275564448 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -36,7 +36,7 @@ import Module import Name ( isExternalName, nameOccName, nameModule_maybe ) import OccName ( occNameFS ) import BasicTypes ( Arity ) -import TysWiredIn ( unboxedUnitDataCon ) +import TysWiredIn ( unboxedUnitDataCon, unitDataConId ) import Literal import Outputable import MonadUtils @@ -395,6 +395,10 @@ coreToStgExpr coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger" coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo) +coreToStgExpr (App (Lit RubbishLit) _some_unlifted_type) + -- We lower 'RubbishLit' to @()@ here, which is much easier than doing it in + -- a STG to Cmm pass. + = coreToStgExpr (Var unitDataConId) coreToStgExpr (Var v) = coreToStgApp Nothing v [] [] coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] [] @@ -1093,9 +1097,9 @@ myCollectBinders expr go bs (Cast e _) = go bs e go bs e = (reverse bs, e) +-- | Precondition: argument expression is an 'App', and there is a 'Var' at the +-- head of the 'App' chain. myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) - -- We assume that we only have variables - -- in the function position by now myCollectArgs expr = go expr [] [] where diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs index 040a6d7da9..8a2ecc2016 100644 --- a/compiler/stranal/WwLib.hs +++ b/compiler/stranal/WwLib.hs @@ -26,11 +26,11 @@ import MkCore ( mkAbsentErrorApp, mkCoreUbxTup import MkId ( voidArgId, voidPrimId ) import TysWiredIn ( tupleDataCon ) import TysPrim ( voidPrimTy ) -import Literal ( absentLiteralOf ) +import Literal ( absentLiteralOf, rubbishLit ) import VarEnv ( mkInScopeSet ) import VarSet ( VarSet ) import Type -import RepType ( isVoidTy ) +import RepType ( isVoidTy, typePrimRep ) import Coercion import FamInstEnv import BasicTypes ( Boxity(..) ) @@ -921,9 +921,11 @@ 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, Trac #4306. For these we find a suitable literal, -using Literal.absentLiteralOf. We don't have literals for -every primitive type, so the function is partial. +example, Trac #4306 and Trac #15627. In the UnliftedRep case, we can +use RubbishLit, 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. @@ -945,10 +947,23 @@ But this is fragile So absentError is only used for lifted types. -} +-- | Tries to find a suitable dummy RHS to bind the given absent identifier to. +-- +-- 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 -> Id -> Maybe (CoreExpr -> CoreExpr) mk_absent_let dflags arg + -- The lifted case: Bind 'absentError' + -- See Note [Absent errors] | not (isUnliftedType arg_ty) = Just (Let (NonRec lifted_arg abs_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 arg_ty , Just lit <- absentLiteralOf tc = Just (Let (NonRec arg (Lit lit))) @@ -956,15 +971,15 @@ mk_absent_let dflags arg = Just (Let (NonRec arg (Var voidPrimId))) | otherwise = WARN( True, text "No absent value for" <+> ppr arg_ty ) - Nothing + Nothing -- Can happen for 'State#' and things of 'VecRep' where - lifted_arg = arg `setIdStrictness` exnSig + lifted_arg = arg `setIdStrictness` exnSig -- Note in strictness signature that this is bottoming -- (for the sake of the "empty case scrutinee not known to -- diverge for sure lint" warning) - arg_ty = idType arg - abs_rhs = mkAbsentErrorApp arg_ty msg - msg = showSDoc (gopt_set dflags Opt_SuppressUniques) + arg_ty = idType arg + abs_rhs = mkAbsentErrorApp arg_ty msg + msg = showSDoc (gopt_set dflags Opt_SuppressUniques) (ppr arg <+> ppr (idType arg)) -- We need to suppress uniques here because otherwise they'd -- end up in the generated code as strings. This is bad for @@ -972,6 +987,7 @@ mk_absent_let dflags arg -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in Unique + unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] mk_seq_case :: Id -> CoreExpr -> CoreExpr mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] |