Add Javascript backend

Add JS backend adapted from the GHCJS project by Luite Stegeman.

Some features haven't been ported or implemented yet. Tests for these
features have been disabled with an associated gitlab ticket.

Bump array submodule

Work funded by IOG.

Co-authored-by: Jeffrey Young <jeffrey.young@iohk.io>
Co-authored-by: Luite Stegeman <stegeman@gmail.com>
Co-authored-by: Josh Meredith <joshmeredith2008@gmail.com>

1 files changed, 66 insertions, 18 deletions

diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index b98d8979f9..f1d1cd742c 100644
--- a/utils/deriveConstants/Main.hs
+++ b/utils/deriveConstants/Main.hs
@@ -51,17 +51,26 @@ main = do opts <- parseArgs
           case mode of
               Gen_Haskell_Type ->
                   writeHaskellType fn
-                      [ what | (wh, what) <- wanteds "OS must not matter"
+                      [ what | (wh, what) <- wanteds Nothing -- OS must not matter
                              , wh `elem` [Haskell, Both] ]
               Gen_Computed cm ->
-                  do os <- getOption "target os"   o_targetOS
+                  do os_str  <- getOption "target os"   o_targetOS
                      tmpdir  <- getOption "tmpdir"      o_tmpdir
                      gccProg <- getOption "gcc program" o_gccProg
                      nmProg  <- getOption "nm program"  o_nmProg
-                     let verbose = o_verbose opts
+                     let os = case os_str of
+                                "ghcjs"   -> JS
+                                "aix"     -> AIX
+                                "wasi"    -> WASI
+                                "openbsd" -> OpenBSD
+                                "mingw32" -> Windows
+                                _         -> DefaultOS
+                         verbose = o_verbose opts
                          gccFlags = o_gccFlags opts
-                     rs <- getWanted verbose os tmpdir gccProg gccFlags nmProg
-                                     (o_objdumpProg opts)
+                     rs <- case os of
+                             JS -> getWantedJS
+                             _  -> getWanted verbose os tmpdir gccProg gccFlags nmProg
+                                        (o_objdumpProg opts)
                      let haskellRs = [ what
                                      | (wh, what) <- rs
                                      , wh `elem` [Haskell, Both] ]
@@ -81,6 +90,15 @@ data Options = Options {
                    o_targetOS :: Maybe String
                }
 
+data OS
+   = DefaultOS
+   | JS
+   | AIX
+   | WASI
+   | OpenBSD
+   | Windows
+   deriving (Show, Eq)
+
 -- | Write a file atomically
 --
 -- This avoids other processes seeing the file while it is being written into.
@@ -290,7 +308,7 @@ defSize w nameBase cExpr = [(w, GetWord ("SIZEOF_" ++ nameBase) (Fst cExpr))]
 defClosureSize :: Where -> Name -> CExpr -> Wanteds
 defClosureSize w nameBase cExpr = [(w, GetClosureSize ("SIZEOF_" ++ nameBase) (Fst cExpr))]
 
-wanteds :: String -> Wanteds
+wanteds :: Maybe OS -> Wanteds
 wanteds os = concat
           [-- Control group constant for integrity check; this
            -- round-tripped constant is used for testing that
@@ -620,7 +638,7 @@ wanteds os = concat
            -- Note that this conditional part only affects the C headers.
            -- That's important, as it means we get the same PlatformConstants
            -- type on all platforms.
-          ,if os == "mingw32"
+          ,if os == Just Windows
            then concat [structSize  C "StgAsyncIOResult"
                        ,structField C "StgAsyncIOResult" "reqID"
                        ,structField C "StgAsyncIOResult" "len"
@@ -686,10 +704,10 @@ wanteds os = concat
           ,constantBool    Haskell "USE_INLINE_SRT_FIELD" "defined(USE_INLINE_SRT_FIELD)"
           ]
 
-getWanted :: Bool -> String -> FilePath -> FilePath -> [String] -> FilePath -> Maybe FilePath
+getWanted :: Bool -> OS -> FilePath -> FilePath -> [String] -> FilePath -> Maybe FilePath
              -> IO Results
 getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
-    = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) (wanteds os))
+    = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) (wanteds (Just os)))
              cFile = tmpdir </> "tmp.c"
              oFile = tmpdir </> "tmp.o"
          atomicWriteFile cFile cStuff
@@ -700,19 +718,19 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
          -- the buffer length info we're interested in.
          execute verbose gccProgram (gccFlags ++ (
              case os of
-                 "wasi" -> ["-emit-llvm", "-S"]
+                 WASI -> ["-emit-llvm", "-S"]
                  _ -> ["-c"]
              ) ++ [cFile, "-o", oFile])
          xs <- case os of
-                 "openbsd" -> readProcess objdumpProgam ["--syms", oFile] ""
-                 "aix"     -> readProcess objdumpProgam ["--syms", oFile] ""
-                 "wasi"    -> readFile oFile
-                 _         -> readProcess nmProgram ["-P", oFile] ""
+                 OpenBSD -> readProcess objdumpProgam ["--syms", oFile] ""
+                 AIX     -> readProcess objdumpProgam ["--syms", oFile] ""
+                 WASI    -> readFile oFile
+                 _       -> readProcess nmProgram ["-P", oFile] ""
 
          let ls = lines xs
              m = Map.fromList $ case os of
-                 "aix" -> parseAixObjdump ls
-                 "wasi" -> mapMaybe parseLLLine ls
+                 AIX   -> parseAixObjdump ls
+                 WASI  -> mapMaybe parseLLLine ls
                  _     -> mapMaybe parseNmLine ls
 
          case Map.lookup "CONTROL_GROUP_CONST_291" m of
@@ -725,7 +743,7 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
                               ++ "to 'configure'.\n"
              Just x     -> die ("unexpected value round-tripped for CONTROL_GROUP_CONST_291: " ++ show x)
 
-         mapM (lookupResult m) (wanteds os)
+         mapM (lookupResult m) (wanteds (Just os))
     where headers = ["#define IN_STG_CODE 0",
                      "",
                      "/*",
@@ -742,7 +760,7 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
                      -- FIXME: rts/PosixSource.h should include ghcplatform.h
                      -- which should set this. There is a mismatch host/target
                      -- again...
-                     if os == "mingw32" then "#define mingw32_HOST_OS 1" else "",
+                     if os == Windows then "#define mingw32_HOST_OS 1" else "",
                      "",
                      "#include \"rts/PosixSource.h\"",
                      "#include \"Rts.h\"",
@@ -901,6 +919,36 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram
           lookupResult _ (w, FieldTypeGcptrMacro name)
               = return (w, FieldTypeGcptrMacro name)
 
+-- The JavaScript backend doesn't require the native-RTS constants, so we filter those here,
+-- and provide reasonable presets for any remaining constants. This way, `deriveConstants`
+-- can still produce a valid constants file (required by GHC), without the side-effect of
+-- producing a c file.
+getWantedJS :: IO Results
+getWantedJS = mapM lookupResult (wanteds (Just JS))
+  where
+    jsHardCoded :: Map String Integer
+    jsHardCoded = Map.fromList [ ("WORD_SIZE", 4)
+                               , ("DOUBLE_SIZE", 8)
+                               , ("CINT_SIZE", 4)
+                               , ("CLONG_SIZE", 4)
+                               , ("CLONG_LONG_SIZE", 8)
+                               ]
+
+    lookupResult :: (Where, What Fst) -> IO (Where, What Snd)
+    lookupResult (w, GetWord name _) | Just res <- Map.lookup name jsHardCoded
+                 = return (w, GetWord name (Snd res))
+    lookupResult (w, what) = return $ case what of
+      GetWord             name _ -> (w, GetWord             name (Snd 0))
+      GetInt              name _ -> (w, GetWord             name (Snd 0))
+      GetNatural          name _ -> (w, GetWord             name (Snd 0))
+      GetBool             name _ -> (w, GetBool             name (Snd False))
+      GetFieldType        name _ -> (w, GetFieldType        name (Snd 1))
+      GetClosureSize      name _ -> (w, GetClosureSize      name (Snd 1))
+      StructFieldMacro    name   -> (w, StructFieldMacro    name)
+      ClosureFieldMacro   name   -> (w, ClosureFieldMacro   name)
+      ClosurePayloadMacro name   -> (w, ClosurePayloadMacro name)
+      FieldTypeGcptrMacro name   -> (w, FieldTypeGcptrMacro name)
+
 writeHaskellType :: FilePath -> [What Fst] -> IO ()
 writeHaskellType fn ws = atomicWriteFile fn xs
     where xs = unlines [header, body, footer, parser]