Some cleanup

12 files changed, 75 insertions, 42 deletions

diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 21c579460a..378f348b61 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -180,7 +180,7 @@ import GHC.Unit.Module        ( Module )
 import GHC.Core.Type
 import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))
 import GHC.Core.TyCo.Rep (RuntimeRepType)
-import GHC.Types.RepType ()
+import GHC.Types.RepType
 import GHC.Core.DataCon
 import GHC.Core.ConLike
 import GHC.Core.TyCon
diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs
index 3b160f7c38..e117000a24 100644
--- a/compiler/GHC/Stg/InferTags.hs
+++ b/compiler/GHC/Stg/InferTags.hs
@@ -17,7 +17,7 @@ import GHC.Types.Name
 import GHC.Stg.Syntax
 import GHC.Types.Basic ( CbvMark (..) )
 import GHC.Types.Unique.Supply (mkSplitUniqSupply)
-import GHC.Types.RepType (dataConRuntimeRepStrictness, isVirtualTyCon, isVirtualDataCon)
+import GHC.Types.RepType (dataConRuntimeRepStrictness, isVirtualDataCon)
 import GHC.Core (AltCon(..))
 import Data.List (mapAccumL)
 import GHC.Utils.Outputable
diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs
index 2b78089a88..d2d0bbeb2f 100644
--- a/compiler/GHC/Stg/InferTags/Rewrite.hs
+++ b/compiler/GHC/Stg/InferTags/Rewrite.hs
@@ -425,7 +425,6 @@ rewriteApp :: InferStgExpr -> RM TgStgExpr
 rewriteApp (StgApp f []) = do
     f' <- rewriteId f
     return $! StgApp f' []
-
 rewriteApp (StgApp f args)
     -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False
     -- = undefined
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index a97ae084c0..414a65aa3b 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -64,7 +64,7 @@ import GHC.Data.FastString
 import GHC.Data.List.SetOps
 
 import Control.Monad
-import GHC.Utils.Trace
+-- import GHC.Utils.Trace
 import GHC.Types.RepType (isVirtualDataCon)
 
 ------------------------------------------------------------------------
@@ -137,7 +137,7 @@ cgTopRhsClosure platform rec id ccs upd_flag args body =
 --              Non-top-level bindings
 ------------------------------------------------------------------------
 
-cgBind :: HasCallStack => CgStgBinding -> FCode ()
+cgBind :: HasDebugCallStack => CgStgBinding -> FCode ()
 cgBind (StgNonRec name rhs)
   = do  { (info, fcode) <- cgRhs name rhs
         ; addBindC info
@@ -294,7 +294,8 @@ mkRhsClosure    profile _ _check_tags bndr _cc
   , StgApp selectee [{-no args-}] <- strip sel_expr
   , the_fv == scrutinee                -- Scrutinee is the only free variable
 
-  -- Virtual data cons just return themselves.
+  -- A case on a virtual data con will look like a selector
+  -- but must just return itself.
   , not $ isVirtualDataCon con
 
   , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params))
@@ -463,7 +464,8 @@ mkClosureLFInfo platform bndr top fvs upd_flag args
 --              The code for closures
 ------------------------------------------------------------------------
 
-closureCodeBody :: HasCallStack => Bool            -- whether this is a top-level binding
+closureCodeBody :: HasDebugCallStack
+                => Bool            -- whether this is a top-level binding
                 -> Id              -- the closure's name
                 -> ClosureInfo     -- Lots of information about this closure
                 -> CostCentreStack -- Optional cost centre attached to closure
diff --git a/compiler/GHC/StgToCmm/Bind.hs-boot b/compiler/GHC/StgToCmm/Bind.hs-boot
index f7cd57d11f..d7e18381c8 100644
--- a/compiler/GHC/StgToCmm/Bind.hs-boot
+++ b/compiler/GHC/StgToCmm/Bind.hs-boot
@@ -6,9 +6,9 @@ import GHC.Types.Basic
 import GHC.Platform
 import GHC.Types.Id
 import GHC.Types.CostCentre
-import qualified GHC.Stack as S
+import qualified GHC.Utils.Misc as S (HasDebugCallStack)
 
-cgBind :: S.HasCallStack => CgStgBinding -> FCode ()
+cgBind :: S.HasDebugCallStack => CgStgBinding -> FCode ()
 
 cgTopRhsClosure :: Platform
                 -> RecFlag              -- member of a recursive group?
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index 87d242138d..71468f5de5 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -101,7 +101,7 @@ import Data.Coerce (coerce)
 import qualified Data.ByteString.Char8 as BS8
 import GHC.StgToCmm.Config
 import GHC.Stg.InferTags.TagSig (isTaggedSig)
-import GHC.Utils.Trace (pprTrace)
+-- import GHC.Utils.Trace (pprTrace)
 
 -----------------------------------------------------------------------------
 --                Data types and synonyms
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
index 199cfe0ba4..2915c3d6be 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ b/compiler/GHC/StgToCmm/DataCon.hs
@@ -43,7 +43,7 @@ import GHC.Types.Id
 import {-# SOURCE #-} GHC.StgToCmm.Bind
 import GHC.Types.Id.Info( CafInfo( NoCafRefs ) )
 import GHC.Types.Name (isInternalName)
-import GHC.Types.RepType (countConRepArgs, isVirtualTyCon, virtualDataConType, VirtualConType(..), isVirtualDataCon)
+import GHC.Types.RepType (countConRepArgs, virtualDataConType, VirtualConType(..), isVirtualDataCon)
 import GHC.Types.Literal
 import GHC.Builtin.Utils
 import GHC.Utils.Panic
@@ -54,10 +54,8 @@ import GHC.Utils.Monad (mapMaybeM)
 import Control.Monad
 import Data.Char
 import GHC.StgToCmm.Config (stgToCmmPlatform)
-import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn, emitTagAssertion, emitTagAssertionId)
+import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn, emitTagAssertionId)
 import GHC.Utils.Outputable
-import GHC.Utils.Trace
-import Data.Maybe
 
 ---------------------------------------------------------------
 --      Top-level constructors
@@ -82,11 +80,15 @@ cgTopRhsCon cfg id con mn args
     (static_info, static_code)
 
   -- Virtual constructor, just return the argument.
+  -- This should never happen. Why? If a user writes:
+  -- "foo = Virtual x" this should translate to
+  -- foo = case x of Virtual x
+  --
   | virtualDataConType con == VirtualBoxed
   , [NonVoid (StgVarArg x)] <- args
   = panic "topRhsCon" $ let fake_rhs = StgApp x []
     in
-      pprTrace "cgTopRhsCon" (ppr id $$ ppr con $$ ppr args) $
+      -- pprTrace "cgTopRhsCon" (ppr id $$ ppr con $$ ppr args) $
       cgTopRhsClosure platform NonRecursive id dontCareCCS Updatable [] fake_rhs
 
   -- Otherwise generate a closure for the constructor.
@@ -204,19 +206,20 @@ the addr modes of the args is that we may be in a "knot", and
 premature looking at the args will cause the compiler to black-hole!
 -}
 -------- buildDynCon': Virtual constructor -----------
-buildDynCon' binder mn actually_bound ccs con args
+buildDynCon' binder _mn _actually_bound _ccs con args
   | virtualDataConType con == VirtualBoxed
   , [NonVoid (StgVarArg arg)] <- assert (length args == 1) args
   = do
       cfg <- getStgToCmmConfig
-      let platform = stgToCmmPlatform cfg
+      let _platform = stgToCmmPlatform cfg
 
       m_arg_cg_info <- (getCgInfo_maybe $ idName arg)
       case m_arg_cg_info of
         Just arg_info -> do
           emitTagAssertionId "buildDynConVirt:" arg
 
-          -- A virtual con is just the arguments info under another name.
+          -- A virtual con is compiled by simply resuing the arguments cg info
+          -- under another name.
           let fake_con_info = arg_info { cg_id = binder }
 
           return (fake_con_info, return mempty)
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index 824d47d398..74911fd69e 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -46,7 +46,6 @@ import GHC.Utils.Panic.Plain
 
 import GHC.Builtin.Names (getUnique)
 import GHC.Utils.Misc
-import GHC.Utils.Trace
 
 
 -------------------------------------
@@ -73,7 +72,8 @@ lneIdInfo platform id regs
     lf     = mkLFLetNoEscape
     blk_id = mkBlockId (idUnique id)
 
--- Construct the cgIdInfo from it's parts and determine a register to put the value.
+-- Construct the cgIdInfo from it's parts and determine which
+-- register to put the value in.
 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
 rhsIdInfo id lf_info
   = do platform <- getPlatform
@@ -127,7 +127,7 @@ addBindsC new_bindings = do
 -- One would think it would be worthwhile to cache these.
 -- Sadly it's not. See #16937
 
-getCgIdInfo :: HasCallStack => Id -> FCode CgIdInfo
+getCgIdInfo :: HasDebugCallStack => Id -> FCode CgIdInfo
 getCgIdInfo id
   = do  { platform <- getPlatform
         ; local_binds <- getBinds -- Try local bindings first
@@ -161,12 +161,11 @@ getCgInfo_maybe name
   = do  { local_binds <- getBinds -- Try local bindings first
         ; return $ lookupVarEnv_Directly local_binds (getUnique name) }
 
-cgLookupPanic :: HasCallStack => Id -> FCode a
+cgLookupPanic :: HasDebugCallStack => Id -> FCode a
 cgLookupPanic id
   = do  local_binds <- getBinds
-        pprTraceM "cgLookupPanic" (callStackDoc)
         pprPanic "GHC.StgToCmm.Env: variable not found"
-                (vcat [ppr id,
+                (vcat [callStackDoc, ppr id,
                 text "local binds for:",
                 pprUFM local_binds $ \infos ->
                   vcat [ ppr (cg_id info) | info <- infos ]
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index e0b5a9dfa2..f0ef3555b2 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -45,7 +45,7 @@ import GHC.Types.Id
 import GHC.Builtin.PrimOps
 import GHC.Core.TyCon
 import GHC.Core.Type        ( isUnliftedType )
-import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs, mightBeFunTy, isVirtualTyCon )
+import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs, mightBeFunTy, isVirtualDataCon )
 import GHC.Types.CostCentre ( CostCentreStack, currentCCS )
 import GHC.Types.Tickish
 import GHC.Data.Maybe
@@ -130,7 +130,7 @@ cgExpr (StgOpApp op args ty) = cgOpApp op args ty
 cgExpr (StgConApp con mn args _)
   -- Unlike for a regular con for a virtual con we
   -- might have to evaluate the argument here!
-  | isVirtualTyCon (dataConTyCon con)
+  | isVirtualDataCon con
   , arg <- getArg args
   = cgExpr (StgApp arg [])
   | otherwise
@@ -438,7 +438,7 @@ data GcPlan
                         -- of the case alternative(s) into the upstream check
 
 -------------------------------------
-cgCase :: HasCallStack => CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
+cgCase :: HasDebugCallStack => CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
 
 {-
 Note [Scrutinising VoidRep]
@@ -684,7 +684,7 @@ chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
                              -- MultiValAlt has only one alternative
 
 -------------------------------------
-cgAlts :: HasCallStack => (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
+cgAlts :: HasDebugCallStack => (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
        -> FCode ReturnKind
 -- At this point the result of the case are in the binders
 cgAlts gc_plan _bndr PolyAlt [alt]
@@ -933,7 +933,7 @@ cgAlts _ _ _ _ = panic "cgAlts"
 --
 
 -------------------
-cgAlgAltRhss :: HasCallStack => (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
+cgAlgAltRhss :: HasDebugCallStack => (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
              -> FCode ( Maybe CmmAGraphScoped
                       , [(ConTagZ, CmmAGraphScoped)] )
 cgAlgAltRhss gc_plan bndr alts
@@ -953,7 +953,7 @@ cgAlgAltRhss gc_plan bndr alts
 
 
 -------------------
-cgAltRhss :: HasCallStack => (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
+cgAltRhss :: HasDebugCallStack => (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
           -> FCode [(AltCon, CmmAGraphScoped)]
 cgAltRhss gc_plan bndr alts = do
   platform <- getPlatform
@@ -989,7 +989,7 @@ cgConApp con mn stg_args
        ; emitReturn arg_exprs }
 
   -- Virtual constructor, just return the argument.
-  | isVirtualTyCon (dataConTyCon con)
+  | isVirtualDataCon con
   , [StgVarArg arg] <- assert (length stg_args == 1) stg_args
   = do
       info <- getCgIdInfo arg
@@ -1010,7 +1010,7 @@ cgConApp con mn stg_args
         ; tickyReturnNewCon (length stg_args)
         ; emitReturn [idInfoToAmode idinfo] }
 
-cgIdApp :: HasCallStack => Id -> [StgArg] -> FCode ReturnKind
+cgIdApp :: HasDebugCallStack => Id -> [StgArg] -> FCode ReturnKind
 cgIdApp fun_id args = do
     platform       <- getPlatform
     fun_info       <- getCgIdInfo fun_id
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index c3ce392e50..0b6c1bf146 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -595,11 +595,11 @@ stdPattern reps
 --        Amodes for arguments
 -------------------------------------------------------------------------
 
-getArgAmode :: HasCallStack => NonVoid StgArg -> FCode CmmExpr
+getArgAmode :: HasDebugCallStack => NonVoid StgArg -> FCode CmmExpr
 getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
 getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit
 
-getNonVoidArgAmodes :: HasCallStack => [StgArg] -> FCode [CmmExpr]
+getNonVoidArgAmodes :: HasDebugCallStack => [StgArg] -> FCode [CmmExpr]
 -- NB: Filters out void args,
 --     so the result list may be shorter than the argument list
 getNonVoidArgAmodes [] = return []
diff --git a/compiler/GHC/StgToCmm/TagCheck.hs b/compiler/GHC/StgToCmm/TagCheck.hs
index 00ff1e7fce..15f64759ac 100644
--- a/compiler/GHC/StgToCmm/TagCheck.hs
+++ b/compiler/GHC/StgToCmm/TagCheck.hs
@@ -100,9 +100,11 @@ emitTagAssertion onWhat fun = whenCheckTags $ do
   }
 
 emitTagAssertionId :: String -> Id -> FCode ()
-emitTagAssertionId msg arg = do
+emitTagAssertionId msg arg = whenCheckTags $ do
   id_info <- getCgIdInfo arg
-  let CmmLoc cmm = cg_loc id_info
+  let cmm = case cg_loc id_info of
+        CmmLoc cmm -> cmm
+        LneLoc{} -> panic "Tried to emit tag check for LNE"
   emitTagAssertion msg cmm
 
 -- | Jump to the first block if the argument closure is subject
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index c5c92fefb9..3b8af01ab7 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -61,7 +61,6 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 
 import Data.List (sort)
-import GHC.Utils.Trace
 import qualified Data.IntSet as IS
 
 {- **********************************************************************
@@ -700,12 +699,42 @@ mightBeFunTy ty
   | otherwise
   = True
 
-------------------------------------------
+{-----------------------------------------
 --   Virtual Data Con stuff
 ------------------------------------------
 
+Note [Virtual Data Cons]
+~~~~~~~~~~~~~~~~~~~~~~~~
+A virtual data constructor which is one that is presented at runtime by it's
+field. E.g. we can treat MkT from `data T = VC !(Maybe Int)` as a virtual data
+constructor.
+
+The conditions for a constructor to be treated as a virtual one are as follows:
+* It must be the only constructor of the data type
+* It must have a single field that is present at runtime
+* That field must be strict or unlifted
+* The field must be represented by a enterable heap closure. This currently
+  rules out `ByteArray#` and other primitive types.
+
+If all these conditions are met then for `let x = VC y` we can compile this as
+if it were `let x = unsafeCoerce# y`. And when matching on such a
+virtual data constructor we compile `case x of VC y -> e` as if it were
+`case unsafeCoerce# x of y -> e`. Note that `VC` here refers to the constructors
+worker and not the wrapper.
+
+Why does this work?
+* There is no difference if we call seq on the field of the constructor or the
+  constructor itself since both are guaranteed to be values.
+* The GC doesn't care, both are regular heap closures.
+* Since the type has just one constructor we will never discriminate based on
+  the tag of the field.
+* The only tricky case is dataToTag# which is handled as described in #20532
+-}
+
 data VirtualConType = VirtualBoxed -- ^ These have a regular pointer tag
-                    | VirtualUnboxed -- ^ ByteArray# and friends. These don't usually have pointers.
+                    | VirtualUnboxed -- ^ ByteArray# and friends. These don't
+                                     -- have tags and currently can't be shorted
+                                     -- out.
                     | NonVirtual -- ^ Can't be shorted out.
                     deriving (Eq,Show)
 
@@ -734,10 +763,8 @@ isVirtualTyCon tc
   , [(field :: Type, strictness)] <- filter (not . isZeroBitTy . fst) $
                              zipWithEqual "isVirtualTyCon" (\a b -> (scaledThing a, b))
                              (rep_tys) (rep_bangs)
-  , pprTrace "isV.3" empty True
   -- That field is boxed
   , isBoxedType field
-  , pprTrace "isV.4" empty True
   -- And it's a boxed ADT!
   -- , pprTrace "isV.5" empty True
   -- , pprTrace "isV.6" empty True
@@ -745,7 +772,8 @@ isVirtualTyCon tc
   , isBoxedType (dataConOrigResTy dc)
   = if (isUnliftedType field)
       then
-        (\r -> pprTrace "safeUnlifted " (ppr tc <+> ppr r) r) (isSafeUnlifted field)
+        -- (\r -> pprTrace "safeUnlifted " (ppr tc <+> ppr r) r)
+        (isSafeUnlifted field)
       else
         isSafeLifted strictness
   -- , pprTrace "isV.7" empty True