Dogfood the wrapperless rts api

asterius/rts/rts.exports.mjs

@@ -16,7 +16,7 @@ function decodeTys(arr, tag) {
 function decodeRtsMk(e, ty) {
   switch (ty) {
     case "JSVal": {
-      return v => e.rts_mkJSVal(e.context.components.jsvalManager.newJSValzh(v));
+      return v => e.rts_mkJSVal(BigInt(e.context.components.jsvalManager.newJSValzh(v)));
     }
     default: {
       const f = `rts_mk${ty}`;
@@ -28,7 +28,7 @@ function decodeRtsMk(e, ty) {
 function decodeRtsGet(e, ty) {
   switch (ty) {
     case "JSVal": {
-      return p => e.context.components.jsvalManager.getJSValzh(e.rts_getJSVal(p));
+      return p => e.context.components.jsvalManager.getJSValzh(Number(e.rts_getJSVal(p)));
     }
     default: {
       const f = `rts_get${ty}`;
@@ -91,12 +91,12 @@ export class Exports {
             `Expected ${arg_mk_funcs.length} arguments, got ${args.length}`
           );
         }
-        let p = this.context.stablePtrManager.deRefStablePtr(sp);
+        let p = BigInt(this.context.stablePtrManager.deRefStablePtr(sp));
         for (let i = 0; i < arg_mk_funcs.length; ++i) {
           p = this.rts_apply(p, arg_mk_funcs[i](args[i]));
         }
-        p = this.rts_apply(run_func, p);
-        const tid = await eval_func(p);
+        p = this.rts_apply(BigInt(run_func), p);
+        const tid = await eval_func(Number(p));
         if (ret_get_funcs.length) {
           return ret_get_funcs[0](this.context.scheduler.getTSOret(tid));
         }

asterius/rts/rts.scheduler.mjs

@@ -272,7 +272,7 @@ export class Scheduler {
               "base_AsteriusziTypesziJSException_mkJSException_closure"
             ),
             this.exports.rts_mkJSVal(
-              this.components.jsvalManager.newJSValzh(tso_info.ffiRetErr)
+              BigInt(this.components.jsvalManager.newJSValzh(tso_info.ffiRetErr))
             )
           );
         this.memory.i64Store(stackobj + rtsConstants.offset_StgStack_sp, sp);

asterius/src/Asterius/Builtins.hs

@@ -27,6 +27,7 @@ import Asterius.Builtins.Env
 import Asterius.Builtins.Exports
 import Asterius.Builtins.Posix
 import Asterius.Builtins.Primitive
+import Asterius.Builtins.RtsAPI
 import Asterius.Builtins.Scheduler
 import Asterius.Builtins.SM
 import Asterius.Builtins.SPT
@@ -194,13 +195,13 @@ rtsAsteriusModule opts =
     <> primitiveCBits
     <> endiannessCBits
     <> barfCBits
+    <> rtsAPICBits
 
 -- Generate the module consisting of functions which need to be wrapped
 -- for communication with the external runtime.
 generateRtsExternalInterfaceModule :: BuiltinsOptions -> AsteriusModule
 generateRtsExternalInterfaceModule opts =
   mempty
-    <> rtsApplyFunction opts
     <> createIOThreadFunction opts
     <> createStrictIOThreadFunction opts
     <> scheduleTSOFunction opts
@@ -210,22 +211,6 @@ generateRtsExternalInterfaceModule opts =
     <> deRefStablePtrWrapperFunction opts
     <> freeStablePtrWrapperFunction opts
     <> makeStableNameWrapperFunction opts
-    <> rtsMkBoolFunction opts
-    <> rtsMkDoubleFunction opts
-    <> rtsMkCharFunction opts
-    <> rtsMkIntFunction opts
-    <> rtsMkWordFunction opts
-    <> rtsMkPtrFunction opts
-    <> rtsMkStablePtrFunction opts
-    <> rtsMkJSValFunction opts
-    <> rtsGetBoolFunction opts
-    <> rtsGetDoubleFunction opts
-    <> generateRtsGetIntFunction opts "rts_getChar"
-    <> generateRtsGetIntFunction opts "rts_getInt"
-    <> generateRtsGetIntFunction opts "rts_getWord"
-    <> generateRtsGetIntFunction opts "rts_getPtr"
-    <> generateRtsGetIntFunction opts "rts_getStablePtr"
-    <> generateRtsGetIntFunction opts "rts_getJSVal"
     <> loadI64Function opts
 
 -- Generate the module consisting of debug functions
@@ -554,23 +539,6 @@ rtsFunctionExports pic debug =
   [ FunctionExport {internalName = f <> "_wrapper", externalName = f}
     | f <-
         [ "loadI64",
-          "rts_mkBool",
-          "rts_mkDouble",
-          "rts_mkChar",
-          "rts_mkInt",
-          "rts_mkWord",
-          "rts_mkPtr",
-          "rts_mkStablePtr",
-          "rts_mkJSVal",
-          "rts_getBool",
-          "rts_getDouble",
-          "rts_getChar",
-          "rts_getInt",
-          "rts_getWord",
-          "rts_getPtr",
-          "rts_getStablePtr",
-          "rts_getJSVal",
-          "rts_apply",
           "createStrictIOThread",
           "createIOThread",
           "scheduleTSO",
@@ -604,7 +572,7 @@ rtsFunctionExports pic debug =
       { internalName = "stg_returnToSchedNotPaused",
         externalName = "stg_returnToSchedNotPaused"
       }
-  ]
+  ] <> rtsAPIExports
 
 rtsGlobalImports :: [GlobalImport]
 rtsGlobalImports =
@@ -780,20 +748,6 @@ hsInitFunction _ = runEDSL "hs_init" $ do
     truncUFloat64ToInt64 <$> callImport' "__asterius_hpAlloc" [constF64 8] F64
   putLVal currentNursery bd_nursery
 
-rtsApplyFunction :: BuiltinsOptions -> AsteriusModule
-rtsApplyFunction _ = runEDSL "rts_apply" $ do
-  setReturnTypes [I64]
-  [f, arg] <- params [I64, I64]
-  ap <-
-    call'
-      "allocate"
-      [mainCapability, constI64 $ roundup_bytes_to_words sizeof_StgThunk + 2]
-      I64
-  storeI64 ap 0 $ symbol "stg_ap_2_upd_info"
-  storeI64 ap offset_StgThunk_payload f
-  storeI64 ap (offset_StgThunk_payload + 8) arg
-  emit ap
-
 rtsGetSchedStatusFunction :: BuiltinsOptions -> AsteriusModule
 rtsGetSchedStatusFunction _ = runEDSL "rts_getSchedStatus" $ do
   setReturnTypes [I32]
@@ -1043,136 +997,6 @@ makeStableNameWrapperFunction _ = runEDSL "makeStableName" $ do
       F64
   emit $ truncUFloat64ToInt64 obj_f64
 
-rtsMkHelper ::
-  BuiltinsOptions ->
-  -- Name of the function to be built
-  EntitySymbol ->
-  -- Mangled name of the primop constructor
-  EntitySymbol ->
-  AsteriusModule
-rtsMkHelper _ n con_sym = runEDSL n $ do
-  setReturnTypes [I64]
-  [i] <- params [I64]
-  p <- call' "allocate" [mainCapability, constI64 2] I64
-  storeI64 p 0 $ symbol con_sym
-  storeI64 p 8 i
-  emit p
-
-rtsMkBoolFunction :: BuiltinsOptions -> AsteriusModule
-rtsMkBoolFunction _ = runEDSL "rts_mkBool" $ do
-  setReturnTypes [I64]
-  [i] <- params [I64]
-  if'
-    [I64]
-    (eqZInt64 i)
-    (emit $ symbol "ghczmprim_GHCziTypes_False_closure")
-    (emit $ symbol "ghczmprim_GHCziTypes_True_closure")
-
-rtsMkDoubleFunction :: BuiltinsOptions -> AsteriusModule
-rtsMkDoubleFunction _ = runEDSL "rts_mkDouble" $ do
-  setReturnTypes [I64]
-  [i] <- params [F64]
-  p <- call' "allocate" [mainCapability, constI64 2] I64
-  storeI64 p 0 $ symbol "ghczmprim_GHCziTypes_Dzh_con_info"
-  storeF64 p 8 i
-  emit p
-
-rtsMkCharFunction :: BuiltinsOptions -> AsteriusModule
-rtsMkCharFunction _ = runEDSL "rts_mkChar" $ do
-  setReturnTypes [I64]
-  [i] <- params [I64]
-  if'
-    [I64]
-    (i `ltUInt64` constI64 256)
-    -- If the character in question is in the range [0..255] we use the
-    -- trick that GHC uses, and instead of generating a heap-allocated Char
-    -- closure, we simply return the address of the statically allocated
-    -- Char. See stg_CHARLIKE_closure in
-    -- ghc-toolkit/boot-libs/rts/StgMiscClosures.cmm
-    ( let offset = i `mulInt64` constI64 16
-       in emit $ symbol "stg_CHARLIKE_closure" `addInt64` offset
-    )
-    -- Otherwise, we fall back to the more inefficient
-    -- approach and generate a dynamic closure.
-    $ do
-      p <- call' "allocate" [mainCapability, constI64 2] I64
-      storeI64 p 0 $ symbol "ghczmprim_GHCziTypes_Czh_con_info"
-      storeI64 p 8 i
-      emit p
-
-rtsMkIntFunction :: BuiltinsOptions -> AsteriusModule
-rtsMkIntFunction _ = runEDSL "rts_mkInt" $ do
-  setReturnTypes [I64]
-  [i] <- params [I64]
-  if'
-    [I64]
-    ((i `leSInt64` constI64 16) `andInt32` (i `geSInt64` constI64 (-16)))
-    -- If the integer in question is in the range [-16..16] we use the
-    -- trick that GHC uses, and instead of generating a heap-allocated Int
-    -- closure, we simply return the address of the statically allocated
-    -- Int. See stg_INTLIKE_closure in
-    -- ghc-toolkit/boot-libs/rts/StgMiscClosures.cmm
-    ( let offset = (i `addInt64` constI64 16) `mulInt64` constI64 16
-       in emit $ symbol "stg_INTLIKE_closure" `addInt64` offset
-    )
-    -- Otherwise, we fall back to the more inefficient
-    -- approach and generate a dynamic closure.
-    $ do
-      p <- call' "allocate" [mainCapability, constI64 2] I64
-      storeI64 p 0 $ symbol "ghczmprim_GHCziTypes_Izh_con_info"
-      storeI64 p 8 i
-      emit p
-
-rtsMkWordFunction :: BuiltinsOptions -> AsteriusModule
-rtsMkWordFunction opts =
-  rtsMkHelper opts "rts_mkWord" "ghczmprim_GHCziTypes_Wzh_con_info"
-
-rtsMkPtrFunction :: BuiltinsOptions -> AsteriusModule
-rtsMkPtrFunction opts =
-  rtsMkHelper opts "rts_mkPtr" "base_GHCziPtr_Ptr_con_info"
-
-rtsMkStablePtrFunction :: BuiltinsOptions -> AsteriusModule
-rtsMkStablePtrFunction opts =
-  rtsMkHelper opts "rts_mkStablePtr" "base_GHCziStable_StablePtr_con_info"
-
-rtsMkJSValFunction :: BuiltinsOptions -> AsteriusModule
-rtsMkJSValFunction opts =
-  rtsMkHelper opts "rts_mkJSVal" "base_AsteriusziTypesziJSVal_JSVal_con_info"
-
-rtsGetBoolFunction :: BuiltinsOptions -> AsteriusModule
-rtsGetBoolFunction _ = runEDSL "rts_getBool" $ do
-  setReturnTypes [I64]
-  p <- param I64
-  emit $ extendUInt32 $
-    neInt32
-      (constI32 0)
-      (loadI32 (loadI64 (unTagClosure p) 0) offset_StgInfoTable_srt)
-
-rtsGetDoubleFunction :: BuiltinsOptions -> AsteriusModule
-rtsGetDoubleFunction _ = runEDSL "rts_getDouble" $ do
-  setReturnTypes [F64]
-  p <- param I64
-  emit $ loadF64 (unTagClosure p) offset_StgClosure_payload
-
--- rtsGetCharFunction = rtsGetIntFunction
--- generate a function which internally performs getInt, but is
--- named differently
-generateRtsGetIntFunction ::
-  BuiltinsOptions ->
-  EntitySymbol -> -- Name of the function
-  AsteriusModule
-generateRtsGetIntFunction _ n = runEDSL n $ do
-  setReturnTypes [I64]
-  p <- param I64
-  emit $ loadI64 (unTagClosure p) offset_StgClosure_payload
-
-{-
-rtsGetIntFunction _ =
-  runEDSL "rts_getInt" $ do
-    setReturnTypes [I64]
-    p <- param I64
-    emit $ loadI64 (unTagClosure p) offset_StgClosure_payload
--}
 loadI64Function :: BuiltinsOptions -> AsteriusModule
 loadI64Function _ = runEDSL "loadI64" $ do
   setReturnTypes [I64]

asterius/src/Asterius/Builtins/RtsAPI.hs

@@ -3,7 +3,7 @@
 
 module Asterius.Builtins.RtsAPI
   ( rtsAPIExports,
-    rtsAPIModule,
+    rtsAPICBits,
   )
 where
 
@@ -33,8 +33,8 @@ rtsAPIExports =
         ]
   ]
 
-rtsAPIModule :: AsteriusModule
-rtsAPIModule =
+rtsAPICBits :: AsteriusModule
+rtsAPICBits =
   rtsApply
     <> mconcat
       [ rtsMk func_sym con_info_sym

asterius/src/Asterius/GHCi/Internals.hs

@@ -384,19 +384,19 @@ asteriusRunTH _ _ q ty loc s ahc_dist_input = withTempDir "asdf" $ \tmp_dir ->
             <> uint8_arr
             <> ")"
         uint8_arr_closure =
-          toJS i <> ".exports.rts_mkJSVal(" <> uint8_arr_sn <> ")"
+          toJS i <> ".exports.rts_mkJSVal(BigInt(" <> uint8_arr_sn <> "))"
         bs_closure =
           toJS i
-            <> ".exports.rts_apply("
+            <> ".exports.rts_apply(BigInt("
             <> buf_conv_closure
-            <> ","
+            <> "),"
             <> uint8_arr_closure
             <> ")"
         runner_closure' =
           toJS i
-            <> ".exports.rts_apply("
+            <> ".exports.rts_apply(BigInt("
             <> runner_closure
-            <> ","
+            <> "),"
             <> bs_closure
             <> ")"
         hv_closure = fromString $ show q
@@ -404,10 +404,10 @@ asteriusRunTH _ _ q ty loc s ahc_dist_input = withTempDir "asdf" $ \tmp_dir ->
           toJS i
             <> ".exports.rts_apply("
             <> runner_closure'
-            <> ","
+            <> ",BigInt("
             <> hv_closure
-            <> ")"
-        tid = toJS i <> ".exports.rts_evalLazyIO(" <> applied_closure <> ")"
+            <> "))"
+        tid = toJS i <> ".exports.rts_evalLazyIO(Number(" <> applied_closure <> "))"
         on_error err = do
           hPrint stderr err
           killSession s

asterius/test/rtsapi/rtsapi.mjs

@@ -2,45 +2,59 @@ import * as rts from "./rts.mjs";
 import module from "./rtsapi.wasm.mjs";
 import rtsapi from "./rtsapi.req.mjs";
 
-process.on("unhandledRejection", err => {
+process.on("unhandledRejection", (err) => {
   throw err;
 });
 
 module
-  .then(m => rts.newAsteriusInstance(Object.assign(rtsapi, { module: m })))
-  .then(async i => {
+  .then((m) => rts.newAsteriusInstance(Object.assign(rtsapi, { module: m })))
+  .then(async (i) => {
     await i.exports.main();
     await i.exports.rts_evalLazyIO(
-      i.exports.rts_apply(
-        i.symbolTable.addressOf("Main_printInt_closure"),
+      Number(
         i.exports.rts_apply(
-          i.symbolTable.addressOf("Main_fact_closure"),
-          i.exports.rts_mkInt(5)
+          BigInt(i.symbolTable.addressOf("Main_printInt_closure")),
+          i.exports.rts_apply(
+            BigInt(i.symbolTable.addressOf("Main_fact_closure")),
+            i.exports.rts_mkInt(5n)
+          )
         )
       )
     );
     const tid_p1 = await i.exports.rts_evalIO(
-      i.exports.rts_apply(
-        i.symbolTable.addressOf("base_AsteriusziTopHandler_runNonIO_closure"),
+      Number(
         i.exports.rts_apply(
-          i.symbolTable.addressOf("Main_fact_closure"),
-          i.exports.rts_mkInt(5)
+          BigInt(
+            i.symbolTable.addressOf(
+              "base_AsteriusziTopHandler_runNonIO_closure"
+            )
+          ),
+          i.exports.rts_apply(
+            BigInt(i.symbolTable.addressOf("Main_fact_closure")),
+            i.exports.rts_mkInt(5n)
+          )
         )
       )
     );
-    console.log(i.exports.rts_getInt(i.exports.getTSOret(tid_p1)));
-    console.log(i.exports.rts_getBool(i.exports.rts_mkBool(0)));
-    console.log(i.exports.rts_getBool(i.exports.rts_mkBool(42)));
+    console.log(i.exports.rts_getInt(BigInt(i.exports.getTSOret(tid_p1))));
+    console.log(i.exports.rts_getBool(BigInt(i.exports.rts_mkBool(0))));
+    console.log(i.exports.rts_getBool(BigInt(i.exports.rts_mkBool(42))));
     const x0 = Math.random();
     const tid_p3 = await i.exports.rts_evalIO(
-      i.exports.rts_apply(
-        i.symbolTable.addressOf("base_AsteriusziTopHandler_runNonIO_closure"),
+      Number(
         i.exports.rts_apply(
-          i.symbolTable.addressOf("base_GHCziBase_id_closure"),
-          i.exports.rts_mkDouble(x0)
+          BigInt(
+            i.symbolTable.addressOf(
+              "base_AsteriusziTopHandler_runNonIO_closure"
+            )
+          ),
+          i.exports.rts_apply(
+            BigInt(i.symbolTable.addressOf("base_GHCziBase_id_closure")),
+            i.exports.rts_mkDouble(x0)
+          )
         )
       )
     );
-    const x1 = i.exports.rts_getDouble(i.exports.getTSOret(tid_p3));
+    const x1 = i.exports.rts_getDouble(BigInt(i.exports.getTSOret(tid_p3)));
     console.log([x0, x1, x0 === x1]);
   });