Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC

Commits:

8 changed files:

Changes:

  • compiler/GHC/Builtin/primops.txt.pp
    ... ... @@ -3948,7 +3948,7 @@ primop NewBCOOp "newBCO#" GenPrimOp
    3948 3948 
        out_of_line      = True
    3949 3949
    3950 3950 
     primop  NewConAppObjOp "newConAppObj#" GenPrimOp
    3951 
    -   Addr# -> ByteArray# -> Array# a -> Word# -> State# s -> (# State# s, b #)
    3951 
    +   Addr# -> ByteArray# -> Array# a_levpoly -> Word# -> State# s -> (# State# s, b_levpoly #)
    3952 3952 
        { @'newConAppObj#' datacon_itbl lits ptrs arity@ creates a new constructor
    3953 3953 
          application object on the heap from the info table pointer of the data
    3954 3954 
          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 )
    43 43 
     import GHC.Utils.Panic
    44 44
    45 45 
     import GHC.Builtin.Types.Prim ( addrPrimTy )
    46 
    +import GHC.Core.Type          ( isUnliftedType )
    46 47 
     import GHC.Core.TyCo.Compare  ( eqType )
    47 48 
     import GHC.Core.TyCon
    48 49 
     import GHC.Data.SizedSeq
    ... ... @@ -222,6 +223,7 @@ assembleBCO platform
    222 223 
         , unlinkedStaticConDataConName = dataConName dc
    223 224 
         , unlinkedStaticConLits = nonptrs
    224 225 
         , unlinkedStaticConPtrs = ptrs
    226 
    +    , unlinkedStaticConIsUnlifted = isUnliftedType (dataConRepType dc)
    225 227 
         }
    226 228 
       where
    227 229 
         litBCOArg (Left l) = Just $ case literal platform l of

  • compiler/GHC/ByteCode/Linker.hs
    ... ... @@ -15,6 +15,7 @@ module GHC.ByteCode.Linker
    15 15 
       , lookupStaticPtr
    16 16 
       , lookupIE
    17 17 
       , linkFail
    18 
    +  , BCOIx(..)
    18 19 
       )
    19 20 
     where
    20 21
    ... ... @@ -56,9 +57,9 @@ linkBCO
    56 57 
       :: Interp
    57 58 
       -> PkgsLoaded
    58 59 
       -> BytecodeLoaderState
    59 
    -  -> NameEnv (Int, Bool)
    60 
    -  -- ^ A mapping from names to int references to other BCOs or Static Constructors in this group.
    61 
    -  -- The boolean identifies whether the referenced object is a BCO (when @True@) or a Static Constructor (when @False@)
    60 
    +  -> NameEnv BCOIx
    61 
    +  -- ^ A mapping from names to references to other BCOs
    62 
    +  --   or static constructors in this group.
    62 63 
       -> UnlinkedBCO
    63 64 
       -> IO ResolvedBCO
    64 65 
     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
    80 81 
           { unlinkedStaticConLits = lits0
    81 82 
           , unlinkedStaticConPtrs = ptrs0
    82 83 
           , unlinkedStaticConDataConName
    84 
    +      , unlinkedStaticConIsUnlifted
    83 85 
           } -> do
    84 86 
             Ptr itbl_ptr# <- lookupIE interp pkgs_loaded bytecode_state unlinkedStaticConDataConName
    85 87 
             lits <- doLits lits0
    ... ... @@ -90,6 +92,7 @@ linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do
    90 92 
               , resolvedStaticConArity = sizeFlatBag lits0 + sizeFlatBag ptrs0
    91 93 
               , resolvedStaticConLits = lits
    92 94 
               , resolvedStaticConPtrs = ptrs
    95 
    +          , resolvedStaticConIsUnlifted = unlinkedStaticConIsUnlifted
    93 96 
               }
    94 97 
       where
    95 98 
         doLits lits0 = do
    ... ... @@ -99,6 +102,17 @@ linkBCO interp pkgs_loaded bytecode_state bco_ix unl_bco = do
    99 102 
         doPtrs ptrs0 = addListToSS emptySS <$> do
    100 103 
           mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0)
    101 104
    105 
    +-- | An index into a BCO or Static Constructor in this group.
    106 
    +--
    107 
    +-- We distinguish between lifted and unlifted static constructors because
    108 
    +-- lifted ones get resolved by tying a knot, since there may be circular
    109 
    +-- dependencies between them, whereas unlifted ones get constructed in a first
    110 
    +-- pass.
    111 
    +data BCOIx = BCOIx !Int
    112 
    +           | LiftedStaticConIx !Int
    113 
    +           | UnliftedStaticConIx !Int
    114 
    +  deriving (Eq, Ord, Show)
    115 
    +
    102 116 
     lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word
    103 117 
     lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of
    104 118 
       BCONPtrWord lit -> return lit
    ... ... @@ -181,16 +195,16 @@ resolvePtr
    181 195 
       :: Interp
    182 196 
       -> PkgsLoaded
    183 197 
       -> BytecodeLoaderState
    184 
    -  -> NameEnv (Int, Bool)
    198 
    +  -> NameEnv BCOIx
    185 199 
       -> BCOPtr
    186 200 
       -> IO ResolvedBCOPtr
    187 201 
     resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = case ptr of
    188 202 
       BCOPtrName nm
    189 
    -    | Just (ix, b) <- lookupNameEnv bco_ix nm
    190 
    -    -> if b then
    191 
    -        return (ResolvedBCORef ix) -- ref to another BCO in this group
    192 
    -       else
    193 
    -        return (ResolvedStaticConRef ix) -- ref to another StaticCon in this group
    203 
    +    | Just bix <- lookupNameEnv bco_ix nm
    204 
    +    -> return $ case bix of
    205 
    +        BCOIx ix               -> ResolvedBCORef ix
    206 
    +        LiftedStaticConIx ix   -> ResolvedStaticConRef ix
    207 
    +        UnliftedStaticConIx ix -> ResolvedUnliftedStaticConRef ix
    194 208
    195 209 
         | Just (_, rhv) <- lookupNameBytecodeState bco_loader_state nm
    196 210 
         -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))

  • compiler/GHC/ByteCode/Serialize.hs
    ... ... @@ -330,6 +330,7 @@ instance Binary UnlinkedBCO where
    330 330 
             <*> getViaBinName bh
    331 331 
             <*> get bh
    332 332 
             <*> get bh
    333 
    +        <*> get bh
    333 334 
           _ -> panic "Binary UnlinkedBCO: invalid byte"
    334 335
    335 336 
       put_ bh UnlinkedBCO {..} = do
    ... ... @@ -346,6 +347,7 @@ instance Binary UnlinkedBCO where
    346 347 
         putViaBinName bh unlinkedStaticConDataConName
    347 348 
         put_ bh unlinkedStaticConLits
    348 349 
         put_ bh unlinkedStaticConPtrs
    350 
    +    put_ bh unlinkedStaticConIsUnlifted
    349 351
    350 352 
     instance Binary BCOPtr where
    351 353 
       get bh = do

  • compiler/GHC/ByteCode/Types.hs
    ... ... @@ -265,7 +265,8 @@ data UnlinkedBCO
    265 265 
             -- ('unlinkedStaticConDataConName')
    266 266 
             unlinkedStaticConDataConName :: !Name,
    267 267 
             unlinkedStaticConLits :: !(FlatBag BCONPtr), -- non-ptrs
    268 
    -        unlinkedStaticConPtrs :: !(FlatBag BCOPtr)   -- ptrs
    268 
    +        unlinkedStaticConPtrs :: !(FlatBag BCOPtr),  -- ptrs
    269 
    +        unlinkedStaticConIsUnlifted :: !Bool
    269 270 
        }
    270 271
    271 272 
     instance NFData UnlinkedBCO where
    ... ... @@ -328,8 +329,9 @@ instance Outputable UnlinkedBCO where
    328 329 
           = sep [text "BCO", ppr nm, text "with",
    329 330 
                  ppr (sizeFlatBag lits), text "lits",
    330 331 
                  ppr (sizeFlatBag ptrs), text "ptrs" ]
    331 
    -   ppr (UnlinkedStaticCon nm dc_nm lits ptrs)
    332 
    +   ppr (UnlinkedStaticCon nm dc_nm lits ptrs unl)
    332 333 
           = sep [text "StaticCon", ppr nm, text "for",
    334 
    +             if unl then text "unlifted" else text "lifted",
    333 335 
                  ppr dc_nm, text "with",
    334 336 
                  ppr (sizeFlatBag lits), text "lits",
    335 337 
                  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 []
    1044 1044 
       do_link [] = return []
    1045 1045 
       do_link mods = do
    1046 1046 
         let flat = [ bco | bcos <- mods, bco <- bcos ]
    1047 
    -        names = map (\case UnlinkedBCO{unlinkedBCOName} -> (unlinkedBCOName, True)
    1048 
    -                           UnlinkedStaticCon{unlinkedStaticConName} -> (unlinkedStaticConName, False)
    1049 
    -                    ) flat
    1050 
    -        bco_ix = mkNameEnv (zipWith (\(n,isBCO) ix -> (n,(ix, isBCO))) names [0..])
    1047 
    +        unl_objs = filter isUnliftedObj flat
    1048 
    +        lif_objs = filter (not . isUnliftedObj) flat
    1049 
    +        unl_objs_ix = mkNameEnv (zipWith mkBCOIx [0..] unl_objs)
    1050 
    +        lif_objs_ix = mkNameEnv (zipWith mkBCOIx [0..] lif_objs)
    1051 
    +        bco_ix = plusNameEnv unl_objs_ix lif_objs_ix
    1051 1052 
         resolved <- sequence [ linkBCO interp pkgs_loaded bytecode_state bco_ix bco | bco <- flat ]
    1052 
    -    hvrefs <- {- pprTrace "CreatingBCOS" (ppr (zip [bco | bco <- flat] [(0::Int)..])) $ -} createBCOs interp resolved
    1053 
    -    return (zipWith (\(n,_) hvr -> (n, hvr)) names hvrefs)
    1053 
    +    hvrefs   <- createBCOs interp resolved
    1054 
    +    return (zip (map mkBCOName $ unl_objs ++ lif_objs) hvrefs)
    1055 
    +
    1056 
    +  mkBCOName UnlinkedBCO{unlinkedBCOName}
    1057 
    +    = unlinkedBCOName
    1058 
    +  mkBCOName UnlinkedStaticCon{unlinkedStaticConName}
    1059 
    +    = unlinkedStaticConName
    1060 
    +
    1061 
    +  mkBCOIx ix
    1062 
    +    UnlinkedBCO{unlinkedBCOName}
    1063 
    +    = (unlinkedBCOName, BCOIx ix)
    1064 
    +  mkBCOIx ix
    1065 
    +    UnlinkedStaticCon
    1066 
    +      { unlinkedStaticConName
    1067 
    +      , unlinkedStaticConIsUnlifted }
    1068 
    +    | unlinkedStaticConIsUnlifted
    1069 
    +    = (unlinkedStaticConName, UnliftedStaticConIx ix)
    1070 
    +    | otherwise
    1071 
    +    = (unlinkedStaticConName, LiftedStaticConIx ix)
    1072 
    +
    1073 
    +  isUnliftedObj = \case
    1074 
    +      UnlinkedStaticCon{..} -> unlinkedStaticConIsUnlifted
    1075 
    +      _                     -> False
    1054 1076
    1055 1077 
     -- | Useful to apply to the result of 'linkSomeBCOs'
    1056 1078 
     makeForeignNamedHValueRefs

  • libraries/ghci/GHCi/CreateBCO.hs
    1 1 
     {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
    2 2 
     {-# LANGUAGE MultiParamTypeClasses #-}
    3 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    4 
    +{-# LANGUAGE UnliftedNewtypes #-}
    5 
    +{-# LANGUAGE TypeApplications #-}
    3 6 
     {-# LANGUAGE FlexibleInstances #-}
    4 7 
     {-# LANGUAGE BangPatterns #-}
    5 8 
     {-# LANGUAGE MagicHash #-}
    ... ... @@ -21,12 +24,13 @@ import GHCi.ResolvedBCO
    21 24 
     import GHCi.RemoteTypes
    22 25 
     import GHCi.BreakArray
    23 26 
     import GHC.Data.SizedSeq
    27 
    +import Data.List (partition)
    24 28
    25 29 
     import System.IO (fixIO)
    26 30 
     import Control.Monad
    27 31 
     import Data.Array.Base
    28 32 
     import Foreign hiding (newArray)
    29 
    -import Unsafe.Coerce (unsafeCoerce)
    33 
    +import Unsafe.Coerce (unsafeCoerce, unsafeCoerceUnlifted)
    30 34 
     import GHC.Arr          ( Array(..) )
    31 35 
     import GHC.Exts   hiding ( BCO, mkApUpd0#, newBCO# )
    32 36 
     import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO# )
    ... ... @@ -34,24 +38,43 @@ import GHC.IO
    34 38 
     import Control.Exception ( ErrorCall(..) )
    35 39
    36 40 
     createBCOs :: [ResolvedBCO] -> IO [HValueRef]
    37 
    -createBCOs bcos = do
    41 
    +createBCOs objs = do
    42 
    +
    43 
    +  let (unl_objs, bcos) = partition isUnliftedObj objs
    44 
    +
    45 
    +  -- First, construct the array of unlifted static cons.
    46 
    +  -- Top-level unlifted constructors are never mutual recursive, so we can do
    47 
    +  -- this by filling the array on demand
    48 
    +  -- (it's also not possible to define a mutually recursive unlifted
    49 
    +  -- top-level value, see [GHC-20185]),
    50 
    +  (unl_cons, unl_hvals) <- createUnliftedStaticCons unl_objs
    51 
    +
    52 
    +  -- Second, construct the lifted BCOs and static cons which may have
    53 
    +  -- (circular) references to one another in this group. References from this
    54 
    +  -- group to the unlifted static cons will be resolved by looking them up in
    55 
    +  -- the array constructed in the first pass.
    38 56 
       let n_bcos = length bcos
    39 57 
       hvals <- fixIO $ \hvs -> do
    40 58 
          let arr = listArray (0, n_bcos-1) hvs
    41 
    -      -- (BCO Index :-> HValue)
    42 
    -     mapM (createBCO arr) bcos
    59 
    +     mapM (createBCO arr unl_cons) bcos
    43 60
    44 
    -  mapM mkRemoteRef hvals
    61 
    +  mapM mkRemoteRef (unl_hvals ++ hvals)
    62 
    +
    63 
    +  where
    64 
    +    isUnliftedObj :: ResolvedBCO -> Bool
    65 
    +    isUnliftedObj = \case
    66 
    +      ResolvedStaticCon{..} -> resolvedStaticConIsUnlifted
    67 
    +      _                     -> False
    45 68
    46 
    -createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue
    47 
    -createBCO _   obj | resolvedBCOIsLE obj /= isLittleEndian
    69 
    +createBCO :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO HValue
    70 
    +createBCO _ _ obj | resolvedBCOIsLE obj /= isLittleEndian
    48 71 
       = throwIO (ErrorCall $
    49 72 
             unlines [ "The endianness of the ResolvedBCO does not match"
    50 73 
                     , "the systems endianness. Using ghc and iserv in a"
    51 74 
                     , "mixed endianness setup is not supported!"
    52 75 
                     ])
    53 
    -createBCO arr bco
    54 
    -   = do linked_thing <- linkBCO' arr bco
    76 
    +createBCO arr unl_arr bco
    77 
    +   = do linked_thing <- linkBCO' arr unl_arr bco
    55 78 
             case linked_thing of
    56 79 
               LinkedBCO bco_arity linked_bco -> do
    57 80 
                 -- Note [Updatable CAF BCOs]
    ... ... @@ -75,13 +98,45 @@ createBCO arr bco
    75 98 
                           return (HValue final_bco) }
    76 99 
               LinkedStaticCon linked_static_con -> do
    77 100 
                 return linked_static_con
    101 
    +          LinkedUnliftedStaticCon linked_static_con -> do
    102 
    +            return $! forgetUnliftedHValue linked_static_con
    78 103
    104 
    +-- | The resulting of linking a BCO or static constructor
    79 105 
     data LinkedBCO
    80 106 
       = LinkedBCO !Int{-BCO arity-} BCO
    81 107 
       | LinkedStaticCon HValue
    108 
    +  | LinkedUnliftedStaticCon UnliftedHValue
    82 109
    83 
    -linkBCO' :: Array Int HValue -> ResolvedBCO -> IO LinkedBCO
    84 
    -linkBCO' arr resolved_obj =
    110 
    +-- | From a list of 'UnliftedStaticCon's, create an array of unlifted heap closures
    111 
    +-- Invariant: All ResolvedBCOs are UnliftedStaticCons
    112 
    +createUnliftedStaticCons :: [ResolvedBCO] -> IO (UnlConsArr, [HValue {- references to actually unlifted values, but we "forget" that -}])
    113 
    +createUnliftedStaticCons objs = do
    114 
    +  -- Ensure objs are topologically sorted by their dependencies
    115 
    +  -- Then, just fill them in in order!
    116 
    +  let !(I# arr_size#) = length objs
    117 
    +      !(EmptyArr emp_arr#) = emptyArr
    118 
    +  ucarr@(UnlConsArr unl_arr#) <- IO $ \s ->
    119 
    +    case newArray# arr_size# (UnliftedHValue (unsafeCoerceUnlifted emp_arr#)) s of
    120 
    +      (# s, arr #) -> (# s, UnlConsArr arr #)
    121 
    +  vs <- forM (zip objs [0..]) $ \(obj, !(I# i#)) -> case obj of
    122 
    +    ResolvedStaticCon{..}
    123 
    +      | resolvedStaticConIsUnlifted
    124 
    +      -> do
    125 
    +        -- Because we topologically sort the objs, it's safe to assume all
    126 
    +        -- references will already be filled in.
    127 
    +        lbc <- linkBCO' (error "there should be no lifted dependencies for unlifted objs") ucarr obj
    128 
    +        case lbc of
    129 
    +          LinkedUnliftedStaticCon linked_static_con -> do
    130 
    +            IO $ \s ->
    131 
    +              case writeArray# unl_arr# i# linked_static_con s of
    132 
    +                s -> (# s, forgetUnliftedHValue linked_static_con #)
    133 
    +          _ -> error "createUnliftedStaticCons: unexpected lifted ResolvedBCO"
    134 
    +    _ ->
    135 
    +      error "createUnliftedStaticCons: unexpected lifted ResolvedBCO"
    136 
    +  return (ucarr, vs)
    137 
    +
    138 
    +linkBCO' :: Array Int HValue -> UnlConsArr -> ResolvedBCO -> IO LinkedBCO
    139 
    +linkBCO' arr unl_arr resolved_obj =
    85 140 
       case resolved_obj of
    86 141 
         ResolvedBCO{..} -> do
    87 142 
           let
    ... ... @@ -94,7 +149,7 @@ linkBCO' arr resolved_obj =
    94 149 
               bitmap_barr = barr (getBCOByteArray resolvedBCOBitmap)
    95 150 
               literals_barr = barr (getBCOByteArray resolvedBCOLits)
    96 151
    97 
    -      PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
    152 
    +      PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs
    98 153 
           IO $ \s ->
    99 154 
             case unsafeFreezeArray# marr s of { (# s, arr #) ->
    100 155 
             case LinkedBCO resolvedBCOArity <$>
    ... ... @@ -113,47 +168,69 @@ linkBCO' arr resolved_obj =
    113 168 
             !(W# itbl_ptr_w#) = resolvedStaticConInfoPtr
    114 169 
             !(Ptr itbl_ptr#)  = Ptr (int2Addr# (word2Int# itbl_ptr_w#))
    115 170
    116 
    -      PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs
    171 
    +      PtrsArr marr <- mkPtrsArray arr unl_arr n_ptrs ptrs
    117 172
    118 173 
           IO $ \s ->
    119 174 
             case unsafeFreezeArray# marr s of { (# s, arr #) ->
    120 175 
             case newConAppObj# itbl_ptr# literals_barr arr data_size# s of
    121 
    -          (# s, hval #) -> (# s, LinkedStaticCon (HValue hval) #)
    176 
    +          (# s, hval #) ->
    177 
    +            (# s, if resolvedStaticConIsUnlifted then
    178 
    +                   LinkedUnliftedStaticCon (UnliftedHValue (unsafeCoerce# hval))
    179 
    +                  else
    180 
    +                   LinkedStaticCon (HValue hval) #)
    122 181 
             }
    123 182 
       where
    124 183 
         !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]
    125 184 
         barr arr# = if I# (sizeofByteArray# arr#) == 0 then empty# else arr#
    126 185
    127 186 
     -- we recursively link any sub-BCOs while making the ptrs array
    128 
    -mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
    129 
    -mkPtrsArray arr n_ptrs ptrs = do
    187 
    +mkPtrsArray :: Array Int HValue -> UnlConsArr -> Word -> [ResolvedBCOPtr] -> IO PtrsArr
    188 
    +mkPtrsArray arr (UnlConsArr unl_arr) n_ptrs ptrs = do
    130 189 
       marr <- newPtrsArray (fromIntegral n_ptrs)
    131 190 
       let
    132 191 
         fill (ResolvedBCORef n) i =
    133 
    -      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!
    192 
    +      writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!
    134 193 
         fill (ResolvedStaticConRef n) i = do
    135 
    -      -- this MUST be /strict/!
    136 
    -      -- the static con reference must be an evaluated pointer to the data con
    137 
    -      -- info table, but (arr ! n) would construct a thunk instead if unforced.
    138 
    -      writePtrsArrayHValue i (arr ! n) marr
    194 
    +      writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!
    195 
    +    fill (ResolvedUnliftedStaticConRef !(I# n#)) i = do
    196 
    +      -- must be strict! we want to store the unlifted con,
    197 
    +      -- not the arr indexing thunk.
    198 
    +      !unl_val <- IO $ \s ->
    199 
    +        case readArray# unl_arr n# s of
    200 
    +            (# s, val #) -> (# s, forgetUnliftedHValue val #)
    201 
    +      writePtrsArrayHValue i unl_val marr
    139 202 
         fill (ResolvedBCOPtr r) i = do
    140 203 
           hv <- localRef r
    141 204 
           writePtrsArrayHValue i hv marr
    142 205 
         fill (ResolvedBCOStaticPtr r) i = do
    143 206 
           writePtrsArrayPtr i (fromRemotePtr r)  marr
    144 207 
         fill (ResolvedBCOPtrBCO bco) i = do
    145 
    -      obj <- linkBCO' arr bco
    208 
    +      obj <- linkBCO' arr (UnlConsArr unl_arr) bco
    146 209 
           case obj of
    147 210 
             LinkedBCO _ bco ->
    148 211 
               writePtrsArrayBCO i bco marr
    149 
    -        LinkedStaticCon !linked_static_con ->
    212 
    +        LinkedStaticCon linked_static_con ->
    150 213 
               writePtrsArrayHValue i linked_static_con marr
    214 
    +        LinkedUnliftedStaticCon linked_static_con -> do
    215 
    +          let !unl_val = forgetUnliftedHValue linked_static_con
    216 
    +          writePtrsArrayHValue i unl_val marr
    151 217 
         fill (ResolvedBCOPtrBreakArray r) i = do
    152 218 
           BA mba <- localRef r
    153 219 
           writePtrsArrayMBA i mba marr
    154 220 
       zipWithM_ fill ptrs [0..]
    155 221 
       return marr
    156 222
    223 
    +-- | A heap closure of unlifted type
    224 
    +type UnliftedHValue :: UnliftedType
    225 
    +newtype UnliftedHValue = UnliftedHValue (Any @UnliftedType)
    226 
    +
    227 
    +-- | Forget that a heap closure is unlifted, and return it as a lifted heap closure.
    228 
    +forgetUnliftedHValue :: UnliftedHValue -> HValue
    229 
    +forgetUnliftedHValue (UnliftedHValue a) = HValue (unsafeCoerce# a)
    230 
    +
    231 
    +-- | A lifted array with unlifted static constructor 'UnliftedHValue's
    232 
    +data UnlConsArr = UnlConsArr (MutableArray# RealWorld UnliftedHValue)
    233 
    +
    157 234 
     data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)
    158 235
    159 236 
     newPtrsArray :: Int -> IO PtrsArr

  • libraries/ghci/GHCi/ResolvedBCO.hs
    ... ... @@ -54,7 +54,8 @@ data ResolvedBCO
    54 54 
             resolvedStaticConInfoPtr :: {-# UNPACK #-} !Word, -- ^ info ptr Addr# as a Word
    55 55 
             resolvedStaticConArity   :: {-# UNPACK #-} !Word,
    56 56 
             resolvedStaticConLits    :: BCOByteArray Word,
    57 
    -        resolvedStaticConPtrs    :: SizedSeq ResolvedBCOPtr
    57 
    +        resolvedStaticConPtrs    :: SizedSeq ResolvedBCOPtr,
    58 
    +        resolvedStaticConIsUnlifted :: Bool
    58 59 
        }
    59 60 
        deriving (Generic, Show)
    60 61
    ... ... @@ -103,11 +104,12 @@ instance Binary ResolvedBCO where
    103 104 
         put resolvedStaticConArity
    104 105 
         put resolvedStaticConLits
    105 106 
         put resolvedStaticConPtrs
    107 
    +    put resolvedStaticConIsUnlifted
    106 108 
       get = do
    107 109 
         t <- getWord8
    108 110 
         case t of
    109 111 
           0 -> ResolvedBCO <$> get <*> get <*> get <*> get <*> get <*> get
    110 
    -      1 -> ResolvedStaticCon <$> get <*> get <*> get <*> get <*> get
    112 
    +      1 -> ResolvedStaticCon <$> get <*> get <*> get <*> get <*> get <*> get
    111 113 
           _ -> error "Binary ResolvedBCO: invalid byte"
    112 114
    113 115 
     -- See Note [BCOByteArray serialization]
    ... ... @@ -118,7 +120,8 @@ instance (Binary a, Storable a, IArray UArray a) => Binary (BCOByteArray a) wher
    118 120
    119 121 
     data ResolvedBCOPtr
    120 122 
       = ResolvedBCORef {-# UNPACK #-} !Int
    121 
    -      -- ^ reference to the Nth BCO in the current set
    123 
    +      -- ^ reference to the Nth BCO in the current set of BCOs and
    124 
    +      -- lifted static constructors
    122 125 
       | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)
    123 126 
           -- ^ reference to a previously created BCO
    124 127 
       | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())
    ... ... @@ -128,7 +131,11 @@ data ResolvedBCOPtr
    128 131 
       | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)
    129 132 
           -- ^ Resolves to the MutableArray# inside the BreakArray
    130 133 
       | ResolvedStaticConRef {-# UNPACK #-} !Int
    131 
    -      -- ^ reference to the Nth static constructor in the current set
    134 
    +      -- ^ reference to the Nth static constructor in the current set of BCOs
    135 
    +      -- and lifted static constructors
    136 
    +  | ResolvedUnliftedStaticConRef {-# UNPACK #-} !Int
    137 
    +      -- ^ reference to the Nth unlifted static constructor in the current set
    138 
    +      -- of exclusively unlifted static constructors
    132 139 
       deriving (Generic, Show)
    133 140
    134 141 
     instance Binary ResolvedBCOPtr

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help