Demonstrate string/array marshaling in jsffi

.dockerignore

@@ -0,0 +1 @@
+.git

Dockerfile

@@ -12,6 +12,7 @@ ENV \
 WORKDIR /root
 
 RUN \
+  apt-mark hold dash && \
   apt update && \
   apt install -y \
     apt-transport-https \

asterius/package.yaml

@@ -11,13 +11,12 @@ extra-source-files:
   - CHANGELOG.md
   - LICENSE
   - README.md
-  - test/fib/fib.hs
-  - test/jsffi/jsffi.hs
-  - test/array/array.hs
-  - test/th/Splices.hs
-  - test/th/th.hs
-  - test/stableptr/stableptr.hs
-  - test/rtsapi/rtsapi.hs
+  - test/array/**/*.hs
+  - test/fib/**/*.hs
+  - test/jsffi/**/*.hs
+  - test/rtsapi/**/*.hs
+  - test/stableptr/**/*.hs
+  - test/th/**/*.hs
 
 data-files:
   - rts/rts.js

asterius/test/jsffi.hs

@@ -17,7 +17,7 @@ main = do
         , "i => {"
         , "i.wasmInstance.exports.hs_init();"
         , "i.wasmInstance.exports.main();"
-        , "console.log(i.wasmInstance.exports.mult_hs(6, 7));"
+        , "console.log(i.wasmInstance.exports.mult_hs(9, 9));"
         , "}"
         ]
     ] <>

asterius/test/jsffi/AsteriusPrim.hs

@@ -0,0 +1,79 @@
+{-# OPTIONS_GHC -Wall -ddump-to-file -ddump-rn -ddump-foreign -ddump-stg -ddump-cmm-raw -ddump-asm #-}
+
+module AsteriusPrim
+  ( JSString
+  , emptyJSString
+  , concatJSString
+  , indexJSString
+  , toJSString
+  , fromJSString
+  , JSArray
+  , emptyJSArray
+  , concatJSArray
+  , indexJSArray
+  , toJSArray
+  , fromJSArray
+  ) where
+
+import Data.List
+
+type JSString = JSRef
+
+{-# INLINEABLE emptyJSString #-}
+emptyJSString :: JSString
+emptyJSString = js_string_empty
+
+{-# INLINEABLE concatJSString #-}
+concatJSString :: JSString -> JSString -> JSString
+concatJSString = js_concat
+
+{-# INLINEABLE indexJSString #-}
+indexJSString :: JSString -> Int -> Char
+indexJSString = js_string_tochar
+
+{-# INLINEABLE toJSString #-}
+toJSString :: String -> JSString
+toJSString = foldl' (\s c -> js_concat s (js_string_fromchar c)) js_string_empty
+
+{-# INLINEABLE fromJSString #-}
+fromJSString :: JSString -> String
+fromJSString s = [js_string_tochar s i | i <- [0 .. js_length s - 1]]
+
+type JSArray = JSRef
+
+{-# INLINEABLE emptyJSArray #-}
+emptyJSArray :: JSArray
+emptyJSArray = js_array_empty
+
+{-# INLINEABLE concatJSArray #-}
+concatJSArray :: JSArray -> JSArray -> JSArray
+concatJSArray = js_concat
+
+{-# INLINEABLE indexJSArray #-}
+indexJSArray :: JSArray -> Int -> JSRef
+indexJSArray = js_array_index
+
+{-# INLINEABLE toJSArray #-}
+toJSArray :: [JSRef] -> JSArray
+toJSArray = foldl' js_concat js_array_empty
+
+{-# INLINEABLE fromJSArray #-}
+fromJSArray :: JSArray -> [JSRef]
+fromJSArray arr = [js_array_index arr i | i <- [0 .. js_length arr - 1]]
+
+foreign import javascript "\"\"" js_string_empty :: JSRef
+
+foreign import javascript "${1}.concat(${2})" js_concat
+  :: JSRef -> JSRef -> JSRef
+
+foreign import javascript "${1}.length" js_length :: JSRef -> Int
+
+foreign import javascript "String.fromCodePoint(${1})" js_string_fromchar
+  :: Char -> JSRef
+
+foreign import javascript "${1}.codePointAt(${2})" js_string_tochar
+  :: JSRef -> Int -> Char
+
+foreign import javascript "[]" js_array_empty :: JSRef
+
+foreign import javascript "${1}[${2}]" js_array_index :: JSRef -> Int -> JSRef

asterius/test/jsffi/jsffi.hs

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -Wall -ddump-to-file -ddump-rn -ddump-foreign -ddump-stg -ddump-cmm-raw -ddump-asm #-}
 
+import AsteriusPrim
 import Foreign.StablePtr
 
 foreign import javascript "new Date()" current_time :: IO JSRef
@@ -25,5 +26,9 @@ main = do
   js_putchar 'H'
   let x = js_mult 6 7
   print_int x
-  x' <- newStablePtr x >>= js_stableptr_id >>= deRefStablePtr
+  x' <- newStablePtr 233 >>= js_stableptr_id >>= deRefStablePtr
   print_int x'
+  js_print $
+    toJSString $
+    fromJSString $ toJSString "I AM A STRING THAT LEAPS BETWEEN HEAPS"
+  js_print $ toJSArray $ fromJSArray $ toJSArray [t, t, t]

binaryen/package.yaml

@@ -26,7 +26,6 @@ custom-setup:
     - Cabal
     - directory
     - filepath
-    - process
 
 ghc-options: -Wall
 

ghc-toolkit/boot-libs/rts/Updates.cmm

@@ -63,13 +63,13 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME,
     }
 
     // common case: it is still our BLACKHOLE
-    if (v == CurrentTSO) (likely: True) {
+    // if (v == CurrentTSO) (likely: True) {
         updateWithIndirection(updatee, ret, return (ret));
-    }
+    // }
 
     // The other cases are all handled by the generic code
-    ccall updateThunk (MyCapability() "ptr", CurrentTSO "ptr",
-                       updatee "ptr", ret "ptr");
+    // ccall updateThunk (MyCapability() "ptr", CurrentTSO "ptr",
+    //                    updatee "ptr", ret "ptr");
 
     return (ret);
 }