diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2022-02-10 08:24:24 +0000 |
|---|---|---|
| committer | Sylvain Henry <sylvain@haskus.fr> | 2022-11-29 09:44:31 +0100 |
| commit | cc25d52e0f65d54c052908c7d91d5946342ab88a (patch) | |
| tree | 0f35764ee3b9b0451ac999b64d2db9fa074fa3dd /compiler/GHC | |
| parent | def47dd32491311289bff26230b664c895f178cc (diff) | |
| download | haskell-cc25d52e0f65d54c052908c7d91d5946342ab88a.tar.gz | |
Add Javascript backend
Add JS backend adapted from the GHCJS project by Luite Stegeman.
Some features haven't been ported or implemented yet. Tests for these
features have been disabled with an associated gitlab ticket.
Bump array submodule
Work funded by IOG.
Co-authored-by: Jeffrey Young <jeffrey.young@iohk.io>
Co-authored-by: Luite Stegeman <stegeman@gmail.com>
Co-authored-by: Josh Meredith <joshmeredith2008@gmail.com>
Diffstat (limited to 'compiler/GHC')
70 files changed, 14362 insertions, 419 deletions
diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 8b4fc099cd..c9f0d56aaf 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module GHC.Builtin.PrimOps ( PrimOp(..), PrimOpVecCat(..), allThePrimOps, @@ -18,7 +19,7 @@ module GHC.Builtin.PrimOps ( primOpOutOfLine, primOpCodeSize, primOpOkForSpeculation, primOpOkForSideEffects, primOpIsCheap, primOpFixity, primOpDocs, - primOpIsDiv, + primOpIsDiv, primOpIsReallyInline, getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), @@ -807,3 +808,12 @@ data PrimCall = PrimCall CLabelString Unit instance Outputable PrimCall where ppr (PrimCall lbl pkgId) = text "__primcall" <+> ppr pkgId <+> ppr lbl + +-- | Indicate if a primop is really inline: that is, it isn't out-of-line and it +-- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- hence induce thread/stack/heap changes. +primOpIsReallyInline :: PrimOp -> Bool +primOpIsReallyInline = \case + SeqOp -> False + DataToTagOp -> False + p -> not (primOpOutOfLine p) diff --git a/compiler/GHC/Data/Graph/Directed.hs b/compiler/GHC/Data/Graph/Directed.hs index 2e1d13bec5..74e619ef90 100644 --- a/compiler/GHC/Data/Graph/Directed.hs +++ b/compiler/GHC/Data/Graph/Directed.hs @@ -7,6 +7,7 @@ module GHC.Data.Graph.Directed ( Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, + graphFromVerticesAndAdjacency, SCC(..), Node(..), flattenSCC, flattenSCCs, stronglyConnCompG, @@ -547,3 +548,21 @@ classifyEdges root getSucc edges = ends'' = addToUFM ends' n time'' in (time'' + 1, starts'', ends'') + +graphFromVerticesAndAdjacency + :: Ord key + => [Node key payload] + -> [(key, key)] -- First component is source vertex key, + -- second is target vertex key (thing depended on) + -- Unlike the other interface I insist they correspond to + -- actual vertices because the alternative hides bugs. I can't + -- do the same thing for the other one for backcompat reasons. + -> Graph (Node key payload) +graphFromVerticesAndAdjacency [] _ = emptyGraph +graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) + where key_extractor = node_key + (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVerticesOrd vertices key_extractor + key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, + expectJust "graphFromVerticesAndAdjacency" $ key_vertex b) + reduced_edges = map key_vertex_pair edges + graph = buildG bounds reduced_edges 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 diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 89be7cca40..32730030e9 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -19,6 +19,7 @@ import GHC.Data.FastString import GHC.Tc.Utils.Monad -- temp import GHC.HsToCore.Foreign.C +import GHC.HsToCore.Foreign.JavaScript import GHC.HsToCore.Foreign.Utils import GHC.HsToCore.Monad @@ -35,7 +36,6 @@ import GHC.Utils.Outputable import GHC.Driver.Session import GHC.Platform import GHC.Data.OrdList -import GHC.Utils.Panic import GHC.Driver.Hooks import Data.List (unzip4) @@ -127,8 +127,11 @@ dsFImport :: Id -> Coercion -> ForeignImport (GhcPass p) -> DsM ([Binding], CHeader, CStub) -dsFImport id co (CImport _ cconv safety mHeader spec) = - dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader +dsFImport id co (CImport _ cconv safety mHeader spec) = do + platform <- getPlatform + case platformArch platform of + ArchJavaScript -> dsJsImport id co spec (unLoc cconv) (unLoc safety) mHeader + _ -> dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader {- ************************************************************************ @@ -163,9 +166,11 @@ dsFExport :: Id -- Either the exported Id, , String -- string describing type to pass to createAdj. , Int -- size of args to stub function ) -dsFExport fn_id co ext_name cconv is_dyn = case cconv of - JavaScriptCallConv -> panic "dsFExport: JavaScript foreign exports not supported yet" - _ -> dsCFExport fn_id co ext_name cconv is_dyn +dsFExport fn_id co ext_name cconv is_dyn = do + platform <- getPlatform + case platformArch platform of + ArchJavaScript -> dsJsFExport fn_id co ext_name cconv is_dyn + _ -> dsCFExport fn_id co ext_name cconv is_dyn foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub diff --git a/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs new file mode 100644 index 0000000000..820ab80275 --- /dev/null +++ b/compiler/GHC/HsToCore/Foreign/JavaScript.hs @@ -0,0 +1,683 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handling of JavaScript foreign imports/exports +module GHC.HsToCore.Foreign.JavaScript + ( dsJsImport + , dsJsFExport + , dsJsFExportDynamic + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Hs + +import GHC.HsToCore.Monad +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.Prim +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Utils + +import GHC.Core +import GHC.Core.Make +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.Unfold.Make +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Multiplicity + +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Literal +import GHC.Types.ForeignStubs +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Basic +import GHC.Types.Unique + +import GHC.Unit.Module + +import GHC.Tc.Utils.TcType + +import GHC.Cmm.Expr +import GHC.Cmm.Utils + +import GHC.JS.Ppr + +import GHC.Driver.Session +import GHC.Driver.Config + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names + +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.Maybe + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Encoding + +dsJsFExport + :: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( CHeader -- contents of Module_stub.h + , CStub -- contents of Module_stub.c + , String -- string describing type to pass to createAdj. + , Int -- size of args to stub function + ) + +dsJsFExport fn_id co ext_name cconv isDyn = do + let + ty = pSnd $ coercionKind co + (_tvs,sans_foralls) = tcSplitForAllTyVars ty + (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + platform <- targetPlatform <$> getDynFlags + return $ + mkFExportJSBits platform ext_name + (if isDyn then Nothing else Just fn_id) + (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv + +mkFExportJSBits + :: Platform + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (CHeader, + CStub, + String, -- the argument reps + Int -- total size of arguments + ) +mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv + = (header_bits, js_bits, type_string, + sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- arg_info] -- all the args + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM + ) + where + -- list the arguments to the JS function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, + stg_type, + ty, + typeCmmType platform (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + arg_cname n _stg_ty = text ('a':show n) + + type_string = primTyDescChar platform res_hty : arg_type_string + + arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] + + -- stuff to do with the return type of the JS function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + unboxResType | res_hty_is_unit = text "h$rts_getUnit" + | otherwise = unpackHObj res_hty + + header_bits = maybe mempty idTag maybe_target + idTag i = let (tag, u) = unpkUnique (getUnique i) + in CHeader (char tag <> int u) + + fun_args + | null arg_info = empty -- text "void" + | otherwise = hsep $ punctuate comma + $ map (\(nm,_ty,_,_) -> nm) arg_info + + fun_proto + = text "async" <+> + text "function" <+> + (if isNothing maybe_target + then text "h$" <> ftext c_nm + else ftext c_nm) <> + parens fun_args + + fun_export + = case maybe_target of + Just hs_fn | Just m <- nameModule_maybe (getName hs_fn) -> + text "h$foreignExport" <> + parens ( + ftext c_nm <> comma <> + strlit (unitIdString (moduleUnitId m)) <> comma <> + strlit (moduleNameString (moduleName m)) <> comma <> + strlit (unpackFS c_nm) <> comma <> + strlit type_string + ) <> semi + _ -> empty + + strlit xs = docToSDoc (pprStringLit (mkFastString xs)) + + -- the target which will form the root of what we ask rts_evalIO to run + the_cfun + = case maybe_target of + Nothing -> text "h$deRefStablePtr(the_stableptr)" + Just hs_fn -> idClosureText hs_fn + + -- the expression we give to rts_eval + expr_to_run :: SDoc + expr_to_run + = foldl appArg the_cfun arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "h$rts_apply" + <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname) + + -- finally, the whole darn thing + 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 + | isExportedId i + , name <- getName i + , Just m <- nameModule_maybe name + = let str = renderWithContext defaultSDocContext (pprFullName m (localiseName name)) + in text "h$" <> text (zEncodeString str) + | otherwise + = panic "idClosureText: unknown module" + +-- | Desugaring of JavaScript foreign imports +dsJsImport + :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], CHeader, CStub) +dsJsImport id co (CLabel cid) cconv _ _ = do + let ty = pFst $ coercionKind co + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (_resTy, foRhs) <- jsResultWrapper ty +-- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this + let rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) + rhs' = Cast rhs co + stdcall_info = fun_type_arg_stdcall_info cconv ty + + return ([(id, rhs')], mempty, mempty) + +dsJsImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsJsImport id co (CFunction target) cconv safety mHeader + = dsJsCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsJsImport id co CWrapper cconv _ _ + = dsJsFExportDynamic id co cconv + +-- fixme work in progress +-- FIXME (Sylvain 2022-03): possibility of code sharing with dsFExportDynamic? +-- Lot of duplication +dsJsFExportDynamic :: Id + -> Coercion + -> CCallConv + -> DsM ([Binding], CHeader, CStub) +dsJsFExportDynamic id co0 cconv = do + let + ty = pFst (coercionKind co0) + (tvs,sans_foralls) = tcSplitForAllTyVars ty + ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + (io_tc, res_ty) = expectJust "dsJsFExportDynamic: IO type expected" + -- Must have an IO type; hence Just + $ tcSplitIOType_maybe fn_res_ty + mod <- getModule + platform <- targetPlatform <$> getDynFlags + let fe_nm = mkFastString $ zEncodeString + ("h$" ++ moduleStableString mod ++ "$" ++ toJsName id) + -- Construct the label based on the passed id, don't use names + -- depending on Unique. See #13807 and Note [Unique Determinism]. + cback <- newSysLocalDs arg_mult arg_ty + newStablePtrId <- dsLookupGlobalId newStablePtrName + stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + let + stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] + export_ty = mkVisFunTyMany stable_ptr_ty arg_ty + bindIOId <- dsLookupGlobalId bindIOName + stbl_value <- newSysLocalDs ManyTy stable_ptr_ty + (h_code, c_code, typestring, args_size) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True + let + {- + The arguments to the external function which will + create a little bit of (template) code on the fly + for allowing the (stable pointed) Haskell closure + to be entered using an external calling convention + (stdcall, ccall). + -} + adj_args = [ mkIntLit platform (toInteger (ccallConvToInt cconv)) + , Var stbl_value + , Lit (LitLabel fe_nm mb_sz_args IsFunction) + , Lit (mkLitString typestring) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = fsLit "createAdjustor" + + -- Determine the number of bytes of arguments to the stub function, + -- so that we can attach the '@N' suffix to its label if it is a + -- stdcall on Windows. + mb_sz_args = case cconv of + StdCallConv -> Just args_size + _ -> Nothing + + ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) + -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + return ([fed], h_code, c_code) + +toJsName :: Id -> String +toJsName i = renderWithContext defaultSDocContext (pprCode (ppr (idName i))) + +dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], CHeader, CStub) +dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do + let + ty = pFst $ coercionKind co + (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty + (arg_tys, io_res_ty) = tcSplitFunTys rho + + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + (val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + simpl_opts <- initSimpleOpts <$> getDynFlags + + let + -- Build the worker + fcall = CCall (CCallSpec target cconv safety) + worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs + the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + fn_id_w_inl = fn_id + `setIdUnfolding` + mkInlineUnfoldingWithArity simpl_opts VanillaSrc + (length args) wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, mempty) + + +mkHObj :: Type -> SDoc +mkHObj t = text "h$rts_mk" <> text (showFFIType t) + +unpackHObj :: Type -> SDoc +unpackHObj t = text "h$rts_get" <> text (showFFIType t) + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> text (showFFIType t) + +showFFIType :: Type -> String +showFFIType t = getOccString (getName (typeTyCon t)) + +typeTyCon :: Type -> TyCon +typeTyCon ty + -- UnaryRep rep_ty <- repType ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) -- rep_ty + = tc + | otherwise + = pprPanic "typeTyCon" (ppr ty) + + +{- + We unbox arguments for JS calls a bit different from native code: + - Bool is marshalled to true/false, not 0/1 + - All int types are narrowed, since JS floats have a greater range than Int32 + -} + +unboxJsArg :: CoreExpr -- The supplied argument + -> DsM (CoreExpr, -- To pass as the actual argument + CoreExpr -> CoreExpr -- Wrapper to unbox the arg + ) +unboxJsArg arg + -- Primtive types: nothing to unbox + | isPrimitiveType arg_ty + = return (arg, \body -> body) + + -- Recursive newtypes + | Just (co, _rep_ty) <- topNormaliseNewType_maybe arg_ty + = unboxJsArg (mkCast arg co) + + -- Booleans, do not convert to 0/1, only force them + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` boolTyConKey + = return (arg, + \ body -> mkWildCase arg (unrestricted boolTy) (exprType body) [Alt DEFAULT [] body]) + + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` anyTyConKey + = return (arg, + \ body -> mkWildCase arg (unrestricted arg_ty) (exprType body) [Alt DEFAULT [] body]) + -- Data types with a single constructor, which has a single, primitive-typed arg + -- This deals with Int, Float etc; also Ptr, ForeignPtr + | is_product_type && data_con_arity == 1 + = do case_bndr <- newSysLocalDs ManyTy arg_ty + prim_arg <- newSysLocalDs ManyTy (scaledThing data_con_arg_ty1) + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] + ) + + -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- data ByteArray ix = ByteArray ix ix ByteArray# + -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) + | is_product_type && + data_con_arity == 3 && + isJust maybe_arg3_tycon && + (arg3_tycon == byteArrayPrimTyCon || + arg3_tycon == mutableByteArrayPrimTyCon) + = do case_bndr <- newSysLocalDs ManyTy arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys + return (Var arr_cts_var, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body] + ) + + | otherwise + = do l <- getSrcSpanDs + pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty) + where + arg_ty = exprType arg + maybe_product_type = splitDataProductType_maybe arg_ty + is_product_type = isJust maybe_product_type + Just (_, _, data_con, data_con_arg_tys) = maybe_product_type + data_con_arity = dataConSourceArity data_con + (data_con_arg_ty1 : _) = data_con_arg_tys + + (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys + maybe_arg3_tycon = tyConAppTyCon_maybe (scaledThing data_con_arg_ty3) + Just arg3_tycon = maybe_arg3_tycon + + +boxJsResult :: Type + -> DsM (Type, CoreExpr -> CoreExpr) +boxJsResult result_ty + | isRuntimeRepKindedTy result_ty = panic "boxJsResult: runtime rep ty" -- fixme +-- Takes the result of the user-level ccall: +-- either (IO t), +-- or maybe just t for an side-effect-free call +-- Returns a wrapper for the primitive ccall itself, along with the +-- type of the result of the primitive ccall. This result type +-- will be of the form +-- State# RealWorld -> (# State# RealWorld, t' #) +-- where t' is the unwrapped form of t. If t is simply (), then +-- the result type will be +-- State# RealWorld -> (# State# RealWorld #) + +boxJsResult result_ty + | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty + -- isIOType_maybe handles the case where the type is a + -- simple wrapping of IO. E.g. + -- newtype Wrap a = W (IO a) + -- No coercion necessary because its a non-recursive newtype + -- (If we wanted to handle a *recursive* newtype too, we'd need + -- another case, and a coercion.) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- jsResultWrapper io_res_ty + ; let return_result state ans + = mkCoreUnboxedTuple [state, ans] + + ; (ccall_res_ty, the_alt) <- mk_alt return_result res + + ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) } + +boxJsResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- jsResultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + where + return_result _ ans = ans + +mk_alt :: (Expr Var -> Expr Var -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, CoreAlt) +mk_alt return_result (Nothing, wrap_result) + = do -- The ccall returns () + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result $ panic "jsBoxResult") + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs + return (ccall_res_ty, the_alt) + +mk_alt return_result (Just prim_res_ty, wrap_result) + -- The ccall returns a non-() value + | isUnboxedTupleType prim_res_ty = do + let + Just ls = fmap dropRuntimeRepArgs (tyConAppArgs_maybe prim_res_ty) + arity = 1 + length ls + args_ids <- mapM (newSysLocalDs ManyTy) ls + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + result_tup = mkCoreUnboxedTuple (map Var args_ids) + the_rhs = return_result (Var state_id) + (wrap_result result_tup) + ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls) + the_alt = Alt (DataAlt (tupleDataCon Unboxed arity)) + (state_id : args_ids) + the_rhs + return (ccall_res_ty, the_alt) + + | otherwise = do + result_id <- newSysLocalDs ManyTy prim_res_ty + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result (Var result_id)) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs + return (ccall_res_ty, the_alt) + +fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int +fun_type_arg_stdcall_info _other_conv _ = Nothing + + +jsResultWrapper + :: Type + -> DsM ( Maybe Type -- Type of the expected result, if any + , CoreExpr -> CoreExpr -- Wrapper for the result + ) +-- resultWrapper deals with the result *value* +-- E.g. foreign import foo :: Int -> IO T +-- Then resultWrapper deals with marshalling the 'T' part +jsResultWrapper result_ty + | isRuntimeRepKindedTy result_ty = return (Nothing, id) -- fixme this seems like a hack + -- Base case 1a: unboxed tuples + | Just (tc, args) <- splitTyConApp_maybe result_ty + , isUnboxedTupleTyCon tc {- && False -} = do + let args' = dropRuntimeRepArgs args + (tys, wrappers) <- unzip <$> mapM jsResultWrapper args' + matched <- mapM (mapM (newSysLocalDs ManyTy)) tys + let tys' = catMaybes tys + -- arity = length args' + -- resCon = tupleDataCon Unboxed (length args) + err = panic "jsResultWrapper: used Id with result type Nothing" + resWrap :: CoreExpr + resWrap = mkCoreUnboxedTuple (zipWith (\w -> w . Var . fromMaybe err) wrappers matched) + return $ + if null tys' + then (Nothing, \_ -> resWrap) + else let innerArity = length tys' + innerTy = mkTupleTy Unboxed tys' + innerCon = tupleDataCon Unboxed innerArity + inner :: CoreExpr -> CoreExpr + inner e = mkWildCase e (unrestricted innerTy) result_ty + [Alt (DataAlt innerCon) + (catMaybes matched) + resWrap + ] + in (Just innerTy, inner) + + -- Base case 1b: primitive types + | isPrimitiveType result_ty + = return (Just result_ty, \e -> e) + -- Base case 1c: boxed tuples + -- fixme: levity args? + | Just (tc, args) <- splitTyConApp_maybe result_ty + , isBoxedTupleTyCon tc = do + let args' = dropRuntimeRepArgs args + innerTy = mkTupleTy Unboxed args' + (inner_res, w) <- jsResultWrapper innerTy + matched <- mapM (newSysLocalDs ManyTy) args' + let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty + [ Alt (DataAlt (tupleDataCon Unboxed (length args'))) + matched + (mkCoreTup (map Var matched)) + -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched) + ] + return (inner_res, inner) + + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey + = return (Nothing, \_ -> Var unitDataConId) + + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do +-- result_id <- newSysLocalDs boolTy + ccall_uniq <- newUnique + let forceBool e = mkJsCall ccall_uniq "$r = !(!$1)" [e] boolTy + return + (Just intPrimTy, \e -> forceBool e) + + -- Base case 4: the any type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` anyTyConKey + = return (Just result_ty, \e -> e) + + -- Newtypes + | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty + = do (maybe_ty, wrapper) <- jsResultWrapper rep_ty + return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) + + -- The type might contain foralls (eg. for dummy type arguments, + -- referring to 'Ptr a' is legal). + | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty + = do (maybe_ty, wrapper) <- jsResultWrapper rest + return (maybe_ty, \e -> Lam tyvar (wrapper e)) + + -- Data types with a single constructor, which has a single arg + -- This includes types like Ptr and ForeignPtr + | Just (_tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty, + dataConSourceArity data_con == 1 + = do let (unwrapped_res_ty : _) = data_con_arg_tys + (maybe_ty, wrapper) <- jsResultWrapper (scaledThing unwrapped_res_ty) + return + (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) + (map Type tycon_arg_tys ++ [wrapper e])) + + | otherwise + = pprPanic "jsResultWrapper" (ppr result_ty) + where + maybe_tc_app = splitTyConApp_maybe result_ty + +-- low-level primitive JavaScript call: +mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr +mkJsCall u tgt args t = mkFCall u ccall args t + where + ccall = CCall $ CCallSpec + (StaticTarget NoSourceText (mkFastString tgt) (Just primUnit) True) + JavaScriptCallConv + PlayRisky diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index db0218d73d..78045aa782 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-} -- -- (c) The University of Glasgow 2002-2006 @@ -15,7 +15,6 @@ module GHC.Iface.Binary ( readBinIface, readBinIfaceHeader, getSymtabName, - getDictFastString, CheckHiWay(..), TraceBinIFace(..), getWithUserData, @@ -24,11 +23,8 @@ module GHC.Iface.Binary ( -- * Internal serialisation functions getSymbolTable, putName, - putDictionary, - putFastString, putSymbolTable, BinSymbolTable(..), - BinDictionary(..) ) where import GHC.Prelude @@ -48,7 +44,6 @@ import GHC.Utils.Outputable import GHC.Types.Name.Cache import GHC.Types.SrcLoc import GHC.Platform -import GHC.Data.FastString import GHC.Settings.Constants import GHC.Utils.Fingerprint @@ -153,31 +148,28 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do -- Names or FastStrings. getWithUserData :: Binary a => NameCache -> BinHandle -> IO a getWithUserData name_cache bh = do + bh <- getTables name_cache bh + get bh + +-- | Setup a BinHandle to read something written using putWithTables +-- +-- Reading names has the side effect of adding them into the given NameCache. +getTables :: NameCache -> BinHandle -> IO BinHandle +getTables name_cache bh = do -- Read the dictionary -- The next word in the file is a pointer to where the dictionary is -- (probably at the end of the file) - dict_p <- Binary.get bh - data_p <- tellBin bh -- Remember where we are now - seekBin bh dict_p - dict <- getDictionary bh - seekBin bh data_p -- Back to where we were before + dict <- Binary.forwardGet bh (getDictionary bh) -- Initialise the user-data field of bh - bh <- do - bh <- return $ setUserData bh $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab_p <- Binary.get bh -- Get the symtab ptr - data_p <- tellBin bh -- Remember where we are now - seekBin bh symtab_p - symtab <- getSymbolTable bh name_cache - seekBin bh data_p -- Back to where we were before - - -- It is only now that we know how to get a Name - return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab) - (getDictFastString dict) - - -- Read the interface file - get bh + let bh_fs = setUserData bh $ newReadState (error "getSymtabName") + (getDictFastString dict) + + symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache) + + -- It is only now that we know how to get a Name + return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab) + (getDictFastString dict) -- | Write an interface file writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO () @@ -211,64 +203,63 @@ writeBinIface profile traceBinIface hi_path mod_iface = do -- This segment should be read using `getWithUserData`. putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO () putWithUserData traceBinIface bh payload = do - -- Remember where the dictionary pointer will go - dict_p_p <- tellBin bh - -- Placeholder for ptr to dictionary - put_ bh dict_p_p - - -- Remember where the symbol table pointer will go - symtab_p_p <- tellBin bh - put_ bh symtab_p_p - -- Make some initial state + (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload) + + case traceBinIface of + QuietBinIFace -> return () + TraceBinIFace printer -> do + printer (text "writeBinIface:" <+> int name_count + <+> text "Names") + printer (text "writeBinIface:" <+> int fs_count + <+> text "dict entries") + +-- | Write name/symbol tables +-- +-- 1. setup the given BinHandle with Name/FastString table handling +-- 2. write the following +-- - FastString table pointer +-- - Name table pointer +-- - payload +-- - Name table +-- - FastString table +-- +-- It returns (number of names, number of FastStrings, payload write result) +-- +putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b) +putWithTables bh put_payload = do + -- initialize state for the name table and the FastString table. symtab_next <- newFastMutInt 0 symtab_map <- newIORef emptyUFM - let bin_symtab = BinSymbolTable { - bin_symtab_next = symtab_next, - bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt 0 - dict_map_ref <- newIORef emptyUFM - let bin_dict = BinDictionary { - bin_dict_next = dict_next_ref, - bin_dict_map = dict_map_ref } - - -- Put the main thing, - bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) - (putName bin_dict bin_symtab) - (putFastString bin_dict) - put_ bh payload - - -- Write the symtab pointer at the front of the file - symtab_p <- tellBin bh -- This is where the symtab will start - putAt bh symtab_p_p symtab_p -- Fill in the placeholder - seekBin bh symtab_p -- Seek back to the end of the file - - -- Write the symbol table itself - symtab_next <- readFastMutInt symtab_next - symtab_map <- readIORef symtab_map - putSymbolTable bh symtab_next symtab_map - case traceBinIface of - QuietBinIFace -> return () - TraceBinIFace printer -> - printer (text "writeBinIface:" <+> int symtab_next - <+> text "Names") - - -- NB. write the dictionary after the symbol table, because - -- writing the symbol table may create more dictionary entries. - - -- Write the dictionary pointer at the front of the file - dict_p <- tellBin bh -- This is where the dictionary will start - putAt bh dict_p_p dict_p -- Fill in the placeholder - seekBin bh dict_p -- Seek back to the end of the file - - -- Write the dictionary itself - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - case traceBinIface of - QuietBinIFace -> return () - TraceBinIFace printer -> - printer (text "writeBinIface:" <+> int dict_next - <+> text "dict entries") + let bin_symtab = BinSymbolTable + { bin_symtab_next = symtab_next + , bin_symtab_map = symtab_map + } + + (bh_fs, bin_dict, put_dict) <- initFSTable bh + + (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do + + -- NB. write the dictionary after the symbol table, because + -- writing the symbol table may create more dictionary entries. + let put_symtab = do + name_count <- readFastMutInt symtab_next + symtab_map <- readIORef symtab_map + putSymbolTable bh_fs name_count symtab_map + pure name_count + + forwardPut bh_fs (const put_symtab) $ do + + -- BinHandle with FastString and Name writing support + let ud_fs = getUserData bh_fs + let ud_name = ud_fs + { ud_put_nonbinding_name = putName bin_dict bin_symtab + , ud_put_binding_name = putName bin_dict bin_symtab + } + let bh_name = setUserData bh ud_name + + put_payload bh_name + + return (name_count, fs_count, r) @@ -287,9 +278,9 @@ binaryInterfaceMagic platform -- putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) +putSymbolTable bh name_count symtab = do + put_ bh name_count + let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab)) -- It's OK to use nonDetEltsUFM here because the elements have -- indices that array uses to create order mapM_ (\n -> serialiseName bh n symtab) names @@ -340,7 +331,7 @@ serialiseName bh name _ = do -- See Note [Symbol table representation of names] -putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () +putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO () putName _dict BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } @@ -392,30 +383,3 @@ data BinSymbolTable = BinSymbolTable { -- indexed by Name } -putFastString :: BinDictionary -> BinHandle -> FastString -> IO () -putFastString dict bh fs = allocateFastString dict fs >>= put_ bh - -allocateFastString :: BinDictionary -> FastString -> IO Word32 -allocateFastString BinDictionary { bin_dict_next = j_r, - bin_dict_map = out_r} f = do - out <- readIORef out_r - let !uniq = getUnique f - case lookupUFM_Directly out uniq of - Just (j, _) -> return (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM_Directly out uniq (j, f) - return (fromIntegral j :: Word32) - -getDictFastString :: Dictionary -> BinHandle -> IO FastString -getDictFastString dict bh = do - j <- get bh - return $! (dict ! fromIntegral (j :: Word32)) - -data BinDictionary = BinDictionary { - bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) - -- indexed by FastString - } - diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs index e492bb726b..6474fbeb8e 100644 --- a/compiler/GHC/Iface/Ext/Binary.hs +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -21,7 +21,6 @@ import GHC.Settings.Utils ( maybeRead ) import GHC.Settings.Config ( cProjectVersion ) import GHC.Prelude import GHC.Utils.Binary -import GHC.Iface.Binary ( getDictFastString ) import GHC.Data.FastMutInt import GHC.Data.FastString ( FastString ) import GHC.Types.Name diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index d53fddb943..0b72f57f56 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -240,8 +240,13 @@ sptCreateStaticBinds opts this_mod binds = do -- @fps@ is a list associating each binding corresponding to a static entry with -- its fingerprint. sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub -sptModuleInitCode _ _ [] = mempty -sptModuleInitCode platform this_mod entries = +sptModuleInitCode platform this_mod entries + -- no CStub if there is no entry + | [] <- entries = mempty + -- no CStub for the JS backend: it deals with it directly during JS code + -- generation + | ArchJavaScript <- platformArch platform = mempty + | otherwise = initializerCStub platform init_fn_nm empty init_fn_body `mappend` finalizerCStub platform fini_fn_nm empty fini_fn_body where diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs new file mode 100644 index 0000000000..fc30d0d915 --- /dev/null +++ b/compiler/GHC/JS/Make.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Make +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Make defines helper functions to ease the creation of JavaScript +-- ASTs as defined in 'GHC.JS.Syntax'. Its purpose is twofold: make the EDSL +-- more ergonomic to program in, and make errors in the EDSL /look/ obvious +-- because the EDSL is untyped. It is primarily concerned with injecting +-- terms into the domain of the EDSL to construct JS programs in Haskell. +-- +-- * Strategy +-- +-- The strategy for this module comes straight from gentzen; where we have +-- two types of helper functions. Functions which inject terms into the +-- EDSL, and combinator functions which operate on terms in the EDSL to +-- construct new terms in the EDSL. Crucially, missing from this module are +-- corresponding /elimination/ or /destructing/ functions which would +-- project information from the EDSL back to Haskell. See +-- 'GHC.StgToJS.UnitUtils' and 'GHC.StgToJS.CoreUtils' for such functions. +-- +-- * /Introduction/ functions +-- +-- We define various primitive helpers which /introduce/ terms in the +-- EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'. Notice +-- that the type of each of these functions have the domain @isSat a +-- => a -> ...@; indicating that they each take something that /can/ +-- be injected into the EDSL domain, and the range 'JExpr' or 'JStat'; +-- indicating the corresponding value in the EDSL domain. Similarly +-- this module exports two typeclasses 'ToExpr' and 'ToSat', 'ToExpr' +-- injects values as a JS expression into the EDSL. 'ToSat' ensures +-- that terms introduced into the EDSL carry identifier information so +-- terms in the EDSL must have meaning. +-- +-- * /Combinator/ functions +-- +-- The rest of the module defines combinators which create terms in +-- the EDSL from terms in the EDSL. Notable examples are '|=' and +-- '||=', '|=' is sugar for 'AssignStat', it is a binding form that +-- declares @foo = bar@ /assuming/ foo has been already declared. +-- '||=' is more sugar on top of '|=', it is also a binding form that +-- declares the LHS of '|=' before calling '|=' to bind a value, bar, +-- to a variable foo. Other common examples are the 'if_' and 'math_' +-- helpers such as 'math_cos'. +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. +-- +-- * Notation +-- +-- In this module we use @==>@ in docstrings to show the translation from +-- the JS EDSL domain to JS code. For example, @foo ||= bar ==> var foo; foo +-- = bar;@ should be read as @foo ||= bar@ is in the EDSL domain and results +-- in the JS code @var foo; foo = bar;@ when compiled. +----------------------------------------------------------------------------- +module GHC.JS.Make + ( -- * Injection Type classes + -- $classes + ToJExpr(..) + , ToStat(..) + -- * Introduction functions + -- $intro_funcs + , var + , jString + , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally + -- * Combinators + -- $combinators + , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) + , (.>.), (.>=.), (.<.), (.<=.) + , (.<<.), (.>>.), (.>>>.) + , (.|.), (.||.), (.&&.) + , if_, if10, if01, ifS, ifBlockS + , jwhenS + , app, appS, returnS + , loop, loopBlockS + , preIncrS, postIncrS + , preDecrS, postDecrS + , off8, off16, off32, off64 + , mask8, mask16 + , signExtend8, signExtend16 + , typeof + , returnStack, assignAllEqual, assignAll, assignAllReverseOrder + , declAssignAll + , nullStat, (.^) + , trace + -- ** Hash combinators + , jhEmpty + , jhSingle + , jhAdd + , jhFromList + -- * Literals + -- $literals + , null_ + , undefined_ + , false_ + , true_ + , zero_ + , one_ + , two_ + , three_ + -- ** Math functions + -- $math + , math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, + math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, + math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround + -- * Statement helpers + , decl + -- * Miscellaneous + -- $misc + , allocData, allocClsA + , dataFieldName, dataFieldNames + ) +where + +import GHC.Prelude hiding ((.|.)) + +import GHC.JS.Syntax + +import Control.Arrow ((***)) + +import Data.Array +import qualified Data.Map as M +import qualified Data.List as List + +import GHC.Utils.Outputable (Outputable (..)) +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Types.Unique.Map + +-------------------------------------------------------------------------------- +-- Type Classes +-------------------------------------------------------------------------------- +-- $classes +-- The 'ToJExpr' class handles injection of of things into the EDSL as a JS +-- expression + +-- | Things that can be marshalled into javascript values. +-- Instantiate for any necessary data structures. +class ToJExpr a where + toJExpr :: a -> JExpr + toJExprFromList :: [a] -> JExpr + toJExprFromList = ValExpr . JList . map toJExpr + +instance ToJExpr a => ToJExpr [a] where + toJExpr = toJExprFromList + +instance ToJExpr JExpr where + toJExpr = id + +instance ToJExpr () where + toJExpr _ = ValExpr $ JList [] + +instance ToJExpr Bool where + toJExpr True = var "true" + toJExpr False = var "false" + +instance ToJExpr JVal where + toJExpr = ValExpr + +instance ToJExpr a => ToJExpr (UniqMap FastString a) where + toJExpr = ValExpr . JHash . mapUniqMap toJExpr + +instance ToJExpr a => ToJExpr (M.Map String a) where + toJExpr = ValExpr . JHash . listToUniqMap . map (mkFastString *** toJExpr) . M.toList + +instance ToJExpr Double where + toJExpr = ValExpr . JDouble . SaneDouble + +instance ToJExpr Int where + toJExpr = ValExpr . JInt . fromIntegral + +instance ToJExpr Integer where + toJExpr = ValExpr . JInt + +instance ToJExpr Char where + toJExpr = ValExpr . JStr . mkFastString . (:[]) + toJExprFromList = ValExpr . JStr . mkFastString +-- where escQuotes = tailDef "" . initDef "" . show + +instance ToJExpr Ident where + toJExpr = ValExpr . JVar + +instance ToJExpr FastString where + toJExpr = ValExpr . JStr + +instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where + toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b] + +instance (ToJExpr a, ToJExpr b, ToJExpr c) => ToJExpr (a,b,c) where + toJExpr (a,b,c) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c] + +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d) => ToJExpr (a,b,c,d) where + toJExpr (a,b,c,d) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d] +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e) => ToJExpr (a,b,c,d,e) where + toJExpr (a,b,c,d,e) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e] +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e, ToJExpr f) => ToJExpr (a,b,c,d,e,f) where + toJExpr (a,b,c,d,e,f) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f] + + +-- | The 'ToStat' class handles injection of of things into the EDSL as a JS +-- statement. This ends up being polymorphic sugar for JS blocks, see helper +-- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data +-- structures. +class ToStat a where + toStat :: a -> JStat + +instance ToStat JStat where + toStat = id + +instance ToStat [JStat] where + toStat = BlockStat + +instance ToStat JExpr where + toStat = expr2stat + +instance ToStat [JExpr] where + toStat = BlockStat . map expr2stat + +-------------------------------------------------------------------------------- +-- Introduction Functions +-------------------------------------------------------------------------------- +-- $intro_functions +-- Introduction functions are functions that map values or terms in the Haskell +-- domain to the JS EDSL domain + +-- | Create a new anonymous function. The result is a 'GHC.JS.Syntax.JExpr' +-- expression. +-- Usage: +-- +-- > jLam $ \x -> jVar x + one_ +-- > jLam $ \f -> (jLam $ \x -> (f `app` (x `app` x))) `app` (jLam $ \x -> (f `app` (x `app` x))) +jLam :: ToSat a => a -> JExpr +jLam f = ValExpr . UnsatVal . IS $ do + (block,is) <- runIdentSupply $ toSat_ f [] + return $ JFunc is block + +-- | Introduce a new variable into scope for the duration +-- of the enclosed expression. The result is a block statement. +-- Usage: +-- +-- @jVar $ \x y -> mconcat [jVar x ||= one_, jVar y ||= two_, jVar x + jVar y]@ +jVar :: ToSat a => a -> JStat +jVar f = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let addDecls (BlockStat ss) = + BlockStat $ map decl is ++ ss + addDecls x = x + return $ addDecls block + +-- | Create a 'for in' statement. +-- Usage: +-- +-- @jForIn {expression} $ \x -> {block involving x}@ +jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat +jForIn e f = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let i = List.head is + return $ decl i `mappend` ForInStat False i e block + +-- | As with "jForIn" but creating a \"for each in\" statement. +jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat +jForEachIn e f = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let i = List.head is + return $ decl i `mappend` ForInStat True i e block + +-- | As with "jForIn" but creating a \"for each in\" statement. +jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat +jTryCatchFinally s f s2 = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let i = List.head is + return $ TryStat s i block s2 + +-- | construct a JS variable reference +var :: FastString -> JExpr +var = ValExpr . JVar . TxtI + +-- | Convert a ShortText to a Javascript String +jString :: FastString -> JExpr +jString = toJExpr + +-- | Create a 'for' statement +jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat +jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b'] + where b' = case toStat b of + BlockStat xs -> BlockStat $ xs ++ [after] + x -> BlockStat [x,after] + +-- | construct a js declaration with the given identifier +decl :: Ident -> JStat +decl i = DeclStat i Nothing + +-- | The empty JS HashMap +jhEmpty :: M.Map k JExpr +jhEmpty = M.empty + +-- | A singleton JS HashMap +jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr +jhSingle k v = jhAdd k v jhEmpty + +-- | insert a key-value pair into a JS HashMap +jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -> M.Map k JExpr +jhAdd k v m = M.insert k (toJExpr v) m + +-- | Construct a JS HashMap from a list of key-value pairs +jhFromList :: [(FastString, JExpr)] -> JVal +jhFromList = JHash . listToUniqMap + +-- | The empty JS statement +nullStat :: JStat +nullStat = BlockStat [] + + +-------------------------------------------------------------------------------- +-- Combinators +-------------------------------------------------------------------------------- +-- $combinators +-- Combinators operate on terms in the JS EDSL domain to create new terms in the +-- EDSL domain. + +-- | JS infix Equality operators +(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr +(.==.) = InfixExpr EqOp +(.===.) = InfixExpr StrictEqOp +(.!=.) = InfixExpr NeqOp +(.!==.) = InfixExpr StrictNeqOp + +infixl 6 .==., .===., .!=., .!==. + +-- | JS infix Ord operators +(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr +(.>.) = InfixExpr GtOp +(.>=.) = InfixExpr GeOp +(.<.) = InfixExpr LtOp +(.<=.) = InfixExpr LeOp + +infixl 7 .>., .>=., .<., .<=. + +-- | JS infix bit operators +(.|.), (.||.), (.&&.) :: JExpr -> JExpr -> JExpr +(.|.) = InfixExpr BOrOp +(.||.) = InfixExpr LOrOp +(.&&.) = InfixExpr LAndOp + +infixl 8 .||., .&&. + +-- | JS infix bit shift operators +(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr +(.<<.) = InfixExpr LeftShiftOp +(.>>.) = InfixExpr RightShiftOp +(.>>>.) = InfixExpr ZRightShiftOp + +infixl 9 .<<., .>>., .>>>. + +-- | Given a 'JExpr', return the its type. +typeof :: JExpr -> JExpr +typeof = UOpExpr TypeofOp + +-- | JS if-expression +-- +-- > if_ e1 e2 e3 ==> e1 ? e2 : e3 +if_ :: JExpr -> JExpr -> JExpr -> JExpr +if_ e1 e2 e3 = IfExpr e1 e2 e3 + +-- | If-expression which returns statements, see related 'ifBlockS' +-- +-- > if e s1 s2 ==> if(e) { s1 } else { s2 } +ifS :: JExpr -> JStat -> JStat -> JStat +ifS e s1 s2 = IfStat e s1 s2 + +-- | A when-statement as syntactic sugar via `ifS` +-- +-- > jwhenS cond block ==> if(cond) { block } else { } +jwhenS :: JExpr -> JStat -> JStat +jwhenS cond block = ifS cond block mempty + +-- | If-expression which returns blocks +-- +-- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 } +ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat +ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2) + +-- | if-expression that returns 1 if condition <=> true, 0 otherwise +-- +-- > if10 e ==> e ? 1 : 0 +if10 :: JExpr -> JExpr +if10 e = IfExpr e one_ zero_ + +-- | if-expression that returns 0 if condition <=> true, 1 otherwise +-- +-- > if01 e ==> e ? 0 : 1 +if01 :: JExpr -> JExpr +if01 e = IfExpr e zero_ one_ + +-- | an expression application, see related 'appS' +-- +-- > app f xs ==> f(xs) +app :: FastString -> [JExpr] -> JExpr +app f xs = ApplExpr (var f) xs + +-- | A statement application, see the expression form 'app' +appS :: FastString -> [JExpr] -> JStat +appS f xs = ApplStat (var f) xs + +-- | Return a 'JExpr' +returnS :: JExpr -> JStat +returnS e = ReturnStat e + +-- | "for" loop with increment at end of body +loop :: JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat +loop initial test body = jVar $ \i -> + mconcat [ i |= initial + , WhileStat False (test i) (body i) + ] + +-- | "for" loop with increment at end of body +loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat +loopBlockS initial test body = jVar $ \i -> + mconcat [ i |= initial + , WhileStat False (test i) (mconcat (body i)) + ] + +-- | Prefix-increment a 'JExpr' +preIncrS :: JExpr -> JStat +preIncrS x = UOpStat PreIncOp x + +-- | Postfix-increment a 'JExpr' +postIncrS :: JExpr -> JStat +postIncrS x = UOpStat PostIncOp x + +-- | Prefix-decrement a 'JExpr' +preDecrS :: JExpr -> JStat +preDecrS x = UOpStat PreDecOp x + +-- | Postfix-decrement a 'JExpr' +postDecrS :: JExpr -> JStat +postDecrS x = UOpStat PostDecOp x + +-- | Byte indexing of o with a 64-bit offset +off64 :: JExpr -> JExpr -> JExpr +off64 o i = Add o (i .<<. three_) + +-- | Byte indexing of o with a 32-bit offset +off32 :: JExpr -> JExpr -> JExpr +off32 o i = Add o (i .<<. two_) + +-- | Byte indexing of o with a 16-bit offset +off16 :: JExpr -> JExpr -> JExpr +off16 o i = Add o (i .<<. one_) + +-- | Byte indexing of o with a 8-bit offset +off8 :: JExpr -> JExpr -> JExpr +off8 o i = Add o i + +-- | a bit mask to retrieve the lower 8-bits +mask8 :: JExpr -> JExpr +mask8 x = BAnd x (Int 0xFF) + +-- | a bit mask to retrieve the lower 16-bits +mask16 :: JExpr -> JExpr +mask16 x = BAnd x (Int 0xFFFF) + +-- | Sign-extend/narrow a 8-bit value +signExtend8 :: JExpr -> JExpr +signExtend8 x = (BAnd x (Int 0x7F )) `Sub` (BAnd x (Int 0x80)) + +-- | Sign-extend/narrow a 16-bit value +signExtend16 :: JExpr -> JExpr +signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000)) + +-- | Select a property 'prop', from and object 'obj' +-- +-- > obj .^ prop ==> obj.prop +(.^) :: JExpr -> FastString -> JExpr +obj .^ prop = SelExpr obj (TxtI prop) +infixl 8 .^ + +-- | Assign a variable to an expression +-- +-- > foo |= expr ==> var foo = expr; +(|=) :: JExpr -> JExpr -> JStat +(|=) = AssignStat + +-- | Declare a variable and then Assign the variable to an expression +-- +-- > foo |= expr ==> var foo; foo = expr; +(||=) :: Ident -> JExpr -> JStat +i ||= ex = DeclStat i (Just ex) + +infixl 2 ||=, |= + +-- | return the expression at idx of obj +-- +-- > obj .! idx ==> obj[idx] +(.!) :: JExpr -> JExpr -> JExpr +(.!) = IdxExpr + +infixl 8 .! + +assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat +assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys) + +assignAll :: [JExpr] -> [JExpr] -> JStat +assignAll xs ys = mconcat (zipWith (|=) xs ys) + +assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat +assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys)) + +declAssignAll :: [Ident] -> [JExpr] -> JStat +declAssignAll xs ys = mconcat (zipWith (||=) xs ys) + +trace :: ToJExpr a => a -> JStat +trace ex = appS "h$log" [toJExpr ex] + + +-------------------------------------------------------------------------------- +-- Literals +-------------------------------------------------------------------------------- +-- $literals +-- Literals in the JS EDSL are constants in the Haskell domain. These are useful +-- helper values and never change + +-- | The JS literal 'null' +null_ :: JExpr +null_ = var "null" + +-- | The JS literal 0 +zero_ :: JExpr +zero_ = Int 0 + +-- | The JS literal 1 +one_ :: JExpr +one_ = Int 1 + +-- | The JS literal 2 +two_ :: JExpr +two_ = Int 2 + +-- | The JS literal 3 +three_ :: JExpr +three_ = Int 3 + +-- | The JS literal 'undefined' +undefined_ :: JExpr +undefined_ = var "undefined" + +-- | The JS literal 'true' +true_ :: JExpr +true_ = var "true" + +-- | The JS literal 'false' +false_ :: JExpr +false_ = var "false" + +returnStack :: JStat +returnStack = ReturnStat (ApplExpr (var "h$rs") []) + + +-------------------------------------------------------------------------------- +-- Math functions +-------------------------------------------------------------------------------- +-- $math +-- Math functions in the EDSL are literals, with the exception of 'math_' which +-- is the sole math introduction function. + +math :: JExpr +math = var "Math" + +math_ :: FastString -> [JExpr] -> JExpr +math_ op args = ApplExpr (math .^ op) args + +math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan, + math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign, + math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround + :: [JExpr] -> JExpr +math_log = math_ "log" +math_sin = math_ "sin" +math_cos = math_ "cos" +math_tan = math_ "tan" +math_exp = math_ "exp" +math_acos = math_ "acos" +math_asin = math_ "asin" +math_atan = math_ "atan" +math_abs = math_ "abs" +math_pow = math_ "pow" +math_sign = math_ "sign" +math_sqrt = math_ "sqrt" +math_asinh = math_ "asinh" +math_acosh = math_ "acosh" +math_atanh = math_ "atanh" +math_sinh = math_ "sinh" +math_cosh = math_ "cosh" +math_tanh = math_ "tanh" +math_expm1 = math_ "expm1" +math_log1p = math_ "log1p" +math_fround = math_ "fround" + +instance Num JExpr where + x + y = InfixExpr AddOp x y + x - y = InfixExpr SubOp x y + x * y = InfixExpr MulOp x y + abs x = math_abs [x] + negate x = UOpExpr NegOp x + signum x = math_sign [x] + fromInteger x = ValExpr (JInt x) + +instance Fractional JExpr where + x / y = InfixExpr DivOp x y + fromRational x = ValExpr (JDouble (realToFrac x)) + + +-------------------------------------------------------------------------------- +-- Miscellaneous +-------------------------------------------------------------------------------- +-- $misc +-- Everything else, + +-- | Cache "dXXX" field names +dataFieldCache :: Array Int FastString +dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) + +nFieldCache :: Int +nFieldCache = 16384 + +dataFieldName :: Int -> FastString +dataFieldName i + | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i) + | otherwise = dataFieldCache ! i + +dataFieldNames :: [FastString] +dataFieldNames = fmap dataFieldName [1..nFieldCache] + + +-- | Cache "h$dXXX" names +dataCache :: Array Int FastString +dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024]) + +allocData :: Int -> JExpr +allocData i = toJExpr (TxtI (dataCache ! i)) + +-- | Cache "h$cXXX" names +clsCache :: Array Int FastString +clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024]) + +allocClsA :: Int -> JExpr +allocClsA i = toJExpr (TxtI (clsCache ! i)) + + +-------------------------------------------------------------------------------- +-- New Identifiers +-------------------------------------------------------------------------------- + +-- | The 'ToSat' class is heavily used in the Introduction function. It ensures +-- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'. +class ToSat a where + toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident]) + +instance ToSat [JStat] where + toSat_ f vs = IS $ return $ (BlockStat f, reverse vs) + +instance ToSat JStat where + toSat_ f vs = IS $ return $ (f, reverse vs) + +instance ToSat JExpr where + toSat_ f vs = IS $ return $ (toStat f, reverse vs) + +instance ToSat [JExpr] where + toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs) + +instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where + toSat_ f vs = IS $ do + x <- takeOneIdent + runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs) + +-- | Convert A JS expression to a JS statement where applicable. This only +-- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary +-- expression; 'UOpExpr'. +expr2stat :: JExpr -> JStat +expr2stat (ApplExpr x y) = (ApplStat x y) +expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z) +expr2stat (UOpExpr o x) = UOpStat o x +expr2stat _ = nullStat + +takeOneIdent :: State [Ident] Ident +takeOneIdent = do + xxs <- get + case xxs of + (x:xs) -> do + put xs + return x + _ -> error "takeOneIdent: empty list" + diff --git a/compiler/GHC/JS/Ppr.hs b/compiler/GHC/JS/Ppr.hs new file mode 100644 index 0000000000..02529a928f --- /dev/null +++ b/compiler/GHC/JS/Ppr.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} + +-- For Outputable instances for JS syntax +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Pretty-printing JavaScript +module GHC.JS.Ppr + ( renderJs + , renderJs' + , renderPrefixJs + , renderPrefixJs' + , JsToDoc(..) + , defaultRenderJs + , RenderJs(..) + , jsToDoc + , pprStringLit + , flattenBlocks + , braceNest + , hangBrace + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Transform + + +import Data.Char (isControl, ord) +import Data.List (sortOn) + +import Numeric(showHex) + +import GHC.Utils.Outputable (Outputable (..), docToSDoc) +import GHC.Utils.Ppr as PP +import GHC.Data.FastString +import GHC.Types.Unique.Map + +instance Outputable JExpr where + ppr = docToSDoc . renderJs + +instance Outputable JVal where + ppr = docToSDoc . renderJs + + +($$$) :: Doc -> Doc -> Doc +x $$$ y = nest 2 $ x $+$ y + +-- | Render a syntax tree as a pretty-printable document +-- (simply showing the resultant doc produces a nice, +-- well formatted String). +renderJs :: (JsToDoc a, JMacro a) => a -> Doc +renderJs = renderJs' defaultRenderJs + +renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc +renderJs' r = jsToDocR r . jsSaturate Nothing + +data RenderJs = RenderJs + { renderJsS :: !(RenderJs -> JStat -> Doc) + , renderJsE :: !(RenderJs -> JExpr -> Doc) + , renderJsV :: !(RenderJs -> JVal -> Doc) + , renderJsI :: !(RenderJs -> Ident -> Doc) + } + +defaultRenderJs :: RenderJs +defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI + +jsToDoc :: JsToDoc a => a -> Doc +jsToDoc = jsToDocR defaultRenderJs + +-- | Render a syntax tree as a pretty-printable document, using a given prefix +-- to all generated names. Use this with distinct prefixes to ensure distinct +-- generated names between independent calls to render(Prefix)Js. +renderPrefixJs :: (JsToDoc a, JMacro a) => FastString -> a -> Doc +renderPrefixJs pfx = renderPrefixJs' defaultRenderJs pfx + +renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> FastString -> a -> Doc +renderPrefixJs' r pfx = jsToDocR r . jsSaturate (Just $ "jmId_" `mappend` pfx) + +braceNest :: Doc -> Doc +braceNest x = char '{' <+> nest 2 x $$ char '}' + +-- | Hang with braces: +-- +-- hdr { +-- body +-- } +hangBrace :: Doc -> Doc -> Doc +hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] + +class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc +instance JsToDoc JStat where jsToDocR r = renderJsS r r +instance JsToDoc JExpr where jsToDocR r = renderJsE r r +instance JsToDoc JVal where jsToDocR r = renderJsV r r +instance JsToDoc Ident where jsToDocR r = renderJsI r r +instance JsToDoc [JExpr] where + jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc [JStat] where + jsToDocR r = vcat . map ((<> semi) . jsToDocR r) + +defRenderJsS :: RenderJs -> JStat -> Doc +defRenderJsS r = \case + IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond)) + (jsToDocR r x) + $$ mbElse + where mbElse | y == BlockStat [] = PP.empty + | otherwise = hangBrace (text "else") (jsToDocR r y) + DeclStat x Nothing -> text "var" <+> jsToDocR r x + DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e + WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b) + WhileStat True p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p) + UnsatBlock e -> jsToDocR r $ pseudoSaturate e + BreakStat l -> maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l + ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l + LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s + where + printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss + printBS x = jsToDocR r x + interSemi [x] = [jsToDocR r x] + interSemi [] = [] + interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs + + ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b) + where txt | each = "for each" + | otherwise = "for" + SwitchStat e l d -> hangBrace (text "switch" <+> parens (jsToDocR r e)) cases + where l' = map (\(c,s) -> (text "case" <+> parens (jsToDocR r c) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)] + cases = vcat l' + ReturnStat e -> text "return" <+> jsToDocR r e + ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es) + TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally + where mbCatch | s1 == BlockStat [] = PP.empty + | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1) + mbFinally | s2 == BlockStat [] = PP.empty + | otherwise = hangBrace (text "finally") (jsToDocR r s2) + AssignStat i x -> case x of + -- special treatment for functions, otherwise there is too much left padding + -- (more than the length of the expression assigned to). E.g. + -- + -- var long_variable_name = (function() + -- { + -- ... + -- }); + -- + ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] + _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x + UOpStat op x + | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x + | isPre op -> ftext (uOpText op) <> optParens r x + | otherwise -> optParens r x <> ftext (uOpText op) + BlockStat xs -> jsToDocR r (flattenBlocks xs) + +flattenBlocks :: [JStat] -> [JStat] +flattenBlocks = \case + BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys + y:ys -> y : flattenBlocks ys + [] -> [] + +optParens :: RenderJs -> JExpr -> Doc +optParens r x = case x of + UOpExpr _ _ -> parens (jsToDocR r x) + _ -> jsToDocR r x + +defRenderJsE :: RenderJs -> JExpr -> Doc +defRenderJsE r = \case + ValExpr x -> jsToDocR r x + SelExpr x y -> jsToDocR r x <> char '.' <> jsToDocR r y + IdxExpr x y -> jsToDocR r x <> brackets (jsToDocR r y) + IfExpr x y z -> parens (jsToDocR r x <+> char '?' <+> jsToDocR r y <+> char ':' <+> jsToDocR r z) + InfixExpr op x y -> parens $ hsep [jsToDocR r x, ftext (opText op), jsToDocR r y] + UOpExpr op x + | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x + | isPre op -> ftext (uOpText op) <> optParens r x + | otherwise -> optParens r x <> ftext (uOpText op) + ApplExpr je xs -> jsToDocR r je <> (parens . hsep . punctuate comma $ map (jsToDocR r) xs) + UnsatExpr e -> jsToDocR r $ pseudoSaturate e + +defRenderJsV :: RenderJs -> JVal -> Doc +defRenderJsV r = \case + JVar i -> jsToDocR r i + JList xs -> brackets . hsep . punctuate comma $ map (jsToDocR r) xs + JDouble (SaneDouble d) + | d < 0 || isNegativeZero d -> parens (double d) + | otherwise -> double d + JInt i + | i < 0 -> parens (integer i) + | otherwise -> integer i + JStr s -> pprStringLit s + JRegEx s -> hcat [char '/',ftext s, char '/'] + JHash m + | isNullUniqMap m -> text "{}" + | otherwise -> braceNest . hsep . punctuate comma . + map (\(x,y) -> squotes (ftext x) <> colon <+> jsToDocR r y) + -- nonDetEltsUniqMap doesn't introduce non-determinism here + -- because we sort the elements lexically + $ sortOn (LexicalFastString . fst) (nonDetEltsUniqMap m) + JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b) + UnsatVal f -> jsToDocR r $ pseudoSaturate f + +defRenderJsI :: RenderJs -> Ident -> Doc +defRenderJsI _ (TxtI t) = ftext t + + +pprStringLit :: FastString -> Doc +pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] + +encodeJson :: FastString -> Doc +encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) + +encodeJsonChar :: Char -> Doc +encodeJsonChar = \case + '/' -> text "\\/" + '\b' -> text "\\b" + '\f' -> text "\\f" + '\n' -> text "\\n" + '\r' -> text "\\r" + '\t' -> text "\\t" + '"' -> text "\\\"" + '\\' -> text "\\\\" + c + | not (isControl c) && ord c <= 127 -> char c + | ord c <= 0xff -> hexxs "\\x" 2 (ord c) + | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) + | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair + in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> + hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) + where hexxs prefix pad cp = + let h = showHex cp "" + in text (prefix ++ replicate (pad - length h) '0' ++ h) + +uOpText :: JUOp -> FastString +uOpText = \case + NotOp -> "!" + BNotOp -> "~" + NegOp -> "-" + PlusOp -> "+" + NewOp -> "new" + TypeofOp -> "typeof" + DeleteOp -> "delete" + YieldOp -> "yield" + VoidOp -> "void" + PreIncOp -> "++" + PostIncOp -> "++" + PreDecOp -> "--" + PostDecOp -> "--" + +opText :: JOp -> FastString +opText = \case + EqOp -> "==" + StrictEqOp -> "===" + NeqOp -> "!=" + StrictNeqOp -> "!==" + GtOp -> ">" + GeOp -> ">=" + LtOp -> "<" + LeOp -> "<=" + AddOp -> "+" + SubOp -> "-" + MulOp -> "*" + DivOp -> "/" + ModOp -> "%" + LeftShiftOp -> "<<" + RightShiftOp -> ">>" + ZRightShiftOp -> ">>>" + BAndOp -> "&" + BOrOp -> "|" + BXorOp -> "^" + LAndOp -> "&&" + LOrOp -> "||" + InstanceofOp -> "instanceof" + InOp -> "in" + + +isPre :: JUOp -> Bool +isPre = \case + PostIncOp -> False + PostDecOp -> False + _ -> True + +isAlphaOp :: JUOp -> Bool +isAlphaOp = \case + NewOp -> True + TypeofOp -> True + DeleteOp -> True + YieldOp -> True + VoidOp -> True + _ -> False diff --git a/compiler/GHC/JS/Syntax.hs b/compiler/GHC/JS/Syntax.hs new file mode 100644 index 0000000000..66067ced9e --- /dev/null +++ b/compiler/GHC/JS/Syntax.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Syntax +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Syntax defines the Syntax for the JS backend in GHC. It comports +-- with the [ECMA-262](https://tc39.es/ecma262/) although not every +-- production rule of the standard is represented. Code in this module is a +-- fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3 +-- Clause) by Gershom Bazerman, heavily modified to accomodate GHC's +-- constraints. +-- +-- +-- * Strategy +-- +-- Nothing fancy in this module, this is a classic deeply embeded AST for +-- JS. We define numerous ADTs and pattern synonyms to make pattern matching +-- and constructing ASTs easier. +-- +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides +-- helper functions that use the deeply embedded DSL defined in this module +-- to provide some of the benefits of a shallow embedding. +----------------------------------------------------------------------------- +module GHC.JS.Syntax + ( -- * Deeply embedded JS datatypes + JStat(..) + , JExpr(..) + , JVal(..) + , JOp(..) + , JUOp(..) + , Ident(..) + , identFS + , JsLabel + -- * pattern synonyms over JS operators + , pattern New + , pattern Not + , pattern Negate + , pattern Add + , pattern Sub + , pattern Mul + , pattern Div + , pattern Mod + , pattern BOr + , pattern BAnd + , pattern BXor + , pattern BNot + , pattern LOr + , pattern LAnd + , pattern Int + , pattern String + , pattern PreInc + , pattern PostInc + , pattern PreDec + , pattern PostDec + -- * Ident supply + , IdentSupply(..) + , newIdentSupply + , pseudoSaturate + -- * Utility + , SaneDouble(..) + ) where + +import GHC.Prelude + +import Control.DeepSeq + +import Data.Function +import Data.Data +import Data.Word +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Types.Unique +import GHC.Types.Unique.Map + +-- | A supply of identifiers, possibly empty +newtype IdentSupply a + = IS {runIdentSupply :: State [Ident] a} + deriving Typeable + +instance NFData (IdentSupply a) where rnf IS{} = () + +inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b +inIdentSupply f x = IS $ f (runIdentSupply x) + +instance Functor IdentSupply where + fmap f x = inIdentSupply (fmap f) x + +newIdentSupply :: Maybe FastString -> [Ident] +newIdentSupply Nothing = newIdentSupply (Just "jmId") +newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) + | x <- [(0::Word64)..] + ] + +-- | Given a Pseudo-saturate a value with garbage @<<unsatId>>@ identifiers. +pseudoSaturate :: IdentSupply a -> a +pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<<unsatId>>") + +instance Eq a => Eq (IdentSupply a) where + (==) = (==) `on` pseudoSaturate +instance Ord a => Ord (IdentSupply a) where + compare = compare `on` pseudoSaturate +instance Show a => Show (IdentSupply a) where + show x = "(" ++ show (pseudoSaturate x) ++ ")" + + +-------------------------------------------------------------------------------- +-- Statements +-------------------------------------------------------------------------------- +-- | JavaScript statements, see the [ECMA262 +-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) +-- for details +data JStat + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If + | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True + | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch + | TryStat JStat Ident JStat JStat -- ^ Try + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat JUOp JExpr -- ^ Unary operators + | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ + | UnsatBlock (IdentSupply JStat) -- ^ /Unsaturated/ blocks see 'pseudoSaturate' + | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JsLabel) -- ^ Break + | ContinueStat (Maybe JsLabel) -- ^ Continue + deriving (Eq, Typeable, Generic) + +-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of +-- course 'LabelStat' +type JsLabel = LexicalFastString + +instance Semigroup JStat where + (<>) = appendJStat + +instance Monoid JStat where + mempty = BlockStat [] + +-- | Append a statement to another statement. 'appendJStat' only returns a +-- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty +-- 'BlockStat'. That is: +-- > (BlockStat [] , y ) = y +-- > (x , BlockStat []) = x +appendJStat :: JStat -> JStat -> JStat +appendJStat mx my = case (mx,my) of + (BlockStat [] , y ) -> y + (x , BlockStat []) -> x + (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys + (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $ xs : ys + (xs , ys ) -> BlockStat [xs,ys] + + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- +-- | JavaScript Expressions +data JExpr + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr JOp JExpr JExpr -- ^ Infix Expressions, see 'JExpr' + -- pattern synonyms + | UOpExpr JUOp JExpr -- ^ Unary Expressions + | IfExpr JExpr JExpr JExpr -- ^ If-expression + | ApplExpr JExpr [JExpr] -- ^ Application + | UnsatExpr (IdentSupply JExpr) -- ^ An /Unsaturated/ expression. + -- See 'pseudoSaturate' + deriving (Eq, Typeable, Generic) + +-- * Useful pattern synonyms to ease programming with the deeply embedded JS +-- AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and +-- for convienience. In addition we include a string wrapper for JS string +-- and Integer literals. + +-- | pattern synonym for a unary operator new +pattern New :: JExpr -> JExpr +pattern New x = UOpExpr NewOp x + +-- | pattern synonym for prefix increment @++x@ +pattern PreInc :: JExpr -> JExpr +pattern PreInc x = UOpExpr PreIncOp x + +-- | pattern synonym for postfix increment @x++@ +pattern PostInc :: JExpr -> JExpr +pattern PostInc x = UOpExpr PostIncOp x + +-- | pattern synonym for prefix decrement @--x@ +pattern PreDec :: JExpr -> JExpr +pattern PreDec x = UOpExpr PreDecOp x + +-- | pattern synonym for postfix decrement @--x@ +pattern PostDec :: JExpr -> JExpr +pattern PostDec x = UOpExpr PostDecOp x + +-- | pattern synonym for logical not @!@ +pattern Not :: JExpr -> JExpr +pattern Not x = UOpExpr NotOp x + +-- | pattern synonym for unary negation @-@ +pattern Negate :: JExpr -> JExpr +pattern Negate x = UOpExpr NegOp x + +-- | pattern synonym for addition @+@ +pattern Add :: JExpr -> JExpr -> JExpr +pattern Add x y = InfixExpr AddOp x y + +-- | pattern synonym for subtraction @-@ +pattern Sub :: JExpr -> JExpr -> JExpr +pattern Sub x y = InfixExpr SubOp x y + +-- | pattern synonym for multiplication @*@ +pattern Mul :: JExpr -> JExpr -> JExpr +pattern Mul x y = InfixExpr MulOp x y + +-- | pattern synonym for division @*@ +pattern Div :: JExpr -> JExpr -> JExpr +pattern Div x y = InfixExpr DivOp x y + +-- | pattern synonym for remainder @%@ +pattern Mod :: JExpr -> JExpr -> JExpr +pattern Mod x y = InfixExpr ModOp x y + +-- | pattern synonym for Bitwise Or @|@ +pattern BOr :: JExpr -> JExpr -> JExpr +pattern BOr x y = InfixExpr BOrOp x y + +-- | pattern synonym for Bitwise And @&@ +pattern BAnd :: JExpr -> JExpr -> JExpr +pattern BAnd x y = InfixExpr BAndOp x y + +-- | pattern synonym for Bitwise XOr @^@ +pattern BXor :: JExpr -> JExpr -> JExpr +pattern BXor x y = InfixExpr BXorOp x y + +-- | pattern synonym for Bitwise Not @~@ +pattern BNot :: JExpr -> JExpr +pattern BNot x = UOpExpr BNotOp x + +-- | pattern synonym for logical Or @||@ +pattern LOr :: JExpr -> JExpr -> JExpr +pattern LOr x y = InfixExpr LOrOp x y + +-- | pattern synonym for logical And @&&@ +pattern LAnd :: JExpr -> JExpr -> JExpr +pattern LAnd x y = InfixExpr LAndOp x y + + +-- | pattern synonym to create integer values +pattern Int :: Integer -> JExpr +pattern Int x = ValExpr (JInt x) + +-- | pattern synonym to create string values +pattern String :: FastString -> JExpr +pattern String x = ValExpr (JStr x) + + +-------------------------------------------------------------------------------- +-- Values +-------------------------------------------------------------------------------- +-- | JavaScript values +data JVal + = JVar Ident -- ^ A variable reference + | JList [JExpr] -- ^ A JavaScript list, or what JS + -- calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex + | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ + | JFunc [Ident] JStat -- ^ A function + | UnsatVal (IdentSupply JVal) -- ^ An /Unsaturated/ value, see 'pseudoSaturate' + deriving (Eq, Typeable, Generic) + +-------------------------------------------------------------------------------- +-- Operators +-------------------------------------------------------------------------------- +-- | JS Binary Operators. We do not deeply embed the comma operator and the +-- assignment operators +data JOp + = EqOp -- ^ Equality: `==` + | StrictEqOp -- ^ Strict Equality: `===` + | NeqOp -- ^ InEquality: `!=` + | StrictNeqOp -- ^ Strict InEquality `!==` + | GtOp -- ^ Greater Than: `>` + | GeOp -- ^ Greater Than or Equal: `>=` + | LtOp -- ^ Less Than: < + | LeOp -- ^ Less Than or Equal: <= + | AddOp -- ^ Addition: + + | SubOp -- ^ Subtraction: - + | MulOp -- ^ Multiplication \* + | DivOp -- ^ Division: \/ + | ModOp -- ^ Remainder: % + | LeftShiftOp -- ^ Left Shift: \<\< + | RightShiftOp -- ^ Right Shift: \>\> + | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> + | BAndOp -- ^ Bitwise And: & + | BOrOp -- ^ Bitwise Or: | + | BXorOp -- ^ Bitwise XOr: ^ + | LAndOp -- ^ Logical And: && + | LOrOp -- ^ Logical Or: || + | InstanceofOp -- ^ @instanceof@ + | InOp -- ^ @in@ + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JOp + +-- | JS Unary Operators +data JUOp + = NotOp -- ^ Logical Not: @!@ + | BNotOp -- ^ Bitwise Not: @~@ + | NegOp -- ^ Negation: @-@ + | PlusOp -- ^ Unary Plus: @+x@ + | NewOp -- ^ new x + | TypeofOp -- ^ typeof x + | DeleteOp -- ^ delete x + | YieldOp -- ^ yield x + | VoidOp -- ^ void x + | PreIncOp -- ^ Prefix Increment: @++x@ + | PostIncOp -- ^ Postfix Increment: @x++@ + | PreDecOp -- ^ Prefix Decrement: @--x@ + | PostDecOp -- ^ Postfix Decrement: @x--@ + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JUOp + +-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' +-- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on +-- Sane-ness +newtype SaneDouble = SaneDouble + { unSaneDouble :: Double + } + deriving (Data, Typeable, Fractional, Num, Generic, NFData) + +instance Eq SaneDouble where + (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y) + +instance Ord SaneDouble where + compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y) + where fromNaN z | isNaN z = Nothing + | otherwise = Just z + +instance Show SaneDouble where + show (SaneDouble x) = show x + + +-------------------------------------------------------------------------------- +-- Identifiers +-------------------------------------------------------------------------------- +-- We use FastString for identifiers in JS backend + +-- | A newtype wrapper around 'FastString' for JS identifiers. +newtype Ident = TxtI { itxt :: FastString } + deriving stock (Show, Eq) + deriving newtype (Uniquable) + +identFS :: Ident -> FastString +identFS = \case + TxtI fs -> fs diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs new file mode 100644 index 0000000000..72b3980537 --- /dev/null +++ b/compiler/GHC/JS/Transform.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} + +module GHC.JS.Transform + ( mapIdent + , mapStatIdent + , mapExprIdent + , identsS + , identsV + , identsE + -- * Saturation + , jsSaturate + -- * Generic traversal (via compos) + , JMacro(..) + , JMGadt(..) + , Compos(..) + , composOp + , composOpM + , composOpM_ + , composOpFold + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax + +import Data.Functor.Identity +import Control.Monad +import Data.Bifunctor + +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Types.Unique.Map + +mapExprIdent :: (Ident -> JExpr) -> JExpr -> JExpr +mapExprIdent f = fst (mapIdent f) + +mapStatIdent :: (Ident -> JExpr) -> JStat -> JStat +mapStatIdent f = snd (mapIdent f) + +-- | Map on every variable ident +mapIdent :: (Ident -> JExpr) -> (JExpr -> JExpr, JStat -> JStat) +mapIdent f = (map_expr, map_stat) + where + map_expr = \case + ValExpr v -> map_val v + SelExpr e i -> SelExpr (map_expr e) i + IdxExpr e1 e2 -> IdxExpr (map_expr e1) (map_expr e2) + InfixExpr o e1 e2 -> InfixExpr o (map_expr e1) (map_expr e2) + UOpExpr o e -> UOpExpr o (map_expr e) + IfExpr e1 e2 e3 -> IfExpr (map_expr e1) (map_expr e2) (map_expr e3) + ApplExpr e es -> ApplExpr (map_expr e) (fmap map_expr es) + UnsatExpr me -> UnsatExpr (fmap map_expr me) + + map_val v = case v of + JVar i -> f i + JList es -> ValExpr $ JList (fmap map_expr es) + JDouble{} -> ValExpr $ v + JInt{} -> ValExpr $ v + JStr{} -> ValExpr $ v + JRegEx{} -> ValExpr $ v + JHash me -> ValExpr $ JHash (fmap map_expr me) + JFunc is s -> ValExpr $ JFunc is (map_stat s) + UnsatVal v2 -> ValExpr $ UnsatVal v2 + + map_stat s = case s of + DeclStat i e -> DeclStat i (fmap map_expr e) + ReturnStat e -> ReturnStat (map_expr e) + IfStat e s1 s2 -> IfStat (map_expr e) (map_stat s1) (map_stat s2) + WhileStat b e s2 -> WhileStat b (map_expr e) (map_stat s2) + ForInStat b i e s2 -> ForInStat b i (map_expr e) (map_stat s2) + SwitchStat e les s2 -> SwitchStat (map_expr e) (fmap (bimap map_expr map_stat) les) (map_stat s2) + TryStat s2 i s3 s4 -> TryStat (map_stat s2) i (map_stat s3) (map_stat s4) + BlockStat ls -> BlockStat (fmap map_stat ls) + ApplStat e es -> ApplStat (map_expr e) (fmap map_expr es) + UOpStat o e -> UOpStat o (map_expr e) + AssignStat e1 e2 -> AssignStat (map_expr e1) (map_expr e2) + UnsatBlock ms -> UnsatBlock (fmap map_stat ms) + LabelStat l s2 -> LabelStat l (map_stat s2) + BreakStat{} -> s + ContinueStat{} -> s + +{-# INLINE identsS #-} +identsS :: JStat -> [Ident] +identsS = \case + DeclStat i e -> [i] ++ maybe [] identsE e + ReturnStat e -> identsE e + IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 + WhileStat _ e s -> identsE e ++ identsS s + ForInStat _ i e s -> [i] ++ identsE e ++ identsS s + SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s + where traverseCase (e,s) = identsE e ++ identsS s + TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3 + BlockStat xs -> concatMap identsS xs + ApplStat e es -> identsE e ++ concatMap identsE es + UOpStat _op e -> identsE e + AssignStat e1 e2 -> identsE e1 ++ identsE e2 + UnsatBlock{} -> error "identsS: UnsatBlock" + LabelStat _l s -> identsS s + BreakStat{} -> [] + ContinueStat{} -> [] + +{-# INLINE identsE #-} +identsE :: JExpr -> [Ident] +identsE = \case + ValExpr v -> identsV v + SelExpr e _i -> identsE e -- do not rename properties + IdxExpr e1 e2 -> identsE e1 ++ identsE e2 + InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2 + UOpExpr _ e -> identsE e + IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3 + ApplExpr e es -> identsE e ++ concatMap identsE es + UnsatExpr{} -> error "identsE: UnsatExpr" + +{-# INLINE identsV #-} +identsV :: JVal -> [Ident] +identsV = \case + JVar i -> [i] + JList xs -> concatMap identsE xs + JDouble{} -> [] + JInt{} -> [] + JStr{} -> [] + JRegEx{} -> [] + JHash m -> concatMap (identsE . snd) (nonDetEltsUniqMap m) + JFunc args s -> args ++ identsS s + UnsatVal{} -> error "identsV: UnsatVal" + + +{-------------------------------------------------------------------- + Compos +--------------------------------------------------------------------} +-- | Compos and ops for generic traversal as defined over +-- the JMacro ADT. + +-- | Utility class to coerce the ADT into a regular structure. + +class JMacro a where + jtoGADT :: a -> JMGadt a + jfromGADT :: JMGadt a -> a + +instance JMacro Ident where + jtoGADT = JMGId + jfromGADT (JMGId x) = x + +instance JMacro JStat where + jtoGADT = JMGStat + jfromGADT (JMGStat x) = x + +instance JMacro JExpr where + jtoGADT = JMGExpr + jfromGADT (JMGExpr x) = x + +instance JMacro JVal where + jtoGADT = JMGVal + jfromGADT (JMGVal x) = x + +-- | Union type to allow regular traversal by compos. +data JMGadt a where + JMGId :: Ident -> JMGadt Ident + JMGStat :: JStat -> JMGadt JStat + JMGExpr :: JExpr -> JMGadt JExpr + JMGVal :: JVal -> JMGadt JVal + +composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b +composOp f = runIdentity . composOpM (Identity . f) + +composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b) +composOpM = compos return ap + +composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m () +composOpM_ = composOpFold (return ()) (>>) + +composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b +composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f) + +newtype C b a = C { unC :: b } + +class Compos t where + compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) + -> (forall a. t a -> m (t a)) -> t c -> m (t c) + +instance Compos JMGadt where + compos = jmcompos + +jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c) +jmcompos ret app f' v = + case v of + JMGId _ -> ret v + JMGStat v' -> ret JMGStat `app` case v' of + DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e + ReturnStat i -> ret ReturnStat `app` f i + IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s' + WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s + ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s + SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d + where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l + BlockStat xs -> ret BlockStat `app` mapM' f xs + ApplStat e xs -> ret ApplStat `app` f e `app` mapM' f xs + TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2 + UOpStat o e -> ret (UOpStat o) `app` f e + AssignStat e e' -> ret AssignStat `app` f e `app` f e' + UnsatBlock _ -> ret v' + ContinueStat l -> ret (ContinueStat l) + BreakStat l -> ret (BreakStat l) + LabelStat l s -> ret (LabelStat l) `app` f s + JMGExpr v' -> ret JMGExpr `app` case v' of + ValExpr e -> ret ValExpr `app` f e + SelExpr e e' -> ret SelExpr `app` f e `app` f e' + IdxExpr e e' -> ret IdxExpr `app` f e `app` f e' + InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e' + UOpExpr o e -> ret (UOpExpr o) `app` f e + IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e'' + ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs + UnsatExpr _ -> ret v' + JMGVal v' -> ret JMGVal `app` case v' of + JVar i -> ret JVar `app` f i + JList xs -> ret JList `app` mapM' f xs + JDouble _ -> ret v' + JInt _ -> ret v' + JStr _ -> ret v' + JRegEx _ -> ret v' + JHash m -> ret JHash `app` m' + -- nonDetEltsUniqMap doesn't introduce nondeterminism here because the + -- elements are treated independently before being re-added to a UniqMap + where (ls, vs) = unzip (nonDetEltsUniqMap m) + m' = ret (listToUniqMap . zip ls) `app` mapM' f vs + JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s + UnsatVal _ -> ret v' + + where + mapM' :: forall a. (a -> m a) -> [a] -> m [a] + mapM' g = foldr (app . app (ret (:)) . g) (ret []) + mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a) + mapMaybeM' g = \case + Nothing -> ret Nothing + Just a -> app (ret Just) (g a) + f :: forall b. JMacro b => b -> m b + f x = ret jfromGADT `app` f' (jtoGADT x) + +{-------------------------------------------------------------------- + Saturation +--------------------------------------------------------------------} + +-- | Given an optional prefix, fills in all free variable names with a supply +-- of names generated by the prefix. +jsSaturate :: (JMacro a) => Maybe FastString -> a -> a +jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) + +jsSaturate_ :: (JMacro a) => a -> IdentSupply a +jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) + where + go :: forall a. JMGadt a -> State [Ident] (JMGadt a) + go v = case v of + JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) + JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) + JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) + _ -> composOpM go v diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index b81b286d54..2bbe6dfc17 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -64,23 +64,27 @@ it is supported by both gcc and clang. Anecdotally nvcc supports -} linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary logger tmpfs dflags unit_env o_files dep_units = do +linkBinary = linkBinary' False + +linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do let platform = ue_platform unit_env unit_state = ue_units unit_env toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags - output_fn = exeFileName platform False (outputFile_ dflags) + arch_os = platformArchOS platform + output_fn = exeFileName arch_os staticLink (outputFile_ dflags) namever = ghcNameVersion dflags ways_ = ways dflags - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. - full_output_fn <- if isAbsolute output_fn then return output_fn else do d <- getCurrentDirectory return $ normalise (d </> output_fn) + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) let pkg_lib_paths = collectLibraryDirs ways_ pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths @@ -267,7 +271,8 @@ linkStaticLib logger dflags unit_env o_files dep_units = do let platform = ue_platform unit_env extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs - output_fn = exeFileName platform True (outputFile_ dflags) + arch_os = platformArchOS platform + output_fn = exeFileName arch_os True (outputFile_ dflags) namever = ghcNameVersion dflags ways_ = ways dflags diff --git a/compiler/GHC/Linker/Static/Utils.hs b/compiler/GHC/Linker/Static/Utils.hs index 6439d197d8..787147caac 100644 --- a/compiler/GHC/Linker/Static/Utils.hs +++ b/compiler/GHC/Linker/Static/Utils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} + module GHC.Linker.Static.Utils where import GHC.Prelude @@ -12,20 +14,18 @@ import System.FilePath -- Use the provided filename (if any), otherwise use "main.exe" (Windows), -- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the -- extension if it is missing. -exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath -exeFileName platform staticLink output_fn - | Just s <- output_fn = - case platformOS platform of - OSMinGW32 -> s <?.> "exe" - _ -> if staticLink - then s <?.> "a" - else s - | otherwise = - if platformOS platform == OSMinGW32 - then "main.exe" - else if staticLink - then "liba.a" - else "a.out" +exeFileName :: ArchOS -> Bool -> Maybe FilePath -> FilePath +exeFileName (ArchOS arch os) staticLink output_fn + | Just s <- output_fn = if + | OSMinGW32 <- os -> s <?.> "exe" + | ArchJavaScript <- arch -> s <?.> "jsexe" + | staticLink -> s <?.> "a" + | otherwise -> s + | otherwise = if + | OSMinGW32 <- os -> "main.exe" + | ArchJavaScript <- arch -> "main.jsexe" + | staticLink -> "liba.a" + | otherwise -> "a.out" where s <?.> ext | null (takeExtension s) = s <.> ext | otherwise = s diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 4956920fb1..a94eebfc83 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -61,7 +61,7 @@ module GHC.Stg.Syntax ( -- ppr StgPprOpts(..), panicStgPprOpts, shortStgPprOpts, - pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, + pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, pprStgAlt, pprGenStgTopBinding, pprStgTopBinding, pprGenStgTopBindings, pprStgTopBindings ) where diff --git a/compiler/GHC/StgToJS.hs b/compiler/GHC/StgToJS.hs new file mode 100644 index 0000000000..8a0b1e59fe --- /dev/null +++ b/compiler/GHC/StgToJS.hs @@ -0,0 +1,216 @@ +module GHC.StgToJS + ( stgToJS + ) +where + +import GHC.StgToJS.CodeGen + + +-- Note [StgToJS design] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- +-- StgToJS ("JS backend") is adapted from GHCJS [GHCJS2013]. +-- +-- Haskell to JavaScript +-- ~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS converts STG into a JavaScript AST (in GHC.JS) that has been adapted +-- from JMacro [JMacro]. +-- +-- Tail calls: translated code is tail call optimized through a trampoline, +-- since JavaScript implementations don't always support tail calls. +-- +-- JavaScript ASTs are then optimized. A dataflow analysis is performed and then +-- dead code and redundant assignments are removed. +-- +-- Primitives +-- ~~~~~~~~~~ +-- Haskell primitives have to be represented as JavaScript values. This is done +-- as follows: +-- +-- - Int#/Int32# -> number in Int32 range +-- - Int16# -> number in Int16 range +-- - Int8# -> number in Int8 range +-- - Word#/Word32# -> number in Word32 range +-- - Word16# -> number in Word16 range +-- - Word8# -> number in Word8 range +-- +-- - Float#/Double# -> both represented as Javascript Double (no Float!) +-- +-- - Int64# -> represented with two fields: +-- high -> number in Int32 range +-- low -> number in Word32 range +-- - Word64# -> represented with two fields: high, low +-- high -> number in Word32 range +-- low -> number in Word32 range +-- +-- - Addr# -> represented with two fields: array (used as a namespace) and index +-- - StablePtr# -> similar to Addr# with array fixed to h$stablePtrBuf +-- +-- - JSVal# -> any Javascript object (used to pass JS objects via FFI) +-- +-- - TVar#, MVar#, etc. are represented with JS objects +-- +-- Foreign JavaScript imports +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS supports inline JavaScript code. Example: +-- +-- > foreign import javascript unsafe +-- > "((x,y) => x + y)" +-- > plus :: Int -> Int -> Int +-- +-- Currently the JS backend only supports functions as JS imports. +-- +-- In comparison, GHCJS supports JavaScript snippets with $1, $2... variables +-- as placeholders for the arguments. It requires a JavaScript parser that the +-- JS backend lacks. In GHCJS, the parser is inherited from JMacro and supports +-- local variable declarations, loops, etc. Local variables are converted to +-- hygienic names to avoid capture. +-- +-- Primitives that are represented as multiple values (Int64#, Word64#, Addr#) +-- are passed to FFI functions with multiple arguments. +-- +-- Interruptible convention: FFI imports with the "interruptible" calling +-- convention are passed an extra argument (usually named "$c") that is a +-- continuation function. The FFI function must call this function to return to +-- Haskell code. +-- +-- Unboxed tuples: returning an unboxed tuple can be done with the predefined +-- macros RETURN_UBX_TUPn where n is the size of the tuples. Internally it uses +-- predefined "h$retN" global variables to pass additional values; the first +-- element of the tuple is returned normally. +-- +-- Memory management +-- ~~~~~~~~~~~~~~~~~ +-- Heap objects are represented as JavaScript values. +-- +-- Most heap objects are represented generically as JavaScript "objects" (hash +-- maps). However, some Haskell heap objects can use use a more memory efficient +-- JavaScript representation: number, string... An example of a consequence of +-- this is that both Int# and Int are represented the same as a JavaScript +-- number. JavaScript introspection (e.g. typeof) is used to differentiate +-- heap object representations when necessary. +-- +-- Generic representation: objects on the heap ("closures") are represented as +-- JavaScript objects with the following fields: +-- +-- { f -- (function) entry function + info table +-- , d1 -- two fields of payload +-- , d2 +-- , m -- GC mark +-- , cc -- optional cost-center +-- } +-- +-- Payload: payload only consists of two fields (d1, d2). When more than two +-- fields of payload are required, the second field is itself an object. +-- payload [] ==> { d1 = null, d2 = null } +-- payload [a] ==> { d1 = a , d2 = null } +-- payload [a,b] ==> { d1 = a , d2 = b } +-- payload [a,b,c] ==> { d1 = a , d2 = { d1 = b, d2 = c} } +-- payload [a,b,c...] ==> { d1 = a , d2 = { d1 = b, d2 = c, ...} } +-- +-- Entry function/ info tables: JavaScript functions are JavaScript objects. If +-- "f" is a function, we can: +-- - call it, e.g. "f(arg0,arg1...)" +-- - get/set its fields, e.g. "f.xyz = abc" +-- This is used to implement the equivalent of tables-next-to-code in +-- JavaScript: every heap object has an entry function "f" that also contains +-- some metadata (info table) about the Haskell object: +-- { t -- object type +-- , size -- number of fields in the payload (-1 if variable layout) +-- , i -- (array) fields layout (empty if variable layout) +-- , n -- (string) object name for easier dubugging +-- , a -- constructor tag / fun arity +-- , r -- ?? +-- , s -- static references? +-- , m -- GC mark? +-- } +-- +-- Payloads for each kind of heap object: +-- +-- THUNK = +-- { f = returns the object reduced to WHNF +-- , m = ? +-- , d1 = ? +-- , d2 = ? +-- } +-- +-- FUN = +-- { f = function itself +-- , m = ? +-- , d1 = free variable 1 +-- , d2 = free variable 2 +-- } +-- +-- There are two different kinds of partial application: +-- - pap_r : pre-generated PAP that contains r registers +-- - pap_gen : generic PAP, contains any number of registers +-- +-- PAP = +-- { f = ? +-- , m = ? +-- , d1 = function +-- , d2 = +-- { d1 & 0xff = number of args (PAP arity) +-- , d1 >> 8 = number of registers (r for h$pap_r) +-- , d2, d3... = args (r) +-- } +-- } +-- +-- CON = +-- { f = entry function of the datacon worker +-- , m = 0 +-- , d1 = first arg +-- , d2 = arity = 2: second arg +-- arity > 2: { d1, d2, ...} object with remaining args (starts with "d1 = x2"!) +-- } +-- +-- BLACKHOLE = +-- { f = h$blackhole +-- , m = ? +-- , d1 = owning TSO +-- , d2 = waiters array +-- } +-- +-- StackFrame closures are *not* represented as JS objects. Instead they are +-- "unpacked" in the stack, i.e. a stack frame occupies a few slots in the JS +-- array representing the stack ("h$stack"). +-- +-- When a shared thunk is entered, it is overriden with a black hole ("eager +-- blackholing") and an update frame is pushed on the stack. +-- +-- Stack: the Haskell stack is implemented with a dynamically growing JavaScript +-- array ("h$stack"). +-- TODO: does it shrink sometimes? +-- TODO: what are the elements of the stack? one JS object per stack frame? +-- +-- +-- Interaction with JavaScript's garbage collector +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Using JS objects to represent Haskell heap objects means that JS's GC does +-- most of the memory management work. +-- +-- However, GHC extends Haskell with features that rely on GC layer violation +-- (weak references, finalizers, etc.). To support these features, a heap scan +-- is can be performed (using TSOs, StablePtr, etc. as roots) to mark reachable +-- objects. Scanning the heap is an expensive operation, but fortunately it +-- doesn't need to happen too often and it can be disabled. +-- +-- TODO: importance of eager blackholing +-- +-- Concurrency +-- ~~~~~~~~~~~ +-- The scheduler is implemented in JS and runs in a single JavaScript thread +-- (similarly to the C RTS not using `-threaded`). +-- +-- The scheduler relies on callbacks/continuations to interact with other JS +-- codes (user interface, etc.). In particular, safe foreign import can use "$c" +-- as a continuation function to return to Haskell code. +-- +-- TODO: is this still true since 2013 or are we using more recent JS features now? +-- TODO: synchronous threads +-- +-- +-- REFERENCES +-- * [GHCJS2013] "Demo Proposal: GHCJS, Concurrent Haskell in the Browser", Luite Stegeman, +-- 2013 (https://www.haskell.org/haskell-symposium/2013/ghcjs.pdf) +-- * [JMacro] https://hackage.haskell.org/package/jmacro diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs new file mode 100644 index 0000000000..6d40f8a7ac --- /dev/null +++ b/compiler/GHC/StgToJS/Apply.hs @@ -0,0 +1,1152 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Apply +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- Module that deals with expression application in JavaScript. In some cases we +-- rely on pre-generated functions that are bundled with the RTS (see rtsApply). +----------------------------------------------------------------------------- + +module GHC.StgToJS.Apply + ( genApp + , rtsApply + ) +where + +import GHC.Prelude hiding ((.|.)) + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure +import GHC.StgToJS.DataCon +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Monad +import GHC.StgToJS.Types +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils +import GHC.StgToJS.Rts.Types +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Types.Literal +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.CostCentre + +import GHC.Stg.Syntax + +import GHC.Builtin.Names + +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Encoding +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Outputable (vcat, ppr) +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import Data.Monoid +import Data.Array + +-- | Pre-generated functions for fast Apply. +-- These are bundled with the RTS. +rtsApply :: StgToJSConfig -> JStat +rtsApply cfg = BlockStat $ + map (specApply cfg) applySpec + ++ map (pap cfg) specPap + ++ [ mkApplyArr + , genericStackApply cfg + , genericFastApply cfg + , zeroApply cfg + , updates cfg + , papGen cfg + , moveRegs2 + , selectors cfg + ] + + +-- | Generate an application of some args to an Id. +-- +-- The case where args is null is common as it's used to generate the evaluation +-- code for an Id. +genApp + :: HasDebugCallStack + => ExprCtx + -> Id + -> [StgArg] + -> G (JStat, ExprResult) +genApp ctx i args + + -- Case: unpackCStringAppend# "some string"# str + -- + -- Generates h$appendToHsStringA(str, "some string"), which has a faster + -- decoding loop. + | [StgLitArg (LitString bs), x] <- args + , [top] <- concatMap typex_expr (ctxTarget ctx) + , getUnique i == unpackCStringAppendIdKey + , d <- utf8DecodeByteString bs + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsStringA" ([toJExpr d, toJExpr a] ++ profArg) + , ExprInline Nothing + ) + + -- let-no-escape + | Just n <- ctxLneBindingStackSize ctx i + = do + as' <- concatMapM genArg args + ei <- varForEntryId i + let ra = mconcat . reverse $ + zipWith (\r a -> toJExpr r |= a) [R1 ..] as' + p <- pushLneFrame n ctx + a <- adjSp 1 -- for the header (which will only be written when the thread is suspended) + return (ra <> p <> a <> returnS ei, ExprCont) + + -- proxy# + | [] <- args + , getUnique i == proxyHashKey + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return (top |= null_, ExprInline Nothing) + + -- unboxed tuple or strict type: return fields individually + | [] <- args + , isUnboxedTupleType (idType i) || isStrictType (idType i) + = do + a <- storeIdFields i (ctxTarget ctx) + return (a, ExprInline Nothing) + + -- Handle alternative heap object representation: in some cases, a heap + -- object is not represented as a JS object but directly as a number or a + -- string. I.e. only the payload is stored because the box isn't useful. + -- It happens for "Int Int#" for example: no need to box the Int# in JS. + -- + -- We must check that: + -- - the object is subject to the optimization (cf isUnboxable predicate) + -- - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we + -- need to evaluate it properly first. + -- + -- In which case we generate a dynamic check (using isObject) that either: + -- - returns the payload of the heap object, if it uses the generic heap + -- object representation + -- - returns the object directly, otherwise + | [] <- args + , [vt] <- idVt i + , isUnboxable vt + , ctxIsEvaluated ctx i + = do + let c = head (concatMap typex_expr $ ctxTarget ctx) + is <- varsForId i + case is of + [i'] -> + return ( c |= if_ (isObject i') (closureField1 i') i' + , ExprInline Nothing + ) + _ -> panic "genApp: invalid size" + + -- case of Id without args and known to be already evaluated: return fields + -- individually + | [] <- args + , ctxIsEvaluated ctx i || isStrictType (idType i) + = do + a <- storeIdFields i (ctxTarget ctx) + -- optional runtime assert for detecting unexpected thunks (unevaluated) + settings <- getSettings + let ww = case concatMap typex_expr (ctxTarget ctx) of + [t] | csAssertRts settings -> + ifS (isObject t .&&. isThunk t) + (appS "throw" [String "unexpected thunk"]) -- yuck + mempty + _ -> mempty + return (a `mappend` ww, ExprInline Nothing) + + + -- Case: "newtype" datacon wrapper + -- + -- If the wrapped argument is known to be already evaluated, then we don't + -- need to enter it. + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + = do + as <- concatMapM genArg args + case as of + [ai] -> do + let t = head (concatMap typex_expr (ctxTarget ctx)) + a' = case args of + [StgVarArg a'] -> a' + _ -> panic "genApp: unexpected arg" + if isStrictId a' || ctxIsEvaluated ctx a' + then return (t |= ai, ExprInline Nothing) + else return (returnS (app "h$e" [ai]), ExprCont) + _ -> panic "genApp: invalid size" + + -- no args and Id can't be a function: just enter it + | [] <- args + , idFunRepArity i == 0 + , not (might_be_a_function (idType i)) + = do + enter_id <- genIdArg i >>= + \case + [x] -> return x + xs -> pprPanic "genApp: unexpected multi-var argument" + (vcat [ppr (length xs), ppr i]) + return (returnS (app "h$e" [enter_id]), ExprCont) + + -- fully saturated global function: + -- - deals with arguments + -- - jumps into the function + | n <- length args + , n /= 0 + , idFunRepArity i == n + , not (isLocalId i) + , isStrictId i + = do + as' <- concatMapM genArg args + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToII i as' is + return (jmp, ExprCont) + + -- oversaturated function: + -- - push continuation with extra args + -- - deals with arguments + -- - jumps into the function + | idFunRepArity i < length args + , isStrictId i + , idFunRepArity i > 0 + = do + let (reg,over) = splitAt (idFunRepArity i) args + reg' <- concatMapM genArg reg + pc <- pushCont over + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToII i reg' is + return (pc <> jmp, ExprCont) + + -- generic apply: + -- - try to find a pre-generated apply function that matches + -- - use it if any + -- - otherwise use generic apply function h$ap_gen_fast + | otherwise + = do + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToFast args is + return (jmp, ExprCont) + +-- avoid one indirection for global ids +-- fixme in many cases we can also jump directly to the entry for local? +jumpToII :: Id -> [JExpr] -> JStat -> G JStat +jumpToII i vars load_app_in_r1 + | isLocalId i = do + ii <- varForId i + return $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , returnS (closureEntry ii) + ] + | otherwise = do + ei <- varForEntryId i + return $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , returnS ei + ] + +-- | Try to use a specialized pre-generated application function. +-- If there is none, use h$ap_gen_fast instead +jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat +jumpToFast args load_app_in_r1 = do + -- get JS expressions for every argument + -- Arguments may have more than one expression (e.g. Word64#) + vars <- concatMapM genArg args + -- try to find a specialized apply function + let spec = mkApplySpec RegsConv args vars + ap_fun <- selectApply spec + pure $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , case ap_fun of + -- specialized apply: no tag + Right fun -> returnS (ApplExpr fun []) + -- generic apply: pass a tag indicating number of args/slots + Left fun -> returnS (ApplExpr fun [specTagExpr spec]) + ] + +-- | Calling convention for an apply function +data ApplyConv + = RegsConv -- ^ Fast calling convention: use registers + | StackConv -- ^ Slow calling convention: use the stack + deriving (Show,Eq,Ord) + +-- | Name of the generic apply function +genericApplyName :: ApplyConv -> FastString +genericApplyName = \case + RegsConv -> "h$ap_gen_fast" + StackConv -> "h$ap_gen" + +-- | Expr of the generic apply function +genericApplyExpr :: ApplyConv -> JExpr +genericApplyExpr conv = var (genericApplyName conv) + + +-- | Return the name of the specialized apply function for the given number of +-- args, number of arg variables, and calling convention. +specApplyName :: ApplySpec -> FastString +specApplyName = \case + -- specialize a few for compiler performance (avoid building FastStrings over + -- and over for common cases) + ApplySpec RegsConv 0 0 -> "h$ap_0_0_fast" + ApplySpec StackConv 0 0 -> "h$ap_0_0" + ApplySpec RegsConv 1 0 -> "h$ap_1_0_fast" + ApplySpec StackConv 1 0 -> "h$ap_1_0" + ApplySpec RegsConv 1 1 -> "h$ap_1_1_fast" + ApplySpec StackConv 1 1 -> "h$ap_1_1" + ApplySpec RegsConv 1 2 -> "h$ap_1_2_fast" + ApplySpec StackConv 1 2 -> "h$ap_1_2" + ApplySpec RegsConv 2 1 -> "h$ap_2_1_fast" + ApplySpec StackConv 2 1 -> "h$ap_2_1" + ApplySpec RegsConv 2 2 -> "h$ap_2_2_fast" + ApplySpec StackConv 2 2 -> "h$ap_2_2" + ApplySpec RegsConv 2 3 -> "h$ap_2_3_fast" + ApplySpec StackConv 2 3 -> "h$ap_2_3" + ApplySpec conv nargs nvars -> mkFastString $ mconcat + [ "h$ap_", show nargs + , "_" , show nvars + , case conv of + RegsConv -> "_fast" + StackConv -> "" + ] + +-- | Return the expression of the specialized apply function for the given +-- number of args, number of arg variables, and calling convention. +-- +-- Warning: the returned function may not be generated! Use specApplyExprMaybe +-- if you want to ensure that it exists. +specApplyExpr :: ApplySpec -> JExpr +specApplyExpr spec = var (specApplyName spec) + +-- | Return the expression of the specialized apply function for the given +-- number of args, number of arg variables, and calling convention. +-- Return Nothing if it isn't generated. +specApplyExprMaybe :: ApplySpec -> Maybe JExpr +specApplyExprMaybe spec = + if spec `elem` applySpec + then Just (specApplyExpr spec) + else Nothing + +-- | Make an ApplySpec from a calling convention, a list of Haskell args, and a +-- list of corresponding JS variables +mkApplySpec :: ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec +mkApplySpec conv args vars = ApplySpec + { specConv = conv + , specArgs = length args + , specVars = length vars + } + +-- | Find a specialized application function if there is one +selectApply + :: ApplySpec + -> G (Either JExpr JExpr) -- ^ the function to call (Left for generic, Right for specialized) +selectApply spec = + case specApplyExprMaybe spec of + Just e -> return (Right e) + Nothing -> return (Left (genericApplyExpr (specConv spec))) + + +-- | Apply specification +data ApplySpec = ApplySpec + { specConv :: !ApplyConv -- ^ Calling convention + , specArgs :: !Int -- ^ number of Haskell arguments + , specVars :: !Int -- ^ number of JavaScript variables for the arguments + } + deriving (Show,Eq,Ord) + +-- | List of specialized apply function templates +applySpec :: [ApplySpec] +applySpec = [ ApplySpec conv nargs nvars + | conv <- [RegsConv, StackConv] + , nargs <- [0..4] + , nvars <- [max 0 (nargs-1)..(nargs*2)] + ] + +-- | Generate a tag for the given ApplySpec +-- +-- Warning: tag doesn't take into account the calling convention +specTag :: ApplySpec -> Int +specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. (specArgs spec) + +-- | Generate a tag expression for the given ApplySpec +specTagExpr :: ApplySpec -> JExpr +specTagExpr = toJExpr . specTag + +-- | Build arrays to quickly lookup apply functions +-- +-- h$apply[r << 8 | n] = function application for r regs, n args +-- h$paps[r] = partial application for r registers (number of args is in the object) +mkApplyArr :: JStat +mkApplyArr = mconcat + [ TxtI "h$apply" ||= toJExpr (JList []) + , TxtI "h$paps" ||= toJExpr (JList []) + , ApplStat (var "h$initStatic" .^ "push") + [ ValExpr $ JFunc [] $ jVar \i -> mconcat + [ i |= zero_ + , WhileStat False (i .<. Int 65536) $ mconcat + [ var "h$apply" .! i |= var "h$ap_gen" + , preIncrS i + ] + , i |= zero_ + , WhileStat False (i .<. Int 128) $ mconcat + [ var "h$paps" .! i |= var "h$pap_gen" + , preIncrS i + ] + , mconcat (map assignSpec applySpec) + , mconcat (map assignPap specPap) + ] + ] + ] + where + assignSpec :: ApplySpec -> JStat + assignSpec spec = case specConv spec of + -- both fast/slow (regs/stack) specialized apply functions have the same + -- tags. We store the stack ones in the array because they are used as + -- continuation stack frames. + StackConv -> var "h$apply" .! specTagExpr spec |= specApplyExpr spec + RegsConv -> mempty + + assignPap :: Int -> JStat + assignPap p = var "h$paps" .! toJExpr p |= + (var (mkFastString $ ("h$pap_" ++ show p))) + +-- | Push a continuation on the stack +-- +-- First push the given args, then push an apply function (specialized if +-- possible, otherwise the generic h$ap_gen function). +pushCont :: HasDebugCallStack + => [StgArg] + -> G JStat +pushCont args = do + vars <- concatMapM genArg args + let spec = mkApplySpec StackConv args vars + selectApply spec >>= \case + Right app -> push $ reverse $ app : vars + Left app -> push $ reverse $ app : specTagExpr spec : vars + +-- | Generic stack apply function (h$ap_gen) that can do everything, but less +-- efficiently than other more specialized functions. +-- +-- Stack layout: +-- -3: ... +-- -2: args +-- -1: tag (number of arg slots << 8 | number of args) +-- +-- Regs: +-- R1 = applied closure +-- +genericStackApply :: StgToJSConfig -> JStat +genericStackApply cfg = closure info body + where + -- h$ap_gen body + body = jVar \cf -> + [ traceRts cfg (jString "h$ap_gen") + , cf |= closureEntry r1 + -- switch on closure type + , SwitchStat (entryClosureType cf) + [ (toJExpr Thunk , thunk_case cfg cf) + , (toJExpr Fun , fun_case cf (funArity' cf)) + , (toJExpr Pap , fun_case cf (papArity r1)) + , (toJExpr Blackhole, blackhole_case cfg) + ] + (default_case cf) + ] + + -- info table for h$ap_gen + info = ClosureInfo + { ciVar = TxtI "h$ap_gen" + , ciRegs = CIRegs 0 [PtrV] -- closure to apply to + , ciName = "h$ap_gen" + , ciLayout = CILayoutVariable + , ciType = CIStackFrame + , ciStatic = mempty + } + + default_case cf = appS "throw" [jString "h$ap_gen: unexpected closure type " + + (entryClosureType cf)] + + thunk_case cfg cf = mconcat + [ profStat cfg pushRestoreCCS + , returnS cf + ] + + blackhole_case cfg = mconcat + [ push' cfg [r1, var "h$return"] + , returnS (app "h$blockOnBlackhole" [r1]) + ] + + fun_case c arity = jVar \tag needed_args needed_regs given_args given_regs newTag newAp p dat -> + [ tag |= stack .! (sp - 1) -- tag on the stack + , given_args |= mask8 tag -- indicates the number of passed args + , given_regs |= tag .>>. 8 -- and the number of passed values for registers + , needed_args |= mask8 arity + , needed_regs |= arity .>>. 8 + , traceRts cfg (jString "h$ap_gen: args: " + given_args + + jString " regs: " + given_regs) + , ifBlockS (given_args .===. needed_args) + -------------------------------- + -- exactly saturated application + -------------------------------- + [ traceRts cfg (jString "h$ap_gen: exact") + -- Set registers to register values on the stack + , loop 0 (.<. given_regs) \i -> mconcat + [ appS "h$setReg" [i+2, stack .! (sp-2-i)] + , postIncrS i + ] + -- drop register values from the stack + , sp |= sp - given_regs - 2 + -- enter closure in R1 + , returnS c + ] + [ ifBlockS (given_args .>. needed_args) + ---------------------------- + -- oversaturated application + ---------------------------- + [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args + + jString " regs: " + needed_regs) + -- load needed register values + , loop 0 (.<. needed_regs) \i -> mconcat + [ traceRts cfg (jString "h$ap_gen: loading register: " + i) + , appS "h$setReg" [i+2, stack .! (sp-2-i)] + , postIncrS i + ] + -- compute new tag with consumed register values and args removed + , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args) + -- find application function for the remaining regs/args + , newAp |= var "h$apply" .! newTag + , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n")) + + -- Drop used registers from the stack. + -- Test if the application function needs a tag and push it. + , ifS (newAp .===. var "h$ap_gen") + ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp - needed_regs - 1) + + -- Push generic application function as continuation + , stack .! sp |= newAp + + -- Push "current thread CCS restore" function as continuation + , profStat cfg pushRestoreCCS + + -- enter closure in R1 + , returnS c + ] + + ----------------------------- + -- undersaturated application + ----------------------------- + [ traceRts cfg (jString "h$ap_gen: undersat") + -- find PAP entry function corresponding to given_regs count + , p |= var "h$paps" .! given_regs + + -- build PAP payload: R1 + tag + given register values + , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args) + , dat |= toJExpr [r1, newTag] + , loop 0 (.<. given_regs) \i -> mconcat + [ (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)] + , postIncrS i + ] + + -- remove register values from the stack. + , sp |= sp - given_regs - 2 + + -- alloc PAP closure, store reference to it in R1. + , r1 |= initClosure cfg p dat jCurrentCCS + + -- return to the continuation on the stack + , returnStack + ] + ] + ] + +-- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less +-- efficiently than other more specialized functions. +-- +-- Signature tag in argument. Tag: (regs << 8 | arity) +-- +-- Regs: +-- R1 = closure to apply to +-- +genericFastApply :: StgToJSConfig -> JStat +genericFastApply s = + TxtI "h$ap_gen_fast" ||= jLam \tag -> jVar \c -> + [traceRts s (jString "h$ap_gen_fast: " + tag) + , c |= closureEntry r1 + , SwitchStat (entryClosureType c) + [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk") + <> pushStackApply c tag + <> returnS c) + , (toJExpr Fun, jVar \farity -> + [ farity |= funArity' c + , traceRts s (jString "h$ap_gen_fast: fun " + farity) + , funCase c tag farity + ]) + , (toJExpr Pap, jVar \parity -> + [ parity |= papArity r1 + , traceRts s (jString "h$ap_gen_fast: pap " + parity) + , funCase c tag parity + ]) + , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con") + <> jwhenS (tag .!=. 0) + (appS "throw" [jString "h$ap_gen_fast: invalid apply"]) + <> returnS c) + , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole") + <> pushStackApply c tag + <> push' s [r1, var "h$return"] + <> returnS (app "h$blockOnBlackhole" [r1])) + ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + entryClosureType c] + ] + + where + -- thunk: push everything to stack frame, enter thunk first + pushStackApply :: JExpr -> JExpr -> JStat + pushStackApply _c tag = + jVar \ap -> + [ pushAllRegs tag + , ap |= var "h$apply" .! tag + , ifS (ap .===. var "h$ap_gen") + ((sp |= sp + 2) <> (stack .! (sp-1) |= tag)) + (sp |= sp + 1) + , stack .! sp |= ap + , profStat s pushRestoreCCS + ] + + funCase :: JExpr -> JExpr -> JExpr -> JStat + funCase c tag arity = + jVar \ar myAr myRegs regsStart newTag newAp dat p -> + [ ar |= mask8 arity + , myAr |= mask8 tag + , myRegs |= tag .>>. 8 + , traceRts s (jString "h$ap_gen_fast: args: " + myAr + + jString " regs: " + myRegs) + , ifS (myAr .===. ar) + -- call the function directly + (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c) + (ifBlockS (myAr .>. ar) + -- push stack frame with remaining args, then call fun + [ traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , regsStart |= (arity .>>. 8) + 1 + , sp |= sp + myRegs - regsStart + 1 + , traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , pushArgs regsStart myRegs + , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar + , newAp |= var "h$apply" .! newTag + , ifS (newAp .===. var "h$ap_gen") + ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp + 1) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , returnS c + ] + -- else + [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag) + , jwhenS (tag .!=. 0) $ mconcat + [ p |= var "h$paps" .! myRegs + , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr] + , loop 0 (.<. myRegs) + (\i -> (dat .^ "push") + `ApplStat` [app "h$getReg" [i+2]] <> postIncrS i) + , r1 |= initClosure s p dat jCurrentCCS + ] + , returnStack + ]) + ] + + + pushAllRegs :: JExpr -> JStat + pushAllRegs tag = + jVar \regs -> + [ regs |= tag .>>. 8 + , sp |= sp + regs + , SwitchStat regs (map pushReg [65,64..2]) mempty + ] + where + pushReg :: Int -> (JExpr, JStat) + pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= jsReg r) + + pushArgs :: JExpr -> JExpr -> JStat + pushArgs start end = + loop end (.>=.start) (\i -> traceRts s (jString "pushing register: " + i) + <> (stack .! (sp + start - i) |= app "h$getReg" [i+1]) + <> postDecrS i + ) + +-- | Make specialized apply function for the given ApplySpec +specApply :: StgToJSConfig -> ApplySpec -> JStat +specApply cfg spec@(ApplySpec conv nargs nvars) = + let fun_name = specApplyName spec + in case conv of + RegsConv -> fastApply cfg fun_name nargs nvars + StackConv -> stackApply cfg fun_name nargs nvars + +-- | Make specialized apply function with Stack calling convention +stackApply + :: StgToJSConfig + -> FastString + -> Int + -> Int + -> JStat +stackApply s fun_name nargs nvars = + -- special case for h$ap_0_0 + if nargs == 0 && nvars == 0 + then closure info0 body0 + else closure info body + where + info = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutUnknown nvars) CIStackFrame mempty + info0 = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutFixed 0 []) CIStackFrame mempty + + body0 = adjSpN' 1 <> enter s r1 + + body = jVar \c -> + [ c |= closureEntry r1 + , traceRts s (toJExpr fun_name + + jString " " + + (c .^ "n") + + jString " sp: " + sp + + jString " a: " + (c .^ "a")) + , SwitchStat (entryClosureType c) + [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c) + , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> funCase c) + , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> papCase c) + , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1])) + ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (entryClosureType c)]) + ] + + funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c + stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..nvars] + + papCase :: JExpr -> JStat + papCase c = jVar \expr arity0 arity -> + case expr of + ValExpr (JVar pap) -> [ arity0 |= papArity r1 + , arity |= mask8 arity0 + , traceRts s (toJExpr (fun_name <> ": found pap, arity: ") + arity) + , ifS (toJExpr nargs .===. arity) + --then + (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) + -- else + (ifS (toJExpr nargs .>. arity) + (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversatCase c arity0 arity) + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap r1 (toJExpr nargs) stackArgs + <> (sp |= sp - toJExpr (nvars + 1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + + funCase :: JExpr -> JStat + funCase c = jVar \expr ar0 ar -> + case expr of + ValExpr (JVar pap) -> [ ar0 |= funArity' c + , ar |= mask8 ar0 + , ifS (toJExpr nargs .===. ar) + (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) + (ifS (toJExpr nargs .>. ar) + (traceRts s (toJExpr (fun_name <> ": oversat")) + <> oversatCase c ar0 ar) + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap (toJExpr R1) (toJExpr nargs) stackArgs + <> (sp |= sp - toJExpr (nvars+1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + + -- oversat: call the function but keep enough on the stack for the next + oversatCase :: JExpr -- function + -> JExpr -- the arity tag + -> JExpr -- real arity (arity & 0xff) + -> JStat + oversatCase c arity arity0 = + jVar \rs newAp -> + [ rs |= (arity .>>. 8) + , loadRegs rs + , sp |= sp - rs + , newAp |= (var "h$apply" .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8))) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n")) + , returnS c + ] + where + loadRegs rs = SwitchStat rs switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, jsReg (x+1) |= stack .! (sp - toJExpr x))) [nvars,nvars-1..1] + +-- | Make specialized apply function with Regs calling convention +-- +-- h$ap_n_r_fast is entered if a function of unknown arity is called, n +-- arguments are already in r registers +fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat +fastApply s fun_name nargs nvars = func ||= body0 + where + -- special case for h$ap_0_0_fast + body0 = if nargs == 0 && nvars == 0 + then jLam (enter s r1) + else toJExpr (JFunc myFunArgs body) + + func = TxtI fun_name + + myFunArgs = [] + + regArgs = take nvars jsRegsFromR2 + + mkAp :: Int -> Int -> [JExpr] + mkAp n' r' = [ specApplyExpr (ApplySpec StackConv n' r') ] + + body = + jVar \c farity arity -> + [ c |= closureEntry r1 + , traceRts s (toJExpr (fun_name <> ": sp ") + sp) + , SwitchStat (entryClosureType c) + [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ") + + clName c + + jString " (arity: " + (c .^ "a") + jString ")") + <> (farity |= funArity' c) + <> funCase c farity) + ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> funCase c arity) + ,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c) + ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))] + (appS "throw" [toJExpr (fun_name <> ": unexpected closure type: ") + entryClosureType c]) + ] + + funCase :: JExpr -> JExpr -> JStat + funCase c arity = jVar \arg ar -> case arg of + ValExpr (JVar pap) -> [ ar |= mask8 arity + , ifS (toJExpr nargs .===. ar) + -- then + (traceRts s (toJExpr (fun_name <> ": exact")) <> returnS c) + -- else + (ifS (toJExpr nargs .>. ar) + --then + (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversatCase c arity) + -- else + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap r1 (toJExpr nargs) regArgs + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + oversatCase :: JExpr -> JExpr -> JStat + oversatCase c arity = + jVar \rs rsRemain -> + [ rs |= arity .>>. 8 + , rsRemain |= toJExpr nvars - rs + , traceRts s (toJExpr + (fun_name <> " regs oversat ") + + rs + + jString " remain: " + + rsRemain) + , saveRegs rs + , sp |= sp + rsRemain + 1 + , stack .! sp |= var "h$apply" .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity)) + , profStat s pushRestoreCCS + , returnS c + ] + where + saveRegs n = SwitchStat n switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (nvars-x)) |= jsReg (x+2))) [0..nvars-1] + +zeroApply :: StgToJSConfig -> JStat +zeroApply s = mconcat + [ TxtI "h$e" ||= jLam (\c -> (r1 |= c) <> enter s c) + ] + +-- carefully enter a closure that might be a thunk or a function + +-- ex may be a local var, but must've been copied to R1 before calling this +enter :: StgToJSConfig -> JExpr -> JStat +enter s ex = jVar \c -> + [ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack + , c |= closureEntry ex + , jwhenS (c .===. var "h$unbox_e") ((r1 |= closureField1 ex) <> returnStack) + , SwitchStat (entryClosureType c) + [ (toJExpr Con, mempty) + , (toJExpr Fun, mempty) + , (toJExpr Pap, returnStack) + , (toJExpr Blackhole, push' s [var "h$ap_0_0", ex, var "h$return"] + <> returnS (app "h$blockOnBlackhole" [ex])) + ] (returnS c) + ] + +updates :: StgToJSConfig -> JStat +updates s = BlockStat + [ closure + (ClosureInfo (TxtI "h$upd_frame") (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + $ jVar \updatee waiters ss si sir -> + let unbox_closure = Closure + { clEntry = var "h$unbox_e" + , clField1 = sir + , clField2 = null_ + , clMeta = 0 + , clCC = Nothing + } + updateCC updatee = closureCC updatee |= jCurrentCCS + in [ updatee |= stack .! (sp - 1) + , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc") + , -- wake up threads blocked on blackhole + waiters |= closureField2 updatee + , jwhenS (waiters .!==. null_) + (loop 0 (.<. waiters .^ "length") + (\i -> appS "h$wakeupThread" [waiters .! i] <> postIncrS i)) + , -- update selectors + jwhenS ((app "typeof" [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel")) + ((ss |= closureMeta updatee .^ "sel") + <> loop 0 (.<. ss .^ "length") \i -> mconcat + [ si |= ss .! i + , sir |= (closureField2 si) `ApplExpr` [r1] + , ifS (app "typeof" [sir] .===. jTyObject) + (copyClosure DontCopyCC si sir) + (assignClosure si unbox_closure) + , postIncrS i + ]) + , -- overwrite the object + ifS (app "typeof" [r1] .===. jTyObject) + (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureEntry r1) .^ "n")) + , copyClosure DontCopyCC updatee r1 + ]) + -- the heap object is represented by another type of value + -- (e.g. a JS number or string) so the unboxing closure + -- will simply return it. + (assignClosure updatee (unbox_closure { clField1 = r1 })) + , profStat s (updateCC updatee) + , adjSpN' 2 + , traceRts s (jString "h$upd_frame: updating: " + + updatee + + jString " -> " + + r1) + , returnStack + ] + + , closure + (ClosureInfo (TxtI "h$upd_frame_lne") (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + $ jVar \updateePos -> + [ updateePos |= stack .! (sp - 1) + , (stack .! updateePos |= r1) + , adjSpN' 2 + , traceRts s (jString "h$upd_frame_lne: updating: " + + updateePos + + jString " -> " + + r1) + , returnStack + ] + ] + +selectors :: StgToJSConfig -> JStat +selectors s = + mkSel "1" closureField1 + <> mkSel "2a" closureField2 + <> mkSel "2b" (closureField1 . closureField2) + <> mconcat (map mkSelN [3..16]) + where + mkSelN :: Int -> JStat + mkSelN x = mkSel (mkFastString $ show x) + (\e -> SelExpr (closureField2 (toJExpr e)) + (TxtI $ mkFastString ("d" ++ show (x-1)))) + + + mkSel :: FastString -> (JExpr -> JExpr) -> JStat + mkSel name sel = mconcat + [TxtI createName ||= jLam \r -> mconcat + [ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc")) + , ifS (isThunk r .||. isBlackhole r) + (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)])) + (returnS (sel r)) + ] + , TxtI resName ||= jLam \r -> mconcat + [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc")) + , returnS (sel r) + ] + , closure + (ClosureInfo (TxtI entryName) (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar \tgt -> + [ tgt |= closureField1 r1 + , traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc")) + , ifS (isThunk tgt .||. isBlackhole tgt) + (preIncrS sp + <> (stack .! sp |= var frameName) + <> returnS (app "h$e" [tgt])) + (returnS (app "h$e" [sel tgt])) + ]) + , closure + (ClosureInfo (TxtI frameName) (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ traceRts s (toJExpr ("selector frame: " <> name)) + , postDecrS sp + , returnS (app "h$e" [sel r1]) + ] + ] + + where + v x = JVar (TxtI x) + n ext = "h$c_sel_" <> name <> ext + createName = n "" + resName = n "_res" + entryName = n "_e" + frameName = n "_frame_e" + + +-- arity is the remaining arity after our supplied arguments are applied +mkPap :: StgToJSConfig + -> Ident -- ^ id of the pap object + -> JExpr -- ^ the function that's called (can be a second pap) + -> JExpr -- ^ number of arguments in pap + -> [JExpr] -- ^ values for the supplied arguments + -> JStat +mkPap s tgt fun n values = + traceRts s (toJExpr $ "making pap with: " ++ show (length values) ++ " items") + `mappend` + allocDynamic s True tgt (toJExpr entry) (fun:papAr:map toJExpr values') + (if csProf s then Just jCurrentCCS else Nothing) + where + papAr = funOrPapArity fun Nothing - toJExpr (length values * 256) - n + + values' | GHC.Prelude.null values = [null_] + | otherwise = values + entry | length values > numSpecPap = TxtI "h$pap_gen" + | otherwise = specPapIdents ! length values + +-- | Number of specialized PAPs (pre-generated for a given number of args) +numSpecPap :: Int +numSpecPap = 6 + +-- specialized (faster) pap generated for [0..numSpecPap] +-- others use h$pap_gen +specPap :: [Int] +specPap = [0..numSpecPap] + +-- | Cache of specialized PAP idents +specPapIdents :: Array Int Ident +specPapIdents = listArray (0,numSpecPap) $ map (TxtI . mkFastString . ("h$pap_"++) . show) specPap + +pap :: StgToJSConfig + -> Int + -> JStat +pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body + where + funcIdent = TxtI funcName + funcName = mkFastString ("h$pap_" ++ show r) + + body = jVar \c d f extra -> + [ c |= closureField1 r1 + , d |= closureField2 r1 + , f |= closureEntry c + , assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap") + , profStat s (enterCostCentreFun currentCCS) + , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r + , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra) + , moveBy extra + , loadOwnArgs d + , r1 |= c + , returnS f + ] + moveBy extra = SwitchStat extra + (reverse $ map moveCase [1..maxReg-r-1]) mempty + moveCase m = (toJExpr m, jsReg (m+r+1) |= jsReg (m+1)) + loadOwnArgs d = mconcat $ map (\r -> + jsReg (r+1) |= dField d (r+2)) [1..r] + dField d n = SelExpr d (TxtI . mkFastString $ ('d':show (n-1))) + +-- Construct a generic PAP +papGen :: StgToJSConfig -> JStat +papGen cfg = + closure (ClosureInfo funcIdent CIRegsUnknown funcName CILayoutVariable CIPap mempty) + (jVar \c f d pr or r -> + [ c |= closureField1 r1 + , d |= closureField2 r1 + , f |= closureEntry c + , pr |= funOrPapArity c (Just f) .>>. 8 + , or |= papArity r1 .>>. 8 + , r |= pr - or + , assertRts cfg + (isFun' f .||. isPap' f) + (jString "h$pap_gen: expected function or pap") + , profStat cfg (enterCostCentreFun currentCCS) + , traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or) + , appS "h$moveRegs2" [or, r] + , loadOwnArgs d r + , r1 |= c + , returnS f + ]) + + + where + funcIdent = TxtI funcName + funcName = "h$pap_gen" + loadOwnArgs d r = + let prop n = d .^ ("d" <> mkFastString (show $ n+1)) + loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n) + in SwitchStat r (map loadOwnArg [127,126..1]) mempty + +-- general utilities +-- move the first n registers, starting at R2, m places up (do not use with negative m) +moveRegs2 :: JStat +moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch + where + moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m) + -- fast cases + switchCases = [switchCase n m | n <- [1..5], m <- [1..4]] + switchCase :: Int -> Int -> (JExpr, JStat) + switchCase n m = (toJExpr $ + (n `Bits.shiftL` 8) Bits..|. m + , mconcat (map (`moveRegFast` m) [n+1,n..2]) + <> BreakStat Nothing {-[j| break; |]-}) + moveRegFast n m = jsReg (n+m) |= jsReg n + -- fallback + defaultCase n m = + loop n (.>.0) (\i -> appS "h$setReg" [i+1+m, app "h$getReg" [i+1]] `mappend` postDecrS i) + + +-- Initalize a variable sized object from an array of values +initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr +initClosure cfg entry values ccs = app "h$init_closure" + [ newClosure $ Closure + { clEntry = entry + , clField1 = null_ + , clField2 = null_ + , clMeta = 0 + , clCC = if csProf cfg then Just ccs else Nothing + } + , values + ] + +-- | Return an expression for every field of the given Id +getIdFields :: Id -> G [TypedExpr] +getIdFields i = assocIdExprs i <$> varsForId i + +-- | Store fields of Id into the given target expressions +storeIdFields :: Id -> [TypedExpr] -> G JStat +storeIdFields i dst = do + fields <- getIdFields i + pure (assignCoerce1 dst fields) diff --git a/compiler/GHC/StgToJS/Arg.hs b/compiler/GHC/StgToJS/Arg.hs new file mode 100644 index 0000000000..854bf7cc17 --- /dev/null +++ b/compiler/GHC/StgToJS/Arg.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Args +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Code generation of application arguments +----------------------------------------------------------------------------- + +module GHC.StgToJS.Arg + ( genArg + , genIdArg + , genIdArgI + , genIdStackArgI + , allocConStatic + , allocUnboxedConStatic + , allocateStaticList + , jsStaticArg + , jsStaticArgs + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.DataCon +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Literal +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Profiling +import GHC.StgToJS.Ids + +import GHC.Builtin.Types +import GHC.Stg.Syntax +import GHC.Core.DataCon + +import GHC.Types.CostCentre +import GHC.Types.Unique.FM +import GHC.Types.Id + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Control.Monad.Trans.State.Strict as State + +{- +Note [ Unboxable Literals Optimization ] +~~~~~~~~~~~~~~~~~~ + +Boxable types in the JS backend are represented as heap objects. See Note +[StgToJS design] in GHC.StgToJS.hs for more details. Some types, such as Int8 +do not benefit from not being wrapped in an object in the JS runtime. This optimization +detects such types and changes the code generator to generate a more efficient +representation. The change is minor and saves one level on indirection. Instead +of generating a wrapper object with a field for the value's payload, such as: + +// a JS object for an Int8 +var anInt8 = { d1 = <Int8# payload> + , f : entry function which would scrutinize the payload + } + +we instead generate: + +// notice, no wrapper object. This representation is essentially an Int8# in the JS backend +var anInt8 = <Int8# payload> + +This optimization fires when the follow invariants hold: + 1. The value in question has a Type which has a single data constructor + 2. The data constructor holds a single field that is monomorphic + 3. The value in question is distinguishable from a THUNK using the JavaScript typeof operator. + +From the haskell perspective this means that: + 1. An Int8# is always a JavaScript 'number', never a JavaScript object. + 2. An Int8 is either a JavaScript 'number' _or_ a JavaScript object depending on + its use case and this optimization. + +How is this sound? +~~~~~~~~~~~~~~~~~~ + +Normally this optimization would violate the guarantees of call-by-need, however +we are able to statically detect whether the type in question will be a THUNK or +not during code gen because the JS backend is consuming STG and we can check +during runtime with the typeof operator. Similarly we can check at runtime using +JavaScript's introspection operator `typeof`. Thus, when we know the value in +question will not be a THUNK we can safely elide the wrapping object, which +unboxes the value in the JS runtime. For example, an Int8 contains an Int8# +which has the JavaScript type 'number'. A THUNK of type Int8 would have a +JavaScript type 'object', so using 'typeof' allows us to check if we have +something that is definitely evaluated (i.e., a 'number') or something else. If +it is an 'object' then we may need to enter it to begin its evaluation. Consider +a type which has a 'ThreadId#' field; such as type would not be subject to this +optimization because it has to be represented as a JavaScript 'object' and thus +cannot be unboxed in this way. Another (edge) case is Int64#. Int64# is +similarly not unboxable in this way because Int64# does not fit in one +JavaScript variable and thus requires an 'object' for its representation in the +JavaScript runtime. + +-} + +-- | Generate JS code for static arguments +genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg] +genStaticArg a = case a of + StgLitArg l -> map StaticLitArg <$> genStaticLit l + StgVarArg i -> do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Nothing -> reg + Just expr -> unfloated expr + where + r = uTypeVt . stgArgType $ a + reg + | isVoid r = + return [] + | i == trueDataConId = + return [StaticLitArg (BoolLit True)] + | i == falseDataConId = + return [StaticLitArg (BoolLit False)] + | isMultiVar r = + map (\(TxtI t) -> StaticObjArg t) <$> mapM (identForIdN i) [1..varSize r] -- this seems wrong, not an obj? + | otherwise = (\(TxtI it) -> [StaticObjArg it]) <$> identForId i + + unfloated :: CgStgExpr -> G [StaticArg] + unfloated (StgLit l) = map StaticLitArg <$> genStaticLit l + unfloated (StgConApp dc _n args _) + | isBoolDataCon dc || isUnboxableCon dc = + (:[]) . allocUnboxedConStatic dc . concat <$> mapM genStaticArg args -- fixme what is allocunboxedcon? + | null args = (\(TxtI t) -> [StaticObjArg t]) <$> identForId (dataConWorkId dc) + | otherwise = do + as <- concat <$> mapM genStaticArg args + (TxtI e) <- identForDataConWorker dc + return [StaticConArg e as] + unfloated x = pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) + +-- | Generate JS code for an StgArg +genArg :: HasDebugCallStack => StgArg -> G [JExpr] +genArg a = case a of + StgLitArg l -> genLit l + StgVarArg i -> do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Just expr -> unfloated expr + Nothing + | isVoid r -> return [] + | i == trueDataConId -> return [true_] + | i == falseDataConId -> return [false_] + | isMultiVar r -> mapM (varForIdN i) [1..varSize r] + | otherwise -> (:[]) <$> varForId i + + where + -- if our argument is a joinid, it can be an unboxed tuple + r :: HasDebugCallStack => VarType + r = uTypeVt . stgArgType $ a + + unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr] + unfloated = \case + StgLit l -> genLit l + StgConApp dc _n args _ + | isBoolDataCon dc || isUnboxableCon dc + -> (:[]) . allocUnboxedCon dc . concat <$> mapM genArg args + | null args -> (:[]) <$> varForId (dataConWorkId dc) + | otherwise -> do + as <- concat <$> mapM genArg args + e <- varForDataConWorker dc + inl_alloc <- csInlineAlloc <$> getSettings + return [allocDynamicE inl_alloc e as Nothing] + x -> pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) + +-- | Generate a Var as JExpr +genIdArg :: HasDebugCallStack => Id -> G [JExpr] +genIdArg i = genArg (StgVarArg i) + +-- | Generate an Id as an Ident +genIdArgI :: HasDebugCallStack => Id -> G [Ident] +genIdArgI i + | isVoid r = return [] + | isMultiVar r = mapM (identForIdN i) [1..varSize r] + | otherwise = (:[]) <$> identForId i + where + r = uTypeVt . idType $ i + +-- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case +genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)] +genIdStackArgI i = zipWith f [1..] <$> genIdArgI i + where + f :: Int -> Ident -> (Ident,StackSlot) + f n ident = (ident, SlotId i n) + +-- | Allocate Static Constructors +allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G () +allocConStatic (TxtI to) cc con args = do + as <- mapM genStaticArg args + cc' <- costCentreStackLbl cc + allocConStatic' cc' (concat as) + where + -- see Note [ Unboxable Literals Optimization ] for the purpose of these + -- checks + allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G () + allocConStatic' cc' [] + | isBoolDataCon con && dataConTag con == 1 = + emitStatic to (StaticUnboxed $ StaticUnboxedBool False) cc' + | isBoolDataCon con && dataConTag con == 2 = + emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc' + | otherwise = do + (TxtI e) <- identForDataConWorker con + emitStatic to (StaticData e []) cc' + allocConStatic' cc' [x] + | isUnboxableCon con = + case x of + StaticLitArg (IntLit i) -> + emitStatic to (StaticUnboxed $ StaticUnboxedInt i) cc' + StaticLitArg (BoolLit b) -> + emitStatic to (StaticUnboxed $ StaticUnboxedBool b) cc' + StaticLitArg (DoubleLit d) -> + emitStatic to (StaticUnboxed $ StaticUnboxedDouble d) cc' + _ -> + pprPanic "allocConStatic: invalid unboxed literal" (ppr x) + allocConStatic' cc' xs = + if con == consDataCon + then case args of + (a0:a1:_) -> flip (emitStatic to) cc' =<< allocateStaticList [a0] a1 + _ -> panic "allocConStatic: invalid args for consDataCon" + else do + (TxtI e) <- identForDataConWorker con + emitStatic to (StaticData e xs) cc' + +-- | Allocate unboxed constructors +allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg +allocUnboxedConStatic con = \case + [] + | isBoolDataCon con && dataConTag con == 1 + -> StaticLitArg (BoolLit False) + | isBoolDataCon con && dataConTag con == 2 + -> StaticLitArg (BoolLit True) + [a@(StaticLitArg (IntLit _i))] -> a + [a@(StaticLitArg (DoubleLit _d))] -> a + _ -> pprPanic "allocUnboxedConStatic: not an unboxed constructor" (ppr con) + + +-- | Allocate Static list +allocateStaticList :: [StgArg] -> StgArg -> G StaticVal +allocateStaticList xs a@(StgVarArg i) + | isDataConId_maybe i == Just nilDataCon = listAlloc xs Nothing + | otherwise = do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Just (StgConApp dc _n [h,t] _) + | dc == consDataCon -> allocateStaticList (h:xs) t + _ -> listAlloc xs (Just a) + where + listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal + listAlloc xs Nothing = do + as <- concat . reverse <$> mapM genStaticArg xs + return (StaticList as Nothing) + listAlloc xs (Just r) = do + as <- concat . reverse <$> mapM genStaticArg xs + r' <- genStaticArg r + case r' of + [StaticObjArg ri] -> return (StaticList as (Just ri)) + _ -> + pprPanic "allocateStaticList: invalid argument (tail)" (ppr (xs, r)) +allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list" + +-- | Generate JS code corresponding to a static arg +jsStaticArg :: StaticArg -> JExpr +jsStaticArg = \case + StaticLitArg l -> toJExpr l + StaticObjArg t -> ValExpr (JVar (TxtI t)) + StaticConArg c args -> + allocDynamicE False (ValExpr . JVar . TxtI $ c) (map jsStaticArg args) Nothing + +-- | Generate JS code corresponding to a list of static args +jsStaticArgs :: [StaticArg] -> JExpr +jsStaticArgs = ValExpr . JList . map jsStaticArg + diff --git a/compiler/GHC/StgToJS/Closure.hs b/compiler/GHC/StgToJS/Closure.hs new file mode 100644 index 0000000000..7c758ede95 --- /dev/null +++ b/compiler/GHC/StgToJS/Closure.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module GHC.StgToJS.Closure + ( closureInfoStat + , closure + , conClosure + , Closure (..) + , newClosure + , assignClosure + , CopyCC (..) + , copyClosure + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Regs (stack,sp) + +import GHC.JS.Make +import GHC.JS.Syntax + +import Data.Monoid +import qualified Data.Bits as Bits + +closureInfoStat :: Bool -> ClosureInfo -> JStat +closureInfoStat debug (ClosureInfo obj rs name layout ctype srefs) + = setObjInfoL debug obj rs layout ty name tag srefs + where + !ty = case ctype of + CIThunk -> Thunk + CIFun {} -> Fun + CICon {} -> Con + CIBlackhole -> Blackhole + CIPap -> Pap + CIStackFrame -> StackFrame + !tag = case ctype of + CIThunk -> 0 + CIFun arity nregs -> mkArityTag arity nregs + CICon con -> con + CIBlackhole -> 0 + CIPap -> 0 + CIStackFrame -> 0 + + +setObjInfoL :: Bool -- ^ debug: output symbol names + -> Ident -- ^ the object name + -> CIRegs -- ^ things in registers + -> CILayout -- ^ layout of the object + -> ClosureType -- ^ closure type + -> FastString -- ^ object name, for printing + -> Int -- ^ `a' argument, depends on type (arity, conid) + -> CIStatic -- ^ static refs + -> JStat +setObjInfoL debug obj rs layout t n a + = setObjInfo debug obj t n field_types a size rs + where + size = case layout of + CILayoutVariable -> (-1) + CILayoutUnknown sz -> sz + CILayoutFixed sz _ -> sz + field_types = case layout of + CILayoutVariable -> [] + CILayoutUnknown size -> toTypeList (replicate size ObjV) + CILayoutFixed _ fs -> toTypeList fs + +setObjInfo :: Bool -- ^ debug: output all symbol names + -> Ident -- ^ the thing to modify + -> ClosureType -- ^ closure type + -> FastString -- ^ object name, for printing + -> [Int] -- ^ list of item types in the object, if known (free variables, datacon fields) + -> Int -- ^ extra 'a' parameter, for constructor tag or arity + -> Int -- ^ object size, -1 (number of vars) for unknown + -> CIRegs -- ^ things in registers + -> CIStatic -- ^ static refs + -> JStat +setObjInfo debug obj t name fields a size regs static + | debug = appS "h$setObjInfo" [ toJExpr obj + , toJExpr t + , toJExpr name + , toJExpr fields + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] + | otherwise = appS "h$o" [ toJExpr obj + , toJExpr t + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] + where + regTag CIRegsUnknown = -1 + regTag (CIRegs skip types) = + let nregs = sum $ map varSize types + in skip + (nregs `Bits.shiftL` 8) + +closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@ + -> JStat -- ^ rhs + -> JStat +closure ci body = (ciVar ci ||= jLam body) `mappend` closureInfoStat False ci + +conClosure :: Ident -> FastString -> CILayout -> Int -> JStat +conClosure symbol name layout constr = + closure (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty) + (returnS (stack .! sp)) + +-- | Used to pass arguments to newClosure with some safety +data Closure = Closure + { clEntry :: JExpr + , clField1 :: JExpr + , clField2 :: JExpr + , clMeta :: JExpr + , clCC :: Maybe JExpr + } + +newClosure :: Closure -> JExpr +newClosure Closure{..} = + let xs = [ (closureEntry_ , clEntry) + , (closureField1_, clField1) + , (closureField2_, clField2) + , (closureMeta_ , clMeta) + ] + in case clCC of + -- CC field is optional (probably to minimize code size as we could assign + -- null_, but we get the same effect implicitly) + Nothing -> ValExpr (jhFromList xs) + Just cc -> ValExpr (jhFromList $ (closureCC_,cc) : xs) + +assignClosure :: JExpr -> Closure -> JStat +assignClosure t Closure{..} = BlockStat + [ closureEntry t |= clEntry + , closureField1 t |= clField1 + , closureField2 t |= clField2 + , closureMeta t |= clMeta + ] <> case clCC of + Nothing -> mempty + Just cc -> closureCC t |= cc + +data CopyCC = CopyCC | DontCopyCC + +copyClosure :: CopyCC -> JExpr -> JExpr -> JStat +copyClosure copy_cc t s = BlockStat + [ closureEntry t |= closureEntry s + , closureField1 t |= closureField1 s + , closureField2 t |= closureField2 s + , closureMeta t |= closureMeta s + ] <> case copy_cc of + DontCopyCC -> mempty + CopyCC -> closureCC t |= closureCC s diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs new file mode 100644 index 0000000000..7703398aea --- /dev/null +++ b/compiler/GHC/StgToJS/CodeGen.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +-- | JavaScript code generator +module GHC.StgToJS.CodeGen + ( stgToJS + ) +where + +import GHC.Prelude + +import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js)) + +import GHC.JS.Ppr +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Arg +import GHC.StgToJS.Sinker +import GHC.StgToJS.Types +import qualified GHC.StgToJS.Object as Object +import GHC.StgToJS.StgUtils +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Deps +import GHC.StgToJS.Expr +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StaticPtr +import GHC.StgToJS.Symbols +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Stg.Syntax +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep (scaledThing) + +import GHC.Unit.Module +import GHC.Linker.Types (SptEntry (..)) + +import GHC.Types.CostCentre +import GHC.Types.ForeignStubs (ForeignStubs (..), getCHeader, getCStub) +import GHC.Types.RepType +import GHC.Types.Id +import GHC.Types.Unique + +import GHC.Data.FastString +import GHC.Utils.Encoding +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Binary +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Utils.Outputable hiding ((<>)) + +import qualified Data.Set as S +import Data.Monoid +import Control.Monad +import System.Directory +import System.FilePath + +-- | Code generator for JavaScript +stgToJS + :: Logger + -> StgToJSConfig + -> [CgStgTopBinding] + -> Module + -> [SptEntry] + -> ForeignStubs + -> CollectedCCs + -> FilePath -- ^ Output file name + -> IO () +stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_fn = do + + let (unfloated_binds, stg_binds) = sinkPgm this_mod stg_binds0 + -- TODO: avoid top level lifting in core-2-core when the JS backend is + -- enabled instead of undoing it here + + -- TODO: add dump pass for optimized STG ast for JS + + (deps,lus) <- runG config this_mod unfloated_binds $ do + ifProfilingM $ initCostCentres cccs + lus <- genUnits this_mod stg_binds spt_entries foreign_stubs + deps <- genDependencyData this_mod lus + pure (deps,lus) + + -- Doc to dump when -ddump-js is enabled + when (logHasDumpFlag logger Opt_D_dump_js) $ do + putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS + $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus) + + -- Write the object file + bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB + Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus) + + createDirectoryIfMissing True (takeDirectory output_fn) + writeBinMem bh output_fn + + + +-- | Generate the ingredients for the linkable units for this module +genUnits :: HasDebugCallStack + => Module + -> [CgStgTopBinding] + -> [SptEntry] + -> ForeignStubs + -> G [LinkableUnit] -- ^ the linkable units +genUnits m ss spt_entries foreign_stubs = do + gbl <- generateGlobalBlock + exports <- generateExportsBlock + others <- go 2 ss + pure (gbl:exports:others) + where + go :: HasDebugCallStack + => Int -- the block we're generating (block 0 is the global unit for the module) + -> [CgStgTopBinding] + -> G [LinkableUnit] + go !n = \case + [] -> pure [] + (x:xs) -> do + mlu <- generateBlock x n + lus <- go (n+1) xs + return (maybe lus (:lus) mlu) + + -- Generate the global unit that all other blocks in the module depend on + -- used for cost centres and static initializers + -- the global unit has no dependencies, exports the moduleGlobalSymbol + generateGlobalBlock :: HasDebugCallStack => G LinkableUnit + generateGlobalBlock = do + glbl <- State.gets gsGlobal + staticInit <- + initStaticPtrs spt_entries + let stat = ( -- O.optimize . + jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) + let syms = [moduleGlobalSymbol m] + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = stat + , oiRaw = mempty + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure lu + + generateExportsBlock :: HasDebugCallStack => G LinkableUnit + generateExportsBlock = do + let (f_hdr, f_c) = case foreign_stubs of + NoStubs -> (empty, empty) + ForeignStubs hdr c -> (getCHeader hdr, getCStub c) + unique_deps = map mkUniqueDep (lines $ renderWithContext defaultSDocContext f_hdr) + mkUniqueDep (tag:xs) = mkUnique tag (read xs) + mkUniqueDep [] = panic "mkUniqueDep" + + let syms = [moduleExportsSymbol m] + let raw = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = mempty + , oiRaw = raw + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = unique_deps + , luOtherDeps = [] + , luRequired = True + , luForeignRefs = [] + } + pure lu + + -- Generate the linkable unit for one binding or group of + -- mutually recursive bindings + generateBlock :: HasDebugCallStack + => CgStgTopBinding + -> Int + -> G (Maybe LinkableUnit) + generateBlock top_bind n = case top_bind of + StgTopStringLit bnd str -> do + bids <- identsForId bnd + case bids of + [(TxtI b1t),(TxtI b2t)] -> do + -- [e1,e2] <- genLit (MachStr str) + emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing + emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing + _extraTl <- State.gets (ggsToplevelStats . gsGroup) + si <- State.gets (ggsStatic . gsGroup) + let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 + let stat = jsSaturate (Just $ modulePrefix m n) body + let ids = [bnd] + syms <- (\(TxtI i) -> [i]) <$> identForId bnd + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = si + , oiStat = stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = ids + , luOtherExports = [] + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure (Just lu) + _ -> panic "generateBlock: invalid size" + + StgTopLifted decl -> do + tl <- genToplevel decl + extraTl <- State.gets (ggsToplevelStats . gsGroup) + ci <- State.gets (ggsClosureInfo . gsGroup) + si <- State.gets (ggsStatic . gsGroup) + unf <- State.gets gsUnfloated + extraDeps <- State.gets (ggsExtraDeps . gsGroup) + fRefs <- State.gets (ggsForeignRefs . gsGroup) + resetGroup + let allDeps = collectIds unf decl + topDeps = collectTopIds decl + required = hasExport decl + stat = -- Opt.optimize . + jsSaturate (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl + syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = ci + , oiStatic = si + , oiStat = stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = fRefs + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = topDeps + , luOtherExports = [] + , luIdDeps = allDeps + , luPseudoIdDeps = [] + , luOtherDeps = S.toList extraDeps + , luRequired = required + , luForeignRefs = fRefs + } + pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu + +-- | variable prefix for the nth block in module +modulePrefix :: Module -> Int -> FastString +modulePrefix m n = + let encMod = zEncodeString . moduleNameString . moduleName $ m + in mkFastString $ "h$" ++ encMod ++ "_id_" ++ show n + +genToplevel :: CgStgBinding -> G JStat +genToplevel (StgNonRec bndr rhs) = genToplevelDecl bndr rhs +genToplevel (StgRec bs) = + mconcat <$> mapM (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs + +genToplevelDecl :: Id -> CgStgRhs -> G JStat +genToplevelDecl i rhs = do + s1 <- resetSlots (genToplevelConEntry i rhs) + s2 <- resetSlots (genToplevelRhs i rhs) + return (s1 <> s2) + +genToplevelConEntry :: Id -> CgStgRhs -> G JStat +genToplevelConEntry i rhs = case rhs of + StgRhsCon _cc con _mu _ts _args + | isDataConWorkId i + -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT + StgRhsClosure _ _cc _upd_flag _args _body + | Just dc <- isDataConWorkId_maybe i + -> genSetConInfo i dc (stgRhsLive rhs) -- srt + _ -> pure mempty + +genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat +genSetConInfo i d l {- srt -} = do + ei <- identForDataConEntryId i + sr <- genStaticRefs l + emitClosureInfo $ ClosureInfo ei + (CIRegs 0 [PtrV]) + (mkFastString $ renderWithContext defaultSDocContext (ppr d)) + (fixedLayout $ map uTypeVt fields) + (CICon $ dataConTag d) + sr + return (ei ||= mkDataEntry) + where + -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug? + fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing) + (dataConRepArgTys d) + -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d) + +mkDataEntry :: JExpr +mkDataEntry = ValExpr $ JFunc [] returnStack + +genToplevelRhs :: Id -> CgStgRhs -> G JStat +-- general cases: +genToplevelRhs i rhs = case rhs of + StgRhsCon cc con _mu _tys args -> do + ii <- identForId i + allocConStatic ii cc con args + return mempty + StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do + {- + algorithm: + - collect all Id refs that are in the global id cache + - count usage in body for each ref + - order by increasing use + - prepend loading lives var to body: body can stay the same + -} + eid@(TxtI eidt) <- identForEntryId i + (TxtI idt) <- identForId i + body <- genBody (initExprCtx i) i R2 args body + global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body) + let lidents = map global_ident global_occs + let lids = map global_id global_occs + let lidents' = map identFS lidents + CIStaticRefs sr0 <- genStaticRefsRhs rhs + let sri = filter (`notElem` lidents') sr0 + sr = CIStaticRefs sri + et <- genEntryType args + ll <- loadLiveFun lids + (static, regs, upd) <- + if et == CIThunk + then do + r <- updateThunk + pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r) + else return (StaticFun eidt (map StaticObjArg lidents'), + (if null lidents then CIRegs 1 (concatMap idVt args) + else CIRegs 0 (PtrV : concatMap idVt args)) + , mempty) + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + emitClosureInfo (ClosureInfo eid + regs + idt + (fixedLayout $ map (uTypeVt . idType) lids) + et + sr) + ccId <- costCentreStackLbl cc + emitStatic idt static ccId + return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body))) diff --git a/compiler/GHC/StgToJS/CoreUtils.hs b/compiler/GHC/StgToJS/CoreUtils.hs new file mode 100644 index 0000000000..0fdf7a5ed8 --- /dev/null +++ b/compiler/GHC/StgToJS/CoreUtils.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Core utils +module GHC.StgToJS.CoreUtils where + +import GHC.Prelude + +import GHC.JS.Syntax + +import GHC.StgToJS.Types + +import GHC.Stg.Syntax + +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Core.Type + +import GHC.Types.RepType +import GHC.Types.Var +import GHC.Types.Id + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import qualified Data.Bits as Bits + +-- | can we unbox C x to x, only if x is represented as a Number +isUnboxableCon :: DataCon -> Bool +isUnboxableCon dc + | [t] <- dataConRepArgTys dc + , [t1] <- typeVt (scaledThing t) + = isUnboxable t1 && + dataConTag dc == 1 && + length (tyConDataCons $ dataConTyCon dc) == 1 + | otherwise = False + +-- | one-constructor types with one primitive field represented as a JS Number +-- can be unboxed +isUnboxable :: VarType -> Bool +isUnboxable DoubleV = True +isUnboxable IntV = True -- includes Char# +isUnboxable _ = False + +-- | Number of slots occupied by a PrimRep +data SlotCount + = NoSlot + | OneSlot + | TwoSlots + deriving (Show,Eq,Ord) + +instance Outputable SlotCount where + ppr = text . show + +-- | Return SlotCount as an Int +slotCount :: SlotCount -> Int +slotCount = \case + NoSlot -> 0 + OneSlot -> 1 + TwoSlots -> 2 + + +-- | Number of slots occupied by a value with the given VarType +varSize :: VarType -> Int +varSize = slotCount . varSlotCount + +varSlotCount :: VarType -> SlotCount +varSlotCount VoidV = NoSlot +varSlotCount LongV = TwoSlots -- hi, low +varSlotCount AddrV = TwoSlots -- obj/array, offset +varSlotCount _ = OneSlot + +typeSize :: Type -> Int +typeSize t = sum . map varSize . typeVt $ t + +isVoid :: VarType -> Bool +isVoid VoidV = True +isVoid _ = False + +isPtr :: VarType -> Bool +isPtr PtrV = True +isPtr _ = False + +isSingleVar :: VarType -> Bool +isSingleVar v = varSlotCount v == OneSlot + +isMultiVar :: VarType -> Bool +isMultiVar v = case varSlotCount v of + NoSlot -> False + OneSlot -> False + TwoSlots -> True + +-- | can we pattern match on these values in a case? +isMatchable :: [VarType] -> Bool +isMatchable [DoubleV] = True +isMatchable [IntV] = True +isMatchable _ = False + +tyConVt :: HasDebugCallStack => TyCon -> [VarType] +tyConVt = typeVt . mkTyConTy + +idVt :: HasDebugCallStack => Id -> [VarType] +idVt = typeVt . idType + +typeVt :: HasDebugCallStack => Type -> [VarType] +typeVt t | isRuntimeRepKindedTy t = [] +typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs t) + +-- only use if you know it's not an unboxed tuple +uTypeVt :: HasDebugCallStack => UnaryType -> VarType +uTypeVt ut + | isRuntimeRepKindedTy ut = VoidV +-- | isRuntimeRepTy ut = VoidV + -- GHC panics on this otherwise + | Just (tc, ty_args) <- splitTyConApp_maybe ut + , length ty_args /= tyConArity tc = PtrV + | isPrimitiveType ut = (primTypeVt ut) + | otherwise = + case typePrimRep' ut of + [] -> VoidV + [pt] -> primRepVt pt + _ -> pprPanic "uTypeVt: not unary" (ppr ut) + +primRepVt :: HasDebugCallStack => PrimRep -> VarType +primRepVt VoidRep = VoidV +primRepVt LiftedRep = PtrV -- fixme does ByteArray# ever map to this? +primRepVt UnliftedRep = RtsObjV +primRepVt IntRep = IntV +primRepVt Int8Rep = IntV +primRepVt Int16Rep = IntV +primRepVt Int32Rep = IntV +primRepVt WordRep = IntV +primRepVt Word8Rep = IntV +primRepVt Word16Rep = IntV +primRepVt Word32Rep = IntV +primRepVt Int64Rep = LongV +primRepVt Word64Rep = LongV +primRepVt AddrRep = AddrV +primRepVt FloatRep = DoubleV +primRepVt DoubleRep = DoubleV +primRepVt (VecRep{}) = error "uTypeVt: vector types are unsupported" + +typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep] +typePrimRep' ty = kindPrimRep' empty (typeKind ty) + +-- | Find the primitive representation of a 'TyCon'. Defined here to +-- avoid module loops. Call this only on unlifted tycons. +tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep] +tyConPrimRep' tc = kindPrimRep' empty res_kind + where + res_kind = tyConResKind tc + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's +-- of values of types of this kind. +kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] +kindPrimRep' doc ki + | Just ki' <- coreView ki + = kindPrimRep' doc ki' +kindPrimRep' doc (TyConApp _typ [runtime_rep]) + = -- ASSERT( typ `hasKey` tYPETyConKey ) + runtimeRepPrimRep doc runtime_rep +kindPrimRep' doc ki + = pprPanic "kindPrimRep'" (ppr ki $$ doc) + +primTypeVt :: HasDebugCallStack => Type -> VarType +primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of + Nothing -> error "primTypeVt: not a TyCon" + Just tc + | tc == charPrimTyCon -> IntV + | tc == intPrimTyCon -> IntV + | tc == wordPrimTyCon -> IntV + | tc == floatPrimTyCon -> DoubleV + | tc == doublePrimTyCon -> DoubleV + | tc == int8PrimTyCon -> IntV + | tc == word8PrimTyCon -> IntV + | tc == int16PrimTyCon -> IntV + | tc == word16PrimTyCon -> IntV + | tc == int32PrimTyCon -> IntV + | tc == word32PrimTyCon -> IntV + | tc == int64PrimTyCon -> LongV + | tc == word64PrimTyCon -> LongV + | tc == addrPrimTyCon -> AddrV + | tc == stablePtrPrimTyCon -> AddrV + | tc == stableNamePrimTyCon -> RtsObjV + | tc == statePrimTyCon -> VoidV + | tc == proxyPrimTyCon -> VoidV + | tc == realWorldTyCon -> VoidV + | tc == threadIdPrimTyCon -> RtsObjV + | tc == weakPrimTyCon -> RtsObjV + | tc == arrayPrimTyCon -> ArrV + | tc == smallArrayPrimTyCon -> ArrV + | tc == byteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal + | tc == mutableArrayPrimTyCon -> ArrV + | tc == smallMutableArrayPrimTyCon -> ArrV + | tc == mutableByteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal + | tc == mutVarPrimTyCon -> RtsObjV + | tc == mVarPrimTyCon -> RtsObjV + | tc == tVarPrimTyCon -> RtsObjV + | tc == bcoPrimTyCon -> RtsObjV -- unsupported? + | tc == stackSnapshotPrimTyCon -> RtsObjV + | tc == ioPortPrimTyCon -> RtsObjV -- unsupported? + | tc == anyTyCon -> PtrV + | tc == compactPrimTyCon -> ObjV -- unsupported? + | tc == eqPrimTyCon -> VoidV -- coercion token? + | tc == eqReprPrimTyCon -> VoidV -- role + | tc == unboxedUnitTyCon -> VoidV -- Void# + | otherwise -> PtrV -- anything else must be some boxed thing + +argVt :: StgArg -> VarType +argVt a = uTypeVt . stgArgType $ a + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +isBoolDataCon :: DataCon -> Bool +isBoolDataCon dc = isBoolTy (dataConType dc) + +-- standard fixed layout: payload types +-- payload starts at .d1 for heap objects, entry closest to Sp for stack frames +fixedLayout :: [VarType] -> CILayout +fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts + +-- 2-var values might have been moved around separately, use DoubleV as substitute +-- ObjV is 1 var, so this is no problem for implicit metadata +stackSlotType :: Id -> VarType +stackSlotType i + | OneSlot <- varSlotCount otype = otype + | otherwise = DoubleV + where otype = uTypeVt (idType i) + +idPrimReps :: Id -> [PrimRep] +idPrimReps = typePrimReps . idType + +typePrimReps :: Type -> [PrimRep] +typePrimReps = typePrimRep . unwrapType + +primRepSize :: PrimRep -> SlotCount +primRepSize p = varSlotCount (primRepVt p) + +-- | Associate the given values to each RrimRep in the given order, taking into +-- account the number of slots per PrimRep +assocPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])] +assocPrimReps [] _ = [] +assocPrimReps (r:rs) vs = case (primRepSize r,vs) of + (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs + (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs + (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs + err -> pprPanic "assocPrimReps" (ppr err) + +-- | Associate the given values to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +assocIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])] +assocIdPrimReps i = assocPrimReps (idPrimReps i) + +-- | Associate the given JExpr to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +assocIdExprs :: Id -> [JExpr] -> [TypedExpr] +assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es) + +-- | Return False only if we are *sure* it's a data type +-- Look through newtypes etc as much as possible +might_be_a_function :: HasDebugCallStack => Type -> Bool +might_be_a_function ty + | [LiftedRep] <- typePrimRep ty + , Just tc <- tyConAppTyCon_maybe (unwrapType ty) + , isDataTyCon tc + = False + | otherwise + = True + +mkArityTag :: Int -> Int -> Int +mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) + +toTypeList :: [VarType] -> [Int] +toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x)) diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs new file mode 100644 index 0000000000..242ea7f189 --- /dev/null +++ b/compiler/GHC/StgToJS/DataCon.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.DataCon +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Code generation of data constructors +----------------------------------------------------------------------------- + +module GHC.StgToJS.DataCon + ( genCon + , allocCon + , allocUnboxedCon + , allocDynamicE + , allocDynamic + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Closure +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Profiling +import GHC.StgToJS.Utils +import GHC.StgToJS.Ids + +import GHC.Core.DataCon + +import GHC.Types.CostCentre +import GHC.Types.Unique.Map + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString + +import Data.Maybe + +-- | Generate a data constructor. Special handling for unboxed tuples +genCon :: ExprCtx -> DataCon -> [JExpr] -> G JStat +genCon ctx con args + | isUnboxedTupleDataCon con + = return $ assignToExprCtx ctx args + + | [ValExpr (JVar ctxi)] <- concatMap typex_expr (ctxTarget ctx) + = allocCon ctxi con currentCCS args + + | xs <- concatMap typex_expr (ctxTarget ctx) + = pprPanic "genCon: unhandled DataCon" (ppr (con, args, xs)) + +-- | Allocate a data constructor. Allocate in this context means bind the data +-- constructor to 'to' +allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat +allocCon to con cc xs + | isBoolDataCon con || isUnboxableCon con = + return (toJExpr to |= allocUnboxedCon con xs) +{- | null xs = do + i <- varForId (dataConWorkId con) + return (assignj to i) -} + | otherwise = do + e <- varForDataConWorker con + cs <- getSettings + prof <- profiling + ccsJ <- if prof then ccsVarJ cc else return Nothing + return $ allocDynamic cs False to e xs ccsJ + +-- | Allocate an unboxed data constructor. If we have a bool we calculate the +-- right value. If not then we expect a singleton list and unbox by converting +-- ''C x' to 'x'. NB. This function may panic. +allocUnboxedCon :: DataCon -> [JExpr] -> JExpr +allocUnboxedCon con = \case + [] + | isBoolDataCon con && dataConTag con == 1 -> false_ + | isBoolDataCon con && dataConTag con == 2 -> true_ + [x] + | isUnboxableCon con -> x + xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con,xs)) + +-- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. +allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig + -> JExpr + -> [JExpr] + -> Maybe JExpr + -> JExpr +allocDynamicE inline_alloc entry free cc + | inline_alloc || length free > 24 = newClosure $ Closure + { clEntry = entry + , clField1 = fillObj1 + , clField2 = fillObj2 + , clMeta = ValExpr (JInt 0) + , clCC = cc + } + | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc) + where + allocFun = allocClsA (length free) + (fillObj1,fillObj2) + = case free of + [] -> (null_, null_) + [x] -> (x,null_) + [x,y] -> (x,y) + (x:xs) -> (x,toJExpr (JHash $ listToUniqMap (zip dataFields xs))) + dataFields = map (mkFastString . ('d':) . show) [(1::Int)..] + +-- | Allocate a dynamic object +allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat +allocDynamic s need_decl to entry free cc + | need_decl = DeclStat to (Just value) + | otherwise = toJExpr to |= value + where + value = allocDynamicE (csInlineAlloc s) entry free cc diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs new file mode 100644 index 0000000000..229daf51a4 --- /dev/null +++ b/compiler/GHC/StgToJS/Deps.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Deps +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Module to calculate the transitive dependencies of a module +----------------------------------------------------------------------------- + +module GHC.StgToJS.Deps + ( genDependencyData + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Object as Object +import GHC.StgToJS.Types +import GHC.StgToJS.Ids + +import GHC.JS.Syntax + +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Name + +import GHC.Unit.Module + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString + +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) +import Data.Array +import Data.Either +import Control.Monad + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +data DependencyDataCache = DDC + { ddcModule :: !(IntMap Unit) -- ^ Unique Module -> Unit + , ddcId :: !(IntMap Object.ExportedFun) -- ^ Unique Id -> Object.ExportedFun (only to other modules) + , ddcOther :: !(Map OtherSymb Object.ExportedFun) + } + +-- | Generate module dependency data +-- +-- Generate the object's dependency data, taking care that package and module names +-- are only stored once +genDependencyData + :: HasDebugCallStack + => Module + -> [LinkableUnit] + -> G Object.Deps +genDependencyData mod units = do + -- [(blockindex, blockdeps, required, exported)] + ds <- evalStateT (mapM (uncurry oneDep) blocks) + (DDC IM.empty IM.empty M.empty) + return $ Object.Deps + { depsModule = mod + , depsRequired = IS.fromList [ n | (n, _, True, _) <- ds ] + , depsHaskellExported = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds + , depsBlocks = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) + } + where + -- Id -> Block + unitIdExports :: UniqFM Id Int + unitIdExports = listToUFM $ + concatMap (\(u,n) -> map (,n) (luIdExports u)) blocks + + -- OtherSymb -> Block + unitOtherExports :: Map OtherSymb Int + unitOtherExports = M.fromList $ + concatMap (\(u,n) -> map (,n) + (map (OtherSymb mod) + (luOtherExports u))) + blocks + + blocks :: [(LinkableUnit, Int)] + blocks = zip units [0..] + + -- generate the list of exports and set of dependencies for one unit + oneDep :: LinkableUnit + -> Int + -> StateT DependencyDataCache G (Int, Object.BlockDeps, Bool, [Object.ExportedFun]) + oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do + (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps + (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps + (edp, bdp) <- partitionEithers <$> mapM (lookupPseudoIdFun n) pseudoIdDeps + expi <- mapM lookupExportedId (filter isExportedId idExports) + expo <- mapM lookupExportedOther otherExports + -- fixme thin deps, remove all transitive dependencies! + let bdeps = Object.BlockDeps + (IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp) + (S.toList . S.fromList $ edi++edo++edp) + return (n, bdeps, req, expi++expo) + + idModule :: Id -> Maybe Module + idModule i = nameModule_maybe (getName i) >>= \m -> + guard (m /= mod) >> return m + + lookupPseudoIdFun :: Int -> Unique + -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + lookupPseudoIdFun _n u = + case lookupUFM_Directly unitIdExports u of + Just k -> return (Right k) + _ -> panic "lookupPseudoIdFun" + + -- get the function for an Id from the cache, add it if necessary + -- result: Left Object.ExportedFun if function refers to another module + -- Right blockNumber if function refers to current module + -- + -- assumes function is internal to the current block if it's + -- from teh current module and not in the unitIdExports map. + lookupIdFun :: Int -> Id + -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + lookupIdFun n i = case lookupUFM unitIdExports i of + Just k -> return (Right k) + Nothing -> case idModule i of + Nothing -> return (Right n) + Just m -> + let k = getKey . getUnique $ i + addEntry :: StateT DependencyDataCache G Object.ExportedFun + addEntry = do + (TxtI idTxt) <- lift (identForId i) + lookupExternalFun (Just k) (OtherSymb m idTxt) + in if m == mod + then pprPanic "local id not found" (ppr m) + else Left <$> do + mr <- gets (IM.lookup k . ddcId) + maybe addEntry return mr + + -- get the function for an OtherSymb from the cache, add it if necessary + lookupOtherFun :: OtherSymb + -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + lookupOtherFun od@(OtherSymb m idTxt) = + case M.lookup od unitOtherExports of + Just n -> return (Right n) + Nothing | m == mod -> panic ("genDependencyData.lookupOtherFun: unknown local other id: " ++ unpackFS idTxt) + Nothing -> Left <$> (maybe (lookupExternalFun Nothing od) return =<< + gets (M.lookup od . ddcOther)) + + lookupExportedId :: Id -> StateT DependencyDataCache G Object.ExportedFun + lookupExportedId i = do + (TxtI idTxt) <- lift (identForId i) + lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt) + + lookupExportedOther :: FastString -> StateT DependencyDataCache G Object.ExportedFun + lookupExportedOther = lookupExternalFun Nothing . OtherSymb mod + + -- lookup a dependency to another module, add to the id cache if there's + -- an id key, otherwise add to other cache + lookupExternalFun :: Maybe Int + -> OtherSymb -> StateT DependencyDataCache G Object.ExportedFun + lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do + let mk = getKey . getUnique $ m + mpk = moduleUnit m + exp_fun = Object.ExportedFun m (LexicalFastString idTxt) + addCache = do + ms <- gets ddcModule + let !cache' = IM.insert mk mpk ms + modify (\s -> s { ddcModule = cache'}) + pure exp_fun + f <- do + mbm <- gets (IM.member mk . ddcModule) + case mbm of + False -> addCache + True -> pure exp_fun + + case mbIdKey of + Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) }) + Just k -> modify (\s -> s { ddcId = IM.insert k f (ddcId s) }) + + return f diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs new file mode 100644 index 0000000000..fd6d09585f --- /dev/null +++ b/compiler/GHC/StgToJS/Expr.hs @@ -0,0 +1,1045 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Expr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Code generation of Expressions +----------------------------------------------------------------------------- + +module GHC.StgToJS.Expr + ( genExpr + , genEntryType + , loadLiveFun + , genStaticRefsRhs + , genStaticRefs + , genBody + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Apply +import GHC.StgToJS.Arg +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.FFI +import GHC.StgToJS.Heap +import GHC.StgToJS.Monad +import GHC.StgToJS.DataCon +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Prim +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StgUtils +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Types.Basic +import GHC.Types.CostCentre +import GHC.Types.Tickish +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Unique.FM +import GHC.Types.RepType + +import GHC.Stg.Syntax +import GHC.Stg.Utils + +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 +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext) +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Data.FastString +import qualified GHC.Data.List.SetOps as ListSetOps + +import Data.Monoid +import Data.Maybe +import Data.Function +import Data.Either +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Map as M +import Control.Monad +import Control.Arrow ((&&&)) + +-- | Evaluate an expression in the given expression context (continuation) +genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult) +genExpr ctx stg = case stg of + StgApp f args -> genApp ctx f args + StgLit l -> do + ls <- genLit l + let r = assignToExprCtx ctx ls + pure (r,ExprInline Nothing) + StgConApp con _n args _ -> do + as <- concatMapM genArg args + c <- genCon ctx con as + return (c, ExprInline (Just as)) + StgOpApp (StgFCallOp f _) args t + -> genForeignCall ctx f t (concatMap typex_expr $ ctxTarget ctx) args + StgOpApp (StgPrimOp op) args t + -> genPrimOp ctx op args t + StgOpApp (StgPrimCallOp c) args t + -> genPrimCall ctx c args t + StgCase e b at alts + -> genCase ctx b e at alts (liveVars $ stgExprLive False stg) + StgLet _ b e -> do + (b',ctx') <- genBind ctx b + (s,r) <- genExpr ctx' e + return (b' <> s, r) + StgLetNoEscape _ b e -> do + (b', ctx') <- genBindLne ctx b + (s, r) <- genExpr ctx' e + return (b' <> s, r) + StgTick (ProfNote cc count scope) e -> do + setSCCstats <- ifProfilingM $ setCC cc count scope + (stats, result) <- genExpr ctx e + return (setSCCstats <> stats, result) + StgTick (SourceNote span _sname) e + -> genExpr (ctxSetSrcSpan span ctx) e + StgTick _m e + -> genExpr ctx e + +-- | regular let binding: allocate heap object +genBind :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStat, ExprCtx) +genBind ctx bndr = + case bndr of + StgNonRec b r -> do + j <- assign b r >>= \case + Just ja -> return ja + Nothing -> allocCls Nothing [(b,r)] + return (j, addEvalRhs ctx [(b,r)]) + StgRec bs -> do + jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls + let m = if null jas then Nothing else Just (mconcat $ catMaybes jas) + j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs + return (j, addEvalRhs ctx bs) + where + ctx' = ctxClearLneFrame ctx + + assign :: Id -> CgStgRhs -> G (Maybe JStat) + assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr) + | let strip = snd . stripStgTicksTop (not . tickishIsCode) + , StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr + , StgApp selectee [] <- strip sel_expr + , let params_w_offsets = zip params (L.scanl' (+) 1 $ map (typeSize . idType) params) + , let total_size = sum (map (typeSize . idType) params) + -- , the_fv == scrutinee -- fixme check + , Just the_offset <- ListSetOps.assocMaybe params_w_offsets selectee + , the_offset <= 16 -- fixme make this some configurable constant + = do + let the_fv = scrutinee -- error "the_fv" -- fixme + let sel_tag | the_offset == 2 = if total_size == 2 then "2a" + else "2b" + | otherwise = show the_offset + tgts <- identsForId b + the_fvjs <- varsForId the_fv + case (tgts, the_fvjs) of + ([tgt], [the_fvj]) -> return $ Just + (tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj]) + _ -> panic "genBind.assign: invalid size" + assign b (StgRhsClosure _ext _ccs _upd [] expr) + | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do + d <- declVarsForId b + tgt <- varsForId b + let ctx' = ctx { ctxTarget = assocIdExprs b tgt } + (j, _) <- genExpr ctx' expr + return (Just (d <> j)) + assign _b StgRhsCon{} = return Nothing + assign b r = genEntry ctx' b r >> return Nothing + + addEvalRhs c [] = c + addEvalRhs c ((b,r):xs) + | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs + | (StgRhsClosure _ _ ReEntrant _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs + | otherwise = addEvalRhs c xs + +genBindLne :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStat, ExprCtx) +genBindLne ctx bndr = do + -- compute live variables and the offsets where they will be stored in the + -- stack + vis <- map (\(x,y,_) -> (x,y)) <$> + optimizeFree oldFrameSize (newLvs++map fst updBinds) + -- initialize updatable bindings to null_ + declUpds <- mconcat <$> mapM (fmap (||= null_) . identForId . fst) updBinds + -- update expression context to include the updated LNE frame + let ctx' = ctxUpdateLneFrame vis bound ctx + mapM_ (uncurry $ genEntryLne ctx') binds + return (declUpds, ctx') + where + oldFrameSize = ctxLneFrameSize ctx + isOldLv i = ctxIsLneBinding ctx i || + ctxIsLneLiveVar ctx i + live = liveVars $ mkDVarSet $ stgLneLive' bndr + newLvs = filter (not . isOldLv) (dVarSetElems live) + binds = case bndr of + StgNonRec b e -> [(b,e)] + StgRec bs -> bs + bound = map fst binds + (updBinds, _nonUpdBinds) = L.partition (isUpdatableRhs . snd) binds + +-- | Generate let-no-escape entry +-- +-- Let-no-escape entries live on the stack. There is no heap object associated with them. +-- +-- A let-no-escape entry is called like a normal stack frame, although as an optimization, +-- `Stack`[`Sp`] is not set when making the call. This is done later if the +-- thread needs to be suspended. +-- +-- Updatable let-no-escape binders have one 'private' slot in the stack frame. This slot +-- is initially set to null, changed to h$blackhole when the thunk is being evaluated. +-- +genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () +genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) = + resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + vars = ctxLneFrameVars ctx + myOffset = + maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame") + ((payloadSize-) . fst) + (L.find ((==i) . fst . snd) (zip [0..] vars)) + bh | isUpdatable update = + jVar (\x -> mconcat + [ x |= ApplExpr (var "h$bh_lne") [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)] + , IfStat x (ReturnStat x) mempty + ]) + | otherwise = mempty + lvs <- popLneFrame True payloadSize ctx + body <- genBody ctx i R1 args body + ei@(TxtI eii) <- identForEntryId i + sr <- genStaticRefsRhs rhs + let f = JFunc [] (bh <> lvs <> body) + emitClosureInfo $ + ClosureInfo ei + (CIRegs 0 $ concatMap idVt args) + (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout . reverse $ + map (stackSlotType . fst) (ctxLneFrameVars ctx)) + CIStackFrame + sr + emitToplevel (ei ||= toJExpr f) +genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + ei@(TxtI _eii) <- identForEntryId i + -- di <- varForDataConWorker con + ii <- freshIdent + p <- popLneFrame True payloadSize ctx + args' <- concatMapM genArg args + ac <- allocCon ii con cc args' + emitToplevel (ei ||= toJExpr (JFunc [] + (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack]))) + +-- | Generate the entry function for a local closure +genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () +genEntry _ _i StgRhsCon {} = return () +genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = resetSlots $ do + let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body + ll <- loadLiveFun live + llv <- verifyRuntimeReps live + upd <- genUpdFrame upd_flag i + body <- genBody entryCtx i R2 args body + ei@(TxtI eii) <- identForEntryId i + et <- genEntryType args + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + sr <- genStaticRefsRhs rhs + emitClosureInfo $ ClosureInfo ei + (CIRegs 0 $ PtrV : concatMap idVt args) + (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout $ map (uTypeVt . idType) live) + et + sr + emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + where + entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) + +-- | Generate the entry function types for identifiers. Note that this only +-- returns either 'CIThunk' or 'CIFun'. Everything else (PAP Blackhole etc.) is +-- filtered as not a RuntimeRepKinded type. +genEntryType :: HasDebugCallStack => [Id] -> G CIType +genEntryType [] = return CIThunk +genEntryType args0 = do + args' <- mapM genIdArg args + return $ CIFun (length args) (length $ concat args') + where + args = filter (not . isRuntimeRepKindedTy . idType) args0 + +-- | Generate the body of an object +genBody :: HasDebugCallStack + => ExprCtx + -> Id + -> StgReg + -> [Id] + -> CgStgExpr + -> G JStat +genBody ctx i startReg args e = do + -- load arguments into local variables + la <- do + args' <- concatMapM genIdArgI args + return (declAssignAll args' (fmap toJExpr [startReg..])) + + -- assert that arguments have valid runtime reps + lav <- verifyRuntimeReps args + + -- compute PrimReps and their number of slots required to return the result of + -- i applied to args. + let res_vars = resultSize args i + + -- compute typed expressions for each slot and assign registers + let go_var regs = \case + [] -> [] + ((rep,size):rs) -> + let !(regs0,regs1) = splitAt size regs + !ts = go_var regs1 rs + in TypedExpr rep regs0 : ts + + let tgt = go_var jsRegsFromR1 res_vars + let !ctx' = ctx { ctxTarget = tgt } + + -- generate code for the expression + (e, _r) <- genExpr ctx' e + + return $ la <> lav <> e <> returnStack + +-- | Find the result type after applying the function to the arguments +-- +-- It's trickier than it looks because: +-- +-- 1. we don't have the Arity of the Id. The following functions return +-- different values in some cases: +-- - idArity +-- - typeArity . idType +-- - idFunRepArity +-- - typeArity . unwrapType . idType +-- Moreover the number of args may be different than all of these arities +-- +-- 2. sometimes the type is Any, perhaps after some unwrapping. For example +-- HappyAbsSyn is a newtype around HappyAny which is Any or (forall a. a). +-- +-- Se we're left to use the applied arguments to peel the type (unwrapped) one +-- arg at a time. But passed args are args after unarisation so we need to +-- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- number of passed args consumed by each type arg. +-- +-- In case of failure to determine the type, we default to LiftedRep as it's +-- probably what it is. +-- +resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)] +resultSize args i = result + where + result = result_reps `zip` result_slots + result_slots = fmap (slotCount . primRepSize) result_reps + result_reps = trim_args (unwrapType (idType i)) (length args) + + trim_args t 0 = typePrimRep t + trim_args t n + | Just (_af, _mult, arg, res) <- splitFunTy_maybe t + , nargs <- length (typePrimRepArgs arg) + , assert (n >= nargs) True + = trim_args (unwrapType res) (n - nargs) + | otherwise + = pprTrace "result_type: not a function type, assume LiftedRep" (ppr t) + [LiftedRep] + +-- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function +-- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False. +verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat +verifyRuntimeReps xs = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else mconcat <$> mapM verifyRuntimeRep xs + where + verifyRuntimeRep i = do + i' <- varsForId i + pure $ go i' (idVt i) + go js (VoidV:vs) = go js vs + go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs + go (j1:j2:js) (AddrV:vs) = v "h$verify_rep_addr" [j1,j2] <> go js vs + go (j:js) (v:vs) = ver j v <> go js vs + go [] [] = mempty + go _ _ = pprPanic "verifyRuntimeReps: inconsistent sizes" (ppr xs) + ver j PtrV = v "h$verify_rep_heapobj" [j] + ver j IntV = v "h$verify_rep_int" [j] + ver j RtsObjV = v "h$verify_rep_rtsobj" [j] + ver j DoubleV = v "h$verify_rep_double" [j] + ver j ArrV = v "h$verify_rep_arr" [j] + ver _ _ = mempty + v f as = ApplStat (var f) as + +-- | Given a set of 'Id's, bind each 'Id' to the appropriate data fields in N +-- registers. This assumes these data fields have already been populated in the +-- registers. For the empty, singleton, and binary case use register 1, for any +-- more use as many registers as necessary. +loadLiveFun :: [Id] -> G JStat +loadLiveFun l = do + l' <- concat <$> mapM identsForId l + case l' of + [] -> return mempty + -- set the ident to d1 field of register 1 + [v] -> return (v ||= r1 .^ closureField1_) + -- set the idents to d1 and d2 fields of register 1 + [v1,v2] -> return $ mconcat + [ v1 ||= r1 .^ closureField1_ + , v2 ||= r1 .^ closureField2_ + ] + -- and so on + (v:vs) -> do + d <- freshIdent + let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs + return $ mconcat + [ v ||= r1 .^ closureField1_ + , d ||= r1 .^ closureField2_ + , l'' + ] + where + loadLiveVar d n v = let ident = TxtI (dataFieldName n) + in v ||= SelExpr d ident + +-- | Pop a let-no-escape frame off the stack +popLneFrame :: Bool -> Int -> ExprCtx -> G JStat +popLneFrame inEntry size ctx = do + -- calculate the new stack size + let ctx' = ctxLneShrinkStack ctx size + + let gen_id_slot (i,n) = do + ids <- identsForId i + let !id_n = ids !! (n-1) + pure (id_n, SlotId i n) + + is <- mapM gen_id_slot (ctxLneFrameVars ctx') + + let skip = if inEntry then 1 else 0 -- pop the frame header + popSkipI skip is + +-- | Generate an updated given an 'Id' +genUpdFrame :: UpdateFlag -> Id -> G JStat +genUpdFrame u i + | isReEntrant u = pure mempty + | isOneShotBndr i = maybeBh + | isUpdatable u = updateThunk + | otherwise = maybeBh + where + isReEntrant ReEntrant = True + isReEntrant _ = False + maybeBh = do + settings <- getSettings + assertRtsStat (return $ bhSingleEntry settings) + +-- | Blackhole single entry +-- +-- Overwrite a single entry object with a special thunk that behaves like a +-- black hole (throws a JS exception when entered) but pretends to be a thunk. +-- Useful for making sure that the object is not accidentally entered multiple +-- times +-- +bhSingleEntry :: StgToJSConfig -> JStat +bhSingleEntry _settings = mconcat + [ r1 .^ closureEntry_ |= var "h$blackholeTrap" + , r1 .^ closureField1_ |= undefined_ + , r1 .^ closureField2_ |= undefined_ + ] + +genStaticRefsRhs :: CgStgRhs -> G CIStatic +genStaticRefsRhs lv = genStaticRefs (stgRhsLive lv) + +-- fixme, update to new way to compute static refs dynamically +genStaticRefs :: LiveVars -> G CIStatic +genStaticRefs lv + | isEmptyDVarSet sv = return (CIStaticRefs []) + | otherwise = do + unfloated <- State.gets gsUnfloated + let xs = filter (\x -> not (elemUFM x unfloated || + typeLevity_maybe (idType x) == Just Unlifted)) + (dVarSetElems sv) + CIStaticRefs . catMaybes <$> mapM getStaticRef xs + where + sv = liveStatic lv + + getStaticRef :: Id -> G (Maybe FastString) + getStaticRef = fmap (fmap itxt . listToMaybe) . identsForId + +-- | Reorder the things we need to push to reuse existing stack values as much +-- as possible True if already on the stack at that location +optimizeFree + :: HasDebugCallStack + => Int + -> [Id] + -> G [(Id,Int,Bool)] -- ^ A list of stack slots. + -- -- Id: stored on the slot + -- -- Int: the part of the value that is stored + -- -- Bool: True when the slot already contains a value +optimizeFree offset ids = do + -- this line goes wrong vvvvvvv + let -- ids' = concat $ map (\i -> map (i,) [1..varSize . uTypeVt . idType $ i]) ids + idSize :: Id -> Int + idSize i = sum $ map varSize (typeVt . idType $ i) + ids' = concatMap (\i -> map (i,) [1..idSize i]) ids + -- 1..varSize] . uTypeVt . idType $ i]) (typeVt ids) + l = length ids' + slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots + let slm = M.fromList (zip slots [0..]) + (remaining, fixed) = partitionEithers $ + map (\inp@(i,n) -> maybe (Left inp) (\j -> Right (i,n,j,True)) + (M.lookup (SlotId i n) slm)) ids' + takenSlots = S.fromList (fmap (\(_,_,x,_) -> x) fixed) + freeSlots = filter (`S.notMember` takenSlots) [0..l-1] + remaining' = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots + allSlots = L.sortBy (compare `on` \(_,_,x,_) -> x) (fixed ++ remaining') + return $ map (\(i,n,_,b) -> (i,n,b)) allSlots + +-- | Allocate local closures +allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat +allocCls dynMiddle xs = do + (stat, dyn) <- partitionEithers <$> mapM toCl xs + ac <- allocDynAll True dynMiddle dyn + pure (mconcat stat <> ac) + where + -- left = static, right = dynamic + toCl :: (Id, CgStgRhs) + -> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack)) + -- statics + {- making zero-arg constructors static is problematic, see #646 + proper candidates for this optimization should have been floated + already + toCl (i, StgRhsCon cc con []) = do + ii <- identForId i + Left <$> (return (decl ii) <> allocCon ii con cc []) -} + toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do + ii <- identForId i + ac <- allocCon ii con cc =<< genArg a + pure (Left (decl ii <> ac)) + + -- dynamics + toCl (i, StgRhsCon cc con _mu _ticks ar) = + -- fixme do we need to handle unboxed? + Right <$> ((,,,) <$> identForId i + <*> varForDataConWorker con + <*> concatMapM genArg ar + <*> pure cc) + toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) = + let live = stgLneLiveExpr cl + in Right <$> ((,,,) <$> identForId i + <*> varForEntryId i + <*> concatMapM varsForId live + <*> pure cc) + +-- fixme CgCase has a reps_compatible check here +-- | Consume Stg case statement and generate a case statement. See also +-- 'genAlts' +genCase :: HasDebugCallStack + => ExprCtx + -> Id + -> CgStgExpr + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G (JStat, ExprResult) +genCase ctx bnd e at alts l + | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do + bndi <- identsForId bnd + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi)) + $ ctx + (ej, r) <- genExpr ctx' e + let d = case r of + ExprInline d0 -> d0 + ExprCont -> pprPanic "genCase: expression was not inline" + (pprStgExpr panicStgPprOpts e) + + (aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts + (saveCCS,restoreCCS) <- ifProfilingM $ do + ccsVar <- freshIdent + pure ( ccsVar ||= toJExpr jCurrentCCS + , toJExpr jCurrentCCS |= toJExpr ccsVar + ) + return ( mconcat + [ mconcat (map decl bndi) + , saveCCS + , ej + , restoreCCS + , aj + ] + , ar + ) + | otherwise = do + rj <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..])) + $ ctx + (ej, _r) <- genExpr ctx' e + return (rj <> ej, ExprCont) + +genRet :: HasDebugCallStack + => ExprCtx + -> Id + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G JStat +genRet ctx e at as l = freshIdent >>= f + where + allRefs :: [Id] + allRefs = S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as + lneLive :: Int + lneLive = maximum $ 0 : catMaybes (map (ctxLneBindingStackSize ctx) allRefs) + ctx' = ctxLneShrinkStack ctx lneLive + lneVars = map fst $ ctxLneFrameVars ctx' + isLne i = ctxIsLneBinding ctx i || ctxIsLneLiveVar ctx' i + nonLne = filter (not . isLne) (dVarSetElems l) + + f :: Ident -> G JStat + f r@(TxtI ri) = do + pushLne <- pushLneFrame lneLive ctx + saveCCS <- ifProfilingM $ push [jCurrentCCS] + free <- optimizeFree 0 nonLne + pushRet <- pushRetArgs free (toJExpr r) + fun' <- fun free + sr <- genStaticRefs l -- srt + prof <- profiling + emitClosureInfo $ + ClosureInfo r + (CIRegs 0 altRegs) + ri + (fixedLayout . reverse $ + map (stackSlotType . fst3) free + ++ if prof then [ObjV] else map stackSlotType lneVars) + CIStackFrame + sr + emitToplevel $ r ||= toJExpr (JFunc [] fun') + return (pushLne <> saveCCS <> pushRet) + fst3 ~(x,_,_) = x + + altRegs :: HasDebugCallStack => [VarType] + altRegs = case at of + PrimAlt ptc -> [primRepVt ptc] + MultiValAlt _n -> idVt e + _ -> [PtrV] + + -- special case for popping CCS but preserving stack size + pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat + pop_handle_CCS [] = return mempty + pop_handle_CCS xs = do + -- grab the slots from 'xs' and push + addSlots (map snd xs) + -- move the stack pointer into the stack by ''length xs + n' + a <- adjSpN (length xs) + -- now load from the top of the stack + return (loadSkip 0 (map fst xs) <> a) + + fun free = resetSlots $ do + decs <- declVarsForId e + load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e + loadv <- verifyRuntimeReps [e] + ras <- loadRetArgs free + rasv <- verifyRuntimeReps (map (\(x,_,_)->x) free) + restoreCCS <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown) + rlne <- popLneFrame False lneLive ctx' + rlnev <- verifyRuntimeReps lneVars + (alts, _altr) <- genAlts ctx' e at Nothing as + return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <> + returnStack + +-- | Consume an Stg case alternative and generate the corresponding alternative +-- in JS land. If one alternative is a continuation then we must normalize the +-- other alternatives. See 'Branch' and 'normalizeBranches'. +genAlts :: HasDebugCallStack + => ExprCtx -- ^ lhs to assign expression result to + -> Id -- ^ id being matched + -> AltType -- ^ type + -> Maybe [JExpr] -- ^ if known, fields in datacon from earlier expression + -> [CgStgAlt] -- ^ the alternatives + -> G (JStat, ExprResult) +genAlts ctx e at me alts = do + (st, er) <- case at of + + PolyAlt -> case alts of + [alt] -> (branch_stat &&& branch_result) <$> mkAlgBranch ctx e alt + _ -> panic "genAlts: multiple polyalt" + + PrimAlt _tc + | [GenStgAlt _ bs expr] <- alts + -> do + ie <- varsForId e + dids <- mconcat <$> mapM declVarsForId bs + bss <- concatMapM varsForId bs + (ej, er) <- genExpr ctx expr + return (dids <> assignAll bss ie <> ej, er) + + PrimAlt tc + -> do + ie <- varsForId e + (r, bss) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkPrimIfBranch ctx [primRepVt tc]) alts + setSlots [] + return (mkSw ie bss, r) + + MultiValAlt n + | [GenStgAlt _ bs expr] <- alts + -> do + eids <- varsForId e + l <- loadUbxTup eids bs n + (ej, er) <- genExpr ctx expr + return (l <> ej, er) + + AlgAlt tc + | [_alt] <- alts + , isUnboxedTupleTyCon tc + -> panic "genAlts: unexpected unboxed tuple" + + AlgAlt _tc + | Just es <- me + , [GenStgAlt (DataAlt dc) bs expr] <- alts + , not (isUnboxableCon dc) + -> do + bsi <- mapM identsForId bs + (ej, er) <- genExpr ctx expr + return (declAssignAll (concat bsi) es <> ej, er) + + AlgAlt _tc + | [alt] <- alts + -> do + Branch _ s r <- mkAlgBranch ctx e alt + return (s, r) + + AlgAlt _tc + | [alt,_] <- alts + , DataAlt dc <- alt_con alt + , isBoolDataCon dc + -> do + i <- varForId e + nbs <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + case nbs of + (r, [Branch _ s1 _, Branch _ s2 _]) -> do + let s = if dataConTag dc == 2 + then IfStat i s1 s2 + else IfStat i s2 s1 + setSlots [] + return (s, r) + _ -> error "genAlts: invalid branches for Bool" + + AlgAlt _tc -> do + ei <- varForId e + (r, brs) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + setSlots [] + return (mkSwitch (ei .^ "f" .^ "a") brs, r) + + _ -> pprPanic "genAlts: unhandled case variant" (ppr (at, length alts)) + + ver <- verifyMatchRep e at + pure (ver <> st, er) + +-- | If 'StgToJSConfig.csRuntimeAssert' is set, then generate an assertion that +-- asserts the pattern match is valid, e.g., the match is attempted on a +-- Boolean, a Data Constructor, or some number. +verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStat +verifyMatchRep x alt = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else case alt of + AlgAlt tc -> do + ix <- varsForId x + pure $ ApplStat (var "h$verify_match_alg") (ValExpr(JStr(mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix) + _ -> pure mempty + +-- | A 'Branch' represents a possible branching path of an Stg case statement, +-- i.e., a possible code path from an 'StgAlt' +data Branch a = Branch + { branch_expr :: a + , branch_stat :: JStat + , branch_result :: ExprResult + } + deriving (Eq,Functor) + +-- | If one branch ends in a continuation but another is inline, we need to +-- adjust the inline branch to use the continuation convention +normalizeBranches :: ExprCtx + -> [Branch a] + -> (ExprResult, [Branch a]) +normalizeBranches ctx brs + | all (==ExprCont) (fmap branch_result brs) = + (ExprCont, brs) + | branchResult (fmap branch_result brs) == ExprCont = + (ExprCont, map mkCont brs) + | otherwise = + (ExprInline Nothing, brs) + where + mkCont b = case branch_result b of + ExprInline{} -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1 + (concatMap typex_expr $ ctxTarget ctx) + , branch_result = ExprCont + } + _ -> b + +-- | Load an unboxed tuple. "Loading" means getting all 'Idents' from the input +-- ID's, declaring them as variables in JS land and binding them, in order, to +-- 'es'. +loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat +loadUbxTup es bs _n = do + bs' <- concatMapM identsForId bs + return $ declAssignAll bs' es + +mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkSw [e] cases = mkSwitch e (fmap (fmap (fmap head)) cases) +mkSw es cases = mkIfElse es cases + +-- | Switch for pattern matching on constructors or prims +mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat +mkSwitch e cases + | [Branch (Just c1) s1 _] <- n + , [Branch _ s2 _] <- d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | [Branch (Just c1) s1 _, Branch _ s2 _] <- n + , null d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | null d + = SwitchStat e (map addBreak (init n)) (branch_stat (last n)) + + | [Branch _ d0 _] <- d + = SwitchStat e (map addBreak n) d0 + + | otherwise = panic "mkSwitch: multiple default cases" + where + addBreak (Branch (Just c) s _) = (c, mconcat [s, BreakStat Nothing]) + addBreak _ = panic "mkSwitch: addBreak" + (n,d) = L.partition (isJust . branch_expr) cases + +-- | if/else for pattern matching on things that js cannot switch on +-- the list of branches is expected to have the default alternative +-- first, if it exists +mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkIfElse e s = go (L.reverse s) + where + go = \case + [Branch _ s _] -> s -- only one 'nothing' allowed + (Branch (Just e0) s _ : xs) -> IfStat (mkEq e e0) s (go xs) + [] -> panic "mkIfElse: empty expression list" + _ -> panic "mkIfElse: multiple DEFAULT cases" + +-- | Wrapper to contruct sequences of (===), e.g., +-- +-- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2) +-- +mkEq :: [JExpr] -> [JExpr] -> JExpr +mkEq es1 es2 + | length es1 == length es2 = foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2) + | otherwise = panic "mkEq: incompatible expressions" + +mkAlgBranch :: ExprCtx -- ^ toplevel id for the result + -> Id -- ^ datacon to match + -> CgStgAlt -- ^ match alternative with binders + -> G (Branch (Maybe JExpr)) +mkAlgBranch top d alt + | DataAlt dc <- alt_con alt + , isUnboxableCon dc + , [b] <- alt_bndrs alt + = do + idd <- varForId d + fldx <- identsForId b + case fldx of + [fld] -> do + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch Nothing (mconcat [fld ||= idd, ej]) er) + _ -> panic "mkAlgBranch: invalid size" + + | otherwise + = do + cc <- caseCond (alt_con alt) + idd <- varForId d + b <- loadParams idd (alt_bndrs alt) + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch cc (b <> ej) er) + +-- | Generate a primitive If-expression +mkPrimIfBranch :: ExprCtx + -> [VarType] + -> CgStgAlt + -> G (Branch (Maybe [JExpr])) +mkPrimIfBranch top _vt alt = + (\ic (ej,er) -> Branch ic ej er) <$> ifCond (alt_con alt) <*> genExpr top (alt_rhs alt) + +-- fixme are bool things always checked correctly here? +ifCond :: AltCon -> G (Maybe [JExpr]) +ifCond = \case + DataAlt da -> return $ Just [toJExpr (dataConTag da)] + LitAlt l -> Just <$> genLit l + DEFAULT -> return Nothing + +caseCond :: AltCon -> G (Maybe JExpr) +caseCond = \case + DEFAULT -> return Nothing + DataAlt da -> return $ Just (toJExpr $ dataConTag da) + LitAlt l -> genLit l >>= \case + [e] -> pure (Just e) + es -> pprPanic "caseCond: expected single-variable literal" (ppr es) + +-- fixme use single tmp var for all branches +-- | Load parameters from constructor +loadParams :: JExpr -> [Id] -> G JStat +loadParams from args = do + as <- concat <$> zipWithM (\a u -> map (,u) <$> identsForId a) args use + return $ case as of + [] -> mempty + [(x,u)] -> loadIfUsed (from .^ closureField1_) x u + [(x1,u1),(x2,u2)] -> mconcat + [ loadIfUsed (from .^ closureField1_) x1 u1 + , loadIfUsed (from .^ closureField2_) x2 u2 + ] + ((x,u):xs) -> mconcat + [ loadIfUsed (from .^ closureField1_) x u + , jVar (\d -> mconcat [ d |= from .^ closureField2_ + , loadConVarsIfUsed d xs + ]) + ] + where + use = repeat True -- fixme clean up + loadIfUsed fr tgt True = tgt ||= fr + loadIfUsed _ _ _ = mempty + + loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..] + where f (x,u) n = loadIfUsed (SelExpr fr (TxtI (dataFieldName n))) x u + +-- | Determine if a branch will end in a continuation or not. If not the inline +-- branch must be normalized. See 'normalizeBranches' +-- NB. not a Monoid +branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult +branchResult = \case + [] -> panic "branchResult: empty list" + [e] -> e + (ExprCont:_) -> ExprCont + (_:es) + | elem ExprCont es -> ExprCont + | otherwise -> ExprInline Nothing + +-- | Push return arguments onto the stack. The 'Bool' tracks whether the value +-- is already on the stack or not, used in 'StgToJS.Stack.pushOptimized'. +pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JExpr -> G JStat +pushRetArgs free fun = do + rs <- mapM (\(i,n,b) -> (\es->(es!!(n-1),b)) <$> genIdArg i) free + pushOptimized (rs++[(fun,False)]) + +-- | Load the return arguments then pop the stack frame +loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStat +loadRetArgs free = do + ids <- mapM (\(i,n,_b) -> (!! (n-1)) <$> genIdStackArgI i) free + popSkipI 1 ids + +-- | allocate multiple, possibly mutually recursive, closures +allocDynAll :: Bool -> Maybe JStat -> [(Ident,JExpr,[JExpr],CostCentreStack)] -> G JStat +{- +XXX remove use of template and enable in-place init again +allocDynAll haveDecl middle [(to,entry,free,cc)] + | isNothing middle && to `notElem` (free ^.. template) = do + ccs <- ccsVarJ cc + return $ allocDynamic s haveDecl to entry free ccs -} +allocDynAll haveDecl middle cls = do + settings <- getSettings + let + middle' = fromMaybe mempty middle + + decl_maybe i e + | haveDecl = toJExpr i |= e + | otherwise = i ||= e + + makeObjs :: G JStat + makeObjs = + fmap mconcat $ forM cls $ \(i,f,_,cc) -> do + ccs <- maybeToList <$> costCentreStackLbl cc + pure $ mconcat + [ decl_maybe i $ if csInlineAlloc settings + then ValExpr (jhFromList $ [ (closureEntry_ , f) + , (closureField1_, null_) + , (closureField2_, null_) + , (closureMeta_ , zero_) + ] + ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs) + else ApplExpr (var "h$c") (f : fmap (ValExpr . JVar) ccs) + ] + + fillObjs = mconcat $ map fillObj cls + fillObj (i,_,es,_) + | csInlineAlloc settings || length es > 24 = + case es of + [] -> mempty + [ex] -> toJExpr i .^ closureField1_ |= toJExpr ex + [e1,e2] -> mconcat + [ toJExpr i .^ closureField1_ |= toJExpr e1 + , toJExpr i .^ closureField2_ |= toJExpr e2 + ] + (ex:es) -> mconcat + [ toJExpr i .^ closureField1_ |= toJExpr ex + , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip dataFieldNames es)) + ] + | otherwise = case es of + [] -> mempty + [ex] -> toJExpr i .^ closureField1_ |= ex + [e1,e2] -> mconcat + [ toJExpr i .^ closureField1_ |= e1 + , toJExpr i .^ closureField2_ |= e2 + ] + (ex:es) -> mconcat + [ toJExpr i .^ closureField1_ |= ex + , toJExpr i .^ closureField2_ |= fillFun es + ] + + fillFun [] = null_ + fillFun es = ApplExpr (allocData (length es)) es + + checkObjs | csAssertRts settings = mconcat $ + map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i]) cls + | otherwise = mempty + + objs <- makeObjs + pure $ mconcat [objs, middle', fillObjs, checkObjs] + +-- | Generate a primop. This function wraps around the real generator +-- 'GHC.StgToJS.genPrim', handling the 'ExprCtx' and all arguments before +-- generating the primop. +genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult) +genPrimOp ctx op args t = do + as <- concatMapM genArg args + prof <- csProf <$> getSettings + bound <- csBoundsCheck <$> getSettings + -- fixme: should we preserve/check the primreps? + return $ case genPrim prof bound t op (concatMap typex_expr $ ctxTarget ctx) as of + PrimInline s -> (s, ExprInline Nothing) + PRPrimCall s -> (s, ExprCont) diff --git a/compiler/GHC/StgToJS/ExprCtx.hs b/compiler/GHC/StgToJS/ExprCtx.hs new file mode 100644 index 0000000000..48a4483009 --- /dev/null +++ b/compiler/GHC/StgToJS/ExprCtx.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.ExprCtx +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- TODO: Write my description! +----------------------------------------------------------------------------- + +module GHC.StgToJS.ExprCtx + ( ExprCtx + , initExprCtx + , ctxAssertEvaluated + , ctxIsEvaluated + , ctxSetSrcSpan + , ctxSrcSpan + , ctxSetTop + , ctxTarget + , ctxSetTarget + , ctxEvaluatedIds + -- * Let-no-escape + , ctxClearLneFrame + , ctxUpdateLneFrame + , ctxLneFrameVars + , ctxLneFrameSize + , ctxIsLneBinding + , ctxIsLneLiveVar + , ctxLneBindingStackSize + , ctxLneShrinkStack + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types + +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Var +import GHC.Types.SrcLoc + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe + + +-- | Context into which an expression is evaluated +data ExprCtx = ExprCtx + { ctxTop :: Id + -- ^ Top-level binding Id + + , ctxTarget :: [TypedExpr] + -- ^ Target variables for the evaluated expression + + , ctxEvaluatedIds :: UniqSet Id + -- ^ Ids that we know to be evaluated (e.g. case binders when the expression + -- to evaluate is in an alternative) + + , ctxSrcSpan :: Maybe RealSrcSpan + -- ^ Source location + + ---------------------------- + -- Handling of let-no-escape + + , ctxLneFrameBs :: UniqFM Id Int + -- ^ LNE bindings with their expected stack size. + -- + -- The Int is the size of the stack when the LNE binding was defined. + -- We need to shrink the stack back to this size when we enter one of the + -- associated binder rhs: it expects its free variables at certain offsets + -- in the stack. + + , ctxLneFrameVars :: [(Id,Int)] + -- ^ Contents of current LNE frame + -- + -- Variables and their index on the stack + + , ctxLneFrameSize :: {-# UNPACK #-} !Int + -- ^ Cache the length of `ctxLneFrameVars` + + } + +-- | Initialize an expression context in the context of the given top-level +-- binding Id +initExprCtx :: Id -> ExprCtx +initExprCtx i = ExprCtx + { ctxTop = i + , ctxTarget = [] + , ctxEvaluatedIds = emptyUniqSet + , ctxLneFrameBs = emptyUFM + , ctxLneFrameVars = [] + , ctxLneFrameSize = 0 + , ctxSrcSpan = Nothing + } + +-- | Set target +ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx +ctxSetTarget t ctx = ctx { ctxTarget = t } + +-- | Set top-level binding Id +ctxSetTop :: Id -> ExprCtx -> ExprCtx +ctxSetTop i ctx = ctx { ctxTop = i } + +-- | Add an Id to the known-evaluated set +ctxAssertEvaluated :: Id -> ExprCtx -> ExprCtx +ctxAssertEvaluated i ctx = ctx { ctxEvaluatedIds = addOneToUniqSet (ctxEvaluatedIds ctx) i } + +-- | Set source location +ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx +ctxSetSrcSpan span ctx = ctx { ctxSrcSpan = Just span } + +-- | Update let-no-escape frame +ctxUpdateLneFrame :: [(Id,Int)] -> [Id] -> ExprCtx -> ExprCtx +ctxUpdateLneFrame new_spilled_vars new_lne_ids ctx = + let old_frame_size = ctxLneFrameSize ctx + new_frame_size = old_frame_size + length new_spilled_vars + in ctx + { ctxLneFrameBs = addListToUFM (ctxLneFrameBs ctx) (map (,new_frame_size) new_lne_ids) + , ctxLneFrameSize = new_frame_size + , ctxLneFrameVars = ctxLneFrameVars ctx ++ new_spilled_vars + } + +-- | Remove information about the current LNE frame +ctxClearLneFrame :: ExprCtx -> ExprCtx +ctxClearLneFrame ctx = + ctx + { ctxLneFrameBs = emptyUFM + , ctxLneFrameVars = [] + , ctxLneFrameSize = 0 + } + +-- | Predicate: do we know for sure that the given Id is evaluated? +ctxIsEvaluated :: ExprCtx -> Id -> Bool +ctxIsEvaluated ctx i = i `elementOfUniqSet` ctxEvaluatedIds ctx + +-- | Does the given Id correspond to a LNE binding +ctxIsLneBinding :: ExprCtx -> Id -> Bool +ctxIsLneBinding ctx i = isJust (ctxLneBindingStackSize ctx i) + +-- | Does the given Id correspond to a LNE live var on the stack +ctxIsLneLiveVar :: ExprCtx -> Id -> Bool +ctxIsLneLiveVar ctx i = i `elem` map fst (ctxLneFrameVars ctx) + +-- | Return the LNE stack size associated to the given Id. +-- Return Nothing when the Id doesn't correspond to a LNE binding. +ctxLneBindingStackSize :: ExprCtx -> Id -> Maybe Int +ctxLneBindingStackSize ctx i = lookupUFM (ctxLneFrameBs ctx) i + +-- | Shrink the LNE stack to the given size +ctxLneShrinkStack :: ExprCtx -> Int -> ExprCtx +ctxLneShrinkStack ctx n = + let l = ctxLneFrameSize ctx + in assertPpr + (l >= n) + (vcat [ text "ctxLneShrinkStack: let-no-escape stack too short:" + , ppr l + , text " < " + , ppr n + ]) + (ctx { ctxLneFrameVars = take n (ctxLneFrameVars ctx) + , ctxLneFrameSize = n + } + ) diff --git a/compiler/GHC/StgToJS/FFI.hs b/compiler/GHC/StgToJS/FFI.hs new file mode 100644 index 0000000000..0c1a713f70 --- /dev/null +++ b/compiler/GHC/StgToJS/FFI.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.FFI + ( genPrimCall + , genForeignCall + , saturateFFI + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Arg +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Monad +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Regs +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Ids + +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Unique.Map +import GHC.Types.Unique.FM + +import GHC.Stg.Syntax + +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim + +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr, vcat, text) +import GHC.Data.FastString + +import Data.Char +import Data.Monoid +import Data.Maybe +import qualified Data.List as L +import Control.Monad +import Control.Applicative +import qualified Text.ParserCombinators.ReadP as P + +genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult) +genPrimCall ctx (PrimCall lbl _) args t = do + j <- parseFFIPattern False False False ("h$" ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args + return (j, ExprInline Nothing) + +-- | generate the actual call +{- + parse FFI patterns: + "&value -> value + 1. "function" -> ret = function(...) + 2. "$r = $1.f($2) -> r1 = a1.f(a2) + + arguments, $1, $2, $3 unary arguments + $1_1, $1_2, for a binary argument + + return type examples + 1. $r unary return + 2. $r1, $r2 binary return + 3. $r1, $r2, $r3_1, $r3_2 unboxed tuple return + -} +parseFFIPattern :: Bool -- ^ catch exception and convert them to haskell exceptions + -> Bool -- ^ async (only valid with javascript calling conv) + -> Bool -- ^ using javascript calling convention + -> String + -> Type + -> [JExpr] + -> [StgArg] + -> G JStat +parseFFIPattern catchExcep async jscc pat t es as + | catchExcep = do + c <- parseFFIPatternA async jscc pat t es as + -- Generate: + -- try { + -- `c`; + -- } catch(except) { + -- return h$throwJSException(except); + -- } + let ex = TxtI "except" + return (TryStat c ex (ReturnStat (ApplExpr (var "h$throwJSException") [toJExpr ex])) mempty) + | otherwise = parseFFIPatternA async jscc pat t es as + +parseFFIPatternA :: Bool -- ^ async + -> Bool -- ^ using JavaScript calling conv + -> String + -> Type + -> [JExpr] + -> [StgArg] + -> G JStat +-- async calls get an extra callback argument +-- call it with the result +parseFFIPatternA True True pat t es as = do + cb <- freshIdent + x <- freshIdent + d <- freshIdent + stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as + return $ mconcat + [ x ||= (toJExpr (jhFromList [("mv", null_)])) + , cb ||= ApplExpr (var "h$mkForeignCallback") [toJExpr x] + , stat + , IfStat (InfixExpr StrictEqOp (toJExpr x .^ "mv") null_) + (mconcat + [ toJExpr x .^ "mv" |= UOpExpr NewOp (ApplExpr (var "h$MVar") []) + , sp |= Add sp one_ + , (IdxExpr stack sp) |= var "h$unboxFFIResult" + , ReturnStat $ ApplExpr (var "h$takeMVar") [toJExpr x .^ "mv"] + ]) + (mconcat + [ d ||= toJExpr x .^ "mv" + , copyResult (toJExpr d) + ]) + ] + where nrst = typeSize t + copyResult d = assignAllEqual es (map (IdxExpr d . toJExpr) [0..nrst-1]) +parseFFIPatternA _async javascriptCc pat t es as = + parseFFIPattern' Nothing javascriptCc pat t es as + +-- parseFFIPatternA _ _ _ _ _ _ = error "parseFFIPattern: non-JavaScript pattern must be synchronous" + +parseFFIPattern' :: Maybe JExpr -- ^ Nothing for sync, Just callback for async + -> Bool -- ^ javascript calling convention used + -> String -- ^ pattern called + -> Type -- ^ return type + -> [JExpr] -- ^ expressions to return in (may be more than necessary) + -> [StgArg] -- ^ arguments + -> G JStat +parseFFIPattern' callback javascriptCc pat t ret args + | not javascriptCc = mkApply pat + | otherwise = + if True + then mkApply pat + else do + u <- freshUnique + case parseFfiJME pat u of + Right (ValExpr (JVar (TxtI _ident))) -> mkApply pat + Right expr | not async && length tgt < 2 -> do + (statPre, ap) <- argPlaceholders javascriptCc args + let rp = resultPlaceholders async t ret + env = addListToUFM emptyUFM (rp ++ ap) + if length tgt == 1 + then return $ statPre <> (mapStatIdent (replaceIdent env) (var "$r" |= expr)) + else return $ statPre <> (mapStatIdent (replaceIdent env) (toStat expr)) + Right _ -> p $ "invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " ++ + " imports with result size 0 or 1.\n" ++ pat + Left _ -> case parseFfiJM pat u of + Left err -> p (show err) + Right stat -> do + let rp = resultPlaceholders async t ret + let cp = callbackPlaceholders callback + (statPre, ap) <- argPlaceholders javascriptCc args + let env = addListToUFM emptyUFM (rp ++ ap ++ cp) + return $ statPre <> (mapStatIdent (replaceIdent env) stat) -- fixme trace? + where + async = isJust callback + tgt = take (typeSize t) ret + -- automatic apply, build call and result copy + mkApply f + | Just cb <- callback = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as++[cb]) + | {-ts@-} + (t:ts') <- tgt = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as + <> mconcat stats + <> (t |= ApplExpr f' (concat as) ) + <> copyResult ts' + -- _ -> error "mkApply: empty list" + | otherwise = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as) + where f' = toJExpr (TxtI $ mkFastString f) + copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs + p e = error ("Parse error in FFI pattern: " ++ pat ++ "\n" ++ e) + + replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr + replaceIdent env i + | isFFIPlaceholder i = fromMaybe err (lookupUFM env i) + | otherwise = ValExpr (JVar i) + where + (TxtI i') = i + err = pprPanic "parseFFIPattern': invalid placeholder, check function type" + (vcat [text pat, ppr i', ppr args, ppr t]) + traceCall cs as + | csTraceForeign cs = ApplStat (var "h$traceForeign") [toJExpr pat, toJExpr as] + | otherwise = mempty + +-- ident is $N, $N_R, $rN, $rN_R or $r or $c +isFFIPlaceholder :: Ident -> Bool +isFFIPlaceholder (TxtI x) = not (null (P.readP_to_S parser (unpackFS x))) + where + digit = P.satisfy (`elem` ("0123456789" :: String)) + parser = void (P.string "$r" >> P.eof) <|> + void (P.string "$c" >> P.eof) <|> do + _ <- P.char '$' + P.optional (P.char 'r') + _ <- P.many1 digit + P.optional (P.char '_' >> P.many1 digit) + P.eof + +-- generate arg to be passed to FFI call, with marshalling JStat to be run +-- before the call +genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr]) +genFFIArg _isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l +genFFIArg isJavaScriptCc a@(StgVarArg i) + | not isJavaScriptCc && + (tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon) = + (\x -> (mempty,[x, zero_])) <$> varForId i + | isVoid r = return (mempty, []) +-- | Just x <- marshalFFIArg a = x + | isMultiVar r = (mempty,) <$> mapM (varForIdN i) [1..varSize r] + | otherwise = (\x -> (mempty,[x])) <$> varForId i + where + tycon = tyConAppTyCon (unwrapType arg_ty) + arg_ty = stgArgType a + r = uTypeVt arg_ty + +-- $1, $2, $3 for single, $1_1, $1_2 etc for dual +-- void args not counted +argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident,JExpr)]) +argPlaceholders isJavaScriptCc args = do + (stats, idents0) <- unzip <$> mapM (genFFIArg isJavaScriptCc) args + let idents = filter (not . null) idents0 + return $ (mconcat stats, concat + (zipWith (\is n -> mkPlaceholder True ("$"++show n) is) idents [(1::Int)..])) + +mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)] +mkPlaceholder undersc prefix aids = + case aids of + [] -> [] + [x] -> [(TxtI . mkFastString $ prefix, x)] + xs@(x:_) -> (TxtI . mkFastString $ prefix, x) : + zipWith (\x m -> (TxtI . mkFastString $ prefix ++ u ++ show m,x)) xs [(1::Int)..] + where u = if undersc then "_" else "" + +-- $r for single, $r1,$r2 for dual +-- $r1, $r2, etc for ubx tup, void args not counted +resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)] -- ident, replacement +resultPlaceholders True _ _ = [] -- async has no direct resuls, use callback +resultPlaceholders False t rs = + case typeVt (unwrapType t) of + [t'] -> mkUnary (varSize t') + uts -> + let sizes = filter (>0) (map varSize uts) + f _ 0 = [] + f n 1 = [["$r" ++ show n]] + f n k = ["$r" ++ sn, "$r" ++ sn ++ "_1"] : map (\x -> ["$r" ++ sn ++ "_" ++ show x]) [2..k] + where sn = show n + phs = zipWith (\size n -> f n size) sizes [(1::Int)..] + in case sizes of + [n] -> mkUnary n + _ -> concat $ zipWith (\phs' r -> map (\i -> (TxtI (mkFastString i), r)) phs') (concat phs) rs + where + mkUnary 0 = [] + mkUnary 1 = [(TxtI "$r",head rs)] -- single + mkUnary n = [(TxtI "$r",head rs),(TxtI "$r1", head rs)] ++ + zipWith (\n r -> (TxtI . mkFastString $ "$r" ++ show n, toJExpr r)) [2..n] (tail rs) + +callbackPlaceholders :: Maybe JExpr -> [(Ident,JExpr)] +callbackPlaceholders Nothing = [] +callbackPlaceholders (Just e) = [((TxtI "$c"), e)] + +parseFfiJME :: String -> Int -> Either String JExpr +parseFfiJME _xs _u = Left "parseFfiJME not yet implemented" + +parseFfiJM :: String -> Int -> Either String JStat +parseFfiJM _xs _u = Left "parseFfiJM not yet implemented" + +saturateFFI :: JMacro a => Int -> a -> a +saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) + +genForeignCall :: HasDebugCallStack + => ExprCtx + -> ForeignCall + -> Type + -> [JExpr] + -> [StgArg] + -> G (JStat, ExprResult) +genForeignCall _ctx + (CCall (CCallSpec (StaticTarget _ tgt Nothing True) + JavaScriptCallConv + PlayRisky)) + _t + [obj] + args + | tgt == fsLit "h$buildObject" + , Just pairs <- getObjectKeyValuePairs args = do + pairs' <- mapM (\(k,v) -> genArg v >>= \vs -> return (k, head vs)) pairs + return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs')) + , ExprInline Nothing + ) + +genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do + emitForeign (ctxSrcSpan ctx) (mkFastString lbl) safety cconv (map showArgType args) (showType t) + (,exprResult) <$> parseFFIPattern catchExcep async isJsCc lbl t tgt' args + where + isJsCc = cconv == JavaScriptCallConv + + lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget + = let clbl' = unpackFS clbl + in if | isJsCc -> clbl' + | wrapperPrefix `L.isPrefixOf` clbl' -> + ("h$" ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl')) + | otherwise -> "h$" ++ clbl' + | otherwise = "h$callDynamic" + + exprResult | async = ExprCont + | otherwise = ExprInline Nothing + + catchExcep = (cconv == JavaScriptCallConv) && + playSafe safety || playInterruptible safety + + async | isJsCc = playInterruptible safety + | otherwise = playInterruptible safety || playSafe safety + + tgt' | async = take (length tgt) jsRegsFromR1 + | otherwise = tgt + + wrapperPrefix = "ghczuwrapperZC" + +getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)] +getObjectKeyValuePairs [] = Just [] +getObjectKeyValuePairs (k:v:xs) + | Just t <- argJSStringLitUnfolding k = + fmap ((t,v):) (getObjectKeyValuePairs xs) +getObjectKeyValuePairs _ = Nothing + +argJSStringLitUnfolding :: StgArg -> Maybe FastString +argJSStringLitUnfolding (StgVarArg _v) = Nothing -- fixme +argJSStringLitUnfolding _ = Nothing + +showArgType :: StgArg -> FastString +showArgType a = showType (stgArgType a) + +showType :: Type -> FastString +showType t + | Just tc <- tyConAppTyCon_maybe (unwrapType t) = + mkFastString (renderWithContext defaultSDocContext (ppr tc)) + | otherwise = "<unknown>" diff --git a/compiler/GHC/StgToJS/Heap.hs b/compiler/GHC/StgToJS/Heap.hs new file mode 100644 index 0000000000..fe2955812d --- /dev/null +++ b/compiler/GHC/StgToJS/Heap.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Heap + ( closureType + , entryClosureType + , isObject + , isThunk + , isThunk' + , isBlackhole + , isFun + , isFun' + , isPap + , isPap' + , isCon + , isCon' + , conTag + , conTag' + , closureEntry + , closureMeta + , closureField1 + , closureField2 + , closureCC + , funArity + , funArity' + , papArity + , funOrPapArity + -- * Field names + , closureEntry_ + , closureMeta_ + , closureCC_ + , closureField1_ + , closureField2_ + -- * Javascript Type literals + , jTyObject + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.StgToJS.Types +import GHC.Data.FastString + +closureEntry_ :: FastString +closureEntry_ = "f" + +closureField1_ :: FastString +closureField1_ = "d1" + +closureField2_ :: FastString +closureField2_ = "d2" + +closureMeta_ :: FastString +closureMeta_ = "m" + +closureCC_ :: FastString +closureCC_ = "cc" + +entryClosureType_ :: FastString +entryClosureType_ = "t" + +entryConTag_ :: FastString +entryConTag_ = "a" + +entryFunArity_ :: FastString +entryFunArity_ = "a" + +jTyObject :: JExpr +jTyObject = jString "object" + +closureType :: JExpr -> JExpr +closureType = entryClosureType . closureEntry + +entryClosureType :: JExpr -> JExpr +entryClosureType f = f .^ entryClosureType_ + +isObject :: JExpr -> JExpr +isObject c = typeof c .===. String "object" + +isThunk :: JExpr -> JExpr +isThunk c = closureType c .===. toJExpr Thunk + +isThunk' :: JExpr -> JExpr +isThunk' f = entryClosureType f .===. toJExpr Thunk + +isBlackhole :: JExpr -> JExpr +isBlackhole c = closureType c .===. toJExpr Blackhole + +isFun :: JExpr -> JExpr +isFun c = closureType c .===. toJExpr Fun + +isFun' :: JExpr -> JExpr +isFun' f = entryClosureType f .===. toJExpr Fun + +isPap :: JExpr -> JExpr +isPap c = closureType c .===. toJExpr Pap + +isPap' :: JExpr -> JExpr +isPap' f = entryClosureType f .===. toJExpr Pap + +isCon :: JExpr -> JExpr +isCon c = closureType c .===. toJExpr Con + +isCon' :: JExpr -> JExpr +isCon' f = entryClosureType f .===. toJExpr Con + +conTag :: JExpr -> JExpr +conTag = conTag' . closureEntry + +conTag' :: JExpr -> JExpr +conTag' f = f .^ entryConTag_ + +-- | Get closure entry function +closureEntry :: JExpr -> JExpr +closureEntry p = p .^ closureEntry_ + +-- | Get closure metadata +closureMeta :: JExpr -> JExpr +closureMeta p = p .^ closureMeta_ + +-- | Get closure cost-center +closureCC :: JExpr -> JExpr +closureCC p = p .^ closureCC_ + +-- | Get closure extra field 1 +closureField1 :: JExpr -> JExpr +closureField1 p = p .^ closureField1_ + +-- | Get closure extra field 2 +closureField2 :: JExpr -> JExpr +closureField2 p = p .^ closureField2_ + +-- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +funArity :: JExpr -> JExpr +funArity = funArity' . closureEntry + +-- function arity with raw reference to the entry +funArity' :: JExpr -> JExpr +funArity' f = f .^ entryFunArity_ + +-- arity of a partial application +papArity :: JExpr -> JExpr +papArity cp = closureField1 (closureField2 cp) + +funOrPapArity + :: JExpr -- ^ heap object + -> Maybe JExpr -- ^ reference to entry, if you have one already (saves a c.f lookup twice) + -> JExpr -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments) +funOrPapArity c = \case + Nothing -> ((IfExpr (toJExpr (isFun c))) (toJExpr (funArity c))) + (toJExpr (papArity c)) + Just f -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (funArity' f))) + (toJExpr (papArity c)) diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs new file mode 100644 index 0000000000..5d28b511f6 --- /dev/null +++ b/compiler/GHC/StgToJS/Ids.hs @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Ids +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Module to deal with JS identifiers +----------------------------------------------------------------------------- + +module GHC.StgToJS.Ids + ( freshUnique + , freshIdent + , makeIdentForId + , cachedIdentForId + -- * Helpers for Idents + , identForId + , identForIdN + , identsForId + , identForEntryId + , identForDataConEntryId + , identForDataConWorker + -- * Helpers for variables + , varForId + , varForIdN + , varsForId + , varForEntryId + , varForDataConEntryId + , varForDataConWorker + , declVarsForId + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Symbols + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import Control.Monad +import Control.Monad.IO.Class +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Map as M +import Data.Maybe +import qualified Data.ByteString.Char8 as BSC + +-- | Get fresh unique number +freshUnique :: G Int +freshUnique = do + id_gen <- State.gets gsId + liftIO $ do + -- no need for atomicFetchAdd as we don't use threads in G + v <- readFastMutInt id_gen + writeFastMutInt id_gen (v+1) + pure v + +-- | Get fresh local Ident of the form: h$$unit:module_uniq +freshIdent :: G Ident +freshIdent = do + i <- freshUnique + mod <- State.gets gsModule + let !name = mkFreshJsSymbol mod i + return (TxtI name) + + +-- | Generate unique Ident for the given ID (uncached!) +-- +-- The ident has the following forms: +-- +-- global Id: h$unit:module.name[_num][_type_suffix] +-- local Id: h$$unit:module.name[_num][_type_suffix]_uniq +-- +-- Note that the string is z-encoded except for "_" delimiters. +-- +-- Optional "_type_suffix" can be: +-- - "_e" for IdEntry +-- - "_con_e" for IdConEntry +-- +-- Optional "_num" is passed as an argument to this function. It is used for +-- Haskell Ids that require several JS variables: e.g. 64-bit numbers (Word64#, +-- Int64#), Addr#, StablePtr#, unboxed tuples, etc. +-- +makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident +makeIdentForId i num id_type current_module = TxtI ident + where + exported = isExportedId i + name = getName i + mod + | exported + , Just m <- nameModule_maybe name + = m + | otherwise + = current_module + + !ident = mkFastStringByteString $ mconcat + [ mkJsSymbolBS exported mod (occNameFS (nameOccName name)) + + ------------- + -- suffixes + + -- suffix for Ids represented with more than one JS var ("_0", "_1", etc.) + , case num of + Nothing -> mempty + Just v -> mconcat [BSC.pack "_", intBS v] + + -- suffix for entry and constructor entry + , case id_type of + IdPlain -> mempty + IdEntry -> BSC.pack "_e" + IdConEntry -> BSC.pack "_con_e" + + -- unique suffix for non-exported Ids + , if exported + then mempty + else let (c,u) = unpkUnique (getUnique i) + in mconcat [BSC.pack ['_',c,'_'], intBS u] + ] + +-- | Retrieve the cached Ident for the given Id if there is one. Otherwise make +-- a new one with 'makeIdentForId' and cache it. +cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident +cachedIdentForId i mi id_type = do + + -- compute key + let !key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) id_type + + -- lookup Ident in the Ident cache + IdCache cache <- State.gets gsIdents + ident <- case M.lookup key cache of + Just ident -> pure ident + Nothing -> do + mod <- State.gets gsModule + let !ident = makeIdentForId i mi id_type mod + let !cache' = IdCache (M.insert key ident cache) + State.modify (\s -> s { gsIdents = cache' }) + pure ident + + -- Now update the GlobalId cache, if required + + let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain + -- fixme also allow caching entries for lifting? + + when (update_global_cache) $ do + GlobalIdCache gidc <- getGlobalIdCache + case elemUFM ident gidc of + False -> setGlobalIdCache $ GlobalIdCache (addToUFM gidc ident (key, i)) + True -> pure () + + pure ident + +-- | Retrieve default Ident for the given Id +identForId :: Id -> G Ident +identForId i = cachedIdentForId i Nothing IdPlain + +-- | Retrieve default Ident for the given Id with sub index +-- +-- Some types, Word64, Addr#, unboxed tuple have more than one corresponding JS +-- var, hence we use the sub index to identify each subpart / JS variable. +identForIdN :: Id -> Int -> G Ident +identForIdN i n = cachedIdentForId i (Just n) IdPlain + +-- | Retrieve all the idents for the given Id. +identsForId :: Id -> G [Ident] +identsForId i = case typeSize (idType i) of + 0 -> pure mempty + 1 -> (:[]) <$> identForId i + s -> mapM (identForIdN i) [1..s] + + +-- | Retrieve entry Ident for the given Id +identForEntryId :: Id -> G Ident +identForEntryId i = cachedIdentForId i Nothing IdEntry + +-- | Retrieve datacon entry Ident for the given Id +-- +-- Different name than the datacon wrapper. +identForDataConEntryId :: Id -> G Ident +identForDataConEntryId i = cachedIdentForId i Nothing IdConEntry + + +-- | Retrieve default variable name for the given Id +varForId :: Id -> G JExpr +varForId i = toJExpr <$> identForId i + +-- | Retrieve default variable name for the given Id with sub index +varForIdN :: Id -> Int -> G JExpr +varForIdN i n = toJExpr <$> identForIdN i n + +-- | Retrieve all the JS vars for the given Id +varsForId :: Id -> G [JExpr] +varsForId i = case typeSize (idType i) of + 0 -> pure mempty + 1 -> (:[]) <$> varForId i + s -> mapM (varForIdN i) [1..s] + + +-- | Retrieve entry variable name for the given Id +varForEntryId :: Id -> G JExpr +varForEntryId i = toJExpr <$> identForEntryId i + +-- | Retrieve datacon entry variable name for the given Id +varForDataConEntryId :: Id -> G JExpr +varForDataConEntryId i = ValExpr . JVar <$> identForDataConEntryId i + + +-- | Retrieve datacon worker entry variable name for the given datacon +identForDataConWorker :: DataCon -> G Ident +identForDataConWorker d = identForDataConEntryId (dataConWorkId d) + +-- | Retrieve datacon worker entry variable name for the given datacon +varForDataConWorker :: DataCon -> G JExpr +varForDataConWorker d = varForDataConEntryId (dataConWorkId d) + +-- | Declare all js vars for the id +declVarsForId :: Id -> G JStat +declVarsForId i = case typeSize (idType i) of + 0 -> return mempty + 1 -> decl <$> identForId i + s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s] + diff --git a/compiler/GHC/StgToJS/Linker/Linker.hs b/compiler/GHC/StgToJS/Linker/Linker.hs new file mode 100644 index 0000000000..6c4b011ce9 --- /dev/null +++ b/compiler/GHC/StgToJS/Linker/Linker.hs @@ -0,0 +1,953 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Linker +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- GHCJS linker, collects dependencies from the object files +-- which contain linkable units with dependency information +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Linker + ( jsLinkBinary + , embedJsFile + ) +where + +import Prelude + +import GHC.Platform.Host (hostPlatformArchOS) + +import GHC.JS.Make +import GHC.JS.Syntax + +import GHC.Driver.Session (DynFlags(..)) +import Language.Haskell.Syntax.Module.Name +import GHC.SysTools.Cpp +import GHC.SysTools + +import GHC.Linker.Static.Utils (exeFileName) + +import GHC.StgToJS.Linker.Types +import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Rts.Rts +import GHC.StgToJS.Object +import GHC.StgToJS.Types hiding (LinkableUnit) +import GHC.StgToJS.Symbols +import GHC.StgToJS.Printer +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure + +import GHC.Unit.State +import GHC.Unit.Env +import GHC.Unit.Home +import GHC.Unit.Types +import GHC.Unit.Module (moduleStableString) + +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Logger (Logger, logVerbAtLeast) +import GHC.Utils.Binary +import qualified GHC.Utils.Ppr as Ppr +import GHC.Utils.Monad +import GHC.Utils.TmpFs + +import GHC.Types.Unique.Set + +import qualified GHC.SysTools.Ar as Ar + +import qualified GHC.Data.ShortText as ST +import GHC.Data.FastString + +import Control.Concurrent.MVar +import Control.Monad + +import Data.Array +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS +import Data.Function (on) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.IORef +import Data.List ( partition, nub, intercalate, group, sort + , groupBy, intersperse, + ) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import Data.Word + +import System.IO +import System.FilePath ((<.>), (</>), dropExtension, takeDirectory) +import System.Directory ( createDirectoryIfMissing + , doesFileExist + , getCurrentDirectory + , Permissions(..) + , setPermissions + , getPermissions + ) + +data LinkerStats = LinkerStats + { bytesPerModule :: !(Map Module Word64) -- ^ number of bytes linked per module + , packedMetaDataSize :: !Word64 -- ^ number of bytes for metadata + } + +newtype ArchiveState = ArchiveState { loadedArchives :: IORef (Map FilePath Ar.Archive) } + +emptyArchiveState :: IO ArchiveState +emptyArchiveState = ArchiveState <$> newIORef M.empty + +jsLinkBinary + :: JSLinkConfig + -> StgToJSConfig + -> [FilePath] + -> Logger + -> DynFlags + -> UnitEnv + -> [FilePath] + -> [UnitId] + -> IO () +jsLinkBinary lc_cfg cfg js_srcs logger dflags u_env objs dep_pkgs + | lcNoJSExecutables lc_cfg = return () + | otherwise = do + -- additional objects to link are passed as FileOption ldInputs... + let cmdline_objs = [ f | FileOption _ f <- ldInputs dflags ] + -- discriminate JavaScript sources from real object files. + (cmdline_js_srcs, cmdline_js_objs) <- partitionM isJsFile cmdline_objs + let + objs' = map ObjFile (objs ++ cmdline_js_objs) + js_srcs' = js_srcs ++ cmdline_js_srcs + isRoot _ = True + exe = jsExeFileName dflags + + void $ link lc_cfg cfg logger u_env exe mempty dep_pkgs objs' js_srcs' isRoot mempty + +-- | link and write result to disk (jsexe directory) +link :: JSLinkConfig + -> StgToJSConfig + -> Logger + -> UnitEnv + -> FilePath -- ^ output file/directory + -> [FilePath] -- ^ include path for home package + -> [UnitId] -- ^ packages to link + -> [LinkedObj] -- ^ the object files we're linking + -> [FilePath] -- ^ extra js files to include + -> (ExportedFun -> Bool) -- ^ functions from the objects to use as roots (include all their deps) + -> Set ExportedFun -- ^ extra symbols to link in + -> IO () +link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun extraStaticDeps = do + + -- create output directory + createDirectoryIfMissing False out + + ------------------------------------------------------------- + -- link all Haskell code (program + dependencies) into out.js + + -- compute dependencies + (dep_map, dep_units, all_deps, _rts_wired_functions, dep_archives) + <- computeLinkDependencies cfg logger out unit_env units objFiles extraStaticDeps isRootFun + + -- retrieve code for dependencies + mods <- collectDeps dep_map dep_units all_deps + + -- LTO + rendering of JS code + link_stats <- withBinaryFile (out </> "out.js") WriteMode $ \h -> + renderLinker h mods jsFiles + + ------------------------------------------------------------- + + -- dump foreign references file (.frefs) + unless (lcOnlyOut lc_cfg) $ do + let frefsFile = "out.frefs" + -- frefs = concatMap mc_frefs mods + jsonFrefs = mempty -- FIXME: toJson frefs + + BL.writeFile (out </> frefsFile <.> "json") jsonFrefs + BL.writeFile (out </> frefsFile <.> "js") + ("h$checkForeignRefs(" <> jsonFrefs <> ");") + + -- dump stats + unless (lcNoStats lc_cfg) $ do + let statsFile = "out.stats" + writeFile (out </> statsFile) (renderLinkerStats link_stats) + + -- link generated RTS parts into rts.js + unless (lcNoRts lc_cfg) $ do + BL.writeFile (out </> "rts.js") ( BLC.pack rtsDeclsText + <> BLC.pack (rtsText cfg)) + + -- link dependencies' JS files into lib.js + withBinaryFile (out </> "lib.js") WriteMode $ \h -> do + forM_ dep_archives $ \archive_file -> do + Ar.Archive entries <- Ar.loadAr archive_file + forM_ entries $ \entry -> do + case getJsArchiveEntry entry of + Nothing -> return () + Just bs -> do + B.hPut h bs + hPutChar h '\n' + + -- link everything together into all.js + when (generateAllJs lc_cfg) $ do + _ <- combineFiles lc_cfg out + writeHtml out + writeRunMain out + writeRunner lc_cfg out + writeExterns out + + +computeLinkDependencies + :: StgToJSConfig + -> Logger + -> String + -> UnitEnv + -> [UnitId] + -> [LinkedObj] + -> Set ExportedFun + -> (ExportedFun -> Bool) + -> IO (Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit, Set ExportedFun, [FilePath]) +computeLinkDependencies cfg logger target unit_env units objFiles extraStaticDeps isRootFun = do + + (objDepsMap, objRequiredUnits) <- loadObjDeps objFiles + + let roots = S.fromList . filter isRootFun $ concatMap (M.keys . depsHaskellExported . fst) (M.elems objDepsMap) + rootMods = map (moduleNameString . moduleName . head) . group . sort . map funModule . S.toList $ roots + objPkgs = map moduleUnitId $ nub (M.keys objDepsMap) + + when (logVerbAtLeast logger 2) $ void $ do + compilationProgressMsg logger $ hcat + [ text "Linking ", text target, text " (", text (intercalate "," rootMods), char ')' ] + compilationProgressMsg logger $ hcat + [ text "objDepsMap ", ppr objDepsMap ] + compilationProgressMsg logger $ hcat + [ text "objFiles ", ppr objFiles ] + + let (rts_wired_units, rts_wired_functions) = rtsDeps units + + -- all the units we want to link together, without their dependencies + let root_units = filter (/= mainUnitId) + $ nub + $ rts_wired_units ++ reverse objPkgs ++ reverse units + + -- all the units we want to link together, including their dependencies, + -- preload units, and backpack instantiations + all_units_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env root_units) + + let all_units = fmap unitId all_units_infos + + dep_archives <- getPackageArchives cfg unit_env all_units + env <- newGhcjsEnv + (archsDepsMap, archsRequiredUnits) <- loadArchiveDeps env dep_archives + + when (logVerbAtLeast logger 2) $ + logInfo logger $ hang (text "Linking with archives:") 2 (vcat (fmap text dep_archives)) + + -- compute dependencies + let dep_units = all_units ++ [homeUnitId (ue_unsafeHomeUnit $ unit_env)] + dep_map = objDepsMap `M.union` archsDepsMap + excluded_units = S.empty + dep_fun_roots = roots `S.union` rts_wired_functions `S.union` extraStaticDeps + dep_unit_roots = archsRequiredUnits ++ objRequiredUnits + + all_deps <- getDeps (fmap fst dep_map) excluded_units dep_fun_roots dep_unit_roots + + when (logVerbAtLeast logger 2) $ + logInfo logger $ hang (text "Units to link:") 2 (vcat (fmap ppr dep_units)) + -- logInfo logger $ hang (text "All deps:") 2 (vcat (fmap ppr (S.toList all_deps))) + + return (dep_map, dep_units, all_deps, rts_wired_functions, dep_archives) + + +-- | Compiled module +data ModuleCode = ModuleCode + { mc_module :: !Module + , mc_js_code :: !JStat + , mc_exports :: !B.ByteString -- ^ rendered exports + , mc_closures :: ![ClosureInfo] + , mc_statics :: ![StaticInfo] + , mc_frefs :: ![ForeignJSRef] + } + +-- | ModuleCode after link with other modules. +-- +-- It contains less information than ModuleCode because they have been commoned +-- up into global "metadata" for the whole link. +data CompactedModuleCode = CompactedModuleCode + { cmc_module :: !Module + , cmc_js_code :: !JStat + , cmc_exports :: !B.ByteString -- ^ rendered exports + } + +-- | Link modules and pretty-print them into the given Handle +renderLinker + :: Handle + -> [ModuleCode] -- ^ linked code per module + -> [FilePath] -- ^ additional JS files + -> IO LinkerStats +renderLinker h mods jsFiles = do + + -- link modules + let (compacted_mods, meta) = linkModules mods + + let + putBS = B.hPut h + putJS x = do + before <- hTell h + Ppr.printLeftRender h (pretty x) + hPutChar h '\n' + after <- hTell h + pure $! (after - before) + + --------------------------------------------------------- + -- Pretty-print JavaScript code for all the dependencies. + -- + -- We have to pretty-print at link time because we want to be able to perform + -- global link-time optimisations (e.g. renamings) on the whole generated JS + -- file. + + -- modules themselves + mod_sizes <- forM compacted_mods $ \m -> do + !mod_size <- fromIntegral <$> putJS (cmc_js_code m) + let !mod_mod = cmc_module m + pure (mod_mod, mod_size) + + -- commoned up metadata + !meta_length <- fromIntegral <$> putJS meta + + -- module exports + mapM_ (putBS . cmc_exports) compacted_mods + + -- explicit additional JS files + mapM_ (\i -> B.readFile i >>= putBS) jsFiles + + -- stats + let link_stats = LinkerStats + { bytesPerModule = M.fromList mod_sizes + , packedMetaDataSize = meta_length + } + + pure link_stats + +-- | Render linker stats +renderLinkerStats :: LinkerStats -> String +renderLinkerStats s = + intercalate "\n\n" [meta_stats, package_stats, module_stats] <> "\n\n" + where + meta = packedMetaDataSize s + meta_stats = "number of modules: " <> show (length bytes_per_mod) + <> "\npacked metadata: " <> show meta + + bytes_per_mod = M.toList $ bytesPerModule s + + show_unit (UnitId fs) = unpackFS fs + + ps :: Map UnitId Word64 + ps = M.fromListWith (+) . map (\(m,s) -> (moduleUnitId m,s)) $ bytes_per_mod + + pad :: Int -> String -> String + pad n t = let l = length t + in if l < n then t <> replicate (n-l) ' ' else t + + pkgMods :: [[(Module,Word64)]] + pkgMods = groupBy ((==) `on` (moduleUnitId . fst)) bytes_per_mod + + showMod :: (Module, Word64) -> String + showMod (m,s) = pad 40 (" " <> moduleStableString m <> ":") <> show s <> "\n" + + package_stats :: String + package_stats = "code size summary per package (in bytes):\n\n" + <> concatMap (\(p,s) -> pad 25 (show_unit p <> ":") <> show s <> "\n") (M.toList ps) + + module_stats :: String + module_stats = "code size per module (in bytes):\n\n" <> unlines (map (concatMap showMod) pkgMods) + + +getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath] +getPackageArchives cfg unit_env units = + filterM doesFileExist [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a" + | u <- units + , p <- getInstalledPackageLibDirs ue_state u + , l <- getInstalledPackageHsLibs ue_state u + ] + where + ue_state = ue_units unit_env + + -- XXX the profiling library name is probably wrong now + profSuff | csProf cfg = "_p" + | otherwise = "" + + +-- | Combine rts.js, lib.js, out.js to all.js that can be run +-- directly with node.js or SpiderMonkey jsshell +combineFiles :: JSLinkConfig + -> FilePath + -> IO () +combineFiles cfg fp = do + let files = map (fp </>) ["rts.js", "lib.js", "out.js"] + withBinaryFile (fp </> "all.js") WriteMode $ \h -> do + let cpy i = B.readFile i >>= B.hPut h + mapM_ cpy files + unless (lcNoHsMain cfg) $ do + B.hPut h runMainJS + +-- | write the index.html file that loads the program if it does not exit +writeHtml + :: FilePath -- ^ output directory + -> IO () +writeHtml out = do + let htmlFile = out </> "index.html" + e <- doesFileExist htmlFile + unless e $ + B.writeFile htmlFile templateHtml + + +templateHtml :: B.ByteString +templateHtml = + "<!DOCTYPE html>\n\ + \<html>\n\ + \ <head>\n\ + \ </head>\n\ + \ <body>\n\ + \ </body>\n\ + \ <script language=\"javascript\" src=\"all.js\" defer></script>\n\ + \</html>" + +-- | write the runmain.js file that will be run with defer so that it runs after +-- index.html is loaded +writeRunMain + :: FilePath -- ^ output directory + -> IO () +writeRunMain out = do + let runMainFile = out </> "runmain.js" + e <- doesFileExist runMainFile + unless e $ + B.writeFile runMainFile runMainJS + +runMainJS :: B.ByteString +runMainJS = "h$main(h$mainZCZCMainzimain);\n" + +writeRunner :: JSLinkConfig -- ^ Settings + -> FilePath -- ^ Output directory + -> IO () +writeRunner _settings out = do + cd <- getCurrentDirectory + let arch_os = hostPlatformArchOS + let runner = cd </> exeFileName arch_os False (Just (dropExtension out)) + srcFile = out </> "all" <.> "js" + nodePgm :: B.ByteString + nodePgm = "node" + src <- B.readFile (cd </> srcFile) + B.writeFile runner ("#!/usr/bin/env " <> nodePgm <> "\n" <> src) + perms <- getPermissions runner + setPermissions runner (perms {executable = True}) + +rtsExterns :: FastString +rtsExterns = + "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <> + mconcat (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n") + [(7::Int)..16384]) + +writeExterns :: FilePath -> IO () +writeExterns out = writeFile (out </> "all.js.externs") + $ unpackFS rtsExterns + +-- | get all dependencies for a given set of roots +getDeps :: Map Module Deps -- ^ loaded deps + -> Set LinkableUnit -- ^ don't link these blocks + -> Set ExportedFun -- ^ start here + -> [LinkableUnit] -- ^ and also link these + -> IO (Set LinkableUnit) +getDeps loaded_deps base fun startlu = go' S.empty (S.fromList startlu) (S.toList fun) + where + go :: Set LinkableUnit + -> Set LinkableUnit + -> IO (Set LinkableUnit) + go result open = case S.minView open of + Nothing -> return result + Just (lu@(lmod,n), open') -> + case M.lookup lmod loaded_deps of + Nothing -> pprPanic "getDeps.go: object file not loaded for: " (pprModule lmod) + Just (Deps _ _ _ b) -> + let block = b!n + result' = S.insert lu result + in go' result' + (addOpen result' open' $ + map (lmod,) (blockBlockDeps block)) (blockFunDeps block) + + go' :: Set LinkableUnit + -> Set LinkableUnit + -> [ExportedFun] + -> IO (Set LinkableUnit) + go' result open [] = go result open + go' result open (f:fs) = + let key = funModule f + in case M.lookup key loaded_deps of + Nothing -> pprPanic "getDeps.go': object file not loaded for: " $ pprModule key + Just (Deps _m _r e _b) -> + let lun :: Int + lun = fromMaybe (pprPanic "exported function not found: " $ ppr f) + (M.lookup f e) + lu = (key, lun) + in go' result (addOpen result open [lu]) fs + + addOpen :: Set LinkableUnit -> Set LinkableUnit -> [LinkableUnit] + -> Set LinkableUnit + addOpen result open newUnits = + let alreadyLinked s = S.member s result || + S.member s open || + S.member s base + in open `S.union` S.fromList (filter (not . alreadyLinked) newUnits) + +-- | collect dependencies for a set of roots +collectDeps :: Map Module (Deps, DepsLocation) -- ^ Dependency map + -> [UnitId] -- ^ packages, code linked in this order + -> Set LinkableUnit -- ^ All dependencides + -> IO [ModuleCode] +collectDeps mod_deps packages all_deps = do + + -- read ghc-prim first, since we depend on that for static initialization + let packages' = uncurry (++) $ partition (== primUnitId) (nub packages) + + units_by_module :: Map Module IntSet + units_by_module = M.fromListWith IS.union $ + map (\(m,n) -> (m, IS.singleton n)) (S.toList all_deps) + + mod_deps_bypkg :: Map UnitId [(Deps, DepsLocation)] + mod_deps_bypkg = M.fromListWith (++) + (map (\(m,v) -> (moduleUnitId m,[v])) (M.toList mod_deps)) + + ar_state <- emptyArchiveState + fmap (catMaybes . concat) . forM packages' $ \pkg -> + mapM (uncurry $ extractDeps ar_state units_by_module) + (fromMaybe [] $ M.lookup pkg mod_deps_bypkg) + +extractDeps :: ArchiveState + -> Map Module IntSet + -> Deps + -> DepsLocation + -> IO (Maybe ModuleCode) +extractDeps ar_state units deps loc = + case M.lookup mod units of + Nothing -> return Nothing + Just mod_units -> Just <$> do + let selector n _ = fromIntegral n `IS.member` mod_units || isGlobalUnit (fromIntegral n) + case loc of + ObjectFile fp -> do + us <- readObjectUnits fp selector + pure (collectCode us) + ArchiveFile a -> do + obj <- readArObject ar_state mod a + us <- getObjectUnits obj selector + pure (collectCode us) + InMemory _n obj -> do + us <- getObjectUnits obj selector + pure (collectCode us) + where + mod = depsModule deps + newline = BC.pack "\n" + mk_exports = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw + mk_js_code = mconcat . map oiStat + collectCode l = ModuleCode + { mc_module = mod + , mc_js_code = mk_js_code l + , mc_exports = mk_exports l + , mc_closures = concatMap oiClInfo l + , mc_statics = concatMap oiStatic l + , mc_frefs = concatMap oiFImports l + } + +readArObject :: ArchiveState -> Module -> FilePath -> IO Object +readArObject ar_state mod ar_file = do + loaded_ars <- readIORef (loadedArchives ar_state) + (Ar.Archive entries) <- case M.lookup ar_file loaded_ars of + Just a -> pure a + Nothing -> do + a <- Ar.loadAr ar_file + modifyIORef (loadedArchives ar_state) (M.insert ar_file a) + pure a + + -- look for the right object in archive + let go_entries = \case + -- XXX this shouldn't be an exception probably + [] -> panic $ "could not find object for module " + ++ moduleNameString (moduleName mod) + ++ " in " + ++ ar_file + + (e:es) -> do + let bs = Ar.filedata e + bh <- unsafeUnpackBinBuffer bs + getObjectHeader bh >>= \case + Left _ -> go_entries es -- not a valid object entry + Right mod_name + | mod_name /= moduleName mod + -> go_entries es -- not the module we're looking for + | otherwise + -> getObjectBody bh mod_name -- found it + + go_entries entries + + +-- | A helper function to read system dependencies that are hardcoded +diffDeps + :: [UnitId] -- ^ Packages that are already Linked + -> ([UnitId], Set ExportedFun) -- ^ New units and functions to link + -> ([UnitId], Set ExportedFun) -- ^ Diff +diffDeps pkgs (deps_pkgs,deps_funs) = + ( filter linked_pkg deps_pkgs + , S.filter linked_fun deps_funs + ) + where + linked_fun f = moduleUnitId (funModule f) `S.member` linked_pkgs + linked_pkg p = S.member p linked_pkgs + linked_pkgs = S.fromList pkgs + +-- | dependencies for the RTS, these need to be always linked +rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun) +rtsDeps pkgs = diffDeps pkgs $ + ( [baseUnitId, primUnitId] + , S.fromList $ concat + [ mkBaseFuns "GHC.Conc.Sync" + ["reportError"] + , mkBaseFuns "Control.Exception.Base" + ["nonTermination"] + , mkBaseFuns "GHC.Exception.Type" + [ "SomeException" + , "underflowException" + , "overflowException" + , "divZeroException" + ] + , mkBaseFuns "GHC.TopHandler" + [ "runMainIO" + , "topHandler" + ] + , mkBaseFuns "GHC.Base" + ["$fMonadIO"] + , mkBaseFuns "GHC.Maybe" + [ "Nothing" + , "Just" + ] + , mkBaseFuns "GHC.Ptr" + ["Ptr"] + , mkBaseFuns "GHC.JS.Prim" + [ "JSVal" + , "JSException" + , "$fShowJSException" + , "$fExceptionJSException" + , "resolve" + , "resolveIO" + , "toIO" + ] + , mkBaseFuns "GHC.JS.Prim.Internal" + [ "wouldBlock" + , "blockedIndefinitelyOnMVar" + , "blockedIndefinitelyOnSTM" + , "ignoreException" + , "setCurrentThreadResultException" + , "setCurrentThreadResultValue" + ] + , mkPrimFuns "GHC.Types" + [ ":" + , "[]" + ] + , mkPrimFuns "GHC.Tuple.Prim" + [ "(,)" + , "(,,)" + , "(,,,)" + , "(,,,,)" + , "(,,,,,)" + , "(,,,,,,)" + , "(,,,,,,,)" + , "(,,,,,,,,)" + , "(,,,,,,,,,)" + ] + ] + ) + +-- | Export the functions in base +mkBaseFuns :: FastString -> [FastString] -> [ExportedFun] +mkBaseFuns = mkExportedFuns baseUnitId + +-- | Export the Prim functions +mkPrimFuns :: FastString -> [FastString] -> [ExportedFun] +mkPrimFuns = mkExportedFuns primUnitId + +-- | Given a @UnitId@, a module name, and a set of symbols in the module, +-- package these into an @ExportedFun@. +mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun] +mkExportedFuns uid mod_name symbols = map mk_fun symbols + where + mod = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod_name) + mk_fun sym = ExportedFun mod (LexicalFastString (mkJsSymbol True mod sym)) + +-- | read all dependency data from the to-be-linked files +loadObjDeps :: [LinkedObj] -- ^ object files to link + -> IO (Map Module (Deps, DepsLocation), [LinkableUnit]) +loadObjDeps objs = (prepareLoadedDeps . catMaybes) <$> mapM readDepsFromObj objs + +-- | Load dependencies for the Linker from Ar +loadArchiveDeps :: GhcjsEnv + -> [FilePath] + -> IO ( Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) +loadArchiveDeps env archives = modifyMVar (linkerArchiveDeps env) $ \m -> + case M.lookup archives' m of + Just r -> return (m, r) + Nothing -> loadArchiveDeps' archives >>= \r -> return (M.insert archives' r m, r) + where + archives' = S.fromList archives + +loadArchiveDeps' :: [FilePath] + -> IO ( Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) +loadArchiveDeps' archives = do + archDeps <- forM archives $ \file -> do + (Ar.Archive entries) <- Ar.loadAr file + catMaybes <$> mapM (readEntry file) entries + return (prepareLoadedDeps $ concat archDeps) + where + readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe (Deps, DepsLocation)) + readEntry ar_file ar_entry = do + let bs = Ar.filedata ar_entry + bh <- unsafeUnpackBinBuffer bs + getObjectHeader bh >>= \case + Left _ -> pure Nothing -- not a valid object entry + Right mod_name -> do + obj <- getObjectBody bh mod_name + let !deps = objDeps obj + pure $ Just (deps, ArchiveFile ar_file) + +-- | Predicate to check that an entry in Ar is a JS source +-- and to return it without its header +getJsArchiveEntry :: Ar.ArchiveEntry -> Maybe B.ByteString +getJsArchiveEntry entry = getJsBS (Ar.filedata entry) + +-- | Predicate to check that a file is a JS source +isJsFile :: FilePath -> IO Bool +isJsFile fp = withBinaryFile fp ReadMode $ \h -> do + bs <- B.hGet h jsHeaderLength + pure (isJsBS bs) + +isJsBS :: B.ByteString -> Bool +isJsBS bs = isJust (getJsBS bs) + +-- | Get JS source with its header (if it's one) +getJsBS :: B.ByteString -> Maybe B.ByteString +getJsBS bs = B.stripPrefix jsHeader bs + +-- Header added to JS sources to discriminate them from other object files. +-- They all have .o extension but JS sources have this header. +jsHeader :: B.ByteString +jsHeader = "//JavaScript" + +jsHeaderLength :: Int +jsHeaderLength = B.length jsHeader + + + +prepareLoadedDeps :: [(Deps, DepsLocation)] + -> ( Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) +prepareLoadedDeps deps = + let req = concatMap (requiredUnits . fst) deps + depsMap = M.fromList $ map (\d -> (depsModule (fst d), d)) deps + in (depsMap, req) + +requiredUnits :: Deps -> [LinkableUnit] +requiredUnits d = map (depsModule d,) (IS.toList $ depsRequired d) + +-- | read dependencies from an object that might have already been into memory +-- pulls in all Deps from an archive +readDepsFromObj :: LinkedObj -> IO (Maybe (Deps, DepsLocation)) +readDepsFromObj = \case + ObjLoaded name obj -> do + let !deps = objDeps obj + pure $ Just (deps,InMemory name obj) + ObjFile file -> do + readObjectDeps file >>= \case + Nothing -> pure Nothing + Just deps -> pure $ Just (deps,ObjectFile file) + + +-- | Embed a JS file into a .o file +-- +-- The JS file is merely copied into a .o file with an additional header +-- ("//Javascript") in order to be recognized later on. +-- +-- JS files may contain option pragmas of the form: //#OPTIONS: +-- For now, only the CPP option is supported. If the CPP option is set, we +-- append some common CPP definitions to the file and call cpp on it. +embedJsFile :: Logger -> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO () +embedJsFile logger dflags tmpfs unit_env input_fn output_fn = do + let profiling = False -- FIXME: add support for profiling way + + createDirectoryIfMissing True (takeDirectory output_fn) + + -- the header lets the linker recognize processed JavaScript files + -- But don't add JavaScript header to object files! + + is_js_obj <- if True + then pure False + else isJsObjectFile input_fn + -- FIXME (Sylvain 2022-09): this call makes the + -- testsuite go into a loop, I don't know why yet! + -- Disabling it for now. + + if is_js_obj + then copyWithHeader "" input_fn output_fn + else do + -- header appended to JS files stored as .o to recognize them. + let header = "//JavaScript\n" + jsFileNeedsCpp input_fn >>= \case + False -> copyWithHeader header input_fn output_fn + True -> do + + -- append common CPP definitions to the .js file. + -- They define macros that avoid directly wiring zencoded names + -- in RTS JS files + pp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + payload <- B.readFile input_fn + B.writeFile pp_fn (commonCppDefs profiling <> payload) + + -- run CPP on the input JS file + js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + let + cpp_opts = CppOpts + { cppUseCc = True + , cppLinePragmas = False -- LINE pragmas aren't JS compatible + } + doCpp logger + tmpfs + dflags + unit_env + cpp_opts + pp_fn + js_fn + -- add header to recognize the object as a JS file + copyWithHeader header js_fn output_fn + +jsFileNeedsCpp :: FilePath -> IO Bool +jsFileNeedsCpp fn = do + opts <- getOptionsFromJsFile fn + pure (CPP `elem` opts) + +-- | Link module codes. +-- +-- Performs link time optimizations and produces one JStat per module plus some +-- commoned up initialization code. +linkModules :: [ModuleCode] -> ([CompactedModuleCode], JStat) +linkModules mods = (compact_mods, meta) + where + compact_mods = map compact mods + + -- here GHCJS used to: + -- - deduplicate declarations + -- - rename local variables into shorter ones + -- - compress initialization data + -- but we haven't ported it (yet). + compact m = CompactedModuleCode + { cmc_js_code = mc_js_code m + , cmc_module = mc_module m + , cmc_exports = mc_exports m + } + + -- common up statics: different bindings may reference the same statics, we + -- filter them here to initialize them once + statics = nubStaticInfo (concatMap mc_statics mods) + + infos = concatMap mc_closures mods + meta = mconcat + -- render metadata as individual statements + [ mconcat (map staticDeclStat statics) + , mconcat (map staticInitStat statics) + , mconcat (map (closureInfoStat True) infos) + ] + +-- | Only keep a single StaticInfo with a given name +nubStaticInfo :: [StaticInfo] -> [StaticInfo] +nubStaticInfo = go emptyUniqSet + where + go us = \case + [] -> [] + (x:xs) -> + -- only match on siVar. There is no reason for the initializing value to + -- be different for the same global name. + let name = siVar x + in if elementOfUniqSet name us + then go us xs + else x : go (addOneToUniqSet us name) xs + +-- | Initialize a global object. +-- +-- All global objects have to be declared (staticInfoDecl) first. +staticInitStat :: StaticInfo -> JStat +staticInitStat (StaticInfo i sv mcc) = + case sv of + StaticData con args -> appS "h$sti" $ add_cc_arg + [ var i + , var con + , jsStaticArgs args + ] + StaticFun f args -> appS "h$sti" $ add_cc_arg + [ var i + , var f + , jsStaticArgs args + ] + StaticList args mt -> appS "h$stl" $ add_cc_arg + [ var i + , jsStaticArgs args + , toJExpr $ maybe null_ (toJExpr . TxtI) mt + ] + StaticThunk (Just (f,args)) -> appS "h$stc" $ add_cc_arg + [ var i + , var f + , jsStaticArgs args + ] + _ -> mempty + where + -- add optional cost-center argument + add_cc_arg as = case mcc of + Nothing -> as + Just cc -> as ++ [toJExpr cc] + +-- | declare and do first-pass init of a global object (create JS object for heap objects) +staticDeclStat :: StaticInfo -> JStat +staticDeclStat (StaticInfo global_name static_value _) = decl + where + global_ident = TxtI global_name + decl_init v = global_ident ||= v + decl_no_init = appS "h$di" [toJExpr global_ident] + + decl = case static_value of + StaticUnboxed u -> decl_init (unboxed_expr u) + StaticThunk Nothing -> decl_no_init -- CAF initialized in an alternative way + _ -> decl_init (app "h$d" []) + + unboxed_expr = \case + StaticUnboxedBool b -> app "h$p" [toJExpr b] + StaticUnboxedInt i -> app "h$p" [toJExpr i] + StaticUnboxedDouble d -> app "h$p" [toJExpr (unSaneDouble d)] + StaticUnboxedString str -> app "h$rawStringData" [ValExpr (to_byte_list str)] + StaticUnboxedStringOffset {} -> 0 + + to_byte_list = JList . map (Int . fromIntegral) . BS.unpack diff --git a/compiler/GHC/StgToJS/Linker/Types.hs b/compiler/GHC/StgToJS/Linker/Types.hs new file mode 100644 index 0000000000..9e1714fc00 --- /dev/null +++ b/compiler/GHC/StgToJS/Linker/Types.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- for Ident's Binary instance + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Types +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Types + ( GhcjsEnv (..) + , newGhcjsEnv + , JSLinkConfig (..) + , defaultJSLinkConfig + , generateAllJs + , LinkedObj (..) + , LinkableUnit + ) +where + +import GHC.StgToJS.Object + +import GHC.Unit.Types +import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr) + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Set (Set) + +import Control.Concurrent.MVar + +import System.IO + +import Prelude + +-------------------------------------------------------------------------------- +-- Linker Config +-------------------------------------------------------------------------------- + +data JSLinkConfig = JSLinkConfig + { lcNoJSExecutables :: Bool + , lcNoHsMain :: Bool + , lcOnlyOut :: Bool + , lcNoRts :: Bool + , lcNoStats :: Bool + } + +-- | we generate a runnable all.js only if we link a complete application, +-- no incremental linking and no skipped parts +generateAllJs :: JSLinkConfig -> Bool +generateAllJs s = not (lcOnlyOut s) && not (lcNoRts s) + +defaultJSLinkConfig :: JSLinkConfig +defaultJSLinkConfig = JSLinkConfig + { lcNoJSExecutables = False + , lcNoHsMain = False + , lcOnlyOut = False + , lcNoRts = False + , lcNoStats = False + } + +-------------------------------------------------------------------------------- +-- Linker Environment +-------------------------------------------------------------------------------- + +-- | A @LinkableUnit@ is a pair of a module and the index of the block in the +-- object file +type LinkableUnit = (Module, Int) + +-- | An object file that's either already in memory (with name) or on disk +data LinkedObj + = ObjFile FilePath -- ^ load from this file + | ObjLoaded String Object -- ^ already loaded: description and payload + +instance Outputable LinkedObj where + ppr = \case + ObjFile fp -> hsep [text "ObjFile", text fp] + ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)] + +data GhcjsEnv = GhcjsEnv + { linkerArchiveDeps :: MVar (Map (Set FilePath) + (Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) + ) + } + +-- | return a fresh @GhcjsEnv@ +newGhcjsEnv :: IO GhcjsEnv +newGhcjsEnv = GhcjsEnv <$> newMVar M.empty diff --git a/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs new file mode 100644 index 0000000000..0733b73ff6 --- /dev/null +++ b/compiler/GHC/StgToJS/Linker/Utils.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Utils +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Various utilies used in the JS Linker +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Utils + ( getOptionsFromJsFile + , JSOption(..) + , jsExeFileName + , getInstalledPackageLibDirs + , getInstalledPackageHsLibs + , commonCppDefs + ) +where + +import System.FilePath +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import Data.ByteString (ByteString) + +import GHC.Driver.Session + +import GHC.Data.ShortText +import GHC.Unit.State +import GHC.Unit.Types + +import GHC.StgToJS.Types + +import Prelude +import GHC.Platform +import Data.List (isPrefixOf) +import System.IO +import Data.Char (isSpace) +import qualified Control.Exception as Exception + +-- | Retrieve library directories provided by the @UnitId@ in @UnitState@ +getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText] +getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us + +-- | Retrieve the names of the libraries provided by @UnitId@ +getInstalledPackageHsLibs :: UnitState -> UnitId -> [ShortText] +getInstalledPackageHsLibs us = maybe mempty unitLibraries . lookupUnitId us + +-- | A constant holding the JavaScript executable Filename extension +jsexeExtension :: String +jsexeExtension = "jsexe" + +-- | CPP definitions that are inserted into every .pp file +commonCppDefs :: Bool -> ByteString +commonCppDefs profiling = case profiling of + True -> commonCppDefs_profiled + False -> commonCppDefs_vanilla + +-- | CPP definitions for normal operation and profiling. Use CAFs for +-- commonCppDefs_* so that they are shared for every CPP file +commonCppDefs_vanilla, commonCppDefs_profiled :: ByteString +commonCppDefs_vanilla = genCommonCppDefs False +commonCppDefs_profiled = genCommonCppDefs True + +-- | Generate CPP Definitions depending on a profiled or normal build. This +-- occurs at link time. +genCommonCppDefs :: Bool -> ByteString +genCommonCppDefs profiling = mconcat + [ + -- constants + let mk_int_def n v = "#define " <> Char8.pack n <> " (" <> Char8.pack (show v) <> ")\n" + -- generate "#define CLOSURE_TYPE_xyz (num)" defines + mk_closure_def t = mk_int_def (ctJsName t) (ctNum t) + closure_defs = map mk_closure_def [minBound..maxBound] + -- generate "#define THREAD_xyz_xyz (num)" defines + mk_thread_def t = mk_int_def (threadStatusJsName t) (threadStatusNum t) + thread_defs = map mk_thread_def [minBound..maxBound] + in mconcat (closure_defs ++ thread_defs) + + -- low-level heap object manipulation macros + , if profiling + then mconcat + [ "#define MK_TUP2(x1,x2) (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP3(x1,x2,x3) (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP4(x1,x2,x3,x4) (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP5(x1,x2,x3,x4,x5) (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP6(x1,x2,x3,x4,x5,x6) (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7) (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + ] + else mconcat + [ "#define MK_TUP2(x1,x2) (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2)))\n" + , "#define MK_TUP3(x1,x2,x3) (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3)))\n" + , "#define MK_TUP4(x1,x2,x3,x4) (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4)))\n" + , "#define MK_TUP5(x1,x2,x3,x4,x5) (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5)))\n" + , "#define MK_TUP6(x1,x2,x3,x4,x5,x6) (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6)))\n" + , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7) (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7)))\n" + , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8)))\n" + , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9)))\n" + , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10)))\n" + ] + + , "#define TUP2_1(x) ((x).d1)\n" + , "#define TUP2_2(x) ((x).d2)\n" + + -- GHCJS.Prim.JSVal + , if profiling + then "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n" + else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x))\n" + , "#define JSVAL_VAL(x) ((x).d1)\n" + + -- GHCJS.Prim.JSException + , if profiling + then "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg),h$CCS_SYSTEM))\n" + else "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg)))\n" + + -- Exception dictionary for JSException + , "#define HS_JSEXCEPTION_EXCEPTION h$baseZCGHCziJSziPrimzizdfExceptionJSException\n" + + -- SomeException + , if profiling + then "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except),h$CCS_SYSTEM))\n" + else "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except)))\n" + + -- GHC.Ptr.Ptr + , if profiling + then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" + else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + + -- Data.Maybe.Maybe + , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" + , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" + , "#define IS_JUST(cl) ((cl).f === h$baseZCGHCziMaybeziJust_con_e)\n" + , "#define JUST_VAL(jj) ((jj).d1)\n" + -- "#define HS_NOTHING h$nothing\n" + , if profiling + then "#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val), h$CCS_SYSTEM))\n" + else "#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val)))\n" + + -- Data.List + , "#define HS_NIL h$ghczmprimZCGHCziTypesziZMZN\n" + , "#define HS_NIL_CON h$ghczmprimZCGHCziTypesziZMZN_con_e\n" + , "#define IS_CONS(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZC_con_e)\n" + , "#define IS_NIL(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZMZN_con_e)\n" + , "#define CONS_HEAD(cl) ((cl).d1)\n" + , "#define CONS_TAIL(cl) ((cl).d2)\n" + , if profiling + then mconcat + [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n" + , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), (cc)))\n" + ] + else mconcat + [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n" + , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n" + ] + + -- Data.Text + , "#define DATA_TEXT_ARRAY(x) ((x).d1)\n" + , "#define DATA_TEXT_OFFSET(x) ((x).d2.d1)\n" + , "#define DATA_TEXT_LENGTH(x) ((x).d2.d2)\n" + + -- Data.Text.Lazy + , "#define LAZY_TEXT_IS_CHUNK(x) ((x).f.a === 2)\n" + , "#define LAZY_TEXT_IS_NIL(x) ((x).f.a === 1)\n" + , "#define LAZY_TEXT_CHUNK_HEAD(x) ((x))\n" + , "#define LAZY_TEXT_CHUNK_TAIL(x) ((x).d2.d3)\n" + + -- black holes + -- can we skip the indirection for black holes? + , "#define IS_BLACKHOLE(x) (typeof (x) === 'object' && (x) && (x).f && (x).f.t === CLOSURE_TYPE_BLACKHOLE)\n" + , "#define BLACKHOLE_TID(bh) ((bh).d1)\n" + , "#define SET_BLACKHOLE_TID(bh,tid) ((bh).d1 = (tid))\n" + , "#define BLACKHOLE_QUEUE(bh) ((bh).d2)\n" + , "#define SET_BLACKHOLE_QUEUE(bh,val) ((bh).d2 = (val))\n" + + -- resumable thunks + , "#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n" + + -- general deconstruction + , "#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n" + , "#define CONSTR_TAG(x) ((x).f.a)\n" + + -- retrieve a numeric value that's possibly stored as an indirection + , "#define IS_WRAPPED_NUMBER(val) ((typeof(val)==='object')&&(val).f === h$unbox_e)\n" + , "#define UNWRAP_NUMBER(val) ((typeof(val) === 'number')?(val):(val).d1)\n" + + -- generic lazy values + , if profiling + then mconcat + [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun), h$CCS_SYSTEM))\n" + , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun), (cc)))\n" + ] + else mconcat + [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun)))\n" + , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun)))\n" + ] + + -- generic data constructors and selectors + , if profiling + then mconcat + [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_DATA2_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_AP1(fun,val) (h$c2(h$ap1_e, (fun), (val), h$CCS_SYSTEM))\n" + , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e, (fun), (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3), h$CCS_SYSTEM))\n" + ] + else mconcat + [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val)))\n" + , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2)))\n" + , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val)))\n" + , "#define MK_DATA2_2(val1,val2) (h$c2(h$data2_e, (val1), (val2)))\n" + , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val)))\n" + , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val)))\n" + , "#define MK_AP1(fun,val) (h$c2(h$ap1_e,(fun),(val)))\n" + , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e,(fun),(val1),(val2)))\n" + , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3)))\n" + ] + + -- unboxed tuple returns + -- , "#define RETURN_UBX_TUP1(x) return x;\n" + , "#define RETURN_UBX_TUP2(x1,x2) { h$ret1 = (x2); return (x1); }\n" + , "#define RETURN_UBX_TUP3(x1,x2,x3) { h$ret1 = (x2); h$ret2 = (x3); return (x1); }\n" + , "#define RETURN_UBX_TUP4(x1,x2,x3,x4) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); return (x1); }\n" + , "#define RETURN_UBX_TUP5(x1,x2,x3,x4,x5) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); return (x1); }\n" + , "#define RETURN_UBX_TUP6(x1,x2,x3,x4,x5,x6) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); return (x1); }\n" + , "#define RETURN_UBX_TUP7(x1,x2,x3,x4,x5,x6,x7) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); return (x1); }\n" + , "#define RETURN_UBX_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); return (x1); }\n" + , "#define RETURN_UBX_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); return (x1); }\n" + , "#define RETURN_UBX_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); h$ret9 = (x10); return (x1); }\n" + + , "#define CALL_UBX_TUP2(r1,r2,c) { (r1) = (c); (r2) = h$ret1; }\n" + , "#define CALL_UBX_TUP3(r1,r2,r3,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; }\n" + , "#define CALL_UBX_TUP4(r1,r2,r3,r4,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; }\n" + , "#define CALL_UBX_TUP5(r1,r2,r3,r4,r5,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; }\n" + , "#define CALL_UBX_TUP6(r1,r2,r3,r4,r5,r6,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; }\n" + , "#define CALL_UBX_TUP7(r1,r2,r3,r4,r5,r6,r7,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; }\n" + , "#define CALL_UBX_TUP8(r1,r2,r3,r4,r5,r6,r7,r8,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; }\n" + , "#define CALL_UBX_TUP9(r1,r2,r3,r4,r5,r6,r7,r8,r9,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; }\n" + , "#define CALL_UBX_TUP10(r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; (r10) = h$ret9; }\n" + ] + +-- | Construct the Filename for the "binary" of Haskell code compiled to +-- JavaScript. +jsExeFileName :: DynFlags -> FilePath +jsExeFileName dflags + | Just s <- outputFile_ dflags = + -- unmunge the extension + let s' = dropPrefix "js_" (drop 1 $ takeExtension s) + in if Prelude.null s' + then dropExtension s <.> jsexeExtension + else dropExtension s <.> s' + | otherwise = + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.jsexe" + else "a.jsexe" + where + dropPrefix prefix xs + | prefix `isPrefixOf` xs = drop (length prefix) xs + | otherwise = xs + + +-- | Parse option pragma in JS file +getOptionsFromJsFile :: FilePath -- ^ Input file + -> IO [JSOption] -- ^ Parsed options, if any. +getOptionsFromJsFile filename + = Exception.bracket + (openBinaryFile filename ReadMode) + hClose + getJsOptions + +data JSOption = CPP deriving (Eq, Ord) + +getJsOptions :: Handle -> IO [JSOption] +getJsOptions handle = do + hSetEncoding handle utf8 + prefix' <- B.hGet handle prefixLen + if prefix == prefix' + then parseJsOptions <$> hGetLine handle + else pure [] + where + prefix :: B.ByteString + prefix = "//#OPTIONS:" + prefixLen = B.length prefix + +parseJsOptions :: String -> [JSOption] +parseJsOptions xs = go xs + where + trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + go [] = [] + go xs = let (tok, rest) = break (== ',') xs + tok' = trim tok + rest' = drop 1 rest + in if | tok' == "CPP" -> CPP : go rest' + | otherwise -> go rest' diff --git a/compiler/GHC/StgToJS/Literal.hs b/compiler/GHC/StgToJS/Literal.hs new file mode 100644 index 0000000000..13549cd324 --- /dev/null +++ b/compiler/GHC/StgToJS/Literal.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Literal + ( genLit + , genStaticLit + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Ids +import GHC.StgToJS.Symbols + +import GHC.Data.FastString +import GHC.Types.Literal +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Float + +import Data.Bits as Bits +import Data.Char (ord) + +-- | Generate JS expressions for a Literal +-- +-- Literals represented with 2 values: +-- * Addr# (Null and Strings): array and offset +-- * 64-bit values: high 32-bit, low 32-bit +-- * labels: call to h$mkFunctionPtr and 0, or function name and 0 +genLit :: HasDebugCallStack => Literal -> G [JExpr] +genLit = \case + LitChar c -> return [ toJExpr (ord c) ] + LitString str -> + freshIdent >>= \strLit@(TxtI strLitT) -> + freshIdent >>= \strOff@(TxtI strOffT) -> do + emitStatic strLitT (StaticUnboxed (StaticUnboxedString str)) Nothing + emitStatic strOffT (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing + return [ ValExpr (JVar strLit), ValExpr (JVar strOff) ] + LitNullAddr -> return [ null_, ValExpr (JInt 0) ] + LitNumber nt v -> case nt of + LitNumInt -> return [ toJExpr v ] + LitNumInt8 -> return [ toJExpr v ] + LitNumInt16 -> return [ toJExpr v ] + LitNumInt32 -> return [ toJExpr v ] + LitNumInt64 -> return [ toJExpr (Bits.shiftR v 32), toU32Expr v ] + LitNumWord -> return [ toU32Expr v ] + LitNumWord8 -> return [ toU32Expr v ] + LitNumWord16 -> return [ toU32Expr v ] + LitNumWord32 -> return [ toU32Expr v ] + LitNumWord64 -> return [ toU32Expr (Bits.shiftR v 32), toU32Expr v ] + LitNumBigNat -> panic "genLit: unexpected BigNat that should have been removed in CorePrep" + LitFloat r -> return [ toJExpr (r2f r) ] + LitDouble r -> return [ toJExpr (r2d r) ] + LitLabel name _size fod + | fod == IsFunction -> return [ ApplExpr (var "h$mkFunctionPtr") + [var (mkRawSymbol True name)] + , ValExpr (JInt 0) + ] + | otherwise -> return [ toJExpr (TxtI (mkRawSymbol True name)) + , ValExpr (JInt 0) + ] + LitRubbish {} -> return [ null_ ] + +-- | generate a literal for the static init tables +genStaticLit :: Literal -> G [StaticLit] +genStaticLit = \case + LitChar c -> return [ IntLit (fromIntegral $ ord c) ] + LitString str + | True -> return [ StringLit (mkFastStringByteString str), IntLit 0] + -- \| invalid UTF8 -> return [ BinLit str, IntLit 0] + LitNullAddr -> return [ NullLit, IntLit 0 ] + LitNumber nt v -> case nt of + LitNumInt -> return [ IntLit v ] + LitNumInt8 -> return [ IntLit v ] + LitNumInt16 -> return [ IntLit v ] + LitNumInt32 -> return [ IntLit v ] + LitNumInt64 -> return [ IntLit (v `Bits.shiftR` 32), toU32Lit v ] + LitNumWord -> return [ toU32Lit v ] + LitNumWord8 -> return [ toU32Lit v ] + LitNumWord16 -> return [ toU32Lit v ] + LitNumWord32 -> return [ toU32Lit v ] + LitNumWord64 -> return [ toU32Lit (v `Bits.shiftR` 32), toU32Lit v ] + LitNumBigNat -> panic "genStaticLit: unexpected BigNat that should have been removed in CorePrep" + LitFloat r -> return [ DoubleLit . SaneDouble . r2f $ r ] + LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] + LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name) + , IntLit 0 ] + l -> pprPanic "genStaticLit" (ppr l) + +-- make an unsigned 32 bit number from this unsigned one, lower 32 bits +toU32Expr :: Integer -> JExpr +toU32Expr i = Int (i Bits..&. 0xFFFFFFFF) .>>>. 0 + +-- make an unsigned 32 bit number from this unsigned one, lower 32 bits +toU32Lit :: Integer -> StaticLit +toU32Lit i = IntLit (i Bits..&. 0xFFFFFFFF) + +r2d :: Rational -> Double +r2d = realToFrac + +r2f :: Rational -> Double +r2f = float2Double . realToFrac diff --git a/compiler/GHC/StgToJS/Monad.hs b/compiler/GHC/StgToJS/Monad.hs new file mode 100644 index 0000000000..b8deb36a63 --- /dev/null +++ b/compiler/GHC/StgToJS/Monad.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | JS codegen state monad +module GHC.StgToJS.Monad + ( runG + , emitGlobal + , addDependency + , emitToplevel + , emitStatic + , emitClosureInfo + , emitForeign + , assertRtsStat + , getSettings + , globalOccs + , setGlobalIdCache + , getGlobalIdCache + , GlobalOcc(..) + -- * Group + , modifyGroup + , resetGroup + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Transform + +import GHC.StgToJS.Types + +import GHC.Unit.Module +import GHC.Stg.Syntax + +import GHC.Types.SrcLoc +import GHC.Types.Id +import GHC.Types.Unique.FM +import GHC.Types.ForeignCall + +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.List as L + +runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a +runG config m unfloat action = State.evalStateT action =<< initState config m unfloat + +initState :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> IO GenState +initState config m unfloat = do + id_gen <- newFastMutInt 1 + pure $ GenState + { gsSettings = config + , gsModule = m + , gsId = id_gen + , gsIdents = emptyIdCache + , gsUnfloated = unfloat + , gsGroup = defaultGenGroupState + , gsGlobal = [] + } + + +modifyGroup :: (GenGroupState -> GenGroupState) -> G () +modifyGroup f = State.modify mod_state + where + mod_state s = s { gsGroup = f (gsGroup s) } + +-- | emit a global (for the current module) toplevel statement +emitGlobal :: JStat -> G () +emitGlobal stat = State.modify (\s -> s { gsGlobal = stat : gsGlobal s }) + +-- | add a dependency on a particular symbol to the current group +addDependency :: OtherSymb -> G () +addDependency symbol = modifyGroup mod_group + where + mod_group g = g { ggsExtraDeps = S.insert symbol (ggsExtraDeps g) } + +-- | emit a top-level statement for the current binding group +emitToplevel :: JStat -> G () +emitToplevel s = modifyGroup mod_group + where + mod_group g = g { ggsToplevelStats = s : ggsToplevelStats g} + +-- | emit static data for the binding group +emitStatic :: FastString -> StaticVal -> Maybe Ident -> G () +emitStatic ident val cc = modifyGroup mod_group + where + mod_group g = g { ggsStatic = mod_static (ggsStatic g) } + mod_static s = StaticInfo ident val cc : s + +-- | add closure info in our binding group. all heap objects must have closure info +emitClosureInfo :: ClosureInfo -> G () +emitClosureInfo ci = modifyGroup mod_group + where + mod_group g = g { ggsClosureInfo = ci : ggsClosureInfo g} + +emitForeign :: Maybe RealSrcSpan + -> FastString + -> Safety + -> CCallConv + -> [FastString] + -> FastString + -> G () +emitForeign mbSpan pat safety cconv arg_tys res_ty = modifyGroup mod_group + where + mod_group g = g { ggsForeignRefs = new_ref : ggsForeignRefs g } + new_ref = ForeignJSRef spanTxt pat safety cconv arg_tys res_ty + spanTxt = case mbSpan of + -- TODO: Is there a better way to concatenate FastStrings? + Just sp -> mkFastString $ + unpackFS (srcSpanFile sp) ++ + " " ++ + show (srcSpanStartLine sp, srcSpanStartCol sp) ++ + "-" ++ + show (srcSpanEndLine sp, srcSpanEndCol sp) + Nothing -> "<unknown>" + + + + + + +-- | start with a new binding group +resetGroup :: G () +resetGroup = State.modify (\s -> s { gsGroup = defaultGenGroupState }) + +defaultGenGroupState :: GenGroupState +defaultGenGroupState = GenGroupState [] [] [] [] 0 S.empty emptyGlobalIdCache [] + +emptyGlobalIdCache :: GlobalIdCache +emptyGlobalIdCache = GlobalIdCache emptyUFM + +emptyIdCache :: IdCache +emptyIdCache = IdCache M.empty + + + +assertRtsStat :: G JStat -> G JStat +assertRtsStat stat = do + s <- State.gets gsSettings + if csAssertRts s then stat else pure mempty + +getSettings :: G StgToJSConfig +getSettings = State.gets gsSettings + +getGlobalIdCache :: G GlobalIdCache +getGlobalIdCache = State.gets (ggsGlobalIdCache . gsGroup) + +setGlobalIdCache :: GlobalIdCache -> G () +setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}}) + + +data GlobalOcc = GlobalOcc + { global_ident :: !Ident + , global_id :: !Id + , global_count :: !Word + } + +-- | Return number of occurrences of every global id used in the given JStat. +-- Sort by increasing occurrence count. +globalOccs :: JStat -> G [GlobalOcc] +globalOccs jst = do + GlobalIdCache gidc <- getGlobalIdCache + -- build a map form Ident Unique to (Ident, Id, Count) + let + cmp_cnt g1 g2 = compare (global_count g1) (global_count g2) + inc g1 g2 = g1 { global_count = global_count g1 + global_count g2 } + go gids = \case + [] -> -- return global Ids used locally sorted by increased use + L.sortBy cmp_cnt $ nonDetEltsUFM gids + (i:is) -> + -- check if the Id is global + case lookupUFM gidc i of + Nothing -> go gids is + Just (_k,gid) -> + -- add it to the list of already found global ids. Increasing + -- count by 1 + let g = GlobalOcc i gid 1 + in go (addToUFM_C inc gids i g) is + + pure $ go emptyUFM (identsS jst) diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs new file mode 100644 index 0000000000..f75d27e20b --- /dev/null +++ b/compiler/GHC/StgToJS/Object.hs @@ -0,0 +1,622 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- only for DB.Binary instances on Module +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Object +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Sylvain Henry <sylvain.henry@iohk.io> +-- Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Serialization/deserialization of binary .o files for the JavaScript backend +-- The .o files contain dependency information and generated code. +-- All strings are mapped to a central string table, which helps reduce +-- file size and gives us efficient hash consing on read +-- +-- Binary intermediate JavaScript object files: +-- serialized [Text] -> ([ClosureInfo], JStat) blocks +-- +-- file layout: +-- - magic "GHCJSOBJ" +-- - compiler version tag +-- - module name +-- - offsets of string table +-- - dependencies +-- - offset of the index +-- - unit infos +-- - index +-- - string table +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Object + ( putObject + , getObjectHeader + , getObjectBody + , getObject + , readObject + , getObjectUnits + , readObjectUnits + , readObjectDeps + , isGlobalUnit + , isJsObjectFile + , Object(..) + , IndexEntry(..) + , Deps (..), BlockDeps (..), DepsLocation (..) + , ExportedFun (..) + ) +where + +import GHC.Prelude + +import Control.Monad + +import Data.Array +import Data.Int +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Word +import Data.Char +import Foreign.Storable +import Foreign.Marshal.Array +import System.IO + +import GHC.Settings.Constants (hiVersion) + +import GHC.JS.Syntax +import GHC.StgToJS.Types + +import GHC.Unit.Module + +import GHC.Data.FastString + +import GHC.Types.Unique.Map +import GHC.Float (castDoubleToWord64, castWord64ToDouble) + +import GHC.Utils.Binary hiding (SymbolTable) +import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep) +import GHC.Utils.Monad (mapMaybeM) + +-- | An object file +data Object = Object + { objModuleName :: !ModuleName + -- ^ name of the module + , objHandle :: !BinHandle + -- ^ BinHandle that can be used to read the ObjUnits + , objPayloadOffset :: !(Bin ObjUnit) + -- ^ Offset of the payload (units) + , objDeps :: !Deps + -- ^ Dependencies + , objIndex :: !Index + -- ^ The Index, serialed unit indices and their linkable units + } + +type BlockId = Int +type BlockIds = IntSet + +-- | dependencies for a single module +data Deps = Deps + { depsModule :: !Module + -- ^ module + , depsRequired :: !BlockIds + -- ^ blocks that always need to be linked when this object is loaded (e.g. + -- everything that contains initializer code or foreign exports) + , depsHaskellExported :: !(Map ExportedFun BlockId) + -- ^ exported Haskell functions -> block + , depsBlocks :: !(Array BlockId BlockDeps) + -- ^ info about each block + } + +instance Outputable Deps where + ppr d = vcat + [ hcat [ text "module: ", pprModule (depsModule d) ] + , hcat [ text "exports: ", ppr (M.keys (depsHaskellExported d)) ] + ] + +-- | Where are the dependencies +data DepsLocation + = ObjectFile FilePath -- ^ In an object file at path + | ArchiveFile FilePath -- ^ In a Ar file at path + | InMemory String Object -- ^ In memory + +instance Outputable DepsLocation where + ppr = \case + ObjectFile fp -> hsep [text "ObjectFile", text fp] + ArchiveFile fp -> hsep [text "ArchiveFile", text fp] + InMemory s o -> hsep [text "InMemory", text s, ppr (objModuleName o)] + +data BlockDeps = BlockDeps + { blockBlockDeps :: [Int] -- ^ dependencies on blocks in this object + , blockFunDeps :: [ExportedFun] -- ^ dependencies on exported symbols in other objects + -- , blockForeignExported :: [ExpFun] + -- , blockForeignImported :: [ForeignRef] + } + +{- | we use the convention that the first unit (0) is a module-global + unit that's always included when something from the module + is loaded. everything in a module implicitly depends on the + global block. the global unit itself can't have dependencies + -} +isGlobalUnit :: Int -> Bool +isGlobalUnit n = n == 0 + +-- | Exported Functions +data ExportedFun = ExportedFun + { funModule :: !Module -- ^ The module containing the function + , funSymbol :: !LexicalFastString -- ^ The function + } deriving (Eq, Ord) + +instance Outputable ExportedFun where + ppr (ExportedFun m f) = vcat + [ hcat [ text "module: ", pprModule m ] + , hcat [ text "symbol: ", ppr f ] + ] + +-- | Write an ObjUnit, except for the top level symbols which are stored in the +-- index +putObjUnit :: BinHandle -> ObjUnit -> IO () +putObjUnit bh (ObjUnit _syms b c d e f g) = do + put_ bh b + put_ bh c + lazyPut bh d + put_ bh e + put_ bh f + put_ bh g + +-- | Read an ObjUnit and associate it to the given symbols (that must have been +-- read from the index) +getObjUnit :: [FastString] -> BinHandle -> IO ObjUnit +getObjUnit syms bh = do + b <- get bh + c <- get bh + d <- lazyGet bh + e <- get bh + f <- get bh + g <- get bh + pure $ ObjUnit + { oiSymbols = syms + , oiClInfo = b + , oiStatic = c + , oiStat = d + , oiRaw = e + , oiFExports = f + , oiFImports = g + } + + +-- | A tag that determines the kind of payload in the .o file. See +-- @StgToJS.Linker.Arhive.magic@ for another kind of magic +magic :: String +magic = "GHCJSOBJ" + +-- | Serialized unit indexes and their exported symbols +-- (the first unit is module-global) +type Index = [IndexEntry] +data IndexEntry = IndexEntry + { idxSymbols :: ![FastString] -- ^ Symbols exported by a unit + , idxOffset :: !(Bin ObjUnit) -- ^ Offset of the unit in the object file + } + + +-------------------------------------------------------------------------------- +-- Essential oeprations on Objects +-------------------------------------------------------------------------------- + +-- | Given a handle to a Binary payload, add the module, 'mod_name', its +-- dependencies, 'deps', and its linkable units to the payload. +putObject + :: BinHandle + -> ModuleName -- ^ module + -> Deps -- ^ dependencies + -> [ObjUnit] -- ^ linkable units and their symbols + -> IO () +putObject bh mod_name deps os = do + forM_ magic (putByte bh . fromIntegral . ord) + put_ bh (show hiVersion) + + -- we store the module name as a String because we don't want to have to + -- decode the FastString table just to decode it when we're looking for an + -- object in an archive. + put_ bh (moduleNameString mod_name) + + (bh_fs, _bin_dict, put_dict) <- initFSTable bh + + forwardPut_ bh (const put_dict) $ do + put_ bh_fs deps + + -- forward put the index + forwardPut_ bh_fs (put_ bh_fs) $ do + idx <- forM os $ \o -> do + p <- tellBin bh_fs + -- write units without their symbols + putObjUnit bh_fs o + -- return symbols and offset to store in the index + pure (oiSymbols o,p) + pure idx + +-- | Test if the object file is a JS object +isJsObjectFile :: FilePath -> IO Bool +isJsObjectFile fp = do + let !n = length magic + withBinaryFile fp ReadMode $ \hdl -> do + allocaArray n $ \ptr -> do + n' <- hGetBuf hdl ptr n + if (n' /= n) + then pure False + else checkMagic (peekElemOff ptr) + +-- | Check magic +checkMagic :: (Int -> IO Word8) -> IO Bool +checkMagic get_byte = do + let go_magic !i = \case + [] -> pure True + (e:es) -> get_byte i >>= \case + c | fromIntegral (ord e) == c -> go_magic (i+1) es + | otherwise -> pure False + go_magic 0 magic + +-- | Parse object magic +getCheckMagic :: BinHandle -> IO Bool +getCheckMagic bh = checkMagic (const (getByte bh)) + +-- | Parse object header +getObjectHeader :: BinHandle -> IO (Either String ModuleName) +getObjectHeader bh = do + is_magic <- getCheckMagic bh + case is_magic of + False -> pure (Left "invalid magic header") + True -> do + is_correct_version <- ((== hiVersion) . read) <$> get bh + case is_correct_version of + False -> pure (Left "invalid header version") + True -> do + mod_name <- get bh + pure (Right (mkModuleName (mod_name))) + + +-- | Parse object body. Must be called after a sucessful getObjectHeader +getObjectBody :: BinHandle -> ModuleName -> IO Object +getObjectBody bh0 mod_name = do + -- Read the string table + dict <- forwardGet bh0 (getDictionary bh0) + let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict } + + deps <- get bh + idx <- forwardGet bh (get bh) + payload_pos <- tellBin bh + + pure $ Object + { objModuleName = mod_name + , objHandle = bh + , objPayloadOffset = payload_pos + , objDeps = deps + , objIndex = idx + } + +-- | Parse object +getObject :: BinHandle -> IO (Maybe Object) +getObject bh = do + getObjectHeader bh >>= \case + Left _err -> pure Nothing + Right mod_name -> Just <$> getObjectBody bh mod_name + +-- | Read object from file +-- +-- The object is still in memory after this (see objHandle). +readObject :: FilePath -> IO (Maybe Object) +readObject file = do + bh <- readBinMem file + getObject bh + +-- | Reads only the part necessary to get the dependencies +readObjectDeps :: FilePath -> IO (Maybe Deps) +readObjectDeps file = do + bh <- readBinMem file + getObject bh >>= \case + Just obj -> pure $! Just $! objDeps obj + Nothing -> pure Nothing + +-- | Get units in the object file, using the given filtering function +getObjectUnits :: Object -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit] +getObjectUnits obj pred = mapMaybeM read_entry (zip (objIndex obj) [0..]) + where + bh = objHandle obj + read_entry (e@(IndexEntry syms offset),i) + | pred i e = do + seekBin bh offset + Just <$> getObjUnit syms bh + | otherwise = pure Nothing + +-- | Read units in the object file, using the given filtering function +readObjectUnits :: FilePath -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit] +readObjectUnits file pred = do + readObject file >>= \case + Nothing -> pure [] + Just obj -> getObjectUnits obj pred + + +-------------------------------------------------------------------------------- +-- Helper functions +-------------------------------------------------------------------------------- + +putEnum :: Enum a => BinHandle -> a -> IO () +putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n) + | otherwise = put_ bh n + where n = fromIntegral $ fromEnum x :: Word16 + +getEnum :: Enum a => BinHandle -> IO a +getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16) + +-- | Helper to convert Int to Int32 +toI32 :: Int -> Int32 +toI32 = fromIntegral + +-- | Helper to convert Int32 to Int +fromI32 :: Int32 -> Int +fromI32 = fromIntegral + + +-------------------------------------------------------------------------------- +-- Binary Instances +-------------------------------------------------------------------------------- + +instance Binary IndexEntry where + put_ bh (IndexEntry a b) = put_ bh a >> put_ bh b + get bh = IndexEntry <$> get bh <*> get bh + +instance Binary Deps where + put_ bh (Deps m r e b) = do + put_ bh m + put_ bh (map toI32 $ IS.toList r) + put_ bh (map (\(x,y) -> (x, toI32 y)) $ M.toList e) + put_ bh (elems b) + get bh = Deps <$> get bh + <*> (IS.fromList . map fromI32 <$> get bh) + <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get bh) + <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get bh) + +instance Binary BlockDeps where + put_ bh (BlockDeps bbd bfd) = put_ bh bbd >> put_ bh bfd + get bh = BlockDeps <$> get bh <*> get bh + +instance Binary ForeignJSRef where + put_ bh (ForeignJSRef span pat safety cconv arg_tys res_ty) = + put_ bh span >> put_ bh pat >> putEnum bh safety >> putEnum bh cconv >> put_ bh arg_tys >> put_ bh res_ty + get bh = ForeignJSRef <$> get bh <*> get bh <*> getEnum bh <*> getEnum bh <*> get bh <*> get bh + +instance Binary ExpFun where + put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res + get bh = ExpFun <$> get bh <*> get bh <*> get bh + +instance Binary JStat where + put_ bh (DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e + put_ bh (ReturnStat e) = putByte bh 2 >> put_ bh e + put_ bh (IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 + put_ bh (WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s + put_ bh (ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (BlockStat xs) = putByte bh 8 >> put_ bh xs + put_ bh (ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es + put_ bh (UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e + put_ bh (AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 + put_ _ (UnsatBlock {}) = error "put_ bh JStat: UnsatBlock" + put_ bh (LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s + put_ bh (BreakStat ml) = putByte bh 13 >> put_ bh ml + put_ bh (ContinueStat ml) = putByte bh 14 >> put_ bh ml + get bh = getByte bh >>= \case + 1 -> DeclStat <$> get bh <*> get bh + 2 -> ReturnStat <$> get bh + 3 -> IfStat <$> get bh <*> get bh <*> get bh + 4 -> WhileStat <$> get bh <*> get bh <*> get bh + 5 -> ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> SwitchStat <$> get bh <*> get bh <*> get bh + 7 -> TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 8 -> BlockStat <$> get bh + 9 -> ApplStat <$> get bh <*> get bh + 10 -> UOpStat <$> get bh <*> get bh + 11 -> AssignStat <$> get bh <*> get bh + 12 -> LabelStat <$> get bh <*> get bh + 13 -> BreakStat <$> get bh + 14 -> ContinueStat <$> get bh + n -> error ("Binary get bh JStat: invalid tag: " ++ show n) + +instance Binary JExpr where + put_ bh (ValExpr v) = putByte bh 1 >> put_ bh v + put_ bh (SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i + put_ bh (IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2 + put_ bh (InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 + put_ bh (UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e + put_ bh (IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 + put_ bh (ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es + put_ _ (UnsatExpr {}) = error "put_ bh JExpr: UnsatExpr" + get bh = getByte bh >>= \case + 1 -> ValExpr <$> get bh + 2 -> SelExpr <$> get bh <*> get bh + 3 -> IdxExpr <$> get bh <*> get bh + 4 -> InfixExpr <$> get bh <*> get bh <*> get bh + 5 -> UOpExpr <$> get bh <*> get bh + 6 -> IfExpr <$> get bh <*> get bh <*> get bh + 7 -> ApplExpr <$> get bh <*> get bh + n -> error ("Binary get bh JExpr: invalid tag: " ++ show n) + +instance Binary JVal where + put_ bh (JVar i) = putByte bh 1 >> put_ bh i + put_ bh (JList es) = putByte bh 2 >> put_ bh es + put_ bh (JDouble d) = putByte bh 3 >> put_ bh d + put_ bh (JInt i) = putByte bh 4 >> put_ bh i + put_ bh (JStr xs) = putByte bh 5 >> put_ bh xs + put_ bh (JRegEx xs) = putByte bh 6 >> put_ bh xs + put_ bh (JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m) + put_ bh (JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s + put_ _ (UnsatVal {}) = error "put_ bh JVal: UnsatVal" + get bh = getByte bh >>= \case + 1 -> JVar <$> get bh + 2 -> JList <$> get bh + 3 -> JDouble <$> get bh + 4 -> JInt <$> get bh + 5 -> JStr <$> get bh + 6 -> JRegEx <$> get bh + 7 -> JHash . listToUniqMap <$> get bh + 8 -> JFunc <$> get bh <*> get bh + n -> error ("Binary get bh JVal: invalid tag: " ++ show n) + +instance Binary Ident where + put_ bh (TxtI xs) = put_ bh xs + get bh = TxtI <$> get bh + +-- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this +instance Binary SaneDouble where + put_ bh (SaneDouble d) + | isNaN d = putByte bh 1 + | isInfinite d && d > 0 = putByte bh 2 + | isInfinite d && d < 0 = putByte bh 3 + | isNegativeZero d = putByte bh 4 + | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d) + get bh = getByte bh >>= \case + 1 -> pure $ SaneDouble (0 / 0) + 2 -> pure $ SaneDouble (1 / 0) + 3 -> pure $ SaneDouble ((-1) / 0) + 4 -> pure $ SaneDouble (-0) + 5 -> SaneDouble . castWord64ToDouble <$> get bh + n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n) + +instance Binary ClosureInfo where + put_ bh (ClosureInfo v regs name layo typ static) = do + put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static + get bh = ClosureInfo <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh + +instance Binary JSFFIType where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary VarType where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary CIRegs where + put_ bh CIRegsUnknown = putByte bh 1 + put_ bh (CIRegs skip types) = putByte bh 2 >> put_ bh skip >> put_ bh types + get bh = getByte bh >>= \case + 1 -> pure CIRegsUnknown + 2 -> CIRegs <$> get bh <*> get bh + n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n) + +instance Binary JOp where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary JUOp where + put_ bh = putEnum bh + get bh = getEnum bh + +-- 16 bit sizes should be enough... +instance Binary CILayout where + put_ bh CILayoutVariable = putByte bh 1 + put_ bh (CILayoutUnknown size) = putByte bh 2 >> put_ bh size + put_ bh (CILayoutFixed size types) = putByte bh 3 >> put_ bh size >> put_ bh types + get bh = getByte bh >>= \case + 1 -> pure CILayoutVariable + 2 -> CILayoutUnknown <$> get bh + 3 -> CILayoutFixed <$> get bh <*> get bh + n -> error ("Binary get bh CILayout: invalid tag: " ++ show n) + +instance Binary CIStatic where + put_ bh (CIStaticRefs refs) = putByte bh 1 >> put_ bh refs + get bh = getByte bh >>= \case + 1 -> CIStaticRefs <$> get bh + n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n) + +instance Binary CIType where + put_ bh (CIFun arity regs) = putByte bh 1 >> put_ bh arity >> put_ bh regs + put_ bh CIThunk = putByte bh 2 + put_ bh (CICon conTag) = putByte bh 3 >> put_ bh conTag + put_ bh CIPap = putByte bh 4 + put_ bh CIBlackhole = putByte bh 5 + put_ bh CIStackFrame = putByte bh 6 + get bh = getByte bh >>= \case + 1 -> CIFun <$> get bh <*> get bh + 2 -> pure CIThunk + 3 -> CICon <$> get bh + 4 -> pure CIPap + 5 -> pure CIBlackhole + 6 -> pure CIStackFrame + n -> error ("Binary get bh CIType: invalid tag: " ++ show n) + +instance Binary ExportedFun where + put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb + get bh = ExportedFun <$> get bh <*> get bh + +instance Binary StaticInfo where + put_ bh (StaticInfo ident val cc) = put_ bh ident >> put_ bh val >> put_ bh cc + get bh = StaticInfo <$> get bh <*> get bh <*> get bh + +instance Binary StaticVal where + put_ bh (StaticFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args + put_ bh (StaticThunk t) = putByte bh 2 >> put_ bh t + put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u + put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args + put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t + get bh = getByte bh >>= \case + 1 -> StaticFun <$> get bh <*> get bh + 2 -> StaticThunk <$> get bh + 3 -> StaticUnboxed <$> get bh + 4 -> StaticData <$> get bh <*> get bh + 5 -> StaticList <$> get bh <*> get bh + n -> error ("Binary get bh StaticVal: invalid tag " ++ show n) + +instance Binary StaticUnboxed where + put_ bh (StaticUnboxedBool b) = putByte bh 1 >> put_ bh b + put_ bh (StaticUnboxedInt i) = putByte bh 2 >> put_ bh i + put_ bh (StaticUnboxedDouble d) = putByte bh 3 >> put_ bh d + put_ bh (StaticUnboxedString str) = putByte bh 4 >> put_ bh str + put_ bh (StaticUnboxedStringOffset str) = putByte bh 5 >> put_ bh str + get bh = getByte bh >>= \case + 1 -> StaticUnboxedBool <$> get bh + 2 -> StaticUnboxedInt <$> get bh + 3 -> StaticUnboxedDouble <$> get bh + 4 -> StaticUnboxedString <$> get bh + 5 -> StaticUnboxedStringOffset <$> get bh + n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n) + +instance Binary StaticArg where + put_ bh (StaticObjArg i) = putByte bh 1 >> put_ bh i + put_ bh (StaticLitArg p) = putByte bh 2 >> put_ bh p + put_ bh (StaticConArg c args) = putByte bh 3 >> put_ bh c >> put_ bh args + get bh = getByte bh >>= \case + 1 -> StaticObjArg <$> get bh + 2 -> StaticLitArg <$> get bh + 3 -> StaticConArg <$> get bh <*> get bh + n -> error ("Binary get bh StaticArg: invalid tag " ++ show n) + +instance Binary StaticLit where + put_ bh (BoolLit b) = putByte bh 1 >> put_ bh b + put_ bh (IntLit i) = putByte bh 2 >> put_ bh i + put_ bh NullLit = putByte bh 3 + put_ bh (DoubleLit d) = putByte bh 4 >> put_ bh d + put_ bh (StringLit t) = putByte bh 5 >> put_ bh t + put_ bh (BinLit b) = putByte bh 6 >> put_ bh b + put_ bh (LabelLit b t) = putByte bh 7 >> put_ bh b >> put_ bh t + get bh = getByte bh >>= \case + 1 -> BoolLit <$> get bh + 2 -> IntLit <$> get bh + 3 -> pure NullLit + 4 -> DoubleLit <$> get bh + 5 -> StringLit <$> get bh + 6 -> BinLit <$> get bh + 7 -> LabelLit <$> get bh <*> get bh + n -> error ("Binary get bh StaticLit: invalid tag " ++ show n) diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs new file mode 100644 index 0000000000..6085b110cf --- /dev/null +++ b/compiler/GHC/StgToJS/Prim.hs @@ -0,0 +1,1509 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} + +-- disable this warning because of all the lambdas matching on primops' +-- arguments. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.StgToJS.Prim + ( genPrim + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax hiding (JUOp (..)) +import GHC.JS.Make + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs + +import GHC.Core.Type + +import GHC.Builtin.PrimOps +import GHC.Tc.Utils.TcType (isBoolTy) +import GHC.Utils.Encoding (zEncodeString) + +import GHC.Data.FastString +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) +import Data.Maybe + + +genPrim :: Bool -- ^ Profiling (cost-centres) enabled + -> Bool -- ^ Array bounds-checking enabled + -> Type + -> PrimOp -- ^ the primitive operation + -> [JExpr] -- ^ where to store the result + -> [JExpr] -- ^ arguments + -> PrimRes +genPrim prof bound ty op = case op of + CharGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + CharGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + CharEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + CharNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + CharLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + CharLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + OrdOp -> \[r] [x] -> PrimInline $ r |= x + + Int8ToWord8Op -> \[r] [x] -> PrimInline $ r |= mask8 x + Word8ToInt8Op -> \[r] [x] -> PrimInline $ r |= signExtend8 x + Int16ToWord16Op -> \[r] [x] -> PrimInline $ r |= mask16 x + Word16ToInt16Op -> \[r] [x] -> PrimInline $ r |= signExtend16 x + Int32ToWord32Op -> \[r] [x] -> PrimInline $ r |= x .>>>. zero_ + Word32ToInt32Op -> \[r] [x] -> PrimInline $ r |= toI32 x + +------------------------------ Int ---------------------------------------------- + + IntAddOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Add x y) + IntSubOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Sub x y) + IntMulOp -> \[r] [x,y] -> PrimInline $ r |= app "h$mulInt32" [x, y] + IntMul2Op -> \[c,hr,lr] [x,y] -> PrimInline $ appT [c,hr,lr] "h$hs_timesInt2" [x, y] + IntMulMayOfloOp -> \[r] [x,y] -> PrimInline $ jVar \tmp -> mconcat + [ tmp |= Mul x y + , r |= if01 (tmp .===. toI32 tmp) + ] + IntQuotOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Div x y) + IntRemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y + IntQuotRemOp -> \[q,r] [x,y] -> PrimInline $ mconcat + [ q |= toI32 (Div x y) + , r |= x `Sub` (Mul y q) + ] + IntAndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y + IntOrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y + IntXorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y + IntNotOp -> \[r] [x] -> PrimInline $ r |= BNot x + + IntNegOp -> \[r] [x] -> PrimInline $ r |= toI32 (Negate x) +-- add with carry: overflow == 0 iff no overflow + IntAddCOp -> \[r,overf] [x,y] -> + PrimInline $ jVar \rt -> mconcat + [ rt |= Add x y + , r |= toI32 rt + , overf |= if10 (r .!=. rt) + ] + IntSubCOp -> \[r,overf] [x,y] -> + PrimInline $ jVar \rt -> mconcat + [ rt |= Sub x y + , r |= toI32 rt + , overf |= if10 (r .!=. rt) + ] + IntGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + IntGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + IntEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + IntNeOp -> \[r] [x,y] -> PrimInline $ r |= if10(x .!==. y) + IntLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + IntLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + ChrOp -> \[r] [x] -> PrimInline $ r |= x + IntToWordOp -> \[r] [x] -> PrimInline $ r |= x .>>>. 0 + IntToFloatOp -> \[r] [x] -> PrimInline $ r |= x + IntToDoubleOp -> \[r] [x] -> PrimInline $ r |= x + IntSllOp -> \[r] [x,y] -> PrimInline $ r |= x .<<. y + IntSraOp -> \[r] [x,y] -> PrimInline $ r |= x .>>. y + IntSrlOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (x .>>>. y) + +------------------------------ Int8 --------------------------------------------- + + Int8ToIntOp -> \[r] [x] -> PrimInline $ r |= x + IntToInt8Op -> \[r] [x] -> PrimInline $ r |= signExtend8 x + Int8NegOp -> \[r] [x] -> PrimInline $ r |= signExtend8 (Negate x) + Int8AddOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Add x y) + Int8SubOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Sub x y) + Int8MulOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Mul x y) + Int8QuotOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (quotShortInt 8 x y) + Int8RemOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (remShortInt 8 x y) + Int8QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat + [ r1 |= signExtend8 (quotShortInt 8 x y) + , r2 |= signExtend8 (remShortInt 8 x y) + ] + Int8EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + Int8GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .>=. (y .<<. (Int 24))) + Int8GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .>. (y .<<. (Int 24))) + Int8LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .<=. (y .<<. (Int 24))) + Int8LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .<. (y .<<. (Int 24))) + Int8NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + + Int8SraOp -> \[r] [x,i] -> PrimInline $ r |= x .>>. i + Int8SrlOp -> \[r] [x,i] -> PrimInline $ r |= signExtend8 (mask8 x .>>>. i) + Int8SllOp -> \[r] [x,i] -> PrimInline $ r |= signExtend8 (mask8 (x .<<. i)) + +------------------------------ Word8 -------------------------------------------- + + Word8ToWordOp -> \[r] [x] -> PrimInline $ r |= mask8 x + WordToWord8Op -> \[r] [x] -> PrimInline $ r |= mask8 x + + Word8AddOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Add x y) + Word8SubOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Sub x y) + Word8MulOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Mul x y) + Word8QuotOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Div x y) + Word8RemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y + Word8QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat + [ r1 |= toI32 (Div x y) + , r2 |= Mod x y + ] + Word8EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + Word8GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + Word8GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + Word8LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + Word8LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + Word8NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + + Word8AndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y + Word8OrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y + Word8XorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y + Word8NotOp -> \[r] [x] -> PrimInline $ r |= BXor x (Int 0xff) + + Word8SllOp -> \[r] [x,i] -> PrimInline $ r |= mask8 (x .<<. i) + Word8SrlOp -> \[r] [x,i] -> PrimInline $ r |= x .>>>. i + +------------------------------ Int16 ------------------------------------------- + + Int16ToIntOp -> \[r] [x] -> PrimInline $ r |= x + IntToInt16Op -> \[r] [x] -> PrimInline $ r |= signExtend16 x + + Int16NegOp -> \[r] [x] -> PrimInline $ r |= signExtend16 (Negate x) + Int16AddOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Add x y) + Int16SubOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Sub x y) + Int16MulOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Mul x y) + Int16QuotOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (quotShortInt 16 x y) + Int16RemOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (remShortInt 16 x y) + Int16QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat + [ r1 |= signExtend16 (quotShortInt 16 x y) + , r2 |= signExtend16 (remShortInt 16 x y) + ] + Int16EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + Int16GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .>=. (y .<<. (Int 16))) + Int16GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .>. (y .<<. (Int 16))) + Int16LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .<=. (y .<<. (Int 16))) + Int16LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .<. (y .<<. (Int 16))) + Int16NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + + Int16SraOp -> \[r] [x,i] -> PrimInline $ r |= x .>>. i + Int16SrlOp -> \[r] [x,i] -> PrimInline $ r |= signExtend16 (mask16 x .>>>. i) + Int16SllOp -> \[r] [x,i] -> PrimInline $ r |= signExtend16 (x .<<. i) + +------------------------------ Word16 ------------------------------------------ + + Word16ToWordOp -> \[r] [x] -> PrimInline $ r |= x + WordToWord16Op -> \[r] [x] -> PrimInline $ r |= mask16 x + + Word16AddOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Add x y) + Word16SubOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Sub x y) + Word16MulOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Mul x y) + Word16QuotOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Div x y) + Word16RemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y + Word16QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat + [ r1 |= toI32 (Div x y) + , r2 |= Mod x y + ] + Word16EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + Word16GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + Word16GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + Word16LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + Word16LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + Word16NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + + Word16AndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y + Word16OrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y + Word16XorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y + Word16NotOp -> \[r] [x] -> PrimInline $ r |= BXor x (Int 0xffff) + + Word16SllOp -> \[r] [x,i] -> PrimInline $ r |= mask16 (x .<<. i) + Word16SrlOp -> \[r] [x,i] -> PrimInline $ r |= x .>>>. i + +------------------------------ Int32 -------------------------------------------- + + Int32ToIntOp -> \[r] [x] -> PrimInline $ r |= x + IntToInt32Op -> \[r] [x] -> PrimInline $ r |= x + + Int32NegOp -> \rs xs -> genPrim prof bound ty IntNegOp rs xs + Int32AddOp -> \rs xs -> genPrim prof bound ty IntAddOp rs xs + Int32SubOp -> \rs xs -> genPrim prof bound ty IntSubOp rs xs + Int32MulOp -> \rs xs -> genPrim prof bound ty IntMulOp rs xs + Int32QuotOp -> \rs xs -> genPrim prof bound ty IntQuotOp rs xs + Int32RemOp -> \rs xs -> genPrim prof bound ty IntRemOp rs xs + Int32QuotRemOp -> \rs xs -> genPrim prof bound ty IntQuotRemOp rs xs + + Int32EqOp -> \rs xs -> genPrim prof bound ty IntEqOp rs xs + Int32GeOp -> \rs xs -> genPrim prof bound ty IntGeOp rs xs + Int32GtOp -> \rs xs -> genPrim prof bound ty IntGtOp rs xs + Int32LeOp -> \rs xs -> genPrim prof bound ty IntLeOp rs xs + Int32LtOp -> \rs xs -> genPrim prof bound ty IntLtOp rs xs + Int32NeOp -> \rs xs -> genPrim prof bound ty IntNeOp rs xs + + Int32SraOp -> \rs xs -> genPrim prof bound ty IntSraOp rs xs + Int32SrlOp -> \rs xs -> genPrim prof bound ty IntSrlOp rs xs + Int32SllOp -> \rs xs -> genPrim prof bound ty IntSllOp rs xs + +------------------------------ Word32 ------------------------------------------- + + Word32ToWordOp -> \[r] [x] -> PrimInline $ r |= x + WordToWord32Op -> \[r] [x] -> PrimInline $ r |= x + + Word32AddOp -> \rs xs -> genPrim prof bound ty WordAddOp rs xs + Word32SubOp -> \rs xs -> genPrim prof bound ty WordSubOp rs xs + Word32MulOp -> \rs xs -> genPrim prof bound ty WordMulOp rs xs + Word32QuotOp -> \rs xs -> genPrim prof bound ty WordQuotOp rs xs + Word32RemOp -> \rs xs -> genPrim prof bound ty WordRemOp rs xs + Word32QuotRemOp -> \rs xs -> genPrim prof bound ty WordQuotRemOp rs xs + + Word32EqOp -> \rs xs -> genPrim prof bound ty WordEqOp rs xs + Word32GeOp -> \rs xs -> genPrim prof bound ty WordGeOp rs xs + Word32GtOp -> \rs xs -> genPrim prof bound ty WordGtOp rs xs + Word32LeOp -> \rs xs -> genPrim prof bound ty WordLeOp rs xs + Word32LtOp -> \rs xs -> genPrim prof bound ty WordLtOp rs xs + Word32NeOp -> \rs xs -> genPrim prof bound ty WordNeOp rs xs + + Word32AndOp -> \rs xs -> genPrim prof bound ty WordAndOp rs xs + Word32OrOp -> \rs xs -> genPrim prof bound ty WordOrOp rs xs + Word32XorOp -> \rs xs -> genPrim prof bound ty WordXorOp rs xs + Word32NotOp -> \rs xs -> genPrim prof bound ty WordNotOp rs xs + + Word32SllOp -> \rs xs -> genPrim prof bound ty WordSllOp rs xs + Word32SrlOp -> \rs xs -> genPrim prof bound ty WordSrlOp rs xs + +------------------------------ Int64 -------------------------------------------- + + Int64ToIntOp -> \[r] [_h,l] -> PrimInline $ r |= toI32 l + + Int64NegOp -> \[r_h,r_l] [h,l] -> + PrimInline $ mconcat + [ r_l |= toU32 (BNot l + 1) + , r_h |= toI32 (BNot h + Not r_l) + ] + + Int64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusInt64" [h0,l0,h1,l1] + Int64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusInt64" [h0,l0,h1,l1] + Int64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesInt64" [h0,l0,h1,l1] + Int64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotInt64" [h0,l0,h1,l1] + Int64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remInt64" [h0,l0,h1,l1] + + Int64SllOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLLInt64" [h,l,n] + Int64SraOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRAInt64" [h,l,n] + Int64SrlOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRLInt64" [h,l,n] + + Int64ToWord64Op -> \[r1,r2] [x1,x2] -> + PrimInline $ mconcat + [ r1 |= toU32 x1 + , r2 |= x2 + ] + IntToInt64Op -> \[r1,r2] [x] -> + PrimInline $ mconcat + [ r1 |= if_ (x .<. 0) (-1) 0 -- sign-extension + , r2 |= toU32 x + ] + + Int64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) + Int64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) + Int64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) + Int64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) + Int64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) + Int64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) + +------------------------------ Word64 ------------------------------------------- + + Word64ToWordOp -> \[r] [_x1,x2] -> PrimInline $ r |= x2 + + WordToWord64Op -> \[rh,rl] [x] -> + PrimInline $ mconcat + [ rh |= 0 + , rl |= x + ] + + Word64ToInt64Op -> \[r1,r2] [x1,x2] -> + PrimInline $ mconcat + [ r1 |= toI32 x1 + , r2 |= x2 + ] + + Word64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) + Word64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) + Word64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) + Word64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) + Word64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) + Word64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) + + Word64SllOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLWord64" [h,l,n] + Word64SrlOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRWord64" [h,l,n] + + Word64OrOp -> \[hr,hl] [h0, l0, h1, l1] -> + PrimInline $ mconcat + [ hr |= toU32 (BOr h0 h1) + , hl |= toU32 (BOr l0 l1) + ] + + Word64AndOp -> \[hr,hl] [h0, l0, h1, l1] -> + PrimInline $ mconcat + [ hr |= toU32 (BAnd h0 h1) + , hl |= toU32 (BAnd l0 l1) + ] + + Word64XorOp -> \[hr,hl] [h0, l0, h1, l1] -> + PrimInline $ mconcat + [ hr |= toU32 (BXor h0 h1) + , hl |= toU32 (BXor l0 l1) + ] + + Word64NotOp -> \[hr,hl] [h, l] -> + PrimInline $ mconcat + [ hr |= toU32 (BNot h) + , hl |= toU32 (BNot l) + ] + + Word64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusWord64" [h0,l0,h1,l1] + Word64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusWord64" [h0,l0,h1,l1] + Word64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesWord64" [h0,l0,h1,l1] + Word64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotWord64" [h0,l0,h1,l1] + Word64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remWord64" [h0,l0,h1,l1] + +------------------------------ Word --------------------------------------------- + + WordAddOp -> \[r] [x,y] -> PrimInline $ r |= (x `Add` y) .>>>. zero_ + WordAddCOp -> \[r,c] [x,y] -> PrimInline $ + jVar \t -> mconcat + [ t |= x `Add` y + , r |= toU32 t + , c |= if10 (t .!==. r) + ] + WordSubCOp -> \[r,c] [x,y] -> + PrimInline $ mconcat + [ r |= toU32 (Sub x y) + , c |= if10 (y .>. x) + ] + WordAdd2Op -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$wordAdd2" [x,y] + WordSubOp -> \ [r] [x,y] -> PrimInline $ r |= toU32 (Sub x y) + WordMulOp -> \ [r] [x,y] -> PrimInline $ r |= app "h$mulWord32" [x, y] + WordMul2Op -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$mul2Word32" [x,y] + WordQuotOp -> \ [q] [x,y] -> PrimInline $ q |= app "h$quotWord32" [x,y] + WordRemOp -> \ [r] [x,y] -> PrimInline $ r |= app "h$remWord32" [x,y] + WordQuotRemOp -> \[q,r] [x,y] -> PrimInline $ appT [q,r] "h$quotRemWord32" [x,y] + WordQuotRem2Op -> \[q,r] [xh,xl,y] -> PrimInline $ appT [q,r] "h$quotRem2Word32" [xh,xl,y] + WordAndOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BAnd x y) + WordOrOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BOr x y) + WordXorOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BXor x y) + WordNotOp -> \[r] [x] -> PrimInline $ r |= toU32 (BNot x) + WordSllOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (x .<<. y) + WordSrlOp -> \[r] [x,y] -> PrimInline $ r |= x .>>>. y + WordToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x + WordGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + WordGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + WordEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + WordNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + WordLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + WordLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + WordToDoubleOp -> \[r] [x] -> PrimInline $ r |= x + WordToFloatOp -> \[r] [x] -> PrimInline $ r |= math_fround [x] + PopCnt8Op -> \[r] [x] -> PrimInline $ r |= var "h$popCntTab" .! (mask8 x) + PopCnt16Op -> \[r] [x] -> PrimInline $ r |= Add (var "h$popCntTab" .! (mask8 x)) + (var "h$popCntTab" .! (mask8 (x .>>>. Int 8))) + + PopCnt32Op -> \[r] [x] -> PrimInline $ r |= app "h$popCnt32" [x] + PopCnt64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$popCnt64" [x1,x2] + PopCntOp -> \[r] [x] -> genPrim prof bound ty PopCnt32Op [r] [x] + Pdep8Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep8" [s,m] + Pdep16Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep16" [s,m] + Pdep32Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep32" [s,m] + Pdep64Op -> \[ra,rb] [sa,sb,ma,mb] -> PrimInline $ appT [ra,rb] "h$pdep64" [sa,sb,ma,mb] + PdepOp -> \rs xs -> genPrim prof bound ty Pdep32Op rs xs + Pext8Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext8" [s,m] + Pext16Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext16" [s,m] + Pext32Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext32" [s,m] + Pext64Op -> \[ra,rb] [sa,sb,ma,mb] -> PrimInline $ appT [ra,rb] "h$pext64" [sa,sb,ma,mb] + PextOp -> \rs xs -> genPrim prof bound ty Pext32Op rs xs + + ClzOp -> \[r] [x] -> PrimInline $ r |= app "h$clz32" [x] + Clz8Op -> \[r] [x] -> PrimInline $ r |= app "h$clz8" [x] + Clz16Op -> \[r] [x] -> PrimInline $ r |= app "h$clz16" [x] + Clz32Op -> \[r] [x] -> PrimInline $ r |= app "h$clz32" [x] + Clz64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$clz64" [x1,x2] + CtzOp -> \[r] [x] -> PrimInline $ r |= app "h$ctz32" [x] + Ctz8Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz8" [x] + Ctz16Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz16" [x] + Ctz32Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz32" [x] + Ctz64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$ctz64" [x1,x2] + + BSwap16Op -> \[r] [x] -> PrimInline $ + r |= BOr ((mask8 x) .<<. (Int 8)) + (mask8 (x .>>>. (Int 8))) + BSwap32Op -> \[r] [x] -> PrimInline $ + r |= toU32 ((x .<<. (Int 24)) + `BOr` ((BAnd x (Int 0xFF00)) .<<. (Int 8)) + `BOr` ((BAnd x (Int 0xFF0000)) .>>. (Int 8)) + `BOr` (x .>>>. (Int 24))) + BSwap64Op -> \[r1,r2] [x,y] -> PrimInline $ appT [r1,r2] "h$bswap64" [x,y] + BSwapOp -> \[r] [x] -> genPrim prof bound ty BSwap32Op [r] [x] + + BRevOp -> \[r] [w] -> genPrim prof bound ty BRev32Op [r] [w] + BRev8Op -> \[r] [w] -> PrimInline $ r |= (app "h$reverseWord" [w] .>>>. 24) + BRev16Op -> \[r] [w] -> PrimInline $ r |= (app "h$reverseWord" [w] .>>>. 16) + BRev32Op -> \[r] [w] -> PrimInline $ r |= app "h$reverseWord" [w] + BRev64Op -> \[rh,rl] [h,l] -> PrimInline $ mconcat [ rl |= app "h$reverseWord" [h] + , rh |= app "h$reverseWord" [l] + ] + +------------------------------ Narrow ------------------------------------------- + + Narrow8IntOp -> \[r] [x] -> PrimInline $ r |= signExtend8 x + Narrow16IntOp -> \[r] [x] -> PrimInline $ r |= signExtend16 x + Narrow32IntOp -> \[r] [x] -> PrimInline $ r |= toI32 x + Narrow8WordOp -> \[r] [x] -> PrimInline $ r |= mask8 x + Narrow16WordOp -> \[r] [x] -> PrimInline $ r |= mask16 x + Narrow32WordOp -> \[r] [x] -> PrimInline $ r |= toU32 x + +------------------------------ Double ------------------------------------------- + + DoubleGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + DoubleGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + DoubleEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + DoubleNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + DoubleLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + DoubleLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + DoubleAddOp -> \[r] [x,y] -> PrimInline $ r |= Add x y + DoubleSubOp -> \[r] [x,y] -> PrimInline $ r |= Sub x y + DoubleMulOp -> \[r] [x,y] -> PrimInline $ r |= Mul x y + DoubleDivOp -> \[r] [x,y] -> PrimInline $ r |= Div x y + DoubleNegOp -> \[r] [x] -> PrimInline $ r |= Negate x + DoubleFabsOp -> \[r] [x] -> PrimInline $ r |= math_abs [x] + DoubleToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x + DoubleToFloatOp -> \[r] [x] -> PrimInline $ r |= math_fround [x] + DoubleExpOp -> \[r] [x] -> PrimInline $ r |= math_exp [x] + DoubleExpM1Op -> \[r] [x] -> PrimInline $ r |= math_expm1 [x] + DoubleLogOp -> \[r] [x] -> PrimInline $ r |= math_log [x] + DoubleLog1POp -> \[r] [x] -> PrimInline $ r |= math_log1p [x] + DoubleSqrtOp -> \[r] [x] -> PrimInline $ r |= math_sqrt [x] + DoubleSinOp -> \[r] [x] -> PrimInline $ r |= math_sin [x] + DoubleCosOp -> \[r] [x] -> PrimInline $ r |= math_cos [x] + DoubleTanOp -> \[r] [x] -> PrimInline $ r |= math_tan [x] + DoubleAsinOp -> \[r] [x] -> PrimInline $ r |= math_asin [x] + DoubleAcosOp -> \[r] [x] -> PrimInline $ r |= math_acos [x] + DoubleAtanOp -> \[r] [x] -> PrimInline $ r |= math_atan [x] + DoubleSinhOp -> \[r] [x] -> PrimInline $ r |= math_sinh [x] + DoubleCoshOp -> \[r] [x] -> PrimInline $ r |= math_cosh [x] + DoubleTanhOp -> \[r] [x] -> PrimInline $ r |= math_tanh [x] + DoubleAsinhOp -> \[r] [x] -> PrimInline $ r |= math_asinh [x] + DoubleAcoshOp -> \[r] [x] -> PrimInline $ r |= math_acosh [x] + DoubleAtanhOp -> \[r] [x] -> PrimInline $ r |= math_atanh [x] + DoublePowerOp -> \[r] [x,y] -> PrimInline $ r |= math_pow [x,y] + DoubleDecode_2IntOp -> \[s,h,l,e] [x] -> PrimInline $ appT [s,h,l,e] "h$decodeDouble2Int" [x] + DoubleDecode_Int64Op -> \[s1,s2,e] [d] -> PrimInline $ appT [e,s1,s2] "h$decodeDoubleInt64" [d] + +------------------------------ Float -------------------------------------------- + + FloatGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + FloatGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + FloatEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + FloatNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + FloatLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + FloatLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + FloatAddOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Add x y] + FloatSubOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Sub x y] + FloatMulOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Mul x y] + FloatDivOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Div x y] + FloatNegOp -> \[r] [x] -> PrimInline $ r |= Negate x + FloatFabsOp -> \[r] [x] -> PrimInline $ r |= math_abs [x] + FloatToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x + FloatExpOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_exp [x]] + FloatExpM1Op -> \[r] [x] -> PrimInline $ r |= math_fround [math_expm1 [x]] + FloatLogOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_log [x]] + FloatLog1POp -> \[r] [x] -> PrimInline $ r |= math_fround [math_log1p [x]] + FloatSqrtOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sqrt [x]] + FloatSinOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sin [x]] + FloatCosOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_cos [x]] + FloatTanOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_tan [x]] + FloatAsinOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_asin [x]] + FloatAcosOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_acos [x]] + FloatAtanOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_atan [x]] + FloatSinhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sinh [x]] + FloatCoshOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_cosh [x]] + FloatTanhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_tanh [x]] + FloatAsinhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_asinh [x]] + FloatAcoshOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_acosh [x]] + FloatAtanhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_atanh [x]] + FloatPowerOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [math_pow [x,y]] + FloatToDoubleOp -> \[r] [x] -> PrimInline $ r |= x + FloatDecode_IntOp -> \[s,e] [x] -> PrimInline $ appT [s,e] "h$decodeFloatInt" [x] + +------------------------------ Arrays ------------------------------------------- + + NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) + ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a + UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a + CopyArrayOp -> \[] [a,o1,ma,o2,n] -> + PrimInline $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] + FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ + jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] + +------------------------------ Small Arrays ------------------------------------- + + NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a + UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a + CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ + loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ + loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] + +------------------------------- Byte Arrays ------------------------------------- + + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a i $ jVar \t -> mconcat + [ t |= a .^ "arr" + , ifBlockS (t .&&. t .! (i .<<. two_)) + [ r1 |= t .! (i .<<. two_) .! zero_ + , r2 |= t .! (i .<<. two_) .! one_ + ] + [ r1 |= null_ + , r2 |= zero_ + ] + ] + + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a (Add i 3) $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_i32 a i + ] + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_i32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_u32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a (Add i 3) $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_i32 a i + ] + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_i32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_u32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) + ] + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 + + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ write_i32 a (Add (i .<<. one_) one_) e1 + , write_u32 a (i .<<. one_) e2 + ] + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ write_u32 a (Add (i .<<. one_) one_) h + , write_u32 a (i .<<. one_) l + ] + CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> + PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) + . boundsChecked bound a2 (Add o2 (Sub n 1)) + $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] + + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) + . boundsChecked bound a2 (Add o2 (Sub n 1)) + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ write_u8 a2 (Add i o2) (read_u8 a1 (Add i o1)) + , postDecrS i + ] + CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + + SetByteArrayOp -> \[] [a,o,n,v] -> + PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + [ write_u8 a (Add o i) v + , postIncrS i + ] + + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + +------------------------------- Addr# ------------------------------------------ + + AddrAddOp -> \[a',o'] [a,o,i] -> PrimInline $ mconcat [a' |= a, o' |= Add o i] + AddrSubOp -> \[i] [_a1,o1,_a2,o2] -> PrimInline $ i |= Sub o1 o2 + AddrRemOp -> \[r] [_a,o,i] -> PrimInline $ r |= Mod o i + AddrToIntOp -> \[i] [_a,o] -> PrimInline $ i |= o -- only usable for comparisons within one range + IntToAddrOp -> \[a,o] [i] -> PrimInline $ mconcat [a |= null_, o |= i] + AddrGtOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>. zero_) + AddrGeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>=. zero_) + AddrEqOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .===. zero_) + AddrNeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .!==. zero_) + AddrLtOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<. zero_) + AddrLeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<=. zero_) + +------------------------------- Addr Indexing: Unboxed Arrays ------------------- + + IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> + PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) + $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) + [ ca |= a .^ "arr" .! (off32 o i) .! zero_ + , co |= a .^ "arr" .! (off32 o i) .! one_ + ] + [ ca |= null_ + , co |= zero_ + ] + IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat + [ c1 |= var "h$stablePtrBuf" + , c2 |= read_boff_i32 a (off32 o i) + ] + IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) + , l |= read_boff_u32 a (off64 o i) + ] + IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) + , l |= read_boff_u32 a (off64 o i) + ] + ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") (Add o x) $ + ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) + [ c1 |= a .^ "arr" .! (Add o x) .! zero_ + , c2 |= a .^ "arr" .! (Add o x) .! one_ + ] + [ c1 |= null_ + , c2 |= zero_ + ] + ] + ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat + [ c1 |= var "h$stablePtrBuf" + , c2 |= read_boff_u32 a (off32 o i) + ] + ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_i32 a (Add (off64 o i) (Int 4)) + , l |= read_u32 a (off64 o i) + ] + ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> + PrimInline $ mconcat + [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) + , c2 |= read_boff_u32 a (off64 o i) + ] + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , boundsChecked bound (a .^ "arr") (off32 o i) $ + AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) + ] + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat + [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 + , write_boff_u32 a (off64 o i) v2 + ] + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat + [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 + , write_boff_u32 a (off64 o i) v2 + ] +-- Mutable variables + NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) + ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" + WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x + AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f] + AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f] + + CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o) + (mconcat [status |= zero_, r |= n, mv .^ "val" |= n]) + (mconcat [status |= one_ , r |= mv .^ "val"]) + +------------------------------- Exceptions -------------------------------------- + + CatchOp -> \[_r] [a,handler] -> PRPrimCall $ returnS (app "h$catch" [a, handler]) + + -- fully ignore the result arity as it can use 1 or 2 + -- slots, depending on the return type. + RaiseOp -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_]) + RaiseIOOp -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_]) + RaiseUnderflowOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypeziunderflowException", false_]) + RaiseOverflowOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezioverflowException", false_]) + RaiseDivZeroOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezidivZZeroException", false_]) + MaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$maskAsync" [a]) + MaskUninterruptibleOp -> \_r [a] -> PRPrimCall $ returnS (app "h$maskUnintAsync" [a]) + UnmaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$unmaskAsync" [a]) + + MaskStatus -> \[r] [] -> PrimInline $ r |= app "h$maskStatus" [] + +------------------------------- STM-accessible Mutable Variables -------------- + + AtomicallyOp -> \[_r] [a] -> PRPrimCall $ returnS (app "h$atomically" [a]) + RetryOp -> \_r [] -> PRPrimCall $ returnS (app "h$stmRetry" []) + CatchRetryOp -> \[_r] [a,b] -> PRPrimCall $ returnS (app "h$stmCatchRetry" [a,b]) + CatchSTMOp -> \[_r] [a,h] -> PRPrimCall $ returnS (app "h$catchStm" [a,h]) + NewTVarOp -> \[tv] [v] -> PrimInline $ tv |= app "h$newTVar" [v] + ReadTVarOp -> \[r] [tv] -> PrimInline $ r |= app "h$readTVar" [tv] + ReadTVarIOOp -> \[r] [tv] -> PrimInline $ r |= app "h$readTVarIO" [tv] + WriteTVarOp -> \[] [tv,v] -> PrimInline $ appS "h$writeTVar" [tv,v] + +------------------------------- Synchronized Mutable Variables ------------------ + + NewMVarOp -> \[r] [] -> PrimInline $ r |= New (app "h$MVar" []) + TakeMVarOp -> \[_r] [m] -> PRPrimCall $ returnS (app "h$takeMVar" [m]) + TryTakeMVarOp -> \[r,v] [m] -> PrimInline $ appT [r,v] "h$tryTakeMVar" [m] + PutMVarOp -> \[] [m,v] -> PRPrimCall $ returnS (app "h$putMVar" [m,v]) + TryPutMVarOp -> \[r] [m,v] -> PrimInline $ r |= app "h$tryPutMVar" [m,v] + ReadMVarOp -> \[_r] [m] -> PRPrimCall $ returnS (app "h$readMVar" [m]) + TryReadMVarOp -> \[r,v] [m] -> PrimInline $ mconcat + [ v |= m .^ "val" + , r |= if01 (v .===. null_) + ] + IsEmptyMVarOp -> \[r] [m] -> PrimInline $ r |= if10 (m .^ "val" .===. null_) + +------------------------------- Delay/Wait Ops --------------------------------- + + DelayOp -> \[] [t] -> PRPrimCall $ returnS (app "h$delayThread" [t]) + WaitReadOp -> \[] [fd] -> PRPrimCall $ returnS (app "h$waidRead" [fd]) + WaitWriteOp -> \[] [fd] -> PRPrimCall $ returnS (app "h$waitWrite" [fd]) + +------------------------------- Concurrency Primitives ------------------------- + + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ r |= var "h$threads" + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + +------------------------------- Weak Pointers ----------------------------------- + + MkWeakOp -> \[r] [o,b,c] -> PrimInline $ r |= app "h$makeWeak" [o,b,c] + MkWeakNoFinalizerOp -> \[r] [o,b] -> PrimInline $ r |= app "h$makeWeakNoFinalizer" [o,b] + AddCFinalizerToWeakOp -> \[r] [_a1,_a1o,_a2,_a2o,_i,_a3,_a3o,_w] -> PrimInline $ r |= one_ + DeRefWeakOp -> \[f,v] [w] -> PrimInline $ mconcat + [ v |= w .^ "val" + , f |= if01 (v .===. null_) + ] + FinalizeWeakOp -> \[fl,fin] [w] -> PrimInline $ appT [fin, fl] "h$finalizeWeak" [w] + TouchOp -> \[] [_e] -> PrimInline mempty + KeepAliveOp -> \[_r] [x, f] -> PRPrimCall $ ReturnStat (app "h$keepAlive" [x, f]) + + +------------------------------ Stable pointers and names ------------------------ + + MakeStablePtrOp -> \[s1,s2] [a] -> PrimInline $ mconcat + [ s1 |= var "h$stablePtrBuf" + , s2 |= app "h$makeStablePtr" [a] + ] + DeRefStablePtrOp -> \[r] [_s1,s2] -> PrimInline $ r |= app "h$deRefStablePtr" [s2] + EqStablePtrOp -> \[r] [_sa1,sa2,_sb1,sb2] -> PrimInline $ r |= if10 (sa2 .===. sb2) + + MakeStableNameOp -> \[r] [a] -> PrimInline $ r |= app "h$makeStableName" [a] + StableNameToIntOp -> \[r] [s] -> PrimInline $ r |= app "h$stableNameInt" [s] + +------------------------------ Compact normal form ----------------------------- + + CompactNewOp -> \[c] [s] -> PrimInline $ c |= app "h$compactNew" [s] + CompactResizeOp -> \[] [c,s] -> PrimInline $ appS "h$compactResize" [c,s] + CompactContainsOp -> \[r] [c,v] -> PrimInline $ r |= app "h$compactContains" [c,v] + CompactContainsAnyOp -> \[r] [v] -> PrimInline $ r |= app "h$compactContainsAny" [v] + CompactGetFirstBlockOp -> \[ra,ro,s] [c] -> + PrimInline $ appT [ra,ro,s] "h$compactGetFirstBlock" [c] + CompactGetNextBlockOp -> \[ra,ro,s] [c,a,o] -> + PrimInline $ appT [ra,ro,s] "h$compactGetNextBlock" [c,a,o] + CompactAllocateBlockOp -> \[ra,ro] [size,sa,so] -> + PrimInline $ appT [ra,ro] "h$compactAllocateBlock" [size,sa,so] + CompactFixupPointersOp -> \[c,newroota, newrooto] [blocka,blocko,roota,rooto] -> + PrimInline $ appT [c,newroota,newrooto] "h$compactFixupPointers" [blocka,blocko,roota,rooto] + CompactAdd -> \[_r] [c,o] -> + PRPrimCall $ returnS (app "h$compactAdd" [c,o]) + CompactAddWithSharing -> \[_r] [c,o] -> + PRPrimCall $ returnS (app "h$compactAddWithSharing" [c,o]) + CompactSize -> \[s] [c] -> + PrimInline $ s |= app "h$compactSize" [c] + +------------------------------ Unsafe pointer equality -------------------------- + + ReallyUnsafePtrEqualityOp -> \[r] [p1,p2] -> PrimInline $ r |= if10 (p1 .===. p2) + +------------------------------ Parallelism -------------------------------------- + + ParOp -> \[r] [_a] -> PrimInline $ r |= zero_ + SparkOp -> \[r] [a] -> PrimInline $ r |= a + SeqOp -> \[_r] [e] -> PRPrimCall $ returnS (app "h$e" [e]) + NumSparks -> \[r] [] -> PrimInline $ r |= zero_ + +------------------------------ Tag to enum stuff -------------------------------- + + DataToTagOp -> \[_r] [d] -> PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] + TagToEnumOp -> \[r] [tag] -> if + | isBoolTy ty -> PrimInline $ r |= IfExpr tag true_ false_ + | otherwise -> PrimInline $ r |= app "h$tagToEnum" [tag] + +------------------------------ Bytecode operations ------------------------------ + + AddrToAnyOp -> \[r] [d,_o] -> PrimInline $ r |= d + +------------------------------ Profiling (CCS) ------------------------------ + + GetCCSOfOp -> \[a, o] [obj] -> if + | prof -> PrimInline $ mconcat + [ a |= if_ (isObject obj) + (app "h$buildCCSPtr" [obj .^ "cc"]) + null_ + , o |= zero_ + ] + | otherwise -> PrimInline $ mconcat + [ a |= null_ + , o |= zero_ + ] + + GetCurrentCCSOp -> \[a, o] [_dummy_arg] -> + let ptr = if prof then app "h$buildCCSPtr" [jCurrentCCS] + else null_ + in PrimInline $ mconcat + [ a |= ptr + , o |= zero_ + ] + + ClearCCSOp -> \[_r] [x] -> PRPrimCall $ ReturnStat (app "h$clearCCS" [x]) + +------------------------------ Eventlog ------------------- + + TraceEventOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceEvent" [ed,eo] + TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] + TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") x $ + ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> + PrimInline $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_boff_i32 a i + ] + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_boff_u32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") x $ + ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> + PrimInline $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_boff_i32 a i + ] + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_boff_u32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , boundsChecked bound (a .^ "arr") (i .<<. two_) $ + a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) + ] + + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> + -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i + -- then write the higher 4 bytes to i+4 + PrimInline . boundsChecked bound a i + $ mconcat [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> + PrimInline . boundsChecked bound a (Add i 7) + $ mconcat [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new + CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new + CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new + CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new + + CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ + jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) + , t_l |= read_u32 a (i .<<. one_) + , r_h |= t_h + , r_l |= t_l + , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast + (ifBlockS (t_h .===. old_h) + -- Pre-Condition is good, do the write + [ write_i32 a (Add (i .<<. one_) one_) new_h + , write_u32 a (i .<<. one_) new_l + ] + -- no good, don't write + mempty) + mempty + ] + + CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ + mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) + (appS "h$memcpy" [a3,o3,a1,o1,8]) + mempty + , r_a |= a1 + , r_o |= o1 + ] + CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new + CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new + CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new + CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new + CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ + mconcat [ r_h |= read_u32 a (Add o (Int 4)) + , r_l |= read_u32 a o + , ifS (r_l .===. old_l) + (ifBlockS (r_h .===. old_h) + [ write_u32 a (Add o (Int 4)) new_h + , write_u32 a o new_l + ] + mempty) + mempty + ] + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v + FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v + FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v + FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v + + InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ + -- this primop can't be implemented + -- correctly because we don't store + -- the array reference part of an Addr#, + -- only the offset part. + -- + -- So let's assume that all the array + -- references are the same... + -- + -- Note: we could generate an assert + -- that checks that a1 === a2. However + -- we can't check that the Addr# read + -- at Addr# a2[o2] also comes from this + -- a1/a2 array. + mconcat [ r_a |= a1 -- might be wrong (see above) + , r_o |= read_boff_u32 a1 o1 + -- TODO (see above) + -- assert that a1 === a2 + , write_boff_u32 a1 o1 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ + mconcat [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] + + ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] + GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + + AtomicReadAddrOp_Word -> \[r] [a,o] -> PrimInline $ r |= read_boff_u32 a o + AtomicWriteAddrOp_Word -> \[] [a,o,w] -> PrimInline $ write_boff_u32 a o w + + +------------------------------ Unhandled primops ------------------- + + NewPromptTagOp -> unhandledPrimop op + PromptOp -> unhandledPrimop op + Control0Op -> unhandledPrimop op + + NewIOPortOp -> unhandledPrimop op + ReadIOPortOp -> unhandledPrimop op + WriteIOPortOp -> unhandledPrimop op + + GetSparkOp -> unhandledPrimop op + AnyToAddrOp -> unhandledPrimop op + MkApUpd0_Op -> unhandledPrimop op + NewBCOOp -> unhandledPrimop op + UnpackClosureOp -> unhandledPrimop op + ClosureSizeOp -> unhandledPrimop op + GetApStackValOp -> unhandledPrimop op + WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n + + SetThreadAllocationCounter -> unhandledPrimop op + +------------------------------- Vector ----------------------------------------- +-- For now, vectors are unsupported on the JS backend. Simply put, they do not +-- make much sense to support given support for arrays and lack of SIMD support +-- in JS. We could try to roll something special but we would not be able to +-- give any performance guarentees to the user and so we leave these has +-- unhandled for now. + VecBroadcastOp _ _ _ -> unhandledPrimop op + VecPackOp _ _ _ -> unhandledPrimop op + VecUnpackOp _ _ _ -> unhandledPrimop op + VecInsertOp _ _ _ -> unhandledPrimop op + VecAddOp _ _ _ -> unhandledPrimop op + VecSubOp _ _ _ -> unhandledPrimop op + VecMulOp _ _ _ -> unhandledPrimop op + VecDivOp _ _ _ -> unhandledPrimop op + VecQuotOp _ _ _ -> unhandledPrimop op + VecRemOp _ _ _ -> unhandledPrimop op + VecNegOp _ _ _ -> unhandledPrimop op + VecIndexByteArrayOp _ _ _ -> unhandledPrimop op + VecReadByteArrayOp _ _ _ -> unhandledPrimop op + VecWriteByteArrayOp _ _ _ -> unhandledPrimop op + VecIndexOffAddrOp _ _ _ -> unhandledPrimop op + VecReadOffAddrOp _ _ _ -> unhandledPrimop op + VecWriteOffAddrOp _ _ _ -> unhandledPrimop op + + VecIndexScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecReadScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecWriteScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecIndexScalarOffAddrOp _ _ _ -> unhandledPrimop op + VecReadScalarOffAddrOp _ _ _ -> unhandledPrimop op + VecWriteScalarOffAddrOp _ _ _ -> unhandledPrimop op + + PrefetchByteArrayOp3 -> noOp + PrefetchMutableByteArrayOp3 -> noOp + PrefetchAddrOp3 -> noOp + PrefetchValueOp3 -> noOp + PrefetchByteArrayOp2 -> noOp + PrefetchMutableByteArrayOp2 -> noOp + PrefetchAddrOp2 -> noOp + PrefetchValueOp2 -> noOp + PrefetchByteArrayOp1 -> noOp + PrefetchMutableByteArrayOp1 -> noOp + PrefetchAddrOp1 -> noOp + PrefetchValueOp1 -> noOp + PrefetchByteArrayOp0 -> noOp + PrefetchMutableByteArrayOp0 -> noOp + PrefetchAddrOp0 -> noOp + PrefetchValueOp0 -> noOp + +unhandledPrimop :: PrimOp -> [JExpr] -> [JExpr] -> PrimRes +unhandledPrimop op rs as = PrimInline $ mconcat + [ appS "h$log" [toJExpr $ mconcat + [ "warning, unhandled primop: " + , renderWithContext defaultSDocContext (ppr op) + , " " + , show (length rs, length as) + ]] + , appS (mkFastString $ "h$primop_" ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as + -- copyRes + , mconcat $ zipWith (\r reg -> r |= toJExpr reg) rs (enumFrom Ret1) + ] + +-- | A No Op, used for primops the JS platform cannot or do not support. For +-- example, the prefetching primops do not make sense on the JS platform because +-- we do not have enough control over memory to provide any kind of prefetching +-- mechanism. Hence, these are NoOps. +noOp :: Foldable f => f a -> f a -> PrimRes +noOp = const . const $ PrimInline mempty + +-- tuple returns +appT :: [JExpr] -> FastString -> [JExpr] -> JStat +appT [] f xs = appS f xs +appT (r:rs) f xs = mconcat + [ r |= app f xs + , mconcat (zipWith (\r ret -> r |= toJExpr ret) rs (enumFrom Ret1)) + ] + +-------------------------------------------- +-- ByteArray indexing +-------------------------------------------- + +-- For every ByteArray, the RTS creates the following views: +-- i3: Int32 view +-- u8: Word8 view +-- u1: Word16 view +-- f3: Float32 view +-- f6: Float64 view +-- dv: generic DataView +-- It seems a bit weird to mix Int and Word views like this, but perhaps they +-- are the more common. +-- +-- See 'h$newByteArray' in 'ghc/rts/js/mem.js' for details. +-- +-- Note that *byte* indexing can only be done with the generic DataView. Use +-- read_boff_* and write_boff_* for this. +-- +-- Other read_* and write_* helpers directly use the more specific views. +-- Prefer using them over idx_* to make your intent clearer. + +idx_i32, idx_u8, idx_u16, idx_f64, idx_f32 :: JExpr -> JExpr -> JExpr +idx_i32 a i = IdxExpr (a .^ "i3") i +idx_u8 a i = IdxExpr (a .^ "u8") i +idx_u16 a i = IdxExpr (a .^ "u1") i +idx_f64 a i = IdxExpr (a .^ "f6") i +idx_f32 a i = IdxExpr (a .^ "f3") i + +read_u8 :: JExpr -> JExpr -> JExpr +read_u8 a i = idx_u8 a i + +read_u16 :: JExpr -> JExpr -> JExpr +read_u16 a i = idx_u16 a i + +read_u32 :: JExpr -> JExpr -> JExpr +read_u32 a i = toU32 (idx_i32 a i) + +read_i8 :: JExpr -> JExpr -> JExpr +read_i8 a i = signExtend8 (idx_u8 a i) + +read_i16 :: JExpr -> JExpr -> JExpr +read_i16 a i = signExtend16 (idx_u16 a i) + +read_i32 :: JExpr -> JExpr -> JExpr +read_i32 a i = idx_i32 a i + +read_f32 :: JExpr -> JExpr -> JExpr +read_f32 a i = idx_f32 a i + +read_f64 :: JExpr -> JExpr -> JExpr +read_f64 a i = idx_f64 a i + +write_u8 :: JExpr -> JExpr -> JExpr -> JStat +write_u8 a i v = idx_u8 a i |= v + +write_u16 :: JExpr -> JExpr -> JExpr -> JStat +write_u16 a i v = idx_u16 a i |= v + +write_u32 :: JExpr -> JExpr -> JExpr -> JStat +write_u32 a i v = idx_i32 a i |= v + +write_i8 :: JExpr -> JExpr -> JExpr -> JStat +write_i8 a i v = idx_u8 a i |= v + +write_i16 :: JExpr -> JExpr -> JExpr -> JStat +write_i16 a i v = idx_u16 a i |= v + +write_i32 :: JExpr -> JExpr -> JExpr -> JStat +write_i32 a i v = idx_i32 a i |= v + +write_f32 :: JExpr -> JExpr -> JExpr -> JStat +write_f32 a i v = idx_f32 a i |= v + +write_f64 :: JExpr -> JExpr -> JExpr -> JStat +write_f64 a i v = idx_f64 a i |= v + +-- Data View helper functions: byte indexed! +-- +-- The argument list consists of the array @a@, the index @i@, and the new value +-- to set (in the case of a setter) @v@. + +write_boff_i8, write_boff_u8, write_boff_i16, write_boff_u16, write_boff_i32, write_boff_u32, write_boff_f32, write_boff_f64 :: JExpr -> JExpr -> JExpr -> JStat +write_boff_i8 a i v = write_i8 a i v +write_boff_u8 a i v = write_u8 a i v +write_boff_i16 a i v = ApplStat (a .^ "dv" .^ "setInt16" ) [i, v, true_] +write_boff_u16 a i v = ApplStat (a .^ "dv" .^ "setUint16" ) [i, v, true_] +write_boff_i32 a i v = ApplStat (a .^ "dv" .^ "setInt32" ) [i, v, true_] +write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] +write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] +write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] + +read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr +read_boff_i8 a i = read_i8 a i +read_boff_u8 a i = read_u8 a i +read_boff_i16 a i = ApplExpr (a .^ "dv" .^ "getInt16" ) [i, true_] +read_boff_u16 a i = ApplExpr (a .^ "dv" .^ "getUint16" ) [i, true_] +read_boff_i32 a i = ApplExpr (a .^ "dv" .^ "getInt32" ) [i, true_] +read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] +read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] +read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] + +fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +fetchOpByteArray op tgt src i v = mconcat + [ tgt |= read_i32 src i + , write_i32 src i (op tgt v) + ] + +fetchOpAddr :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +fetchOpAddr op tgt src i v = mconcat + [ tgt |= read_boff_u32 src i + , write_boff_u32 src i (op tgt v) + ] + +casOp + :: (JExpr -> JExpr -> JExpr) -- read + -> (JExpr -> JExpr -> JExpr -> JStat) -- write + -> JExpr -- target register to store result + -> JExpr -- source arrays + -> JExpr -- index + -> JExpr -- old value to compare + -> JExpr -- new value to write + -> JStat +casOp read write tgt src i old new = mconcat + [ tgt |= read src i + , ifS (tgt .===. old) + (write src i new) + mempty + ] + +-------------------------------------------------------------------------------- +-- Lifted Arrays +-------------------------------------------------------------------------------- +-- | lifted arrays +cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat +cloneArray tgt src mb_offset len = mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, end] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] + where + start = fromMaybe zero_ mb_offset + end = maybe len (Add len) mb_offset + +newArray :: JExpr -> JExpr -> JExpr -> JStat +newArray tgt len elem = + tgt |= app "h$newArray" [len, elem] + +newByteArray :: JExpr -> JExpr -> JStat +newByteArray tgt len = + tgt |= app "h$newByteArray" [len] + +boundsChecked :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +boundsChecked False _ _ r = r +boundsChecked True xs i r = + ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) + r + (returnS $ app "h$exitProcess" [Int 134]) + +-- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 +-- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. +-- So (x|0) * (y|0) can still return values outside of the Int32 range. You have +-- been warned! +toI32 :: JExpr -> JExpr +toI32 e = BOr e zero_ + +-- e>>>0 (32 bit unsigned integer truncation) +-- required because of JS numbers. e>>>0 converts e to a Word32 +-- so (-2147483648) >>> 0 = 2147483648 +-- and ((-2147483648) >>>0) | 0 = -2147483648 +toU32 :: JExpr -> JExpr +toU32 e = e .>>>. zero_ + +quotShortInt :: Int -> JExpr -> JExpr -> JExpr +quotShortInt bits x y = BAnd (signed x `Div` signed y) mask + where + signed z = (z .<<. shift) .>>. shift + shift = toJExpr (32 - bits) + mask = toJExpr (((2::Integer) ^ bits) - 1) + +remShortInt :: Int -> JExpr -> JExpr -> JExpr +remShortInt bits x y = BAnd (signed x `Mod` signed y) mask + where + signed z = (z .<<. shift) .>>. shift + shift = toJExpr (32 - bits) + mask = toJExpr (((2::Integer) ^ bits) - 1) diff --git a/compiler/GHC/StgToJS/Printer.hs b/compiler/GHC/StgToJS/Printer.hs new file mode 100644 index 0000000000..086f30ba07 --- /dev/null +++ b/compiler/GHC/StgToJS/Printer.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Printer +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Stability : experimental +-- +-- Custom prettyprinter for JS AST uses the JS PPr module for most of +-- the work +-- +-- +----------------------------------------------------------------------------- +module GHC.StgToJS.Printer + ( pretty + , ghcjsRenderJs + , prettyBlock + ) +where + +import GHC.Prelude +import GHC.Int +import GHC.Exts + +import GHC.JS.Syntax +import GHC.JS.Ppr + +import GHC.Utils.Ppr as PP +import GHC.Data.FastString +import GHC.Types.Unique.Map + +import Data.List (sortOn) +import Data.Char (isAlpha,isDigit,ord) +import qualified Data.ByteString.Short as SBS + +pretty :: JStat -> Doc +pretty = jsToDocR ghcjsRenderJs + +ghcjsRenderJs :: RenderJs +ghcjsRenderJs = defaultRenderJs + { renderJsV = ghcjsRenderJsV + , renderJsS = ghcjsRenderJsS + , renderJsI = ghcjsRenderJsI + } + +hdd :: SBS.ShortByteString +hdd = SBS.pack (map (fromIntegral . ord) "h$$") + +ghcjsRenderJsI :: RenderJs -> Ident -> Doc +ghcjsRenderJsI _ (TxtI fs) + -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by + -- name in user code, only in compiled code. Hence we can rename them if we do + -- it consistently in all the linked code. + -- + -- These symbols are usually very large because their name includes the + -- unit-id, the module name, and some unique number. So we rename these + -- symbols with a much shorter globally unique number. + -- + -- Here we reuse their FastString unique for this purpose! Note that it only + -- works if we pretty-print all the JS code linked together at once, which we + -- currently do. GHCJS used to maintain a CompactorState to support + -- incremental linking: it contained the mapping between original symbols and + -- their renaming. + | hdd `SBS.isPrefixOf` fastStringToShortByteString fs + , u <- uniqueOfFS fs + = text "h$$" <> hexDoc (fromIntegral u) + | otherwise + = ftext fs + +-- | Render as an hexadecimal number in reversed order (because it's faster and we +-- don't care about the actual value). +hexDoc :: Word -> Doc +hexDoc 0 = char '0' +hexDoc v = text $ go v + where + sym (I# i) = C# (indexCharOffAddr# chars i) + chars = "0123456789abcdef"# + go = \case + 0 -> [] + n -> sym (fromIntegral (n .&. 0x0F)) + : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) + : go (n `shiftR` 8) + + + + +-- attempt to resugar some of the common constructs +ghcjsRenderJsS :: RenderJs -> JStat -> Doc +ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s + +-- don't quote keys in our object literals, so closure compiler works +ghcjsRenderJsV :: RenderJs -> JVal -> Doc +ghcjsRenderJsV r (JHash m) + | isNullUniqMap m = text "{}" + | otherwise = braceNest . PP.fsep . punctuate comma . + map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y) + -- nonDetEltsUniqMap doesn't introduce non-determinism here because + -- we sort the elements lexically + . sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m + where + quoteIfRequired :: FastString -> Doc + quoteIfRequired x + | isUnquotedKey x' = text x' + | otherwise = PP.squotes (text x') + where x' = unpackFS x + + isUnquotedKey :: String -> Bool + isUnquotedKey x | null x = False + | all isDigit x = True + | otherwise = validFirstIdent (head x) + && all validOtherIdent (tail x) + + + validFirstIdent c = c == '_' || c == '$' || isAlpha c + validOtherIdent c = isAlpha c || isDigit c +ghcjsRenderJsV r v = renderJsV defaultRenderJs r v + +prettyBlock :: RenderJs -> [JStat] -> Doc +prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs) + +-- recognize common patterns in a block and convert them to more idiomatic/concise javascript +prettyBlock' :: RenderJs -> [JStat] -> [Doc] +-- return/... +prettyBlock' r ( x@(ReturnStat _) + : xs + ) + | not (null xs) + = prettyBlock' r [x] +-- declare/assign +prettyBlock' r ( (DeclStat i Nothing) + : (AssignStat (ValExpr (JVar i')) v) + : xs + ) + | i == i' + = prettyBlock' r (DeclStat i (Just v) : xs) + +-- resugar for loops with/without var declaration +prettyBlock' r ( (DeclStat i (Just v0)) + : (WhileStat False p (BlockStat bs)) + : xs + ) + | not (null flat) && isForUpdStat (last flat) + = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs + where + flat = flattenBlocks bs +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0) + : (WhileStat False p (BlockStat bs)) + : xs + ) + | not (null flat) && isForUpdStat (last flat) + = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs + where + flat = flattenBlocks bs + +-- global function (does not preserve semantics but works for GHCJS) +prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b)))) + : xs + ) + = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) + (jsToDocR r b) + ) : prettyBlock' r xs +-- modify/assign operators +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) + : xs + ) + | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) + : xs + ) + | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e)) + : xs + ) + | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e)) + : xs + ) + | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs + + +prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs +prettyBlock' _ [] = [] + +-- build the for block +mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc +mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond) + (jsToDocR r $ BlockStat sb) + where + c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0 + | otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0 + forCond = parens $ hcat $ interSemi + [ c0 + , jsToDocR r p + , parens (jsToDocR r s1) + ] + +-- check if a statement is suitable to be converted to something in the for(;;x) position +isForUpdStat :: JStat -> Bool +isForUpdStat UOpStat {} = True +isForUpdStat AssignStat {} = True +isForUpdStat ApplStat {} = True +isForUpdStat _ = False + +interSemi :: [Doc] -> [Doc] +interSemi [] = [PP.empty] +interSemi [s] = [s] +interSemi (x:xs) = x <> text ";" : interSemi xs + +addSemi :: Doc -> Doc +addSemi x = x <> text ";" diff --git a/compiler/GHC/StgToJS/Profiling.hs b/compiler/GHC/StgToJS/Profiling.hs new file mode 100644 index 0000000000..cd27604082 --- /dev/null +++ b/compiler/GHC/StgToJS/Profiling.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Profiling + ( initCostCentres + , emitCostCentreDecl + , emitCostCentreStackDecl + , enterCostCentreFun + , enterCostCentreThunk + , setCC + , pushRestoreCCS + , jCurrentCCS + , jCafCCS + , jSystemCCS + , costCentreLbl + , costCentreStackLbl + , singletonCCSLbl + , ccsVarJ + -- * Predicates + , profiling + , ifProfiling + , ifProfilingM + -- * helpers + , profStat + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Regs +import GHC.StgToJS.Types +import GHC.StgToJS.Symbols +import GHC.StgToJS.Monad + +import GHC.Types.CostCentre + +import GHC.Data.FastString +import GHC.Unit.Module +import GHC.Utils.Encoding +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Control.Monad.Trans.State.Strict as State + +-------------------------------------------------------------------------------- +-- Initialization + +initCostCentres :: CollectedCCs -> G () +initCostCentres (local_CCs, singleton_CCSs) = do + mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs + +emitCostCentreDecl :: CostCentre -> G () +emitCostCentreDecl cc = do + ccsLbl <- costCentreLbl cc + let is_caf = isCafCC cc + label = costCentreUserName cc + modl = moduleNameString $ moduleName $ cc_mod cc + loc = renderWithContext defaultSDocContext (ppr (costCentreSrcSpan cc)) + js = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CC") + [ toJExpr label + , toJExpr modl + , toJExpr loc + , toJExpr is_caf + ]) + emitGlobal js + +emitCostCentreStackDecl :: CostCentreStack -> G () +emitCostCentreStackDecl ccs = + case maybeSingletonCCS ccs of + Just cc -> do + ccsLbl <- singletonCCSLbl cc + ccLbl <- costCentreLbl cc + let js = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CCS") [null_, toJExpr ccLbl]) + emitGlobal js + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +-------------------------------------------------------------------------------- +-- Entering to cost-centres + +enterCostCentreFun :: CostCentreStack -> JStat +enterCostCentreFun ccs + | isCurrentCCS ccs = ApplStat (var "h$enterFunCCS") [jCurrentCCS, r1 .^ "cc"] + | otherwise = mempty -- top-level function, nothing to do + +enterCostCentreThunk :: JStat +enterCostCentreThunk = ApplStat (var "h$enterThunkCCS") [r1 .^ "cc"] + +setCC :: CostCentre -> Bool -> Bool -> G JStat +setCC cc _tick True = do + ccI@(TxtI _ccLbl) <- costCentreLbl cc + addDependency $ OtherSymb (cc_mod cc) + (moduleGlobalSymbol $ cc_mod cc) + return $ jCurrentCCS |= ApplExpr (var "h$pushCostCentre") [jCurrentCCS, toJExpr ccI] +setCC _cc _tick _push = return mempty + +pushRestoreCCS :: JStat +pushRestoreCCS = ApplStat (var "h$pushRestoreCCS") [] + +-------------------------------------------------------------------------------- +-- Some cost-centre stacks to be used in generator + +jCurrentCCS :: JExpr +jCurrentCCS = var "h$currentThread" .^ "ccs" + +jCafCCS :: JExpr +jCafCCS = var "h$CAF" + +jSystemCCS :: JExpr +jSystemCCS = var "h$CCS_SYSTEM" +-------------------------------------------------------------------------------- +-- Helpers for generating profiling related things + +profiling :: G Bool +profiling = csProf <$> getSettings + +ifProfiling :: Monoid m => m -> G m +ifProfiling m = do + prof <- profiling + return $ if prof then m else mempty + +ifProfilingM :: Monoid m => G m -> G m +ifProfilingM m = do + prof <- profiling + if prof then m else return mempty + +-- | If profiling is enabled, then use input JStat, else ignore +profStat :: StgToJSConfig -> JStat -> JStat +profStat cfg e = if csProf cfg then e else mempty +-------------------------------------------------------------------------------- +-- Generating cost-centre and cost-centre stack variables + +costCentreLbl' :: CostCentre -> G String +costCentreLbl' cc = do + curModl <- State.gets gsModule + let lbl = renderWithContext defaultSDocContext + $ withPprStyle PprCode (ppr cc) + return . ("h$"++) . zEncodeString $ + moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl + +costCentreLbl :: CostCentre -> G Ident +costCentreLbl cc = TxtI . mkFastString <$> costCentreLbl' cc + +costCentreStackLbl' :: CostCentreStack -> G (Maybe String) +costCentreStackLbl' ccs = do + ifProfilingM f + where + f | isCurrentCCS ccs = return $ Just "h$currentThread.ccs" + | dontCareCCS == ccs = return $ Just "h$CCS_DONT_CARE" + | otherwise = + case maybeSingletonCCS ccs of + Just cc -> Just <$> singletonCCSLbl' cc + Nothing -> pure Nothing + +costCentreStackLbl :: CostCentreStack -> G (Maybe Ident) +costCentreStackLbl ccs = fmap (TxtI . mkFastString) <$> costCentreStackLbl' ccs + +singletonCCSLbl' :: CostCentre -> G String +singletonCCSLbl' cc = do + curModl <- State.gets gsModule + ccLbl <- costCentreLbl' cc + let ccsLbl = ccLbl ++ "_ccs" + return . zEncodeString $ mconcat + [ moduleNameColons (moduleName curModl) + , "_" + , ccsLbl + ] + +singletonCCSLbl :: CostCentre -> G Ident +singletonCCSLbl cc = TxtI . mkFastString <$> singletonCCSLbl' cc + +ccsVarJ :: CostCentreStack -> G (Maybe JExpr) +ccsVarJ ccs = do + prof <- profiling + if prof + then fmap (ValExpr . JVar) <$> costCentreStackLbl ccs + else pure Nothing diff --git a/compiler/GHC/StgToJS/Regs.hs b/compiler/GHC/StgToJS/Regs.hs new file mode 100644 index 0000000000..ea482d4036 --- /dev/null +++ b/compiler/GHC/StgToJS/Regs.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Regs + ( StgReg (..) + , Special(..) + , sp + , stack + , r1, r2, r3, r4 + , regsFromR1 + , regsFromR2 + , jsRegsFromR1 + , jsRegsFromR2 + , StgRet (..) + , jsRegToInt + , intToJSReg + , jsReg + , maxReg + , minReg + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Data.FastString + +import Data.Array +import Data.Char + +-- | General purpose "registers" +-- +-- The JS backend arbitrarily supports 128 registers +data StgReg + = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 + | R9 | R10 | R11 | R12 | R13 | R14 | R15 | R16 + | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 + | R25 | R26 | R27 | R28 | R29 | R30 | R31 | R32 + | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40 + | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 + | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56 + | R57 | R58 | R59 | R60 | R61 | R62 | R63 | R64 + | R65 | R66 | R67 | R68 | R69 | R70 | R71 | R72 + | R73 | R74 | R75 | R76 | R77 | R78 | R79 | R80 + | R81 | R82 | R83 | R84 | R85 | R86 | R87 | R88 + | R89 | R90 | R91 | R92 | R93 | R94 | R95 | R96 + | R97 | R98 | R99 | R100 | R101 | R102 | R103 | R104 + | R105 | R106 | R107 | R108 | R109 | R110 | R111 | R112 + | R113 | R114 | R115 | R116 | R117 | R118 | R119 | R120 + | R121 | R122 | R123 | R124 | R125 | R126 | R127 | R128 + deriving (Eq, Ord, Show, Enum, Bounded, Ix) + +-- | Stack registers +data Special + = Stack + | Sp + deriving (Show, Eq) + +-- | Return registers +-- +-- Extra results from foreign calls can be stored here (while first result is +-- directly returned) +data StgRet = Ret1 | Ret2 | Ret3 | Ret4 | Ret5 | Ret6 | Ret7 | Ret8 | Ret9 | Ret10 + deriving (Eq, Ord, Show, Enum, Bounded, Ix) + +instance ToJExpr Special where + toJExpr Stack = var "h$stack" + toJExpr Sp = var "h$sp" + +instance ToJExpr StgReg where + toJExpr r = registers ! r + +instance ToJExpr StgRet where + toJExpr r = rets ! r + +--------------------------------------------------- +-- helpers +--------------------------------------------------- + +sp :: JExpr +sp = toJExpr Sp + +stack :: JExpr +stack = toJExpr Stack + +r1, r2, r3, r4 :: JExpr +r1 = toJExpr R1 +r2 = toJExpr R2 +r3 = toJExpr R3 +r4 = toJExpr R4 + + +jsRegToInt :: StgReg -> Int +jsRegToInt = (+1) . fromEnum + +intToJSReg :: Int -> StgReg +intToJSReg r = toEnum (r - 1) + +jsReg :: Int -> JExpr +jsReg r = toJExpr (intToJSReg r) + +maxReg :: Int +maxReg = jsRegToInt maxBound + +minReg :: Int +minReg = jsRegToInt minBound + +-- | List of registers, starting from R1 +regsFromR1 :: [StgReg] +regsFromR1 = enumFrom R1 + +-- | List of registers, starting from R2 +regsFromR2 :: [StgReg] +regsFromR2 = tail regsFromR1 + +-- | List of registers, starting from R1 as JExpr +jsRegsFromR1 :: [JExpr] +jsRegsFromR1 = fmap toJExpr regsFromR1 + +-- | List of registers, starting from R2 as JExpr +jsRegsFromR2 :: [JExpr] +jsRegsFromR2 = tail jsRegsFromR1 + +--------------------------------------------------- +-- caches +--------------------------------------------------- + +-- cache JExpr representing StgReg +registers :: Array StgReg JExpr +registers = listArray (minBound, maxBound) (map regN regsFromR1) + where + regN r + | fromEnum r < 32 = var . mkFastString . ("h$"++) . map toLower . show $ r + | otherwise = IdxExpr (var "h$regs") + (toJExpr ((fromEnum r) - 32)) + +-- cache JExpr representing StgRet +rets :: Array StgRet JExpr +rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1)) + where + retN = var . mkFastString . ("h$"++) . map toLower . show diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs new file mode 100644 index 0000000000..55e1a3f312 --- /dev/null +++ b/compiler/GHC/StgToJS/Rts/Rts.hs @@ -0,0 +1,661 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -O0 #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Rts.Rts +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Top level driver of the JavaScript Backend RTS. This file is an +-- implementation of the JS RTS for the JS backend written as an EDSL in +-- Haskell. It assumes the existence of pre-generated JS functions, included as +-- js-sources in base. These functions are similarly assumed for non-inline +-- Primops, See 'GHC.StgToJS.Prim'. Most of the elements in this module are +-- constants in Haskell Land which define pieces of the JS RTS. +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Rts.Rts where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Apply +import GHC.StgToJS.Closure +import GHC.StgToJS.Heap +import GHC.StgToJS.Printer +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Types +import GHC.StgToJS.Stack + +import GHC.Data.FastString +import GHC.Types.Unique.Map + +import Data.Array +import Data.Monoid +import Data.Char (toLower, toUpper) +import qualified Data.Bits as Bits + +-- | The garbageCollector resets registers and result variables. +garbageCollector :: JStat +garbageCollector = + mconcat [ TxtI "h$resetRegisters" ||= jLam (mconcat $ map resetRegister [minBound..maxBound]) + , TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound]) + ] + +-- | Reset the register 'r' in JS Land. Note that this "resets" by setting the +-- register to a dummy variable called "null", /not/ by setting to JS's nil +-- value. +resetRegister :: StgReg -> JStat +resetRegister r = toJExpr r |= null_ + +-- | Reset the return variable 'r' in JS Land. Note that this "resets" by +-- setting the register to a dummy variable called "null", /not/ by setting to +-- JS's nil value. +resetResultVar :: StgRet -> JStat +resetResultVar r = toJExpr r |= null_ + +-- | Define closures based on size, these functions are syntactic sugar, e.g., a +-- Haskell function which generates some useful JS. Each Closure constructor +-- follows the naming convention h$cN, where N is a natural number. For example, +-- h$c (with the nat omitted) is a JS Land Constructor for a closure in JS land +-- which has a single entry function 'f', and no fields; identical to h$c0. h$c1 +-- is a JS Land Constructor for a closure with an entry function 'f', and a +-- /single/ field 'x1', 'Just foo' is an example of this kind of closure. h$c2 +-- is a JS Land Constructor for a closure with an entry function and two data +-- fields: 'x1' and 'x2'. And so on. Note that this has JIT performance +-- implications; you should use h$c1, h$c2, h$c3, ... h$c24 instead of making +-- objects manually so layouts and fields can be changed more easily and so the +-- JIT can optimize better. +closureConstructors :: StgToJSConfig -> JStat +closureConstructors s = BlockStat + [ declClsConstr "h$c" ["f"] $ Closure + { clEntry = var "f" + , clField1 = null_ + , clField2 = null_ + , clMeta = 0 + , clCC = ccVal + } + , declClsConstr "h$c0" ["f"] $ Closure + { clEntry = var "f" + , clField1 = null_ + , clField2 = null_ + , clMeta = 0 + , clCC = ccVal + } + , declClsConstr "h$c1" ["f", "x1"] $ Closure + { clEntry = var "f" + , clField1 = var "x1" + , clField2 = null_ + , clMeta = 0 + , clCC = ccVal + } + , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure + { clEntry = var "f" + , clField1 = var "x1" + , clField2 = var "x2" + , clMeta = 0 + , clCC = ccVal + } + , mconcat (map mkClosureCon [3..24]) + , mconcat (map mkDataFill [1..24]) + ] + where + prof = csProf s + (ccArg,ccVal) + -- the cc argument happens to be named just like the cc field... + | prof = ([TxtI closureCC_], Just (var closureCC_)) + | otherwise = ([], Nothing) + addCCArg as = map TxtI as ++ ccArg + addCCArg' as = as ++ ccArg + + declClsConstr i as cl = TxtI i ||= ValExpr (JFunc (addCCArg as) + ( jVar $ \x -> + [ checkC + , x |= newClosure cl + , notifyAlloc x + , traceAlloc x + , returnS x + ] + )) + + traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x] + | otherwise = mempty + + notifyAlloc x | csDebugAlloc s = appS "h$debugAlloc_notifyAlloc" [x] + | otherwise = mempty + + -- only JSVal can typically contain undefined or null + -- although it's possible (and legal) to make other Haskell types + -- to contain JS refs directly + -- this can cause false positives here + checkC :: JStat + checkC | csAssertRts s = + jVar $ \msg -> + jwhenS (var "arguments" .! 0 .!==. jString "h$baseZCGHCziJSziPrimziJSVal_con_e") + (loop 1 (.<. var "arguments" .^ "length") + (\i -> + mconcat [msg |= jString "warning: undefined or null in argument: " + + i + + jString " allocating closure: " + (var "arguments" .! 0 .^ "n") + , appS "h$log" [msg] + , jwhenS (var "console" .&&. (var "console" .^ "trace")) ((var "console" .^ "trace") `ApplStat` [msg]) + , postIncrS i + ]) + + ) + | otherwise = mempty + + -- h$d is never used for JSVal (since it's only for constructors with + -- at least three fields, so we always warn here + checkD | csAssertRts s = + loop 0 (.<. var "arguments" .^ "length") + (\i -> jwhenS ((var "arguments" .! i .===. null_) + .||. (var "arguments" .! i .===. undefined_)) + (jVar $ \msg -> + mconcat [ msg |= jString "warning: undefined or null in argument: " + i + jString " allocating fields" + , jwhenS (var "console" .&&. (var "console" .^ "trace")) + ((var "console" .^ "trace") `ApplStat` [msg]) + ])) + + | otherwise = mempty + + mkClosureCon :: Int -> JStat + mkClosureCon n = funName ||= toJExpr fun + where + funName = TxtI $ mkFastString ("h$c" ++ show n) + -- args are: f x1 x2 .. xn [cc] + args = TxtI "f" : addCCArg' (map (TxtI . mkFastString . ('x':) . show) [(1::Int)..n]) + fun = JFunc args funBod + -- x1 goes into closureField1. All the other args are bundled into an + -- object in closureField2: { d1 = x2, d2 = x3, ... } + -- + extra_args = ValExpr . JHash . listToUniqMap $ zip + (map (mkFastString . ('d':) . show) [(1::Int)..]) + (map (toJExpr . TxtI . mkFastString . ('x':) . show) [2..n]) + + funBod = jVar $ \x -> + [ checkC + , x |= newClosure Closure + { clEntry = var "f" + , clField1 = var "x1" + , clField2 = extra_args + , clMeta = 0 + , clCC = ccVal + } + , notifyAlloc x + , traceAlloc x + , returnS x + ] + + mkDataFill :: Int -> JStat + mkDataFill n = funName ||= toJExpr fun + where + funName = TxtI $ mkFastString ("h$d" ++ show n) + ds = map (mkFastString . ('d':) . show) [(1::Int)..n] + extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds + fun = JFunc (map TxtI ds) (checkD <> returnS extra_args) + +-- | JS Payload to perform stack manipulation in the RTS +stackManip :: JStat +stackManip = mconcat (map mkPush [1..32]) <> + mconcat (map mkPpush [1..255]) + where + mkPush :: Int -> JStat + mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) + as = map (TxtI . mkFastString . ('x':) . show) [1..n] + fun = JFunc as ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + [1..] as)) + in funName ||= toJExpr fun + + -- partial pushes, based on bitmap, increases Sp by highest bit + mkPpush :: Integer -> JStat + mkPpush sig | sig Bits..&. (sig+1) == 0 = mempty -- already handled by h$p + mkPpush sig = let funName = TxtI $ mkFastString ("h$pp" ++ show sig) + bits = bitsIdx sig + n = length bits + h = last bits + args = map (TxtI . mkFastString . ('x':) . show) [1..n] + fun = JFunc args $ + mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) + ] + in funName ||= toJExpr fun + +bitsIdx :: Integer -> [Int] +bitsIdx n | n < 0 = error "bitsIdx: negative" + | otherwise = go n 0 + where + go 0 _ = [] + go m b | Bits.testBit m b = b : go (Bits.clearBit m b) (b+1) + | otherwise = go (Bits.clearBit m b) (b+1) + +bhLneStats :: StgToJSConfig -> JExpr -> JExpr -> JStat +bhLneStats _s p frameSize = + jVar $ \v -> + mconcat [ v |= stack .! p + , ifS v + ((sp |= sp - frameSize) + <> ifS (v .===. var "h$blackhole") + (returnS $ app "h$throw" [var "h$baseZCControlziExceptionziBasezinonTermination", false_]) + (mconcat [r1 |= v + , sp |= sp - frameSize + , returnStack + ])) + ((stack .! p |= var "h$blackhole") <> returnS null_) + ] + + +-- | JS payload to declare the registers +declRegs :: JStat +declRegs = + mconcat [ TxtI "h$regs" ||= toJExpr (JList []) + , mconcat (map declReg (enumFromTo R1 R32)) + , regGettersSetters + , loadRegs + ] + where + declReg r = (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) r + <> BlockStat [AssignStat (toJExpr r) (ValExpr (JInt 0))] -- [j| `r` = 0; |] + +-- | JS payload to define getters and setters on the registers. +regGettersSetters :: JStat +regGettersSetters = + mconcat [ TxtI "h$getReg" ||= jLam (\n -> SwitchStat n getRegCases mempty) + , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty) + ] + where + getRegCases = + map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) regsFromR1 + setRegCases v = + map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) regsFromR1 + +-- | JS payload that defines the functions to load each register +loadRegs :: JStat +loadRegs = mconcat $ map mkLoad [1..32] + where + mkLoad :: Int -> JStat + mkLoad n = let args = map (TxtI . mkFastString . ("x"++) . show) [1..n] + assign = zipWith (\a r -> toJExpr r |= toJExpr a) + args (reverse $ take n regsFromR1) + fname = TxtI $ mkFastString ("h$l" ++ show n) + fun = JFunc args (mconcat assign) + in fname ||= toJExpr fun + +-- | Assign registers R1 ... Rn in descending order, that is assign Rn first. +-- This function uses the 'assignRegs'' array to construct functions which set +-- the registers. +assignRegs :: StgToJSConfig -> [JExpr] -> JStat +assignRegs _ [] = mempty +assignRegs s xs + | l <= 32 && not (csInlineLoadRegs s) + = ApplStat (ValExpr (JVar $ assignRegs'!l)) (reverse xs) + | otherwise = mconcat . reverse $ + zipWith (\r ex -> toJExpr r |= ex) (take l regsFromR1) xs + where + l = length xs + +-- | JS payload which defines an array of function symbols that set N registers +-- from M parameters. For example, h$l2 compiles to: +-- @ +-- function h$l4(x1, x2, x3, x4) { +-- h$r4 = x1; +-- h$r3 = x2; +-- h$r2 = x3; +-- h$r1 = x4; +-- }; +-- @ +assignRegs' :: Array Int Ident +assignRegs' = listArray (1,32) (map (TxtI . mkFastString . ("h$l"++) . show) [(1::Int)..32]) + +-- | JS payload to declare return variables. +declRets :: JStat +declRets = mconcat $ map (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) (enumFrom Ret1) + +-- | JS payload defining the types closures. +closureTypes :: JStat +closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> closureTypeName + where + mkClosureType :: ClosureType -> JStat + mkClosureType c = let s = TxtI . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE" + in s ||= toJExpr c + closureTypeName :: JStat + closureTypeName = + TxtI "h$closureTypeName" ||= jLam (\c -> + mconcat (map (ifCT c) [minBound..maxBound]) + <> returnS (jString "InvalidClosureType")) + + ifCT :: JExpr -> ClosureType -> JStat + ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) + +-- | JS payload declaring the RTS functions. +rtsDecls :: JStat +rtsDecls = jsSaturate (Just "h$RTSD") $ + mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread + , TxtI "h$stack" ||= null_ -- stack for the current thread + , TxtI "h$sp" ||= 0 -- stack pointer for the current thread + , TxtI "h$initStatic" ||= toJExpr (JList []) -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs + , TxtI "h$staticThunks" ||= toJExpr (jhFromList []) -- funcName -> heapidx map for srefs + , TxtI "h$staticThunksArr" ||= toJExpr (JList []) -- indices of updatable thunks in static heap + , TxtI "h$CAFs" ||= toJExpr (JList []) + , TxtI "h$CAFsReset" ||= toJExpr (JList []) + -- stg registers + , declRegs + , declRets] + +-- | print the embedded RTS to a String +rtsText :: StgToJSConfig -> String +rtsText = show . pretty . rts + +-- | print the RTS declarations to a String. +rtsDeclsText :: String +rtsDeclsText = show . pretty $ rtsDecls + +-- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' +rts :: StgToJSConfig -> JStat +rts = jsSaturate (Just "h$RTS") . rts' + +-- | JS Payload which defines the embedded RTS. +rts' :: StgToJSConfig -> JStat +rts' s = + mconcat [ closureConstructors s + , garbageCollector + , stackManip + , TxtI "h$rts_traceForeign" ||= toJExpr (csTraceForeign s) + , TxtI "h$rts_profiling" ||= toJExpr (csProf s) + , TxtI "h$ct_fun" ||= toJExpr Fun + , TxtI "h$ct_con" ||= toJExpr Con + , TxtI "h$ct_thunk" ||= toJExpr Thunk + , TxtI "h$ct_pap" ||= toJExpr Pap + , TxtI "h$ct_blackhole" ||= toJExpr Blackhole + , TxtI "h$ct_stackframe" ||= toJExpr StackFrame + , TxtI "h$vt_ptr" ||= toJExpr PtrV + , TxtI "h$vt_void" ||= toJExpr VoidV + , TxtI "h$vt_double" ||= toJExpr IntV + , TxtI "h$vt_long" ||= toJExpr LongV + , TxtI "h$vt_addr" ||= toJExpr AddrV + , TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV + , TxtI "h$vt_obj" ||= toJExpr ObjV + , TxtI "h$vt_arr" ||= toJExpr ArrV + , TxtI "h$bh" ||= jLam (bhStats s True) + , TxtI "h$bh_lne" ||= jLam (\x frameSize -> bhLneStats s x frameSize) + , closure (ClosureInfo (TxtI "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty) + (appS "throw" [jString "oops: entered black hole"]) + , closure (ClosureInfo (TxtI "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty) + (appS "throw" [jString "oops: entered multiple times"]) + , closure (ClosureInfo (TxtI "h$done") (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty) + (appS "h$finishThread" [var "h$currentThread"] <> returnS (var "h$reschedule")) + , closure (ClosureInfo (TxtI "h$doneMain_e") (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty) + (returnS (var "h$doneMain")) + , conClosure (TxtI "h$false_e") "GHC.Types.False" (CILayoutFixed 0 []) 1 + , conClosure (TxtI "h$true_e" ) "GHC.Types.True" (CILayoutFixed 0 []) 2 + -- generic data constructor with 1 non-heapobj field + , conClosure (TxtI "h$data1_e") "data1" (CILayoutFixed 1 [ObjV]) 1 + -- generic data constructor with 2 non-heapobj fields + , conClosure (TxtI "h$data2_e") "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1 + , closure (ClosureInfo (TxtI "h$noop_e") (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty) + (returnS (stack .! sp)) + <> (TxtI "h$noop" ||= ApplExpr (var "h$c0") (var "h$noop_e" : [jSystemCCS | csProf s])) + , closure (ClosureInfo (TxtI "h$catch_e") (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty) + (adjSpN' 3 <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$dataToTag_e") (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeof r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0) + , adjSpN' 1 + , returnS (stack .! sp) + ] + -- function application to one argument + , closure (ClosureInfo (TxtI "h$ap1_e") (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 -> + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , returnS (app "h$ap_1_1_fast" []) + ]) + -- function application to two arguments + , closure (ClosureInfo (TxtI "h$ap2_e") (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 d3 -> + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 .^ "d1" + , d3 |= closureField2 r1 .^ "d2" + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , returnS (app "h$ap_2_2_fast" []) + ]) + -- function application to three arguments + , closure (ClosureInfo (TxtI "h$ap3_e") (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 d3 d4 -> + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 .^ "d1" + , d3 |= closureField2 r1 .^ "d2" + , d4 |= closureField2 r1 .^ "d3" + , appS "h$bh" [] + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , r4 |= d4 + , returnS (app "h$ap_3_3_fast" []) + ]) + -- select first field + , closure (ClosureInfo (TxtI "h$select1_e") (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar $ \t -> + mconcat [ t |= closureField1 r1 + , adjSp' 3 + , stack .! (sp - 2) |= r1 + , stack .! (sp - 1) |= var "h$upd_frame" + , stack .! sp |= var "h$select1_ret" + , closureEntry r1 |= var "h$blackhole" + , closureField1 r1 |= var "h$currentThread" + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app "h$ap_0_0_fast" []) + ]) + , closure (ClosureInfo (TxtI "h$select1_ret") (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty) + ((r1 |= closureField1 r1) + <> adjSpN' 1 + <> returnS (app "h$ap_0_0_fast" []) + ) + -- select second field of a two-field constructor + , closure (ClosureInfo (TxtI "h$select2_e") (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar $ \t -> + mconcat [t |= closureField1 r1 + , adjSp' 3 + , stack .! (sp - 2) |= r1 + , stack .! (sp - 1) |= var "h$upd_frame" + , stack .! sp |= var "h$select2_ret" + , closureEntry r1 |= var "h$blackhole" + , closureField1 r1 |= var "h$currentThread" + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app "h$ap_0_0_fast" []) + ] + ) + , closure (ClosureInfo (TxtI "h$select2_ret") (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ r1 |= closureField2 r1 + , adjSpN' 1 + , returnS (app "h$ap_0_0_fast" []) + ] + , closure (ClosureInfo (TxtI "h$keepAlive_e") (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (mconcat [ adjSpN' 2 + , returnS (stack .! sp) + ] + ) + -- a thunk that just raises a synchronous exception + , closure (ClosureInfo (TxtI "h$raise_e") (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty) + (returnS (app "h$throw" [closureField1 r1, false_])) + , closure (ClosureInfo (TxtI "h$raiseAsync_e") (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty) + (returnS (app "h$throw" [closureField1 r1, true_])) + , closure (ClosureInfo (TxtI "h$raiseAsync_frame") (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty) + (jVar $ \ex -> + mconcat [ ex |= stack .! (sp - 1) + , adjSpN' 2 + , returnS (app "h$throw" [ex, true_]) + ]) + {- reduce result if it's a thunk, follow if it's an ind + add this to the stack if you want the outermost result + to always be reduced to whnf, and not an ind + -} + , closure (ClosureInfo (TxtI "h$reduce") (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty) + (ifS (isThunk r1) + (returnS (r1 .^ "f")) + (adjSpN' 1 <> returnS (stack .! sp)) + ) + , rtsApply s + , closureTypes + , closure (ClosureInfo (TxtI "h$runio_e") (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + $ mconcat [ r1 |= closureField1 r1 + , stack .! PreInc sp |= var "h$ap_1_0" + , returnS (var "h$ap_1_0") + ] + , closure (ClosureInfo (TxtI "h$flushStdout_e") (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty) + $ mconcat [ r1 |= var "h$baseZCGHCziIOziHandlezihFlush" + , r2 |= var "h$baseZCGHCziIOziHandleziFDzistdout" + , returnS (app "h$ap_1_1_fast" []) + ] + , TxtI "h$flushStdout" ||= app "h$static_thunk" [var "h$flushStdout_e"] + -- the scheduler pushes this frame when suspending a thread that + -- has not called h$reschedule explicitly + , closure (ClosureInfo (TxtI "h$restoreThread") (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty) + (jVar $ \f frameSize nregs -> + mconcat [f |= stack .! (sp - 2) + , frameSize |= stack .! (sp - 1) + , nregs |= frameSize - 3 + , loop 1 (.<=. nregs) + (\i -> appS "h$setReg" [i, stack .! (sp - 2 - i)] <> postIncrS i) + , sp |= sp - frameSize + , returnS f + ]) + -- return a closure in the stack frame to the next thing on the stack + , closure (ClosureInfo (TxtI "h$return") (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + ((r1 |= stack .! (sp - 1)) + <> adjSpN' 2 + <> returnS (stack .! sp)) + -- return a function in the stack frame for the next call + , closure (ClosureInfo (TxtI "h$returnf") (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar $ \r -> + mconcat [ r |= stack .! (sp - 1) + , adjSpN' 2 + , returnS r + ]) + -- return this function when the scheduler needs to come into action + -- (yield, delay etc), returning thread needs to push all relevant + -- registers to stack frame, thread will be resumed by calling the stack top + , closure (ClosureInfo (TxtI "h$reschedule") (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty) + (returnS $ var "h$reschedule") + -- debug thing, insert on stack to dump current result, should be boxed + , closure (ClosureInfo (TxtI "h$dumpRes") (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty) + (jVar $ \re -> + mconcat [ appS "h$log" [jString "h$dumpRes result: " + stack .! (sp-1)] + , appS "h$log" [r1] + , appS "h$log" [app "h$collectProps" [r1]] + , jwhenS ((r1 .^ "f") .&&. (r1 .^ "f" .^ "n")) + (appS "h$log" [jString "name: " + r1 .^ "f" .^ "n"]) + , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureField1_]) + (appS "h$log" [jString "d1: " + closureField1 r1]) + , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureField2_]) + (appS "h$log" [jString "d2: " + closureField2 r1]) + , jwhenS (r1 .^ "f") $ mconcat + [ re |= New (app "RegExp" [jString "([^\\n]+)\\n(.|\\n)*"]) + , appS "h$log" [jString "function" + + ApplExpr (ApplExpr ((jString "" + r1 .^ "f") .^ "substring") [0, 50] .^ "replace") [r1, jString "$1"]] + ] + , adjSpN' 2 + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo (TxtI "h$resume_e") (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty) + (jVar $ \ss -> + mconcat [ss |= closureField1 r1 + , updateThunk' s + , loop 0 (.<. ss .^ "length") (\i -> (stack .! (sp+1+i) |= ss .! i) + <> postIncrS i) + , sp |= sp + ss .^ "length" + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo (TxtI "h$unmaskFrame") (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 0) + <> adjSpN' 1 + -- back to scheduler to give us async exception if pending + <> ifS (var "h$currentThread" .^ "excep" .^ "length" .>. 0) + (push' s [r1, var "h$return"] <> returnS (var "h$reschedule")) + (returnS (stack .! sp))) + , closure (ClosureInfo (TxtI "h$maskFrame") (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 2) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$maskUnintFrame") (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 1) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$unboxFFIResult") (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar $ \d -> + mconcat [d |= closureField1 r1 + , loop 0 (.<. d .^ "length") (\i -> appS "h$setReg" [i + 1, d .! i] <> postIncrS i) + , adjSpN' 1 + , returnS (stack .! sp) + ]) + , closure (ClosureInfo (TxtI "h$unbox_e") (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty) + ((r1 |= closureField1 r1) <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$retryInterrupted") (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar $ \a -> + mconcat [ a |= stack .! (sp - 1) + , adjSpN' 2 + , returnS (ApplExpr (a .! 0 .^ "apply") [var "this", ApplExpr (a .^ "slice") [1]]) + ]) + , closure (ClosureInfo (TxtI "h$atomically_e") (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (ifS (app "h$stmValidateTransaction" []) + (appS "h$stmCommitTransaction" [] + <> adjSpN' 2 + <> returnS (stack .! sp)) + (returnS (app "h$stmStartTransaction" [stack .! (sp - 1)]))) + + , closure (ClosureInfo (TxtI "h$stmCatchRetry_e") (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (adjSpN' 2 + <> appS "h$stmCommitTransaction" [] + <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$catchStm_e") (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty) + (adjSpN' 4 + <> appS "h$stmCommitTransaction" [] + <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$stmResumeRetry_e") (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar $ \blocked -> + mconcat [ jwhenS (stack .! (sp - 2) .!==. var "h$atomically_e") + (appS "throw" [jString "h$stmResumeRetry_e: unexpected value on stack"]) + , blocked |= stack .! (sp - 1) + , adjSpN' 2 + , appS "h$stmRemoveBlockedThread" [blocked, var "h$currentThread"] + , returnS (app "h$stmStartTransaction" [stack .! (sp - 1)]) + ]) + , closure (ClosureInfo (TxtI "h$lazy_e") (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty) + (jVar $ \x -> + mconcat [x |= ApplExpr (closureField1 r1) [] + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= x + , returnS (stack .! sp) + ]) + -- Top-level statements to generate only in profiling mode + , profStat s (closure (ClosureInfo (TxtI "h$setCcs_e") (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (appS "h$restoreCCS" [ stack .! (sp - 1)] + <> adjSpN' 2 + <> returnS (stack .! sp))) + ] diff --git a/compiler/GHC/StgToJS/Rts/Types.hs b/compiler/GHC/StgToJS/Rts/Types.hs new file mode 100644 index 0000000000..f1a0276d5d --- /dev/null +++ b/compiler/GHC/StgToJS/Rts/Types.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP, + FlexibleInstances, + OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Rts.Apply +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Types and utility functions used in the JS RTS. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Rts.Types where + +import GHC.Prelude + +import GHC.JS.Make +import GHC.JS.Syntax +import GHC.StgToJS.Regs +import GHC.StgToJS.Types + +-------------------------------------------------------------------------------- +-- Syntactic Sugar for some Utilities we want in JS land +-------------------------------------------------------------------------------- + +-- | Syntactic sugar, i.e., a Haskell function which generates useful JS code. +-- Given a @JExpr@, 'ex', inject a trace statement on 'ex' in the compiled JS +-- program +traceRts :: StgToJSConfig -> JExpr -> JStat +traceRts s ex | (csTraceRts s) = appS "h$log" [ex] + | otherwise = mempty + +-- | Syntactic sugar. Given a @JExpr@, 'ex' which is assumed to be a predicate, +-- and a message 'm', assert that 'not ex' is True, if not throw an exception in +-- JS land with message 'm'. +assertRts :: ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat +assertRts s ex m | csAssertRts s = jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m]) + | otherwise = mempty + +-- | name of the closure 'c' +clName :: JExpr -> JExpr +clName c = c .^ "n" + +-- | Type name of the closure 'c' +clTypeName :: JExpr -> JExpr +clTypeName c = app "h$closureTypeName" [c .^ "t"] + +-- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +stackFrameSize :: JExpr -- ^ assign frame size to this + -> JExpr -- ^ stack frame header function + -> JStat -- ^ size of the frame, including header +stackFrameSize tgt f = + ifS (f .===. var "h$ap_gen") -- h$ap_gen is special + (tgt |= (stack .! (sp - 1) .>>. 8) + 2) + (jVar (\tag -> + mconcat + [tag |= f .^ "size" + , ifS (tag .<. 0) -- if tag is less than 0 + (tgt |= stack .! (sp - 1)) -- set target to stack pointer - 1 + (tgt |= mask8 tag + 1) -- else set to mask'd tag + 1 + ] + )) + +-------------------------------------------------------------------------------- +-- Register utilities +-------------------------------------------------------------------------------- + +-- | Perform the computation 'f', on the range of registers bounded by 'start' +-- and 'end'. +withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat +withRegs start end f = mconcat $ fmap f [start..end] diff --git a/compiler/GHC/StgToJS/Sinker.hs b/compiler/GHC/StgToJS/Sinker.hs new file mode 100644 index 0000000000..6df58d4fcf --- /dev/null +++ b/compiler/GHC/StgToJS/Sinker.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Sinker (sinkPgm) where + +import GHC.Prelude +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Types.Literal +import GHC.Data.Graph.Directed + +import GHC.StgToJS.CoreUtils + +import Data.Char +import Data.Either +import Data.List (partition) +import Data.Maybe + + +-- | Unfloat some top-level unexported things +-- +-- GHC floats constants to the top level. This is fine in native code, but with JS +-- they occupy some global variable name. We can unfloat some unexported things: +-- +-- - global constructors, as long as they're referenced only once by another global +-- constructor and are not in a recursive binding group +-- - literals (small literals may also be sunk if they are used more than once) +sinkPgm :: Module + -> [CgStgTopBinding] + -> (UniqFM Id CgStgExpr, [CgStgTopBinding]) +sinkPgm m pgm = (sunk, map StgTopLifted pgm'' ++ stringLits) + where + selectLifted (StgTopLifted b) = Left b + selectLifted x = Right x + (pgm', stringLits) = partitionEithers (map selectLifted pgm) + (sunk, pgm'') = sinkPgm' m pgm' + +sinkPgm' + :: Module + -- ^ the module, since we treat definitions from the current module + -- differently + -> [CgStgBinding] + -- ^ the bindings + -> (UniqFM Id CgStgExpr, [CgStgBinding]) + -- ^ a map with sunken replacements for nodes, for where the replacement + -- does not fit in the 'StgBinding' AST and the new bindings +sinkPgm' m pgm = + let usedOnce = collectUsedOnce pgm + sinkables = listToUFM $ + concatMap alwaysSinkable pgm ++ + filter ((`elementOfUniqSet` usedOnce) . fst) (concatMap (onceSinkable m) pgm) + isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True + isSunkBind _ = False + in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm) + +-- | always sinkable, values that may be duplicated in the generated code (e.g. +-- small literals) +alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)] +alwaysSinkable (StgRec {}) = [] +alwaysSinkable (StgNonRec b rhs) = case rhs of + StgRhsClosure _ _ _ _ e@(StgLit l) + | isSmallSinkableLit l + , isLocal b + -> [(b,e)] + StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] + | isSmallSinkableLit l + , isLocal b + , isUnboxableCon dc + -> [(b,StgConApp dc cnum as [])] + _ -> [] + +isSmallSinkableLit :: Literal -> Bool +isSmallSinkableLit (LitChar c) = ord c < 100000 +isSmallSinkableLit (LitNumber _ i) = abs i < 100000 +isSmallSinkableLit _ = False + + +-- | once sinkable: may be sunk, but duplication is not ok +onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)] +onceSinkable _m (StgNonRec b rhs) + | Just e <- getSinkable rhs + , isLocal b = [(b,e)] + where + getSinkable = \case + StgRhsCon _ccs dc cnum _ticks args -> Just (StgConApp dc cnum args []) + StgRhsClosure _ _ _ _ e@(StgLit{}) -> Just e + _ -> Nothing +onceSinkable _ _ = [] + +-- | collect all idents used only once in an argument at the top level +-- and never anywhere else +collectUsedOnce :: [CgStgBinding] -> IdSet +collectUsedOnce binds = intersectUniqSets (usedOnce args) (usedOnce top_args) + where + top_args = concatMap collectArgsTop binds + args = concatMap collectArgs binds + usedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet) + g i t@(once, mult) + | i `elementOfUniqSet` mult = t + | i `elementOfUniqSet` once + = (delOneFromUniqSet once i, addOneToUniqSet mult i) + | otherwise = (addOneToUniqSet once i, mult) + +-- | fold over all id in StgArg used at the top level in an StgRhsCon +collectArgsTop :: CgStgBinding -> [Id] +collectArgsTop = \case + StgNonRec _b r -> collectArgsTopRhs r + StgRec bs -> concatMap (collectArgsTopRhs . snd) bs + +collectArgsTopRhs :: CgStgRhs -> [Id] +collectArgsTopRhs = \case + StgRhsCon _ccs _dc _mu _ticks args -> concatMap collectArgsA args + StgRhsClosure {} -> [] + +-- | fold over all Id in StgArg in the AST +collectArgs :: CgStgBinding -> [Id] +collectArgs = \case + StgNonRec _b r -> collectArgsR r + StgRec bs -> concatMap (collectArgsR . snd) bs + +collectArgsR :: CgStgRhs -> [Id] +collectArgsR = \case + StgRhsClosure _x0 _x1 _x2 _x3 e -> collectArgsE e + StgRhsCon _ccs _con _mu _ticks args -> concatMap collectArgsA args + +collectArgsAlt :: CgStgAlt -> [Id] +collectArgsAlt alt = collectArgsE (alt_rhs alt) + +collectArgsE :: CgStgExpr -> [Id] +collectArgsE = \case + StgApp x args + -> x : concatMap collectArgsA args + StgConApp _con _mn args _ts + -> concatMap collectArgsA args + StgOpApp _x args _t + -> concatMap collectArgsA args + StgCase e _b _a alts + -> collectArgsE e ++ concatMap collectArgsAlt alts + StgLet _x b e + -> collectArgs b ++ collectArgsE e + StgLetNoEscape _x b e + -> collectArgs b ++ collectArgsE e + StgTick _i e + -> collectArgsE e + StgLit _ + -> [] + +collectArgsA :: StgArg -> [Id] +collectArgsA = \case + StgVarArg i -> [i] + StgLitArg _ -> [] + +isLocal :: Id -> Bool +isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i) + +-- | since we have sequential initialization, topsort the non-recursive +-- constructor bindings +topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding] +topSortDecls _m binds = rest ++ nr' + where + (nr, rest) = partition isNonRec binds + isNonRec StgNonRec{} = True + isNonRec _ = False + vs = map getV nr + keys = mkUniqSet (map node_key vs) + getV e@(StgNonRec b _) = DigraphNode e b [] + getV _ = error "topSortDecls: getV, unexpected binding" + collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args)) = + [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ] + collectDeps _ = [] + g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr) + nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g] + = error "topSortDecls: unexpected cycle" + | otherwise = map node_payload (topologicalSortG g) diff --git a/compiler/GHC/StgToJS/Stack.hs b/compiler/GHC/StgToJS/Stack.hs new file mode 100644 index 0000000000..0250837f32 --- /dev/null +++ b/compiler/GHC/StgToJS/Stack.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Stack +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Utilities and wrappers for Stack manipulation in JS Land. +-- +-- In general, functions suffixed with a tick do the actual work, functions +-- suffixed with an "I" are identical to the non-I versions but work on 'Ident's +-- +-- The stack in JS land is held in the special JS array 'h$stack' and the stack +-- pointer is held in 'h$sp'. The top of the stack thus exists at +-- 'h$stack[h$sp]'. h$stack[h$sp + i] where i > 0, moves deeper into the stack +-- into older entries, whereas h$stack[h$sp - i] moves towards the top of the +-- stack. +-- +-- The stack layout algorithm is slightly peculiar. It makes an effort to +-- remember recently popped things so that if these values need to be pushed +-- then they can be quickly. The implementation for this is storing these values +-- above the stack pointer, and the pushing will skip slots that we know we will +-- use and fill in slots marked as unknown. Thus, you may find that our push and +-- pop functions do some non-traditional stack manipulation such as adding slots +-- in pop or removing slots in push. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Stack + ( resetSlots + , isolateSlots + , setSlots + , getSlots + , addSlots + , dropSlots + , addUnknownSlots + , push + , push' + , adjSpN + , adjSpN' + , adjSp' + , adjSp + , pushNN + , pushNN' + , pushN' + , pushN + , pushOptimized' + , pushOptimized + , pushLneFrame + , popN + , popSkip + , popSkipI + , loadSkip + -- * Thunk update + , updateThunk + , updateThunk' + , bhStats + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Ids +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Regs + +import GHC.Types.Id +import GHC.Utils.Misc +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import qualified Data.List as L +import qualified Control.Monad.Trans.State.Strict as State +import Data.Array +import Data.Monoid +import Control.Monad + +-- | Run the action, 'm', with no stack info +resetSlots :: G a -> G a +resetSlots m = do + s <- getSlots + d <- getStackDepth + setSlots [] + a <- m + setSlots s + setStackDepth d + return a + +-- | run the action, 'm', with current stack info, but don't let modifications +-- propagate +isolateSlots :: G a -> G a +isolateSlots m = do + s <- getSlots + d <- getStackDepth + a <- m + setSlots s + setStackDepth d + pure a + +-- | Set stack depth +setStackDepth :: Int -> G () +setStackDepth d = modifyGroup (\s -> s { ggsStackDepth = d}) + +-- | Get stack depth +getStackDepth :: G Int +getStackDepth = State.gets (ggsStackDepth . gsGroup) + +-- | Modify stack depth +modifyStackDepth :: (Int -> Int) -> G () +modifyStackDepth f = modifyGroup (\s -> s { ggsStackDepth = f (ggsStackDepth s) }) + +-- | overwrite our stack knowledge +setSlots :: [StackSlot] -> G () +setSlots xs = modifyGroup (\g -> g { ggsStack = xs}) + +-- | retrieve our current stack knowledge +getSlots :: G [StackSlot] +getSlots = State.gets (ggsStack . gsGroup) + +-- | Modify stack slots +modifySlots :: ([StackSlot] -> [StackSlot]) -> G () +modifySlots f = modifyGroup (\g -> g { ggsStack = f (ggsStack g)}) + +-- | add `n` unknown slots to our stack knowledge +addUnknownSlots :: Int -> G () +addUnknownSlots n = addSlots (replicate n SlotUnknown) + +-- | add knowledge about the stack slots +addSlots :: [StackSlot] -> G () +addSlots xs = do + s <- getSlots + setSlots (xs ++ s) + +-- | drop 'n' slots from our stack knowledge +dropSlots :: Int -> G () +dropSlots n = modifySlots (drop n) + +push :: [JExpr] -> G JStat +push xs = do + dropSlots (length xs) + modifyStackDepth (+ (length xs)) + flip push' xs <$> getSettings + +push' :: StgToJSConfig -> [JExpr] -> JStat +push' _ [] = mempty +push' cs xs + | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items + | otherwise = ApplStat (toJExpr $ pushN ! l) xs + where + items = zipWith f [(1::Int)..] xs + offset i | i == l = sp + | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) + l = length xs + f i e = AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e) + + +-- | Grow the stack pointer by 'n' without modifying the stack depth. The stack +-- is just a JS array so we add to grow (instead of the traditional subtract) +adjSp' :: Int -> JStat +adjSp' 0 = mempty +adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n) + +-- | Shrink the stack pointer by 'n'. The stack grows downward so substract +adjSpN' :: Int -> JStat +adjSpN' 0 = mempty +adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n) + +-- | Wrapper which adjusts the stack pointer /and/ modifies the stack depth +-- tracked in 'G'. See also 'adjSp'' which actually does the stack pointer +-- manipulation. +adjSp :: Int -> G JStat +adjSp 0 = return mempty +adjSp n = do + -- grow depth by n + modifyStackDepth (+n) + return (adjSp' n) + +-- | Shrink the stack and stack pointer. NB: This function is unsafe when the +-- input 'n', is negative. This function wraps around 'adjSpN' which actually +-- performs the work. +adjSpN :: Int -> G JStat +adjSpN 0 = return mempty +adjSpN n = do + modifyStackDepth (\x -> x - n) + return (adjSpN' n) + +-- | A constant array that holds global function symbols which do N pushes onto +-- the stack. For example: +-- @ +-- function h$p1(x1) { +-- ++h$sp; +-- h$stack[(h$sp - 0)] = x1; +-- }; +-- function h$p2(x1, x2) { +-- h$sp += 2; +-- h$stack[(h$sp - 1)] = x1; +-- h$stack[(h$sp - 0)] = x2; +-- }; +-- @ +-- +-- and so on up to 32. +pushN :: Array Int Ident +pushN = listArray (1,32) $ map (TxtI . mkFastString . ("h$p"++) . show) [(1::Int)..32] + +-- | Convert all function symbols in 'pushN' to global top-level functions. This +-- is a hack which converts the function symbols to variables. This hack is +-- caught in 'GHC.StgToJS.Printer.prettyBlock'' to turn these into global +-- functions. +pushN' :: Array Int JExpr +pushN' = fmap (ValExpr . JVar) pushN + +-- | Partial Push functions. Like 'pushN' except these push functions skip +-- slots. For example, +-- @ +-- function h$pp33(x1, x2) { +-- h$sp += 6; +-- h$stack[(h$sp - 5)] = x1; +-- h$stack[(h$sp - 0)] = x2; +-- }; +-- @ +-- +-- The 33rd entry skips slots 1-4 to bind the top of the stack and the 6th +-- slot. See 'pushOptimized' and 'pushOptimized'' for use cases. +pushNN :: Array Integer Ident +pushNN = listArray (1,255) $ map (TxtI . mkFastString . ("h$pp"++) . show) [(1::Int)..255] + +-- | Like 'pushN'' but for the partial push functions +pushNN' :: Array Integer JExpr +pushNN' = fmap (ValExpr . JVar) pushNN + +pushOptimized' :: [(Id,Int)] -> G JStat +pushOptimized' xs = do + slots <- getSlots + pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown)) + where + f (i1,n1) xs2 = do + xs <- varsForId i1 + let !id_n1 = xs !! (n1-1) + + case xs2 of + SlotId i2 n2 -> pure (id_n1,i1==i2&&n1==n2) + _ -> pure (id_n1,False) + +-- | optimized push that reuses existing values on stack automatically chooses +-- an optimized partial push (h$ppN) function when possible. +pushOptimized :: [(JExpr,Bool)] -- ^ contents of the slots, True if same value is already there + -> G JStat +pushOptimized [] = return mempty +pushOptimized xs = do + dropSlots l + modifyStackDepth (+ length xs) + go . csInlinePush <$> getSettings + where + go True = inlinePush + go _ + | all snd xs = adjSp' l + | all (not.snd) xs && l <= 32 = + ApplStat (pushN' ! l) (map fst xs) + | l <= 8 && not (snd $ last xs) = + ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ] + | otherwise = inlinePush + l = length xs + sig :: Integer + sig = L.foldl1' (Bits..|.) $ zipWith (\(_e,b) i -> if not b then Bits.bit i else 0) xs [0..] + inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs) + pushSlot i (ex, False) = IdxExpr stack (offset i) |= ex + pushSlot _ _ = mempty + offset i | i == l = sp + | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) + +-- | push a let-no-escape frame onto the stack +pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat +pushLneFrame size ctx = + let ctx' = ctxLneShrinkStack ctx size + in pushOptimized' (ctxLneFrameVars ctx') + +-- | Pop things, don't update the stack knowledge in 'G' +popSkip :: Int -- ^ number of slots to skip + -> [JExpr] -- ^ assign stack slot values to these + -> JStat +popSkip 0 [] = mempty +popSkip n [] = adjSpN' n +popSkip n tgt = loadSkip n tgt <> adjSpN' (length tgt + n) + +-- | Load 'length (xs :: [JExpr])' things from the stack at offset 'n :: Int'. +-- This function does no stack pointer manipulation, it merely indexes into the +-- stack and loads payloads into 'xs'. +loadSkip :: Int -> [JExpr] -> JStat +loadSkip = loadSkipFrom sp + where + loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat + loadSkipFrom fr n xs = mconcat items + where + items = reverse $ zipWith f [(0::Int)..] (reverse xs) + -- helper to generate sp - n offset to index with + offset 0 = fr + offset n = InfixExpr SubOp fr (toJExpr n) + -- helper to load stack .! i into ex, e.g., ex = stack[i] + f i ex = ex |= IdxExpr stack (toJExpr (offset (i+n))) + + +-- | Pop but preserve the first N slots +popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat +popSkipI 0 [] = pure mempty +popSkipI n [] = popN n +popSkipI n xs = do + -- add N unknown slots + addUnknownSlots n + -- now add the slots from xs, after this line the stack should look like + -- [xs] ++ [Unknown...] ++ old_stack + addSlots (map snd xs) + -- move stack pointer into the stack by (length xs + n), basically resetting + -- the stack pointer + a <- adjSpN (length xs + n) + -- now load skipping first N slots + return (loadSkipI n (map fst xs) <> a) + +-- | Just like 'loadSkip' but operate on 'Ident's rather than 'JExpr' +loadSkipI :: Int -> [Ident] -> JStat +loadSkipI = loadSkipIFrom sp + where loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat + loadSkipIFrom fr n xs = mconcat items + where + items = reverse $ zipWith f [(0::Int)..] (reverse xs) + offset 0 = fr + offset n = InfixExpr SubOp fr (toJExpr n) + f i ex = ex ||= IdxExpr stack (toJExpr (offset (i+n))) + +-- | Blindly pop N slots +popN :: Int -> G JStat +popN n = addUnknownSlots n >> adjSpN n + +-- | Generate statements to update the current node with a blackhole +bhStats :: StgToJSConfig -> Bool -> JStat +bhStats s pushUpd = mconcat + [ if pushUpd then push' s [r1, var "h$upd_frame"] else mempty + , toJExpr R1 .^ closureEntry_ |= var "h$blackhole" + , toJExpr R1 .^ closureField1_ |= var "h$currentThread" + , toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array + ] + +-- | Wrapper around 'updateThunk'', performs the stack manipulation before +-- updating the Thunk. +updateThunk :: G JStat +updateThunk = do + settings <- getSettings + -- update frame size + let adjPushStack :: Int -> G () + adjPushStack n = do modifyStackDepth (+n) + dropSlots n + adjPushStack 2 + return $ (updateThunk' settings) + +-- | Update a thunk by checking 'StgToJSConfig'. If the config inlines black +-- holes then update inline, else make an explicit call to the black hole +-- handler. +updateThunk' :: StgToJSConfig -> JStat +updateThunk' settings = + if csInlineBlackhole settings + then bhStats settings True + else ApplStat (var "h$bh") [] diff --git a/compiler/GHC/StgToJS/StaticPtr.hs b/compiler/GHC/StgToJS/StaticPtr.hs new file mode 100644 index 0000000000..bddae1e674 --- /dev/null +++ b/compiler/GHC/StgToJS/StaticPtr.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.StaticPtr + ( initStaticPtrs + ) +where + +import GHC.Prelude +import GHC.Linker.Types (SptEntry(..)) +import GHC.Fingerprint.Type +import GHC.Types.Literal + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Ids + +initStaticPtrs :: [SptEntry] -> G JStat +initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs + where + initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do + i <- varForId sp_id + fpa <- concat <$> mapM (genLit . mkLitWord64 . fromIntegral) [w1,w2] + let sptInsert = ApplExpr (var "h$hs_spt_insert") (fpa ++ [i]) + return $ (var "h$initStatic" .^ "push") `ApplStat` [jLam sptInsert] + diff --git a/compiler/GHC/StgToJS/StgUtils.hs b/compiler/GHC/StgToJS/StgUtils.hs new file mode 100644 index 0000000000..62c494c3a7 --- /dev/null +++ b/compiler/GHC/StgToJS/StgUtils.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.StgUtils + ( bindingRefs + , hasExport + , collectTopIds + , collectIds + , removeTick + , isUpdatableRhs + , isInlineExpr + , exprRefs + -- * Live vars + , LiveVars + , liveVars + , liveStatic + , stgRhsLive + , stgExprLive + , stgTopBindLive + , stgLetNoEscapeLive + , stgLneLiveExpr + , stgLneLive + , stgLneLive' + ) +where + +import GHC.Prelude + +import GHC.Stg.Syntax +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.TyCon + +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.ForeignCall +import GHC.Types.TyThing +import GHC.Types.Name +import GHC.Types.Var.Set + +import GHC.Builtin.Names +import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Utils.Misc (seqList) +import GHC.Utils.Panic + +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.List as L +import Data.Set (Set) +import Data.Monoid + +s :: a -> Set a +s = S.singleton + +l :: (a -> Set Id) -> [a] -> Set Id +l = F.foldMap + +-- | collect Ids that this binding refers to +-- (does not include the bindees themselves) +-- first argument is Id -> StgExpr map for unfloated arguments +bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id +bindingRefs u = \case + StgNonRec _ rhs -> rhsRefs u rhs + StgRec bs -> l (rhsRefs u . snd) bs + +rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id +rhsRefs u = \case + StgRhsClosure _ _ _ _ body -> exprRefs u body + StgRhsCon _ccs d _mu _ticks args -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + +exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id +exprRefs u = \case + StgApp f args -> s f <> l (argRefs u) args + StgConApp d _n args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + StgOpApp _ args _ -> l (argRefs u) args + StgLit {} -> mempty + StgCase expr _ _ alts -> exprRefs u expr <> mconcat (fmap (altRefs u) alts) + StgLet _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgLetNoEscape _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgTick _ expr -> exprRefs u expr + +altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id +altRefs u alt = exprRefs u (alt_rhs alt) + +argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id +argRefs u = \case + StgVarArg id + | Just e <- lookupUFM u id -> exprRefs u e + | otherwise -> s id + _ -> mempty + +hasExport :: CgStgBinding -> Bool +hasExport bnd = + case bnd of + StgNonRec b e -> isExportedBind b e + StgRec bs -> any (uncurry isExportedBind) bs + where + isExportedBind _i (StgRhsCon _cc con _ _ _) = + getUnique con == staticPtrDataConKey + isExportedBind _ _ = False + +collectTopIds :: CgStgBinding -> [Id] +collectTopIds (StgNonRec b _) = [b] +collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs + in seqList xs `seq` xs + +collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id] +collectIds unfloated b = + let xs = map zapFragileIdInfo . + filter acceptId $ S.toList (bindingRefs unfloated b) + in seqList xs `seq` xs + where + acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden] + -- the GHC.Prim module has no js source file + isForbidden i + | Just m <- nameModule_maybe (getName i) = m == gHC_PRIM + | otherwise = False + +removeTick :: CgStgExpr -> CgStgExpr +removeTick (StgTick _ e) = e +removeTick e = e + +----------------------------------------------------- +-- Live vars +-- +-- TODO: should probably be moved into GHC.Stg.LiveVars + +type LiveVars = DVarSet + +liveStatic :: LiveVars -> LiveVars +liveStatic = filterDVarSet isGlobalId + +liveVars :: LiveVars -> LiveVars +liveVars = filterDVarSet (not . isGlobalId) + +stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)] +stgTopBindLive = \case + StgTopLifted b -> stgBindLive b + StgTopStringLit {} -> [] + +stgBindLive :: CgStgBinding -> [(Id, LiveVars)] +stgBindLive = \case + StgNonRec b rhs -> [(b, stgRhsLive rhs)] + StgRec bs -> map (\(b,rhs) -> (b, stgRhsLive rhs)) bs + +stgBindRhsLive :: CgStgBinding -> LiveVars +stgBindRhsLive b = + let (bs, ls) = unzip (stgBindLive b) + in delDVarSetList (unionDVarSets ls) bs + +stgRhsLive :: CgStgRhs -> LiveVars +stgRhsLive = \case + StgRhsClosure _ _ _ args e -> delDVarSetList (stgExprLive True e) args + StgRhsCon _ _ _ _ args -> unionDVarSets (map stgArgLive args) + +stgArgLive :: StgArg -> LiveVars +stgArgLive = \case + StgVarArg occ -> unitDVarSet occ + StgLitArg {} -> emptyDVarSet + +stgExprLive :: Bool -> CgStgExpr -> LiveVars +stgExprLive includeLHS = \case + StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args) + StgLit {} -> emptyDVarSet + StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args) + StgOpApp _op args _ty -> unionDVarSets (map stgArgLive args) + StgCase e b _at alts + | includeLHS -> el `unionDVarSet` delDVarSet al b + | otherwise -> delDVarSet al b + where + al = unionDVarSets (map stgAltLive alts) + el = stgExprLive True e + StgLet _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgLetNoEscape _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgTick _ti e -> stgExprLive True e + +stgAltLive :: CgStgAlt -> LiveVars +stgAltLive alt = + delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt) + +stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars +stgLetNoEscapeLive _someBool _b _e = panic "stgLetNoEscapeLive" + +bindees :: CgStgBinding -> [Id] +bindees = \case + StgNonRec b _e -> [b] + StgRec bs -> map fst bs + +isUpdatableRhs :: CgStgRhs -> Bool +isUpdatableRhs (StgRhsClosure _ _ u _ _) = isUpdatable u +isUpdatableRhs _ = False + +stgLneLive' :: CgStgBinding -> [Id] +stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b) + +stgLneLive :: CgStgBinding -> [Id] +stgLneLive (StgNonRec _b e) = stgLneLiveExpr e +stgLneLive (StgRec bs) = L.nub $ concatMap (stgLneLiveExpr . snd) bs + +stgLneLiveExpr :: CgStgRhs -> [Id] +stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs) +-- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e)) +-- stgLneLiveExpr StgRhsCon {} = [] + +-- | returns True if the expression is definitely inline +isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool) +isInlineExpr v = \case + StgApp i args + -> (emptyUniqSet, isInlineApp v i args) + StgLit{} + -> (emptyUniqSet, True) + StgConApp{} + -> (emptyUniqSet, True) + StgOpApp (StgFCallOp f _) _ _ + -> (emptyUniqSet, isInlineForeignCall f) + StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t + -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) + StgOpApp (StgPrimOp op) _ _ + -> (emptyUniqSet, primOpIsReallyInline op) + StgOpApp (StgPrimCallOp _c) _ _ + -> (emptyUniqSet, True) + StgCase e b _ alts + ->let (_ve, ie) = isInlineExpr v e + v' = addOneToUniqSet v b + (vas, ias) = unzip $ map (isInlineExpr v') (fmap alt_rhs alts) + vr = L.foldl1' intersectUniqSets vas + in (vr, (ie || b `elementOfUniqSet` v) && and ias) + StgLet _ b e + -> isInlineExpr (inspectInlineBinding v b) e + StgLetNoEscape _ _b e + -> isInlineExpr v e + StgTick _ e + -> isInlineExpr v e + +inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id +inspectInlineBinding v = \case + StgNonRec i r -> inspectInlineRhs v i r + StgRec bs -> foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs + +inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id +inspectInlineRhs v i = \case + StgRhsCon{} -> addOneToUniqSet v i + StgRhsClosure _ _ ReEntrant _ _ -> addOneToUniqSet v i + _ -> v + +isInlineForeignCall :: ForeignCall -> Bool +isInlineForeignCall (CCall (CCallSpec _ cconv safety)) = + not (playInterruptible safety) && + not (cconv /= JavaScriptCallConv && playSafe safety) + +isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool +isInlineApp v i = \case + _ | isJoinId i -> False + [] -> isUnboxedTupleType (idType i) || + isStrictType (idType i) || + i `elementOfUniqSet` v + + [StgVarArg a] + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a + -> True + _ -> False + diff --git a/compiler/GHC/StgToJS/Symbols.hs b/compiler/GHC/StgToJS/Symbols.hs new file mode 100644 index 0000000000..999c654fa8 --- /dev/null +++ b/compiler/GHC/StgToJS/Symbols.hs @@ -0,0 +1,89 @@ + +-- | JS symbol generation +module GHC.StgToJS.Symbols + ( moduleGlobalSymbol + , moduleExportsSymbol + , mkJsSymbol + , mkJsSymbolBS + , mkFreshJsSymbol + , mkRawSymbol + , intBS + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Unit.Module +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL + +-- | Hexadecimal representation of an int +-- +-- Used for uniques. We could use base-62 as GHC usually does but this is likely +-- faster. +intBS :: Int -> ByteString +intBS = BSL.toStrict . BSB.toLazyByteString . BSB.wordHex . fromIntegral + +-- | Return z-encoded unit:module +unitModuleStringZ :: Module -> ByteString +unitModuleStringZ mod = mconcat + [ fastZStringToByteString (zEncodeFS (unitIdFS (moduleUnitId mod))) + , BSC.pack "ZC" -- z-encoding for ":" + , fastZStringToByteString (zEncodeFS (moduleNameFS (moduleName mod))) + ] + +-- | the global linkable unit of a module exports this symbol, depend on it to +-- include that unit (used for cost centres) +moduleGlobalSymbol :: Module -> FastString +moduleGlobalSymbol m = mkFastStringByteString $ mconcat + [ hd + , unitModuleStringZ m + , BSC.pack "_<global>" + ] + +moduleExportsSymbol :: Module -> FastString +moduleExportsSymbol m = mkFastStringByteString $ mconcat + [ hd + , unitModuleStringZ m + , BSC.pack "_<exports>" + ] + +-- | Make JS symbol corresponding to the given Haskell symbol in the given +-- module +mkJsSymbolBS :: Bool -> Module -> FastString -> ByteString +mkJsSymbolBS exported mod s = mconcat + [ if exported then hd else hdd + , unitModuleStringZ mod + , BSC.pack "zi" -- z-encoding of "." + , fastZStringToByteString (zEncodeFS s) + ] + +-- | Make JS symbol corresponding to the given Haskell symbol in the given +-- module +mkJsSymbol :: Bool -> Module -> FastString -> FastString +mkJsSymbol exported mod s = mkFastStringByteString (mkJsSymbolBS exported mod s) + +-- | Make JS symbol for given module and unique. +mkFreshJsSymbol :: Module -> Int -> FastString +mkFreshJsSymbol mod i = mkFastStringByteString $ mconcat + [ hdd + , unitModuleStringZ mod + , BSC.pack "_" + , intBS i + ] + +-- | Make symbol "h$XYZ" or "h$$XYZ" +mkRawSymbol :: Bool -> FastString -> FastString +mkRawSymbol exported fs + | exported = mkFastStringByteString $ mconcat [ hd, bytesFS fs ] + | otherwise = mkFastStringByteString $ mconcat [ hdd, bytesFS fs ] + +-- | "h$$" constant string +hdd :: ByteString +hdd = BSC.pack "h$$" + +-- | "h$" constant string +hd :: ByteString +hd = BSC.take 2 hdd diff --git a/compiler/GHC/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs new file mode 100644 index 0000000000..2c01a30bf2 --- /dev/null +++ b/compiler/GHC/StgToJS/Types.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Types +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- Module that holds the Types required for the StgToJS pass +----------------------------------------------------------------------------- + +module GHC.StgToJS.Types where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Ppr () + +import GHC.Stg.Syntax +import GHC.Core.TyCon + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Var +import GHC.Types.ForeignCall + +import Control.Monad.Trans.State.Strict +import GHC.Utils.Outputable (Outputable (..), text, SDocContext, (<+>), ($$)) + +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import GHC.Unit.Module + +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.ByteString as BS +import Data.Monoid +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Control.DeepSeq + +-- | A State monad over IO holding the generator state. +type G = StateT GenState IO + +-- | The JS code generator state +data GenState = GenState + { gsSettings :: !StgToJSConfig -- ^ codegen settings, read-only + , gsModule :: !Module -- ^ current module + , gsId :: {-# UNPACK #-} !FastMutInt -- ^ unique number for the id generator + , gsIdents :: !IdCache -- ^ hash consing for identifiers from a Unique + , gsUnfloated :: !(UniqFM Id CgStgExpr) -- ^ unfloated arguments + , gsGroup :: GenGroupState -- ^ state for the current binding group + , gsGlobal :: [JStat] -- ^ global (per module) statements (gets included when anything else from the module is used) + } + +-- | The JS code generator state relevant for the current binding group +data GenGroupState = GenGroupState + { ggsToplevelStats :: [JStat] -- ^ extra toplevel statements for the binding group + , ggsClosureInfo :: [ClosureInfo] -- ^ closure metadata (info tables) for the binding group + , ggsStatic :: [StaticInfo] -- ^ static (CAF) data in our binding group + , ggsStack :: [StackSlot] -- ^ stack info for the current expression + , ggsStackDepth :: Int -- ^ current stack depth + , ggsExtraDeps :: Set OtherSymb -- ^ extra dependencies for the linkable unit that contains this group + , ggsGlobalIdCache :: GlobalIdCache + , ggsForeignRefs :: [ForeignJSRef] + } + +-- | The Configuration record for the StgToJS pass +data StgToJSConfig = StgToJSConfig + -- flags + { csInlinePush :: !Bool + , csInlineBlackhole :: !Bool + , csInlineLoadRegs :: !Bool + , csInlineEnter :: !Bool + , csInlineAlloc :: !Bool + , csTraceRts :: !Bool + , csAssertRts :: !Bool + , csBoundsCheck :: !Bool + , csDebugAlloc :: !Bool + , csTraceForeign :: !Bool + , csProf :: !Bool -- ^ Profiling enabled + , csRuntimeAssert :: !Bool -- ^ Enable runtime assertions + -- settings + , csContext :: !SDocContext + } + +-- | Information relevenat to code generation for closures. +data ClosureInfo = ClosureInfo + { ciVar :: Ident -- ^ object being infod + , ciRegs :: CIRegs -- ^ size of the payload (in number of JS values) + , ciName :: FastString -- ^ friendly name for printing + , ciLayout :: CILayout -- ^ heap/stack layout of the object + , ciType :: CIType -- ^ type of the object, with extra info where required + , ciStatic :: CIStatic -- ^ static references of this object + } + deriving stock (Eq, Show, Generic) + +-- | Closure information, 'ClosureInfo', registers +data CIRegs + = CIRegsUnknown -- ^ A value witnessing a state of unknown registers + | CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start + , ciRegsTypes :: [VarType] -- ^ args + } + deriving stock (Eq, Ord, Show, Generic) + +instance NFData CIRegs + +-- | Closure Information, 'ClosureInfo', layout +data CILayout + = CILayoutVariable -- ^ layout stored in object itself, first position from the start + | CILayoutUnknown -- ^ fixed size, but content unknown (for example stack apply frame) + { layoutSize :: !Int + } + | CILayoutFixed -- ^ whole layout known + { layoutSize :: !Int -- ^ closure size in array positions, including entry + , layout :: [VarType] -- ^ The set of sized Types to layout + } + deriving stock (Eq, Ord, Show, Generic) + +instance NFData CILayout + +-- | The type of 'ClosureInfo' +data CIType + = CIFun { citArity :: !Int -- ^ function arity + , citRegs :: !Int -- ^ number of registers for the args + } + | CIThunk -- ^ The closure is a THUNK + | CICon { citConstructor :: !Int } -- ^ The closure is a Constructor + | CIPap -- ^ The closure is a Partial Application + | CIBlackhole -- ^ The closure is a black hole + | CIStackFrame -- ^ The closure is a stack frame + deriving stock (Eq, Ord, Show, Generic) + +instance NFData CIType + +-- | Static references that must be kept alive +newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] } + deriving stock (Eq, Generic) + deriving newtype (Semigroup, Monoid, Show) + +-- | static refs: array = references, null = nothing to report +-- note: only works after all top-level objects have been created +instance ToJExpr CIStatic where + toJExpr (CIStaticRefs []) = null_ -- [je| null |] + toJExpr (CIStaticRefs rs) = toJExpr (map TxtI rs) + +-- | Free variable types +data VarType + = PtrV -- ^ pointer = reference to heap object (closure object) + | VoidV -- ^ no fields + | DoubleV -- ^ A Double: one field + | IntV -- ^ An Int (32bit because JS): one field + | LongV -- ^ A Long: two fields one for the upper 32bits, one for the lower (NB: JS is little endian) + | AddrV -- ^ a pointer not to the heap: two fields, array + index + | RtsObjV -- ^ some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#) + | ObjV -- ^ some JS object, user supplied, be careful around these, can be anything + | ArrV -- ^ boxed array + deriving stock (Eq, Ord, Enum, Bounded, Show, Generic) + +instance NFData VarType + +instance ToJExpr VarType where + toJExpr = toJExpr . fromEnum + +-- | The type of identifiers. These determine the suffix of generated functions +-- in JS Land. For example, the entry function for the 'Just' constructor is a +-- 'IdConEntry' which compiles to: +-- @ +-- function h$baseZCGHCziMaybeziJust_con_e() { return h$rs() }; +-- @ +-- which just returns whatever the stack point is pointing to. Whereas the entry +-- function to 'Just' is an 'IdEntry' and does the work. It compiles to: +-- @ +-- function h$baseZCGHCziMaybeziJust_e() { +-- var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2; +-- h$r1 = h$c1(h$baseZCGHCziMaybeziJust_con_e, h$$baseZCGHCziMaybezieta_8KXnScrCjF5); +-- return h$rs(); +-- }; +-- @ +-- Which loads some payload from register 2, and applies the Constructor Entry +-- function for the Just to the payload, returns the result in register 1 and +-- returns whatever is on top of the stack +data IdType + = IdPlain -- ^ A plain identifier for values, no suffix added + | IdEntry -- ^ An entry function, suffix = "_e" in 'GHC.StgToJS.Ids.makeIdentForId' + | IdConEntry -- ^ A Constructor entry function, suffix = "_con_e" in 'GHC.StgToJS.Ids.makeIdentForId' + deriving (Enum, Eq, Ord) + +-- | Keys to differentiate Ident's in the ID Cache +data IdKey + = IdKey !Int !Int !IdType + deriving (Eq, Ord) + +-- | Some other symbol +data OtherSymb + = OtherSymb !Module !FastString + deriving Eq + +instance Ord OtherSymb where + compare (OtherSymb m1 t1) (OtherSymb m2 t2) + = stableModuleCmp m1 m2 <> lexicalCompareFS t1 t2 + +-- | The identifier cache indexed on 'IdKey' local to a module +newtype IdCache = IdCache (M.Map IdKey Ident) + +-- | The global Identifier Cache +newtype GlobalIdCache = GlobalIdCache (UniqFM Ident (IdKey, Id)) + +-- | A Stack Slot is either known or unknown. We avoid maybe here for more +-- strictness. +data StackSlot + = SlotId !Id !Int + | SlotUnknown + deriving (Eq, Ord) + +data StaticInfo = StaticInfo + { siVar :: !FastString -- ^ global object + , siVal :: !StaticVal -- ^ static initialization + , siCC :: !(Maybe Ident) -- ^ optional CCS name + } deriving stock (Eq, Show, Typeable, Generic) + +data StaticVal + = StaticFun !FastString [StaticArg] + -- ^ heap object for function + | StaticThunk !(Maybe (FastString,[StaticArg])) + -- ^ heap object for CAF (field is Nothing when thunk is initialized in an + -- alternative way, like string thunks through h$str) + | StaticUnboxed !StaticUnboxed + -- ^ unboxed constructor (Bool, Int, Double etc) + | StaticData !FastString [StaticArg] + -- ^ regular datacon app + | StaticList [StaticArg] (Maybe FastString) + -- ^ list initializer (with optional tail) + deriving stock (Eq, Show, Generic) + +data StaticUnboxed + = StaticUnboxedBool !Bool + | StaticUnboxedInt !Integer + | StaticUnboxedDouble !SaneDouble + | StaticUnboxedString !BS.ByteString + | StaticUnboxedStringOffset !BS.ByteString + deriving stock (Eq, Ord, Show, Generic) + +instance NFData StaticUnboxed + +-- | Static Arguments. Static Arguments are things that are statically +-- allocated, i.e., they exist at program startup. These are static heap objects +-- or literals or things that have been floated to the top level binding by ghc. +data StaticArg + = StaticObjArg !FastString -- ^ reference to a heap object + | StaticLitArg !StaticLit -- ^ literal + | StaticConArg !FastString [StaticArg] -- ^ unfloated constructor + deriving stock (Eq, Show, Generic) + +instance Outputable StaticArg where + ppr x = text (show x) + +-- | A Static literal value +data StaticLit + = BoolLit !Bool + | IntLit !Integer + | NullLit + | DoubleLit !SaneDouble -- should we actually use double here? + | StringLit !FastString + | BinLit !BS.ByteString + | LabelLit !Bool !FastString -- ^ is function pointer, label (also used for string / binary init) + deriving (Eq, Show, Generic) + +instance Outputable StaticLit where + ppr x = text (show x) + + +instance ToJExpr StaticLit where + toJExpr (BoolLit b) = toJExpr b + toJExpr (IntLit i) = toJExpr i + toJExpr NullLit = null_ + toJExpr (DoubleLit d) = toJExpr (unSaneDouble d) + toJExpr (StringLit t) = app (mkFastString "h$str") [toJExpr t] + toJExpr (BinLit b) = app (mkFastString "h$rstr") [toJExpr (map toInteger (BS.unpack b))] + toJExpr (LabelLit _isFun lbl) = var lbl + +-- | A foreign reference to some JS code +data ForeignJSRef = ForeignJSRef + { foreignRefSrcSpan :: !FastString + , foreignRefPattern :: !FastString + , foreignRefSafety :: !Safety + , foreignRefCConv :: !CCallConv + , foreignRefArgs :: ![FastString] + , foreignRefResult :: !FastString + } deriving stock (Generic) + +-- | data used to generate one ObjUnit in our object file +data LinkableUnit = LinkableUnit + { luObjUnit :: ObjUnit -- ^ serializable unit info + , luIdExports :: [Id] -- ^ exported names from haskell identifiers + , luOtherExports :: [FastString] -- ^ other exports + , luIdDeps :: [Id] -- ^ identifiers this unit depends on + , luPseudoIdDeps :: [Unique] -- ^ pseudo-id identifiers this unit depends on (fixme) + , luOtherDeps :: [OtherSymb] -- ^ symbols not from a haskell id that this unit depends on + , luRequired :: Bool -- ^ always link this unit + , luForeignRefs :: [ForeignJSRef] + } + +-- | one toplevel block in the object file +data ObjUnit = ObjUnit + { oiSymbols :: ![FastString] -- ^ toplevel symbols (stored in index) + , oiClInfo :: ![ClosureInfo] -- ^ closure information of all closures in block + , oiStatic :: ![StaticInfo] -- ^ static closure data + , oiStat :: JStat -- ^ the code + , oiRaw :: !BS.ByteString -- ^ raw JS code + , oiFExports :: ![ExpFun] + , oiFImports :: ![ForeignJSRef] + } + +data ExpFun = ExpFun + { isIO :: !Bool + , args :: [JSFFIType] + , result :: !JSFFIType + } deriving (Eq, Ord, Show) + +-- | Types of FFI values +data JSFFIType + = Int8Type + | Int16Type + | Int32Type + | Int64Type + | Word8Type + | Word16Type + | Word32Type + | Word64Type + | DoubleType + | ByteArrayType + | PtrType + | RefType + deriving (Show, Ord, Eq, Enum) + + +-- | Typed expression +data TypedExpr = TypedExpr + { typex_typ :: !PrimRep + , typex_expr :: [JExpr] + } + +instance Outputable TypedExpr where + ppr x = text "TypedExpr: " <+> ppr (typex_expr x) + $$ text "PrimReps: " <+> ppr (typex_typ x) + +-- | A Primop result is either an inlining of some JS payload, or a primitive +-- call to a JS function defined in Shim files in base. +data PrimRes + = PrimInline JStat -- ^ primop is inline, result is assigned directly + | PRPrimCall JStat -- ^ primop is async call, primop returns the next + -- function to run. result returned to stack top in registers + +data ExprResult + = ExprCont + | ExprInline (Maybe [JExpr]) + deriving (Eq) + +newtype ExprValData = ExprValData [JExpr] + deriving newtype (Eq) + +-- | A Closure is one of six types +data ClosureType + = Thunk -- ^ The closure is a THUNK + | Fun -- ^ The closure is a Function + | Pap -- ^ The closure is a Partial Application + | Con -- ^ The closure is a Constructor + | Blackhole -- ^ The closure is a Blackhole + | StackFrame -- ^ The closure is a stack frame + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Convert 'ClosureType' to an Int +ctNum :: ClosureType -> Int +ctNum Fun = 1 +ctNum Con = 2 +ctNum Thunk = 0 +ctNum Pap = 3 +ctNum Blackhole = 5 +ctNum StackFrame = -1 + +-- | Convert 'ClosureType' to a String +ctJsName :: ClosureType -> String +ctJsName = \case + Thunk -> "CLOSURE_TYPE_THUNK" + Fun -> "CLOSURE_TYPE_FUN" + Pap -> "CLOSURE_TYPE_PAP" + Con -> "CLOSURE_TYPE_CON" + Blackhole -> "CLOSURE_TYPE_BLACKHOLE" + StackFrame -> "CLOSURE_TYPE_STACKFRAME" + +instance ToJExpr ClosureType where + toJExpr e = toJExpr (ctNum e) + + +-- | A thread is in one of 4 states +data ThreadStatus + = Running -- ^ The thread is running + | Blocked -- ^ The thread is blocked + | Finished -- ^ The thread is done + | Died -- ^ The thread has died + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Convert the status of a thread in JS land to an Int +threadStatusNum :: ThreadStatus -> Int +threadStatusNum = \case + Running -> 0 + Blocked -> 1 + Finished -> 16 + Died -> 17 + +-- | convert the status of a thread in JS land to a string +threadStatusJsName :: ThreadStatus -> String +threadStatusJsName = \case + Running -> "THREAD_RUNNING" + Blocked -> "THREAD_BLOCKED" + Finished -> "THREAD_FINISHED" + Died -> "THREAD_DIED" diff --git a/compiler/GHC/StgToJS/Utils.hs b/compiler/GHC/StgToJS/Utils.hs new file mode 100644 index 0000000000..8d16f39a64 --- /dev/null +++ b/compiler/GHC/StgToJS/Utils.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Utils + ( assignToTypedExprs + , assignCoerce1 + , assignToExprCtx + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types +import GHC.StgToJS.ExprCtx + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Core.TyCon + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable + +assignToTypedExprs :: HasDebugCallStack => [TypedExpr] -> [JExpr] -> JStat +assignToTypedExprs tes es = + assignAllEqual (concatMap typex_expr tes) es + +assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStat +assignTypedExprs tes es = + -- TODO: check primRep (typex_typ) here? + assignToTypedExprs tes (concatMap typex_expr es) + +assignToExprCtx :: HasDebugCallStack => ExprCtx -> [JExpr] -> JStat +assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es + +-- | Assign first expr only (if it exists), performing coercions between some +-- PrimReps (e.g. StablePtr# and Addr#). +assignCoerce1 :: HasDebugCallStack => [TypedExpr] -> [TypedExpr] -> JStat +assignCoerce1 [x] [y] = assignCoerce x y +assignCoerce1 [] [] = mempty +assignCoerce1 x y = pprPanic "assignCoerce1" + (vcat [ text "lengths do not match" + , ppr x + , ppr y + ]) + +-- | Assign p2 to p1 with optional coercion +assignCoerce :: TypedExpr -> TypedExpr -> JStat +-- Coercion between StablePtr# and Addr# +assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr UnliftedRep [sptr]) = mconcat + [ a_val |= var "h$stablePtrBuf" + , a_off |= sptr + ] +assignCoerce (TypedExpr UnliftedRep [sptr]) (TypedExpr AddrRep [_a_val, a_off]) = + sptr |= a_off +assignCoerce p1 p2 = assignTypedExprs [p1] [p2] + diff --git a/compiler/GHC/SysTools/Cpp.hs b/compiler/GHC/SysTools/Cpp.hs index 1754def83d..61f70342a6 100644 --- a/compiler/GHC/SysTools/Cpp.hs +++ b/compiler/GHC/SysTools/Cpp.hs @@ -231,4 +231,3 @@ offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs offsetIncludePaths dflags (IncludeSpecs incs quotes impl) = let go = map (augmentByWorkingDirectory dflags) in IncludeSpecs (go incs) (go quotes) (go impl) - diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index a1846980a1..465b86a181 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -159,6 +159,10 @@ runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do ,pgm_c dflags, "Asm Compiler") RawObject -> ("c", [] ,pgm_c dflags, "C Compiler") -- claim C for lack of a better idea + --JS backend shouldn't reach here, so we just pass + -- strings to satisfy the totality checker + LangJs -> ("js", [] + ,pgm_c dflags, "JS Backend Compiler") userOpts_c = getOpts dflags opt_c userOpts_cxx = getOpts dflags opt_cxx @@ -221,6 +225,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/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index e4b741f13a..caa7feeca7 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -340,6 +340,10 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty return (CImport src (L lc cconv) (L ls safety) mh (CFunction target)) + | cconv == JavaScriptCallConv = do + checkCg (Right idecl) backendValidityOfCImport + -- leave the rest to the JS backend (at least for now) + return (CImport src (L lc cconv) (L ls safety) mh (CFunction target)) | otherwise = do -- Normal foreign import checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 5c58a73701..e6d03af276 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -977,7 +977,7 @@ removeBindingShadowing bindings = reverse $ fst $ foldl -- | Get target platform -getPlatform :: TcM Platform +getPlatform :: TcRnIf a b Platform getPlatform = targetPlatform <$> getDynFlags --------------------------- diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs index aef23be566..b889ba2bbd 100644 --- a/compiler/GHC/Types/Unique/Map.hs +++ b/compiler/GHC/Types/Unique/Map.hs @@ -61,7 +61,7 @@ import Data.Maybe import Data.Data -- | Maps indexed by 'Uniquable' keys -newtype UniqMap k a = UniqMap (UniqFM k (k, a)) +newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) } deriving (Data, Eq, Functor) type role UniqMap nominal representational diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index c2d36c5c0e..4ae489d631 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -42,6 +42,7 @@ module GHC.Unit.Module.Graph where import GHC.Prelude +import GHC.Platform import qualified GHC.LanguageExtensions as LangExt @@ -262,7 +263,8 @@ showModMsg dflags _ (LinkNode {}) = _ -> False platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile_ dflags) + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) in text exe_file showModMsg _ _ (InstantiationNode _uid indef_unit) = ppr $ instUnitInstanceOf indef_unit diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 26328d8d05..99d5a01665 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -34,6 +34,7 @@ module GHC.Utils.Binary SymbolTable, Dictionary, BinData(..), dataHandle, handleData, + unsafeUnpackBinBuffer, openBinMem, -- closeBin, @@ -47,8 +48,10 @@ module GHC.Utils.Binary writeBinMem, readBinMem, + readBinMemN, putAt, getAt, + forwardPut, forwardPut_, forwardGet, -- * For writing instances putByte, @@ -71,8 +74,11 @@ module GHC.Utils.Binary -- * User data UserData(..), getUserData, setUserData, - newReadState, newWriteState, + newReadState, newWriteState, noUserData, + + -- * String table ("dictionary") putDictionary, getDictionary, putFS, + FSTable, initFSTable, getDictFastString, putDictFastString, -- * Newtype wrappers BinSpan(..), BinSrcSpan(..), BinLocated(..) @@ -89,10 +95,11 @@ import GHC.Types.Unique.FM import GHC.Data.FastMutInt import GHC.Utils.Fingerprint import GHC.Types.SrcLoc +import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import Control.DeepSeq -import Foreign hiding (shiftL, shiftR) +import Foreign hiding (shiftL, shiftR, void) import Data.Array import Data.Array.IO import Data.Array.Unsafe @@ -107,7 +114,7 @@ import Data.Set ( Set ) import qualified Data.Set as Set import Data.Time import Data.List (unfoldr) -import Control.Monad ( when, (<$!>), unless, forM_ ) +import Control.Monad ( when, (<$!>), unless, forM_, void ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -186,6 +193,12 @@ withBinBuffer (BinMem _ ix_r _ arr_r) action = do ix <- readFastMutInt ix_r action $ BS.fromForeignPtr arr 0 ix +unsafeUnpackBinBuffer :: ByteString -> IO BinHandle +unsafeUnpackBinBuffer (BS.BS arr len) = do + arr_r <- newIORef arr + ix_r <- newFastMutInt 0 + sz_r <- newFastMutInt len + return (BinMem noUserData ix_r sz_r arr_r) --------------------------------------------------------------- -- Bin @@ -222,7 +235,7 @@ getAt bh p = do seekBin bh p; get bh openBinMem :: Int -> IO BinHandle openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" + | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- mallocForeignPtrBytes size arr_r <- newIORef arr @@ -240,6 +253,14 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p +-- | SeekBin but without calling expandBin +seekBinNoExpand :: BinHandle -> Bin a -> IO () +seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then panic "seekBinNoExpand: seek out of range" + else writeFastMutInt ix_r p + writeBinMem :: BinHandle -> FilePath -> IO () writeBinMem (BinMem _ ix_r _ arr_r) fn = do h <- openBinaryFile fn WriteMode @@ -249,16 +270,27 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do hClose h readBinMem :: FilePath -> IO BinHandle --- Return a BinHandle with a totally undefined State readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + readBinMem_ filesize h + +readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle) +readBinMemN size filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + if filesize < size + then pure Nothing + else Just <$> readBinMem_ size h + +readBinMem_ :: Int -> Handle -> IO BinHandle +readBinMem_ filesize h = do arr <- mallocForeignPtrBytes filesize count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize when (count /= filesize) $ error ("Binary.readBinMem: only read " ++ show count ++ " bytes") - hClose h arr_r <- newIORef arr ix_r <- newFastMutInt 0 sz_r <- newFastMutInt filesize @@ -557,7 +589,9 @@ getSLEB128 bh = do -- | Encode the argument in it's full length. This is different from many default -- binary instances which make no guarantee about the actual encoding and -- might do things use variable length encoding. -newtype FixedLengthEncoding a = FixedLengthEncoding { unFixedLength :: a } +newtype FixedLengthEncoding a + = FixedLengthEncoding { unFixedLength :: a } + deriving (Eq,Ord,Show) instance Binary (FixedLengthEncoding Word8) where put_ h (FixedLengthEncoding x) = putByte h x @@ -920,6 +954,45 @@ instance Binary (Bin a) where -- ----------------------------------------------------------------------------- +-- Forward reading/writing + +-- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B +-- by using a forward reference +forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPut bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBin bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBin bh + putAt bh pre_a a + seekBinNoExpand bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO () +forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B + +-- | Read a value stored using a forward reference +forwardGet :: BinHandle -> IO a -> IO a +forwardGet bh get_A = do + -- read forward reference + p <- get bh -- a BinPtr + -- store current position + p_a <- tellBin bh + -- go read the forward value, then seek back + seekBinNoExpand bh p + r <- get_A + seekBinNoExpand bh p_a + pure r + +-- ----------------------------------------------------------------------------- -- Lazy reading/writing lazyPut :: Binary a => BinHandle -> a -> IO () @@ -1026,8 +1099,14 @@ newWriteState put_nonbinding_name put_binding_name put_fs ud_put_fs = put_fs } -noUserData :: a -noUserData = undef "UserData" +noUserData :: UserData +noUserData = UserData + { ud_get_name = undef "get_name" + , ud_get_fs = undef "get_fs" + , ud_put_nonbinding_name = undef "put_nonbinding_name" + , ud_put_binding_name = undef "put_binding_name" + , ud_put_fs = undef "put_fs" + } undef :: String -> a undef s = panic ("Binary.UserData: no " ++ s) @@ -1055,6 +1134,58 @@ getDictionary bh = do writeArray mut_arr i fs unsafeFreeze mut_arr +getDictFastString :: Dictionary -> BinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + + +initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int) +initFSTable bh = do + dict_next_ref <- newFastMutInt 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = FSTable + { fs_tab_next = dict_next_ref + , fs_tab_map = dict_map_ref + } + let put_dict = do + fs_count <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh fs_count dict_map + pure fs_count + + -- BinHandle with FastString writing support + let ud = getUserData bh + let ud_fs = ud { ud_put_fs = putDictFastString bin_dict } + let bh_fs = setUserData bh ud_fs + + return (bh_fs,bin_dict,put_dict) + +putDictFastString :: FSTable -> BinHandle -> FastString -> IO () +putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: FSTable -> FastString -> IO Word32 +allocateFastString FSTable { fs_tab_next = j_r + , fs_tab_map = out_r + } f = do + out <- readIORef out_r + let !uniq = getUnique f + case lookupUFM_Directly out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM_Directly out uniq (j, f) + return (fromIntegral j :: Word32) + +-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to +-- avoid a collision and copy to avoid a dependency. +data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use + , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString))) + -- indexed by FastString + } + + --------------------------------------------------------- -- The Symbol Table --------------------------------------------------------- diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index 4603b42d7b..618ded2669 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -202,6 +202,7 @@ data DumpFormat | FormatASM -- ^ Assembly code | FormatC -- ^ C code/header | FormatLLVM -- ^ LLVM bytecode + | FormatJS -- ^ JavaScript code | FormatText -- ^ Unstructured dump deriving (Show,Eq) diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 0d5eabeb0b..a115c61336 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -228,10 +228,10 @@ are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not? -} -zipEqual :: String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipEqual :: HasDebugCallStack => String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #if !defined(DEBUG) zipEqual _ = zip diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs index c5e24794a4..d91570223c 100644 --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -19,6 +19,8 @@ module GHC.Utils.Monad , anyM, allM, orM , foldlM, foldlM_, foldrM , whenM, unlessM + , filterOutM + , partitionM ) where ------------------------------------------------------------------------------- @@ -226,6 +228,19 @@ unlessM :: Monad m => m Bool -> m () -> m () unlessM condM acc = do { cond <- condM ; unless cond acc } +-- | Like 'filterM', only it reverses the sense of the test. +filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] +filterOutM p = + foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) + +-- | Monadic version of @partition@ +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + pure ([x | res]++as, [x | not res]++bs) + {- Note [The one-shot state monad trick] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Summary: many places in GHC use a state monad, and we really want those diff --git a/compiler/GHC/Utils/Panic/Plain.hs b/compiler/GHC/Utils/Panic/Plain.hs index 656b7f2fa8..10b963bf5d 100644 --- a/compiler/GHC/Utils/Panic/Plain.hs +++ b/compiler/GHC/Utils/Panic/Plain.hs @@ -101,11 +101,12 @@ throwPlainGhcException :: PlainGhcException -> a throwPlainGhcException = Exception.throw -- | Panics and asserts. -panic, sorry, pgmError :: String -> a +panic, sorry, pgmError :: HasCallStack => String -> a panic x = unsafeDupablePerformIO $ do stack <- ccsToStrings =<< getCurrentCCS x + let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack) if null stack - then throwPlainGhcException (PlainPanic x) + then throwPlainGhcException (PlainPanic (x ++ '\n' : doc)) else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) sorry x = throwPlainGhcException (PlainSorry x) diff --git a/compiler/GHC/Utils/Ppr.hs b/compiler/GHC/Utils/Ppr.hs index 4c28f083af..51af55b06b 100644 --- a/compiler/GHC/Utils/Ppr.hs +++ b/compiler/GHC/Utils/Ppr.hs @@ -79,7 +79,7 @@ module GHC.Utils.Ppr ( lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- ** Wrapping documents in delimiters - parens, brackets, braces, quotes, quote, doubleQuotes, + parens, brackets, braces, quotes, squotes, quote, doubleQuotes, maybeParens, -- ** Combining documents @@ -108,7 +108,7 @@ module GHC.Utils.Ppr ( -- ** GHC-specific rendering printDoc, printDoc_, - bufLeftRender -- performance hack + bufLeftRender, printLeftRender -- performance hack ) where @@ -462,10 +462,12 @@ hex n = text ('0' : 'x' : padded) parens :: Doc -> Doc -- ^ Wrap document in @(...)@ brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ braces :: Doc -> Doc -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ +quotes :: Doc -> Doc -- ^ Wrap document in @\`...\'@ +squotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ quote :: Doc -> Doc doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ quotes p = char '`' <> p <> char '\'' +squotes p = char '\'' <> p <> char '\'' quote p = char '\'' <> p doubleQuotes p = char '"' <> p <> char '"' parens p = char '(' <> p <> char ')' @@ -1170,16 +1172,14 @@ bufLeftRender :: BufHandle -> Doc -> IO () bufLeftRender b doc = layLeft b (reduceDoc doc) layLeft :: BufHandle -> Doc -> IO () -layLeft b _ | b `seq` False = undefined -- make it strict in b -layLeft _ NoDoc = error "layLeft: NoDoc" +layLeft !_ NoDoc = error "layLeft: NoDoc" layLeft b (Union p q) = layLeft b $! first p q layLeft b (Nest _ p) = layLeft b $! p layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) -layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) +layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p +layLeft b (TextBeside s _ p) = put b s >> layLeft b p where - put b _ | b `seq` False = undefined - put b (Chr c) = bPutChar b c + put !b (Chr c) = bPutChar b c put b (Str s) = bPutStr b s put b (PStr s) = bPutFS b s put b (ZStr s) = bPutFZS b s |