diff options
Diffstat (limited to 'compiler/GHC/Driver')
| -rw-r--r-- | compiler/GHC/Driver/Backend.hs | 305 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Backend/Internal.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/StgToCmm.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Config/StgToJS.hs | 32 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 85 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Phases.hs | 15 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 133 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline/Execute.hs | 88 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline/Phases.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 3 |
12 files changed, 448 insertions, 243 deletions
diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs index 776e5eb675..b02d5c76f4 100644 --- a/compiler/GHC/Driver/Backend.hs +++ b/compiler/GHC/Driver/Backend.hs @@ -45,6 +45,7 @@ module GHC.Driver.Backend -- * Available back ends , ncgBackend , llvmBackend + , jsBackend , viaCBackend , interpreterBackend , noBackend @@ -96,6 +97,7 @@ module GHC.Driver.Backend , backendAssemblerInfoGetter , backendCDefs , backendCodeOutput + , backendUseJSLinker , backendPostHscPipeline , backendNormalSuccessorPhase , backendName @@ -193,12 +195,11 @@ import GHC.Platform --------------------------------------------------------------------------------- - - platformDefaultBackend :: Platform -> Backend platformDefaultBackend platform = if | platformUnregisterised platform -> viaCBackend | platformNcgSupported platform -> ncgBackend + | platformJSSupported platform -> jsBackend | otherwise -> llvmBackend -- | Is the platform supported by the Native Code Generator? @@ -217,6 +218,11 @@ platformNcgSupported platform = if ArchWasm32 -> True _ -> False +-- | Is the platform supported by the JS backend? +platformJSSupported :: Platform -> Bool +platformJSSupported platform + | platformArch platform == ArchJavaScript = True + | otherwise = False -- | AÂ value of type @Backend@ represents one of GHC's back ends. @@ -247,7 +253,7 @@ instance Show Backend where show = backendDescription -ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend +ncgBackend, llvmBackend, viaCBackend, interpreterBackend, jsBackend, noBackend :: Backend -- | The native code generator. @@ -274,6 +280,11 @@ ncgBackend = Named NCG -- See "GHC.CmmToLlvm" llvmBackend = Named LLVM +-- | The JavaScript Backend +-- +-- See documentation in GHC.StgToJS +jsBackend = Named JavaScript + -- | Via-C ("unregisterised") backend. -- -- Compiles Cmm code into C code, then relies on a C compiler @@ -329,8 +340,9 @@ noBackend = Named NoBackend -- it without mutual recursion across module boundaries.) data PrimitiveImplementation - = LlvmPrimitives -- ^ Primitives supported by LLVM - | NcgPrimitives -- ^ Primitives supported by the native code generator + = LlvmPrimitives -- ^ Primitives supported by LLVM + | NcgPrimitives -- ^ Primitives supported by the native code generator + | JSPrimitives -- ^ Primitives supported by JS backend | GenericPrimitives -- ^ Primitives supported by all back ends deriving Show @@ -344,6 +356,8 @@ data PrimitiveImplementation data DefunctionalizedAssemblerProg = StandardAssemblerProg -- ^ Use the standard system assembler + | JSAssemblerProg + -- ^ JS Backend compile to JS via Stg, and so does not use any assembler | DarwinClangAssemblerProg -- ^ If running on Darwin, use the assembler from the @clang@ -- toolchain. Otherwise use the standard system assembler. @@ -360,6 +374,8 @@ data DefunctionalizedAssemblerProg data DefunctionalizedAssemblerInfoGetter = StandardAssemblerInfoGetter -- ^ Interrogate the standard system assembler + | JSAssemblerInfoGetter + -- ^ If using the JS backend; return 'Emscripten' | DarwinClangAssemblerInfoGetter -- ^ If running on Darwin, return `Clang`; otherwise -- interrogate the standard system assembler. @@ -387,6 +403,7 @@ data DefunctionalizedCodeOutput = NcgCodeOutput | ViaCCodeOutput | LlvmCodeOutput + | JSCodeOutput -- | Names a function that tells the driver what should happen after @@ -407,6 +424,7 @@ data DefunctionalizedPostHscPipeline = NcgPostHscPipeline | ViaCPostHscPipeline | LlvmPostHscPipeline + | JSPostHscPipeline | NoPostHscPipeline -- ^ After code generation, nothing else need happen. -- | Names a function that tells the driver what command-line options @@ -432,42 +450,46 @@ data DefunctionalizedCDefs -- issuing warning messages /only/. If code depends on -- what's in the string, you deserve what happens to you. backendDescription :: Backend -> String -backendDescription (Named NCG) = "native code generator" -backendDescription (Named LLVM) = "LLVM" -backendDescription (Named ViaC) = "compiling via C" +backendDescription (Named NCG) = "native code generator" +backendDescription (Named LLVM) = "LLVM" +backendDescription (Named ViaC) = "compiling via C" +backendDescription (Named JavaScript) = "compiling to JavaScript" backendDescription (Named Interpreter) = "byte-code interpreter" -backendDescription (Named NoBackend) = "no code generated" +backendDescription (Named NoBackend) = "no code generated" -- | This flag tells the compiler driver whether the back -- end will write files: interface files and object files. -- It is typically true for "real" back ends that generate -- code into the filesystem. (That means, not the interpreter.) backendWritesFiles :: Backend -> Bool -backendWritesFiles (Named NCG) = True -backendWritesFiles (Named LLVM) = True -backendWritesFiles (Named ViaC) = True +backendWritesFiles (Named NCG) = True +backendWritesFiles (Named LLVM) = True +backendWritesFiles (Named ViaC) = True +backendWritesFiles (Named JavaScript) = True backendWritesFiles (Named Interpreter) = False -backendWritesFiles (Named NoBackend) = False +backendWritesFiles (Named NoBackend) = False -- | When the back end does write files, this value tells -- the compiler in what manner of file the output should go: -- temporary, persistent, or specific. backendPipelineOutput :: Backend -> PipelineOutput -backendPipelineOutput (Named NCG) = Persistent +backendPipelineOutput (Named NCG) = Persistent backendPipelineOutput (Named LLVM) = Persistent backendPipelineOutput (Named ViaC) = Persistent +backendPipelineOutput (Named JavaScript) = Persistent backendPipelineOutput (Named Interpreter) = NoOutputFile -backendPipelineOutput (Named NoBackend) = NoOutputFile +backendPipelineOutput (Named NoBackend) = NoOutputFile -- | This flag tells the driver whether the back end can -- reuse code (bytecode or object code) that has been -- loaded dynamically. Likely true only of the interpreter. backendCanReuseLoadedCode :: Backend -> Bool -backendCanReuseLoadedCode (Named NCG) = False -backendCanReuseLoadedCode (Named LLVM) = False -backendCanReuseLoadedCode (Named ViaC) = False +backendCanReuseLoadedCode (Named NCG) = False +backendCanReuseLoadedCode (Named LLVM) = False +backendCanReuseLoadedCode (Named ViaC) = False +backendCanReuseLoadedCode (Named JavaScript) = False backendCanReuseLoadedCode (Named Interpreter) = True -backendCanReuseLoadedCode (Named NoBackend) = False +backendCanReuseLoadedCode (Named NoBackend) = False -- | It is is true of every back end except @-fno-code@ -- that it "generates code." Surprisingly, this property @@ -487,33 +509,36 @@ backendCanReuseLoadedCode (Named NoBackend) = False -- to date). -- backendGeneratesCode :: Backend -> Bool -backendGeneratesCode (Named NCG) = True -backendGeneratesCode (Named LLVM) = True -backendGeneratesCode (Named ViaC) = True +backendGeneratesCode (Named NCG) = True +backendGeneratesCode (Named LLVM) = True +backendGeneratesCode (Named ViaC) = True +backendGeneratesCode (Named JavaScript) = True backendGeneratesCode (Named Interpreter) = True -backendGeneratesCode (Named NoBackend) = False +backendGeneratesCode (Named NoBackend) = False -- | When set, this flag turns on interface writing for -- Backpack. It should probably be the same as -- `backendGeneratesCode`, but it is kept distinct for -- reasons described in Note [-fno-code mode]. backendSupportsInterfaceWriting :: Backend -> Bool -backendSupportsInterfaceWriting (Named NCG) = True -backendSupportsInterfaceWriting (Named LLVM) = True -backendSupportsInterfaceWriting (Named ViaC) = True +backendSupportsInterfaceWriting (Named NCG) = True +backendSupportsInterfaceWriting (Named LLVM) = True +backendSupportsInterfaceWriting (Named ViaC) = True +backendSupportsInterfaceWriting (Named JavaScript) = True backendSupportsInterfaceWriting (Named Interpreter) = True -backendSupportsInterfaceWriting (Named NoBackend) = False +backendSupportsInterfaceWriting (Named NoBackend) = False -- | When preparing code for this back end, the type -- checker should pay attention to SPECIALISE pragmas. If -- this flag is `False`, then the type checker ignores -- SPECIALISE pragmas (for imported things?). backendRespectsSpecialise :: Backend -> Bool -backendRespectsSpecialise (Named NCG) = True -backendRespectsSpecialise (Named LLVM) = True -backendRespectsSpecialise (Named ViaC) = True +backendRespectsSpecialise (Named NCG) = True +backendRespectsSpecialise (Named LLVM) = True +backendRespectsSpecialise (Named ViaC) = True +backendRespectsSpecialise (Named JavaScript) = True backendRespectsSpecialise (Named Interpreter) = False -backendRespectsSpecialise (Named NoBackend) = False +backendRespectsSpecialise (Named NoBackend) = False -- | This back end wants the `mi_globals` field of a -- `ModIface` to be populated (with the top-level bindings @@ -522,11 +547,12 @@ backendRespectsSpecialise (Named NoBackend) = False -- (After typechecking a module, Haddock wants access to -- the module's `GlobalRdrEnv`.) backendWantsGlobalBindings :: Backend -> Bool -backendWantsGlobalBindings (Named NCG) = False -backendWantsGlobalBindings (Named LLVM) = False -backendWantsGlobalBindings (Named ViaC) = False +backendWantsGlobalBindings (Named NCG) = False +backendWantsGlobalBindings (Named LLVM) = False +backendWantsGlobalBindings (Named ViaC) = False +backendWantsGlobalBindings (Named JavaScript) = False backendWantsGlobalBindings (Named Interpreter) = True -backendWantsGlobalBindings (Named NoBackend) = True +backendWantsGlobalBindings (Named NoBackend) = True -- | The back end targets a technology that implements -- `switch` natively. (For example, LLVM or C.) Therefore @@ -534,11 +560,12 @@ backendWantsGlobalBindings (Named NoBackend) = True -- form into a decision tree with jump tables at the -- leaves. backendHasNativeSwitch :: Backend -> Bool -backendHasNativeSwitch (Named NCG) = False -backendHasNativeSwitch (Named LLVM) = True -backendHasNativeSwitch (Named ViaC) = True +backendHasNativeSwitch (Named NCG) = False +backendHasNativeSwitch (Named LLVM) = True +backendHasNativeSwitch (Named ViaC) = True +backendHasNativeSwitch (Named JavaScript) = True backendHasNativeSwitch (Named Interpreter) = False -backendHasNativeSwitch (Named NoBackend) = False +backendHasNativeSwitch (Named NoBackend) = False -- | As noted in the documentation for -- `PrimitiveImplementation`, certain primitives have @@ -547,32 +574,35 @@ backendHasNativeSwitch (Named NoBackend) = False -- "GHC.StgToCmm.Prim" what implementations to use with -- this back end. backendPrimitiveImplementation :: Backend -> PrimitiveImplementation -backendPrimitiveImplementation (Named NCG) = NcgPrimitives -backendPrimitiveImplementation (Named LLVM) = LlvmPrimitives -backendPrimitiveImplementation (Named ViaC) = GenericPrimitives +backendPrimitiveImplementation (Named NCG) = NcgPrimitives +backendPrimitiveImplementation (Named LLVM) = LlvmPrimitives +backendPrimitiveImplementation (Named JavaScript) = JSPrimitives +backendPrimitiveImplementation (Named ViaC) = GenericPrimitives backendPrimitiveImplementation (Named Interpreter) = GenericPrimitives -backendPrimitiveImplementation (Named NoBackend) = GenericPrimitives +backendPrimitiveImplementation (Named NoBackend) = GenericPrimitives -- | When this value is `IsValid`, the back end is -- compatible with vector instructions. When it is -- `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."] +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] -- in "GHC.CmmToAsm.Ppr". backendSupportsEmbeddedBlobs :: Backend -> Bool -backendSupportsEmbeddedBlobs (Named NCG) = True -backendSupportsEmbeddedBlobs (Named LLVM) = False -backendSupportsEmbeddedBlobs (Named ViaC) = False +backendSupportsEmbeddedBlobs (Named NCG) = True +backendSupportsEmbeddedBlobs (Named LLVM) = False +backendSupportsEmbeddedBlobs (Named ViaC) = False +backendSupportsEmbeddedBlobs (Named JavaScript) = False backendSupportsEmbeddedBlobs (Named Interpreter) = False -backendSupportsEmbeddedBlobs (Named NoBackend) = False +backendSupportsEmbeddedBlobs (Named NoBackend) = False -- | This flag tells the compiler driver that the back end -- does not support every target platform; it supports @@ -582,22 +612,24 @@ backendSupportsEmbeddedBlobs (Named NoBackend) = False -- platform support, the driver fails over to the LLVM -- back end. backendNeedsPlatformNcgSupport :: Backend -> Bool -backendNeedsPlatformNcgSupport (Named NCG) = True -backendNeedsPlatformNcgSupport (Named LLVM) = False -backendNeedsPlatformNcgSupport (Named ViaC) = False +backendNeedsPlatformNcgSupport (Named NCG) = True +backendNeedsPlatformNcgSupport (Named LLVM) = False +backendNeedsPlatformNcgSupport (Named ViaC) = False +backendNeedsPlatformNcgSupport (Named JavaScript) = False backendNeedsPlatformNcgSupport (Named Interpreter) = False -backendNeedsPlatformNcgSupport (Named NoBackend) = False +backendNeedsPlatformNcgSupport (Named NoBackend) = False -- | This flag is set if the back end can generate code -- for proc points. If the flag is not set, then a Cmm -- pass needs to split proc points (that is, turn each -- proc point into a standalone procedure). backendSupportsUnsplitProcPoints :: Backend -> Bool -backendSupportsUnsplitProcPoints (Named NCG) = True -backendSupportsUnsplitProcPoints (Named LLVM) = False -backendSupportsUnsplitProcPoints (Named ViaC) = False +backendSupportsUnsplitProcPoints (Named NCG) = True +backendSupportsUnsplitProcPoints (Named LLVM) = False +backendSupportsUnsplitProcPoints (Named ViaC) = False +backendSupportsUnsplitProcPoints (Named JavaScript) = False backendSupportsUnsplitProcPoints (Named Interpreter) = False -backendSupportsUnsplitProcPoints (Named NoBackend) = False +backendSupportsUnsplitProcPoints (Named NoBackend) = False -- | This flag guides the driver in resolving issues about -- API support on the target platform. If the flag is set, @@ -610,113 +642,124 @@ backendSupportsUnsplitProcPoints (Named NoBackend) = False -- this back end can replace compilation via C. -- backendSwappableWithViaC :: Backend -> Bool -backendSwappableWithViaC (Named NCG) = True -backendSwappableWithViaC (Named LLVM) = True -backendSwappableWithViaC (Named ViaC) = False +backendSwappableWithViaC (Named NCG) = True +backendSwappableWithViaC (Named LLVM) = True +backendSwappableWithViaC (Named ViaC) = False +backendSwappableWithViaC (Named JavaScript) = False backendSwappableWithViaC (Named Interpreter) = False -backendSwappableWithViaC (Named NoBackend) = False +backendSwappableWithViaC (Named NoBackend) = False -- | This flag is true if the back end works *only* with -- the unregisterised ABI. backendUnregisterisedAbiOnly :: Backend -> Bool -backendUnregisterisedAbiOnly (Named NCG) = False -backendUnregisterisedAbiOnly (Named LLVM) = False -backendUnregisterisedAbiOnly (Named ViaC) = True +backendUnregisterisedAbiOnly (Named NCG) = False +backendUnregisterisedAbiOnly (Named LLVM) = False +backendUnregisterisedAbiOnly (Named ViaC) = True +backendUnregisterisedAbiOnly (Named JavaScript) = False backendUnregisterisedAbiOnly (Named Interpreter) = False -backendUnregisterisedAbiOnly (Named NoBackend) = False +backendUnregisterisedAbiOnly (Named NoBackend) = False -- | This flag is set if the back end generates C code in -- a @.hc@ file. The flag lets the compiler driver know -- if the command-line flag @-C@ is meaningful. backendGeneratesHc :: Backend -> Bool -backendGeneratesHc (Named NCG) = False -backendGeneratesHc (Named LLVM) = False -backendGeneratesHc (Named ViaC) = True +backendGeneratesHc (Named NCG) = False +backendGeneratesHc (Named LLVM) = False +backendGeneratesHc (Named ViaC) = True +backendGeneratesHc (Named JavaScript) = False backendGeneratesHc (Named Interpreter) = False -backendGeneratesHc (Named NoBackend) = False +backendGeneratesHc (Named NoBackend) = False -- | This flag says whether SPT (static pointer table) -- entries will be inserted dynamically if needed. If -- this flag is `False`, then "GHC.Iface.Tidy" should emit C -- stubs that initialize the SPT entries. backendSptIsDynamic :: Backend -> Bool -backendSptIsDynamic (Named NCG) = False -backendSptIsDynamic (Named LLVM) = False -backendSptIsDynamic (Named ViaC) = False +backendSptIsDynamic (Named NCG) = False +backendSptIsDynamic (Named LLVM) = False +backendSptIsDynamic (Named ViaC) = False +backendSptIsDynamic (Named JavaScript) = False backendSptIsDynamic (Named Interpreter) = True -backendSptIsDynamic (Named NoBackend) = False +backendSptIsDynamic (Named NoBackend) = False -- | If this flag is set, then "GHC.HsToCore.Ticks" -- inserts `Breakpoint` ticks. Used only for the -- interpreter. backendWantsBreakpointTicks :: Backend -> Bool -backendWantsBreakpointTicks (Named NCG) = False -backendWantsBreakpointTicks (Named LLVM) = False -backendWantsBreakpointTicks (Named ViaC) = False +backendWantsBreakpointTicks (Named NCG) = False +backendWantsBreakpointTicks (Named LLVM) = False +backendWantsBreakpointTicks (Named ViaC) = False +backendWantsBreakpointTicks (Named JavaScript) = False backendWantsBreakpointTicks (Named Interpreter) = True -backendWantsBreakpointTicks (Named NoBackend) = False +backendWantsBreakpointTicks (Named NoBackend) = False -- | If this flag is set, then the driver forces the -- optimization level to 0, issuing a warning message if -- the command line requested a higher optimization level. backendForcesOptimization0 :: Backend -> Bool -backendForcesOptimization0 (Named NCG) = False -backendForcesOptimization0 (Named LLVM) = False -backendForcesOptimization0 (Named ViaC) = False +backendForcesOptimization0 (Named NCG) = False +backendForcesOptimization0 (Named LLVM) = False +backendForcesOptimization0 (Named ViaC) = False +backendForcesOptimization0 (Named JavaScript) = False backendForcesOptimization0 (Named Interpreter) = True -backendForcesOptimization0 (Named NoBackend) = False +backendForcesOptimization0 (Named NoBackend) = False -- | I don't understand exactly how this works. But if -- this flag is set *and* another condition is met, then -- @ghc/Main.hs@ will alter the `DynFlags` so that all the -- `hostFullWays` are asked for. It is set only for the interpreter. backendNeedsFullWays :: Backend -> Bool -backendNeedsFullWays (Named NCG) = False -backendNeedsFullWays (Named LLVM) = False -backendNeedsFullWays (Named ViaC) = False +backendNeedsFullWays (Named NCG) = False +backendNeedsFullWays (Named LLVM) = False +backendNeedsFullWays (Named ViaC) = False +backendNeedsFullWays (Named JavaScript) = False backendNeedsFullWays (Named Interpreter) = True -backendNeedsFullWays (Named NoBackend) = False +backendNeedsFullWays (Named NoBackend) = False -- | This flag is also special for the interpreter: if a -- message about a module needs to be shown, do we know -- anything special about where the module came from? The -- Boolean argument is a `recomp` flag. backendSpecialModuleSource :: Backend -> Bool -> Maybe String -backendSpecialModuleSource (Named NCG) = const Nothing -backendSpecialModuleSource (Named LLVM) = const Nothing -backendSpecialModuleSource (Named ViaC) = const Nothing +backendSpecialModuleSource (Named NCG) = const Nothing +backendSpecialModuleSource (Named LLVM) = const Nothing +backendSpecialModuleSource (Named ViaC) = const Nothing +backendSpecialModuleSource (Named JavaScript) = const Nothing backendSpecialModuleSource (Named Interpreter) = \b -> if b then Just "interpreted" else Nothing -backendSpecialModuleSource (Named NoBackend) = const (Just "nothing") +backendSpecialModuleSource (Named NoBackend) = const (Just "nothing") -- | This flag says whether the back end supports Haskell -- Program Coverage (HPC). If not, the compiler driver -- will ignore the `-fhpc` option (and will issue a -- warning message if it is used). backendSupportsHpc :: Backend -> Bool -backendSupportsHpc (Named NCG) = True -backendSupportsHpc (Named LLVM) = True -backendSupportsHpc (Named ViaC) = True +backendSupportsHpc (Named NCG) = True +backendSupportsHpc (Named LLVM) = True +backendSupportsHpc (Named ViaC) = True +backendSupportsHpc (Named JavaScript) = False backendSupportsHpc (Named Interpreter) = False -backendSupportsHpc (Named NoBackend) = True +backendSupportsHpc (Named NoBackend) = True -- | This flag says whether the back end supports foreign -- import of C functions. ("Supports" means "does not -- barf on," so @-fno-code@ supports foreign C imports.) backendSupportsCImport :: Backend -> Bool -backendSupportsCImport (Named NCG) = True -backendSupportsCImport (Named LLVM) = True -backendSupportsCImport (Named ViaC) = True +backendSupportsCImport (Named NCG) = True +backendSupportsCImport (Named LLVM) = True +backendSupportsCImport (Named ViaC) = True +backendSupportsCImport (Named JavaScript) = True backendSupportsCImport (Named Interpreter) = True -backendSupportsCImport (Named NoBackend) = True +backendSupportsCImport (Named NoBackend) = True -- | This flag says whether the back end supports foreign -- export of Haskell functions to C. backendSupportsCExport :: Backend -> Bool -backendSupportsCExport (Named NCG) = True -backendSupportsCExport (Named LLVM) = True -backendSupportsCExport (Named ViaC) = True +backendSupportsCExport (Named NCG) = True +backendSupportsCExport (Named LLVM) = True +backendSupportsCExport (Named ViaC) = True +backendSupportsCExport (Named JavaScript) = True backendSupportsCExport (Named Interpreter) = False -backendSupportsCExport (Named NoBackend) = True +backendSupportsCExport (Named NoBackend) = True -- | This (defunctionalized) function runs the assembler -- used on the code that is written by this back end. A @@ -731,11 +774,12 @@ backendSupportsCExport (Named NoBackend) = True -- -- This field is usually defaulted. backendAssemblerProg :: Backend -> DefunctionalizedAssemblerProg -backendAssemblerProg (Named NCG) = StandardAssemblerProg +backendAssemblerProg (Named NCG) = StandardAssemblerProg backendAssemblerProg (Named LLVM) = DarwinClangAssemblerProg backendAssemblerProg (Named ViaC) = StandardAssemblerProg +backendAssemblerProg (Named JavaScript) = JSAssemblerProg backendAssemblerProg (Named Interpreter) = StandardAssemblerProg -backendAssemblerProg (Named NoBackend) = StandardAssemblerProg +backendAssemblerProg (Named NoBackend) = StandardAssemblerProg -- | This (defunctionalized) function is used to retrieve -- an enumeration value that characterizes the C/assembler @@ -749,11 +793,12 @@ backendAssemblerProg (Named NoBackend) = StandardAssemblerProg -- -- This field is usually defaulted. backendAssemblerInfoGetter :: Backend -> DefunctionalizedAssemblerInfoGetter -backendAssemblerInfoGetter (Named NCG) = StandardAssemblerInfoGetter -backendAssemblerInfoGetter (Named LLVM) = DarwinClangAssemblerInfoGetter -backendAssemblerInfoGetter (Named ViaC) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named NCG) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named LLVM) = DarwinClangAssemblerInfoGetter +backendAssemblerInfoGetter (Named ViaC) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named JavaScript) = JSAssemblerInfoGetter backendAssemblerInfoGetter (Named Interpreter) = StandardAssemblerInfoGetter -backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter -- | When using this back end, it may be necessary or -- advisable to pass some `-D` options to a C compiler. @@ -769,11 +814,12 @@ backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter -- -- This field is usually defaulted. backendCDefs :: Backend -> DefunctionalizedCDefs -backendCDefs (Named NCG) = NoCDefs -backendCDefs (Named LLVM) = LlvmCDefs -backendCDefs (Named ViaC) = NoCDefs +backendCDefs (Named NCG) = NoCDefs +backendCDefs (Named LLVM) = LlvmCDefs +backendCDefs (Named ViaC) = NoCDefs +backendCDefs (Named JavaScript) = NoCDefs backendCDefs (Named Interpreter) = NoCDefs -backendCDefs (Named NoBackend) = NoCDefs +backendCDefs (Named NoBackend) = NoCDefs -- | This (defunctionalized) function generates code and -- writes it to a file. The type of the function is @@ -787,11 +833,20 @@ backendCDefs (Named NoBackend) = NoCDefs -- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` -- > -> IO a backendCodeOutput :: Backend -> DefunctionalizedCodeOutput -backendCodeOutput (Named NCG) = NcgCodeOutput -backendCodeOutput (Named LLVM) = LlvmCodeOutput -backendCodeOutput (Named ViaC) = ViaCCodeOutput +backendCodeOutput (Named NCG) = NcgCodeOutput +backendCodeOutput (Named LLVM) = LlvmCodeOutput +backendCodeOutput (Named ViaC) = ViaCCodeOutput +backendCodeOutput (Named JavaScript) = JSCodeOutput backendCodeOutput (Named Interpreter) = panic "backendCodeOutput: interpreterBackend" -backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" +backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" + +backendUseJSLinker :: Backend -> Bool +backendUseJSLinker (Named NCG) = False +backendUseJSLinker (Named LLVM) = False +backendUseJSLinker (Named ViaC) = False +backendUseJSLinker (Named JavaScript) = True +backendUseJSLinker (Named Interpreter) = False +backendUseJSLinker (Named NoBackend) = False -- | This (defunctionalized) function tells the compiler -- driver what else has to be run after code output. @@ -805,9 +860,10 @@ backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" -- > -> FilePath -- > -> m (Maybe FilePath) backendPostHscPipeline :: Backend -> DefunctionalizedPostHscPipeline -backendPostHscPipeline (Named NCG) = NcgPostHscPipeline +backendPostHscPipeline (Named NCG) = NcgPostHscPipeline backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline +backendPostHscPipeline (Named JavaScript) = JSPostHscPipeline backendPostHscPipeline (Named Interpreter) = NoPostHscPipeline backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline @@ -818,21 +874,23 @@ backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline -- value gives instructions like "run the C compiler", -- "run the assembler," or "run the LLVM Optimizer." backendNormalSuccessorPhase :: Backend -> Phase -backendNormalSuccessorPhase (Named NCG) = As False +backendNormalSuccessorPhase (Named NCG) = As False backendNormalSuccessorPhase (Named LLVM) = LlvmOpt backendNormalSuccessorPhase (Named ViaC) = HCc +backendNormalSuccessorPhase (Named JavaScript) = StopLn backendNormalSuccessorPhase (Named Interpreter) = StopLn -backendNormalSuccessorPhase (Named NoBackend) = StopLn +backendNormalSuccessorPhase (Named NoBackend) = StopLn -- | Name of the back end, if any. Used to migrate legacy -- clients of the GHC API. Code within the GHC source -- tree should not refer to a back end's name. backendName :: Backend -> BackendName -backendName (Named NCG) = NCG +backendName (Named NCG) = NCG backendName (Named LLVM) = LLVM backendName (Named ViaC) = ViaC +backendName (Named JavaScript) = JavaScript backendName (Named Interpreter) = Interpreter -backendName (Named NoBackend) = NoBackend +backendName (Named NoBackend) = NoBackend @@ -843,6 +901,7 @@ allBackends :: [Backend] allBackends = [ ncgBackend , llvmBackend , viaCBackend + , jsBackend , interpreterBackend , noBackend ] @@ -911,7 +970,7 @@ Such a function may be applied in one of two ways: applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] @ - Function `applyCDefs` is defined in module "GHC.Driver.Pipeline.Execute". + Function `applyCDefs` is defined in module "GHC.SysTools.Cpp". I don't love this solution, but defunctionalization is a standard thing, and it makes the meanings of the enumeration values clear. diff --git a/compiler/GHC/Driver/Backend/Internal.hs b/compiler/GHC/Driver/Backend/Internal.hs index 99484b752e..596755dd1f 100644 --- a/compiler/GHC/Driver/Backend/Internal.hs +++ b/compiler/GHC/Driver/Backend/Internal.hs @@ -27,6 +27,7 @@ data BackendName = NCG -- ^ Names the native code generator backend. | LLVM -- ^ Names the LLVM backend. | ViaC -- ^ Names the Via-C backend. + | JavaScript -- ^ Names the JS backend. | Interpreter -- ^ Names the ByteCode interpreter. | NoBackend -- ^ Names the `-fno-code` backend. deriving (Eq, Show) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 2e56336cba..934d958120 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -28,9 +28,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 @@ -45,8 +45,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 ) @@ -125,6 +126,7 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g final_stream ViaCCodeOutput -> outputC logger dflags filenm final_stream pkg_deps LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm final_stream + JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs ; return (filenm, stubs_exist, foreign_fps, a) } @@ -219,6 +221,18 @@ outputLlvm logger llvm_config dflags filenm cmm_stream = do {- ************************************************************************ * * +\subsection{JavaScript} +* * +************************************************************************ +-} +outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputJS _ _ _ _ _ = pgmError $ "codeOutput: Hit JavaScript case. We 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!" + +{- +************************************************************************ +* * \subsection{Foreign import/export} * * ************************************************************************ diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs index c7f716bbfc..283ece1d50 100644 --- a/compiler/GHC/Driver/Config/StgToCmm.hs +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -63,8 +63,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/Config/StgToJS.hs b/compiler/GHC/Driver/Config/StgToJS.hs new file mode 100644 index 0000000000..087767d39b --- /dev/null +++ b/compiler/GHC/Driver/Config/StgToJS.hs @@ -0,0 +1,32 @@ +module GHC.Driver.Config.StgToJS + ( initStgToJSConfig + ) +where + +import GHC.StgToJS.Types + +import GHC.Driver.Session +import GHC.Platform.Ways +import GHC.Utils.Outputable + +import GHC.Prelude + +-- | Initialize StgToJS settings from DynFlags +initStgToJSConfig :: DynFlags -> StgToJSConfig +initStgToJSConfig dflags = StgToJSConfig + -- flags + { csInlinePush = False + , csInlineBlackhole = False + , csInlineLoadRegs = False + , csInlineEnter = False + , csInlineAlloc = False + , csTraceRts = False + , csAssertRts = False + , csBoundsCheck = gopt Opt_DoBoundsChecking dflags + , csDebugAlloc = False + , csTraceForeign = False + , csProf = ways dflags `hasWay` WayProf + , csRuntimeAssert = False + -- settings + , csContext = initSDocContext dflags defaultDumpStyle + } diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index b1154b6398..0144454abf 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -77,6 +77,7 @@ data DumpFlag | Opt_D_dump_asm_stats | Opt_D_dump_c_backend | Opt_D_dump_llvm + | Opt_D_dump_js | Opt_D_dump_core_stats | Opt_D_dump_deriv | Opt_D_dump_ds diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 4a22645223..b6ff27621b 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -132,6 +132,7 @@ import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) import GHC.Driver.Config.Cmm (initCmmConfig) import GHC.Driver.LlvmConfigCache (initLlvmConfigCache) +import GHC.Driver.Config.StgToJS (initStgToJSConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Tidy import GHC.Driver.Hooks @@ -153,6 +154,7 @@ import GHC.Hs.Stats ( ppSourceStats ) import GHC.HsToCore import GHC.StgToByteCode ( byteCodeGen ) +import GHC.StgToJS ( stgToJS ) import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) @@ -1789,7 +1791,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do cg_foreign = foreign_stubs0, cg_foreign_files = foreign_files, cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info } = cgguts + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries + } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env @@ -1849,38 +1853,53 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------ Code generation ------------------ -- The back-end is streamed: each top-level function goes -- from Stg all the way to asm before dealing with the next - -- top-level function, so showPass isn't very useful here. - -- Hence we have one showPass for the whole backend, the - -- next showPass after this will be "Assembler". - withTiming logger - (text "CodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - cmms <- {-# SCC "StgToCmm" #-} - doCodeGen hsc_env this_mod denv data_tycons - cost_centre_info - stg_binds hpc_info - - ------------------ Code output ----------------------- - rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger profile cmms - Just h -> h dflags (Just this_mod) cmms - - let dump a = do - unless (null a) $ - putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) - return a - rawcmms1 = Stream.mapM dump rawcmms0 - - let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init - `appendStubC` cgIPEStub st - - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos) - <- {-# SCC "codeOutput" #-} - 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 stg_cg_infos, Just cmm_cg_infos) + -- top-level function, so withTiming isn't very useful here. + -- Hence we have one withTiming for the whole backend, the + -- next withTiming after this will be "Assembler" (hard code only). + withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) + $ case backendCodeOutput (backend dflags) of + JSCodeOutput -> + do + let js_config = initStgToJSConfig dflags + cmm_cg_infos = Nothing + stub_c_exists = Nothing + foreign_fps = [] + + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG + (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds) + + -- do the unfortunately effectual business + stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename + return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, cmm_cg_infos) + + _ -> + do + cmms <- {-# SCC "StgToCmm" #-} + doCodeGen hsc_env this_mod denv data_tycons + cost_centre_info + stg_binds hpc_info + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + case cmmToRawCmmHook hooks of + Nothing -> cmmToRawCmm logger profile cmms + Just h -> h dflags (Just this_mod) cmms + + let dump a = do + unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) + return a + rawcmms1 = Stream.mapM dump rawcmms0 + + let foreign_stubs st = foreign_stubs0 + `appendStubC` prof_init + `appendStubC` cgIPEStub st + + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos) + <- {-# SCC "codeOutput" #-} + 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 stg_cg_infos, Just cmm_cg_infos) -- The part of CgGuts that we need for HscInteractive diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs index c4be206fbf..2cfcd6d9f6 100644 --- a/compiler/GHC/Driver/Phases.hs +++ b/compiler/GHC/Driver/Phases.hs @@ -99,6 +99,7 @@ data Phase | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code | MergeForeign -- merge in the foreign object files + | Js -- pre-process Js source -- The final phase is a pseudo-phase that tells the pipeline to stop. | StopLn -- Stop, but linking will follow, so generate .o file @@ -134,6 +135,7 @@ eqPhase MergeForeign MergeForeign = True eqPhase StopLn StopLn = True eqPhase Ccxx Ccxx = True eqPhase Cobjcxx Cobjcxx = True +eqPhase Js Js = True eqPhase _ _ = False -- MP: happensBefore is only used in preprocessPipeline, that usage should @@ -165,6 +167,7 @@ nextPhase platform p Cmm -> maybeHCc HCc -> MergeForeign MergeForeign -> StopLn + Js -> StopLn StopLn -> panic "nextPhase: nothing after StopLn" where maybeHCc = if platformUnregisterised platform then HCc @@ -198,6 +201,7 @@ startPhase "lm_s" = LlvmMangle startPhase "o" = StopLn startPhase "cmm" = CmmCpp startPhase "cmmcpp" = Cmm +startPhase "js" = Js startPhase _ = StopLn -- all unknown file types -- This is used to determine the extension for the output from the @@ -226,10 +230,11 @@ phaseInputExt LlvmMangle = "lm_s" phaseInputExt CmmCpp = "cmmcpp" phaseInputExt Cmm = "cmm" phaseInputExt MergeForeign = "o" +phaseInputExt Js = "js" phaseInputExt StopLn = "o" haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - haskellish_user_src_suffixes, haskellish_sig_suffixes + js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes :: [String] -- When a file with an extension in the haskellish_src_suffixes group is -- loaded in --make mode, its imports will be loaded too. @@ -238,6 +243,7 @@ haskellish_src_suffixes = haskellish_user_src_suffixes ++ haskellish_suffixes = haskellish_src_suffixes ++ [ "hc", "cmm", "cmmcpp" ] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] +js_suffixes = [ "js" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = @@ -259,13 +265,14 @@ dynlib_suffixes platform = case platformOS platform of _ -> ["so"] isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isHaskellSigSuffix + isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isBackpackishSuffix s = s `elem` backpackish_suffixes isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes +isJsSuffix s = s `elem` js_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool @@ -275,6 +282,7 @@ isDynLibSuffix platform s = s `elem` dynlib_suffixes platform isSourceSuffix :: String -> Bool isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff + || isJsSuffix suff || isBackpackishSuffix suff -- | When we are given files (modified by -x arguments) we need @@ -291,7 +299,7 @@ isHaskellishTarget :: (String, Maybe Phase) -> Bool isHaskellishTarget (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) isHaskellishTarget (_,Just phase) = - phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, Js , StopLn] isHaskellishFilename, isHaskellSrcFilename, isCishFilename, @@ -319,4 +327,5 @@ phaseForeignLanguage phase = case phase of HCc -> Just LangC As _ -> Just LangAsm MergeForeign -> Just RawObject + Js -> Just LangJs _ -> Nothing 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" {- diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index 2a1e877292..bd9ee7805a 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -46,6 +46,7 @@ import GHC.Utils.Error import Data.Maybe import GHC.CmmToLlvm.Mangler import GHC.SysTools +import GHC.SysTools.Cpp import GHC.Utils.Panic.Plain import System.Directory import System.FilePath @@ -72,13 +73,12 @@ import GHC.Settings import System.IO import GHC.Linker.ExtraObj import GHC.Linker.Dynamic -import Data.Version import GHC.Utils.Panic import GHC.Unit.Module.Env import GHC.Driver.Env.KnotVars import GHC.Driver.Config.Finder import GHC.Rename.Names -import GHC.SysTools.Cpp +import GHC.StgToJS.Linker.Linker (embedJsFile) import Language.Haskell.Syntax.Module.Name import GHC.Unit.Home.ModInfo @@ -127,6 +127,7 @@ 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_Cmm pipe_env hsc_env input_fn) = do let dflags = hsc_dflags hsc_env let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) @@ -345,11 +346,62 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do return output_fn + +-- Note [JS Backend .o file procedure] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The JS backend breaks some of the assumptions on file generation order +-- because it directly produces .o files. This violation breaks some of the +-- assumptions on file timestamps, particularly in the postHsc phase. The +-- postHsc phase for the JS backend is performed in 'runJsPhase'. Consider +-- what the NCG does: +-- +-- With other NCG backends we have the following order: +-- 1. The backend produces a .s file +-- 2. Then we write the interface file, .hi +-- 3. Then we generate a .o file in a postHsc phase (calling the asm phase etc.) +-- +-- For the JS Backend this order is different +-- 1. The JS Backend _directly_ produces .o files +-- 2. Then we write the interface file. Notice that this breaks the ordering +-- of .hi > .o (step 2 and step 3 in the NCG above). +-- +-- This violation results in timestamp checks which pass on the NCG but fail +-- in the JS backend. In particular, checks that compare 'ms_obj_date', and +-- 'ms_iface_date' in 'GHC.Unit.Module.ModSummary'. +-- +-- Thus to fix this ordering we touch the object files we generated earlier +-- 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 + 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 + if (input_fn /= output_fn) + then embedJsFile logger dflags tmpfs unit_env input_fn output_fn + else touchObjectFile logger dflags output_fn + + return output_fn + + applyAssemblerInfoGetter :: DefunctionalizedAssemblerInfoGetter -> 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 @@ -361,6 +413,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 @@ -1113,36 +1167,6 @@ linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [UnitInfo] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = unitPackageVersion pkg - pkgname = map fixchar (unitPackageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - - -- ----------------------------------------------------------------------------- -- Misc. diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs b/compiler/GHC/Driver/Pipeline/Phases.hs index c54bf2d838..a999a40343 100644 --- a/compiler/GHC/Driver/Pipeline/Phases.hs +++ b/compiler/GHC/Driver/Pipeline/Phases.hs @@ -44,6 +44,7 @@ data TPhase res where T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath) 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_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/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 168a204fbc..ea3866b00d 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2443,6 +2443,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_core_stats) , make_ord_flag defGhcFlag "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-js" + (setDumpFlag Opt_D_dump_js) , make_ord_flag defGhcFlag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) , make_ord_flag defGhcFlag "ddump-asm-liveness" @@ -4943,6 +4945,7 @@ data CompilerInfo | Clang | AppleClang | AppleClang51 + | Emscripten | UnknownCC deriving Eq |