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, 43 insertions, 23 deletions

diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index d9d8b41f33..419c0c8806 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -150,7 +150,7 @@ module GHC.Core.Type (
         Kind,
 
         -- ** Finding the kind of a type
-        typeKind, tcTypeKind, typeHasFixedRuntimeRep,
+        typeKind, tcTypeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep,
         tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,
         tcIsBoxedTypeKind, tcIsRuntimeTypeKind,
 
@@ -294,8 +294,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
 
@@ -3201,6 +3200,19 @@ typeHasFixedRuntimeRep = go
     go (ForAllTy _ ty)          = go ty
     go ty                       = isFixedRuntimeRepKind (typeKind ty)
 
+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 0ff846d79e..6316e321d4 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -528,9 +528,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
 
@@ -564,7 +564,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 33999c5070..2d287a1b3d 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -1422,7 +1422,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
@@ -1629,7 +1629,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 d6fd70e8db..5ba4decd4f 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -51,7 +51,7 @@ import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )
 import GHC.Unit.Module
 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
@@ -548,7 +548,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.
@@ -600,10 +600,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 d5b308a550..01ad94172a 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -500,16 +500,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
@@ -575,7 +575,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 (realIdUnfolding id)
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index 1b4ee7ae1c..ee7708baa8 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -153,7 +153,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
 
@@ -274,7 +277,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 3089c6533f..e46a3279fa 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -81,7 +81,6 @@ import GHC.Utils.Panic.Plain
 import GHC.Data.FastString
 import GHC.Data.List.SetOps
 
-
 {-
 ************************************************************************
 *                                                                      *