Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC Commits: 94b4fed5 by Rodrigo Mesquita at 2025-12-22T20:08:56+00:00 Trying to work around the lazy IO unlifted business... hard. test w/ ./hadrian/build -j --flavour=perf+debug_ghc+no_profiled_libs+debug_info --only="T25636" --freeze1 test - - - - - 8 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Linker/Loader.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3948,7 +3948,7 @@ primop NewBCOOp "newBCO#" GenPrimOp out_of_line = True primop NewConAppObjOp "newConAppObj#" GenPrimOp - Addr# -> ByteArray# -> Array# a -> Word# -> State# s -> (# State# s, b #) + Addr# -> ByteArray# -> Array# a_levpoly -> Word# -> State# s -> (# State# s, b_levpoly #) { @'newConAppObj#' datacon_itbl lits ptrs arity@ creates a new constructor application object on the heap from the info table pointer of the data constructor and the data arguments given in @ptrs@ and @lits@. The ===================================== compiler/GHC/ByteCode/Asm.hs ===================================== @@ -43,6 +43,7 @@ import GHC.Utils.Outputable ( Outputable(..), text, (<+>), vcat ) import GHC.Utils.Panic import GHC.Builtin.Types.Prim ( addrPrimTy ) +import GHC.Core.Type ( isUnliftedType ) import GHC.Core.TyCo.Compare ( eqType ) import GHC.Core.TyCon import GHC.Data.SizedSeq @@ -222,6 +223,7 @@ assembleBCO platform , unlinkedStaticConDataConName = dataConName dc , unlinkedStaticConLits = nonptrs , unlinkedStaticConPtrs = ptrs + , unlinkedStaticConIsUnlifted = isUnliftedType (dataConRepType dc) } where litBCOArg (Left l) = Just $ case literal platform l of ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -15,6 +15,7 @@ module GHC.ByteCode.Linker , lookupStaticPtr , lookupIE , linkFail + , BCOIx(..) ) where @@ -56,9 +57,9 @@ linkBCO :: Interp -> PkgsLoaded -> BytecodeLoaderState - -> NameEnv (Int, Bool) - -- ^ A mapping from names to int references to other BCOs or Static Constructors in this group. - -- The boolean identifies whether the referenced object is a BCO (when @True@) or a Static Constructor (when @False@) + -> NameEnv BCOIx + -- ^ A mapping from names to references to other BCOs + -- or static constructors in this group. -> UnlinkedBCO -> IO ResolvedBCO linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do @@ -80,6 +81,7 @@ linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do { unlinkedStaticConLits = lits0 , unlinkedStaticConPtrs = ptrs0 , unlinkedStaticConDataConName + , unlinkedStaticConIsUnlifted } -> do Ptr itbl_ptr# <- lookupIE interp pkgs_loaded bytecode_state unlinkedStaticConDataConName lits <- doLits lits0 @@ -90,6 +92,7 @@ linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do , resolvedStaticConArity = sizeFlatBag lits0 + sizeFlatBag ptrs0 , resolvedStaticConLits = lits , resolvedStaticConPtrs = ptrs + , resolvedStaticConIsUnlifted = unlinkedStaticConIsUnlifted } where doLits lits0 = do @@ -99,6 +102,17 @@ linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do doPtrs ptrs0 = addListToSS emptySS <$> do mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0) +-- | An index into a BCO or Static Constructor in this group. +-- +-- We distinguish between lifted and unlifted static constructors because +-- lifted ones get resolved by tying a knot, since there may be circular +-- dependencies between them, whereas unlifted ones get constructed in a first +-- pass. +data BCOIx = BCOIx !Int + | LiftedStaticConIx !Int + | UnliftedStaticConIx !Int + deriving (Eq, Ord, Show) + lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of BCONPtrWord lit -> return lit @@ -181,16 +195,16 @@ resolvePtr :: Interp -> PkgsLoaded -> BytecodeLoaderState - -> NameEnv (Int, Bool) + -> NameEnv BCOIx -> BCOPtr -> IO ResolvedBCOPtr resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = case ptr of BCOPtrName nm - | Just (ix, b) <- lookupNameEnv bco_ix nm - -> if b then - return (ResolvedBCORef ix) -- ref to another BCO in this group - else - return (ResolvedStaticConRef ix) -- ref to another StaticCon in this group + | Just bix <- lookupNameEnv bco_ix nm + -> return $ case bix of + BCOIx ix -> ResolvedBCORef ix + LiftedStaticConIx ix -> ResolvedStaticConRef ix + UnliftedStaticConIx ix -> ResolvedUnliftedStaticConRef ix | Just (_, rhv) <- lookupNameBytecodeState bco_loader_state nm -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -330,6 +330,7 @@ instance Binary UnlinkedBCO where <*> getViaBinName bh <*> get bh <*> get bh + <*> get bh _ -> panic "Binary UnlinkedBCO: invalid byte" put_ bh UnlinkedBCO {..} = do @@ -346,6 +347,7 @@ instance Binary UnlinkedBCO where putViaBinName bh unlinkedStaticConDataConName put_ bh unlinkedStaticConLits put_ bh unlinkedStaticConPtrs + put_ bh unlinkedStaticConIsUnlifted instance Binary BCOPtr where get bh = do ===================================== compiler/GHC/ByteCode/Types.hs ===================================== @@ -265,7 +265,8 @@ data UnlinkedBCO -- ('unlinkedStaticConDataConName') unlinkedStaticConDataConName :: !Name, unlinkedStaticConLits :: !(FlatBag BCONPtr), -- non-ptrs - unlinkedStaticConPtrs :: !(FlatBag BCOPtr) -- ptrs + unlinkedStaticConPtrs :: !(FlatBag BCOPtr), -- ptrs + unlinkedStaticConIsUnlifted :: !Bool } instance NFData UnlinkedBCO where @@ -328,8 +329,9 @@ instance Outputable UnlinkedBCO where = sep [text "BCO", ppr nm, text "with", ppr (sizeFlatBag lits), text "lits", ppr (sizeFlatBag ptrs), text "ptrs" ] - ppr (UnlinkedStaticCon nm dc_nm lits ptrs) + ppr (UnlinkedStaticCon nm dc_nm lits ptrs unl) = sep [text "StaticCon", ppr nm, text "for", + if unl then text "unlifted" else text "lifted", ppr dc_nm, text "with", ppr (sizeFlatBag lits), text "lits", ppr (sizeFlatBag ptrs), text "ptrs" ] ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -1044,13 +1044,35 @@ linkSomeBCOs interp pkgs_loaded bytecode_state mods = foldr fun do_link mods [] do_link [] = return [] do_link mods = do let flat = [ bco | bcos <- mods, bco <- bcos ] - names = map (\case UnlinkedBCO{unlinkedBCOName} -> (unlinkedBCOName, True) - UnlinkedStaticCon{unlinkedStaticConName} -> (unlinkedStaticConName, False) - ) flat - bco_ix = mkNameEnv (zipWith (\(n,isBCO) ix -> (n,(ix, isBCO))) names [0..]) + unl_objs = filter isUnliftedObj flat + lif_objs = filter (not . isUnliftedObj) flat + unl_objs_ix = mkNameEnv (zipWith mkBCOIx [0..] unl_objs) + lif_objs_ix = mkNameEnv (zipWith mkBCOIx [0..] lif_objs) + bco_ix = plusNameEnv unl_objs_ix lif_objs_ix resolved <- sequence [ linkBCO interp pkgs_loaded bytecode_state bco_ix bco | bco <- flat ] - hvrefs <- {- pprTrace "CreatingBCOS" (ppr (zip [bco | bco <- flat] [(0::Int)..])) $ -} createBCOs interp resolved - return (zipWith (\(n,_) hvr -> (n, hvr)) names hvrefs) + hvrefs <- createBCOs interp resolved + return (zip (map mkBCOName $ unl_objs ++ lif_objs) hvrefs) + + mkBCOName UnlinkedBCO{unlinkedBCOName} + = unlinkedBCOName + mkBCOName UnlinkedStaticCon{unlinkedStaticConName} + = unlinkedStaticConName + + mkBCOIx ix + UnlinkedBCO{unlinkedBCOName} + = (unlinkedBCOName, BCOIx ix) + mkBCOIx ix + UnlinkedStaticCon + { unlinkedStaticConName + , unlinkedStaticConIsUnlifted } + | unlinkedStaticConIsUnlifted + = (unlinkedStaticConName, UnliftedStaticConIx ix) + | otherwise + = (unlinkedStaticConName, LiftedStaticConIx ix) + + isUnliftedObj = \case + UnlinkedStaticCon{..} -> unlinkedStaticConIsUnlifted + _ -> False -- | Useful to apply to the result of 'linkSomeBCOs' makeForeignNamedHValueRefs ===================================== libraries/ghci/GHCi/CreateBCO.hs ===================================== @@ -1,5 +1,8 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnliftedNewtypes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} @@ -21,12 +24,13 @@ import GHCi.ResolvedBCO import GHCi.RemoteTypes import GHCi.BreakArray import GHC.Data.SizedSeq +import Data.List (partition) import System.IO (fixIO) import Control.Monad import Data.Array.Base import Foreign hiding (newArray) -import Unsafe.Coerce (unsafeCoerce) +import Unsafe.Coerce (unsafeCoerce, unsafeCoerceUnlifted) import GHC.Arr ( Array(..) ) import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO# ) import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# ) @@ -34,24 +38,43 @@ import GHC.IO import Control.Exception ( ErrorCall(..) ) createBCOs :: [ResolvedBCO] -> IO [HValueRef] -createBCOs bcos = do +createBCOs objs = do + + let (unl_objs, bcos) = partition isUnliftedObj objs + + -- First, construct the array of unlifted static cons. + -- Top-level unlifted constructors are never mutual recursive, so we can do + -- this by filling the array on demand + -- (it's also not possible to define a mutually recursive unlifted + -- top-level value, see [GHC-20185]), + (unl_cons, unl_hvals) <- createUnliftedStaticCons unl_objs + + -- Second, construct the lifted BCOs and static cons which may have + -- (circular) references to one another in this group. References from this + -- group to the unlifted static cons will be resolved by looking them up in + -- the array constructed in the first pass. let n_bcos = length bcos hvals <- fixIO $ \hvs -> do let arr = listArray (0, n_bcos-1) hvs - -- (BCO Index :-> HValue) - mapM (createBCO arr) bcos + mapM (createBCO arr unl_cons) bcos - mapM mkRemoteRef hvals + mapM mkRemoteRef (unl_hvals ++ hvals) + + where + isUnliftedObj :: ResolvedBCO -> Bool + isUnliftedObj = \case + ResolvedStaticCon{..} -> resolvedStaticConIsUnlifted + _ -> False -createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue -createBCO _ obj | resolvedBCOIsLE obj /= isLittleEndian +createBCO :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO HValue +createBCO _ _ obj | resolvedBCOIsLE obj /= isLittleEndian = throwIO (ErrorCall $ unlines [ "The endianness of the ResolvedBCO does not match" , "the systems endianness. Using ghc and iserv in a" , "mixed endianness setup is not supported!" ]) -createBCO arr bco - = do linked_thing <- linkBCO' arr bco +createBCO arr unl_arr bco + = do linked_thing <- linkBCO' arr unl_arr bco case linked_thing of LinkedBCO bco_arity linked_bco -> do -- Note [Updatable CAF BCOs] @@ -75,13 +98,45 @@ createBCO arr bco return (HValue final_bco) } LinkedStaticCon linked_static_con -> do return linked_static_con + LinkedUnliftedStaticCon linked_static_con -> do + return $! forgetUnliftedHValue linked_static_con +-- | The resulting of linking a BCO or static constructor data LinkedBCO = LinkedBCO !Int{-BCO arity-} BCO | LinkedStaticCon HValue + | LinkedUnliftedStaticCon UnliftedHValue -linkBCO' :: Array Int HValue -> ResolvedBCO -> IO LinkedBCO -linkBCO' arr resolved_obj = +-- | From a list of 'UnliftedStaticCon's, create an array of unlifted heap closures +-- Invariant: All ResolvedBCOs are UnliftedStaticCons +createUnliftedStaticCons :: [ResolvedBCO] -> IO (UnlConsArr, [HValue {- references to actually unlifted values, but we "forget" that -}]) +createUnliftedStaticCons objs = do + -- Ensure objs are topologically sorted by their dependencies + -- Then, just fill them in in order! + let !(I# arr_size#) = length objs + !(EmptyArr emp_arr#) = emptyArr + ucarr@(UnlConsArr unl_arr#) <- IO $ \s -> + case newArray# arr_size# (UnliftedHValue (unsafeCoerceUnlifted emp_arr#)) s of + (# s, arr #) -> (# s, UnlConsArr arr #) + vs <- forM (zip objs [0..]) $ \(obj, !(I# i#)) -> case obj of + ResolvedStaticCon{..} + | resolvedStaticConIsUnlifted + -> do + -- Because we topologically sort the objs, it's safe to assume all + -- references will already be filled in. + lbc <- linkBCO' (error "there should be no lifted dependencies for unlifted objs") ucarr obj + case lbc of + LinkedUnliftedStaticCon linked_static_con -> do + IO $ \s -> + case writeArray# unl_arr# i# linked_static_con s of + s -> (# s, forgetUnliftedHValue linked_static_con #) + _ -> error "createUnliftedStaticCons: unexpected lifted ResolvedBCO" + _ -> + error "createUnliftedStaticCons: unexpected lifted ResolvedBCO" + return (ucarr, vs) + +linkBCO' :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO +linkBCO' arr unl_arr resolved_obj = case resolved_obj of ResolvedBCO{..} -> do let @@ -94,7 +149,7 @@ linkBCO' arr resolved_obj = bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap) literals_barr = barr (getBCOByteArray resolvedBCOLits) - PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs + PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> case LinkedBCO resolvedBCOArity <$> @@ -113,47 +168,69 @@ linkBCO' arr resolved_obj = !(W# itbl_ptr_w#) = resolvedStaticConInfoPtr !(Ptr itbl_ptr#) = Ptr (int2Addr# (word2Int# itbl_ptr_w#)) - PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs + PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs IO $ \s -> case unsafeFreezeArray# marr s of { (# s, arr #) -> case newConAppObj# itbl_ptr# literals_barr arr data_size# s of - (# s, hval #) -> (# s, LinkedStaticCon (HValue hval) #) + (# s, hval #) -> + (# s, if resolvedStaticConIsUnlifted then + LinkedUnliftedStaticCon (UnliftedHValue (unsafeCoerce# hval)) + else + LinkedStaticCon (HValue hval) #) } where !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array] barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr# -- we recursively link any sub-BCOs while making the ptrs array -mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr -mkPtrsArray arr n_ptrs ptrs = do +mkPtrsArray :: Array Int HValue -> UnlConsArr -> Word -> [ResolvedBCOPtr] -> IO PtrsArr +mkPtrsArray arr (UnlConsArr unl_arr) n_ptrs ptrs = do marr <- newPtrsArray (fromIntegral n_ptrs) let fill (ResolvedBCORef n) i = - writePtrsArrayHValue i (arr ! n{-thunk which returns the HValue by looking it up in the arr which is captured by the thunk-}) marr -- must be lazy! + writePtrsArrayHValue i (arr ! n) marr -- must be lazy! fill (ResolvedStaticConRef n) i = do - -- this MUST be /strict/! - -- the static con reference must be an evaluated pointer to the data con - -- info table, but (arr ! n) would construct a thunk instead if unforced. - writePtrsArrayHValue i (arr ! n) marr + writePtrsArrayHValue i (arr ! n) marr -- must be lazy! + fill (ResolvedUnliftedStaticConRef !(I# n#)) i = do + -- must be strict! we want to store the unlifted con, + -- not the arr indexing thunk. + !unl_val <- IO $ \s -> + case readArray# unl_arr n# s of + (# s, val #) -> (# s, forgetUnliftedHValue val #) + writePtrsArrayHValue i unl_val marr fill (ResolvedBCOPtr r) i = do hv <- localRef r writePtrsArrayHValue i hv marr fill (ResolvedBCOStaticPtr r) i = do writePtrsArrayPtr i (fromRemotePtr r) marr fill (ResolvedBCOPtrBCO bco) i = do - obj <- linkBCO' arr bco + obj <- linkBCO' arr (UnlConsArr unl_arr) bco case obj of LinkedBCO _ bco -> writePtrsArrayBCO i bco marr - LinkedStaticCon !linked_static_con -> + LinkedStaticCon linked_static_con -> writePtrsArrayHValue i linked_static_con marr + LinkedUnliftedStaticCon linked_static_con -> do + let !unl_val = forgetUnliftedHValue linked_static_con + writePtrsArrayHValue i unl_val marr fill (ResolvedBCOPtrBreakArray r) i = do BA mba <- localRef r writePtrsArrayMBA i mba marr zipWithM_ fill ptrs [0..] return marr +-- | A heap closure of unlifted type +type UnliftedHValue :: UnliftedType +newtype UnliftedHValue = UnliftedHValue (Any @UnliftedType) + +-- | Forget that a heap closure is unlifted, and return it as a lifted heap closure. +forgetUnliftedHValue :: UnliftedHValue -> HValue +forgetUnliftedHValue (UnliftedHValue a) = HValue (unsafeCoerce# a) + +-- | A lifted array with unlifted static constructor 'UnliftedHValue's +data UnlConsArr = UnlConsArr (MutableArray# RealWorld UnliftedHValue) + data PtrsArr = PtrsArr (MutableArray# RealWorld HValue) newPtrsArray :: Int -> IO PtrsArr ===================================== libraries/ghci/GHCi/ResolvedBCO.hs ===================================== @@ -54,7 +54,8 @@ data ResolvedBCO resolvedStaticConInfoPtr :: {-# UNPACK #-} !Word, -- ^ info ptr Addr# as a Word resolvedStaticConArity :: {-# UNPACK #-} !Word, resolvedStaticConLits :: BCOByteArray Word, - resolvedStaticConPtrs :: SizedSeq ResolvedBCOPtr + resolvedStaticConPtrs :: SizedSeq ResolvedBCOPtr, + resolvedStaticConIsUnlifted :: Bool } deriving (Generic, Show) @@ -103,11 +104,12 @@ instance Binary ResolvedBCO where put resolvedStaticConArity put resolvedStaticConLits put resolvedStaticConPtrs + put resolvedStaticConIsUnlifted get = do t <- getWord8 case t of 0 -> ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get - 1 -> ResolvedStaticCon <$> get <*> get <*> get <*> get <*> get + 1 -> ResolvedStaticCon <$> get <*> get <*> get <*> get <*> get <*> get _ -> error "Binary ResolvedBCO: invalid byte" -- See Note [BCOByteArray serialization] @@ -118,7 +120,8 @@ instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) wher data ResolvedBCOPtr = ResolvedBCORef {-# UNPACK #-} !Int - -- ^ reference to the Nth BCO in the current set + -- ^ reference to the Nth BCO in the current set of BCOs and + -- lifted static constructors | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue) -- ^ reference to a previously created BCO | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ()) @@ -128,7 +131,11 @@ data ResolvedBCOPtr | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray) -- ^ Resolves to the MutableArray# inside the BreakArray | ResolvedStaticConRef {-# UNPACK #-} !Int - -- ^ reference to the Nth static constructor in the current set + -- ^ reference to the Nth static constructor in the current set of BCOs + -- and lifted static constructors + | ResolvedUnliftedStaticConRef {-# UNPACK #-} !Int + -- ^ reference to the Nth unlifted static constructor in the current set + -- of exclusively unlifted static constructors deriving (Generic, Show) instance Binary ResolvedBCOPtr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94b4fed57d01fea75428b7ada80b6aaa... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94b4fed57d01fea75428b7ada80b6aaa... You're receiving this email because of your account on gitlab.haskell.org.