Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC
Commits:
-
c20b043b
by Rodrigo Mesquita at 2025-12-19T20:30:44+00:00
3 changed files:
Changes:
| ... | ... | @@ -25,6 +25,7 @@ module GHC.ByteCode.Asm ( |
| 25 | 25 | |
| 26 | 26 | import GHC.Prelude hiding ( any, words )
|
| 27 | 27 | |
| 28 | +import Data.Maybe
|
|
| 28 | 29 | import GHC.ByteCode.Instr
|
| 29 | 30 | import GHC.ByteCode.InfoTable
|
| 30 | 31 | import GHC.ByteCode.Types
|
| ... | ... | @@ -41,6 +42,8 @@ import GHC.Unit.Types |
| 41 | 42 | import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat )
|
| 42 | 43 | import GHC.Utils.Panic
|
| 43 | 44 | |
| 45 | +import GHC.Builtin.Types.Prim ( addrPrimTy )
|
|
| 46 | +import GHC.Core.TyCo.Compare ( eqType )
|
|
| 44 | 47 | import GHC.Core.TyCon
|
| 45 | 48 | import GHC.Data.SizedSeq
|
| 46 | 49 | import GHC.Data.SmallArray
|
| ... | ... | @@ -67,7 +70,6 @@ import Data.Array.Base ( unsafeWrite ) |
| 67 | 70 | import Foreign hiding (shiftL, shiftR)
|
| 68 | 71 | import Data.ByteString (ByteString)
|
| 69 | 72 | import Data.Char (ord)
|
| 70 | -import Data.Maybe (fromMaybe)
|
|
| 71 | 73 | import GHC.Float (castFloatToWord32, castDoubleToWord64)
|
| 72 | 74 | |
| 73 | 75 | import qualified Data.List as List ( any )
|
| ... | ... | @@ -211,12 +213,10 @@ assembleBCO :: Platform -> ProtoBCO -> IO UnlinkedBCO |
| 211 | 213 | assembleBCO platform
|
| 212 | 214 | (ProtoStaticCon { protoStaticConName
|
| 213 | 215 | , protoStaticCon = dc
|
| 214 | - , protoStaticConLits = lits
|
|
| 215 | - , protoStaticConIds = ids
|
|
| 216 | + , protoStaticConData = args
|
|
| 216 | 217 | }) = do
|
| 217 | - pprTraceM "assembleBCO: static con" (ppr dc <+> ppr lits <+> ppr ids)
|
|
| 218 | - let ptrs = foldr mappendFlatBag emptyFlatBag (map idBCOArg ids)
|
|
| 219 | - let nonptrs = foldr mappendFlatBag emptyFlatBag (map litBCOArg lits)
|
|
| 218 | + let ptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe idBCOArg args)
|
|
| 219 | + let nonptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe litBCOArg args)
|
|
| 220 | 220 | pure UnlinkedStaticCon
|
| 221 | 221 | { unlinkedStaticConName = protoStaticConName
|
| 222 | 222 | , unlinkedStaticConDataConName = dataConName dc
|
| ... | ... | @@ -224,14 +224,24 @@ assembleBCO platform |
| 224 | 224 | , unlinkedStaticConPtrs = ptrs
|
| 225 | 225 | }
|
| 226 | 226 | where
|
| 227 | - litBCOArg l = case literal platform l of
|
|
| 227 | + litBCOArg (Left l) = Just $ case literal platform l of
|
|
| 228 | 228 | OnlyOne np -> unitFlatBag np
|
| 229 | 229 | OnlyTwo np1 np2 -> TupleFlatBag np1 np2
|
| 230 | - idBCOArg i
|
|
| 231 | - | Just prim <- isPrimOpId_maybe i
|
|
| 232 | - = unitFlatBag (BCOPtrPrimOp prim)
|
|
| 230 | + litBCOArg (Right var)
|
|
| 231 | + -- Addr# literals are non-pointers
|
|
| 232 | + | idType var `eqType` addrPrimTy
|
|
| 233 | + = Just $ unitFlatBag (BCONPtrAddr (getName var))
|
|
| 233 | 234 | | otherwise
|
| 234 | - = unitFlatBag (BCOPtrName (getName i))
|
|
| 235 | + = Nothing
|
|
| 236 | + |
|
| 237 | + idBCOArg (Left _) = Nothing
|
|
| 238 | + idBCOArg (Right var)
|
|
| 239 | + | idType var `eqType` addrPrimTy
|
|
| 240 | + = Nothing
|
|
| 241 | + | Just prim <- isPrimOpId_maybe var
|
|
| 242 | + = Just $ unitFlatBag (BCOPtrPrimOp prim)
|
|
| 243 | + | otherwise
|
|
| 244 | + = Just $ unitFlatBag (BCOPtrName (getName var))
|
|
| 235 | 245 | |
| 236 | 246 | assembleBCO platform
|
| 237 | 247 | (ProtoBCO { protoBCOName = nm
|
| ... | ... | @@ -56,10 +56,14 @@ data ProtoBCO |
| 56 | 56 | -- ^ The name to which this static constructor is bound,
|
| 57 | 57 | -- not to be confused with the DataCon itself.
|
| 58 | 58 | protoStaticCon :: DataCon,
|
| 59 | - protoStaticConLits :: [Literal],
|
|
| 60 | - protoStaticConIds :: [Id],
|
|
| 61 | - -- | What the static con came from, for debugging only
|
|
| 59 | + -- ^ The DataCon being constructed.
|
|
| 60 | + -- We use this to construct the right info table.
|
|
| 61 | + protoStaticConData :: [Either Literal Id],
|
|
| 62 | + -- ^ The static constructor pointer and non-pointer arguments, sorted
|
|
| 63 | + -- in the order they should appear at runtime (see 'mkVirtConstrOffsets').
|
|
| 64 | + -- The pointers always come first, followed by the non-pointers.
|
|
| 62 | 65 | protoStaticConExpr :: CgStgRhs
|
| 66 | + -- ^ What the static con came from, for debugging only
|
|
| 63 | 67 | }
|
| 64 | 68 | |
| 65 | 69 | -- | A local block label (e.g. identifying a case alternative).
|
| ... | ... | @@ -293,11 +297,10 @@ data BCInstr |
| 293 | 297 | -- Printing bytecode instructions
|
| 294 | 298 | |
| 295 | 299 | instance Outputable ProtoBCO where
|
| 296 | - ppr (ProtoStaticCon nm con lits ids origin)
|
|
| 300 | + ppr (ProtoStaticCon nm con args origin)
|
|
| 297 | 301 | = text "ProtoStaticCon" <+> ppr nm <+> text "for constructor" <+> ppr con <> colon
|
| 298 | 302 | $$ nest 3 (pprStgRhsShort shortStgPprOpts origin)
|
| 299 | - $$ nest 3 (text "lits: " <+> ppr lits)
|
|
| 300 | - $$ nest 3 (text "ids: " <+> ppr ids)
|
|
| 303 | + $$ nest 3 (text "sorted args: " <+> ppr args)
|
|
| 301 | 304 | ppr (ProtoBCO { protoBCOName = name
|
| 302 | 305 | , protoBCOInstrs = instrs
|
| 303 | 306 | , protoBCOBitmap = bitmap
|
| ... | ... | @@ -316,8 +316,9 @@ schemeTopBind (id, rhs@(StgRhsCon _ dc _ _ args _)) |
| 316 | 316 | return ProtoStaticCon
|
| 317 | 317 | { protoStaticConName = getName id
|
| 318 | 318 | , protoStaticCon = dc
|
| 319 | - , protoStaticConLits = [ lit | (NonVoid (StgLitArg lit), _) <- args_offsets ]
|
|
| 320 | - , protoStaticConIds = [ i | (NonVoid (StgVarArg i), _) <- args_offsets {-, assert is never a local var -} ]
|
|
| 319 | + , protoStaticConData = [ case a of StgLitArg l -> Left l
|
|
| 320 | + StgVarArg i -> Right i
|
|
| 321 | + | (NonVoid a, _) <- args_offsets ]
|
|
| 321 | 322 | , protoStaticConExpr = rhs
|
| 322 | 323 | }
|
| 323 | 324 | schemeTopBind (id, rhs)
|