JS-Backend: rebased to master 468f919b

First rebase of the JS-Backend. This rebase includes the JS backend
combined with !7442 (new backend design). Unfortunately we have to short
circuit the new backend design because the JS backend takes over after
STG and not after StgToCmm.

What's working:
  - hadrian builds JS backend
  - JS backend outputs .js files and "links" them

What still has to be done:
   - JS backend is missing core js libraries as we add these we
   discover bugs in the linker and js rts.

12 files changed, 69 insertions, 55 deletions

diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs
index 14a9cb5739..269fffe009 100644
--- a/compiler/GHC/Driver/Backend.hs
+++ b/compiler/GHC/Driver/Backend.hs
@@ -222,15 +222,6 @@ platformJSSupported platform
   | platformArch platform == ArchJavaScript = True
   | otherwise                               = False
 
--- | Will this backend produce an object file on the disk?
-backendProducesObject :: Backend -> Bool
-backendProducesObject ViaC        = True
-backendProducesObject NCG         = True
-backendProducesObject LLVM        = True
-backendProducesObject JavaScript  = True
-backendProducesObject Interpreter = False
-backendProducesObject NoBackend   = False
-
 
 -- | A value of type @Backend@ represents one of GHC's back ends.
 -- The set of back ends cannot be extended except by modifying the
@@ -484,7 +475,7 @@ backendWritesFiles :: Backend -> Bool
 backendWritesFiles (Named NCG)         = True
 backendWritesFiles (Named LLVM)        = True
 backendWritesFiles (Named ViaC)        = True
-backendDescription (Named JavaScript)  = True
+backendWritesFiles (Named JavaScript)  = True
 backendWritesFiles (Named Interpreter) = False
 backendWritesFiles (Named NoBackend)   = False
 
@@ -605,12 +596,12 @@ backendPrimitiveImplementation (Named NoBackend)   = GenericPrimitives
 -- `NotValid`, it carries a message that is shown to
 -- users.
 backendSimdValidity :: Backend -> Validity' String
-backendSimdValidity (Named NCG) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
-backendSimdValidity (Named LLVM) = IsValid
-backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
-backendSimdJavaScript (Named JavaScript) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
+backendSimdValidity (Named NCG)         = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
+backendSimdValidity (Named LLVM)        = IsValid
+backendSimdValidity (Named ViaC)        = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
+backendSimdValidity (Named JavaScript)  = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
 backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
-backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
+backendSimdValidity (Named NoBackend)   = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."]
 
 -- | This flag says whether the back end supports large
 -- binary blobs.  See Note [Embedding large binary blobs]
@@ -766,7 +757,7 @@ backendSupportsCImport :: Backend -> Bool
 backendSupportsCImport (Named NCG)         = True
 backendSupportsCImport (Named LLVM)        = True
 backendSupportsCImport (Named ViaC)        = True
-backendSupportsCImport (Named JavaScript)  = False
+backendSupportsCImport (Named JavaScript)  = True
 backendSupportsCImport (Named Interpreter) = True
 backendSupportsCImport (Named NoBackend)   = True
 
@@ -776,7 +767,7 @@ backendSupportsCExport :: Backend -> Bool
 backendSupportsCExport (Named NCG)         = True
 backendSupportsCExport (Named LLVM)        = True
 backendSupportsCExport (Named ViaC)        = True
-backendSupportsCExport (Named JavaScript)  = False
+backendSupportsCExport (Named JavaScript)  = True
 backendSupportsCExport (Named Interpreter) = False
 backendSupportsCExport (Named NoBackend)   = True
 
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 36966eddda..bdb61db1de 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -27,9 +27,9 @@ import GHC.Cmm
 import GHC.Cmm.CLabel
 
 import GHC.Driver.Session
-import GHC.Driver.Config.Finder    (initFinderOpts)
-import GHC.Driver.Config.CmmToAsm  (initNCGConfig)
-import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig)
+import GHC.Driver.Config.Finder    ( initFinderOpts   )
+import GHC.Driver.Config.CmmToAsm  ( initNCGConfig    )
+import GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig )
 import GHC.Driver.LlvmConfigCache  (LlvmConfigCache)
 import GHC.Driver.Ppr
 import GHC.Driver.Backend
@@ -44,8 +44,9 @@ import GHC.Utils.TmpFs
 import GHC.Utils.Error
 import GHC.Utils.Outputable
 import GHC.Utils.Logger
-import GHC.Utils.Exception (bracket)
+import GHC.Utils.Exception ( bracket )
 import GHC.Utils.Ppr (Mode(..))
+import GHC.Utils.Panic.Plain ( pgmError )
 
 import GHC.Unit
 import GHC.Unit.Finder      ( mkStubPaths )
@@ -224,9 +225,9 @@ outputLlvm logger llvm_config dflags filenm cmm_stream = do
 ************************************************************************
 -}
 outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
-outputJS _ _ _ _ _ = panic $ "codeOutput: Hit JavaScript case. You should never reach here!"
-                           ++ "\nThe JS backend should shortcircuit to StgToJS after Stg."
-                           ++ "\nIf you reached this point then you've somehow made it to Cmm!"
+outputJS _ _ _ _ _ = pgmError $ "codeOutput: Hit JavaScript case. You should never reach here!"
+                              ++ "\nThe JS backend should shortcircuit to StgToJS after Stg."
+                              ++ "\nIf you reached this point then you've somehow made it to Cmm!"
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs
index 38e8f6684d..fa7d7c94d2 100644
--- a/compiler/GHC/Driver/Config/StgToCmm.hs
+++ b/compiler/GHC/Driver/Config/StgToCmm.hs
@@ -64,8 +64,9 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
           b_blob  = if not ncg then Nothing else binBlobThreshold dflags
           (ncg, llvm) = case backendPrimitiveImplementation bk_end of
                           GenericPrimitives -> (False, False)
-                          NcgPrimitives -> (True, False)
-                          LlvmPrimitives -> (False, True)
+                          JSPrimitives      -> (False, False)
+                          NcgPrimitives     -> (True, False)
+                          LlvmPrimitives    -> (False, True)
           x86ish  = case platformArch platform of
                       ArchX86    -> True
                       ArchX86_64 -> True
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index ff1adea1c3..7b8be4cb91 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1720,8 +1720,8 @@ hscGenHardCode hsc_env cgguts location output_filename = do
         -- next withTiming after this will be "Assembler" (hard code only).
         let do_code_gen =
               withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ())
-              $ case backend dflags of
-                  JavaScript ->
+              $ case backendCodeOutput (backend dflags) of
+                  JSCodeOutput ->
                     do
                     let js_config = initStgToJSConfig dflags
                         cg_infos      = Nothing
@@ -1756,9 +1756,10 @@ hscGenHardCode hsc_env cgguts location output_filename = do
 
                     (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)
                       <- {-# SCC "codeOutput" #-}
-                      codeOutput logger        tmpfs           dflags   (hsc_units hsc_env)
-                                 this_mod      output_filename location foreign_stubs
-                                 foreign_files dependencies    rawcmms1
+                      codeOutput logger           tmpfs              llvm_config
+                                 dflags          (hsc_units hsc_env) this_mod
+                                 output_filename location            foreign_stubs
+                                 foreign_files   dependencies        rawcmms1
 
                     return (output_filename, stub_c_exists, foreign_fps, Just cg_infos)
         do_code_gen
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 6b7bb9571c..1d55a60726 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -438,7 +438,9 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
 
 
         -- Don't showPass in Batch mode; doLink will do that for us.
-        let isJS = backend dflags == JavaScript
+        let isJS = case backendCodeOutput (backend dflags) of
+                     JSCodeOutput -> True
+                     _            -> False
 
         case ghcLink dflags of
           LinkBinary
@@ -562,7 +564,9 @@ doLink hsc_env o_files = do
     logger   = hsc_logger   hsc_env
     unit_env = hsc_unit_env hsc_env
     tmpfs    = hsc_tmpfs    hsc_env
-    isJS     = backend dflags == JavaScript
+    isJS     = case backendCodeOutput (backend dflags) of
+                 JSCodeOutput -> True
+                 _            -> False
 
   case ghcLink dflags of
     NoLink        -> return ()
@@ -833,8 +837,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)
 
+-- | This JS pipeline is just a no-op because the JS backend short circuits to
+-- 'GHC.StgToJS' before Cmm
 jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
-jsPipeline _ _ _ _ input_fn = pure input_fn -- .o file has been generated by StgToJS
+jsPipeline _ _ _ input_fn = pure input_fn -- .o file has been generated by StgToJS
 
 hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
 hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing
@@ -852,7 +858,7 @@ applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc
 applyPostHscPipeline LlvmPostHscPipeline =
     \pe he ml fp -> Just <$> llvmPipeline pe he ml fp
 applyPostHscPipeline JSPostHscPipeline =
-    \pe he ml fp -> Just <$> jsPipeline
+    \pe he ml fp -> Just <$> jsPipeline pe he ml fp
 applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing
 
 -- Pipeline from a given suffix
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index ff62a9a6db..7cfd4676ce 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -343,6 +343,8 @@ applyAssemblerInfoGetter
     -> Logger -> DynFlags -> Platform -> IO CompilerInfo
 applyAssemblerInfoGetter StandardAssemblerInfoGetter logger dflags _platform =
     getAssemblerInfo logger dflags
+applyAssemblerInfoGetter JSAssemblerInfoGetter _ _ _ =
+    pure Emscripten
 applyAssemblerInfoGetter DarwinClangAssemblerInfoGetter logger dflags platform =
     if platformOS platform == OSDarwin then
         pure Clang
@@ -354,6 +356,8 @@ applyAssemblerProg
     -> Logger -> DynFlags -> Platform -> [Option] -> IO ()
 applyAssemblerProg StandardAssemblerProg logger dflags _platform =
     runAs logger dflags
+applyAssemblerProg JSAssemblerProg logger dflags _platform =
+    runEmscripten logger dflags
 applyAssemblerProg DarwinClangAssemblerProg logger dflags platform =
     if platformOS platform == OSDarwin then
         runClang logger dflags
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 1ed839b814..061c7b777f 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -4925,6 +4925,7 @@ data CompilerInfo
    | Clang
    | AppleClang
    | AppleClang51
+   | Emscripten
    | UnknownCC
    deriving Eq
 
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 07bfc4cfda..f5b69d25a2 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -37,9 +37,7 @@ import GHC.Utils.Outputable
 import GHC.Driver.Session
 import GHC.Platform
 import GHC.Data.OrdList
-import GHC.Utils.Panic
 import GHC.Driver.Hooks
-import GHC.Unit.Module
 
 import Data.List (unzip4)
 
diff --git a/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs
index 2605589fff..926f5d75d0 100644
--- a/compiler/GHC/HsToCore/Foreign/JavaScript.hs
+++ b/compiler/GHC/HsToCore/Foreign/JavaScript.hs
@@ -205,21 +205,25 @@ mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
                <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname)
 
   -- finally, the whole darn thing
-  js_bits = CStub $
-    space $$
-    fun_proto  $$
-    vcat
-     [ lbrace
-     ,   text "return" <+> text "await" <+>
-         text "h$rts_eval" <> parens (
-                (if is_IO_res_ty
-                       then expr_to_run
-                       else text "h$rts_toIO" <> parens expr_to_run)
-                 <> comma <+> unboxResType
-             ) <> semi
-     , rbrace
-     ] $$
-     fun_export
+  js_bits = CStub { getCStub        = js_sdoc
+                  , getInitializers = mempty
+                  , getFinalizers   = mempty
+                  }
+       where js_sdoc = space
+               $$ fun_proto
+               $$ vcat
+                 [ lbrace
+                 ,   text "return"
+                     <+> text "await"
+                     <+> text "h$rts_eval"
+                     <> parens ((if is_IO_res_ty
+                                 then expr_to_run
+                                 else text "h$rts_toIO" <> parens expr_to_run)
+                                <> comma <+> unboxResType)
+                     <> semi
+                 , rbrace
+                 ]
+               $$ fun_export
 
 idClosureText :: Id -> SDoc
 idClosureText i
diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs
index 33aa895a8f..35f0966d0c 100644
--- a/compiler/GHC/StgToJS/Expr.hs
+++ b/compiler/GHC/StgToJS/Expr.hs
@@ -34,6 +34,7 @@ import GHC.StgToJS.StgUtils
 import GHC.StgToJS.CoreUtils
 import GHC.StgToJS.Utils
 
+import GHC.Types.Basic
 import GHC.Types.CostCentre
 import GHC.Types.Tickish
 import GHC.Types.Var.Set
@@ -49,6 +50,7 @@ import GHC.Builtin.PrimOps
 import GHC.Core
 import GHC.Core.TyCon
 import GHC.Core.DataCon
+import GHC.Core.Opt.Arity (isOneShotBndr)
 import GHC.Core.Type hiding (typeSize)
 
 import GHC.Utils.Misc
@@ -317,7 +319,7 @@ resultSize [] t
   -- Note that RuntimeRep from Builtins.Types hits this case. A singleton of
   -- (LiftedRep, 1) is exactly what's returned by the otherwise case for
   -- RuntimeRep.
-  | Nothing <- isLiftedType_maybe t' = [(LiftedRep, 1)]
+  | Nothing <- typeLevity_maybe t' = [(LiftedRep, 1)]
   | otherwise = fmap (\p -> (p, slotCount (primRepSize p))) (typePrimReps t)
   where
     t' = unwrapType t
@@ -420,7 +422,7 @@ genStaticRefs lv
   | otherwise         = do
       unfloated <- State.gets gsUnfloated
       let xs = filter (\x -> not (elemUFM x unfloated ||
-                                  isLiftedType_maybe (idType x) == Just False))
+                                  typeLevity_maybe (idType x) == Just Unlifted))
                       (dVarSetElems sv)
       CIStaticRefs . catMaybes <$> mapM getStaticRef xs
   where
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
index a1846980a1..26963a1b66 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ b/compiler/GHC/SysTools/Tasks.hs
@@ -221,6 +221,12 @@ runClang logger dflags args = traceSystoolCommand logger "clang" $ do
         throwIO err
     )
 
+runEmscripten :: Logger -> DynFlags -> [Option] -> IO ()
+runEmscripten logger dflags args = traceSystoolCommand logger "emcc" $ do
+  let (p,args0) = pgm_a dflags
+      args1     = args0 ++ args
+  runSomething logger "Emscripten" p args1
+
 -- | Figure out which version of LLVM we are running this session
 figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)
 figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index d677639cec..eeb6ad2b9d 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -467,7 +467,6 @@ Library
         GHC.HsToCore.Foreign.Decl
         GHC.HsToCore.Foreign.JavaScript
         GHC.HsToCore.Foreign.Prim
-        GHC.HsToCore.Foreign.C
         GHC.HsToCore.Foreign.Utils
         GHC.HsToCore.GuardedRHSs
         GHC.HsToCore.ListComp