Make PrimOpId record levity

This patch concerns #20155, part (1)

The general idea is that since primops have curried bindings
(currently in PrimOpWrappers.hs) we don't need to eta-expand
them.  But we /do/ need to eta-expand the levity-polymorphic ones,
because they /don't/ have bindings.

This patch makes a start in that direction, by identifying the
levity-polymophic primops in the PrimOpId IdDetails constructor.

For the moment, I'm still eta-expanding all primops (by saying
that hasNoBinding returns True for all primops), because of the
bug reported in #20155.  But I hope that before long we can
tidy that up too, and remove the TEMPORARILY stuff in hasNoBinding.

7 files changed, 49 insertions, 27 deletions

diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 85cc635791..150fa37e7e 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -145,7 +145,8 @@ module GHC.Core.Type (
         Kind,
 
         -- ** Finding the kind of a type
-        typeKind, tcTypeKind, typeHasFixedRuntimeRep, resultHasFixedRuntimeRep,
+        typeKind, tcTypeKind, typeHasFixedRuntimeRep,
+        resultHasFixedRuntimeRep, argsHaveFixedRuntimeRep,
         tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,
         tcIsBoxedTypeKind, tcIsRuntimeTypeKind,
 
@@ -285,8 +286,7 @@ import GHC.Data.Pair
 import GHC.Data.List.SetOps
 import GHC.Types.Unique ( nonDetCmpUnique )
 
-import GHC.Data.Maybe   ( orElse, expectJust )
-import Data.Maybe       ( isJust )
+import GHC.Data.Maybe   ( orElse, expectJust, isJust )
 import Control.Monad    ( guard )
 -- import GHC.Utils.Trace
 
@@ -3109,6 +3109,19 @@ typeHasFixedRuntimeRep = go
 resultHasFixedRuntimeRep :: Type -> Bool
 resultHasFixedRuntimeRep = typeHasFixedRuntimeRep . snd . splitPiTys
 
+argsHaveFixedRuntimeRep :: Type -> Bool
+-- ^ True if the argument types of this function type
+-- all have a fixed-runtime-rep
+argsHaveFixedRuntimeRep ty
+  = all ok bndrs
+  where
+    ok :: TyCoBinder -> Bool
+    ok (Anon _ ty) = typeHasFixedRuntimeRep (scaledThing ty)
+    ok _           = True
+
+    bndrs :: [TyCoBinder]
+    (bndrs, _) = splitPiTys ty
+
 {- **********************************************************************
 *                                                                       *
            Occurs check expansion
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 08c5a10b30..a4f5423be8 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -526,9 +526,9 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
           is_inline_scrut scrut
               | (Var f, _) <- collectArgs scrut
                 = case idDetails f of
-                    FCallId fc  -> not (isSafeForeignCall fc)
-                    PrimOpId op -> not (primOpOutOfLine op)
-                    _other      -> False
+                    FCallId fc    -> not (isSafeForeignCall fc)
+                    PrimOpId op _ -> not (primOpOutOfLine op)
+                    _other        -> False
               | otherwise
                 = False
 
@@ -562,7 +562,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
        = case idDetails fun of
            FCallId _        -> sizeN (callSize (length val_args) voids)
            DataConWorkId dc -> conSize    dc (length val_args)
-           PrimOpId op      -> primOpSize op (length val_args)
+           PrimOpId op _    -> primOpSize op (length val_args)
            ClassOpId _      -> classOpSize opts top_args val_args
            _                -> funSize opts top_args fun (length val_args) voids
 
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 798363540c..df2cdb37e4 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -1407,7 +1407,7 @@ isCheapApp fn n_val_args
       DataConWorkId {} -> True  -- Actually handled by isWorkFreeApp
       RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]
       ClassOpId {}     -> n_val_args == 1
-      PrimOpId op      -> primOpIsCheap op
+      PrimOpId op _    -> primOpIsCheap op
       _                -> False
         -- In principle we should worry about primops
         -- that return a type variable, since the result
@@ -1612,7 +1612,7 @@ app_ok primop_ok fun args
                 -- been expressed by its "wrapper", so we don't need
                 -- to take the arguments into account
 
-      PrimOpId op
+      PrimOpId op _
         | primOpIsDiv op
         , [arg1, Lit lit] <- args
         -> not (isZeroLit lit) && expr_ok primop_ok arg1
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 629398eb8e..a94faee4b2 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -49,7 +49,7 @@ import GHC.Unit.Module
 import GHC.Builtin.Types ( unboxedUnitDataCon )
 import GHC.Data.FastString
 import GHC.Platform.Ways
-import GHC.Builtin.PrimOps ( PrimCall(..) )
+import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
 
 import GHC.Utils.Outputable
 import GHC.Utils.Monad
@@ -547,7 +547,7 @@ coreToStgApp f args ticks = do
                 -- Some primitive operator that might be implemented as a library call.
                 -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
                 -- we require that primop applications be saturated.
-                PrimOpId op      -> assert saturated $
+                PrimOpId op _    -> -- assertPpr saturated (ppr f <+> ppr args) $
                                     StgOpApp (StgPrimOp op) args' res_ty
 
                 -- A call to some primitive Cmm function.
@@ -599,10 +599,11 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
     let
         (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
         stg_arg = case arg'' of
-                       StgApp v []        -> StgVarArg v
-                       StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)
-                       StgLit lit         -> StgLitArg lit
-                       _                  -> pprPanic "coreToStgArgs" (ppr arg)
+           StgApp v []                  -> StgVarArg v
+           StgConApp con _ [] _         -> StgVarArg (dataConWorkId con)
+           StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op)
+           StgLit lit                   -> StgLitArg lit
+           _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'')
 
         -- WARNING: what if we have an argument like (v `cast` co)
         --          where 'co' changes the representation type?
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index df34dd12fd..d9f78a3bcf 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -489,16 +489,16 @@ isClassOpId_maybe id = case Var.idDetails id of
                         _other        -> Nothing
 
 isPrimOpId id = case Var.idDetails id of
-                        PrimOpId _ -> True
-                        _          -> False
+                        PrimOpId {} -> True
+                        _           -> False
 
 isDFunId id = case Var.idDetails id of
                         DFunId {} -> True
                         _         -> False
 
 isPrimOpId_maybe id = case Var.idDetails id of
-                        PrimOpId op -> Just op
-                        _           -> Nothing
+                        PrimOpId op _ -> Just op
+                        _             -> Nothing
 
 isFCallId id = case Var.idDetails id of
                         FCallId _ -> True
@@ -563,7 +563,12 @@ hasNoBinding :: Id -> Bool
 -- exception to this is unboxed tuples and sums datacons, which definitely have
 -- no binding
 hasNoBinding id = case Var.idDetails id of
-                        PrimOpId _       -> True    -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps
+
+-- TEMPORARILY make all primops hasNoBinding, to avoid #20155
+-- The goal is to understand #20155 and revert to the commented out version
+                        PrimOpId _ _ -> True    -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps
+--                        PrimOpId _ lev_poly -> lev_poly    -- TEMPORARILY commented out
+
                         FCallId _        -> True
                         DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
                         _                -> isCompulsoryUnfolding (idUnfolding id)
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index ec5607d40f..dc23932a51 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -159,7 +159,10 @@ data IdDetails
   | ClassOpId Class             -- ^ The 'Id' is a superclass selector,
                                 -- or class operation of a class
 
-  | PrimOpId PrimOp             -- ^ The 'Id' is for a primitive operator
+  | PrimOpId PrimOp Bool        -- ^ The 'Id' is for a primitive operator
+                                -- True <=> is representation-polymorphic,
+                                --          and hence has no binding
+
   | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call.
                                 -- Type will be simple: no type families, newtypes, etc
 
@@ -213,7 +216,7 @@ pprIdDetails other     = brackets (pp other)
    pp (DataConWorkId _)       = text "DataCon"
    pp (DataConWrapId _)       = text "DataConWrapper"
    pp (ClassOpId {})          = text "ClassOp"
-   pp (PrimOpId _)            = text "PrimOp"
+   pp (PrimOpId {})           = text "PrimOp"
    pp (FCallId _)             = text "ForeignCall"
    pp (TickBoxOpId _)         = text "TickBoxOp"
    pp (DFunId nt)             = text "DFunId" <> ppWhen nt (text "(nt)")
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 085214bb50..94a2f7af06 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -86,7 +86,7 @@ import GHC.Data.List.SetOps
 import GHC.Types.Var (VarBndr(Bndr))
 import qualified GHC.LanguageExtensions as LangExt
 
-import Data.Maybe       ( maybeToList )
+import Data.Maybe       ( isJust, maybeToList )
 
 {-
 ************************************************************************
@@ -1298,12 +1298,12 @@ mkPrimOpId prim_op
     name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
                          (mkPrimOpIdUnique (primOpTag prim_op))
                          (AnId id) UserSyntax
-    id   = mkGlobalId (PrimOpId prim_op) name ty info
+    id   = mkGlobalId (PrimOpId prim_op lev_poly) name ty info
+    lev_poly = not (argsHaveFixedRuntimeRep ty)
 
     -- PrimOps don't ever construct a product, but we want to preserve bottoms
-    cpr
-      | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr
-      | otherwise                                   = topCpr
+    cpr | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr
+        | otherwise                                   = topCpr
 
     info = noCafIdInfo
            `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)