Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • compiler/GHC/ByteCode/Linker.hs
    ... ... @@ -42,6 +42,7 @@ import qualified GHC.Types.Id as Id
    42 42 
     import GHC.Types.Unique.DFM
    43 43
    44 44 
     -- Standard libraries
    45 
    +import Control.Concurrent
    45 46 
     import Data.Array.Unboxed
    46 47 
     import Foreign.Ptr
    47 48 
     import GHC.Exts
    ... ... @@ -87,9 +88,12 @@ lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of
    87 88 
       BCONPtrStr bs -> do
    88 89 
         RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs]
    89 90 
         pure $ fromIntegral p
    90 
    -  BCONPtrFS fs -> do
    91 
    -    RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bytesFS fs]
    92 
    -    pure $ fromIntegral p
    91 
    +  BCONPtrFS fs -> modifyMVar (interpStringCache interp) $ \fs_env ->
    92 
    +    case lookupFsEnv fs_env fs of
    93 
    +      Just (RemotePtr p) -> pure (fs_env, fromIntegral p)
    94 
    +      Nothing -> do
    95 
    +        rp@(RemotePtr p) <- fmap head $ interpCmd interp $ MallocStrings [bytesFS fs]
    96 
    +        pure (extendFsEnv fs_env fs rp, fromIntegral p)
    93 97 
       BCONPtrFFIInfo (FFIInfo {..}) -> do
    94 98 
         RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet
    95 99 
         pure $ fromIntegral p

  • compiler/GHC/Driver/Main.hs
    ... ... @@ -2845,7 +2845,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
    2845 2845
    2846 2846 
       case interp of
    2847 2847 
         -- always generate JS code for the JS interpreter (no bytecode!)
    2848 
    -    Interp (ExternalInterp (ExtJS i)) _ _ ->
    2848 
    +    Interp { interpInstance = ExternalInterp (ExtJS i) } ->
    2849 2849 
           jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id
    2850 2850
    2851 2851 
         _ -> do

  • compiler/GHC/Runtime/Interpreter/Init.hs
    ... ... @@ -9,6 +9,7 @@ where
    9 9
    10 10
    11 11 
     import GHC.Prelude
    12 
    +import GHC.Data.FastString.Env
    12 13 
     import GHC.Driver.DynFlags
    13 14 
     import GHC.Platform
    14 15 
     import GHC.Platform.Ways
    ... ... @@ -71,6 +72,8 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do
    71 72
    72 73 
       lookup_cache  <- liftIO $ mkInterpSymbolCache
    73 74
    75 
    +  fs_cache <- liftIO $ newMVar emptyFsEnv
    76 
    +
    74 77 
       -- see Note [Target code interpreter]
    75 78 
       if
    76 79 
     #if !defined(wasm32_HOST_ARCH)
    ... ... @@ -100,7 +103,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do
    100 103 
                     , wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (interpNameVer opts)
    101 104 
                     , wasmInterpUnitState = ue_homeUnitState unit_env
    102 105 
                     }
    103 
    -        pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache
    106 
    +        pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache fs_cache
    104 107 
     #endif
    105 108
    106 109 
         -- JavaScript interpreter
    ... ... @@ -119,7 +122,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do
    119 122 
                   , jsInterpFinderOpts  = interpFinderOpts opts
    120 123 
                   , jsInterpFinderCache = finder_cache
    121 124 
                   }
    122 
    -         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache))
    125 
    +         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache fs_cache))
    123 126
    124 127 
         -- external interpreter
    125 128 
         | interpExternal opts
    ... ... @@ -146,7 +149,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do
    146 149 
                }
    147 150 
             s <- liftIO $ newMVar InterpPending
    148 151 
             loader <- liftIO Loader.uninitializedLoader
    149 
    -        return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache))
    152 
    +        return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache))
    150 153
    151 154 
         -- Internal interpreter
    152 155 
         | otherwise
    ... ... @@ -154,7 +157,7 @@ initInterpreter dflags tmpfs logger platform finder_cache unit_env opts = do
    154 157 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    155 158 
          do
    156 159 
           loader <- liftIO Loader.uninitializedLoader
    157 
    -      return (Just (Interp InternalInterp loader lookup_cache))
    160 
    +      return (Just (Interp InternalInterp loader lookup_cache fs_cache))
    158 161 
     #else
    159 162 
           return Nothing
    160 163 
     #endif

  • compiler/GHC/Runtime/Interpreter/Types.hs
    ... ... @@ -47,6 +47,7 @@ import GHC.Linker.Types
    47 47 
     import GHCi.RemoteTypes
    48 48 
     import GHCi.Message         ( Pipe )
    49 49
    50 
    +import GHC.Data.FastString.Env
    50 51 
     import GHC.Platform
    51 52 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    52 53 
     import GHC.Platform.Ways
    ... ... @@ -75,6 +76,9 @@ data Interp = Interp
    75 76
    76 77 
       , interpSymbolCache :: !InterpSymbolCache
    77 78 
           -- ^ LookupSymbol cache
    79 
    +
    80 
    +  , interpStringCache :: !(MVar (FastStringEnv (RemotePtr ())))
    81 
    +      -- ^ MallocStrings cache
    78 82 
       }
    79 83
    80 84 
     data InterpInstance

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