[Git][ghc/ghc][wip/js-th] Remove useless/unused commands
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Thu Jan 19 09:22:34 UTC 2023
Sylvain Henry pushed to branch wip/js-th at Glasgow Haskell Compiler / GHC
Commits:
e3fed6f5 by Sylvain Henry at 2023-01-19T10:26:44+01:00
Remove useless/unused commands
- - - - -
4 changed files:
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/JS.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- thrunner.js
Changes:
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -473,10 +473,7 @@ lookupSymbol interp str = case interpInstance interp of
modifyMVar_ (instLookupSymbolCache (instDetails inst)) (const (pure cache'))
return (Just p)
- ExtJS i -> withJSInterp i $ \inst -> do
- ms <- jsLookupSymbol inst str
- -- FIXME: this is stupid. Why do we cast a RemotePtr into a Ptr??
- pure (fmap fromRemotePtr ms)
+ ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
lookupClosure :: Interp -> String -> IO (Maybe AnyHeapRef)
lookupClosure interp str =
=====================================
compiler/GHC/Runtime/Interpreter/JS.hs
=====================================
@@ -12,7 +12,6 @@ module GHC.Runtime.Interpreter.JS
, jsLinkRts
, jsLinkInterp
, jsLinkObject
- , jsLookupSymbol
, jsLoadFile
, jsLoadCode
, jsRunServer
@@ -34,7 +33,6 @@ import GHC.JS.Syntax
import GHC.StgToJS.Linker.Types
import GHC.StgToJS.Linker.Linker
import GHC.StgToJS.Types
-import GHC.StgToJS.Symbols
import GHC.StgToJS.Printer (pretty)
import GHC.StgToJS.Object
@@ -47,9 +45,8 @@ import GHC.Utils.TmpFs
import GHC.Utils.Exception
import GHC.Utils.Panic
import GHC.Utils.Error (logInfo)
-import GHC.Utils.Outputable (text,ftext)
+import GHC.Utils.Outputable (text)
import qualified GHC.Utils.Ppr as Ppr
-import GHC.Data.FastMutInt
import GHC.Data.FastString
import Control.Concurrent
@@ -120,7 +117,6 @@ spawnJSInterp cfg = do
let codegen_cfg = jsInterpCodegenCfg cfg
let unit_env = jsInterpUnitEnv cfg
(std_in, proc) <- startTHRunnerProcess (jsInterpTopDir cfg) (jsInterpNodeConfig cfg)
- unique_supply <- newFastMutInt 0
js_state <- newMVar (JSState
{ jsLinkState = emptyLinkPlan
, jsServerStarted = False
@@ -128,7 +124,6 @@ spawnJSInterp cfg = do
let details = JSInterpInstance
{ instStdIn = std_in
- , instUniqueSupply = unique_supply
, instConfig = cfg
, instJSState = js_state
}
@@ -324,8 +319,8 @@ jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do
-- Haskell server.
server_started <- jsServerStarted <$> readMVar (instJSState (instDetails inst))
if server_started
- then jsPassthroughNoResponseCommand inst $ LoadJS all_js
- else jsSendCommand inst $ LoadFile all_js
+ then sendMessageNoResponse inst $ LoadJS all_js
+ else jsSendCommand inst $ LoadFile all_js
----------------------------------------------------------------
-- update linker state
@@ -337,13 +332,8 @@ jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do
-- | Commands understood by the JS interpreter
data Command r where
ExitSuccess :: Command ()
- Ping :: Command ()
- LoadCode :: !JStat -> Command ()
- LoadFile :: !FilePath -> Command ()
- AllocString :: !B.ByteString -> Command (RemotePtr a)
+ LoadFile :: !FilePath -> Command ()
RunServer :: Command () -- ^ Run GHCi.Server.defaultServer
- Passthrough :: Binary a => Message a -> Command a
- PassthroughNoResponse :: Message () -> Command ()
-- | Send a command to the JS interpreter
jsSendCommand :: ExtInterpInstance JSInterpInstance -> Command r -> IO r
@@ -364,78 +354,24 @@ jsSendCommand inst cmd = do
put_cmd = word8
- fresh_interp_ident = do
- i <- atomicFetchAddFastMut (instUniqueSupply details) 1
- pure (i, mkFreshInterpSymbol i)
-
flush = hFlush handle
- config = instConfig details
- logger = jsInterpLogger config
- tmpfs = jsInterpTmpFs config
- tmp_dir = jsInterpTmpDir config
-
- new_temp_name = newTempName logger tmpfs tmp_dir
-
case cmd of
- Ping -> do
- put_cmd 1
- flush
-
LoadFile fp -> do
withCStringLen fp \(p,n) -> do
- put_cmd 2
+ put_cmd 1
int32 (fromIntegral n)
ptr p n
flush
RunServer -> do
- put_cmd 3
+ put_cmd 2
flush
- -- Passthrough a command to the interpreter
- Passthrough m ->
- sendMessage inst m
-
- PassthroughNoResponse m ->
- sendMessageNoResponse inst m
-
ExitSuccess -> do
put_cmd 99
flush
- LoadCode doc -> do
- -- dump code into file
- out <- new_temp_name TFL_CurrentModule "js"
- withBinaryFile out WriteMode \h ->
- Ppr.printLeftRender h (pretty doc)
-
- -- load file
- jsLoadFile inst out
-
- AllocString str -> do
- (str_id, str_js_id) <- fresh_interp_ident
- (_off_id, off_js_id) <- fresh_interp_ident
- let cc = Nothing
- let str_info = StaticInfo str_js_id (StaticUnboxed (StaticUnboxedString str)) cc
- let off_info = StaticInfo off_js_id (StaticUnboxed (StaticUnboxedStringOffset str)) cc
- let code = mconcat
- [ staticDeclStat str_info
- , staticDeclStat off_info
- , staticInitStat str_info
- , staticInitStat off_info
- ]
-
- -- load code
- jsLoadCode inst code
-
- -- FIXME: return valid RemotePtr
- --
- -- add variables to a global RemotePtr table?
- -- [ ValExpr (JVar str_js_id), ValExpr (JVar off_js_id) ]
- pure (RemotePtr (fromIntegral str_id))
-
-
jsInterpCmd :: Binary a => ExtInterpInstance JSInterpInstance -> Message a -> IO a
jsInterpCmd inst msg = do
let
@@ -496,31 +432,31 @@ jsInterpCmd inst msg = do
-------------------------------------
-- interpreter
- MallocData d -> jsSendCommand inst (AllocString d)
-
- MallocStrings [] -> pure []
- MallocStrings ss -> forM ss \s -> jsSendCommand inst (AllocString s)
-
-- commands that are passed through to the interpreter
- RunTH {} -> jsPassthroughCommand inst msg
- LoadJS {} -> jsPassthroughCommand inst msg
+ RunTH {} -> sendMessage inst msg
+ LoadJS {} -> sendMessage inst msg
_ -> error ("jsInterpCmd: " ++ show msg)
--- | Lookup symbol
-jsLookupSymbol :: ExtInterpInstance JSInterpInstance -> FastString -> IO (Maybe (RemotePtr ()))
-jsLookupSymbol _i s = do
- pprTraceM "jsLookupSymbol" (ftext s)
- -- FIXME
- pure (Just (RemotePtr 0))
-
-- | Load a JS file in the interpreter
jsLoadFile :: ExtInterpInstance JSInterpInstance -> FilePath -> IO ()
jsLoadFile inst path = jsSendCommand inst (LoadFile path)
-- | Load some JS code in the interpreter
jsLoadCode :: ExtInterpInstance JSInterpInstance -> JStat -> IO ()
-jsLoadCode inst code = jsSendCommand inst (LoadCode code)
+jsLoadCode inst doc = do
+ let config = instConfig (instDetails inst)
+ let logger = jsInterpLogger config
+ let tmpfs = jsInterpTmpFs config
+ let tmp_dir = jsInterpTmpDir config
+
+ -- dump code into file
+ out <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "js"
+ withBinaryFile out WriteMode \h ->
+ Ppr.printLeftRender h (pretty doc)
+
+ -- load file
+ jsLoadFile inst out
-- | Run JS server
jsRunServer :: ExtInterpInstance JSInterpInstance -> IO ()
@@ -532,12 +468,4 @@ jsRunServer inst = do
-- | Lookup a closure
jsLookupClosure :: ExtInterpInstance JSInterpInstance -> String -> IO (Maybe AnyHeapRef)
-jsLookupClosure inst str = jsPassthroughCommand inst (LookupClosure str)
-
--- | Passthrough command to the interpreter
-jsPassthroughCommand :: Binary a => ExtInterpInstance JSInterpInstance -> Message a -> IO a
-jsPassthroughCommand inst msg = jsSendCommand inst (Passthrough msg)
-
--- | Passthrough command to the interpreter
-jsPassthroughNoResponseCommand :: ExtInterpInstance JSInterpInstance -> Message () -> IO ()
-jsPassthroughNoResponseCommand inst msg = jsSendCommand inst (PassthroughNoResponse msg)
+jsLookupClosure inst str = sendMessage inst (LookupClosure str)
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -30,7 +30,6 @@ import GHCi.RemoteTypes
import GHCi.Message ( Pipe )
import GHC.Types.Unique.FM
import GHC.Data.FastString ( FastString )
-import GHC.Data.FastMutInt
import Foreign
import GHC.Utils.TmpFs
@@ -118,7 +117,6 @@ data IServInstance = IServInstance
data JSInterpInstance = JSInterpInstance
{ instStdIn :: !Handle -- ^ Stdin for the process
- , instUniqueSupply :: {-# UNPACK #-} !FastMutInt -- ^ Unique supply for the interpreter
, instConfig :: !JSInterpConfig -- ^ Config used by the interpreter
, instJSState :: !(MVar JSState) -- ^ Mutable state
}
=====================================
thrunner.js
=====================================
@@ -112,13 +112,8 @@ function h$interp_loop() {
process.exit(0);
break;
- // Ping
- case 1:
- console.log("Pong");
- break;
-
// load JS file
- case 2:
+ case 1:
const payload_size = getInt32();
const payload = getBuffer(payload_size);
const p = payload.toString('utf8');
@@ -126,7 +121,7 @@ function h$interp_loop() {
break;
// RunServer
- case 3:
+ case 2:
h$runServer();
return; // break the main loop!
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3fed6f5b9045cfdc2495d4e4b416771cf7e3221
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3fed6f5b9045cfdc2495d4e4b416771cf7e3221
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230119/9591133c/attachment-0001.html>
More information about the ghc-commits
mailing list