[Git][ghc/ghc][wip/js-mk_tup] JavaScript: update MK_TUP macros to use current tuple constructors (#23659)

Josh Meredith (@JoshMeredith) gitlab at gitlab.haskell.org
Tue Aug 1 11:32:25 UTC 2023



Josh Meredith pushed to branch wip/js-mk_tup at Glasgow Haskell Compiler / GHC


Commits:
ae802353 by Josh Meredith at 2023-08-01T21:32:05+10:00
JavaScript: update MK_TUP macros to use current tuple constructors (#23659)

- - - - -


7 changed files:

- compiler/GHC/StgToJS/Linker/Utils.hs
- testsuite/tests/javascript/all.T
- testsuite/tests/javascript/js-ffi-string.hs
- testsuite/tests/javascript/js-ffi-string.stdout
- + testsuite/tests/javascript/js-mk_tup.hs
- + testsuite/tests/javascript/js-mk_tup.stdout
- + testsuite/tests/javascript/test-mk_tup.js


Changes:

=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -47,6 +47,14 @@ import System.IO
 import Data.Char (isSpace)
 import qualified Control.Exception as Exception
 
+import GHC.Builtin.Types
+import Language.Haskell.Syntax.Basic
+import GHC.Types.Name
+import GHC.StgToJS.Ids
+import GHC.Core.DataCon
+import GHC.JS.Unsat.Syntax
+import GHC.Data.FastString
+
 -- | Retrieve library directories provided by the @UnitId@ in @UnitState@
 getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText]
 getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us
@@ -71,6 +79,26 @@ commonCppDefs_vanilla, commonCppDefs_profiled :: ByteString
 commonCppDefs_vanilla  = genCommonCppDefs False
 commonCppDefs_profiled = genCommonCppDefs True
 
+-- | Generate macros MK_TUP* for tuples sized 2+.
+genMkTup :: Bool -> Int -> ByteString
+genMkTup profiling n = mconcat
+  [ "#define MK_TUP", sn                                                          -- #define MK_TUPn
+  , "(", B.intercalate "," xs, ")"                                                -- (x1,x2,...)
+  , "(h$c", sn, "("                                                               -- (h$cn(
+  , bytesFS symbol, ","                                                           -- h$ghczmprimZCGHCziTupleziPrimziZnT_con_e,                                                                        -- ,
+  , B.intercalate "," $ map (\x -> "(" <> x <> ")") xs                            -- (x1),(x2),(...)
+  , if profiling then ",h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM" else "" -- ,h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM
+  , "))\n"                                                                        -- ))\n
+  ]
+  where
+    xs = take n $ map (("x" <>) . Char8.pack . show) ([1..] :: [Int])
+    sn = Char8.pack $ show n
+    TxtI symbol = makeIdentForId (dataConWorkId $ tupleDataCon Boxed n) Nothing IdConEntry mod
+    name = tupleDataConName Boxed n
+    mod = case nameModule_maybe name of
+      Just m -> m
+      Nothing -> error "Tuple constructor is missing a module"
+
 -- | Generate CPP Definitions depending on a profiled or normal build. This
 -- occurs at link time.
 genCommonCppDefs :: Bool -> ByteString
@@ -87,29 +115,7 @@ genCommonCppDefs profiling = mconcat
     in mconcat (closure_defs ++ thread_defs)
 
   -- low-level heap object manipulation macros
-  , if profiling
-      then mconcat
-        [ "#define MK_TUP2(x1,x2)                           (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP3(x1,x2,x3)                        (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP4(x1,x2,x3,x4)                     (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP5(x1,x2,x3,x4,x5)                  (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP6(x1,x2,x3,x4,x5,x6)               (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7)            (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8)         (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9)      (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        ]
-      else mconcat
-        [ "#define MK_TUP2(x1,x2)                           (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2)))\n"
-        , "#define MK_TUP3(x1,x2,x3)                        (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3)))\n"
-        , "#define MK_TUP4(x1,x2,x3,x4)                     (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4)))\n"
-        , "#define MK_TUP5(x1,x2,x3,x4,x5)                  (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5)))\n"
-        , "#define MK_TUP6(x1,x2,x3,x4,x5,x6)               (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6)))\n"
-        , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7)            (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7)))\n"
-        , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8)         (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8)))\n"
-        , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9)      (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9)))\n"
-        , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10)))\n"
-        ]
+  , mconcat (map (genMkTup profiling) [2..10])
 
   , "#define TUP2_1(x) ((x).d1)\n"
   , "#define TUP2_2(x) ((x).d2)\n"


=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -16,6 +16,8 @@ test('js-callback03', normal, compile_and_run, [''])
 test('js-callback04', js_skip, compile_and_run, [''])
 test('js-callback05', js_skip, compile_and_run, [''])
 
+test('js-mk_tup', extra_files(['test-mk_tup.js']), compile_and_run, ['test-mk_tup.js'])
+
 test('T23346', normal, compile_and_run, [''])
 test('T22455', normal, compile_and_run, ['-ddisable-js-minifier'])
 test('T23565', normal, compile_and_run, [''])


=====================================
testsuite/tests/javascript/js-ffi-string.hs
=====================================
@@ -17,33 +17,38 @@ foreign import javascript "(() => { return 'abc' + String.fromCodePoint(128522);
 hsString :: String
 hsString = "abc" ++ "\128522"
 
+emptyHsString :: String
+emptyHsString = drop (length hsString) hsString
+
 main :: IO ()
 main = do
-  putStrLn "Does JS `String.fromCodePoint` decode to the expected UTF-16 values? "
+  putStr "Does JS `String.fromCodePoint` decode to the expected UTF-16 values? "
   print (eq_JSVal js_utf16_string js_codepoint_string)
   hFlush stdout
   log_js_string js_utf16_string
   log_js_string js_codepoint_string
 
-  putStrLn "\nDoes `GHC.JS.fromJSString` convert the JavaScript literal string correctly? "
+  putStr "\nDoes `GHC.JS.fromJSString` convert the JavaScript literal string correctly? "
   print (hsString == fromJSString js_utf16_string)
   putStrLn hsString
   putStrLn (fromJSString js_utf16_string)
 
-  putStrLn "\nDoes `GHC.JS.toJSString` convert the Haskell-defined string correctly? "
+  putStr "\nDoes `GHC.JS.toJSString` convert the Haskell-defined string correctly? "
   print (eq_JSVal js_utf16_string (toJSString hsString))
   hFlush stdout
   log_js_string js_utf16_string
   log_js_string (toJSString hsString)
 
-  putStrLn "\nDo values survive the Haskell -> JavaScript -> Haskell round-trip? "
+  putStr "\nDo values survive the Haskell -> JavaScript -> Haskell round-trip? "
   print (hsString == fromJSString (toJSString hsString))
   putStrLn hsString
   putStrLn (fromJSString js_utf16_string)
 
-  putStrLn "\nDo values survive the JavaScript -> Haskell -> JavaScript round-trip? "
+  putStr "\nDo values survive the JavaScript -> Haskell -> JavaScript round-trip? "
   print (eq_JSVal js_utf16_string (toJSString $ fromJSString js_utf16_string))
   hFlush stdout
   log_js_string js_utf16_string
   log_js_string (toJSString $ fromJSString js_utf16_string)
 
+  putStr "\nDoes the empty string survive the Haskell -> JavaScript -> Haskell round-trip? "
+  print (emptyHsString == fromJSString (toJSString emptyHsString))


=====================================
testsuite/tests/javascript/js-ffi-string.stdout
=====================================
@@ -1,25 +1,21 @@
-Does JS `String.fromCodePoint` decode to the expected UTF-16 values? 
-True
+Does JS `String.fromCodePoint` decode to the expected UTF-16 values? True
 abc😊
 abc😊
 
-Does `GHC.JS.fromJSString` convert the JavaScript literal string correctly? 
-True
+Does `GHC.JS.fromJSString` convert the JavaScript literal string correctly? True
 abc😊
 abc😊
 
-Does `GHC.JS.toJSString` convert the Haskell-defined string correctly? 
-True
+Does `GHC.JS.toJSString` convert the Haskell-defined string correctly? True
 abc😊
 abc😊
 
-Do values survive the Haskell -> JavaScript -> Haskell round-trip? 
-True
+Do values survive the Haskell -> JavaScript -> Haskell round-trip? True
 abc😊
 abc😊
 
-Do values survive the JavaScript -> Haskell -> JavaScript round-trip? 
-True
+Do values survive the JavaScript -> Haskell -> JavaScript round-trip? True
 abc😊
 abc😊
 
+Does the empty string survive the Haskell -> JavaScript -> Haskell round-trip? True


=====================================
testsuite/tests/javascript/js-mk_tup.hs
=====================================
@@ -0,0 +1,83 @@
+module Main where
+
+import qualified GHC.Exts as Exts
+import           Unsafe.Coerce
+
+foreign import javascript "test_mk_tup2"  js_mk_tup2  :: Exts.Any -- (Int, Int)
+foreign import javascript "test_mk_tup3"  js_mk_tup3  :: Exts.Any -- (Int, Int, Int)
+foreign import javascript "test_mk_tup4"  js_mk_tup4  :: Exts.Any -- (Int, Int, Int, Int)
+foreign import javascript "test_mk_tup5"  js_mk_tup5  :: Exts.Any -- (Int, Int, Int, Int, ...)
+foreign import javascript "test_mk_tup6"  js_mk_tup6  :: Exts.Any -- (Int, Int, Int, Int, ...)
+foreign import javascript "test_mk_tup7"  js_mk_tup7  :: Exts.Any -- (Int, Int, Int, Int, ...)
+foreign import javascript "test_mk_tup8"  js_mk_tup8  :: Exts.Any -- (Int, Int, Int, Int, ...)
+foreign import javascript "test_mk_tup9"  js_mk_tup9  :: Exts.Any -- (Int, Int, Int, Int, ...)
+foreign import javascript "test_mk_tup10" js_mk_tup10 :: Exts.Any -- (Int, Int, Int, Int, ...)
+
+mkTup2 :: (Int, Int)
+mkTup2 = unsafeCoerce js_mk_tup2
+
+mkTup3 :: (Int, Int, Int)
+mkTup3 = unsafeCoerce js_mk_tup3
+
+mkTup4 :: (Int, Int, Int, Int)
+mkTup4 = unsafeCoerce js_mk_tup4
+
+mkTup5 :: (Int, Int, Int, Int, Int)
+mkTup5 = unsafeCoerce js_mk_tup5
+
+mkTup6 :: (Int, Int, Int, Int, Int, Int)
+mkTup6 = unsafeCoerce js_mk_tup6
+
+mkTup7 :: (Int, Int, Int, Int, Int, Int, Int)
+mkTup7 = unsafeCoerce js_mk_tup7
+
+mkTup8 :: (Int, Int, Int, Int, Int, Int, Int, Int)
+mkTup8 = unsafeCoerce js_mk_tup8
+
+mkTup9 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)
+mkTup9 = unsafeCoerce js_mk_tup9
+
+mkTup10 :: (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)
+mkTup10 = unsafeCoerce js_mk_tup10
+
+-- We have to use the Haskell tuple constructors here to make sure
+-- that the linker includes them in the final output for us to use
+-- in our JS code.
+main :: IO ()
+main = do
+  putStr "mkTup2: "
+  print $ mkTup2 == (101, 102)
+  print mkTup2
+
+  putStr "mkTup3: "
+  print $ mkTup3 == (101, 102, 103)
+  print mkTup3
+
+  putStr "mkTup4: "
+  print $ mkTup4 == (101, 102, 103, 104)
+  print mkTup4
+
+  putStr "mkTup5: "
+  print $ mkTup5 == (101, 102, 103, 104, 105)
+  print mkTup5
+
+  putStr "mkTup6: "
+  print $ mkTup6 == (101, 102, 103, 104, 105, 106)
+  print mkTup6
+
+  putStr "mkTup7: "
+  print $ mkTup7 == (101, 102, 103, 104, 105, 106, 107)
+  print mkTup7
+
+  putStr "mkTup8: "
+  print $ mkTup8 == (101, 102, 103, 104, 105, 106, 107, 108)
+  print mkTup8
+
+  putStr "mkTup9: "
+  print $ mkTup9 == (101, 102, 103, 104, 105, 106, 107, 108, 109)
+  print mkTup9
+
+  putStr "mkTup10: "
+  print $ mkTup10 == (101, 102, 103, 104, 105, 106, 107, 108, 109, 110)
+  print mkTup10
+


=====================================
testsuite/tests/javascript/js-mk_tup.stdout
=====================================
@@ -0,0 +1,18 @@
+mkTup2: True
+(101,102)
+mkTup3: True
+(101,102,103)
+mkTup4: True
+(101,102,103,104)
+mkTup5: True
+(101,102,103,104,105)
+mkTup6: True
+(101,102,103,104,105,106)
+mkTup7: True
+(101,102,103,104,105,106,107)
+mkTup8: True
+(101,102,103,104,105,106,107,108)
+mkTup9: True
+(101,102,103,104,105,106,107,108,109)
+mkTup10: True
+(101,102,103,104,105,106,107,108,109,110)


=====================================
testsuite/tests/javascript/test-mk_tup.js
=====================================
@@ -0,0 +1,37 @@
+//#OPTIONS: CPP
+
+function test_mk_tup2() {
+  return MK_TUP2(101,102);
+}
+
+function test_mk_tup3() {
+  return MK_TUP3(101,102,103);
+}
+
+function test_mk_tup4() {
+  return MK_TUP4(101,102,103,104);
+}
+
+function test_mk_tup5() {
+  return MK_TUP5(101,102,103,104,105);
+}
+
+function test_mk_tup6() {
+  return MK_TUP6(101,102,103,104,105,106);
+}
+
+function test_mk_tup7() {
+  return MK_TUP7(101,102,103,104,105,106,107);
+}
+
+function test_mk_tup8() {
+  return MK_TUP8(101,102,103,104,105,106,107,108);
+}
+
+function test_mk_tup9() {
+  return MK_TUP9(101,102,103,104,105,106,107,108,109);
+}
+
+function test_mk_tup10() {
+  return MK_TUP10(101,102,103,104,105,106,107,108,109,110);
+}



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae802353b3789822c2b59980d39c7ce2197f1889

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae802353b3789822c2b59980d39c7ce2197f1889
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/20230801/98d3be11/attachment-0001.html>


More information about the ghc-commits mailing list