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 Almost there. Finally, we get a runtime loop That's something better to investigate. No longer messing up the names and addr# - - - - - 3 changed files: - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/StgToByteCode.hs Changes: ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -25,6 +25,7 @@ module GHC.ByteCode.Asm ( import GHC.Prelude hiding ( any, words ) +import Data.Maybe import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable import GHC.ByteCode.Types @@ -41,6 +42,8 @@ import GHC.Unit.Types import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat ) import GHC.Utils.Panic +import GHC.Builtin.Types.Prim ( addrPrimTy ) +import GHC.Core.TyCo.Compare ( eqType ) import GHC.Core.TyCon import GHC.Data.SizedSeq import GHC.Data.SmallArray @@ -67,7 +70,6 @@ import Data.Array.Base ( unsafeWrite ) import Foreign hiding (shiftL, shiftR) import Data.ByteString (ByteString) import Data.Char (ord) -import Data.Maybe (fromMaybe) import GHC.Float (castFloatToWord32, castDoubleToWord64) import qualified Data.List as List ( any ) @@ -211,12 +213,10 @@ assembleBCO :: Platform -> ProtoBCO -> IO UnlinkedBCO assembleBCO platform (ProtoStaticCon { protoStaticConName , protoStaticCon = dc - , protoStaticConLits = lits - , protoStaticConIds = ids + , protoStaticConData = args }) = do - pprTraceM "assembleBCO: static con" (ppr dc <+> ppr lits <+> ppr ids) - let ptrs = foldr mappendFlatBag emptyFlatBag (map idBCOArg ids) - let nonptrs = foldr mappendFlatBag emptyFlatBag (map litBCOArg lits) + let ptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe idBCOArg args) + let nonptrs = foldr mappendFlatBag emptyFlatBag (mapMaybe litBCOArg args) pure UnlinkedStaticCon { unlinkedStaticConName = protoStaticConName , unlinkedStaticConDataConName = dataConName dc @@ -224,14 +224,24 @@ assembleBCO platform , unlinkedStaticConPtrs = ptrs } where - litBCOArg l = case literal platform l of + litBCOArg (Left l) = Just $ case literal platform l of OnlyOne np -> unitFlatBag np OnlyTwo np1 np2 -> TupleFlatBag np1 np2 - idBCOArg i - | Just prim <- isPrimOpId_maybe i - = unitFlatBag (BCOPtrPrimOp prim) + litBCOArg (Right var) + -- Addr# literals are non-pointers + | idType var `eqType` addrPrimTy + = Just $ unitFlatBag (BCONPtrAddr (getName var)) | otherwise - = unitFlatBag (BCOPtrName (getName i)) + = Nothing + + idBCOArg (Left _) = Nothing + idBCOArg (Right var) + | idType var `eqType` addrPrimTy + = Nothing + | Just prim <- isPrimOpId_maybe var + = Just $ unitFlatBag (BCOPtrPrimOp prim) + | otherwise + = Just $ unitFlatBag (BCOPtrName (getName var)) assembleBCO platform (ProtoBCO { protoBCOName = nm ===================================== compiler/GHC/ByteCode/Instr.hs ===================================== @@ -56,10 +56,14 @@ data ProtoBCO -- ^ The name to which this static constructor is bound, -- not to be confused with the DataCon itself. protoStaticCon :: DataCon, - protoStaticConLits :: [Literal], - protoStaticConIds :: [Id], - -- | What the static con came from, for debugging only + -- ^ The DataCon being constructed. + -- We use this to construct the right info table. + protoStaticConData :: [Either Literal Id], + -- ^ The static constructor pointer and non-pointer arguments, sorted + -- in the order they should appear at runtime (see 'mkVirtConstrOffsets'). + -- The pointers always come first, followed by the non-pointers. protoStaticConExpr :: CgStgRhs + -- ^ What the static con came from, for debugging only } -- | A local block label (e.g. identifying a case alternative). @@ -293,11 +297,10 @@ data BCInstr -- Printing bytecode instructions instance Outputable ProtoBCO where - ppr (ProtoStaticCon nm con lits ids origin) + ppr (ProtoStaticCon nm con args origin) = text "ProtoStaticCon" <+> ppr nm <+> text "for constructor" <+> ppr con <> colon $$ nest 3 (pprStgRhsShort shortStgPprOpts origin) - $$ nest 3 (text "lits: " <+> ppr lits) - $$ nest 3 (text "ids: " <+> ppr ids) + $$ nest 3 (text "sorted args: " <+> ppr args) ppr (ProtoBCO { protoBCOName = name , protoBCOInstrs = instrs , protoBCOBitmap = bitmap ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -316,8 +316,9 @@ schemeTopBind (id, rhs@(StgRhsCon _ dc _ _ args _)) return ProtoStaticCon { protoStaticConName = getName id , protoStaticCon = dc - , protoStaticConLits = [ lit | (NonVoid (StgLitArg lit), _) <- args_offsets ] - , protoStaticConIds = [ i | (NonVoid (StgVarArg i), _) <- args_offsets {-, assert is never a local var -} ] + , protoStaticConData = [ case a of StgLitArg l -> Left l + StgVarArg i -> Right i + | (NonVoid a, _) <- args_offsets ] , protoStaticConExpr = rhs } schemeTopBind (id, rhs) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c20b043b6a006361c1744c6886ad0c97... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c20b043b6a006361c1744c6886ad0c97... You're receiving this email because of your account on gitlab.haskell.org.