Fix fun_type in Cmm dump (#22760)wip/supersven/ghc-correct-fun-type-Cmm

The correct fun_type is ArgGenBig if the arguments cannot be represented
in a small bitmap (i.e. a large bitmap is used.)

5 files changed, 50 insertions, 28 deletions

diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs
index 71c8ddfb42..812104bd98 100644
--- a/compiler/GHC/Cmm/Info.hs
+++ b/compiler/GHC/Cmm/Info.hs
@@ -242,20 +242,29 @@ mkInfoTableContents profile
            ; return (Nothing, Nothing,  extra_bits, []) }
 
     mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
+      = mk_pieces_arg_gen arity arg_bits aRG_GEN srt_label
+
+    mk_pieces (Fun arity (ArgGenBig arg_bits)) srt_label
+      = mk_pieces_arg_gen arity arg_bits aRG_GEN_BIG srt_label
+
+    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
+
+    mk_pieces_arg_gen arity arg_bits fun_type srt_label
       = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits
-           ; let fun_type | null liveness_data = aRG_GEN
-                          | otherwise          = aRG_GEN_BIG
+           ; let fun_type' | null liveness_data = aRG_GEN
+                           | otherwise          = aRG_GEN_BIG
                  extra_bits = [ packIntsCLit platform fun_type arity ]
-                           ++ (if inlineSRT platform then [] else [ srt_lit ])
+                           ++ ([ srt_lit | not (inlineSRT platform) ])
                            ++ [ liveness_lit, slow_entry ]
-           ; return (Nothing, Nothing, extra_bits, liveness_data) }
+           ; massert (fun_type == fun_type')
+           ; return (Nothing, Nothing, extra_bits, liveness_data)
+           }
       where
         slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)
         srt_lit = case srt_label of
                     []          -> mkIntCLit platform 0
                     (lit:_rest) -> assert (null _rest) lit
 
-    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
 
 mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
 
diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs
index 0e43f1b85e..cf458cea45 100644
--- a/compiler/GHC/Runtime/Heap/Layout.hs
+++ b/compiler/GHC/Runtime/Heap/Layout.hs
@@ -214,13 +214,16 @@ type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
 -- | An ArgDescr describes the argument pattern of a function
 
 data ArgDescr
-  = ArgSpec             -- Fits one of the standard patterns
-        !Int            -- RTS type identifier ARG_P, ARG_N, ...
+  = ArgSpec             -- ^ Fits one of the standard patterns
+        !Int            -- ^ RTS type identifier ARG_P, ARG_N, ...
 
-  | ArgGen              -- General case
-        Liveness        -- Details about the arguments
+  | ArgGen              -- ^ General case (small bitmap)
+        Liveness        -- ^ Details about the arguments
 
-  | ArgUnknown          -- For imported binds.
+  | ArgGenBig           -- ^ General case (large bitmap)
+        Liveness        -- ^ Details about the arguments
+
+  | ArgUnknown          -- ^ For imported binds.
                         -- Invariant: Never Unknown for binds of the module
                         -- we are compiling.
   deriving (Eq)
@@ -228,6 +231,7 @@ data ArgDescr
 instance Outputable ArgDescr where
   ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
   ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
+  ppr (ArgGenBig ls) = text "ArgGenBig" <+> ppr ls
   ppr ArgUnknown = text "ArgUnknown"
 
 -----------------------------------------------------------------------------
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 57cdb1d3f9..060c86e060 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -612,23 +612,29 @@ mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
 -- Here, we emit the slow-entry code.
 mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
   | Just (_, ArgGen _) <- closureFunInfo cl_info
-  = do cfg       <- getStgToCmmConfig
-       upd_frame <- getUpdFrameOff
-       let node = idToReg platform (NonVoid bndr)
-           profile  = stgToCmmProfile  cfg
-           platform = stgToCmmPlatform cfg
-           slow_lbl = closureSlowEntryLabel  platform cl_info
-           fast_lbl = closureLocalEntryLabel platform cl_info
-           -- mkDirectJump does not clobber `Node' containing function closure
-           jump = mkJump profile NativeNodeCall
-                                (mkLblExpr fast_lbl)
-                                (map (CmmReg . CmmLocal) (node : arg_regs))
-                                upd_frame
-       tscope <- getTickScope
-       emitProcWithConvention Slow Nothing slow_lbl
-         (node : arg_regs) (jump, tscope)
+    = mkSlowEntryCode' bndr cl_info arg_regs
+  | Just (_, ArgGenBig _) <- closureFunInfo cl_info
+    = mkSlowEntryCode' bndr cl_info arg_regs
   | otherwise = return ()
 
+mkSlowEntryCode' :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
+mkSlowEntryCode' bndr cl_info arg_regs = do
+  cfg <- getStgToCmmConfig
+  upd_frame <- getUpdFrameOff
+  let node = idToReg platform (NonVoid bndr)
+      profile = stgToCmmProfile  cfg
+      platform = stgToCmmPlatform cfg
+      slow_lbl = closureSlowEntryLabel  platform cl_info
+      fast_lbl = closureLocalEntryLabel platform cl_info
+      -- mkDirectJump does not clobber `Node' containing function closure
+      jump = mkJump profile NativeNodeCall
+                            (mkLblExpr fast_lbl)
+                            (map (CmmReg . CmmLocal) (node : arg_regs))
+                            upd_frame
+  tscope <- getTickScope
+  emitProcWithConvention Slow Nothing slow_lbl
+    (node : arg_regs) (jump, tscope)
+
 -----------------------------------------
 thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
           -> LocalReg -> CgStgExpr -> FCode ()
diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs
index 1f9e0e68b1..e67ce1eb2c 100644
--- a/compiler/GHC/StgToCmm/Heap.hs
+++ b/compiler/GHC/StgToCmm/Heap.hs
@@ -339,8 +339,9 @@ entryHeapCheck cl_info nodeSet arity args code = do
               Nothing -> CmmLit (CmmLabel $ staticClosureLabel platform cl_info)
 
     is_fastf = case closureFunInfo cl_info of
-                 Just (_, ArgGen _) -> False
-                 _otherwise         -> True
+                 Just (_, ArgGen _)    -> False
+                 Just (_, ArgGenBig _) -> False
+                 _otherwise            -> True
 
   entryHeapCheck' is_fastf node arity args code
 
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index a85a4aa495..98369ef38c 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -66,6 +66,7 @@ import GHC.Data.FastString
 import Control.Monad
 import GHC.StgToCmm.Config (stgToCmmPlatform)
 import GHC.StgToCmm.Types
+import GHC.Data.Bitmap (mAX_SMALL_BITMAP_SIZE)
 
 ------------------------------------------------------------------------
 --                Call and return sequences
@@ -548,10 +549,11 @@ mkArgDescr :: Platform -> [Id] -> ArgDescr
 mkArgDescr platform args
   = let arg_bits = argBits platform arg_reps
         arg_reps = filter isNonV (map (idArgRep platform) args)
+        isLargeBitmap = mAX_SMALL_BITMAP_SIZE platform < length arg_bits
            -- Getting rid of voids eases matching of standard patterns
     in case stdPattern arg_reps of
          Just spec_id -> ArgSpec spec_id
-         Nothing      -> ArgGen  arg_bits
+         Nothing      -> (if isLargeBitmap then ArgGenBig else ArgGen) arg_bits
 
 argBits :: Platform -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr
 argBits _         []           = []