Cheng Shao pushed to branch wip/ghci-messages-no-string at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • compiler/GHC/Driver/Plugins.hs
    ... ... @@ -405,7 +405,7 @@ loadExternalPlugins ps = do
    405 405 
             symbol
    406 406 
               | null unit = ztmp
    407 407 
               | otherwise = zEncodeString unit ++ "_" ++ ztmp
    408 
    -    plugin <- lookupSymbol symbol >>= \case
    408 
    +    plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case
    409 409 
           Nothing -> pprPanic "loadExternalPlugins"
    410 410 
                       (vcat [ text "Symbol not found"
    411 411 
                             , text "  Library path: " <> text path

  • compiler/GHC/Runtime/Interpreter.hs
    ... ... @@ -465,27 +465,27 @@ lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
    465 465 
     lookupSymbol interp str = withSymbolCache interp str $
    466 466 
       case interpInstance interp of
    467 467 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    468 
    -    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
    468 
    +    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
    469 469 
     #endif
    470 470 
         ExternalInterp ext -> case ext of
    471 471 
           ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
    472 472 
             uninterruptibleMask_ $
    473 
    -          sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
    473 
    +          sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
    474 474 
           ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
    475 475 
           ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
    476 476 
             uninterruptibleMask_ $
    477 
    -          sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
    477 
    +          sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
    478 478
    479 479 
     lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
    480 480 
     lookupSymbolInDLL interp dll str = withSymbolCache interp str $
    481 481 
       case interpInstance interp of
    482 482 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    483 
    -    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
    483 
    +    InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
    484 484 
     #endif
    485 485 
         ExternalInterp ext -> case ext of
    486 486 
           ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
    487 487 
             uninterruptibleMask_ $
    488 
    -          sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
    488 
    +          sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
    489 489 
           ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
    490 490 
           -- wasm dyld doesn't track which symbol comes from which .so
    491 491 
           ExtWasm {} -> lookupSymbol interp str
    ... ... @@ -519,7 +519,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is -
    519 519
    520 520 
     lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
    521 521 
     lookupClosure interp str =
    522 
    -  interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
    522 
    +  interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str)))
    523 523
    524 524 
     -- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
    525 525 
     -- which maps symbols to the address where they are loaded.

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -86,9 +86,9 @@ data Message a where
    86 86
    87 87 
       -- These all invoke the corresponding functions in the RTS Linker API.
    88 88 
       InitLinker :: Message ()
    89 
    -  LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
    90 
    -  LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
    91 
    -  LookupClosure :: String -> Message (Maybe HValueRef)
    89 
    +  LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
    90 
    +  LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ()))
    91 
    +  LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef)
    92 92 
       LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL])
    93 93 
       LoadArchive :: String -> Message () -- error?
    94 94 
       LoadObj :: String -> Message () -- error?

  • libraries/ghci/GHCi/ObjLink.hs
    ... ... @@ -31,6 +31,8 @@ import GHCi.RemoteTypes
    31 31 
     import GHCi.Message (LoadedDLL)
    32 32 
     import Control.Exception (throwIO, ErrorCall(..))
    33 33 
     import Control.Monad    ( when )
    34 
    +import qualified Data.ByteString.Short as BS
    35 
    +import Data.Char (ord)
    34 36 
     import Data.Foldable
    35 37 
     import Foreign.C
    36 38 
     import Foreign.Marshal.Alloc ( alloca, free )
    ... ... @@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f
    104 106 
     purgeObj :: String -> IO ()
    105 107 
     purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f
    106 108
    107 
    -lookupSymbol :: String -> IO (Maybe (Ptr a))
    108 
    -lookupSymbol sym = do
    109 
    -  r <- js_lookupSymbol $ toJSString sym
    109 
    +lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
    110 
    +lookupSymbol sym@(BS.SBS ba#) = do
    111 
    +  r <- js_lookupSymbolPtr ba# (BS.length sym)
    110 112 
       evaluate $ if r == nullPtr then Nothing else Just r
    111 113
    112 
    -foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)"
    113 
    -  js_lookupSymbol :: JSString -> IO (Ptr a)
    114 
    +foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)"
    115 
    +  js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a)
    114 116
    115 
    -lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
    117 
    +lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
    116 118 
     lookupSymbolInDLL _ _ = pure Nothing
    117 119
    118 120 
     resolveObjs :: IO Bool
    ... ... @@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO ()
    149 151 
     initObjLinker RetainCAFs = c_initLinker_ 1
    150 152 
     initObjLinker _ = c_initLinker_ 0
    151 153
    152 
    -lookupSymbol :: String -> IO (Maybe (Ptr a))
    154 
    +lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a))
    153 155 
     lookupSymbol str_in = do
    154 156 
        let str = prefixUnderscore str_in
    155 
    -   withCAString str $ \c_str -> do
    157 
    +   BS.useAsCString str $ \c_str -> do
    156 158 
          addr <- c_lookupSymbol c_str
    157 159 
          if addr == nullPtr
    158 160 
             then return Nothing
    159 161 
             else return (Just addr)
    160 162
    161 
    -lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a))
    163 
    +lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a))
    162 164 
     lookupSymbolInDLL dll str_in = do
    163 165 
        let str = prefixUnderscore str_in
    164 
    -   withCAString str $ \c_str -> do
    166 
    +   BS.useAsCString str $ \c_str -> do
    165 167 
          addr <- c_lookupSymbolInNativeObj dll c_str
    166 168 
          if addr == nullPtr
    167 169 
            then return Nothing
    168 170 
            else return (Just addr)
    169 171
    170 
    -prefixUnderscore :: String -> String
    172 
    +prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString
    171 173 
     prefixUnderscore
    172 
    - | cLeadingUnderscore = ('_':)
    174 
    + | cLeadingUnderscore = BS.cons (fromIntegral (ord '_'))
    173 175 
      | otherwise          = id
    174 176
    175 177 
     -- | loadDLL loads a dynamic library using the OS's native linker
    ... ... @@ -298,7 +300,7 @@ isWindowsHost = False
    298 300
    299 301 
     #endif
    300 302
    301 
    -lookupClosure :: String -> IO (Maybe HValueRef)
    303 
    +lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
    302 304 
     lookupClosure str = do
    303 305 
       m <- lookupSymbol str
    304 306 
       case m of

  • libraries/ghci/GHCi/Run.hs
    ... ... @@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o
    135 135
    136 136 
     foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #)
    137 137
    138 
    -lookupJSClosure' :: String -> IO Int
    139 
    -lookupJSClosure' str = withCString str $ \cstr -> IO (\s ->
    138 
    +lookupJSClosure' :: BS.ShortByteString -> IO Int
    139 
    +lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s ->
    140 140 
       case lookupJSClosure# cstr s of
    141 141 
         (# s', r #) -> (# s', I# r #))
    142 142
    143 
    -lookupJSClosure :: String -> IO (Maybe HValueRef)
    143 
    +lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef)
    144 144 
     lookupJSClosure str = lookupJSClosure' str >>= \case
    145 145 
       0 -> pure Nothing
    146 146 
       r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r))))

  • testsuite/tests/driver/linkwhole/Main.hs
    1 
    +{-# LANGUAGE OverloadedStrings #-}
    1 2 
     {-# LANGUAGE RecordWildCards #-}
    2 3
    3 4 
     module Main (main) where
    4 5
    5 6 
     import Control.Exception
    6 7 
     import Control.Monad
    8 
    +import Data.ByteString.Short (ShortByteString)
    7 9
    8 10 
     import Foreign
    9 11
    ... ... @@ -15,7 +17,7 @@ import GHCi.ObjLink
    15 17
    16 18 
     rotateSO
    17 19 
       :: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a)))
    18 
    -  -> String
    20 
    +  -> ShortByteString
    19 21 
       -> (Maybe FilePath, FilePath)
    20 22 
       -> IO a
    21 23 
     rotateSO dynamicCall symName (old, newDLL) = do

  • testsuite/tests/ghci/should_run/T18064.script
    1 
    +:set -XOverloadedStrings
    1 2 
     import GHCi.ObjLink
    2 3 
     lookupClosure "blah"

  • testsuite/tests/rts/KeepCafsMain.hs
    1 
    +{-# LANGUAGE OverloadedStrings #-}
    2 
    +
    1 3 
     module Main (main) where
    2 4
    3 5 
     import Foreign

  • utils/jsffi/dyld.mjs
    ... ... @@ -1334,6 +1334,13 @@ class DyLD {
    1334 1334 
         }
    1335 1335 
         return 0;
    1336 1336 
       }
    1337 
    +
    1338 
    +  lookupSymbolPtr(symPtr, symLen) {
    1339 
    +    const sym = new TextDecoder("utf-8", { fatal: true }).decode(
    1340 
    +      new Uint8Array(this.#memory.buffer, symPtr, symLen)
    1341 
    +    );
    1342 
    +    return this.lookupSymbol(sym);
    1343 
    +  }
    1337 1344 
     }
    1338 1345
    1339 1346 
     // The main entry point of dyld that may be run on node/browser, and

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