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

1 files changed, 26 insertions, 10 deletions

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)]