JS: fix support for -outputdir (#22641)

The `-outputdir` option wasn't correctly handled with the JS backend
because the same code path was used to handle both objects produced by
the JS backend and foreign .js files. Now we clearly distinguish the
two in the pipeline, fixing the bug.

4 files changed, 56 insertions, 62 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 25e082c62f..0737a2f8c1 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -607,7 +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
+              LangJs     -> \pe hsc_env ml fp -> Just <$> foreignJsPipeline pe hsc_env ml fp
 #if __GLASGOW_HASKELL__ < 811
               RawObject  -> panic "compileForeign: should be unreachable"
 #endif
@@ -639,7 +639,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
       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
+          pipeline = Just <$> foreignJsPipeline pipe_env hsc_env (Just location) empty_stub
       _ <- runPipeline (hsc_hooks hsc_env) pipeline
       pure ()
 
@@ -858,6 +858,10 @@ jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m Fil
 jsPipeline pipe_env hsc_env location input_fn = do
   use (T_Js pipe_env hsc_env location input_fn)
 
+foreignJsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
+foreignJsPipeline pipe_env hsc_env location input_fn = do
+  use (T_ForeignJs 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
@@ -928,7 +932,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 Js         = Just <$> foreignJsPipeline pipe_env hsc_env Nothing input_fn
    fromPhase MergeForeign = panic "fromPhase: MergeForeign"
 
 {-
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 30bd0531a0..04b641c5d9 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -127,7 +127,10 @@ runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do
           })
         input_fn output_fn
   return output_fn
-runPhase (T_Js pipe_env hsc_env _mb_location js_src) = runJsPhase pipe_env hsc_env js_src
+runPhase (T_Js pipe_env hsc_env location js_src) =
+  runJsPhase pipe_env hsc_env location js_src
+runPhase (T_ForeignJs pipe_env hsc_env location js_src) =
+  runForeignJsPhase pipe_env hsc_env location js_src
 runPhase (T_Cmm pipe_env hsc_env input_fn) = do
   let dflags = hsc_dflags hsc_env
   let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)
@@ -374,31 +377,27 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do
 -- to ensure these timestamps abide by the proper ordering.
 
 -- | Run the JS Backend postHsc phase.
-runJsPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
-runJsPhase pipe_env hsc_env input_fn = do
+runJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
+runJsPhase _pipe_env hsc_env _location input_fn = do
+  let dflags     = hsc_dflags   hsc_env
+  let logger     = hsc_logger   hsc_env
+
+  -- The object file is already generated. We only touch it to ensure the
+  -- timestamp is refreshed, see Note [JS Backend .o file procedure].
+  touchObjectFile logger dflags input_fn
+
+  return input_fn
+
+-- | Deal with foreign JS files (embed them into .o files)
+runForeignJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
+runForeignJsPhase pipe_env hsc_env _location input_fn = do
   let dflags     = hsc_dflags   hsc_env
   let logger     = hsc_logger   hsc_env
   let tmpfs      = hsc_tmpfs    hsc_env
   let unit_env   = hsc_unit_env hsc_env
 
   output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing
-
-  -- if the input filename is the same as the output, then we've probably
-  -- generated the object ourselves. In this case, we touch the object file to
-  -- ensure the timestamp is refreshed, see Note [JS Backend .o file procedure]. If
-  -- they are not the same then we embed the .js file into a .o file with the
-  -- addition of a header
-  --
-  -- We need to canonicalize the paths, otherwise the comparison can return
-  -- wrong results (e.g. with Cabal using paths containing "build/./Foo/..."
-  -- that are compared to "build/Foo/...").
-  --
-  cin  <- canonicalizePath input_fn
-  cout <- canonicalizePath output_fn
-  if (not (equalFilePath cin cout))
-    then embedJsFile logger dflags tmpfs unit_env input_fn output_fn
-    else touchObjectFile logger dflags output_fn
-
+  embedJsFile logger dflags tmpfs unit_env input_fn output_fn
   return output_fn
 
 
diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs b/compiler/GHC/Driver/Pipeline/Phases.hs
index a999a40343..01a507be67 100644
--- a/compiler/GHC/Driver/Pipeline/Phases.hs
+++ b/compiler/GHC/Driver/Pipeline/Phases.hs
@@ -45,6 +45,7 @@ data TPhase res where
   T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
   T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
   T_Js :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
+  T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
   T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
   T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
   T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
diff --git a/compiler/GHC/StgToJS/Linker/Linker.hs b/compiler/GHC/StgToJS/Linker/Linker.hs
index 6c4b011ce9..99e56efbb6 100644
--- a/compiler/GHC/StgToJS/Linker/Linker.hs
+++ b/compiler/GHC/StgToJS/Linker/Linker.hs
@@ -806,45 +806,35 @@ embedJsFile logger dflags tmpfs unit_env input_fn output_fn = do
   -- the header lets the linker recognize processed JavaScript files
   -- But don't add JavaScript header to object files!
 
-  is_js_obj <- if True
-                then pure False
-                else isJsObjectFile input_fn
-                -- FIXME (Sylvain 2022-09): this call makes the
-                -- testsuite go into a loop, I don't know why yet!
-                -- Disabling it for now.
-
-  if is_js_obj
-    then copyWithHeader "" input_fn output_fn
-    else do
-      -- header appended to JS files stored as .o to recognize them.
-      let header = "//JavaScript\n"
-      jsFileNeedsCpp input_fn >>= \case
-        False -> copyWithHeader header input_fn output_fn
-        True  -> do
-
-          -- append common CPP definitions to the .js file.
-          -- They define macros that avoid directly wiring zencoded names
-          -- in RTS JS files
-          pp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
-          payload <- B.readFile input_fn
-          B.writeFile pp_fn (commonCppDefs profiling <> payload)
-
-          -- run CPP on the input JS file
-          js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
-          let
-            cpp_opts = CppOpts
-              { cppUseCc       = True
-              , cppLinePragmas = False -- LINE pragmas aren't JS compatible
-              }
-          doCpp logger
-                  tmpfs
-                  dflags
-                  unit_env
-                  cpp_opts
-                  pp_fn
-                  js_fn
-          -- add header to recognize the object as a JS file
-          copyWithHeader header js_fn output_fn
+  -- header appended to JS files stored as .o to recognize them.
+  let header = "//JavaScript\n"
+  jsFileNeedsCpp input_fn >>= \case
+    False -> copyWithHeader header input_fn output_fn
+    True  -> do
+
+      -- append common CPP definitions to the .js file.
+      -- They define macros that avoid directly wiring zencoded names
+      -- in RTS JS files
+      pp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
+      payload <- B.readFile input_fn
+      B.writeFile pp_fn (commonCppDefs profiling <> payload)
+
+      -- run CPP on the input JS file
+      js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
+      let
+        cpp_opts = CppOpts
+          { cppUseCc       = True
+          , cppLinePragmas = False -- LINE pragmas aren't JS compatible
+          }
+      doCpp logger
+              tmpfs
+              dflags
+              unit_env
+              cpp_opts
+              pp_fn
+              js_fn
+      -- add header to recognize the object as a JS file
+      copyWithHeader header js_fn output_fn
 
 jsFileNeedsCpp :: FilePath -> IO Bool
 jsFileNeedsCpp fn = do