GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

472df471

by Peter Trommler at 2026-01-08T13:28:54-05:00

Use half-word literals in info tables

With this commit info tables are mapped to the same assembler code
on big-endian and little-endian platforms.

Fixes #26579.

2 changed files:

compiler/GHC/Cmm/Info.hs
compiler/GHC/Cmm/Utils.hs

Changes:

compiler/GHC/Cmm/Info.hs

@@ -28,7 +28,7 @@ module GHC.Cmm.Info (
    conInfoTableSizeB,
    stdSrtBitmapOffset,
    stdClosureTypeOffset,
 -  stdPtrsOffset, stdNonPtrsOffset,
 +  stdPtrsOffset, stdNonPtrsOffset
  ) where
  import GHC.Prelude
@@ -194,7 +194,7 @@ mkInfoTableContents profile
         ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
         ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame
         ; let
 -             std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap liveness_lit
 +             std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap [liveness_lit]
               rts_tag | Just tag <- mb_rts_tag = tag
                       | null liveness_data     = rET_SMALL -- Fits in extra_bits
                       | otherwise              = rET_BIG   -- Does not; extra_bits is
@@ -202,7 +202,8 @@ mkInfoTableContents profile
         ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
    | HeapRep _ ptrs nonptrs closure_type <- smrep
 -  = do { let layout  = packIntsCLit platform ptrs nonptrs
 +  = do { let layout  = [ mkStgHalfWordCLit platform ptrs,
 +                         mkStgHalfWordCLit platform nonptrs]
         ; (prof_lits, prof_data) <- mkProfLits platform prof
         ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
         ; (mb_srt_field, mb_layout, extra_bits, ct_data)
@@ -214,11 +215,23 @@ mkInfoTableContents profile
         ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
    where
      platform = profilePlatform profile
 +    mk_extra_bits :: Int -> Int -> [CmmLit]
 +    mk_extra_bits low high
 +      = if platformTablesNextToCode platform
 +           -- In mkInfoTable do_one_info extra bits are reversed for TNTC
 +           -- so we must generate the high address halfword before
 +           -- the low address halfword.
 +        then [ mkStgHalfWordCLit platform high
 +             , mkStgHalfWordCLit platform low
 +             ]
 +        else [ mkStgHalfWordCLit platform low
 +             , mkStgHalfWordCLit platform high
 +             ]
      mk_pieces :: ClosureTypeInfo -> [CmmLit]
 -              -> UniqDSM ( Maybe CmmLit  -- Override the SRT field with this
 -                         , Maybe CmmLit  -- Override the layout field with this
 -                         , [CmmLit]           -- "Extra bits" for info table
 -                         , [RawCmmDecl])      -- Auxiliary data decls
 +              -> UniqDSM ( Maybe CmmLit   -- Override the SRT field with this
 +                         , Maybe [CmmLit] -- Override the layout field with this
 +                         , [CmmLit]       -- "Extra bits" for info table
 +                         , [RawCmmDecl])  -- Auxiliary data decls
      mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
        = do { (descr_lit, decl) <- newStringLit con_descr
             ; return ( Just (CmmInt (fromIntegral con_tag)
@@ -230,18 +243,19 @@ mkInfoTableContents profile
      mk_pieces (ThunkSelector offset) _no_srt
        = return (Just (CmmInt 0 (halfWordWidth platform)),
 -                Just (mkWordCLit platform (fromIntegral offset)), [], [])
 +                Just [(mkWordCLit platform (fromIntegral offset))], [], [])
           -- Layout known (one free var); we use the layout field for offset
      mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
 -      = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label
 +      = do { let extra_bits = mk_extra_bits fun_type arity
 +                           ++ srt_label
             ; return (Nothing, Nothing,  extra_bits, []) }
      mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
        = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits
             ; let fun_type | null liveness_data = aRG_GEN
                            | otherwise          = aRG_GEN_BIG
 -                 extra_bits = [ packIntsCLit platform fun_type arity ]
 +                 extra_bits = mk_extra_bits fun_type arity
                             ++ (if inlineSRT platform then [] else [ srt_lit ])
                             ++ [ liveness_lit, slow_entry ]
             ; return (Nothing, Nothing, extra_bits, liveness_data) }
@@ -255,11 +269,13 @@ mkInfoTableContents profile
  mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
 -packIntsCLit :: Platform -> Int -> Int -> CmmLit
 -packIntsCLit platform a b = packHalfWordsCLit platform
 -                           (toStgHalfWord platform (fromIntegral a))
 -                           (toStgHalfWord platform (fromIntegral b))
 +mkStgWordCLit :: Platform -> StgWord -> CmmLit
 +mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
 +mkStgHalfWordCLit :: Platform -> Int -> CmmLit
 +mkStgHalfWordCLit platform hwd
 +  = CmmInt (fromStgHalfWord (toStgHalfWord platform (fromIntegral hwd)))
 +           (halfWordWidth platform)
  mkSRTLit :: Platform
           -> CLabel
@@ -385,15 +401,15 @@ mkStdInfoTable
     -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)
     -> Int               -- Closure RTS tag
     -> CmmLit            -- SRT length
 -   -> CmmLit            -- layout field
 +   -> [CmmLit]          -- layout field
     -> [CmmLit]
 -mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit
 +mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lits
   =      -- Parallel revertible-black hole field
      prof_info
          -- Ticky info (none at present)
          -- Debug info (none at present)
 - ++ [layout_lit, tag, srt]
 + ++ layout_lits ++ [tag, srt]
   where
      platform = profilePlatform profile

compiler/GHC/Cmm/Utils.hs

@@ -13,10 +13,9 @@ module GHC.Cmm.Utils(
          -- CmmLit
          zeroCLit, mkIntCLit,
 -        mkWordCLit, packHalfWordsCLit,
 +        mkWordCLit,
          mkByteStringCLit, mkFileEmbedLit,
          mkDataLits, mkRODataLits,
 -        mkStgWordCLit,
          -- CmmExpr
          mkIntExpr, zeroExpr,
@@ -211,22 +210,6 @@ mkRODataLits lbl lits
      needsRelocation (CmmLabelOff _ _) = True
      needsRelocation _                 = False
 -mkStgWordCLit :: Platform -> StgWord -> CmmLit
 -mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
+-
 -packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit
 --- Make a single word literal in which the lower_half_word is
 --- at the lower address, and the upper_half_word is at the
 --- higher address
 --- ToDo: consider using half-word lits instead
 ---       but be careful: that's vulnerable when reversed
 -packHalfWordsCLit platform lower_half_word upper_half_word
 -   = case platformByteOrder platform of
 -       BigEndian    -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
 -       LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
 -    where l = fromStgHalfWord lower_half_word
 -          u = fromStgHalfWord upper_half_word
+-
  ---------------------------------------------------
  --
  --      CmmExpr