Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC
Commits:
-
96c451aa
by Rodrigo Mesquita at 2025-12-19T10:21:32+00:00
-
e8aeb770
by Rodrigo Mesquita at 2025-12-19T13:57:27+00:00
8 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Linker.hs
- libraries/ghci/GHCi/CreateBCO.hs
- rts/PrimOps.cmm
- utils/genprimopcode/Main.hs
Changes:
| ... | ... | @@ -2099,9 +2099,6 @@ exceptionContextTyConKey = mkPreludeTyConUnique 420 |
| 2099 | 2099 | |
| 2100 | 2100 | unsafeUnpackJSStringUtf8ShShKey = mkPreludeMiscIdUnique 805
|
| 2101 | 2101 | |
| 2102 | -staticConObjPrimTyConKey :: Unique
|
|
| 2103 | -staticConObjPrimTyConKey = mkPreludeTyConUnique 501
|
|
| 2104 | - |
|
| 2105 | 2102 | {-
|
| 2106 | 2103 | ************************************************************************
|
| 2107 | 2104 | * *
|
| ... | ... | @@ -82,7 +82,6 @@ module GHC.Builtin.Types.Prim( |
| 82 | 82 | stableNamePrimTyCon, mkStableNamePrimTy,
|
| 83 | 83 | compactPrimTyCon, compactPrimTy,
|
| 84 | 84 | bcoPrimTyCon, bcoPrimTy,
|
| 85 | - staticConObjPrimTyCon, staticConObjPrimTy,
|
|
| 86 | 85 | weakPrimTyCon, mkWeakPrimTy,
|
| 87 | 86 | threadIdPrimTyCon, threadIdPrimTy,
|
| 88 | 87 | stackSnapshotPrimTyCon, stackSnapshotPrimTy,
|
| ... | ... | @@ -310,7 +309,7 @@ charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int3 |
| 310 | 309 | mutableArrayPrimTyConName, mutableByteArrayPrimTyConName,
|
| 311 | 310 | smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName,
|
| 312 | 311 | tVarPrimTyConName, stablePtrPrimTyConName,
|
| 313 | - stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, staticConObjPrimTyConName,
|
|
| 312 | + stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,
|
|
| 314 | 313 | weakPrimTyConName, threadIdPrimTyConName,
|
| 315 | 314 | eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,
|
| 316 | 315 | stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name
|
| ... | ... | @@ -348,7 +347,6 @@ stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyC |
| 348 | 347 | compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon
|
| 349 | 348 | stackSnapshotPrimTyConName = mkPrimTc (fsLit "StackSnapshot#") stackSnapshotPrimTyConKey stackSnapshotPrimTyCon
|
| 350 | 349 | bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon
|
| 351 | -staticConObjPrimTyConName = mkPrimTc (fsLit "StaticConObj#") staticConObjPrimTyConKey staticConObjPrimTyCon
|
|
| 352 | 350 | weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
|
| 353 | 351 | threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
|
| 354 | 352 | promptTagPrimTyConName = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon
|
| ... | ... | @@ -1401,12 +1399,6 @@ bcoPrimTy = mkTyConTy bcoPrimTyCon |
| 1401 | 1399 | bcoPrimTyCon :: TyCon
|
| 1402 | 1400 | bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName liftedRepTy
|
| 1403 | 1401 | |
| 1404 | --- A static constructor object is never a thunk, unlike BCOs
|
|
| 1405 | -staticConObjPrimTy :: Type
|
|
| 1406 | -staticConObjPrimTy = mkTyConTy staticConObjPrimTyCon
|
|
| 1407 | -staticConObjPrimTyCon :: TyCon
|
|
| 1408 | -staticConObjPrimTyCon = pcPrimTyCon0 staticConObjPrimTyConName unliftedRepTy
|
|
| 1409 | - |
|
| 1410 | 1402 | {-
|
| 1411 | 1403 | ************************************************************************
|
| 1412 | 1404 | * *
|
| ... | ... | @@ -3909,9 +3909,6 @@ section "Bytecode operations" |
| 3909 | 3909 | primtype BCO
|
| 3910 | 3910 | { Primitive bytecode type. }
|
| 3911 | 3911 | |
| 3912 | -primtype StaticConObj#
|
|
| 3913 | - { Primitive static constructor allocated on the heap type. }
|
|
| 3914 | - |
|
| 3915 | 3912 | primop AddrToAnyOp "addrToAny#" GenPrimOp
|
| 3916 | 3913 | Addr# -> (# a_levpoly #)
|
| 3917 | 3914 | { Convert an 'Addr#' to a followable Any type. }
|
| ... | ... | @@ -3951,7 +3948,7 @@ primop NewBCOOp "newBCO#" GenPrimOp |
| 3951 | 3948 | out_of_line = True
|
| 3952 | 3949 | |
| 3953 | 3950 | primop NewStaticConOp "newStaticCon#" GenPrimOp
|
| 3954 | - Array# a -> Int# -> State# s -> (# State# s, StaticConObj# #)
|
|
| 3951 | + Addr# -> Array# a -> Int# -> State# s -> (# State# s, a #)
|
|
| 3955 | 3952 | { @'newStaticCon#' data size@ creates a new static constructor object. The
|
| 3956 | 3953 | resulting object points to the given data laid out contiguously on a heap allocated location.
|
| 3957 | 3954 | The first element of the @data@ array must be a pointer to the info table representing the
|
| ... | ... | @@ -161,9 +161,9 @@ assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do |
| 161 | 161 | --
|
| 162 | 162 | |
| 163 | 163 | data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)
|
| 164 | - , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)
|
|
| 165 | - , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr )
|
|
| 166 | - }
|
|
| 164 | + , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)
|
|
| 165 | + , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr)
|
|
| 166 | + }
|
|
| 167 | 167 | |
| 168 | 168 | data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16)
|
| 169 | 169 | , final_ptr_array :: !(SmallArray BCOPtr)
|
| ... | ... | @@ -65,9 +65,7 @@ linkBCO |
| 65 | 65 | -> IO ResolvedBCO
|
| 66 | 66 | linkBCO interp pkgs_loaded le lb bco_ix
|
| 67 | 67 | (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
|
| 68 | - -- fromIntegral Word -> Word64 should be a no op if Word is Word64
|
|
| 69 | - -- otherwise it will result in a cast to longlong on 32bit systems.
|
|
| 70 | - (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0)
|
|
| 68 | + (lits :: [Word]) <- mapM (lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0)
|
|
| 71 | 69 | ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0)
|
| 72 | 70 | let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
|
| 73 | 71 | return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian
|
| ... | ... | @@ -33,6 +33,7 @@ import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# ) |
| 33 | 33 | import GHC.IO
|
| 34 | 34 | import Control.Exception ( ErrorCall(..) )
|
| 35 | 35 | import Data.Kind
|
| 36 | +import Data.Maybe
|
|
| 36 | 37 | |
| 37 | 38 | createBCOs :: [ResolvedBCO] -> IO [HValueRef]
|
| 38 | 39 | createBCOs bcos = do
|
| ... | ... | @@ -52,7 +53,7 @@ createBCO _ obj | resolvedBCOIsLE obj /= isLittleEndian |
| 52 | 53 | createBCO arr bco
|
| 53 | 54 | = do linked_thing <- linkBCO' arr bco
|
| 54 | 55 | case linked_thing of
|
| 55 | - LeftL linked_bco -> do
|
|
| 56 | + Left linked_bco -> do
|
|
| 56 | 57 | -- Note [Updatable CAF BCOs]
|
| 57 | 58 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~
|
| 58 | 59 | -- Why do we need mkApUpd0 here? Otherwise top-level
|
| ... | ... | @@ -72,10 +73,10 @@ createBCO arr bco |
| 72 | 73 | then return (HValue (unsafeCoerce linked_bco))
|
| 73 | 74 | else case mkApUpd0# linked_bco of { (# final_bco #) ->
|
| 74 | 75 | return (HValue final_bco) }
|
| 75 | - RightU linked_static_con -> do
|
|
| 76 | + Right linked_static_con -> do
|
|
| 76 | 77 | return (HValue (unsafeCoerce linked_static_con))
|
| 77 | 78 | |
| 78 | -linkBCO' :: Array Int HValue -> ResolvedBCO -> IO (EitherLU BCO StaticConObj#)
|
|
| 79 | +linkBCO' :: Array Int HValue -> ResolvedBCO -> IO (Either BCO HValue)
|
|
| 79 | 80 | linkBCO' arr ResolvedBCO{..} = do
|
| 80 | 81 | let
|
| 81 | 82 | ptrs = ssElts resolvedBCOPtrs
|
| ... | ... | @@ -97,7 +98,7 @@ linkBCO' arr ResolvedBCO{..} = do |
| 97 | 98 | }}
|
| 98 | 99 | linkBCO' arr ResolvedStaticCon{..} = do
|
| 99 | 100 | |
| 100 | - let data_size@(I# data_size#)
|
|
| 101 | + let data_size@(W# data_size#)
|
|
| 101 | 102 | = sizeSS resolvedStaticConData
|
| 102 | 103 | data_els = ssElts resolvedStaticConData
|
| 103 | 104 | |
| ... | ... | @@ -105,17 +106,17 @@ linkBCO' arr ResolvedStaticCon{..} = do |
| 105 | 106 | PtrsArr marr <- mkPtrsArray arr data_size $
|
| 106 | 107 | mapMaybe (\case
|
| 107 | 108 | (Left _,_) -> Nothing
|
| 108 | - (Right p,_) -> Just p
|
|
| 109 | + (Right p,i) -> Just (p, i)
|
|
| 109 | 110 | ) (zip data_els [0..])
|
| 110 | 111 | -- Second, write literals at the remaining location
|
| 111 | - writeLiterals marr $
|
|
| 112 | + writeLiterals (unsafeCoerce# marr) $
|
|
| 112 | 113 | mapMaybe (\case
|
| 113 | - (Left l,_) -> Just l
|
|
| 114 | + (Left l,i) -> Just (l, i)
|
|
| 114 | 115 | (Right _,_) -> Nothing
|
| 115 | 116 | ) (zip data_els [0..])
|
| 116 | 117 | |
| 117 | 118 | IO $ \s ->
|
| 118 | - case unsafeFreezeArray# marr' s of { (# s, arr #) ->
|
|
| 119 | + case unsafeFreezeArray# marr s of { (# s, arr #) ->
|
|
| 119 | 120 | newStaticCon# arr data_size# s
|
| 120 | 121 | }
|
| 121 | 122 | where
|
| ... | ... | @@ -126,9 +127,6 @@ linkBCO' arr ResolvedStaticCon{..} = do |
| 126 | 127 | writeLiteral arr w i = IO $ \s ->
|
| 127 | 128 | case writeArray# arr i w s of s' -> (# s', () #)
|
| 128 | 129 | |
| 129 | --- | Either for lifted @a@ and unlifted @b@
|
|
| 130 | -data EitherLU (a :: Type) (b :: UnliftedType) = LeftL a | RightU b
|
|
| 131 | - |
|
| 132 | 130 | -- we recursively link any sub-BCOs while making the ptrs array
|
| 133 | 131 | mkPtrsArray :: Array Int HValue -> Word -> [(ResolvedBCOPtr, Int{-index of array at which to write ResolvedBCOPtr-})] -> IO PtrsArr
|
| 134 | 132 | mkPtrsArray arr n_ptrs ptrs = do
|
| ... | ... | @@ -2185,15 +2185,24 @@ stg_newStaticConzh ( P_ data, W_ size ) |
| 2185 | 2185 | {
|
| 2186 | 2186 | W_ staticConObj, itbl, bytes;
|
| 2187 | 2187 | |
| 2188 | + // TODO: Could probably use the bytes from the StgArrBytes
|
|
| 2188 | 2189 | bytes = WDS(size);
|
| 2189 | 2190 | |
| 2190 | 2191 | ALLOC_PRIM (bytes);
|
| 2191 | 2192 | |
| 2192 | 2193 | staticConObj = Hp - bytes;
|
| 2193 | - // No memory barrier necessary as this is a new allocation.
|
|
| 2194 | - SET_HDR(staticConObj, stg_BCO_info, CCS_MAIN);
|
|
| 2195 | 2194 | |
| 2196 | - TODOOOOOOO
|
|
| 2195 | + // Copy the data (which includes the itbl pointer for this static con)
|
|
| 2196 | + W_ i;
|
|
| 2197 | + i = 0;
|
|
| 2198 | +for:
|
|
| 2199 | + if (i < size) {
|
|
| 2200 | + W_[staticConObj + WDS(i)] = StgArrBytes_payload(data,i);
|
|
| 2201 | + i = i + 1;
|
|
| 2202 | + goto for;
|
|
| 2203 | + }
|
|
| 2204 | + |
|
| 2205 | + return (staticConObj);
|
|
| 2197 | 2206 | }
|
| 2198 | 2207 | |
| 2199 | 2208 | stg_mkApUpd0zh ( P_ bco )
|
| ... | ... | @@ -944,7 +944,6 @@ ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy" |
| 944 | 944 | ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy"
|
| 945 | 945 | ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy"
|
| 946 | 946 | ppType (TyApp (TyCon "BCO") []) = "bcoPrimTy"
|
| 947 | -ppType (TyApp (TyCon "StaticConObj#") []) = "staticConObjPrimTy"
|
|
| 948 | 947 | ppType (TyApp (TyCon "Compact#") []) = "compactPrimTy"
|
| 949 | 948 | ppType (TyApp (TyCon "StackSnapshot#") []) = "stackSnapshotPrimTy"
|
| 950 | 949 | ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is GHC.Builtin.Types's name for ()
|