[Git][ghc/ghc][wip/js-th] 3 commits: Testsuite: enable TH for the JS target
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Mon Jan 23 11:47:54 UTC 2023
Sylvain Henry pushed to branch wip/js-th at Glasgow Haskell Compiler / GHC
Commits:
3963655f by Sylvain Henry at 2023-01-23T10:56:06+01:00
Testsuite: enable TH for the JS target
- - - - -
b5ec9b90 by Sylvain Henry at 2023-01-23T11:24:54+01:00
Disable verbose messages
- - - - -
85c77da0 by Sylvain Henry at 2023-01-23T12:46:53+01:00
Simplify JS protocole a great deal (use strings)
- - - - -
4 changed files:
- compiler/GHC/Runtime/Interpreter/JS.hs
- libraries/base/jsbits/base.js
- testsuite/driver/testlib.py
- thrunner.js
Changes:
=====================================
compiler/GHC/Runtime/Interpreter/JS.hs
=====================================
@@ -47,15 +47,11 @@ import System.Process
import System.IO
import System.FilePath
-import Data.Binary
-import Data.Int
import Data.IORef
import qualified Data.Set as Set
import qualified Data.ByteString as B
import Foreign.C.String
-import Foreign.Ptr
-import Foreign.Marshal.Utils
---------------------------------------------------------
-- Running node
@@ -98,8 +94,9 @@ startTHRunnerProcess topdir settings = do
-- Run NodeJS with thrunner.js and its deps (including the rts) loaded.
spawnJSInterp :: JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra)
spawnJSInterp cfg = do
-
- logInfo (jsInterpLogger cfg) (text "Spawning JS interpreter")
+ let logger= jsInterpLogger cfg
+ when (logVerbAtLeast logger 2) $
+ logInfo logger (text "Spawning JS interpreter")
let tmpfs = jsInterpTmpFs cfg
let tmp_dir = jsInterpTmpDir cfg
@@ -294,7 +291,7 @@ jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do
server_started <- jsServerStarted <$> readMVar (instJSState (instExtra inst))
if server_started
then sendMessageNoResponse inst $ LoadJS all_js
- else jsSendCommand inst $ LoadFile all_js
+ else jsLoadFile inst all_js
----------------------------------------------------------------
-- update linker state
@@ -302,58 +299,25 @@ jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do
modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsLinkState = total_plan }
-
--- | Commands understood by the JS interpreter
-data Command r where
- ExitSuccess :: Command ()
- LoadFile :: !FilePath -> Command ()
- RunServer :: Command () -- ^ Run GHCi.Server.defaultServer
-
-- | Send a command to the JS interpreter
-jsSendCommand :: ExtInterpInstance JSInterpExtra -> Command r -> IO r
-jsSendCommand inst cmd = do
- let
- extra = instExtra inst
- handle = instStdIn extra
-
- ptr :: forall a. Ptr a -> Int -> IO ()
- ptr p n = hPutBuf handle p n
-
- -- FIXME: we should ensure little-endianness (expected by JS)
- int32 :: Int32 -> IO ()
- int32 x = with x \p -> ptr p 4
-
- word8 :: Word8 -> IO ()
- word8 x = with x \p -> ptr p 1
-
- put_cmd = word8
-
- flush = hFlush handle
-
- case cmd of
- LoadFile fp -> do
- withCStringLen fp \(p,n) -> do
- put_cmd 1
- int32 (fromIntegral n)
- ptr p n
- flush
-
- RunServer -> do
- put_cmd 2
- flush
-
- ExitSuccess -> do
- put_cmd 99
- flush
+jsSendCommand :: ExtInterpInstance JSInterpExtra -> String -> IO ()
+jsSendCommand inst cmd = send_cmd cmd
+ where
+ extra = instExtra inst
+ handle = instStdIn extra
+ send_cmd s = do
+ withCStringLen s \(p,n) -> hPutBuf handle p n
+ hFlush handle
-- | Load a JS file in the interpreter
jsLoadFile :: ExtInterpInstance JSInterpExtra -> FilePath -> IO ()
-jsLoadFile inst path = jsSendCommand inst (LoadFile path)
+jsLoadFile inst path = jsSendCommand inst ("LOAD " ++ path ++ "\n")
-- | Run JS server
jsRunServer :: ExtInterpInstance JSInterpExtra -> IO ()
jsRunServer inst = do
- jsSendCommand inst RunServer
+ -- Run `GHCi.Server.defaultServer`
+ jsSendCommand inst ("RUN_SERVER\n")
-- indicate that the Haskell server is now started
modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsServerStarted = True }
=====================================
libraries/base/jsbits/base.js
=====================================
@@ -677,12 +677,8 @@ if(h$isNode()) {
c(0);
}
- // if we are in a Template Haskell context (global.h$TH is set) then we
- // should keep away from stdin, because it's used for communication with GHC
- if(typeof global.h$TH !== 'object') {
- process.stdin.on('readable', h$base_process_stdin);
- process.stdin.on('end', function() { h$base_stdin_eof = true; h$base_process_stdin(); });
- }
+ process.stdin.on('readable', h$base_process_stdin);
+ process.stdin.on('end', function() { h$base_stdin_eof = true; h$base_process_stdin(); });
h$base_isattyStdin = function() { return process.stdin.isTTY; };
h$base_isattyStdout = function() { return process.stdout.isTTY; };
=====================================
testsuite/driver/testlib.py
=====================================
@@ -262,8 +262,6 @@ def req_dynamic_hs( name, opts ):
def req_interp( name, opts ):
if not config.have_interp:
opts.expect = 'fail'
- # JS backend doesn't provide an interpreter yet
- js_skip(name, opts)
def req_rts_linker( name, opts ):
if not config.have_RTS_linker:
@@ -292,7 +290,13 @@ def req_th( name, opts ):
when GHC is dynamically-linked since we can't load profiled objects in this
case.
"""
- req_interp(name, opts)
+
+ # The JS target always supports TH, even in the stage1 compiler
+ # However it doesn't support the "Interpreter" yet (GHCi).
+ # So specifically enables TH here for JS.
+ if arch("js"):
+ return normal;
+
if ghc_dynamic():
return _omit_ways(name, opts, ['profasm', 'profthreaded'])
=====================================
thrunner.js
=====================================
@@ -1,63 +1,41 @@
/*
- Template Haskell communication
+ GHC JS Interpreter
- reads messages from stdin, sends over stderr
- (Haskell stderr stream is redirected to stdout)
+ Read commands on stdin:
+ LOAD foo.js\n : load foo.js file
+ RUN_SERVER\n : run GHCi.Server.defaultServer
- messages are prefixed with the following data:
- - UInt32BE: message length
- - UInt32BE: message target:
- 0: control message from compiler to TH server
- n: response to request n
+ Once the Haskell server is started with RUN_SERVER, the JS server no longer
+ reads commands on stdin. Everything must go throught the Haskell server (which
+ uses pipes for communication)
*/
var h$THfs = require('fs');
var h$THvm = require('vm');
-if(typeof __dirname == 'undefined') {
- // TODO work out the best shim to use here
- var __dirname = '/GHCJS_thrunner_dirname/';
-}
-
-// set this to true to record each message and the received JS code to a file
-// you can then replay the TH session later with 'node thrunner.js replay'
-var h$THRecord = // true ||
- !!process.env['GHCJS_RECORD_TH'];
-
-var h$THReplay = process.argv.length > 0 && process.argv[process.argv.length-1] === 'replay';
-
-var h$TH = { nWaiters: 0
- , waiters: {}
- , data: []
- , dataLen: 0
- , requestId: 1
- , loadedSymbol: null
- , sendRequest: h$sendRequest
- , awaitMessage: h$awaitMessage
- , sendMessage: h$sendMessage
- , loadCode: h$loadCode
- , loadCodeStr: h$loadCodeStr
- , bufSize: h$bufSize
- , getMemoryUsage: h$getMemoryUsage
- };
-
-global.h$TH = h$TH;
global.require = require;
-global.module = module;
-global.__dirname = __dirname;
+global.module = module;
+
+function h$debug_log(s) {
+ // switch this to 'true' to enable some debug messages
+ if (false) {
+ console.log("[JS interpreter] " + s);
+ }
+}
// load and exec JS file
function h$loadJS(path) {
- console.log("Loading file: " + path);
+ h$debug_log("Loading file: " + path);
var data = h$THfs.readFileSync(path);
const script = new h$THvm.Script(data);
script.runInThisContext();
}
+// Lookup a static closure by its name
function h$lookupClosure(v) {
- console.log("Looking up closure: " + v);
+ h$debug_log("Looking up closure: " + v);
const r = eval(v);
- console.log(" -> Result: " + r);
+ h$debug_log(" -> Result: " + r);
if (!r) return 0;
// a HeapRef is just the offset of a stable pointer
return h$makeStablePtr(r);
@@ -67,289 +45,57 @@ function h$lookupClosure(v) {
globalThis.h$loadJS = h$loadJS;
globalThis.h$lookupClosure = h$lookupClosure;
-async function h$initTH() {
- console.log("Welcome to GHC's JS interpreter");
- process.stderr.setEncoding('binary');
+function h$initInterp() {
+ h$debug_log("Welcome to GHC's JS interpreter");
- process.stdin.on('end', () => {
- console.log('GHC disconnected: goodbye.');
+ function stdin_end() {
+ h$debug_log('GHC disconnected: goodbye.');
process.exit(1);
- });
-
- h$interp_loop();
-}
-
-async function h$interp_loop() {
- async function getInt32() {
- let b = await readStdin(4);
- return new Int32Array(b)[0];
- }
-
- async function getByte() {
- let b = await readStdin(1);
- return b[0];
- }
-
- console.log("Entering interpreter loop...");
-
- while(true) {
- const cmd_id = await getByte();
-
- // interpret command
- switch (cmd_id) {
- // exit
- case 99:
- console.log("Goodbye");
- process.exit(0);
- break;
-
- // load JS file
- case 1:
- const payload_size = await getInt32();
- const payload = await readStdin(payload_size);
- const p = payload.toString('utf8');
- h$loadJS(p);
- break;
-
- // RunServer
- case 2:
- h$runServer();
- return; // break the main loop!
-
- // unknown command
- default:
- throw ("Unknown command number: " + cmd_id);
- }
- }
-}
-
-/////////////////////////////////////////////////////////////////////
-// stdin buffering helpers
-//
-// usage: await readStdin(n);
-// this returns a buffer with n bytes from stdin
-//
-// perhaps we can use some existing infrastructure instead of
-// managing our own buffers
-/////////////////////////////////////////////////////////////////////
-let stdinBufs = [], stdinWaiters = [];
-process.stdin.on('data', (d) => {
- stdinBufs.push(d);
- let waiters = stdinWaiters;
- stdinWaiters = [];
- for(const r of waiters) r();
-});
-
-
-// helper function, reads n bytes from stdin if available in the buffer,
-// returns null otherwise
-//
-// warning: this is very inefficient for larger buffers
-function getStdinData(n) {
- if(stdinBufs.length == 0) return null;
- let b = stdinBufs.length == 1 ? stdinBufs[0] : Buffer.concat(stdinBufs);
- if(b.length >= n) {
- let r = b.slice(0, n);
- stdinBufs = [b.slice(n)];
- return r;
- } else {
- if(stdinBufs.length !== 1) stdinBufs = [b];
- return null;
- }
-}
-
-async function readStdin(n) {
- while(true) {
- let d = getStdinData(n);
- if(d) {
- return d;
- } else {
- await new Promise((resolve) => { stdinWaiters.push(resolve); });
- }
- }
-}
-/////////////////////////////////////////////////////////////////////
-
-function h$runServer() {
- console.log("Run server");
- h$main(h$ghciZCGHCiziServerzidefaultServer);
-}
-
-/*
-
-// start listening
-function h$initTH() {
- process.stdin.setEncoding('utf8');
- process.stderr.setEncoding('binary');
- process.on('uncaughtException', function(err) { console.log(err); });
- console.log("Welcome to GHC's JS interpreter");
- process.stdin.on('readable', function() {
- let r = process.stdin.read(4);
- console.log("Received:"+ r);
- switch (r) {
- case "LOAD":
- console.log("LOAD received");
+ };
+
+ // read until we find '\n'
+ // Accumulate bytes in "bytes" array
+ let bytes = [];
+ let decoder = new TextDecoder('utf8');
+
+ function stdin_readable() {
+ let b;
+ // read until we find '\n'
+ while (null !== (bs = process.stdin.read(1))) {
+ let b = bs[0];
+ switch(b) {
+ case 10: // `\n` found. `bytes` must contain a command
+ let cmd = decoder.decode(new Uint8Array(bytes));
+ bytes = [];
+ // we only supports 2 commands: LOAD, RUN_SERVER
+ if (cmd.startsWith("LOAD ")) {
+ h$loadJS(cmd.slice(5));
+ }
+ else if (cmd === "RUN_SERVER") {
+ // remove listeners
+ process.stdin.removeListener('end', stdin_end);
+ process.stdin.removeListener('readable', stdin_readable);
+ // run the server
+ h$debug_log("Run server");
+ h$main(h$ghciZCGHCiziServerzidefaultServer);
+ // break the loop
+ return;
+ }
+ else {
+ console.log("[JS interpreter] Invalid command received: " + cmd);
+ process.exit(1);
+ }
break;
default:
- break;
+ bytes.push(b);
}
- });
-
- h$awaitMessageRaw(0, h$loadInitialCode);
- var leftover = null;
- process.stdin.on('readable', function() {
- while(true) {
- var str = process.stdin.read();
- if(str) {
- // save incomplete hex pair if needed
- str = str.toString();
- if(leftover) str = leftover + str;
- str = str.replace(/\s/gm, '');
- if(str.length % 2) {
- leftover = str.slice(str.length-1);
- str = str.slice(0,str.length-1);
- } else {
- leftover = null;
- }
- var buf = Buffer.from(str, 'hex');
-
- // make sure the first 8 bytes into data[0]
- // otherwise delay copying the buffers until a complete message
- // has been received
- if(h$TH.data.length < 1 || h$TH.data[0].length >= 8) {
- h$TH.data.push(buf);
- } else {
- h$TH.data[0] = Buffer.concat([h$TH.data[0], buf]);
- }
- h$TH.dataLen += buf.length;
- h$processQueue();
- } else {
- return;
- }
- }
- });
- process.stdin.on('close', function() { process.exit(0); });
-}
-*/
-
-function h$getMemoryUsage() {
- var m = process.memoryUsage();
- // return m.rss;
- return (m.heapTotal + m.external)|0;
-}
-
-var h$THMessageN = 0;
-function h$processQueue() {
- while(h$TH.nWaiters > 0 && h$TH.data && h$TH.dataLen >= 8) {
- // if we have at least 8 bytes, they are all in data[0]
- var msgLength = h$TH.data[0].readUInt32BE(0);
- var msgTarget = h$TH.data[0].readUInt32BE(4);
- var msgBytes = msgLength + 8;
- if(h$TH.dataLen >= msgBytes && h$TH.waiters[msgTarget]) {
- var bb = Buffer.concat(h$TH.data);
- var w = h$TH.waiters[msgTarget]
- var msgPayload = bb.slice(8, msgBytes);
-
- h$TH.data = [bb.slice(msgBytes)];
- h$TH.dataLen -= msgBytes;
- delete h$TH.waiters[msgTarget];
- h$TH.nWaiters--;
- if(h$THRecord && !h$THReplay)
- h$THfs.writeFileSync("thmessage." + (++h$THMessageN) + ".dat", msgPayload);
- w(msgPayload);
- } else {
- return;
- }
}
-}
-
-function h$sendRequest(bs, offset, len, c) {
- var req = h$TH.requestId++;
- h$sendMessage(bs, offset, len, req, function() {});
- h$awaitMessage(req, c);
-}
+ };
-function h$sendMessage(bs, offset, len, req, c) {
- var msg = len === -1 ? Buffer.from(bs.u8.subarray(offset))
- : Buffer.from(bs.u8.subarray(offset, len));
- var hdr = Buffer.alloc(8);
- hdr.writeUInt32BE(msg.length, 0);
- hdr.writeUInt32BE(req, 4);
- process.stderr.write(Buffer.concat([hdr, msg]), 'binary', function() { c(); });
+ // read commands on STDIN
+ process.stdin.on('end', stdin_end);
+ process.stdin.on('readable', stdin_readable);
}
-function h$awaitMessage(req, c) {
- h$awaitMessageRaw(req, function(buf) {
- c(h$THWrapBuffer(h$BufferToArrayBuffer(buf),false),0);
- });
-}
-
-var h$THReplayMessageN = 0;
-function h$awaitMessageRaw(req, c) {
- if(h$TH.waiters[req]) throw ("h$awaitMessage: already waiting for " + req);
- if(h$THReplay) {
- try {
- c(h$THfs.readFileSync('thmessage.' + (++h$THReplayMessageN) + '.dat'));
- return;
- } catch(e) { }
- }
- h$TH.nWaiters++;
- h$TH.waiters[req] = c;
- h$processQueue();
-}
-
-function h$bufSize(buf, buf_offset) {
- if(buf === null) return 0;
- return buf.len;
-}
-
-var h$THCodeN = 0;
-function h$loadCodeStr(str, isFirst) {
- if(h$THReplay) {
- try {
- str = h$THfs.readFileSync("thcode." + (++h$THCodeN) + ".js").toString('utf8');
- } catch(e) { }
- } else if(h$THRecord) {
- h$THfs.writeFileSync("thcode." + (++h$THCodeN) + ".js", str);
- }
- eval.call(null, str);
-}
-
-// load additional code and run the initializers for it, the code should
-// assign the h$TH.loadedSymbol variable
-function h$loadCode(buf, off, len) {
- h$TH.loadedSymbol = null;
- var str = Buffer.from(buf.u8).toString('utf8',off, off+len);
- h$TH.loadCodeStr(str, false);
- // h$runInitStatic();
- if(h$TH.loadedSymbol === null) throw "h$loadCode: error loading code"
- return h$TH.loadedSymbol;
-}
-
-function h$BufferToArrayBuffer(buf) {
- if(buf.toArrayBuffer) return buf.toArrayBuffer();
- return new Uint8Array(buf).buffer;
-}
-
-// copied from src/mem.js
-function h$THWrapBuffer(buf, unalignedOk, offset, length) {
- if(!unalignedOk && offset && offset % 8 !== 0) {
- throw ("h$THWrapBuffer: offset not aligned:" + offset);
- }
- if(!buf || !(buf instanceof ArrayBuffer))
- throw "h$THWrapBuffer: not an ArrayBuffer"
- if(!offset) { offset = 0; }
- if(!length || length < 0) { length = buf.byteLength - offset; }
- // console.log("wrapping buf: " + length + " " + offset);
- return { buf: buf
- , len: length
- , i3: (offset%4) ? null : new Int32Array(buf, offset, length >> 2)
- , u8: new Uint8Array(buf, offset, length)
- , u1: (offset%2) ? null : new Uint16Array(buf, offset, length >> 1)
- , f3: (offset%4) ? null : new Float32Array(buf, offset, length >> 2)
- , f6: (offset%8) ? null : new Float64Array(buf, offset, length >> 3)
- , dv: new DataView(buf, offset, length)
- };
-}
-h$initTH();
+h$initInterp();
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75b6a584057d9f162339bd2f40f6535ec8613a0f...85c77da0c08c847f1842bd5a3ed241ff0353a2cf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75b6a584057d9f162339bd2f40f6535ec8613a0f...85c77da0c08c847f1842bd5a3ed241ff0353a2cf
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/20230123/58e4dac7/attachment-0001.html>
More information about the ghc-commits
mailing list