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, 87 insertions, 46 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index d05dd751ce..25e082c62f 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -42,7 +42,7 @@ module GHC.Driver.Pipeline (
    TPipelineClass, MonadUse(..),
 
    preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline,
-   hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline,
+   hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, jsPipeline,
    llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,
 
    -- * Default method of running a pipeline
@@ -62,6 +62,7 @@ import GHC.Driver.Errors
 import GHC.Driver.Errors.Types
 import GHC.Driver.Pipeline.Monad
 import GHC.Driver.Config.Diagnostic
+import GHC.Driver.Config.StgToJS
 import GHC.Driver.Phases
 import GHC.Driver.Pipeline.Execute
 import GHC.Driver.Pipeline.Phases
@@ -81,6 +82,9 @@ import GHC.Linker.Static
 import GHC.Linker.Static.Utils
 import GHC.Linker.Types
 
+import GHC.StgToJS.Linker.Linker
+import GHC.StgToJS.Linker.Types (defaultJSLinkConfig)
+
 import GHC.Utils.Outputable
 import GHC.Utils.Error
 import GHC.Utils.Panic
@@ -364,17 +368,17 @@ link :: GhcLink                 -- ^ interactive or batch
 link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt =
   case linkHook hooks of
       Nothing -> case ghcLink of
-          NoLink        -> return Succeeded
-          LinkBinary    -> normal_link
-          LinkStaticLib -> normal_link
-          LinkDynLib    -> normal_link
-          LinkMergedObj -> normal_link
-          LinkInMemory
-              | platformMisc_ghcWithInterpreter $ platformMisc dflags
-              -> -- Not Linking...(demand linker will do the job)
-                 return Succeeded
-              | otherwise
-              -> panicBadLink LinkInMemory
+        NoLink        -> return Succeeded
+        LinkBinary    -> normal_link
+        LinkStaticLib -> normal_link
+        LinkDynLib    -> normal_link
+        LinkMergedObj -> normal_link
+        LinkInMemory
+          | platformMisc_ghcWithInterpreter $ platformMisc dflags
+           -- Not Linking...(demand linker will do the job)
+            -> return Succeeded
+          | otherwise
+            -> panicBadLink LinkInMemory
       Just h  -> h ghcLink dflags batch_attempt_linking hpt
   where
     normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt
@@ -412,7 +416,9 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
             -- the linkables to link
             linkables = map (expectJust "link". homeModInfoObject) home_mod_infos
 
+        debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos))
         debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
+        debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps))
 
         -- check for the -no-link flag
         if isNoLink (ghcLink dflags)
@@ -423,7 +429,8 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
         let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)
             obj_files = concatMap getOfiles linkables
             platform  = targetPlatform dflags
-            exe_file  = exeFileName platform staticLink (outputFile_ dflags)
+            arch_os   = platformArchOS platform
+            exe_file  = exeFileName arch_os staticLink (outputFile_ dflags)
 
         linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps
 
@@ -435,12 +442,13 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
 
 
         -- Don't showPass in Batch mode; doLink will do that for us.
-        let link = case ghcLink dflags of
-                LinkBinary    -> linkBinary logger tmpfs
-                LinkStaticLib -> linkStaticLib logger
-                LinkDynLib    -> linkDynLibCheck logger tmpfs
-                other         -> panicBadLink other
-        link dflags unit_env obj_files pkg_deps
+        case ghcLink dflags of
+          LinkBinary
+            | backendUseJSLinker (backend dflags) -> linkJSBinary logger dflags unit_env obj_files pkg_deps
+            | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps
+          LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps
+          LinkDynLib    -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps
+          other         -> panicBadLink other
 
         debugTraceMsg logger 3 (text "link: done")
 
@@ -453,6 +461,15 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
         return Succeeded
 
 
+linkJSBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
+linkJSBinary logger dflags unit_env obj_files pkg_deps = do
+  -- we use the default configuration for now. In the future we may expose
+  -- settings to the user via DynFlags.
+  let lc_cfg   = defaultJSLinkConfig
+  let cfg      = initStgToJSConfig dflags
+  let extra_js = mempty
+  jsLinkBinary lc_cfg cfg extra_js logger dflags unit_env obj_files pkg_deps
+
 linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired
 linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
         -- if the modification time on the executable is later than the
@@ -460,7 +477,8 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
         -- linking (unless the -fforce-recomp flag was given).
   let platform   = ue_platform unit_env
       unit_state = ue_units unit_env
-      exe_file   = exeFileName platform staticLink (outputFile_ dflags)
+      arch_os    = platformArchOS platform
+      exe_file   = exeFileName arch_os staticLink (outputFile_ dflags)
   e_exe_time <- tryIO $ getModificationUTCTime exe_file
   case e_exe_time of
     Left _  -> return $ NeedsRecompile MustCompile
@@ -544,23 +562,27 @@ compileFile hsc_env stop_phase (src, mb_phase) = do
 
 
 doLink :: HscEnv -> [FilePath] -> IO ()
-doLink hsc_env o_files =
-    let
-        dflags   = hsc_dflags   hsc_env
-        logger   = hsc_logger   hsc_env
-        unit_env = hsc_unit_env hsc_env
-        tmpfs    = hsc_tmpfs    hsc_env
-    in case ghcLink dflags of
-        NoLink        -> return ()
-        LinkBinary    -> linkBinary         logger tmpfs dflags unit_env o_files []
-        LinkStaticLib -> linkStaticLib      logger       dflags unit_env o_files []
-        LinkDynLib    -> linkDynLibCheck    logger tmpfs dflags unit_env o_files []
-        LinkMergedObj
-          | Just out <- outputFile dflags
-          , let objs = [ f | FileOption _ f <- ldInputs dflags ]
-                      -> joinObjectFiles hsc_env (o_files ++ objs) out
-          | otherwise -> panic "Output path must be specified for LinkMergedObj"
-        other         -> panicBadLink other
+doLink hsc_env o_files = do
+  let
+    dflags   = hsc_dflags   hsc_env
+    logger   = hsc_logger   hsc_env
+    unit_env = hsc_unit_env hsc_env
+    tmpfs    = hsc_tmpfs    hsc_env
+
+  case ghcLink dflags of
+    NoLink        -> return ()
+    LinkBinary
+      | backendUseJSLinker (backend dflags)
+                  -> linkJSBinary logger dflags unit_env o_files []
+      | otherwise -> linkBinary logger tmpfs dflags unit_env o_files []
+    LinkStaticLib -> linkStaticLib      logger       dflags unit_env o_files []
+    LinkDynLib    -> linkDynLibCheck    logger tmpfs dflags unit_env o_files []
+    LinkMergedObj
+      | Just out <- outputFile dflags
+      , let objs = [ f | FileOption _ f <- ldInputs dflags ]
+                  -> joinObjectFiles hsc_env (o_files ++ objs) out
+      | otherwise -> panic "Output path must be specified for LinkMergedObj"
+    other         -> panicBadLink other
 
 -----------------------------------------------------------------------------
 -- stub .h and .c files (for foreign export support), and cc files.
@@ -585,6 +607,7 @@ compileForeign hsc_env lang stub_c = do
               LangObjc   -> viaCPipeline Cobjc
               LangObjcxx -> viaCPipeline Cobjcxx
               LangAsm    -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp
+              LangJs     -> \pe hsc_env ml fp -> Just <$> jsPipeline pe hsc_env ml fp
 #if __GLASGOW_HASKELL__ < 811
               RawObject  -> panic "compileForeign: should be unreachable"
 #endif
@@ -608,14 +631,27 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
   -- and https://github.com/haskell/cabal/issues/2257
   let logger = hsc_logger hsc_env
   let tmpfs  = hsc_tmpfs hsc_env
-  empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
   let home_unit = hsc_home_unit hsc_env
-      src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
-  writeFile empty_stub (showSDoc dflags (pprCode src))
-  let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
-      pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
-  _ <- runPipeline (hsc_hooks hsc_env) pipeline
-  return ()
+
+  case backendCodeOutput (backend dflags) of
+    JSCodeOutput -> do
+      empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
+      let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
+      writeFile empty_stub (showSDoc dflags (pprCode src))
+      let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
+          pipeline = Just <$> jsPipeline pipe_env hsc_env (Just location) empty_stub
+      _ <- runPipeline (hsc_hooks hsc_env) pipeline
+      pure ()
+
+    _ -> do
+      empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
+      let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
+      writeFile empty_stub (showSDoc dflags (pprCode src))
+      let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
+          pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
+      _ <- runPipeline (hsc_hooks hsc_env) pipeline
+      pure ()
+
 
 
 {- Environment Initialisation -}
@@ -818,6 +854,10 @@ cmmPipeline pipe_env hsc_env input_fn = do
     Nothing -> panic "CMM pipeline - produced no .o file"
     Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos)
 
+jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
+jsPipeline pipe_env hsc_env location input_fn = do
+  use (T_Js pipe_env hsc_env location input_fn)
+
 hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
 hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing
 hscPostBackendPipeline _ _ HsigFile _ _ _     = return Nothing
@@ -833,9 +873,10 @@ applyPostHscPipeline NcgPostHscPipeline =
 applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc
 applyPostHscPipeline LlvmPostHscPipeline =
     \pe he ml fp -> llvmPipeline pe he ml fp
+applyPostHscPipeline JSPostHscPipeline =
+    \pe he ml fp -> Just <$> jsPipeline pe he ml fp
 applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing
 
-
 -- Pipeline from a given suffix
 pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)
 pipelineStart pipe_env hsc_env input_fn mb_phase =
@@ -870,7 +911,6 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
    objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk
    objFromLinkable _ = Nothing
 
-
    fromPhase :: P m => Phase -> m (Maybe FilePath)
    fromPhase (Unlit p)  = frontend p
    fromPhase (Cpp p)    = frontend p
@@ -888,6 +928,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
    fromPhase StopLn     = return (Just input_fn)
    fromPhase CmmCpp     = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
    fromPhase Cmm        = Just <$> cmmPipeline pipe_env hsc_env input_fn
+   fromPhase Js         = Just <$> jsPipeline pipe_env hsc_env Nothing input_fn
    fromPhase MergeForeign = panic "fromPhase: MergeForeign"
 
 {-