[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
Mon Jul 24 06:04:50 UTC 2023
Josh Meredith pushed to branch wip/js-mk_tup at Glasgow Haskell Compiler / GHC
Commits:
69b8c332 by Josh Meredith at 2023-07-24T16:04:38+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
+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
+ -- symbol = mkJsSymbolBS True mod (occNameMangledFS $ nameOccName name)
+ 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/69b8c33254dc7bdf26cb20090aae8c6541383707
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69b8c33254dc7bdf26cb20090aae8c6541383707
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/20230724/8bbebe46/attachment-0001.html>
More information about the ghc-commits
mailing list