summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Driver/Backend.hs25
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs15
-rw-r--r--compiler/GHC/Driver/Config/StgToCmm.hs5
-rw-r--r--compiler/GHC/Driver/Main.hs11
-rw-r--r--compiler/GHC/Driver/Pipeline.hs14
-rw-r--r--compiler/GHC/Driver/Pipeline/Execute.hs4
-rw-r--r--compiler/GHC/Driver/Session.hs1
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs2
-rw-r--r--compiler/GHC/HsToCore/Foreign/JavaScript.hs34
-rw-r--r--compiler/GHC/StgToJS/Expr.hs6
-rw-r--r--compiler/GHC/SysTools/Tasks.hs6
-rw-r--r--compiler/ghc.cabal.in1
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
View Lorry Controller Status