wip compiles and seems to run with suboptimal code

Now can bootstrap GHC

15 files changed, 295 insertions, 32 deletions

diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 378f348b61..21c579460a 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/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 5ba4decd4f..6dd7a25f06 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -727,8 +727,15 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
     not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args)
   = -- CorePrep does this right, but just to make sure
     assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
-              (ppr bndr $$ ppr con $$ ppr args)
-    ( StgRhsCon dontCareCCS con mn ticks args, ccs )
+              (ppr bndr $$ ppr con $$ ppr args) $
+  if isVirtualDataCon con
+    then
+          ( StgRhsClosure noExtFieldSilent
+                    all_cafs_ccs
+                    upd_flag [] (virtual_arg args)
+          , ccs )
+    else
+      ( StgRhsCon dontCareCCS con mn ticks args, ccs )
 
   -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
   | gopt Opt_AutoSccsOnIndividualCafs dflags
@@ -744,6 +751,12 @@ mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
     , ccs )
 
   where
+    virtual_arg args
+      | [arg] <- filter (not . isZeroBitTy . idType) [ v | StgVarArg v <- args]
+      = StgApp arg []
+      | [litArg] <- [ l | StgLitArg l <- args]
+      = pprPanic "virtualConTop - literal argument" (ppr litArg)
+      | otherwise = panic "virtualConTop - mkTopStgRhs - what is happening ?!?"
     (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
 
     upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs
index 9236bc44a6..3b160f7c38 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)
+import GHC.Types.RepType (dataConRuntimeRepStrictness, isVirtualTyCon, isVirtualDataCon)
 import GHC.Core (AltCon(..))
 import Data.List (mapAccumL)
 import GHC.Utils.Outputable
@@ -593,6 +593,10 @@ time and there doesn't seem to huge benefit to doing differently.
 -- See Note [Constructor TagSigs]
 inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo
 inferConTag env con args
+  | isVirtualDataCon con
+  = TagDunno
+  -- TODO: This should only be needed for top lvl rhss, but I haven't threaded
+  -- the top level flag through yet
   | isUnboxedTupleDataCon con
   = TagTuple $ map (flatten_arg_tag . lookupInfo env) args
   | otherwise =
diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs
index d2d0bbeb2f..2b78089a88 100644
--- a/compiler/GHC/Stg/InferTags/Rewrite.hs
+++ b/compiler/GHC/Stg/InferTags/Rewrite.hs
@@ -425,6 +425,7 @@ 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.hs b/compiler/GHC/StgToCmm.hs
index 4efcf69d18..c0f450dcd6 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -11,7 +11,7 @@
 --
 -----------------------------------------------------------------------------
 
-module GHC.StgToCmm ( codeGen ) where
+module GHC.StgToCmm ( codeGen, cgTopRhs ) where
 
 import GHC.Prelude as Prelude
 
diff --git a/compiler/GHC/StgToCmm.hs-boot b/compiler/GHC/StgToCmm.hs-boot
new file mode 100644
index 0000000000..7e7473b18f
--- /dev/null
+++ b/compiler/GHC/StgToCmm.hs-boot
@@ -0,0 +1,73 @@
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module GHC.StgToCmm ( cgTopRhs ) where
+
+import GHC.Prelude as Prelude
+
+import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)
+import GHC.StgToCmm.Monad
+import GHC.StgToCmm.Env
+import GHC.StgToCmm.Bind
+import GHC.StgToCmm.Layout
+import GHC.StgToCmm.Utils
+import GHC.StgToCmm.Closure
+import GHC.StgToCmm.Config
+import GHC.StgToCmm.Hpc
+import GHC.StgToCmm.Ticky
+import GHC.StgToCmm.Types (ModuleLFInfos)
+
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.CLabel
+import GHC.Cmm.Graph
+
+import GHC.Stg.Syntax
+
+import GHC.Types.CostCentre
+import GHC.Types.IPE
+import GHC.Types.HpcInfo
+import GHC.Types.Id
+import GHC.Types.Id.Info
+import GHC.Types.RepType
+import GHC.Types.Basic
+import GHC.Types.Var.Set ( isEmptyDVarSet )
+import GHC.Types.Unique.FM
+import GHC.Types.Name.Env
+
+import GHC.Core.DataCon
+import GHC.Core.TyCon
+import GHC.Core.Multiplicity
+
+import GHC.Unit.Module
+
+import GHC.Utils.Error
+import GHC.Utils.Outputable
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Logger
+
+import GHC.Utils.TmpFs
+
+import GHC.Data.Stream
+import GHC.Data.OrdList
+import GHC.Types.Unique.Map
+
+import Control.Monad (when,void, forM_)
+import GHC.Utils.Misc
+import System.IO.Unsafe
+import qualified Data.ByteString as BS
+import Data.IORef
+import GHC.Utils.Panic (assertPpr)
+
+cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
+        -- The Id is passed along for setting up a binding...
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 177c3f2912..a97ae084c0 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -64,6 +64,8 @@ import GHC.Data.FastString
 import GHC.Data.List.SetOps
 
 import Control.Monad
+import GHC.Utils.Trace
+import GHC.Types.RepType (isVirtualDataCon)
 
 ------------------------------------------------------------------------
 --              Top-level bindings
@@ -82,6 +84,7 @@ cgTopRhsClosure :: Platform
                 -> (CgIdInfo, FCode ())
 
 cgTopRhsClosure platform rec id ccs upd_flag args body =
+  -- pprTrace "cgTopRhsClosure" (ppr id $$ ppr body) $
   let closure_label = mkClosureLabel (idName id) (idCafInfo id)
       cg_id_info    = litIdInfo platform id lf_info (CmmLabel closure_label)
       lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args
@@ -134,7 +137,7 @@ cgTopRhsClosure platform rec id ccs upd_flag args body =
 --              Non-top-level bindings
 ------------------------------------------------------------------------
 
-cgBind :: CgStgBinding -> FCode ()
+cgBind :: HasCallStack => CgStgBinding -> FCode ()
 cgBind (StgNonRec name rhs)
   = do  { (info, fcode) <- cgRhs name rhs
         ; addBindC info
@@ -285,12 +288,15 @@ mkRhsClosure    profile _ _check_tags bndr _cc
   , StgCase (StgApp scrutinee [{-no args-}])
          _   -- ignore bndr
          (AlgAlt _)
-         [GenStgAlt{ alt_con   = DataAlt _
+         [GenStgAlt{ alt_con   = DataAlt con
                    , alt_bndrs = params
                    , alt_rhs   = sel_expr}] <- strip expr
   , StgApp selectee [{-no args-}] <- strip sel_expr
   , the_fv == scrutinee                -- Scrutinee is the only free variable
 
+  -- Virtual data cons just return themselves.
+  , not $ isVirtualDataCon con
+
   , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params))
                                    -- pattern binders are always non-void,
                                    -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
@@ -457,7 +463,7 @@ mkClosureLFInfo platform bndr top fvs upd_flag args
 --              The code for closures
 ------------------------------------------------------------------------
 
-closureCodeBody :: Bool            -- whether this is a top-level binding
+closureCodeBody :: HasCallStack => 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 6e8b2bdf7a..f7cd57d11f 100644
--- a/compiler/GHC/StgToCmm/Bind.hs-boot
+++ b/compiler/GHC/StgToCmm/Bind.hs-boot
@@ -1,6 +1,20 @@
 module GHC.StgToCmm.Bind where
 
-import GHC.StgToCmm.Monad( FCode )
-import GHC.Stg.Syntax( CgStgBinding )
+import GHC.StgToCmm.Monad( FCode, CgIdInfo )
+import GHC.Stg.Syntax -- ( CgStgBinding )
+import GHC.Types.Basic
+import GHC.Platform
+import GHC.Types.Id
+import GHC.Types.CostCentre
+import qualified GHC.Stack as S
 
-cgBind :: CgStgBinding -> FCode ()
+cgBind :: S.HasCallStack => CgStgBinding -> FCode ()
+
+cgTopRhsClosure :: Platform
+                -> RecFlag              -- member of a recursive group?
+                -> Id
+                -> CostCentreStack      -- Optional cost centre annotation
+                -> UpdateFlag
+                -> [Id]                 -- Args
+                -> CgStgExpr
+                -> (CgIdInfo, FCode ())
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index fc76664d94..87d242138d 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -101,6 +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)
 
 -----------------------------------------------------------------------------
 --                Data types and synonyms
@@ -514,6 +515,9 @@ getCallMethod :: StgToCmmConfig
               -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call
               -> CallMethod
 
+-- getCallMethod cfg name id lf  n_args v_args cg_loc self_loop
+--   -- | pprTrace "getCallMethod" (ppr (name, id, lf,  n_args, v_args, self_loop) $$ ppr (idTagSig_maybe id)) False
+--   -- = undefined
 getCallMethod cfg _ id _  n_args v_args _cg_loc (Just (self_loop_id, block_id, args))
   | stgToCmmLoopification cfg
   , id == self_loop_id
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
index 89bdb88058..199cfe0ba4 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ b/compiler/GHC/StgToCmm/DataCon.hs
@@ -38,10 +38,12 @@ import GHC.Types.CostCentre
 import GHC.Unit
 import GHC.Core.DataCon
 import GHC.Data.FastString
+import GHC.Types.Basic
 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)
+import GHC.Types.RepType (countConRepArgs, isVirtualTyCon, virtualDataConType, VirtualConType(..), isVirtualDataCon)
 import GHC.Types.Literal
 import GHC.Builtin.Utils
 import GHC.Utils.Panic
@@ -52,8 +54,10 @@ import GHC.Utils.Monad (mapMaybeM)
 import Control.Monad
 import Data.Char
 import GHC.StgToCmm.Config (stgToCmmPlatform)
-import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)
+import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn, emitTagAssertion, emitTagAssertionId)
 import GHC.Utils.Outputable
+import GHC.Utils.Trace
+import Data.Maybe
 
 ---------------------------------------------------------------
 --      Top-level constructors
@@ -77,6 +81,14 @@ cgTopRhsCon cfg id con mn args
     -- See Note [About the NameSorts] in "GHC.Types.Name" for Internal/External
     (static_info, static_code)
 
+  -- Virtual constructor, just return the argument.
+  | virtualDataConType con == VirtualBoxed
+  , [NonVoid (StgVarArg x)] <- args
+  = panic "topRhsCon" $ let fake_rhs = StgApp x []
+    in
+      pprTrace "cgTopRhsCon" (ppr id $$ ppr con $$ ppr args) $
+      cgTopRhsClosure platform NonRecursive id dontCareCCS Updatable [] fake_rhs
+
   -- Otherwise generate a closure for the constructor.
   | otherwise
   = (id_Info, gen_code)
@@ -191,6 +203,32 @@ The reason for having a separate argument, rather than looking at
 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
+  | virtualDataConType con == VirtualBoxed
+  , [NonVoid (StgVarArg arg)] <- assert (length args == 1) args
+  = do
+      cfg <- getStgToCmmConfig
+      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.
+          let fake_con_info = arg_info { cg_id = binder }
+
+          return (fake_con_info, return mempty)
+        Nothing -> panic "buildDynCon': LFInfo for VCon args unknown" (ppr binder <> text " = " <> ppr con <+> ppr args)
+
+          -- let !lf_info = mkLFArgument arg
+
+          -- (id_info, reg) <- rhsIdInfo binder lf_info
+          -- emit $ mkAssign (CmmLocal reg) ((CmmReg $ CmmLocal $ idToReg platform $ NonVoid arg))
+          -- bindArgToGivenReg (NonVoid arg) reg
+          -- return (id_info, return mempty)
+
 -------- buildDynCon': the general case -----------
 buildDynCon' binder mn actually_bound ccs con args
   = do  { (id_info, reg) <- rhsIdInfo binder lf_info
@@ -382,7 +420,13 @@ bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
 -- binders args, assuming that we have just returned from a 'case' which
 -- found a con
 bindConArgs (DataAlt con) base args
-  = assert (not (isUnboxedTupleDataCon con)) $
+  | isVirtualDataCon con
+  , [NonVoid arg] <- assert (length args == 1) args
+  = do
+      bindArgToGivenReg (NonVoid arg) base
+      return [base]
+
+  | otherwise = assert (not (isUnboxedTupleDataCon con)) $
     do profile <- getProfile
        platform <- getPlatform
        let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index aced870367..824d47d398 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -16,7 +16,7 @@ module GHC.StgToCmm.Env (
         addBindC, addBindsC,
 
         bindArgsToRegs, bindToReg, rebindToReg,
-        bindArgToReg, idToReg,
+        bindArgToReg, bindArgToGivenReg, idToReg,
         getCgIdInfo, getCgInfo_maybe,
         maybeLetNoEscape,
         ) where
@@ -45,6 +45,8 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 
 import GHC.Builtin.Names (getUnique)
+import GHC.Utils.Misc
+import GHC.Utils.Trace
 
 
 -------------------------------------
@@ -71,7 +73,7 @@ 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.
 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
 rhsIdInfo id lf_info
   = do platform <- getPlatform
@@ -125,7 +127,7 @@ addBindsC new_bindings = do
 -- One would think it would be worthwhile to cache these.
 -- Sadly it's not. See #16937
 
-getCgIdInfo :: Id -> FCode CgIdInfo
+getCgIdInfo :: HasCallStack => Id -> FCode CgIdInfo
 getCgIdInfo id
   = do  { platform <- getPlatform
         ; local_binds <- getBinds -- Try local bindings first
@@ -159,9 +161,10 @@ getCgInfo_maybe name
   = do  { local_binds <- getBinds -- Try local bindings first
         ; return $ lookupVarEnv_Directly local_binds (getUnique name) }
 
-cgLookupPanic :: Id -> FCode a
+cgLookupPanic :: HasCallStack => Id -> FCode a
 cgLookupPanic id
   = do  local_binds <- getBinds
+        pprTraceM "cgLookupPanic" (callStackDoc)
         pprPanic "GHC.StgToCmm.Env: variable not found"
                 (vcat [ppr id,
                 text "local binds for:",
@@ -182,6 +185,13 @@ bindToReg nvid@(NonVoid id) lf_info
        addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
        return reg
 
+bindArgToGivenReg :: NonVoid Id -> LocalReg -> FCode ()
+-- Records that an arg is already present in the given reg
+bindArgToGivenReg (NonVoid id) reg
+  = do let !lf_info = mkLFArgument id
+       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
+
+
 rebindToReg :: NonVoid Id -> FCode LocalReg
 -- Like bindToReg, but the Id is already in scope, so
 -- get its LF info from the envt
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index fcf91b4509..e0b5a9dfa2 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 )
+import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs, mightBeFunTy, isVirtualTyCon )
 import GHC.Types.CostCentre ( CostCentreStack, currentCCS )
 import GHC.Types.Tickish
 import GHC.Data.Maybe
@@ -65,7 +65,7 @@ import GHC.Platform.Profile (profileIsProfiling)
 --              cgExpr: the main function
 ------------------------------------------------------------------------
 
-cgExpr  :: CgStgExpr -> FCode ReturnKind
+cgExpr  :: HasCallStack => CgStgExpr -> FCode ReturnKind
 
 cgExpr (StgApp fun args)     = cgIdApp fun args
 
@@ -127,7 +127,19 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
 
 
 cgExpr (StgOpApp op args ty) = cgOpApp op args ty
-cgExpr (StgConApp con mn args _) = cgConApp con mn args
+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)
+  , arg <- getArg args
+  = cgExpr (StgApp arg [])
+  | otherwise
+  = cgConApp con mn args
+  where
+      getArg args
+        | [StgVarArg arg] <- args
+        = arg
+        | otherwise = pprPanic "Very odd virtalCon" (ppr con <> ppr args)
 cgExpr (StgTick t e)         = cgTick t >> cgExpr e
 cgExpr (StgLit lit)          = do cmm_expr <- cgLit lit
                                   emitReturn [cmm_expr]
@@ -426,7 +438,7 @@ data GcPlan
                         -- of the case alternative(s) into the upstream check
 
 -------------------------------------
-cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
+cgCase :: HasCallStack => CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
 
 {-
 Note [Scrutinising VoidRep]
@@ -672,7 +684,7 @@ chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
                              -- MultiValAlt has only one alternative
 
 -------------------------------------
-cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
+cgAlts :: HasCallStack => (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]
@@ -921,7 +933,7 @@ cgAlts _ _ _ _ = panic "cgAlts"
 --
 
 -------------------
-cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
+cgAlgAltRhss :: HasCallStack => (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
              -> FCode ( Maybe CmmAGraphScoped
                       , [(ConTagZ, CmmAGraphScoped)] )
 cgAlgAltRhss gc_plan bndr alts
@@ -941,7 +953,7 @@ cgAlgAltRhss gc_plan bndr alts
 
 
 -------------------
-cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
+cgAltRhss :: HasCallStack => (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
           -> FCode [(AltCon, CmmAGraphScoped)]
 cgAltRhss gc_plan bndr alts = do
   platform <- getPlatform
@@ -976,6 +988,13 @@ cgConApp con mn stg_args
        ; tickyUnboxedTupleReturn (length arg_exprs)
        ; emitReturn arg_exprs }
 
+  -- Virtual constructor, just return the argument.
+  | isVirtualTyCon (dataConTyCon con)
+  , [StgVarArg arg] <- assert (length stg_args == 1) stg_args
+  = do
+      info <- getCgIdInfo arg
+      emitReturn [idInfoToAmode info]
+
   | otherwise   --  Boxed constructors; allocate and return
   = assertPpr (stg_args `lengthIs` countConRepArgs con)
               (ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args) $
@@ -991,7 +1010,7 @@ cgConApp con mn stg_args
         ; tickyReturnNewCon (length stg_args)
         ; emitReturn [idInfoToAmode idinfo] }
 
-cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
+cgIdApp :: HasCallStack => 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 5b05e846d5..c3ce392e50 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -595,11 +595,11 @@ stdPattern reps
 --        Amodes for arguments
 -------------------------------------------------------------------------
 
-getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+getArgAmode :: HasCallStack => NonVoid StgArg -> FCode CmmExpr
 getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
 getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit
 
-getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
+getNonVoidArgAmodes :: HasCallStack => [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 c83b4de5d4..00ff1e7fce 100644
--- a/compiler/GHC/StgToCmm/TagCheck.hs
+++ b/compiler/GHC/StgToCmm/TagCheck.hs
@@ -9,7 +9,7 @@
 -----------------------------------------------------------------------------
 
 module GHC.StgToCmm.TagCheck
-  ( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags,
+  ( emitTagAssertion, emitTagAssertionId, emitArgTagCheck, checkArg, whenCheckTags,
     checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where
 
 #include "ClosureTypes.h"
@@ -50,7 +50,7 @@ checkFunctionArgTags msg f args = whenCheckTags $ do
     -- Only check args marked as strict, and only lifted ones.
     let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args
     -- Get their (cmm) address
-    arg_infos <- mapM getCgIdInfo cbv_args
+    arg_infos <- mapM getCgIdInfo $ cbv_args
     let arg_cmms = map idInfoToAmode arg_infos
     mapM_ (\(cmm,arg) -> emitTagAssertion (showPprUnsafe $ msg <+> ppr arg) cmm)  (zip arg_cmms cbv_args)
 
@@ -81,7 +81,7 @@ whenCheckTags act = do
 -- * A tag is present
 -- * Or the object is a PAP (for which zero is the proper tag)
 emitTagAssertion :: String -> CmmExpr -> FCode ()
-emitTagAssertion onWhat fun = do
+emitTagAssertion onWhat fun = whenCheckTags $ do
   { platform <- getPlatform
   ; lret <- newBlockId
   ; lno_tag <- newBlockId
@@ -99,6 +99,12 @@ emitTagAssertion onWhat fun = do
   ; emitLabel lret
   }
 
+emitTagAssertionId :: String -> Id -> FCode ()
+emitTagAssertionId msg arg = do
+  id_info <- getCgIdInfo arg
+  let CmmLoc cmm = cg_loc id_info
+  emitTagAssertion msg cmm
+
 -- | Jump to the first block if the argument closure is subject
 --   to tagging requirements. Otherwise jump to the 2nd one.
 needsArgTag :: CmmExpr -> BlockId -> BlockId -> FCode ()
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index 993694e1c3..c5c92fefb9 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -1,5 +1,6 @@
 
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE InstanceSigs #-}
 
 module GHC.Types.RepType
   (
@@ -23,8 +24,9 @@ module GHC.Types.RepType
     slotPrimRep, primRepSlot,
 
     -- * Is this type known to be data?
-    mightBeFunTy
+    mightBeFunTy,
 
+    isVirtualTyCon, isVirtualDataCon, virtualDataConType, VirtualConType(..)
     ) where
 
 import GHC.Prelude
@@ -59,6 +61,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 
 import Data.List (sort)
+import GHC.Utils.Trace
 import qualified Data.IntSet as IS
 
 {- **********************************************************************
@@ -67,6 +70,9 @@ import qualified Data.IntSet as IS
 *                                                                       *
 ********************************************************************** -}
 
+tyHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool
+tyHasFixedRuntimeRep = isFixedRuntimeRepKind . typeKind
+
 type NvUnaryType = Type
 type UnaryType   = Type
      -- Both are always a value type; i.e. its kind is TYPE rr
@@ -693,3 +699,66 @@ mightBeFunTy ty
   = False
   | otherwise
   = True
+
+------------------------------------------
+--   Virtual Data Con stuff
+------------------------------------------
+
+data VirtualConType = VirtualBoxed -- ^ These have a regular pointer tag
+                    | VirtualUnboxed -- ^ ByteArray# and friends. These don't usually have pointers.
+                    | NonVirtual -- ^ Can't be shorted out.
+                    deriving (Eq,Show)
+
+instance Outputable VirtualConType where
+  ppr :: VirtualConType -> SDoc
+  ppr = text . show
+
+isVirtualDataCon :: DataCon -> Bool
+isVirtualDataCon con = virtualDataConType con /= NonVirtual
+
+virtualDataConType :: DataCon -> VirtualConType
+virtualDataConType = isVirtualTyCon . dataConTyCon
+
+isVirtualTyCon :: HasDebugCallStack => TyCon -> VirtualConType
+isVirtualTyCon tc
+  -- Exactly one constructor
+  | [dc] <- tyConDataCons tc
+  -- No (runtime) constraints
+  , [] <- filter (not . isZeroBitTy) (dataConOtherTheta dc)
+  -- , pprTrace "isV.2" (ppr dc <> text ":" <> ppr tc) True
+  --Exactly one non-void field argument
+  , rep_bangs <- dataConRepStrictness dc
+  , rep_tys <- dataConRepArgTys dc
+  , all (tyHasFixedRuntimeRep) $ map scaledThing rep_tys
+  -- , pprTrace "args,bangs" (ppr rep_bangs <> ppr rep_tys) True
+  , [(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
+  -- That field is either unlifted or strict
+  , isBoxedType (dataConOrigResTy dc)
+  = if (isUnliftedType field)
+      then
+        (\r -> pprTrace "safeUnlifted " (ppr tc <+> ppr r) r) (isSafeUnlifted field)
+      else
+        isSafeLifted strictness
+  -- , pprTrace "isV.7" empty True
+  -- -- Result is boxed
+  -- = pprTrace "foundVirtualCon:" (ppr dc <> text ":" <> ppr tc <> text "@" <> ppr field) True
+  | otherwise = NonVirtual
+  where
+    isSafeLifted strictness = case strictness of MarkedStrict -> VirtualBoxed; _ -> NonVirtual
+
+    isSafeUnlifted field
+      | Just field_tc <- tyConAppTyCon_maybe field
+      -- , pprTrace "ftc" (ppr field_tc) True
+      , isDataTyCon field_tc
+      = VirtualBoxed
+      -- TODO: Hashmaps etc.
+      | otherwise = NonVirtual