summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/Literal.hs87
-rw-r--r--compiler/codeGen/StgCmmUtils.hs1
-rw-r--r--compiler/coreSyn/CoreUtils.hs11
-rw-r--r--compiler/ghci/ByteCodeAsm.hs4
-rw-r--r--compiler/ghci/ByteCodeGen.hs1
-rw-r--r--compiler/prelude/TysPrim.hs13
-rw-r--r--compiler/prelude/TysWiredIn.hs2
-rw-r--r--compiler/stgSyn/CoreToStg.hs10
-rw-r--r--compiler/stranal/WwLib.hs36
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)]
View Lorry Controller Status