Add RubbishLit for absent bindings of UnliftedRep
authorSebastian Graf <sebastian.graf@kit.edu>
Sun, 14 Oct 2018 18:32:40 +0000 (20:32 +0200)
committerKrzysztof Gogolewski <krz.gogolewski@gmail.com>
Sun, 14 Oct 2018 18:32:41 +0000 (20:32 +0200)
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

12 files changed:
compiler/basicTypes/Literal.hs
compiler/codeGen/StgCmmUtils.hs
compiler/coreSyn/CoreUtils.hs
compiler/ghci/ByteCodeAsm.hs
compiler/ghci/ByteCodeGen.hs
compiler/prelude/TysPrim.hs
compiler/prelude/TysWiredIn.hs
compiler/stgSyn/CoreToStg.hs
compiler/stranal/WwLib.hs
testsuite/tests/stranal/should_compile/T15627.hs [new file with mode: 0644]
testsuite/tests/stranal/should_compile/T15627.stderr [new file with mode: 0644]
testsuite/tests/stranal/should_compile/all.T

index 21f4a92..0bf3897 100644 (file)
@@ -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.
 -}
index 99fa550..94e19e4 100644 (file)
@@ -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)
 
 --------------------------------------------------------------------------
index 6dfb1df..55609cf 100644 (file)
@@ -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
index 476a9b2..4473a9e 100644 (file)
@@ -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]
index 022fe89..9aaaa7d 100644 (file)
@@ -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"
index 4a69df8..339913b 100644 (file)
@@ -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'
index 20c7d27..78a8d8c 100644 (file)
@@ -1234,7 +1234,7 @@ liftedRepDataConTyCon = promoteDataCon liftedRepDataCon
 
 -- The type ('LiftedRep)
 liftedRepTy :: Type
-liftedRepTy = mkTyConTy liftedRepDataConTyCon
+liftedRepTy = liftedRepDataConTy
 
 {- *********************************************************************
 *                                                                      *
index fdd8d5b..8275564 100644 (file)
@@ -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
index 040a6d7..8a2ecc2 100644 (file)
@@ -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)]
diff --git a/testsuite/tests/stranal/should_compile/T15627.hs b/testsuite/tests/stranal/should_compile/T15627.hs
new file mode 100644 (file)
index 0000000..c7fe0ce
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE MagicHash #-}
+
+-- | Asserts that absent bindings of UnliftedRep are properly WWed
+module Unlifted where
+
+import GHC.Exts
+
+fac :: Int -> Int
+fac n = product [1..n]
+
+data MMutVar s a = MMutVar (MutVar# s a) Int
+mutVar :: MMutVar s a -> Int
+mutVar (MMutVar _ n) = fac n
+{-# NOINLINE mutVar #-}
+
+data AArray a = AArray (Array# a) Int
+array :: AArray a -> Int
+array (AArray _ n) = fac n
+{-# NOINLINE array #-}
diff --git a/testsuite/tests/stranal/should_compile/T15627.stderr b/testsuite/tests/stranal/should_compile/T15627.stderr
new file mode 100644 (file)
index 0000000..b1c5ff0
--- /dev/null
@@ -0,0 +1,338 @@
+[1 of 1] Compiling Unlifted         ( T15627.hs, T15627.o )
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 254, types: 130, coercions: 0, joins: 3/3}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$trModule4 :: Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Unlifted.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Unlifted.$trModule3 = GHC.Types.TrNameS Unlifted.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$trModule2 :: Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unlifted.$trModule2 = "Unlifted"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Unlifted.$trModule1 = GHC.Types.TrNameS Unlifted.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$trModule :: GHC.Types.Module
+[GblId,
+ Caf=NoCafRefs,
+ Str=m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+Unlifted.$trModule = GHC.Types.Module Unlifted.$trModule3 Unlifted.$trModule1
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep_r2Xd :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []]
+$krep_r2Xd = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @ GHC.Types.KindRep)
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep1_r2Xe :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m2, Unf=OtherCon []]
+$krep1_r2Xe = GHC.Types.KindRepVar 1#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep2_r2Xf :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m2, Unf=OtherCon []]
+$krep2_r2Xf = GHC.Types.KindRepVar 0#
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep3_r2Xg :: [GHC.Types.KindRep]
+[GblId, Caf=NoCafRefs, Str=m2, Unf=OtherCon []]
+$krep3_r2Xg = GHC.Types.: @ GHC.Types.KindRep $krep2_r2Xf (GHC.Types.[] @ GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep4_r2Xh :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []]
+$krep4_r2Xh = GHC.Types.KindRepTyConApp GHC.Types.$tcArray# $krep3_r2Xg
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep5_r2Xi :: [GHC.Types.KindRep]
+[GblId, Caf=NoCafRefs, Str=m2, Unf=OtherCon []]
+$krep5_r2Xi = GHC.Types.: @ GHC.Types.KindRep $krep1_r2Xe (GHC.Types.[] @ GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep6_r2Xj :: [GHC.Types.KindRep]
+[GblId, Caf=NoCafRefs, Str=m2, Unf=OtherCon []]
+$krep6_r2Xj = GHC.Types.: @ GHC.Types.KindRep $krep2_r2Xf $krep5_r2Xi
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep7_r2Xk :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []]
+$krep7_r2Xk = GHC.Types.KindRepTyConApp GHC.Types.$tcMutVar# $krep6_r2Xj
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tcMMutVar2 :: Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unlifted.$tcMMutVar2 = "MMutVar"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tcMMutVar1 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Unlifted.$tcMMutVar1 = GHC.Types.TrNameS Unlifted.$tcMMutVar2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tcMMutVar :: GHC.Types.TyCon
+[GblId,
+ Caf=NoCafRefs,
+ Str=m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}]
+Unlifted.$tcMMutVar
+  = GHC.Types.TyCon 976071122164149049## 18076036821450447502## Unlifted.$trModule Unlifted.$tcMMutVar1 0# GHC.Types.krep$*->*->*
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep8_r2Xl :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []]
+$krep8_r2Xl = GHC.Types.KindRepTyConApp Unlifted.$tcMMutVar $krep6_r2Xj
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep9_r2Xm :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m4, Unf=OtherCon []]
+$krep9_r2Xm = GHC.Types.KindRepFun $krep_r2Xd $krep8_r2Xl
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tc'MMutVar1 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m4, Unf=OtherCon []]
+Unlifted.$tc'MMutVar1 = GHC.Types.KindRepFun $krep7_r2Xk $krep9_r2Xm
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tc'MMutVar3 :: Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unlifted.$tc'MMutVar3 = "'MMutVar"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tc'MMutVar2 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Unlifted.$tc'MMutVar2 = GHC.Types.TrNameS Unlifted.$tc'MMutVar3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tc'MMutVar :: GHC.Types.TyCon
+[GblId,
+ Caf=NoCafRefs,
+ Str=m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}]
+Unlifted.$tc'MMutVar
+  = GHC.Types.TyCon 1807347364283186211## 6245494011022471830## Unlifted.$trModule Unlifted.$tc'MMutVar2 2# Unlifted.$tc'MMutVar1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tcAArray2 :: Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unlifted.$tcAArray2 = "AArray"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tcAArray1 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Unlifted.$tcAArray1 = GHC.Types.TrNameS Unlifted.$tcAArray2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tcAArray :: GHC.Types.TyCon
+[GblId,
+ Caf=NoCafRefs,
+ Str=m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}]
+Unlifted.$tcAArray
+  = GHC.Types.TyCon 15463012197909582608## 8369862272173810511## Unlifted.$trModule Unlifted.$tcAArray1 0# GHC.Types.krep$*Arr*
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep10_r2Xn :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []]
+$krep10_r2Xn = GHC.Types.KindRepTyConApp Unlifted.$tcAArray $krep3_r2Xg
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep11_r2Xo :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m4, Unf=OtherCon []]
+$krep11_r2Xo = GHC.Types.KindRepFun $krep_r2Xd $krep10_r2Xn
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tc'AArray1 [InlPrag=NOUSERINLINE[~]] :: GHC.Types.KindRep
+[GblId, Caf=NoCafRefs, Str=m4, Unf=OtherCon []]
+Unlifted.$tc'AArray1 = GHC.Types.KindRepFun $krep4_r2Xh $krep11_r2Xo
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tc'AArray3 :: Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unlifted.$tc'AArray3 = "'AArray"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tc'AArray2 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Unlifted.$tc'AArray2 = GHC.Types.TrNameS Unlifted.$tc'AArray3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unlifted.$tc'AArray :: GHC.Types.TyCon
+[GblId,
+ Caf=NoCafRefs,
+ Str=m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}]
+Unlifted.$tc'AArray
+  = GHC.Types.TyCon 5117353292610538775## 18288923674485681885## Unlifted.$trModule Unlifted.$tc'AArray2 1# Unlifted.$tc'AArray1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl_r2Xp :: Int
+[GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []]
+lvl_r2Xp = GHC.Types.I# 1#
+
+-- RHS size: {terms: 34, types: 10, coercions: 0, joins: 1/1}
+fac [InlPrag=NOUSERINLINE[2]] :: Int -> Int
+[GblId,
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=<S(S),1*U(U)>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (w_s2UI [Occ=Once!] :: Int) ->
+                 case w_s2UI of { I# ww1_s2UL ->
+                 case ># 1# ww1_s2UL of {
+                   __DEFAULT ->
+                     joinrec {
+                       $wgo_s2UH [InlPrag=NOUSERINLINE[2], Occ=LoopBreakerT[2]] :: Int# -> Int# -> Int
+                       [LclId[JoinId(2)], Arity=2, Str=<S,U><S,U>m, Unf=OtherCon []]
+                       $wgo_s2UH (w1_s2UB :: Int#) (ww2_s2UF [Occ=Once*] :: Int#)
+                         = case ==# w1_s2UB ww1_s2UL of {
+                             __DEFAULT -> jump $wgo_s2UH (+# w1_s2UB 1#) (*# ww2_s2UF w1_s2UB);
+                             1# -> GHC.Types.I# (*# ww2_s2UF w1_s2UB)
+                           }; } in
+                     jump $wgo_s2UH 1# 1#;
+                   1# -> GHC.Types.I# 1#
+                 }
+                 }}]
+fac
+  = \ (w_s2UI :: Int) ->
+      case w_s2UI of { I# ww1_s2UL ->
+      case ># 1# ww1_s2UL of {
+        __DEFAULT ->
+          joinrec {
+            $wgo_s2UH [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: Int# -> Int# -> Int
+            [LclId[JoinId(2)], Arity=2, Str=<S,U><S,U>m, Unf=OtherCon []]
+            $wgo_s2UH (w1_s2UB :: Int#) (ww2_s2UF :: Int#)
+              = case ==# w1_s2UB ww1_s2UL of {
+                  __DEFAULT -> jump $wgo_s2UH (+# w1_s2UB 1#) (*# ww2_s2UF w1_s2UB);
+                  1# -> GHC.Types.I# (*# ww2_s2UF w1_s2UB)
+                }; } in
+          jump $wgo_s2UH 1# 1#;
+        1# -> lvl_r2Xp
+      }
+      }
+
+-- RHS size: {terms: 32, types: 12, coercions: 0, joins: 1/1}
+Unlifted.$wmutVar [InlPrag=NOINLINE] :: forall s a. Int# -> Int#
+[GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>, Unf=OtherCon []]
+Unlifted.$wmutVar
+  = \ (@ s_s2UR) (@ a_s2US) (ww_s2V0 :: Int#) ->
+      case ># 1# ww_s2V0 of {
+        __DEFAULT ->
+          joinrec {
+            $wgo_s2UH [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: Int# -> Int# -> Int#
+            [LclId[JoinId(2)], Arity=2, Str=<S,U><S,U>, Unf=OtherCon []]
+            $wgo_s2UH (w_s2UB :: Int#) (ww1_s2UF :: Int#)
+              = case ==# w_s2UB ww_s2V0 of {
+                  __DEFAULT -> jump $wgo_s2UH (+# w_s2UB 1#) (*# ww1_s2UF w_s2UB);
+                  1# -> *# ww1_s2UF w_s2UB
+                }; } in
+          jump $wgo_s2UH 1# 1#;
+        1# -> 1#
+      }
+
+-- RHS size: {terms: 15, types: 19, coercions: 0, joins: 0/0}
+mutVar [InlPrag=NOUSERINLINE[0]] :: forall s a. MMutVar s a -> Int
+[GblId,
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=<S(LS(S)),1*U(A,1*U(U))>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@ s_s2UR) (@ a_s2US) (w_s2UT [Occ=Once!] :: MMutVar s_s2UR a_s2US) ->
+                 case w_s2UT of { MMutVar _ [Occ=Dead] ww2_s2UX [Occ=Once!] ->
+                 case ww2_s2UX of { I# ww4_s2V0 [Occ=Once] ->
+                 case Unlifted.$wmutVar @ s_s2UR @ a_s2US ww4_s2V0 of ww5_s2V5 [Occ=Once] { __DEFAULT -> GHC.Types.I# ww5_s2V5 }
+                 }
+                 }}]
+mutVar
+  = \ (@ s_s2UR) (@ a_s2US) (w_s2UT :: MMutVar s_s2UR a_s2US) ->
+      case w_s2UT of { MMutVar ww1_s2UW ww2_s2UX ->
+      case ww2_s2UX of { I# ww4_s2V0 ->
+      case Unlifted.$wmutVar @ s_s2UR @ a_s2US ww4_s2V0 of ww5_s2V5 { __DEFAULT -> GHC.Types.I# ww5_s2V5 }
+      }
+      }
+
+-- RHS size: {terms: 31, types: 10, coercions: 0, joins: 1/1}
+Unlifted.$warray [InlPrag=NOINLINE] :: forall a. Int# -> Int#
+[GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>, Unf=OtherCon []]
+Unlifted.$warray
+  = \ (@ a_s2V7) (ww_s2Vf :: Int#) ->
+      case ># 1# ww_s2Vf of {
+        __DEFAULT ->
+          joinrec {
+            $wgo_s2UH [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: Int# -> Int# -> Int#
+            [LclId[JoinId(2)], Arity=2, Str=<S,U><S,U>, Unf=OtherCon []]
+            $wgo_s2UH (w_s2UB :: Int#) (ww1_s2UF :: Int#)
+              = case ==# w_s2UB ww_s2Vf of {
+                  __DEFAULT -> jump $wgo_s2UH (+# w_s2UB 1#) (*# ww1_s2UF w_s2UB);
+                  1# -> *# ww1_s2UF w_s2UB
+                }; } in
+          jump $wgo_s2UH 1# 1#;
+        1# -> 1#
+      }
+
+-- RHS size: {terms: 14, types: 13, coercions: 0, joins: 0/0}
+array [InlPrag=NOUSERINLINE[0]] :: forall a. AArray a -> Int
+[GblId,
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=<S(LS(S)),1*U(A,1*U(U))>m,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@ a_s2V7) (w_s2V8 [Occ=Once!] :: AArray a_s2V7) ->
+                 case w_s2V8 of { AArray _ [Occ=Dead] ww2_s2Vc [Occ=Once!] ->
+                 case ww2_s2Vc of { I# ww4_s2Vf [Occ=Once] ->
+                 case Unlifted.$warray @ a_s2V7 ww4_s2Vf of ww5_s2Vk [Occ=Once] { __DEFAULT -> GHC.Types.I# ww5_s2Vk }
+                 }
+                 }}]
+array
+  = \ (@ a_s2V7) (w_s2V8 :: AArray a_s2V7) ->
+      case w_s2V8 of { AArray ww1_s2Vb ww2_s2Vc ->
+      case ww2_s2Vc of { I# ww4_s2Vf -> case Unlifted.$warray @ a_s2V7 ww4_s2Vf of ww5_s2Vk { __DEFAULT -> GHC.Types.I# ww5_s2Vk } }
+      }
+
+
+
index 4421b24..a2aa1d5 100644 (file)
@@ -41,3 +41,9 @@ test('T13031', normal, run_command,
 
 test('T13077', normal, compile, [''])
 test('T13077a', normal, compile, [''])
+
+# T15627
+#   Absent bindings of unlifted types should be WW'ed away.
+#   The idea is to check that both $wmutVar and $warray
+#   don't mention MutVar# and Array# anymore.
+test('T15627',  [ grep_errmsg(r'(wmutVar|warray).*Int#') ], compile, ['-dppr-cols=200 -ddump-simpl'])