diff options
45 files changed, 8449 insertions, 189 deletions
diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 574cfa4659..509c11592a 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, @@ -17,7 +18,7 @@ module GHC.Builtin.PrimOps ( primOpOutOfLine, primOpCodeSize, primOpOkForSpeculation, primOpOkForSideEffects, primOpIsCheap, primOpFixity, primOpDocs, - primOpIsDiv, + primOpIsDiv, primOpIsReallyInline, getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), @@ -804,3 +805,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 afe8176f78..c804840c90 100644 --- a/compiler/GHC/Driver/Backend.hs +++ b/compiler/GHC/Driver/Backend.hs @@ -193,8 +193,6 @@ import GHC.Platform --------------------------------------------------------------------------------- - - platformDefaultBackend :: Platform -> Backend platformDefaultBackend platform = if | platformUnregisterised platform -> viaCBackend @@ -216,6 +214,14 @@ platformNcgSupported platform = if ArchAArch64 -> True _ -> False +-- | Will this backend produce an object file on the disk? +backendProducesObject :: Backend -> Bool +backendProducesObject ViaC = True +backendProducesObject NCG = True +backendProducesObject LLVM = True +backendProducesObject JavaScript = True +backendProducesObject Interpreter = False +backendProducesObject NoBackend = False -- | AÂ value of type @Backend@ represents one of GHC's back ends. @@ -246,7 +252,7 @@ instance Show Backend where show = backendDescription -ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend +ncgBackend, llvmBackend, viaCBackend, interpreterBackend, jsBackend, noBackend :: Backend -- | The native code generator. @@ -273,6 +279,23 @@ ncgBackend = Named NCG -- See "GHC.CmmToLlvm" llvmBackend = Named LLVM +-- | The JavaScript Backend +-- +-- Compiles Stg code to JS, the relies on the +-- JS toolchain to produce workable code. +-- +-- Notable points are: +-- 1. The JS backend /does not/ rely on GHC's native RTS or linker. +-- 2. Instead, the JS backend writes its own RTS. This RTS is split between +-- Haskell (see "GHC.StgToJS.Rts") and JavaScript (see "js" directory in root of +-- GHC project). +-- 3. "Linking" in the JS backend is not actually linking, rather it is merging +-- JS concrete syntax with static guarentees that all symbols used are defined +-- before their call sites (see "GHC.StgToJS.Linker"). +-- +-- See "GHC.StgToJS" +jsBackend = Named JavaScript + -- | Via-C ("unregisterised") backend. -- -- Compiles Cmm code into C code, then relies on a C compiler @@ -328,8 +351,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 @@ -343,6 +367,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. @@ -359,6 +385,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. @@ -386,6 +414,7 @@ data DefunctionalizedCodeOutput = NcgCodeOutput | ViaCCodeOutput | LlvmCodeOutput + | JSCodeOutput -- | Names a function that tells the driver what should happen after @@ -406,6 +435,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 @@ -431,42 +461,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 via emscripten" 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 +backendDescription (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 @@ -486,33 +520,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 @@ -521,11 +558,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 @@ -533,11 +571,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 @@ -546,11 +585,12 @@ 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 @@ -560,6 +600,7 @@ backendSimdValidity :: Backend -> Validity' String backendSimdValidity (Named NCG) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] backendSimdValidity (Named LLVM) = IsValid backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdJavaScript (Named JavaScript) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] backendSimdValidity (Named 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."] @@ -567,11 +608,12 @@ backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instruc -- 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 @@ -581,22 +623,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, @@ -609,113 +653,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) = False 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) = False 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 @@ -730,11 +785,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 @@ -748,11 +804,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. @@ -768,11 +825,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 @@ -786,11 +844,12 @@ 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" -- | This (defunctionalized) function tells the compiler -- driver what else has to be run after code output. @@ -804,9 +863,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 @@ -817,21 +877,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 @@ -842,6 +904,7 @@ allBackends :: [Backend] allBackends = [ ncgBackend , llvmBackend , viaCBackend + , jsBackend , interpreterBackend , noBackend ] 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 5b3f614d8e..36966eddda 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -124,6 +124,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) } @@ -218,6 +219,18 @@ outputLlvm logger llvm_config dflags filenm cmm_stream = do {- ************************************************************************ * * +\subsection{JavaScript} +* * +************************************************************************ +-} +outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputJS _ _ _ _ _ = panic $ "codeOutput: Hit JavaScript case. You should never reach here!" + ++ "\nThe JS backend should shortcircuit to StgToJS after Stg." + ++ "\nIf you reached this point then you've somehow made it to Cmm!" + +{- +************************************************************************ +* * \subsection{Foreign import/export} * * ************************************************************************ diff --git a/compiler/GHC/Driver/Config/StgToJS.hs b/compiler/GHC/Driver/Config/StgToJS.hs new file mode 100644 index 0000000000..69bb27953c --- /dev/null +++ b/compiler/GHC/Driver/Config/StgToJS.hs @@ -0,0 +1,25 @@ +module GHC.Driver.Config.StgToJS + ( initStgToJSConfig + ) +where + +import GHC.Prelude +import GHC.Driver.Session +import GHC.Platform.Ways +import GHC.StgToJS.Types + +-- | Initialize StgToJS settings from DynFlags +initStgToJSConfig :: DynFlags -> StgToJSConfig +initStgToJSConfig dflags = StgToJSConfig + { csInlinePush = False + , csInlineBlackhole = False + , csInlineLoadRegs = False + , csInlineEnter = False + , csInlineAlloc = False + , csTraceRts = False + , csAssertRts = False + , csDebugAlloc = False + , csTraceForeign = False + , csProf = ways dflags `hasWay` WayProf + , csRuntimeAssert = False + } diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 209e6d1776..6d48840071 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -75,6 +75,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 7db9b62331..0e149ecf78 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -120,6 +120,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 @@ -141,6 +142,7 @@ import GHC.Hs.Stats ( ppSourceStats ) import GHC.HsToCore import GHC.StgToByteCode ( byteCodeGen ) +import GHC.StgToJS ( stgToJS ) import GHC.IfaceToCore ( typecheckIface ) @@ -1675,7 +1677,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 @@ -1711,31 +1715,38 @@ 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". + -- 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 ()) $ 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 + case backend dflags of + JavaScript -> do + let js_config = initStgToJSConfig dflags + stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename + let cg_infos = Nothing + let stub_c_exists = Nothing + let foreign_fps = [] + return (output_filename, stub_c_exists, foreign_fps, 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 (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index e988979df2..4cf2f8049a 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -807,6 +807,9 @@ 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 _ _ _ _ input_fn = pure input_fn -- .o file has been generated by StgToJS + hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing @@ -822,9 +825,10 @@ applyPostHscPipeline NcgPostHscPipeline = applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc applyPostHscPipeline LlvmPostHscPipeline = \pe he ml fp -> Just <$> llvmPipeline pe he ml fp +applyPostHscPipeline JSPostHscPipeline = + \pe he ml fp -> Just <$> jsPipeline applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing - -- Pipeline from a given suffix pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) pipelineStart pipe_env hsc_env input_fn = diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 627b2c69b3..571dd72cab 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2447,6 +2447,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" @@ -2897,6 +2899,7 @@ dynamic_flags_deps = [ (deprecate $ "The -fvia-C flag does nothing; " ++ "it will be removed in a future GHC release")) , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend llvmBackend)) + , make_ord_flag defGhcFlag "fjavascript" (NoArg (upd $ \dfs -> dfs { backend = JavaScript})) , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> d { ghcLink=NoLink }) >> setBackend noBackend)) diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs new file mode 100644 index 0000000000..2987e1a1a9 --- /dev/null +++ b/compiler/GHC/JS/Make.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Helpers to create JS syntax values +module GHC.JS.Make + ( ToJExpr (..) + , ToStat (..) + , var + -- * Literals + , null_ + , undefined_ + , false_ + , true_ + , zero_ + , one_ + , two_ + , three_ + -- * Hash combinators + , jhEmpty + , jhSingle + , jhAdd + , jhFromList + -- * Combinators + , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) + , (.>.), (.>=.), (.<.), (.<=.) + , (.<<.), (.>>.), (.>>>.) + , (.||.), (.&&.) + , if_, if10, if01, ifS, ifBlockS + , app, appS, returnS + , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally + , loop, loopBlockS + , preIncrS, postIncrS + , preDecrS, postDecrS + , off8, off16, off32, off64 + , mask8, mask16 + , allocData, allocClsA + , typeof + , dataFieldName, dataFieldNames + , returnStack, assignAllEqual, assignAll + , declAssignAll + , nullStat, (.^) + ) +where + +import GHC.Prelude + +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 qualified GHC.Data.ShortText as ST +import GHC.Data.ShortText (ShortText) +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Panic +import GHC.Utils.Misc + +{-------------------------------------------------------------------- + ToJExpr Class +--------------------------------------------------------------------} + + +-- | 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 (M.Map ShortText a) where + toJExpr = ValExpr . JHash . M.map toJExpr + +instance ToJExpr a => ToJExpr (M.Map String a) where + toJExpr = ValExpr . JHash . M.fromList . map (ST.pack *** 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 . ST.pack . (:[]) + toJExprFromList = ValExpr . JStr . ST.pack +-- where escQuotes = tailDef "" . initDef "" . show + +instance ToJExpr Ident where + toJExpr = ValExpr . JVar + +instance ToJExpr ShortText 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] + +{-------------------------------------------------------------------- + Block Sugar +--------------------------------------------------------------------} + +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 + +{-------------------------------------------------------------------- + Combinators +--------------------------------------------------------------------} + +-- | Create a new anonymous function. The result is an expression. +-- Usage: +-- @jLam $ \ x y -> {JExpr involving x and y}@ +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 -> {JExpr involving x and y}@ +jVar :: ToSat a => a -> JStat +jVar f = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let addDecls (BlockStat ss) = + BlockStat $ map DeclStat 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 $ DeclStat 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 $ DeclStat i `mappend` ForInStat True i e block + +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 + +var :: ShortText -> JExpr +var = ValExpr . JVar . TxtI + +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] + +jhEmpty :: M.Map k JExpr +jhEmpty = M.empty + +jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr +jhSingle k v = jhAdd k v $ jhEmpty + +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 + +jhFromList :: [(ShortText, JExpr)] -> JVal +jhFromList = JHash . M.fromList + +nullStat :: JStat +nullStat = BlockStat [] + +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 + +(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr +(.==.) = InfixExpr EqOp +(.===.) = InfixExpr StrictEqOp +(.!=.) = InfixExpr NeqOp +(.!==.) = InfixExpr StrictNeqOp + +infixl 6 .==., .===., .!=., .!==. + +(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr +(.>.) = InfixExpr GtOp +(.>=.) = InfixExpr GeOp +(.<.) = InfixExpr LtOp +(.<=.) = InfixExpr LeOp + +infixl 7 .>., .>=., .<., .<=. + +(.||.), (.&&.) :: JExpr -> JExpr -> JExpr +(.||.) = InfixExpr LOrOp +(.&&.) = InfixExpr LAndOp + +infixl 8 .||., .&&. + +(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr +(.<<.) = InfixExpr LeftShiftOp +(.>>.) = InfixExpr RightShiftOp +(.>>>.) = InfixExpr ZRightShiftOp + +infixl 9 .<<., .>>., .>>>. + +typeof :: JExpr -> JExpr +typeof = UOpExpr TypeofOp + +-- e1 ? e2 : e3 +if_ :: JExpr -> JExpr -> JExpr -> JExpr +if_ e1 e2 e3 = IfExpr e1 e2 e3 + +-- if(e) { s1 } else { s2 } +ifS :: JExpr -> JStat -> JStat -> JStat +ifS e s1 s2 = IfStat e s1 s2 + +-- if(e) { s1 } else { s2 } +ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat +ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2) + +-- e ? 1 : 0 +if10 :: JExpr -> JExpr +if10 e = IfExpr e one_ zero_ + +-- e ? 0 : 1 +if01 :: JExpr -> JExpr +if01 e = IfExpr e zero_ one_ + +app :: ShortText -> [JExpr] -> JExpr +app f xs = ApplExpr (var f) xs + +appS :: ShortText -> [JExpr] -> JStat +appS f xs = ApplStat (var f) xs + +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)) + ] + +preIncrS :: JExpr -> JStat +preIncrS x = UOpStat PreIncOp x + +postIncrS :: JExpr -> JStat +postIncrS x = UOpStat PostIncOp x + +preDecrS :: JExpr -> JStat +preDecrS x = UOpStat PreDecOp x + +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 + +mask8 :: JExpr -> JExpr +mask8 x = BAnd x (Int 0xFF) + +mask16 :: JExpr -> JExpr +mask16 x = BAnd x (Int 0xFFFF) + +null_ :: JExpr +null_ = var "null" + +zero_ :: JExpr +zero_ = Int 0 + +one_ :: JExpr +one_ = Int 1 + +two_ :: JExpr +two_ = Int 2 + +three_ :: JExpr +three_ = Int 3 + +undefined_ :: JExpr +undefined_ = var "undefined" + +true_ :: JExpr +true_ = var "true" + +false_ :: JExpr +false_ = var "false" + +(.^) :: JExpr -> ShortText -> JExpr +x .^ p = SelExpr x (TxtI p) +infixl 8 .^ + +returnStack :: JStat +returnStack = ReturnStat (ApplExpr (var "h$rs") []) + +(|=) :: JExpr -> JExpr -> JStat +(|=) = AssignStat + +(||=) :: Ident -> JExpr -> JStat +i ||= ex = DeclStat i `mappend` (toJExpr i |= ex) + +infixl 2 ||=, |= + +(.!) :: 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) + +declAssignAll :: [Ident] -> [JExpr] -> JStat +declAssignAll xs ys = mconcat (zipWith (||=) xs ys) + +-- | Cache "dXXX" field names +-- +-- TODO: use FastString instead +dataFieldCache :: Array Int ShortText +dataFieldCache = listArray (1,nFieldCache) (map (ST.pack . ('d':) . show) [(1::Int)..nFieldCache]) + +nFieldCache :: Int +nFieldCache = 16384 + +dataFieldName :: Int -> ShortText +dataFieldName i + | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i) + | otherwise = dataFieldCache ! i + +dataFieldNames :: [ShortText] +dataFieldNames = fmap dataFieldName [1..nFieldCache] + + +-- | Cache "h$dXXX" names +-- +-- TODO: use FastString instead +dataCache :: Array Int ShortText +dataCache = listArray (1,1024) (map (ST.pack . ("h$d"++) . show) [(1::Int)..1024]) + +allocData :: Int -> JExpr +allocData i = toJExpr (TxtI (dataCache ! i)) + +-- | Cache "h$cXXX" names +-- +-- TODO: use FastString instead +clsCache :: Array Int ShortText +clsCache = listArray (1,1024) (map (ST.pack . ("h$c"++) . show) [(1::Int)..1024]) + +allocClsA :: Int -> JExpr +allocClsA i = toJExpr (TxtI (clsCache ! i)) + +{-------------------------------------------------------------------- + New Identifiers +--------------------------------------------------------------------} + +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) + +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..856e2623d4 --- /dev/null +++ b/compiler/GHC/JS/Ppr.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Pretty-printing JavaScript +module GHC.JS.Ppr + ( renderJs + , renderJs' + , renderPrefixJs + , renderPrefixJs' + , JsToDoc(..) + , defaultRenderJs + , RenderJs(..) + , jsToDoc + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Transform + + +import Data.Function +import Data.Char (isControl, ord) +import qualified Data.Map as M + +import Numeric(showHex) + +import GHC.Utils.Ppr as PP +import qualified GHC.Data.ShortText as ST +import GHC.Data.ShortText (ShortText) + +($$$) :: Doc -> Doc -> Doc +--x $$$ y = align (nest 2 $ x $+$ y) -- FIXME (Sylvain, 2022/02) +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) => ShortText -> a -> Doc +renderPrefixJs pfx = renderPrefixJs' defaultRenderJs pfx + +renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> ShortText -> a -> Doc +renderPrefixJs' r pfx = jsToDocR r . jsSaturate (Just $ "jmId_" `mappend` pfx) + +braceNest :: Doc -> Doc +braceNest x = char '{' <+> nest 2 x $$ char '}' + +braceNest' :: Doc -> Doc +braceNest' x = nest 2 (char '{' $+$ x) $$ 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 -> text "if" <> parens (jsToDocR r cond) $$ braceNest' (jsToDocR r x) $$ mbElse + where mbElse | y == BlockStat [] = PP.empty + | otherwise = text "else" $$ braceNest' (jsToDocR r y) + DeclStat x -> text "var" <+> jsToDocR r x + WhileStat False p b -> text "while" <> parens (jsToDocR r p) $$ braceNest' (jsToDocR r b) + WhileStat True p b -> (text "do" $$ braceNest' (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p) + UnsatBlock e -> jsToDocR r $ pseudoSaturate e + BreakStat l -> maybe (text "break") (((<+>) `on` stext) "break") l + ContinueStat l -> maybe (text "continue") (((<+>) `on` stext) "continue") l + LabelStat l s -> stext 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 -> text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e) $$ braceNest' (jsToDocR r b) + where txt | each = "for each" + | otherwise = "for" + SwitchStat e l d -> text "switch" <+> parens (jsToDocR r e) $$ braceNest' 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 -> text "try" $$ braceNest' (jsToDocR r s) $$ mbCatch $$ mbFinally + where mbCatch | s1 == BlockStat [] = PP.empty + | otherwise = text "catch" <> parens (jsToDocR r i) $$ braceNest' (jsToDocR r s1) + mbFinally | s2 == BlockStat [] = PP.empty + | otherwise = text "finally" $$ braceNest' (jsToDocR r s2) + AssignStat i x -> jsToDocR r i <+> char '=' <+> jsToDocR r x + UOpStat op x + | isPre op && isAlphaOp op -> stext (uOpText op) <+> optParens r x + | isPre op -> stext (uOpText op) <> optParens r x + | otherwise -> optParens r x <> stext (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 -> cat [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, stext (opText op), jsToDocR r y] + UOpExpr op x + | isPre op && isAlphaOp op -> stext (uOpText op) <+> optParens r x + | isPre op -> stext (uOpText op) <> optParens r x + | otherwise -> optParens r x <> stext (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 -> hcat [char '\"',encodeJson s, char '\"'] + JRegEx s -> hcat [char '/',stext s, char '/'] + JHash m + | M.null m -> text "{}" + | otherwise -> braceNest . hsep . punctuate comma . + map (\(x,y) -> squotes (stext x) <> colon <+> jsToDocR r y) $ M.toList m + JFunc is b -> parens $ text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) $$ braceNest' (jsToDocR r b) + UnsatVal f -> jsToDocR r $ pseudoSaturate f + +defRenderJsI :: RenderJs -> Ident -> Doc +defRenderJsI _ (TxtI t) = stext t + +encodeJson :: ShortText -> Doc +encodeJson xs = hcat (map encodeJsonChar (ST.unpack 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 -> ShortText +uOpText = \case + NotOp -> "!" + BNotOp -> "~" + NegOp -> "-" + PlusOp -> "+" + NewOp -> "new" + TypeofOp -> "typeof" + DeleteOp -> "delete" + YieldOp -> "yield" + VoidOp -> "void" + PreIncOp -> "++" + PostIncOp -> "++" + PreDecOp -> "--" + PostDecOp -> "--" + +opText :: JOp -> ShortText +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..79f53f39ee --- /dev/null +++ b/compiler/GHC/JS/Syntax.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | JavaScript syntax +-- +-- Fork of JMacro (BSD 3 Clause) by Gershom Bazerman, heavily modified to +-- accomodate GHC's constraints. +module GHC.JS.Syntax + ( JStat(..) + , JExpr(..) + , JVal(..) + , JOp(..) + , JUOp(..) + , Ident(..) + , JsLabel + , 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 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 qualified Data.Map as M +import Data.Data +import Data.Word +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import GHC.Utils.Outputable (Outputable (..)) +import qualified GHC.Utils.Outputable as O +import qualified GHC.Data.ShortText as ST +import GHC.Data.ShortText (ShortText) +import GHC.Utils.Monad.State.Strict + +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 ShortText -> [Ident] +newIdentSupply Nothing = newIdentSupply (Just "jmId") +newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",ST.pack (show x)]) + | x <- [(0::Word64)..] + ] + +-- | 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 +data JStat + = DeclStat Ident + | ReturnStat JExpr + | IfStat JExpr JStat JStat + | WhileStat Bool JExpr JStat -- bool is "do" + | ForInStat Bool Ident JExpr JStat -- bool is "each" + | SwitchStat JExpr [(JExpr, JStat)] JStat + | TryStat JStat Ident JStat JStat + | BlockStat [JStat] + | ApplStat JExpr [JExpr] + | UOpStat JUOp JExpr + | AssignStat JExpr JExpr + | UnsatBlock (IdentSupply JStat) + | LabelStat JsLabel JStat + | BreakStat (Maybe JsLabel) + | ContinueStat (Maybe JsLabel) + deriving (Eq, Ord, Show, Typeable, Generic) + +instance NFData JStat + +type JsLabel = ShortText + + +instance Semigroup JStat where + (<>) = appendJStat + +instance Monoid JStat where + mempty = BlockStat [] + +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] + + + +-- TODO: annotate expressions with type +-- | Expressions +data JExpr + = ValExpr JVal + | SelExpr JExpr Ident + | IdxExpr JExpr JExpr + | InfixExpr JOp JExpr JExpr + | UOpExpr JUOp JExpr + | IfExpr JExpr JExpr JExpr + | ApplExpr JExpr [JExpr] + | UnsatExpr (IdentSupply JExpr) + deriving (Eq, Ord, Show, Typeable, Generic) + +instance Outputable JExpr where + ppr x = O.text (show x) + +instance NFData JExpr + +pattern New :: JExpr -> JExpr +pattern New x = UOpExpr NewOp x + +pattern PreInc :: JExpr -> JExpr +pattern PreInc x = UOpExpr PreIncOp x + +pattern PostInc :: JExpr -> JExpr +pattern PostInc x = UOpExpr PostIncOp x + +pattern PreDec :: JExpr -> JExpr +pattern PreDec x = UOpExpr PreDecOp x + +pattern PostDec :: JExpr -> JExpr +pattern PostDec x = UOpExpr PostDecOp x + +pattern Not :: JExpr -> JExpr +pattern Not x = UOpExpr NotOp x + +pattern Negate :: JExpr -> JExpr +pattern Negate x = UOpExpr NegOp x + +pattern Add :: JExpr -> JExpr -> JExpr +pattern Add x y = InfixExpr AddOp x y + +pattern Sub :: JExpr -> JExpr -> JExpr +pattern Sub x y = InfixExpr SubOp x y + +pattern Mul :: JExpr -> JExpr -> JExpr +pattern Mul x y = InfixExpr MulOp x y + +pattern Div :: JExpr -> JExpr -> JExpr +pattern Div x y = InfixExpr DivOp x y + +pattern Mod :: JExpr -> JExpr -> JExpr +pattern Mod x y = InfixExpr ModOp x y + +pattern BOr :: JExpr -> JExpr -> JExpr +pattern BOr x y = InfixExpr BOrOp x y + +pattern BAnd :: JExpr -> JExpr -> JExpr +pattern BAnd x y = InfixExpr BAndOp x y + +pattern BXor :: JExpr -> JExpr -> JExpr +pattern BXor x y = InfixExpr BXorOp x y + +pattern BNot :: JExpr -> JExpr +pattern BNot x = UOpExpr BNotOp x + +pattern Int :: Integer -> JExpr +pattern Int x = ValExpr (JInt x) + +pattern String :: ShortText -> JExpr +pattern String x = ValExpr (JStr x) + +-- | Values +data JVal + = JVar Ident + | JList [JExpr] + | JDouble SaneDouble + | JInt Integer + | JStr ShortText + | JRegEx ShortText + | JHash (M.Map ShortText JExpr) + | JFunc [Ident] JStat + | UnsatVal (IdentSupply JVal) + deriving (Eq, Ord, Show, Typeable, Generic) + +instance Outputable JVal where + ppr x = O.text (show x) + +instance NFData JVal + +data JOp + = 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 + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JOp + +data JUOp + = NotOp -- ! + | BNotOp -- ~ + | NegOp -- - + | PlusOp -- +x + | NewOp -- new x + | TypeofOp -- typeof x + | DeleteOp -- delete x + | YieldOp -- yield x + | VoidOp -- void x + | PreIncOp -- ++x + | PostIncOp -- x++ + | PreDecOp -- --x + | PostDecOp -- x-- + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JUOp + + +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 +newtype Ident = TxtI { itxt:: ShortText} + deriving (Show, Typeable, Ord, Eq, Generic, NFData) diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs new file mode 100644 index 0000000000..cb99200163 --- /dev/null +++ b/compiler/GHC/JS/Transform.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHC.JS.Transform + ( mapIdent + , mapStatIdent + , mapExprIdent + , identsS + , identsV + , identsE + -- * Saturation + , jsSaturate + -- * Generic traversal (via compos) + , JMacro(..) + , JMGadt(..) + , Compos(..) + , composOp + , composOpM + , composOpM_ + , composOpFold + -- * Hygienic transformation + , withHygiene + , scopify + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax + +import qualified Data.Map as M +import Text.Read (readMaybe) +import Data.Functor.Identity +import Control.Monad +import Data.Bifunctor + + +import qualified GHC.Data.ShortText as ST +import GHC.Data.ShortText (ShortText) +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Panic + +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 + -- FIXME: shouldn't we transform this into `UnsatExpr (map_val v2)`? + + map_stat s = case s of + DeclStat{} -> s + 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 -> [i] + 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 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 -> ret DeclStat `app` f i + 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' + where (ls, vs) = unzip (M.toList m) + m' = ret (M.fromAscList . 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 []) + 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 ShortText -> 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 + +{-------------------------------------------------------------------- + Transformation +--------------------------------------------------------------------} + +-- doesn't apply to unsaturated bits +jsReplace_ :: JMacro a => [(Ident, Ident)] -> a -> a +jsReplace_ xs e = jfromGADT $ go (jtoGADT e) + where + go :: forall a. JMGadt a -> JMGadt a + go v = case v of + JMGId i -> maybe v JMGId (M.lookup i mp) + _ -> composOp go v + mp = M.fromList xs + +-- only works on fully saturated things +jsUnsat_ :: JMacro a => [Ident] -> a -> IdentSupply a +jsUnsat_ xs e = IS $ do + (idents,is') <- splitAt (length xs) <$> get + put is' + return $ jsReplace_ (zip xs idents) e + +-- | Apply a transformation to a fully saturated syntax tree, +-- taking care to return any free variables back to their free state +-- following the transformation. As the transformation preserves +-- free variables, it is hygienic. +withHygiene :: JMacro a => (a -> a) -> a -> a +withHygiene f x = jfromGADT $ case jtoGADT x of + JMGExpr z -> JMGExpr $ UnsatExpr $ inScope z + JMGStat z -> JMGStat $ UnsatBlock $ inScope z + JMGVal z -> JMGVal $ UnsatVal $ inScope z + JMGId _ -> jtoGADT $ f x + where + inScope z = IS $ do + ti <- get + case ti of + ((TxtI a):b) -> do + put b + return $ withHygiene_ a f z + _ -> error "withHygiene: empty list" + +withHygiene_ :: JMacro a => ShortText -> (a -> a) -> a -> a +withHygiene_ un f x = jfromGADT $ case jtoGADT x of + JMGStat _ -> jtoGADT $ UnsatBlock (jsUnsat_ is' x'') + JMGExpr _ -> jtoGADT $ UnsatExpr (jsUnsat_ is' x'') + JMGVal _ -> jtoGADT $ UnsatVal (jsUnsat_ is' x'') + JMGId _ -> jtoGADT $ f x + where + (x',l) = case runState (runIdentSupply $ jsSaturate_ x) is of + (_ , []) -> panic "withHygiene: empty ident list" + (x', TxtI l : _) -> (x',l) + is' = take lastVal is + x'' = f x' + lastVal = case readMaybe (reverse . takeWhile (/= '_') . reverse . ST.unpack $ l) of + Nothing -> panic ("inSat" ++ ST.unpack un) + Just r -> r :: Int + is = newIdentSupply $ Just (ST.pack "inSat" `mappend` un) + +-- | Takes a fully saturated expression and transforms it to use unique +-- variables that respect scope. +scopify :: JStat -> JStat +scopify x = evalState (jfromGADT <$> go (jtoGADT x)) (newIdentSupply Nothing) + where + go :: forall a. JMGadt a -> State [Ident] (JMGadt a) + go = \case + JMGStat (BlockStat ss) -> JMGStat . BlockStat <$> + blocks ss + where blocks [] = return [] + blocks (DeclStat (TxtI i) : xs) + | ('!':'!':rs) <- ST.unpack i + = (DeclStat (TxtI (ST.pack rs)):) <$> blocks xs + | ('!':rs) <- ST.unpack i + = (DeclStat (TxtI $ ST.pack rs):) <$> blocks xs + | otherwise = do + xx <- get + case xx of + (newI:st) -> do + put st + rest <- blocks xs + return $ [DeclStat newI `mappend` jsReplace_ [(TxtI i, newI)] (BlockStat rest)] + _ -> error "scopify: empty list" + blocks (x':xs) = (jfromGADT <$> go (jtoGADT x')) <:> blocks xs + (<:>) = liftM2 (:) + JMGStat (TryStat s (TxtI i) s1 s2) -> do + xx <- get + case xx of + (newI:st) -> do + put st + t <- jfromGADT <$> go (jtoGADT s) + c <- jfromGADT <$> go (jtoGADT s1) + f <- jfromGADT <$> go (jtoGADT s2) + return . JMGStat . TryStat t newI (jsReplace_ [(TxtI i, newI)] c) $ f + _ -> error "scopify: empty list" + JMGExpr (ValExpr (JFunc is s)) -> do + st <- get + let (newIs,newSt) = splitAt (length is) st + put newSt + rest <- jfromGADT <$> go (jtoGADT s) + return . JMGExpr . ValExpr $ JFunc newIs $ (jsReplace_ $ zip is newIs) rest + v -> composOpM go v + diff --git a/compiler/GHC/StgToJS.hs b/compiler/GHC/StgToJS.hs new file mode 100644 index 0000000000..2496e6cc15 --- /dev/null +++ b/compiler/GHC/StgToJS.hs @@ -0,0 +1,150 @@ +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. +-- TODO: add GHCJS optimizer for this to be true +-- +-- JavaScript ASTs are then optimized. A dataflow analysis is performed and then +-- dead code and redundant assignments are removed. +-- +-- Primitives +-- ~~~~~~~~~~ +-- TODO: pointer emulation (Addr#) +-- TODO: 64-bit primops +-- TODO: JSVal# +-- TODO: StablePtr# +-- +-- Foreign JavaScript imports +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS supports inline JavaScript code. Example: +-- +-- > foreign import javascript unsafe +-- > "$1 + $2" +-- > plus :: Int -> Int -> Int +-- +-- The parser is inherited from JMacro and supports local variable declarations, +-- loops, etc. Local variables are converted to hygienic names to avoid capture. +-- +-- TODO: argument order for multi-values primreps (Int64#, Word64#, Addr#) +-- TODO: "$c" safe call continuation? +-- +-- Memory management +-- ~~~~~~~~~~~~~~~~~ +-- 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? +-- +-- Heap: objects on the heap ("closures") are represented as JavaScript objects +-- with the following fields: +-- +-- { f: function -- entry function +-- , m: meta -- meta data +-- , d1: x -- closure specific fields +-- , d2: y +-- } +-- +-- Every heap object has an entry function "f". +-- +-- Similarly to info tables in native code generation, the JS function object +-- "f" also contains some metadata about the Haskell object: +-- +-- { t: closure type +-- , a: constructor tag / fun arity +-- } +-- +-- Note that functions in JS are objects so if "f" is a function we can: +-- - call it, e.g. "f(arg0,arg1...)" +-- - get/set its metadata, e.g. "var closureType = f.t" +-- +-- THUNK = +-- { f = returns the object reduced to WHNF +-- , m = ? +-- , d1 = ? +-- , d2 = ? +-- } +-- +-- FUN = +-- { f = function itself +-- , m = ? +-- , d1 = free variable 1 +-- , d2 = free variable 2 +-- } +-- +-- PAP = +-- { f = ? +-- , m = ? +-- , d1 = ? +-- , d2 = +-- { d1 = PAP arity +-- } +-- } +-- +-- 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. +-- +-- 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..bcc990fe31 --- /dev/null +++ b/compiler/GHC/StgToJS/Apply.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} + +module GHC.StgToJS.Apply + ( genApp + , mkApplyArr + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Arg +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.Types.Literal +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.RepType + +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 qualified GHC.Data.ShortText as ST + +import Data.Bits as Bits +import Data.Monoid + + +-- | Generate an application of some args to an Id +genApp + :: HasDebugCallStack + => ExprCtx + -> Id + -> [StgArg] + -> G (JStat, ExprResult) +genApp ctx i args + +-- FIXME (sylvain 2022/02): what's our new equivalent of this? +-- -- special cases for JSString literals +-- -- we could handle unpackNBytes# here, but that's probably not common +-- -- enough to warrant a special case +-- | [StgVarArg v] <- args +-- , [top] <- concatMap snd (ctxTarget ctx) +-- -- , Just (Lit (MachStr bs)) <- expandUnfolding_maybe (idUnfolding v) +-- -- , Just t <- decodeModifiedUTF8 bs -- unpackFS fs -- Just t <- decodeModifiedUTF8 bs +-- , matchVarName "ghcjs-prim" "GHCJS.Prim" "unsafeUnpackJSStringUtf8##" i = +-- (,ExprInline Nothing) . (|=) top . app "h$decodeUtf8z" <$> genIds v + + | [StgLitArg (LitString bs), x] <- args + , [top] <- concatMap typex_expr (ctxTarget ctx) + , getUnique i == unpackCStringAppendIdKey + -- , Just d <- decodeModifiedUTF8 bs + , d <- utf8DecodeByteString bs + -- FIXME (Sylvain, 2022/02): we assume that it decodes but it may not (e.g. embedded file) + = do + -- fixme breaks assumption in codegen if bs doesn't decode + 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 <- lookupUFM (ctxLneFrameBs ctx) i + = do + as' <- concatMapM genArg args + ei <- jsEntryId 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) + + | [] <- args + , isUnboxedTupleType (idType i) || isStrictType (idType i) + = do + a <- assignCoerce1 (ctxTarget ctx) . (alignIdExprs i) <$> genIds i + return (a, ExprInline Nothing) + + | [] <- args + , [vt] <- idVt i + , isUnboxable vt + , i `elementOfUniqSet` (ctxEval ctx) + = do + let c = head (concatMap typex_expr $ ctxTarget ctx) + is <- genIds i + case is of + [i'] -> + return ( c |= if_ (isObject i') (i' .^ closureExtra1_) i' + , ExprInline Nothing + ) + _ -> panic "genApp: invalid size" + + | [] <- args + , i `elementOfUniqSet` (ctxEval ctx) || isStrictId i + = do + a <- assignCoerce1 (ctxTarget ctx) . (alignIdExprs i) <$> genIds i + 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) + + | 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' || a' `elementOfUniqSet` (ctxEval ctx) + then return (t |= ai, ExprInline Nothing) + else return (returnS (app "h$e" [ai]), ExprCont) + _ -> panic "genApp: invalid size" + + | [] <- args + , idFunRepArity i == 0 + , not (might_be_a_function (idType i)) + = do + ii <- enterId + return (returnS (app "h$e" [ii]), ExprCont) + + | n <- length args + , n /= 0 + , idFunRepArity i == n + , not (isLocalId i) + , isStrictId i + = do + as' <- concatMapM genArg args + jmp <- jumpToII i as' =<< r1 + return (jmp, ExprCont) + + | idFunRepArity i < length args + , isStrictId i + , idFunRepArity i > 0 + = do + let (reg,over) = splitAt (idFunRepArity i) args + reg' <- concatMapM genArg reg + pc <- pushCont over + jmp <- jumpToII i reg' =<< r1 + return (pc <> jmp, ExprCont) + + | otherwise + = do + jmp <- jumpToFast args =<< r1 + return (jmp, ExprCont) + where + enterId :: G JExpr + enterId = genArg (StgVarArg i) >>= + \case + [x] -> return x + xs -> pprPanic "genApp: unexpected multi-var argument" + (vcat [ppr (length xs), ppr i]) + + r1 :: G JStat + r1 = do + ids <- genIds i + return $ mconcat $ zipWith (\r u -> toJExpr r |= toJExpr u) (enumFrom R1) ids + +-- 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 args afterLoad + | isLocalId i = do + ii <- jsId i + return $ mconcat + [ ra + , afterLoad + , returnS (ii .^ "f") + ] + | otherwise = do + ei <- jsEntryId i + return $ mconcat + [ ra + , afterLoad + , returnS ei + ] + where + ra = mconcat . reverse $ zipWith (\r a -> toJExpr r |= a) (enumFrom R2) args + +jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat +jumpToFast as afterLoad = do + regs <- concatMapM genArg as + (fun, spec) <- selectApply True (as,regs) + pure $ mconcat + [ mconcat (ra regs) + , afterLoad + , if spec + then returnS (ApplExpr fun []) + else returnS (ApplExpr fun [toJExpr (mkTag regs as)]) + ] + where + ra regs = reverse $ zipWith (\r ex -> toJExpr r |= ex) (enumFrom R2) regs + mkTag rs as = (length rs `Bits.shiftL` 8) Bits..|. length as + +-- find a specialized application path if there is one +selectApply + :: Bool -- ^ true for fast apply, false for stack apply + -> ([StgArg], [JExpr]) -- ^ arguments + -> G (JExpr, Bool) -- ^ the function to call, true if specialized path +selectApply fast (args, as) = + case specApply fast (length args) (length as) of + Just e -> return (e, True) + Nothing -> return (var $ "h$ap_gen" <> fastSuff, False) + where + fastSuff | fast = "_fast" + | otherwise = "" + + + +-- specialized apply for these +-- make sure that once you are in spec, you stay there +applySpec :: [(Int,Int)] -- regs,arity +applySpec = [ (regs,arity) | arity <- [1..4], regs <- [max 0 (arity-1)..(arity*2)]] + +specApply :: Bool -> Int -> Int -> Maybe JExpr +specApply fast n r + | (r,n) == (0,0) = Just (var . ST.pack $ ("h$ap_0_0" ++ fastSuff)) + | (r,n) == (0,1) = Just (var . ST.pack $ ("h$ap_1_0" ++ fastSuff)) + | (r,n) `elem` applySpec = Just (var . ST.pack $ ("h$ap_" ++ show n ++ "_" ++ show r ++ fastSuff)) + | otherwise = Nothing + where + fastSuff | fast = "_fast" + | otherwise = "" + +{- + Build arrays to quickly lookup apply functions, getting the fast variant when possible + - 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 + ] + , var "h$apply" .! zero_ |= var "h$ap_0_0" + , mconcat (map assignSpec applySpec) + , mconcat (map assignPap specPap) + ] + ] + ] + where + assignSpec :: (Int, Int) -> JStat + assignSpec (r,n) = + var "h$apply" .! (toJExpr $ Bits.shiftL r 8 Bits..|. n) |= + (var (ST.pack ("h$ap_" ++ show n ++ "_" ++ show r))) + + assignPap :: Int -> JStat + assignPap p = var "h$paps" .! toJExpr p |= + (var (ST.pack $ ("h$pap_" ++ show p))) + +-- specialized (faster) pap generated for [0..numSpecPap] +-- others use h$pap_gen +specPap :: [Int] +specPap = [0..numSpecPap] + +numSpecPap :: Int +numSpecPap = 6 + +pushCont :: HasDebugCallStack + => [StgArg] + -> G JStat +pushCont as = do + as' <- concatMapM genArg as + (app, spec) <- selectApply False (as,as') + if spec + then push $ reverse $ app : as' + else push $ reverse $ app : mkTag as' as : as' + where + mkTag rs ns = toJExpr ((length rs `Bits.shiftL` 8) Bits..|. length ns) + +-- | 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 diff --git a/compiler/GHC/StgToJS/Arg.hs b/compiler/GHC/StgToJS/Arg.hs new file mode 100644 index 0000000000..69b3b7fd8d --- /dev/null +++ b/compiler/GHC/StgToJS/Arg.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Arg + ( genArg + , genStaticArg + , genIdArg + , genIdArgI + , genIdStackArgI + , allocConStatic + , allocUnboxedConStatic + , allocateStaticList + ) +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.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 GHC.Utils.Monad.State.Strict as State + +genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg] +genStaticArg (StgLitArg l) = map StaticLitArg <$> genStaticLit l +genStaticArg a@(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 (jsIdIN i) [1..varSize r] -- this seems wrong, not an obj? + | otherwise = (\(TxtI it) -> [StaticObjArg it]) <$> jsIdI 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]) <$> jsIdI (dataConWorkId dc) + | otherwise = do + as <- concat <$> mapM genStaticArg args + (TxtI e) <- enterDataConI dc + return [StaticConArg e as] + unfloated x = pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) + +genArg :: HasDebugCallStack => StgArg -> G [JExpr] +genArg (StgLitArg l) = genLit l +genArg a@(StgVarArg i) = do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Nothing -> reg + Just expr -> unfloated expr + where + -- if our argument is a joinid, it can be an unboxed tuple + r :: HasDebugCallStack => VarType + r = uTypeVt . stgArgType $ a + reg + | isVoid r = return [] + | i == trueDataConId = return [true_] + | i == falseDataConId = return [false_] + | isMultiVar r = mapM (jsIdN i) [1..varSize r] + | otherwise = (:[]) <$> jsId i + + 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 -> (:[]) <$> jsId (dataConWorkId dc) + | otherwise -> do + as <- concat <$> mapM genArg args + e <- enterDataCon dc + cs <- getSettings + return [allocDynamicE cs e as Nothing] -- FIXME: ccs + x -> pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) + +genIdArg :: HasDebugCallStack => Id -> G [JExpr] +genIdArg i = genArg (StgVarArg i) + +genIdArgI :: HasDebugCallStack => Id -> G [Ident] +genIdArgI i + | isVoid r = return [] + | isMultiVar r = mapM (jsIdIN i) [1..varSize r] + | otherwise = (:[]) <$> jsIdI i + where + r = uTypeVt . idType $ i + + +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) + + +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 + 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) <- enterDataConI 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) <- enterDataConI con + emitStatic to (StaticData e xs) cc' + +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) + + +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" + diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs new file mode 100644 index 0000000000..d2cad54392 --- /dev/null +++ b/compiler/GHC/StgToJS/CodeGen.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} + +-- | JavaScript code generator +module GHC.StgToJS.CodeGen 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.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StaticPtr +import GHC.StgToJS.UnitUtils + +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.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique +import GHC.Types.TyThing + +import qualified GHC.Data.ShortText as ST +import GHC.Data.ShortText (ShortText) +import GHC.Utils.Encoding +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.Misc +import qualified GHC.Utils.Monad.State.Strict as State +import GHC.Utils.Outputable hiding ((<>)) + +import qualified Data.Set as S +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.Monoid +import Control.Monad +import Data.Bifunctor + +-- | 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 + + let obj = runG config this_mod unfloated_binds $ do + ifProfilingM $ initCostCentres cccs + (sym_table, lus) <- genUnits this_mod stg_binds spt_entries foreign_stubs + + -- (exported symbol names, javascript statements) for each linkable unit + p <- forM lus \u -> do + ts <- mapM (fmap (\(TxtI i) -> i) . jsIdI) (luIdExports u) + return (ts ++ luOtherExports u, luStat u) + + deps <- genDependencyData this_mod lus + pure $! Object.object' (moduleName this_mod) sym_table deps (map (second BL.fromStrict) p) + + -- Doc to dump when -ddump-js is enabled + let mod_name = renderWithContext defaultSDocContext (ppr this_mod) + putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS + $ vcat (fmap (docToSDoc . jsToDoc . Object.oiStat) (Object.readObject mod_name obj)) + + BL.writeFile output_fn obj + + + +-- | Generate the ingredients for the linkable units for this module +genUnits :: HasDebugCallStack + => Module + -> [CgStgTopBinding] + -> [SptEntry] + -> ForeignStubs + -> G (Object.SymbolTable, [LinkableUnit]) -- ^ the final symbol table and the linkable units +genUnits m ss spt_entries foreign_stubs + = generateGlobalBlock =<< + generateExportsBlock =<< + go 2 Object.emptySymbolTable ss + where + go :: HasDebugCallStack + => Int -- ^ the block we're generating (block 0 is the global unit for the module) + -> Object.SymbolTable -- ^ the shared symbol table + -> [CgStgTopBinding] + -> G (Object.SymbolTable, [LinkableUnit]) + go !n st (x:xs) = do + (st', mlu) <- generateBlock st x n + (st'', lus) <- go (n+1) st' xs + return (st'', maybe lus (:lus) mlu) + go _ st [] = return (st, []) + + -- | 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 + => (Object.SymbolTable, [LinkableUnit]) + -> G (Object.SymbolTable, [LinkableUnit]) + generateGlobalBlock (st, lus) = do + glbl <- State.gets gsGlobal + staticInit <- + initStaticPtrs spt_entries + (st', _, bs) <- serializeLinkableUnit m st [] [] [] + ( -- FIXME (Sylvain, 2022/02): optimizer disabled: O.optimize . + jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) "" [] [] + return ( st' + , LinkableUnit bs + [] + [moduleGlobalSymbol m] + [] + [] + [] + False + [] + : lus + ) + + generateExportsBlock :: HasDebugCallStack + => (Object.SymbolTable, [LinkableUnit]) + -> G (Object.SymbolTable, [LinkableUnit]) + generateExportsBlock (st, lus) = 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" + + (st', _, bs) <- serializeLinkableUnit m + st + [] + [] + [] + mempty + (ST.pack $ renderWithContext defaultSDocContext f_c) + [] + [] + return ( st' + , LinkableUnit bs + [] + [moduleExportsSymbol m] + [] -- id deps + unique_deps -- pseudo id deps + [] + True + [] + : lus + ) + + -- | Generate the linkable unit for one binding or group of + -- mutually recursive bindings + generateBlock :: HasDebugCallStack + => Object.SymbolTable + -> CgStgTopBinding + -> Int + -> G (Object.SymbolTable, Maybe LinkableUnit) + generateBlock st (StgTopStringLit bnd str) n = do + bids <- genIdsI 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 stat = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 + (st', _ss, bs) <- serializeLinkableUnit m st [bnd] [] si + (jsSaturate (Just $ modulePrefix m n) stat) "" [] [] + pure (st', Just $ LinkableUnit bs [bnd] [] [] [] [] False []) + _ -> panic "generateBlock: invalid size" + generateBlock st (StgTopLifted decl) n = 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 = -- FIXME (Sylvain 2022/02): optimizer disabled: + -- {-decl -} Opt.optimize . + jsSaturate (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl + (st', _ss, bs) <- serializeLinkableUnit m st topDeps ci si stat mempty [] fRefs + return $! seqList topDeps `seq` seqList allDeps `seq` st' `seq` + (st', Just $ LinkableUnit bs topDeps [] allDeps [] (S.toList extraDeps) required fRefs) + +-- | serialize the payload of a linkable unit in the object file, adding strings +-- to the SymbolTable where necessary +serializeLinkableUnit :: HasDebugCallStack + => Module + -> Object.SymbolTable -- symbol table to start with + -> [Id] -- id's exported by unit + -> [ClosureInfo] + -> [StaticInfo] + -> JStat -- generated code for the unit + -> ShortText + -> [Object.ExpFun] + -> [ForeignJSRef] + -> G (Object.SymbolTable, [ShortText], BS.ByteString) +serializeLinkableUnit _m st i ci si stat rawStat fe fi = do + !i' <- mapM idStr i + let !(!st', !o) = Object.serializeStat st ci si stat rawStat fe fi + return (st', i', o) -- deepseq results? + where + idStr i = itxt <$> jsIdI i + +-- | variable prefix for the nth block in module +modulePrefix :: Module -> Int -> ShortText +modulePrefix m n = + let encMod = zEncodeString . moduleNameString . moduleName $ m + in ST.pack $ "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 + | i `elem` [ i' | AnId i' <- dataConImplicitTyThings con ] + -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT + StgRhsClosure _ _cc _upd_flag _args body + | StgConApp dc _n _cargs _tys <- removeTick body + , i `elem` [ i' | AnId i' <- dataConImplicitTyThings dc ] + -> genSetConInfo i dc (stgRhsLive rhs) -- srt + _ -> pure mempty + +genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat +genSetConInfo i d l {- srt -} = do + ei@(TxtI eii) <- jsDcEntryIdI i + sr <- genStaticRefs l + emitClosureInfo $ ClosureInfo eii + (CIRegs 0 [PtrV]) + (ST.pack $ 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 <- jsIdI i + allocConStatic ii cc con args + return mempty + StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do + eid@(TxtI eidt) <- jsEnIdI i + (TxtI idt) <- jsIdI i + body <- genBody (ExprCtx i [] emptyUniqSet emptyUniqSet emptyUFM [] Nothing) i R2 args body + (lidents, lids) <- unzip <$> liftToGlobal (jsSaturate (Just "ghcjs_tmp_sat_") body) + let lidents' = map (\(TxtI t) -> t) 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 eidt + 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..b945024c1b --- /dev/null +++ b/compiler/GHC/StgToJS/CoreUtils.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE LambdaCase #-} + +-- | 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 + +-- | 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 + +data SlotCount + = NoSlot + | OneSlot + | TwoSlots + deriving (Show,Eq,Ord) + +instance Outputable SlotCount where + ppr = text . show + +varSize :: VarType -> Int +varSize = slotCount . varSlotCount + +slotCount :: SlotCount -> Int +slotCount = \case + NoSlot -> 0 + OneSlot -> 1 + TwoSlots -> 2 + +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 {- || isRuntimeRepTy 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 -- fixme what do we need here? + | tc == anyTyCon -> PtrV + | tc == compactPrimTyCon -> ObjV -- unsupported? + | tc == eqPrimTyCon -> VoidV -- coercion token? + | tc == eqReprPrimTyCon -> VoidV -- role + | tc == unboxedUnitTyCon -> VoidV -- Void# + | otherwise -> pprPanic "primTypeVt: unrecognized primitive type" (ppr tc) + +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) + +-- | Assign values to each prim rep slot +alignPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])] +alignPrimReps [] _ = [] +alignPrimReps (r:rs) vs = case (primRepSize r,vs) of + (NoSlot, xs) -> (r,[]) : alignPrimReps rs xs + (OneSlot, x:xs) -> (r,[x]) : alignPrimReps rs xs + (TwoSlots, x:y:xs) -> (r,[x,y]) : alignPrimReps rs xs + err -> pprPanic "alignPrimReps" (ppr err) + +alignIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])] +alignIdPrimReps i = alignPrimReps (idPrimReps i) + +alignIdExprs :: Id -> [JExpr] -> [TypedExpr] +alignIdExprs i es = fmap (uncurry TypedExpr) (alignIdPrimReps i es) diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs new file mode 100644 index 0000000000..01e15bbfae --- /dev/null +++ b/compiler/GHC/StgToJS/DataCon.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.DataCon + ( genCon + , allocCon + , allocUnboxedCon + , allocDynamicE + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Profiling +import GHC.StgToJS.Utils + +import GHC.Core.DataCon + +import GHC.Types.CostCentre + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified GHC.Data.ShortText as ST + +import qualified Data.Map as M +import Data.Maybe + +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 + + -- FIXME: (Sylvain 2022-03-11) Do we support e.g. "data T = MkT Word64"? It + -- would return two JExprs + + | otherwise + = pprPanic "genCon: unhandled DataCon" (ppr con) + +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 <- jsId (dataConWorkId con) + return (assignj to i) -} + | otherwise = do + e <- enterDataCon con + cs <- getSettings + prof <- profiling + ccsJ <- if prof then ccsVarJ cc else return Nothing + return $ allocDynamic cs False to e xs ccsJ + +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)) + +allocDynamicE :: StgToJSConfig -> JExpr -> [JExpr] -> Maybe JExpr -> JExpr +allocDynamicE s entry free cc + | csInlineAlloc s || length free > 24 = + ValExpr . jhFromList $ [ (closureEntry_ , entry) + , (closureExtra1_, fillObj1) + , (closureExtra2_, fillObj2) + , (closureMeta_ , ValExpr (JInt 0)) + ] ++ + maybe [] (\cid -> [("cc", cid)]) 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 $ M.fromList (zip dataFields xs))) + dataFields = map (ST.pack . ('d':) . show) [(1::Int)..] + +allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat +allocDynamic s haveDecl to entry free cc = + dec to `mappend` (toJExpr to |= allocDynamicE s entry free cc) + where + dec i | haveDecl = DeclStat i + | otherwise = mempty diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs new file mode 100644 index 0000000000..88d45057e0 --- /dev/null +++ b/compiler/GHC/StgToJS/Deps.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE TupleSections #-} + +module GHC.StgToJS.Deps + ( genDependencyData + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Object as Object +import GHC.StgToJS.Types +import GHC.StgToJS.Monad + +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.ShortText as ST + +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 -- FIXME Sylvain 2022-02: use UniqFM + { ddcModule :: !(IntMap Unit) -- ^ Unique Module -> Object.Package + , 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 dependy 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 (jsIdI 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: " ++ ST.unpack 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 (jsIdI i) + lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt) + + lookupExportedOther :: ShortText -> 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 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..28e2706734 --- /dev/null +++ b/compiler/GHC/StgToJS/Expr.hs @@ -0,0 +1,947 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} + +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.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.Types.CostCentre +import GHC.Types.Tickish +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Unique.Set +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.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext) +import qualified GHC.Utils.Monad.State.Strict as State +import qualified GHC.Data.ShortText as ST +import qualified GHC.Data.List.SetOps as ListSetOps + +import Data.Ord +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 + +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 (ctx { ctxSrcSpan = Just span} ) 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' = clearCtxStack 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 <- genIdsI b + the_fvjs <- genIds the_fv + case (tgts, the_fvjs) of + ([tgt], [the_fvj]) -> return $ Just + (tgt ||= ApplExpr (var ("h$c_sel_" <> ST.pack sel_tag)) [the_fvj]) + _ -> panic "genBind.assign: invalid size" + assign b (StgRhsClosure _ext _ccs _upd [] expr) + | snd (isInlineExpr (ctxEval ctx) expr) = do + d <- declIds b + tgt <- genIds b + let ctx' = ctx { ctxTarget = alignIdExprs 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 (addEval b c) xs + | (StgRhsClosure _ _ ReEntrant _ _) <- r = addEvalRhs (addEval b c) xs + | otherwise = addEvalRhs c xs + +genBindLne :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStat, ExprCtx) +genBindLne ctx bndr = do + vis <- map (\(x,y,_) -> (x,y)) <$> + optimizeFree oldFrameSize (newLvs++map fst updBinds) + declUpds <- mconcat <$> mapM (fmap (\x -> x ||= null_) . jsIdI . fst) updBinds + let newFrameSize = oldFrameSize + length vis + ctx' = ctx + { ctxLne = addListToUniqSet (ctxLne ctx) bound + , ctxLneFrameBs = addListToUFM (ctxLneFrameBs ctx) (map (,newFrameSize) bound) + , ctxLneFrame = ctxLneFrame ctx ++ vis + } + mapM_ (uncurry $ genEntryLne ctx') binds + return (declUpds, ctx') + where + oldFrame = ctxLneFrame ctx + oldFrameSize = length oldFrame + isOldLv i = i `elementOfUniqSet` (ctxLne ctx) || + i `elem` (map fst oldFrame) + 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 = length frame + frame = ctxLneFrame ctx + myOffset = + maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame") + ((payloadSize-) . fst) + (listToMaybe $ filter ((==i).fst.snd) (zip [0..] frame)) + 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) <- jsEntryIdI i + sr <- genStaticRefsRhs rhs + let f = JFunc [] (bh <> lvs <> body) + emitClosureInfo $ + ClosureInfo eii + (CIRegs 0 $ concatMap idVt args) + (eii <> ", " <> ST.pack (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout . reverse $ + map (stackSlotType . fst) (ctxLneFrame ctx)) + CIStackFrame + sr + emitToplevel (ei ||= toJExpr f) +genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do + let payloadSize = length (ctxLneFrame ctx) + ei@(TxtI _eii) <- jsEntryIdI i + -- di <- enterDataCon con + ii <- makeIdent + p <- popLneFrame True payloadSize ctx + args' <- concatMapM genArg args + ac <- allocCon ii con cc args' + emitToplevel (ei ||= toJExpr (JFunc [] + (mconcat [DeclStat 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 () -- mempty -- error "local data entry" +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) <- jsEntryIdI i + et <- genEntryType args + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + sr <- genStaticRefsRhs rhs + emitClosureInfo $ ClosureInfo eii + (CIRegs 0 $ PtrV : concatMap idVt args) + (eii <> ", " <> ST.pack (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout $ map (uTypeVt . idType) live) + et + sr + emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + where + entryCtx = ExprCtx i [] (ctxEval ctx) (ctxLne ctx) emptyUFM [] (ctxSrcSpan ctx) + +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 + +genBody :: HasDebugCallStack + => ExprCtx + -> Id + -> StgReg + -> [Id] + -> CgStgExpr + -> G JStat +genBody ctx i startReg args e = do + la <- loadArgs startReg args + lav <- verifyRuntimeReps args + let ids :: [TypedExpr] + ids = -- take (resultSize args $ idType i) (map toJExpr $ enumFrom R1) + reverse . fst $ + foldl' (\(rs, vs) (rep, size) -> + let (vs0, vs1) = splitAt size vs + in (TypedExpr rep vs0:rs,vs1)) + ([], map toJExpr $ enumFrom R1) + (resultSize args $ idType i) + (e, _r) <- genExpr (ctx { ctxTarget = ids }) e + return $ la <> lav <> e <> returnStack + +-- find the result type after applying the function to the arguments +resultSize :: HasDebugCallStack => [Id] -> Type -> [(PrimRep, Int)] +resultSize xxs@(_:xs) t + | t' <- unwrapType t + , Just (_mult, fa, fr) <- splitFunTy_maybe t' -- isFunTy t' = + , Just (tc, ys) <- splitTyConApp_maybe fa + , isUnboxedTupleTyCon tc = + resultSize xxs (mkVisFunTysMany (dropRuntimeRepArgs ys) fr) + | t' <- unwrapType t + , Just (_mult, _fa, fr) <- splitFunTy_maybe t' = -- isFunTy t' = + resultSize xs fr + | otherwise = [(LiftedRep, 1)] -- possibly newtype family, must be boxed +resultSize [] t + | isRuntimeRepKindedTy t' = [] + | isRuntimeRepTy t' = [] + | Nothing <- isLiftedType_maybe t' = [(LiftedRep, 1)] + | otherwise = fmap (\p -> (p, slotCount (primRepSize p))) (typePrimReps t) + where + t' = unwrapType t + +loadArgs :: HasDebugCallStack => StgReg -> [Id] -> G JStat +loadArgs start args = do + args' <- concatMapM genIdArgI args + return (declAssignAll args' (fmap toJExpr [start..])) + +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' <- genIds 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 + +loadLiveFun :: [Id] -> G JStat +loadLiveFun l = do + l' <- concat <$> mapM genIdsI l + case l' of + [] -> return mempty + [v] -> return (v ||= r1 .^ closureExtra1_) + [v1,v2] -> return $ mconcat + [ v1 ||= r1 .^ closureExtra1_ + , v2 ||= r1 .^ closureExtra2_ + ] + (v:vs) -> do + d <- makeIdent + let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs + return $ mconcat + [ v ||= r1 .^ closureExtra1_ + , d ||= r1 .^ closureExtra2_ + , l'' + ] + where + loadLiveVar d n v = let ident = TxtI (dataFieldName n) + in DeclStat v `mappend` (toJExpr v |= SelExpr d ident) + +popLneFrame :: Bool -> Int -> ExprCtx -> G JStat +popLneFrame inEntry size ctx + | l < size = panic $ "popLneFrame: let-no-escape frame too short: " ++ + show l ++ " < " ++ show size + | otherwise = popSkipI skip + =<< mapM (\(i,n) -> (,SlotId i n) <$> genIdsIN i n) + (take size $ ctxLneFrame ctx) + where + skip = if inEntry then 1 else 0 -- pop the frame header + l = length (ctxLneFrame ctx) + +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 .^ closureExtra1_ |= undefined_ + , r1 .^ closureExtra2_ |= 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 || + isLiftedType_maybe (idType x) == Just False)) + (dVarSetElems sv) + CIStaticRefs . catMaybes <$> mapM getStaticRef xs + where + sv = liveStatic lv + +-- 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)] +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 + +addEval :: Id -> ExprCtx -> ExprCtx +addEval i ctx = ctx { ctxEval = addOneToUniqSet (ctxEval ctx) i } + +-- 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 <- jsIdI i + Left <$> (return (decl ii) <> allocCon ii con cc []) -} + toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do + ii <- jsIdI i + ac <- allocCon ii con cc =<< genArg a + pure (Left (DeclStat ii <> ac)) + + -- dynamics + toCl (i, StgRhsCon cc con _mu _ticks ar) = + -- fixme do we need to handle unboxed? + Right <$> ((,,,) <$> jsIdI i + <*> enterDataCon con + <*> concatMapM genArg ar + <*> pure cc) + toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) = + let live = stgLneLiveExpr cl + in Right <$> ((,,,) <$> jsIdI i + <*> jsEntryId i + <*> concatMapM genIds live + <*> pure cc) + +-- fixme CgCase has a reps_compatible check here +genCase :: HasDebugCallStack + => ExprCtx + -> Id + -> CgStgExpr + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G (JStat, ExprResult) +genCase ctx bnd e at alts l + | snd (isInlineExpr (ctxEval ctx) e) = withNewIdent $ \ccsVar -> do + bndi <- genIdsI bnd + let ctx' = ctx + { ctxTop = bnd + , ctxTarget = alignIdExprs bnd (map toJExpr bndi) + } + (ej, r) <- genExpr ctx' e + let d = case r of + ExprInline d0 -> d0 + ExprCont -> pprPanic "genCase: expression was not inline" + (pprStgExpr panicStgPprOpts e) + + ww = mempty -- if snd (isInlineExpr emptyUniqSet e) then mempty else [j| h$log('danger will robinson'); |] + (aj, ar) <- genAlts (addEval bnd ctx) bnd at d alts + saveCCS <- ifProfiling (toJExpr ccsVar |= toJExpr jCurrentCCS) + restoreCCS <- ifProfiling (toJExpr jCurrentCCS |= toJExpr ccsVar) + return ( mconcat + [ DeclStat ccsVar + , mconcat (map DeclStat bndi) + , saveCCS + , ww + , ej + , restoreCCS + , aj + ] + , ar + ) + | otherwise = do + rj <- genRet (addEval bnd ctx) bnd at alts l + let ctx' = ctx + { ctxTop = bnd + , ctxTarget = alignIdExprs bnd (map toJExpr [R1 ..]) + } + (ej, _r) <- genExpr ctx' e + return (rj <> ej, ExprCont) + +genRet :: HasDebugCallStack + => ExprCtx + -> Id + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G JStat +genRet ctx e at as l = withNewIdent f + where + allRefs :: [Id] + allRefs = S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as + lneLive :: Int + lneLive = maximum $ 0 : map (fromMaybe 0 . lookupUFM (ctxLneFrameBs ctx)) allRefs + ctx' = adjustCtxStack lneLive ctx + lneVars = map fst $ take lneLive (ctxLneFrame ctx) + isLne i = i `elem` lneVars || i `elementOfUniqSet` (ctxLne ctx) + 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 ri + (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] + + fun free = resetSlots $ do + decs <- declIds e + load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> genIdsI e + loadv <- verifyRuntimeReps [e] + ras <- loadRetArgs free + rasv <- verifyRuntimeReps (map (\(x,_,_)->x) free) + restoreCCS <- ifProfilingM $ popUnknown [jCurrentCCS] + rlne <- popLneFrame False lneLive ctx' + rlnev <- verifyRuntimeReps (map fst $ take lneLive (ctxLneFrame ctx')) + (alts, _altr) <- genAlts ctx' e at Nothing as + return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <> + returnStack + +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] -> (\b -> (branch_stat b, branch_result b)) <$> mkAlgBranch ctx e alt + _ -> panic "genAlts: multiple polyalt" + + PrimAlt _tc + | [GenStgAlt _ bs expr] <- alts + -> do + ie <- genIds e + dids <- mconcat <$> mapM declIds bs + bss <- concatMapM genIds bs + (ej, er) <- genExpr ctx expr + return (dids <> assignAllEqual bss ie <> ej, er) + + PrimAlt tc + -> do + ie <- genIds 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 <- genIds 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 genIdsI 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 <- jsId 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" + + -- FIXME: add all alts + + AlgAlt _tc -> do + ei <- jsId 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) + +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 <- genIds x + pure $ ApplStat (var "h$verify_match_alg") (ValExpr(JStr(ST.pack (renderWithContext defaultSDocContext (ppr tc)))):ix) + _ -> pure mempty + +data Branch a = Branch + { branch_expr :: a + , branch_stat :: JStat + , branch_result :: ExprResult + } + deriving (Eq,Ord,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 (map toJExpr $ enumFrom R1) + (concatMap typex_expr $ ctxTarget ctx) + , branch_result = ExprCont + } + _ -> b + +loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat +loadUbxTup es bs _n = do + bs' <- concatMapM genIdsI 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 +mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkIfElse e s = go (L.sortOn Down 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" + +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 <- jsId d + fldx <- genIdsI 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 <- jsId d + b <- loadParams idd (alt_bndrs alt) + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch cc (b <> ej) er) + +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) + +-- load parameters from constructor +-- fixme use single tmp var for all branches +loadParams :: JExpr -> [Id] -> G JStat +loadParams from args = do + as <- concat <$> zipWithM (\a u -> map (,u) <$> genIdsI a) args use + return $ case as of + [] -> mempty + [(x,u)] -> loadIfUsed (from .^ closureExtra1_) x u + [(x1,u1),(x2,u2)] -> mconcat + [ loadIfUsed (from .^ closureExtra1_) x1 u1 + , loadIfUsed (from .^ closureExtra2_) x2 u2 + ] + ((x,u):xs) -> mconcat + [ loadIfUsed (from .^ closureExtra1_) x u + , jVar (\d -> mconcat [ d |= from .^ closureExtra2_ + , 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 + +-- 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 + +adjustCtxStack :: Int -> ExprCtx -> ExprCtx +adjustCtxStack n ctx + | l < n = panic $ "adjustCtxStack: let-no-escape stack too short: " ++ + show l ++ " < " ++ show n + | otherwise = ctx { ctxLneFrame = take n (ctxLneFrame ctx) } + where + l = length (ctxLneFrame ctx) + +clearCtxStack :: ExprCtx -> ExprCtx +clearCtxStack ctx = ctx + { ctxLneFrameBs = emptyUFM + , ctxLneFrame = [] + } + +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)]) + +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 + + makeObjs :: G JStat + makeObjs = do + fmap mconcat $ forM cls $ \(i,f,_,cc) -> do + ccs <- maybeToList <$> costCentreStackLbl cc + pure $ mconcat + [ dec i + , toJExpr i |= if csInlineAlloc settings + then ValExpr (jhFromList $ [ (closureEntry_ , f) + , (closureExtra1_, null_) + , (closureExtra2_, null_) + , (closureMeta_ , zero_) + ] + ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs) + else ApplExpr (var "h$c") (f : fmap (\cid -> ValExpr (JVar cid)) ccs) + ] + + fillObjs = mconcat $ map fillObj cls + fillObj (i,_,es,_) + | csInlineAlloc settings || length es > 24 = + case es of + [] -> mempty + [ex] -> toJExpr i .^ closureExtra1_ |= toJExpr ex + [e1,e2] -> mconcat + [ toJExpr i .^ closureExtra1_ |= toJExpr e1 + , toJExpr i .^ closureExtra2_ |= toJExpr e2 + ] + (ex:es) -> mconcat + [ toJExpr i .^ closureExtra1_ |= toJExpr ex + , toJExpr i .^ closureExtra2_ |= toJExpr (jhFromList (zip dataFieldNames es)) + ] + | otherwise = case es of + [] -> mempty + [ex] -> toJExpr i .^ closureExtra1_ |= ex + [e1,e2] -> mconcat + [ toJExpr i .^ closureExtra1_ |= e1 + , toJExpr i .^ closureExtra2_ |= e2 + ] + (ex:es) -> mconcat + [ toJExpr i .^ closureExtra1_ |= ex + , toJExpr i .^ closureExtra2_ |= fillFun es + ] + + fillFun [] = null_ + fillFun es = ApplExpr (allocData (length es)) es + + dec i | haveDecl = DeclStat i + | otherwise = mempty + checkObjs | csAssertRts settings = mconcat $ map (\(i,_,_,_) -> (ApplStat (ValExpr (JVar (TxtI "h$checkObj")))) (((:) (toJExpr i)) []){-[j| h$checkObj(`i`); |]-}) cls + | otherwise = mempty + + objs <- makeObjs + pure $ mconcat [objs, middle', fillObjs, checkObjs] + +genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult) +genPrimOp ctx op args t = do + as <- concatMapM genArg args + prof <- csProf <$> getSettings + -- fixme: should we preserve/check the primreps? + return $ case genPrim prof t op (concatMap typex_expr $ ctxTarget ctx) as of + PrimInline s -> (s, ExprInline Nothing) + PRPrimCall s -> (s, ExprCont) diff --git a/compiler/GHC/StgToJS/FFI.hs b/compiler/GHC/StgToJS/FFI.hs new file mode 100644 index 0000000000..007f9f4ae3 --- /dev/null +++ b/compiler/GHC/StgToJS/FFI.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE LambdaCase #-} +{-# 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.Monad +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Regs +import GHC.StgToJS.CoreUtils + +import GHC.Types.RepType +import GHC.Types.ForeignCall + +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 qualified GHC.Data.ShortText as ST +import GHC.Data.ShortText (ShortText) + +import Data.Char +import Data.Monoid +import Data.Maybe +import qualified Data.List as L +import qualified Data.Map as M +import Control.Monad +import Control.Applicative +import qualified Text.ParserCombinators.ReadP as P + +-- FIXME: what if the call returns a thunk? +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 + let ex = TxtI "except" + return (TryStat c ex (ReturnStat (ApplExpr (var "h$throwJSException") [toJExpr ex])) mempty) + {-[j| try { + `c`; + } catch(e) { + return h$throwJSException(e); + } + |]-} + | 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 <- makeIdent + x <- makeIdent + d <- makeIdent + 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 + [ DeclStat d + , toJExpr 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 = 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 = M.fromList (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 = M.fromList (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 $ ST.pack 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 :: M.Map Ident JExpr -> Ident -> JExpr + replaceIdent env i + | isFFIPlaceholder i = fromMaybe err (M.lookup i env) + | otherwise = ValExpr (JVar i) + where + (TxtI i') = i + err = pprPanic "parseFFIPattern': invalid placeholder, check function type" + (vcat [ppr pat, text (ST.unpack 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 (ST.unpack 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_])) <$> jsId i + | isVoid r = return (mempty, []) +-- | Just x <- marshalFFIArg a = x + | isMultiVar r = (mempty,) <$> mapM (jsIdN i) [1..varSize r] + | otherwise = (\x -> (mempty,[x])) <$> jsId 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 . ST.pack $ prefix, x)] + xs@(x:_) -> (TxtI . ST.pack $ prefix, x) : + zipWith (\x m -> (TxtI . ST.pack $ 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 (ST.pack 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 . ST.pack $ "$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" + -- FIXME: removed temporarily for the codegen merge (sylvain) + +parseFfiJM :: String -> Int -> Either String JStat +parseFfiJM _xs _u = Left "parseFfiJM not yet implemented" + -- FIXME: removed temporarily for the codegen merge (sylvain) + +saturateFFI :: JMacro a => Int -> a -> a +saturateFFI u = jsSaturate (Just . ST.pack $ "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 $ M.fromList pairs')) + , ExprInline Nothing + ) + +genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do + emitForeign (ctxSrcSpan ctx) (ST.pack 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) (map toJExpr $ enumFrom R1) + | otherwise = tgt + + wrapperPrefix = "ghczuwrapperZC" + +getObjectKeyValuePairs :: [StgArg] -> Maybe [(ShortText, StgArg)] +getObjectKeyValuePairs [] = Just [] +getObjectKeyValuePairs (k:v:xs) + | Just t <- argJSStringLitUnfolding k = + fmap ((t,v):) (getObjectKeyValuePairs xs) +getObjectKeyValuePairs _ = Nothing + +argJSStringLitUnfolding :: StgArg -> Maybe ShortText +argJSStringLitUnfolding (StgVarArg _v) = Nothing -- fixme +argJSStringLitUnfolding _ = Nothing + +showArgType :: StgArg -> ShortText +showArgType a = showType (stgArgType a) + +showType :: Type -> ShortText +showType t + | Just tc <- tyConAppTyCon_maybe (unwrapType t) = + ST.pack (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..0edfe6729e --- /dev/null +++ b/compiler/GHC/StgToJS/Heap.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Heap + ( closureType + , entryClosureType + , isObject + , isThunk + , isThunk' + , isBlackhole + , isFun + , isFun' + , isPap + , isPap' + , isCon + , isCon' + , conTag + , conTag' + , entry + , funArity + , funArity' + , papArity + , funOrPapArity + -- * Field names + , closureEntry_ + , closureMeta_ + , closureExtra1_ + , closureExtra2_ + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.StgToJS.Types +import GHC.Data.ShortText (ShortText) + +closureEntry_ :: ShortText +closureEntry_ = "f" + +closureExtra1_ :: ShortText +closureExtra1_ = "d1" + +closureExtra2_ :: ShortText +closureExtra2_ = "d2" + +closureMeta_ :: ShortText +closureMeta_ = "m" + +entryClosureType_ :: ShortText +entryClosureType_ = "t" + +entryConTag_ :: ShortText +entryConTag_ = "a" + +entryFunArity_ :: ShortText +entryFunArity_ = "a" + + + +closureType :: JExpr -> JExpr +closureType = entryClosureType . entry + +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' . entry + +conTag' :: JExpr -> JExpr +conTag' f = f .^ entryConTag_ + +entry :: JExpr -> JExpr +entry p = p .^ closureEntry_ + +-- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +funArity :: JExpr -> JExpr +funArity = funArity' . entry + +-- 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 = cp .^ closureExtra2_ .^ closureExtra1_ + +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/Literal.hs b/compiler/GHC/StgToJS/Literal.hs new file mode 100644 index 0000000000..b9de8ffe50 --- /dev/null +++ b/compiler/GHC/StgToJS/Literal.hs @@ -0,0 +1,99 @@ +{-# 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 qualified GHC.Data.ShortText as ST +import GHC.Data.ShortText (ShortText(..)) +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 qualified Data.ByteString.Short as Short +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 -> + withNewIdent $ \strLit@(TxtI strLitT) -> + withNewIdent $ \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 LitNumInt i -> return [ toJExpr i ] + LitNumber LitNumInt64 i -> return [ toJExpr (Bits.shiftR i 32), toJExpr (toSigned i) ] + LitNumber LitNumWord w -> return [ toJExpr (toSigned w) ] + LitNumber LitNumWord64 w -> return [ toJExpr (toSigned (Bits.shiftR w 32)), toJExpr (toSigned w) ] + LitFloat r -> return [ toJExpr (r2f r) ] + LitDouble r -> return [ toJExpr (r2d r) ] + LitLabel name _size fod + | fod == IsFunction -> return [ ApplExpr (var "h$mkFunctionPtr") + [var (ST.pack $ "h$" ++ unpackFS name)] + , ValExpr (JInt 0) + ] + | otherwise -> return [ toJExpr (TxtI . ST.pack $ "h$" ++ unpackFS name) + , ValExpr (JInt 0) + ] + -- FIXME: handle other LitNumbers, LitRubbish, etc. + l -> pprPanic "genLit" (ppr l) + +-- | 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 (ShortText (Short.toShort str)), IntLit 0] + -- FIXME: documentation for LitString says it's always UTF8 encoded but it's + -- not true (e.g. for embedded files). + -- 1) We should add a decoding function that detects errors in + -- GHC.Utils.Encoding + -- 2) We should perhaps add a different LitBin constructor that would + -- benefit other backends? + -- | invalid UTF8 -> return [ BinLit str, IntLit 0] + LitNullAddr -> return [ NullLit, IntLit 0 ] + LitNumber LitNumInt i -> return [ IntLit (fromIntegral i) ] + LitNumber LitNumInt64 i -> return [ IntLit (i `Bits.shiftR` 32), IntLit (toSigned i) ] + LitNumber LitNumWord w -> return [ IntLit (toSigned w) ] + LitNumber LitNumWord64 w -> return [ IntLit (toSigned (w `Bits.shiftR` 32)), IntLit (toSigned w) ] + LitFloat r -> return [ DoubleLit . SaneDouble . r2f $ r ] + LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] + LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (ST.pack $ "h$" ++ unpackFS name) + , IntLit 0 ] + -- FIXME: handle other LitNumbers, LitRubbish, etc. + l -> pprPanic "genStaticLit" (ppr l) + +-- make a signed 32 bit int from this unsigned one, lower 32 bits +toSigned :: Integer -> Integer +toSigned i | Bits.testBit i 31 = Bits.complement (0x7FFFFFFF `Bits.xor` (i Bits..&. 0x7FFFFFFF)) + | otherwise = 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..275aab9dab --- /dev/null +++ b/compiler/GHC/StgToJS/Monad.hs @@ -0,0 +1,654 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module GHC.StgToJS.Monad + ( runG + , emitGlobal + , addDependency + , emitToplevel + , emitStatic + , emitClosureInfo + , emitForeign + , assertRtsStat + , getSettings + , updateThunk + , updateThunk' + , liftToGlobal + -- * IDs + , withNewIdent + , makeIdent + , freshUnique + , jsIdIdent + , jsId + , jsIdN + , jsIdI + , jsIdIN + , jsIdV + , jsEnId + , jsEnIdI + , jsEntryId + , jsEntryIdI + , jsDcEntryId + , jsDcEntryIdI + , genIds + , genIdsN + , genIdsI + , genIdsIN + , getStaticRef + , declIds + -- * Datacon + , enterDataCon + , enterDataConI + -- * Group + , modifyGroup + , resetGroup + -- * Stack + , resetSlots + , isolateSlots + , setSlots + , getSlots + , addSlots + , dropSlots + , addUnknownSlots + , adjPushStack + , push + , push' + , adjSpN + , adjSpN' + , adjSp + , pushNN + , pushNN' + , pushN' + , pushN + , pushOptimized' + , pushOptimized + , pushLneFrame + , pop + , popn + , popUnknown + , popSkipUnknown + , popSkip + , popSkip' + , popSkipI + , loadSkip + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.Regs +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.UnitUtils + +import GHC.Data.ShortText as ST +import GHC.Unit.Module +import GHC.Core.DataCon +import GHC.Stg.Syntax + +import GHC.Types.SrcLoc +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.ForeignCall + +import GHC.Utils.Encoding (zEncodeString) +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Misc +import GHC.Utils.Panic +import qualified GHC.Utils.Monad.State.Strict as State +import GHC.Data.FastString + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Bits as Bits +import qualified Data.List as L +import Data.Function +import Data.Maybe +import Data.Array +import Data.Monoid +import Control.Monad + +runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> a +runG config m unfloat action = State.evalState action (initState config m unfloat) + +initState :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> GenState +initState config m unfloat = GenState + { gsSettings = config + , gsModule = m + , gsId = 1 + , 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 :: ShortText -> 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 + -> ShortText + -> Safety + -> CCallConv + -> [ShortText] + -> ShortText + -> 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 + Just sp -> ST.pack $ + unpackFS (srcSpanFile sp) ++ + " " ++ + show (srcSpanStartLine sp, srcSpanStartCol sp) ++ + "-" ++ + show (srcSpanEndLine sp, srcSpanEndCol sp) + Nothing -> "<unknown>" + + +withNewIdent :: (Ident -> G a) -> G a +withNewIdent m = makeIdent >>= m + +makeIdent :: G Ident +makeIdent = do + i <- freshUnique + mod <- State.gets gsModule + let !name = ST.pack $ mconcat + [ "h$$" + , zEncodeString (unitModuleString mod) + , "_" + , encodeUnique i + ] + return (TxtI name) + +encodeUnique :: Int -> String +encodeUnique = reverse . iToBase62 -- reversed is more compressible + +jsId :: Id -> G JExpr +jsId i +-- | i == trueDataConId = return $ toJExpr True +-- | i == falseDataConId = return $ toJExpr False + | otherwise = ValExpr . JVar <$> jsIdIdent i Nothing IdPlain + +jsIdI :: Id -> G Ident +jsIdI i = jsIdIdent i Nothing IdPlain + +-- some types, Word64, Addr#, unboxed tuple have more than one javascript var +jsIdIN :: Id -> Int -> G Ident +jsIdIN i n = jsIdIdent i (Just n) IdPlain + +jsIdN :: Id -> Int -> G JExpr +jsIdN i n = ValExpr . JVar <$> jsIdIdent i (Just n) IdPlain + +-- entry id +jsEnId :: Id -> G JExpr +jsEnId i = ValExpr . JVar <$> jsEnIdI i + +jsEnIdI :: Id -> G Ident +jsEnIdI i = jsIdIdent i Nothing IdEntry + +jsEntryId :: Id -> G JExpr +jsEntryId i = ValExpr . JVar <$> jsEntryIdI i + +jsEntryIdI :: Id -> G Ident +jsEntryIdI i = jsIdIdent i Nothing IdEntry + +-- datacon entry, different name than the wrapper +jsDcEntryId :: Id -> G JExpr +jsDcEntryId i = ValExpr . JVar <$> jsDcEntryIdI i + +jsDcEntryIdI :: Id -> G Ident +jsDcEntryIdI i = jsIdIdent i Nothing IdConEntry + +-- entry function of the worker +enterDataCon :: DataCon -> G JExpr +enterDataCon d = jsDcEntryId (dataConWorkId d) + +enterDataConI :: DataCon -> G Ident +enterDataConI d = jsDcEntryIdI (dataConWorkId d) + + +jsIdV :: Id -> G JVal +jsIdV i = JVar <$> jsIdIdent i Nothing IdPlain + + +-- | generate all js vars for the ids (can be multiple per var) +genIds :: Id -> G [JExpr] +genIds i + | s == 0 = return mempty + | s == 1 = (:[]) <$> jsId i + | otherwise = mapM (jsIdN i) [1..s] + where + s = typeSize (idType i) + +genIdsN :: Id -> Int -> G JExpr +genIdsN i n = do + xs <- genIds i + return $ xs !! (n-1) + +-- | get all idents for an id +genIdsI :: Id -> G [Ident] +genIdsI i + | s == 1 = (:[]) <$> jsIdI i + | otherwise = mapM (jsIdIN i) [1..s] + where + s = typeSize (idType i) + +genIdsIN :: Id -> Int -> G Ident +genIdsIN i n = do + xs <- genIdsI i + return $ xs !! (n-1) + +jsIdIdent :: Id -> Maybe Int -> IdType -> G Ident +jsIdIdent i mi suffix = do + IdCache cache <- State.gets gsIdents + ident <- case M.lookup key cache of + Just ident -> pure ident + Nothing -> do + mod <- State.gets gsModule + let !ident = makeIdIdent i mi suffix mod + let !cache' = IdCache (M.insert key ident cache) + State.modify (\s -> s { gsIdents = cache' }) + pure ident + updateGlobalIdCache ident + where + !key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) suffix + updateGlobalIdCache :: Ident -> G Ident + updateGlobalIdCache ji + -- fixme also allow caching entries for lifting? + | not (isGlobalId i) || isJust mi || suffix /= IdPlain = pure ji + | otherwise = do + GlobalIdCache gidc <- getGlobalIdCache + case M.lookup ji gidc of + Nothing -> do + let mod_group g = g { ggsGlobalIdCache = GlobalIdCache (M.insert ji (key, i) gidc) } + State.modify (\s -> s { gsGroup = mod_group (gsGroup s) }) + Just _ -> pure () + pure ji + +getStaticRef :: Id -> G (Maybe ShortText) +getStaticRef = fmap (fmap itxt . listToMaybe) . genIdsI + +-- uncached +makeIdIdent :: Id -> Maybe Int -> IdType -> Module -> Ident +makeIdIdent i mn suffix0 mod = TxtI txt + where + !txt = ST.pack full_name + + full_name = mconcat + ["h$" + , prefix + , zEncodeString ('.':name) + , mns + , suffix + , u + ] + + -- prefix and suffix (unique) + (prefix,u) + | isExportedId i + , Just x <- (nameModule_maybe . getName) i + = ( zEncodeString (unitModuleString x) + , "" + ) + | otherwise + = ( '$':zEncodeString (unitModuleString mod) + , '_': encodeUnique (getKey (getUnique i)) + ) + + suffix = idTypeSuffix suffix0 + mns = maybe "" (('_':).show) mn + name = renderWithContext defaultSDocContext . ppr . localiseName . getName $ i + + + +idTypeSuffix :: IdType -> String +idTypeSuffix IdPlain = "" +idTypeSuffix IdEntry = "_e" +idTypeSuffix IdConEntry = "_con_e" + +-- | 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 M.empty + +emptyIdCache :: IdCache +emptyIdCache = IdCache M.empty + +-- | run the action 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 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) + +dropSlots :: Int -> G () +dropSlots n = modifySlots (drop n) + +adjPushStack :: Int -> G () +adjPushStack n = do + modifyStackDepth (+n) + dropSlots 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 (\i e -> AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e)) + [(1::Int)..] xs + offset i | i == l = sp + | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) + l = length xs + + +adjSp' :: Int -> JStat +adjSp' 0 = mempty +adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n) + +adjSpN' :: Int -> JStat +adjSpN' 0 = mempty +adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n) + +adjSp :: Int -> G JStat +adjSp 0 = return mempty +adjSp n = do + modifyStackDepth (+n) + return (adjSp' n) + +adjSpN :: Int -> G JStat +adjSpN 0 = return mempty +adjSpN n = do + modifyStackDepth (\x -> x - n) + return (adjSpN' n) + +pushN :: Array Int Ident +pushN = listArray (1,32) $ map (TxtI . ST.pack . ("h$p"++) . show) [(1::Int)..32] + +pushN' :: Array Int JExpr +pushN' = fmap (ValExpr . JVar) pushN + +pushNN :: Array Integer Ident +pushNN = listArray (1,255) $ map (TxtI . ST.pack . ("h$pp"++) . show) [(1::Int)..255] + +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) (SlotId i2 n2) = (,i1==i2&&n1==n2) <$> genIdsN i1 n1 + f (i1,n1) _ = (,False) <$> genIdsN i1 n1 + +-- | 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)) + +pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat +pushLneFrame size ctx + | l < size = panic $ "pushLneFrame: let-no-escape frame too short " ++ + show l ++ " < " ++ show size + | otherwise = pushOptimized' (take size $ ctxLneFrame ctx) + where + l = length (ctxLneFrame ctx) + + + +popUnknown :: [JExpr] -> G JStat +popUnknown xs = popSkipUnknown 0 xs + +popSkipUnknown :: Int -> [JExpr] -> G JStat +popSkipUnknown n xs = popSkip n (map (,SlotUnknown) xs) + +pop :: [(JExpr,StackSlot)] -> G JStat +pop = popSkip 0 + +-- | pop the expressions, but ignore the top n elements of the stack +popSkip :: Int -> [(JExpr,StackSlot)] -> G JStat +popSkip 0 [] = pure mempty +popSkip n [] = addUnknownSlots n >> adjSpN n +popSkip n xs = do + addUnknownSlots n + addSlots (map snd xs) + a <- adjSpN (length xs + n) + return (loadSkip n (map fst xs) <> a) + +-- | pop things, don't upstate stack knowledge +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) + +-- | like popSkip, but without modifying the stack pointer +loadSkip :: Int -> [JExpr] -> JStat +loadSkip = loadSkipFrom sp + +loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat +loadSkipFrom fr n xs = mconcat items + where + items = reverse $ zipWith (\i ex -> ex |= IdxExpr stack (toJExpr (offset (i+n)))) + [(0::Int)..] + (reverse xs) + offset 0 = toJExpr fr + offset n = InfixExpr SubOp (toJExpr fr) (toJExpr n) + + +-- declare and pop +popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat +popSkipI 0 [] = pure mempty +popSkipI n [] = adjSpN n +popSkipI n xs = do + addUnknownSlots n + addSlots (map snd xs) + a <- adjSpN (length xs + n) + return (loadSkipI n (map fst xs) <> a) + +-- like popSkip, but without modifying sp +loadSkipI :: Int -> [Ident] -> JStat +loadSkipI = loadSkipIFrom sp + +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))) + +popn :: Int -> G JStat +popn n = addUnknownSlots n >> adjSpN n + + +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) + +updateThunk' :: StgToJSConfig -> JStat +updateThunk' settings = + if csInlineBlackhole settings + then bhStats settings True + else ApplStat (var "h$bh") [] + +-- | Generate statemeents 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 .^ closureExtra1_ |= var "h$currentThread" + , toJExpr R1 .^ closureExtra2_ |= null_ -- will be filled with waiters array + ] + +updateThunk :: G JStat +updateThunk = do + settings <- getSettings + adjPushStack 2 -- update frame size + return $ (updateThunk' settings) + +-- | declare all js vars for the id +declIds :: Id -> G JStat +declIds i + | s == 0 = return mempty + | s == 1 = DeclStat <$> jsIdI i + | otherwise = mconcat <$> mapM (\n -> DeclStat <$> jsIdIN i n) [1..s] + where + s = typeSize (idType i) + +freshUnique :: G Int +freshUnique = do + State.modify (\s -> s { gsId = gsId s + 1}) + State.gets gsId + +liftToGlobal :: JStat -> G [(Ident, Id)] +liftToGlobal jst = do + GlobalIdCache gidc <- getGlobalIdCache + let sids = filter (`M.member` gidc) (identsS jst) + cnt = M.fromListWith (+) (map (,(1::Integer)) sids) + sids' = L.sortBy (compare `on` (cnt M.!)) (nub' sids) + pure $ map (\s -> (s, snd $ gidc M.! s)) sids' + +nub' :: (Ord a, Eq a) => [a] -> [a] +nub' xs = go S.empty xs + where + go _ [] = [] + go s (x:xs) | S.member x s = go s xs + | otherwise = x : go (S.insert x s) xs +-- ids = filter M.member gidc +{- + algorithm: + - collect all Id refs that are in the cache, count usage + - order by increasing use + - prepend loading lives var to body: body can stay the same +-} diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs new file mode 100644 index 0000000000..bb986926b1 --- /dev/null +++ b/compiler/GHC/StgToJS/Object.hs @@ -0,0 +1,845 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | 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: +-- - header ["GHCJSOBJ", length of symbol table, length of dependencies, length of index] +-- - compiler version tag +-- - symbol table +-- - dependency info +-- - closureinfo index +-- - closureinfo data (offsets described by index) +-- +module GHC.StgToJS.Object + ( object + , object' + , readDepsFile + , readDepsFileEither + , hReadDeps + , hReadDepsEither + , readDeps, readDepsMaybe + , readObjectFile + , readObjectFileKeys + , readObject + , readObjectKeys + , serializeStat + , emptySymbolTable + , isGlobalUnit + , isExportsUnit -- XXX verify that this is used + -- XXX probably should instead do something that just inspects the header instead of exporting it + , Header(..), getHeader, moduleNameTag + , SymbolTable + , ObjUnit (..) + , Deps (..), BlockDeps (..) + , ExpFun (..), ExportedFun (..) + , versionTag, versionTagLength + ) +where + +import GHC.Prelude + +import Control.Exception (bracket) +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import qualified Control.Monad.Trans.State as St + +import Data.Array +import Data.Monoid +import qualified Data.Binary as DB +import qualified Data.Binary.Get as DB +import qualified Data.Binary.Put as DB +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as B +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as C8 (pack, unpack) +import qualified Data.ByteString.Short as SBS +import Data.Function (on) +import Data.Int +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.List (sortBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Word +import Data.Char (isSpace) + +import GHC.Generics +import GHC.Settings.Constants (hiVersion) + +import System.IO (openBinaryFile, withBinaryFile, Handle, + hClose, hSeek, SeekMode(..), IOMode(..) ) + +import GHC.JS.Syntax +import GHC.StgToJS.Types + +import GHC.Unit.Module + +import GHC.Data.FastString +import GHC.Data.ShortText as ST + +import GHC.Utils.Misc + +data Header = Header + { hdrModuleName :: !BS.ByteString + , hdrSymbsLen :: !Int64 + , hdrDepsLen :: !Int64 + , hdrIdxLen :: !Int64 + } deriving (Eq, Ord, Show) + +-- | dependencies for a single module +data Deps = Deps + { depsModule :: !Module -- ^ module + , depsRequired :: !IntSet -- ^ 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 Int) -- ^ exported Haskell functions -> block + , depsBlocks :: !(Array Int BlockDeps) -- ^ info about each block + } deriving (Generic) + +data BlockDeps = BlockDeps + { blockBlockDeps :: [Int] -- ^ dependencies on blocks in this object + , blockFunDeps :: [ExportedFun] -- ^ dependencies on exported symbols in other objects + -- , blockForeignExported :: [ExpFun] + -- , blockForeignImported :: [ForeignRef] + } deriving (Generic) + +data ExpFun = ExpFun + { isIO :: !Bool + , args :: [JSFFIType] + , result :: !JSFFIType + } deriving (Eq, Ord, Show) + +trim :: String -> String +trim = let f = dropWhile isSpace . reverse in f . f + +{- | 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 + +-- fixme document, exports unit is always linked +isExportsUnit :: Int -> Bool +isExportsUnit n = n == 1 + +data JSFFIType + = Int8Type + | Int16Type + | Int32Type + | Int64Type + | Word8Type + | Word16Type + | Word32Type + | Word64Type + | DoubleType + | ByteArrayType + | PtrType + | RefType + deriving (Show, Ord, Eq, Enum) + +data ExportedFun = ExportedFun + { funModule :: !Module + , funSymbol :: !ShortText + } deriving (Eq, Ord) + +-- we need to store the size separately, since getting a HashMap's size is O(n) +data SymbolTable + = SymbolTable !Int !(Map ShortText Int) + deriving (Show) + +emptySymbolTable :: SymbolTable +emptySymbolTable = SymbolTable 0 M.empty + +insertSymbol :: ShortText -> SymbolTable -> (SymbolTable, Int) +insertSymbol s st@(SymbolTable n t) = + case M.lookup s t of + Just k -> (st, k) + Nothing -> (SymbolTable (n+1) (M.insert s n t), n) + +data ObjEnv = ObjEnv + { oeSymbols :: SymbolTableR + , oeName :: String + } + +data SymbolTableR = SymbolTableR + { strText :: Array Int ShortText + , strString :: Array Int String + } + +type PutSM = St.StateT SymbolTable DB.PutM -- FIXME: StateT isn't strict enough apparently +type PutS = PutSM () +type GetS = ReaderT ObjEnv DB.Get + +class Objectable a where + put :: a -> PutS + get :: GetS a + putList :: [a] -> PutS + putList = putListOf put + getList :: GetS [a] + getList = getListOf get + +runGetS :: HasDebugCallStack => String -> SymbolTableR -> GetS a -> ByteString -> a +runGetS name st m bs = DB.runGet (runReaderT m (ObjEnv st name)) bs + +runPutS :: SymbolTable -> PutS -> (SymbolTable, ByteString) +runPutS st ps = DB.runPutM (St.execStateT ps st) + +unexpected :: String -> GetS a +unexpected err = ask >>= \e -> + error (oeName e ++ ": " ++ err) + +-- one toplevel block in the object file +data ObjUnit = ObjUnit + { oiSymbols :: [ShortText] -- toplevel symbols (stored in index) + , oiClInfo :: [ClosureInfo] -- closure information of all closures in block + , oiStatic :: [StaticInfo] -- static closure data + , oiStat :: JStat -- the code + , oiRaw :: ShortText -- raw JS code + , oiFExports :: [ExpFun] + , oiFImports :: [ForeignJSRef] + } + +-- | build an object file +object :: ModuleName -- ^ the module name + -> Deps -- ^ the dependencies + -> [ObjUnit] -- ^ units, the first unit is the module-global one + -> ByteString -- ^ serialized object +object mname ds units = object' mname symbs ds xs + where + (xs, symbs) = go emptySymbolTable units + go st0 (ObjUnit sy cl si st str fe fi : ys) = + let (st1, bs) = serializeStat st0 cl si st str fe fi + (bss, st2) = go st1 ys + in ((sy,B.fromChunks [bs]):bss, st2) + go st0 [] = ([], st0) + +serializeStat :: SymbolTable + -> [ClosureInfo] + -> [StaticInfo] + -> JStat + -> ShortText + -> [ExpFun] + -> [ForeignJSRef] + -> (SymbolTable, BS.ByteString) +serializeStat st ci si s sraw fe fi = + let (st', bs) = runPutS st $ do + put ci + put si + put s + put sraw + put fe + put fi + bs' = B.toStrict bs + in (st', bs') + +-- tag to store the module name in the object file +moduleNameTag :: ModuleName -> BS.ByteString +moduleNameTag (ModuleName fs) = case compare len moduleNameLength of + EQ -> tag + LT -> tag <> BS.replicate (moduleNameLength - len) 0 -- pad with 0s + GT -> BS.drop (len - moduleNameLength) tag -- take only the ending chars + where + !tag = SBS.fromShort (fs_sbs fs) + !len = n_chars fs + +object' + :: ModuleName -- ^ module + -> SymbolTable -- ^ final symbol table + -> Deps -- ^ dependencies + -> [([ShortText],ByteString)] -- ^ serialized units and their exported symbols, the first unit is module-global + -> ByteString +object' mod_name st0 deps0 os = hdr <> symbs <> deps1 <> idx <> mconcat (map snd os) + where + hdr = putHeader (Header (moduleNameTag mod_name) (bl symbs) (bl deps1) (bl idx)) + bl = fromIntegral . B.length + deps1 = putDepsSection deps0 + (sti, idx) = putIndex st0 os + symbs = putSymbolTable sti + +putIndex :: SymbolTable -> [([ShortText], ByteString)] -> (SymbolTable, ByteString) +putIndex st xs = runPutS st (put $ zip symbols offsets) + where + (symbols, values) = unzip xs + offsets = scanl (+) 0 (map B.length values) + +getIndex :: HasDebugCallStack => String -> SymbolTableR -> ByteString -> [([ShortText], Int64)] +getIndex name st bs = runGetS name st get bs + +putDeps :: SymbolTable -> Deps -> (SymbolTable, ByteString) +putDeps st deps = runPutS st (put deps) + +getDeps :: HasDebugCallStack => String -> SymbolTableR -> ByteString -> Deps +getDeps name st bs = runGetS name st get bs + +toI32 :: Int -> Int32 +toI32 = fromIntegral + +fromI32 :: Int32 -> Int +fromI32 = fromIntegral + +putDepsSection :: Deps -> ByteString +putDepsSection deps = + let (st, depsbs) = putDeps emptySymbolTable deps + stbs = putSymbolTable st + in DB.runPut (DB.putWord32le (fromIntegral $ B.length stbs)) <> stbs <> depsbs + +getDepsSection :: HasDebugCallStack => String -> ByteString -> Deps +getDepsSection name bs = + let symbsLen = fromIntegral $ DB.runGet DB.getWord32le bs + symbs = getSymbolTable (B.drop 4 bs) + in getDeps name symbs (B.drop (4+symbsLen) bs) + +instance Objectable Deps where + put (Deps m r e b) = do + put m + put (map toI32 $ IS.toList r) + put (map (\(x,y) -> (x, toI32 y)) $ M.toList e) + put (elems b) + get = Deps <$> get + <*> (IS.fromList . map fromI32 <$> get) + <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get) + <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get) + +instance Objectable BlockDeps where + put (BlockDeps bbd bfd) = put bbd >> put bfd + get = BlockDeps <$> get <*> get + +instance Objectable ForeignJSRef where + put (ForeignJSRef span pat safety cconv arg_tys res_ty) = + put span >> put pat >> putEnum safety >> putEnum cconv >> put arg_tys >> put res_ty + get = ForeignJSRef <$> get <*> get <*> getEnum <*> getEnum <*> get <*> get + +instance Objectable ExpFun where + put (ExpFun isIO args res) = put isIO >> put args >> put res + get = ExpFun <$> get <*> get <*> get + +-- | reads only the part necessary to get the dependencies +-- so it's potentially more efficient than readDeps <$> B.readFile file +readDepsFile :: FilePath -> IO Deps +readDepsFile file = withBinaryFile file ReadMode (hReadDeps file) + +readDepsFileEither :: FilePath -> IO (Either String Deps) +readDepsFileEither file = withBinaryFile file ReadMode (hReadDepsEither file) + +hReadDeps :: String -> Handle -> IO Deps +hReadDeps name h = do + res <- hReadDepsEither name h + case res of + Left err -> error ("hReadDeps: not a valid GHCJS object: " ++ name ++ "\n " ++ err) + Right deps -> pure deps + +hReadDepsEither :: String -> Handle -> IO (Either String Deps) +hReadDepsEither name h = do + mhdr <- getHeader <$> B.hGet h headerLength + case mhdr of + Left err -> pure (Left err) + Right hdr -> do + hSeek h RelativeSeek (fromIntegral $ hdrSymbsLen hdr) + Right . getDepsSection name <$> B.hGet h (fromIntegral $ hdrDepsLen hdr) + +readDepsEither :: String -> ByteString -> Either String Deps +readDepsEither name bs = + case getHeader bs of + Left err -> Left err + Right hdr -> + let depsStart = fromIntegral headerLength + fromIntegral (hdrSymbsLen hdr) + in Right $ getDepsSection name (B.drop depsStart bs) + + +-- | call with contents of the file +readDeps :: String -> ByteString -> Deps +readDeps name bs = + case readDepsEither name bs of + Left err -> error ("readDeps: not a valid GHCJS object: " ++ name ++ "\n " ++ err) + Right deps -> deps + +readDepsMaybe :: String -> ByteString -> Maybe Deps +readDepsMaybe name bs = either (const Nothing) Just (readDepsEither name bs) + +-- | extract the linkable units from an object file +readObjectFile :: FilePath -> IO [ObjUnit] +readObjectFile = readObjectFileKeys (\_ _ -> True) + +readObjectFileKeys :: (Int -> [ShortText] -> Bool) -> FilePath -> IO [ObjUnit] +readObjectFileKeys p file = bracket (openBinaryFile file ReadMode) hClose $ \h -> do + mhdr <- getHeader <$> B.hGet h headerLength + case mhdr of + Left err -> error ("readObjectFileKeys: not a valid GHCJS object: " ++ file ++ "\n " ++ err) + Right hdr -> do + bss <- B.hGet h (fromIntegral $ hdrSymbsLen hdr) + hSeek h RelativeSeek (fromIntegral $ hdrDepsLen hdr) + bsi <- B.fromStrict <$> BS.hGetContents h + return $ readObjectKeys' file p (getSymbolTable bss) bsi (B.drop (fromIntegral $ hdrIdxLen hdr) bsi) + +readObject :: String -> ByteString -> [ObjUnit] +readObject name = readObjectKeys name (\_ _ -> True) + +readObjectKeys :: HasDebugCallStack => String -> (Int -> [ShortText] -> Bool) -> ByteString -> [ObjUnit] +readObjectKeys name p bs = + case getHeader bs of + Left err -> error ("readObjectKeys: not a valid GHCJS object: " ++ name ++ "\n " ++ err) + Right hdr -> + let bssymbs = B.drop (fromIntegral headerLength) bs + bsidx = B.drop (fromIntegral $ hdrSymbsLen hdr + hdrDepsLen hdr) bssymbs + bsobjs = B.drop (fromIntegral $ hdrIdxLen hdr) bsidx + in readObjectKeys' name p (getSymbolTable bssymbs) bsidx bsobjs + +readObjectKeys' :: HasDebugCallStack + => String + -> (Int -> [ShortText] -> Bool) + -> SymbolTableR + -> ByteString + -> ByteString + -> [ObjUnit] +readObjectKeys' name p st bsidx bsobjs = catMaybes (zipWith readObj [0..] idx) + where + idx = getIndex name st bsidx + readObj n (x,off) + | p n x = let (ci, si, s, sraw, fe, fi) = runGetS name st ((,,,,,) <$> get <*> get <*> get <*> get <*> get <*> get) (B.drop off bsobjs) + in Just (ObjUnit x ci si s sraw fe fi) + | otherwise = Nothing + +getSymbolTable :: HasDebugCallStack => ByteString -> SymbolTableR +getSymbolTable bs = SymbolTableR (listArray (0,n-1) xs) (listArray (0,n-1) (map ST.unpack xs)) + where + (n,xs) = DB.runGet getter bs + getter :: DB.Get (Int, [ShortText]) + getter = do + l <- DB.getWord32le + let l' = fromIntegral l + (l',) <$> replicateM l' DB.get + +putSymbolTable :: SymbolTable -> ByteString +putSymbolTable (SymbolTable _ hm) = st + where + st = DB.runPut $ do + DB.putWord32le (fromIntegral $ length xs) + mapM_ DB.put xs + -- fixme: this is a workaround for some weird issue sometimes causing zero-length + -- strings when using the Data.Text instance directly + -- mapM_ (DB.put . TE.encodeUtf8) xs + xs :: [ShortText] + xs = map fst . sortBy (compare `on` snd) . M.toList $ hm + +headerLength :: Int +headerLength = 32 + versionTagLength + moduleNameLength + +-- human readable version string in object +versionTag :: ByteString +versionTag = B.take 32 . C8.pack $ show hiVersion ++ replicate versionTagLength ' ' + +versionTagLength :: Int +versionTagLength = 32 + +-- last part of the module name, to disambiguate files +moduleNameLength :: Int +moduleNameLength = 128 + +getHeader :: HasDebugCallStack => ByteString -> Either String Header +getHeader bs + | B.length bs < fromIntegral headerLength = Left "not enough input, file truncated?" + | magic /= "GHCJSOBJ" = Left $ "magic number incorrect, not a JavaScript .o file?" + | tag /= versionTag = Left $ "incorrect version, expected " ++ show hiVersion ++ + " but got " ++ (trim . C8.unpack $ tag) + | otherwise = Right (Header mn sl dl il) + where + g = fromIntegral <$> DB.getWord64le + (magic, tag, mn, sl, dl, il) = DB.runGet ((,,,,,) <$> DB.getByteString 8 + <*> DB.getLazyByteString (fromIntegral versionTagLength) + <*> DB.getByteString (fromIntegral moduleNameLength) + <*> g + <*> g + <*> g + ) bs + +putHeader :: Header -> ByteString +putHeader (Header mn sl dl il) = DB.runPut $ do + DB.putByteString "GHCJSOBJ" + DB.putLazyByteString versionTag + DB.putByteString mn + mapM_ (DB.putWord64le . fromIntegral) [sl, dl, il] + +tag :: Word8 -> PutS +tag x = lift (DB.putWord8 x) + +getTag :: GetS Word8 +getTag = lift DB.getWord8 + +instance (Objectable a, Objectable b) => Objectable (a, b) where + put (x, y) = put x >> put y + get = (,) <$> get <*> get + +instance Objectable a => Objectable [a] where + put = putList + get = getList + +instance Objectable Char where + put = lift . DB.putWord32le . fromIntegral . fromEnum + get = toEnum . fromIntegral <$> lift DB.getWord32le + putList = put . ST.pack + getList = do + st <- oeSymbols <$> ask + n <- lift DB.getWord32le + return (strString st ! fromIntegral n) + +putListOf :: (a -> PutS) -> [a] -> PutS +putListOf p xs = do + lift (DB.putWord32le (fromIntegral $ length xs)) + mapM_ p xs + +getListOf :: GetS a -> GetS [a] +getListOf g = do + l <- lift DB.getWord32le + replicateM (fromIntegral l) g + +instance (Ord k, Objectable k, Objectable v) => Objectable (Map k v) where + put = put . M.toList + get = M.fromList <$> get + +instance (Ord a, Objectable a) => Objectable (Set a) where + put = put . S.toList + get = S.fromList <$> get + +instance Objectable Word64 where + put = lift . DB.putWord64le + get = lift DB.getWord64le + +instance Objectable Int64 where + put = lift . DB.putWord64le . fromIntegral + get = fromIntegral <$> lift DB.getWord64le + +instance Objectable Word32 where + put = lift . DB.putWord32le + get = lift DB.getWord32le + +instance Objectable Int32 where + put = lift . DB.putWord32le . fromIntegral + get = fromIntegral <$> lift DB.getWord32le + +instance Objectable a => Objectable (Maybe a) where + put Nothing = tag 1 + put (Just x) = tag 2 >> put x + get = getTag >>= \case + 1 -> pure Nothing + 2 -> Just <$> get + n -> unexpected ("Objectable get Maybe: invalid tag: " ++ show n) + +instance Objectable ShortText where + put t = do + symbols <- St.get + let (symbols', n) = insertSymbol t symbols + St.put symbols' + lift (DB.putWord32le $ fromIntegral n) + get = do + st <- oeSymbols <$> ask + n <- lift DB.getWord32le + return (strText st ! fromIntegral n) + +instance Objectable JStat where + put (DeclStat i) = tag 1 >> put i + put (ReturnStat e) = tag 2 >> put e + put (IfStat e s1 s2) = tag 3 >> put e >> put s1 >> put s2 + put (WhileStat b e s) = tag 4 >> put b >> put e >> put s + put (ForInStat b i e s) = tag 5 >> put b >> put i >> put e >> put s + put (SwitchStat e ss s) = tag 6 >> put e >> put ss >> put s + put (TryStat s1 i s2 s3) = tag 7 >> put s1 >> put i >> put s2 >> put s3 + put (BlockStat xs) = tag 8 >> put xs + put (ApplStat e es) = tag 9 >> put e >> put es + put (UOpStat o e) = tag 10 >> put o >> put e + put (AssignStat e1 e2) = tag 11 >> put e1 >> put e2 + put (UnsatBlock {}) = error "put JStat: UnsatBlock" + put (LabelStat l s) = tag 12 >> put l >> put s + put (BreakStat ml) = tag 13 >> put ml + put (ContinueStat ml) = tag 14 >> put ml + get = getTag >>= \case + 1 -> DeclStat <$> get + 2 -> ReturnStat <$> get + 3 -> IfStat <$> get <*> get <*> get + 4 -> WhileStat <$> get <*> get <*> get + 5 -> ForInStat <$> get <*> get <*> get <*> get + 6 -> SwitchStat <$> get <*> get <*> get + 7 -> TryStat <$> get <*> get <*> get <*> get + 8 -> BlockStat <$> get + 9 -> ApplStat <$> get <*> get + 10 -> UOpStat <$> get <*> get + 11 -> AssignStat <$> get <*> get + 12 -> LabelStat <$> get <*> get + 13 -> BreakStat <$> get + 14 -> ContinueStat <$> get + n -> unexpected ("Objectable get JStat: invalid tag: " ++ show n) + +instance Objectable JExpr where + put (ValExpr v) = tag 1 >> put v + put (SelExpr e i) = tag 2 >> put e >> put i + put (IdxExpr e1 e2) = tag 3 >> put e1 >> put e2 + put (InfixExpr o e1 e2) = tag 4 >> put o >> put e1 >> put e2 + put (UOpExpr o e) = tag 5 >> put o >> put e + put (IfExpr e1 e2 e3) = tag 6 >> put e1 >> put e2 >> put e3 + put (ApplExpr e es) = tag 7 >> put e >> put es + put (UnsatExpr {}) = error "put JExpr: UnsatExpr" + get = getTag >>= \case + 1 -> ValExpr <$> get + 2 -> SelExpr <$> get <*> get + 3 -> IdxExpr <$> get <*> get + 4 -> InfixExpr <$> get <*> get <*> get + 5 -> UOpExpr <$> get <*> get + 6 -> IfExpr <$> get <*> get <*> get + 7 -> ApplExpr <$> get <*> get + n -> unexpected ("Objectable get JExpr: invalid tag: " ++ show n) + +instance Objectable JVal where + put (JVar i) = tag 1 >> put i + put (JList es) = tag 2 >> put es + put (JDouble d) = tag 3 >> put d + put (JInt i) = tag 4 >> put i + put (JStr xs) = tag 5 >> put xs + put (JRegEx xs) = tag 6 >> put xs + put (JHash m) = tag 7 >> put (M.toList m) + put (JFunc is s) = tag 8 >> put is >> put s + put (UnsatVal {}) = error "put JVal: UnsatVal" + get = getTag >>= \case + 1 -> JVar <$> get + 2 -> JList <$> get + 3 -> JDouble <$> get + 4 -> JInt <$> get + 5 -> JStr <$> get + 6 -> JRegEx <$> get + 7 -> JHash . M.fromList <$> get + 8 -> JFunc <$> get <*> get + n -> unexpected ("Objectable get JVal: invalid tag: " ++ show n) + +instance Objectable Ident where + put (TxtI xs) = put xs + get = TxtI <$> get + +instance Objectable Integer where + put = lift . DB.put + get = lift DB.get + +-- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this +instance Objectable SaneDouble where + put (SaneDouble d) + | isNaN d = tag 1 + | isInfinite d && d > 0 = tag 2 + | isInfinite d && d < 0 = tag 3 + | isNegativeZero d = tag 4 + | otherwise = tag 5 >> lift (DB.put d) + get = getTag >>= \case + 1 -> pure $ SaneDouble (0 / 0) + 2 -> pure $ SaneDouble (1 / 0) + 3 -> pure $ SaneDouble ((-1) / 0) + 4 -> pure $ SaneDouble (-0) + 5 -> SaneDouble <$> lift DB.get + n -> unexpected ("Objectable get SaneDouble: invalid tag: " ++ show n) + +instance Objectable ClosureInfo where + put (ClosureInfo v regs name layo typ static) = do + put v >> put regs >> put name >> put layo >> put typ >> put static + get = ClosureInfo <$> get <*> get <*> get <*> get <*> get <*> get + +instance Objectable JSFFIType where + put = putEnum + get = getEnum + +instance Objectable VarType where + put = putEnum + get = getEnum + +instance Objectable CIRegs where + put CIRegsUnknown = tag 1 + put (CIRegs skip types) = tag 2 >> putIW16 skip >> put types + get = getTag >>= \case + 1 -> pure CIRegsUnknown + 2 -> CIRegs <$> getIW16 <*> get + n -> unexpected ("Objectable get CIRegs: invalid tag: " ++ show n) + +instance Objectable JOp where + put = putEnum + get = getEnum + +instance Objectable JUOp where + put = putEnum + get = getEnum + +-- 16 bit sizes should be enough... +instance Objectable CILayout where + put CILayoutVariable = tag 1 + put (CILayoutUnknown size) = tag 2 >> putIW16 size + put (CILayoutFixed size types) = tag 3 >> putIW16 size >> put types + get = getTag >>= \case + 1 -> pure CILayoutVariable + 2 -> CILayoutUnknown <$> getIW16 + 3 -> CILayoutFixed <$> getIW16 <*> get + n -> unexpected ("Objectable get CILayout: invalid tag: " ++ show n) + +instance Objectable CIStatic where + put (CIStaticRefs refs) = tag 1 >> put refs + get = getTag >>= \case + 1 -> CIStaticRefs <$> get + n -> unexpected ("Objectable get CIStatic: invalid tag: " ++ show n) + +instance Objectable CIType where + put (CIFun arity regs) = tag 1 >> putIW16 arity >> putIW16 regs + put CIThunk = tag 2 + put (CICon conTag) = tag 3 >> putIW16 conTag + put CIPap = tag 4 + put CIBlackhole = tag 5 + put CIStackFrame = tag 6 + get = getTag >>= \case + 1 -> CIFun <$> getIW16 <*> getIW16 + 2 -> pure CIThunk + 3 -> CICon <$> getIW16 + 4 -> pure CIPap + 5 -> pure CIBlackhole + 6 -> pure CIStackFrame + n -> unexpected ("Objectable get CIType: invalid tag: " ++ show n) + +-- put an Int as a Word16, little endian. useful for many small values +putIW16 :: Int -> PutS +putIW16 i | i > 65535 || i < 0 = error ("putIW16: out of range: " ++ show i) + | otherwise = lift $ DB.putWord16le (fromIntegral i) + +getIW16 :: GetS Int +getIW16 = lift (fmap fromIntegral DB.getWord16le) + +-- the binary instance stores ints as 64 bit +instance Objectable Int where + put = lift . DB.put + get = lift DB.get + +instance Objectable ExportedFun where + put (ExportedFun modu symb) = put modu >> put symb + get = ExportedFun <$> get <*> get + +instance Objectable Module where + put (Module unit mod_name) = put unit >> put mod_name + get = Module <$> get <*> get + +instance Objectable ModuleName where + put (ModuleName fs) = put fs + get = ModuleName <$> get + +instance Objectable Unit where + put = \case + RealUnit (Definite uid) -> tag 0 >> put uid + VirtUnit uid -> tag 1 >> put uid + HoleUnit -> tag 2 + get = getTag >>= \case + 0 -> (RealUnit . Definite) <$> get + 1 -> VirtUnit <$> get + _ -> pure HoleUnit + +instance Objectable FastString where + put fs = put (unpackFS fs) + get = mkFastString <$> get + +instance Objectable UnitId where + put (UnitId fs) = put fs + get = UnitId <$> get + +instance Objectable InstantiatedUnit where + put indef = do + put (instUnitInstanceOf indef) + put (instUnitInsts indef) + get = mkInstantiatedUnitSorted <$> get <*> get + +putEnum :: Enum a => a -> PutS +putEnum x | n > 65535 = error ("putEnum: out of range: " ++ show n) + | otherwise = putIW16 n + where n = fromEnum x + +getEnum :: Enum a => GetS a +getEnum = toEnum <$> getIW16 + +instance Objectable Bool where + put False = tag 1 + put True = tag 2 + get = getTag >>= \case + 1 -> return False + 2 -> return True + n -> unexpected ("Objectable get Bool: invalid tag: " ++ show n) + +instance Objectable StaticInfo where + put (StaticInfo ident val cc) = put ident >> put val >> put cc + get = StaticInfo <$> get <*> get <*> get + +instance Objectable StaticVal where + put (StaticFun f args) = tag 1 >> put f >> put args + put (StaticThunk t) = tag 2 >> put t + put (StaticUnboxed u) = tag 3 >> put u + put (StaticData dc args) = tag 4 >> put dc >> put args + put (StaticList xs t) = tag 5 >> put xs >> put t + get = getTag >>= \case + 1 -> StaticFun <$> get <*> get + 2 -> StaticThunk <$> get + 3 -> StaticUnboxed <$> get + 4 -> StaticData <$> get <*> get + 5 -> StaticList <$> get <*> get + n -> unexpected ("Objectable get StaticVal: invalid tag " ++ show n) + +instance Objectable StaticUnboxed where + put (StaticUnboxedBool b) = tag 1 >> put b + put (StaticUnboxedInt i) = tag 2 >> put i + put (StaticUnboxedDouble d) = tag 3 >> put d + put (StaticUnboxedString str) = tag 4 >> put str + put (StaticUnboxedStringOffset str) = tag 5 >> put str + get = getTag >>= \case + 1 -> StaticUnboxedBool <$> get + 2 -> StaticUnboxedInt <$> get + 3 -> StaticUnboxedDouble <$> get + 4 -> StaticUnboxedString <$> get + 5 -> StaticUnboxedStringOffset <$> get + n -> unexpected ("Objectable get StaticUnboxed: invalid tag " ++ show n) + +instance Objectable StaticArg where + put (StaticObjArg i) = tag 1 >> put i + put (StaticLitArg p) = tag 2 >> put p + put (StaticConArg c args) = tag 3 >> put c >> put args + get = getTag >>= \case + 1 -> StaticObjArg <$> get + 2 -> StaticLitArg <$> get + 3 -> StaticConArg <$> get <*> get + n -> unexpected ("Objectable get StaticArg: invalid tag " ++ show n) + +instance Objectable StaticLit where + put (BoolLit b) = tag 1 >> put b + put (IntLit i) = tag 2 >> put i + put NullLit = tag 3 + put (DoubleLit d) = tag 4 >> put d + put (StringLit t) = tag 5 >> put t + put (BinLit b) = tag 6 >> put b + put (LabelLit b t) = tag 7 >> put b >> put t + get = getTag >>= \case + 1 -> BoolLit <$> get + 2 -> IntLit <$> get + 3 -> pure NullLit + 4 -> DoubleLit <$> get + 5 -> StringLit <$> get + 6 -> BinLit <$> get + 7 -> LabelLit <$> get <*> get + n -> unexpected ("Objectable get StaticLit: invalid tag " ++ show n) + +instance Objectable BS.ByteString where + put = lift . DB.put + get = lift DB.get diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs new file mode 100644 index 0000000000..8e958e59ae --- /dev/null +++ b/compiler/GHC/StgToJS/Prim.hs @@ -0,0 +1,1024 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} + +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.Data.ShortText (ShortText) +import qualified GHC.Data.ShortText as ST +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) +import Data.Maybe + + +genPrim :: Bool -- ^ Profiling (cost-centres) enabled + -> Type + -> PrimOp -- ^ the primitive operation + -> [JExpr] -- ^ where to store the result + -> [JExpr] -- ^ arguments + -> PrimRes +genPrim _ _ CharGtOp [r] [x,y] = PrimInline $ r |= if10 (x .>. y) +genPrim _ _ CharGeOp [r] [x,y] = PrimInline $ r |= if10 (x .>=. y) +genPrim _ _ CharEqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ CharNeOp [r] [x,y] = PrimInline $ r |= if10 (x .!==. y) +genPrim _ _ CharLtOp [r] [x,y] = PrimInline $ r |= if10 (x .<. y) +genPrim _ _ CharLeOp [r] [x,y] = PrimInline $ r |= if10 (x .<=. y) +genPrim _ _ OrdOp [r] [x] = PrimInline $ r |= x + +genPrim _ _ IntAddOp [r] [x,y] = PrimInline $ r |= trunc (Add x y) +genPrim _ _ IntSubOp [r] [x,y] = PrimInline $ r |= trunc (Sub x y) +genPrim _ _ IntMulOp [r] [x,y] = + PrimInline $ r |= app "h$mulInt32" [x, y] +-- fixme may will give the wrong result in case of overflow +genPrim _ _ IntMulMayOfloOp [r] [x,y] = + PrimInline $ jVar \tmp -> mconcat + [ tmp |= Mul x y + , r |= if01 (tmp .===. trunc tmp) + ] +genPrim _ _ IntQuotOp [r] [x,y] = PrimInline $ r |= trunc (Div x y) +genPrim _ _ IntRemOp [r] [x,y] = PrimInline $ r |= Mod x y +genPrim _ _ IntQuotRemOp [q,r] [x,y] = PrimInline $ mconcat + [ q |= trunc (Div x y) + , r |= x `Sub` (Mul y q) + ] +genPrim _ _ IntAndOp [r] [x,y] = PrimInline $ r |= BAnd x y +genPrim _ _ IntOrOp [r] [x,y] = PrimInline $ r |= BOr x y +genPrim _ _ IntXorOp [r] [x,y] = PrimInline $ r |= BXor x y +genPrim _ _ IntNotOp [r] [x] = PrimInline $ r |= BNot x + +genPrim _ _ IntNegOp [r] [x] = PrimInline $ r |= trunc (Negate x) +-- add with carry: overflow == 0 iff no overflow +genPrim _ _ IntAddCOp [r,overf] [x,y] = + PrimInline $ jVar \rt -> mconcat + [ rt |= Add x y + , r |= trunc rt + , overf |= if10 (r .!=. rt) + ] +genPrim _ _ IntSubCOp [r,overf] [x,y] = + PrimInline $ jVar \rt -> mconcat + [ rt |= Sub x y + , r |= trunc rt + , overf |= if10 (r .!=. rt) + ] +genPrim _ _ IntGtOp [r] [x,y] = PrimInline $ r |= if10 (x .>. y) +genPrim _ _ IntGeOp [r] [x,y] = PrimInline $ r |= if10 (x .>=. y) +genPrim _ _ IntEqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ IntNeOp [r] [x,y] = PrimInline $ r |= if10(x .!==. y) +genPrim _ _ IntLtOp [r] [x,y] = PrimInline $ r |= if10 (x .<. y) +genPrim _ _ IntLeOp [r] [x,y] = PrimInline $ r |= if10 (x .<=. y) +genPrim _ _ ChrOp [r] [x] = PrimInline $ r |= x +genPrim _ _ IntToWordOp [r] [x] = PrimInline $ r |= x +genPrim _ _ IntToFloatOp [r] [x] = PrimInline $ r |= x +genPrim _ _ IntToDoubleOp [r] [x] = PrimInline $ r |= x +genPrim _ _ IntSllOp [r] [x,y] = PrimInline $ r |= x .<<. y +genPrim _ _ IntSraOp [r] [x,y] = PrimInline $ r |= x .>>. y +genPrim _ _ IntSrlOp [r] [x,y] = PrimInline $ r |= trunc (x .>>>. y) + +genPrim _ _ Int8ToIntOp [r] [x] = PrimInline $ r |= mask8 x +genPrim _ _ IntToInt8Op [r] [x] = PrimInline $ r |= mask8 x -- fixme +genPrim _ _ Int8NegOp [r] [x] = PrimInline $ r |= mask8 (Sub (Int 0x100) x) +genPrim _ _ Int8AddOp [r] [x,y] = PrimInline $ r |= mask8 (Add x y) +genPrim _ _ Int8SubOp [r] [x,y] = PrimInline $ r |= mask8 (Sub x y) +genPrim _ _ Int8MulOp [r] [x,y] = PrimInline $ r |= mask8 (Mul x y) +genPrim _ _ Int8QuotOp [r] [x,y] = PrimInline $ r |= quotShortInt 8 x y +genPrim _ _ Int8RemOp [r] [x,y] = PrimInline $ r |= remShortInt 8 x y +genPrim _ _ Int8QuotRemOp [r1,r2] [x,y] = PrimInline $ mconcat + [ r1 |= quotShortInt 8 x y + , r2 |= remShortInt 8 x y + ] +genPrim _ _ Int8EqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ Int8GeOp [r] [x,y] = PrimInline $ r |= if10 ((x .<<. (Int 24)) .>=. (y .<<. (Int 24))) +genPrim _ _ Int8GtOp [r] [x,y] = PrimInline $ r |= if10 ((x .<<. (Int 24)) .>. (y .<<. (Int 24))) +genPrim _ _ Int8LeOp [r] [x,y] = PrimInline $ r |= if10 ((x .<<. (Int 24)) .<=. (y .<<. (Int 24))) +genPrim _ _ Int8LtOp [r] [x,y] = PrimInline $ r |= if10 ((x .<<. (Int 24)) .<. (y .<<. (Int 24))) +genPrim _ _ Int8NeOp [r] [x,y] = PrimInline $ r |= if10 (x .!==. y) + +genPrim _ _ Word8ToWordOp [r] [x] = PrimInline $ r |= mask8 x +genPrim _ _ WordToWord8Op [r] [x] = PrimInline $ r |= mask8 x +genPrim _ _ Word8NotOp [r] [x] = PrimInline $ r |= BXor x (Int 0xff) +genPrim _ _ Word8AddOp [r] [x,y] = PrimInline $ r |= mask8 (Add x y) +genPrim _ _ Word8SubOp [r] [x,y] = PrimInline $ r |= mask8 (Sub x y) +genPrim _ _ Word8MulOp [r] [x,y] = PrimInline $ r |= mask8 (Mul x y) +genPrim _ _ Word8QuotOp [r] [x,y] = PrimInline $ r |= trunc (Div x y) +genPrim _ _ Word8RemOp [r] [x,y] = PrimInline $ r |= Mod x y +genPrim _ _ Word8QuotRemOp [r1,r2] [x,y] = PrimInline $ mconcat + [ r1 |= trunc (Div x y) + , r2 |= Mod x y + ] +genPrim _ _ Word8EqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ Word8GeOp [r] [x,y] = PrimInline $ r |= if10 (x .>=. y) +genPrim _ _ Word8GtOp [r] [x,y] = PrimInline $ r |= if10 (x .>. y) +genPrim _ _ Word8LeOp [r] [x,y] = PrimInline $ r |= if10 (x .<=. y) +genPrim _ _ Word8LtOp [r] [x,y] = PrimInline $ r |= if10 (x .<. y) +genPrim _ _ Word8NeOp [r] [x,y] = PrimInline $ r |= if10 (x .!==. y) + +genPrim _ _ Int16ToIntOp [r] [x] = PrimInline $ r |= mask16 x +genPrim _ _ IntToInt16Op [r] [x] = PrimInline $ r |= mask16 x -- fixme ? +genPrim _ _ Int16NegOp [r] [x] = PrimInline $ r |= mask16 (Sub (Int 0x10000) x) +genPrim _ _ Int16AddOp [r] [x,y] = PrimInline $ r |= mask16 (Add x y) +genPrim _ _ Int16SubOp [r] [x,y] = PrimInline $ r |= mask16 (Sub x y) +genPrim _ _ Int16MulOp [r] [x,y] = PrimInline $ r |= mask16 (Mul x y) +genPrim _ _ Int16QuotOp [r] [x,y] = PrimInline $ r |= quotShortInt 16 x y +genPrim _ _ Int16RemOp [r] [x,y] = PrimInline $ r |= remShortInt 16 x y +genPrim _ _ Int16QuotRemOp [r1,r2] [x,y] = PrimInline $ mconcat + [ r1 |= quotShortInt 16 x y + , r2 |= remShortInt 16 x y + ] +genPrim _ _ Int16EqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ Int16GeOp [r] [x,y] = PrimInline $ r |= if10 ((x .<<. (Int 16)) .>=. (y .<<. (Int 16))) +genPrim _ _ Int16GtOp [r] [x,y] = PrimInline $ r |= if10 ((x .<<. (Int 16)) .>. (y .<<. (Int 16))) +genPrim _ _ Int16LeOp [r] [x,y] = PrimInline $ r |= if10 ((x .<<. (Int 16)) .<=. (y .<<. (Int 16))) +genPrim _ _ Int16LtOp [r] [x,y] = PrimInline $ r |= if10 ((x .<<. (Int 16)) .<. (y .<<. (Int 16))) +genPrim _ _ Int16NeOp [r] [x,y] = PrimInline $ r |= if10 (x .!==. y) + +genPrim _ _ Word16ToWordOp [r] [x] = PrimInline $ r |= mask16 x +genPrim _ _ WordToWord16Op [r] [x] = PrimInline $ r |= mask16 x +genPrim _ _ Word16NotOp [r] [x] = PrimInline $ r |= BXor x (Int 0xffff) +genPrim _ _ Word16AddOp [r] [x,y] = PrimInline $ r |= mask16 (Add x y) +genPrim _ _ Word16SubOp [r] [x,y] = PrimInline $ r |= mask16 (Sub x y) +genPrim _ _ Word16MulOp [r] [x,y] = PrimInline $ r |= mask16 (Mul x y) +genPrim _ _ Word16QuotOp [r] [x,y] = PrimInline $ r |= trunc (Div x y) +genPrim _ _ Word16RemOp [r] [x,y] = PrimInline $ r |= Mod x y +genPrim _ _ Word16QuotRemOp [r1,r2] [x,y] = PrimInline $ mconcat + [ r1 |= trunc (Div x y) + , r2 |= Mod x y + ] +genPrim _ _ Word16EqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ Word16GeOp [r] [x,y] = PrimInline $ r |= if10 (x .>=. y) +genPrim _ _ Word16GtOp [r] [x,y] = PrimInline $ r |= if10 (x .>. y) +genPrim _ _ Word16LeOp [r] [x,y] = PrimInline $ r |= if10 (x .<=. y) +genPrim _ _ Word16LtOp [r] [x,y] = PrimInline $ r |= if10 (x .<. y) +genPrim _ _ Word16NeOp [r] [x,y] = PrimInline $ r |= if10 (x .!==. y) + +genPrim _ _ WordAddOp [r] [x,y] = PrimInline $ r |= trunc (x `Add` y) +genPrim _ _ WordAddCOp [r,c] [x,y] = PrimInline $ + jVar \t -> mconcat + [ t |= (x .>>>. zero_) `Add` (y .>>>. zero_) + , r |= trunc t + , c |= if10 (t .>. Int 4294967295) + ] +genPrim _ _ WordSubCOp [r,c] [x,y] = + PrimInline $ mconcat + [ r |= trunc (Sub x y) + , c |= if10 ((y .>>>. zero_) .>. (x .>>>. zero_)) + ] +genPrim _ _ WordAdd2Op [h,l] [x,y] = PrimInline $ appT [h,l] "h$wordAdd2" [x,y] +genPrim _ _ WordSubOp [r] [x,y] = PrimInline $ r |= trunc (Sub x y) +genPrim _ _ WordMulOp [r] [x,y] = PrimInline $ r |= app "h$mulWord32" [x, y] +genPrim _ _ WordMul2Op [h,l] [x,y] = PrimInline $ appT [h,l] "h$mul2Word32" [x,y] +genPrim _ _ WordQuotOp [q] [x,y] = PrimInline $ q |= app "h$quotWord32" [x,y] +genPrim _ _ WordRemOp [r] [x,y] = PrimInline $ r |= app "h$remWord32" [x,y] +genPrim _ _ WordQuotRemOp [q,r] [x,y] = PrimInline $ mconcat + [ q |= app "h$quotWord32" [x,y] + , r |= app "h$remWord32" [x,y] + ] +genPrim _ _ WordQuotRem2Op [q,r] [xh,xl,y] = PrimInline $ appT [q,r] "h$quotRem2Word32" [xh,xl,y] +genPrim _ _ WordAndOp [r] [x,y] = PrimInline $ r |= BAnd x y +genPrim _ _ WordOrOp [r] [x,y] = PrimInline $ r |= BOr x y +genPrim _ _ WordXorOp [r] [x,y] = PrimInline $ r |= BXor x y +genPrim _ _ WordNotOp [r] [x] = PrimInline $ r |= BNot x +genPrim _ _ WordSllOp [r] [x,y] = PrimInline $ r |= x .<<. y +genPrim _ _ WordSrlOp [r] [x,y] = PrimInline $ r |= trunc (x .>>>. y) +genPrim _ _ WordToIntOp [r] [x] = PrimInline $ r |= x +genPrim _ _ WordGtOp [r] [x,y] = + PrimInline $ r |= if10 ((x .>>>. zero_) .>. (y .>>>. zero_)) +genPrim _ _ WordGeOp [r] [x,y] = + PrimInline $ r |= if10 ((x .>>>. zero_) .>=. (y .>>>. zero_)) +genPrim _ _ WordEqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ WordNeOp [r] [x,y] = PrimInline $ r |= if10 (x .!==. y) +genPrim _ _ WordLtOp [r] [x,y] = + PrimInline $ r |= if10 ((x .>>>. zero_) .<. (y .>>>. zero_)) +genPrim _ _ WordLeOp [r] [x,y] = + PrimInline $ r |= if10 ((x .>>>. zero_) .<=. (y .>>>. zero_)) +genPrim _ _ WordToDoubleOp [r] [x] = PrimInline $ r |= (Add (BAnd x (Int 0x7FFFFFFF)) (x .>>>. (Int 31))) `Mul` Int 2147483648 +genPrim _ _ WordToFloatOp [r] [x] = PrimInline $ r |= (Add (BAnd x (Int 0x7FFFFFFF)) (x .>>>. (Int 31))) `Mul` Int 2147483648 +genPrim _ _ PopCnt8Op [r] [x] = PrimInline $ r |= var "h$popCntTab" .! (mask8 x) +genPrim _ _ PopCnt16Op [r] [x] = + PrimInline $ r |= Add (var "h$popCntTab" .! (mask8 x)) + (var "h$popCntTab" .! (mask8 (x .>>>. Int 8))) + +genPrim _ _ PopCnt32Op [r] [x] = PrimInline $ r |= app "h$popCnt32" [x] +genPrim _ _ PopCnt64Op [r] [x1,x2] = PrimInline $ r |= app "h$popCnt64" [x1,x2] +genPrim d t PopCntOp [r] [x] = genPrim d t PopCnt32Op [r] [x] +genPrim _ _ Pdep8Op [r] [s,m] = PrimInline $ r |= app "h$pdep8" [s,m] +genPrim _ _ Pdep16Op [r] [s,m] = PrimInline $ r |= app "h$pdep16" [s,m] +genPrim _ _ Pdep32Op [r] [s,m] = PrimInline $ r |= app "h$pdep32" [s,m] +genPrim _ _ Pdep64Op [ra,rb] [sa,sb,ma,mb] = PrimInline $ appT [ra,rb] "h$pdep64" [sa,sb,ma,mb] +genPrim d t PdepOp rs xs = genPrim d t Pdep32Op rs xs +genPrim _ _ Pext8Op [r] [s,m] = PrimInline $ r |= app "h$pext8" [s,m] +genPrim _ _ Pext16Op [r] [s,m] = PrimInline $ r |= app "h$pext16" [s,m] +genPrim _ _ Pext32Op [r] [s,m] = PrimInline $ r |= app "h$pext32" [s,m] +genPrim _ _ Pext64Op [ra,rb] [sa,sb,ma,mb] = PrimInline $ + appT [ra,rb] "h$pext64" [sa,sb,ma,mb] +genPrim d t PextOp rs xs = genPrim d t Pext32Op rs xs + +genPrim _ _ ClzOp [r] [x] = PrimInline $ r |= app "h$clz32" [x] +genPrim _ _ Clz8Op [r] [x] = PrimInline $ r |= app "h$clz8" [x] +genPrim _ _ Clz16Op [r] [x] = PrimInline $ r |= app "h$clz16" [x] +genPrim _ _ Clz32Op [r] [x] = PrimInline $ r |= app "h$clz32" [x] +genPrim _ _ Clz64Op [r] [x1,x2] = PrimInline $ r |= app "h$clz64" [x1,x2] + +genPrim _ _ CtzOp [r] [x] = PrimInline $ r |= app "h$ctz32" [x] +genPrim _ _ Ctz8Op [r] [x] = PrimInline $ r |= app "h$ctz8" [x] +genPrim _ _ Ctz16Op [r] [x] = PrimInline $ r |= app "h$ctz16" [x] +genPrim _ _ Ctz32Op [r] [x] = PrimInline $ r |= app "h$ctz32" [x] +genPrim _ _ Ctz64Op [r] [x1,x2] = PrimInline $ r |= app "h$ctz64" [x1,x2] + +genPrim _ _ BSwap16Op [r] [x] = PrimInline $ + r |= BOr ((mask8 x) .<<. (Int 8)) + (mask8 (x .>>>. (Int 8))) +genPrim _ _ BSwap32Op [r] [x] = PrimInline $ + r |= (x .<<. (Int 24)) + `BOr` ((BAnd x (Int 0xFF00)) .<<. (Int 8)) + `BOr` ((BAnd x (Int 0xFF0000)) .>>. (Int 8)) + `BOr` (x .>>>. (Int 24)) +genPrim _ _ BSwap64Op [r1,r2] [x,y] = PrimInline $ + appT [r1,r2] "h$bswap64" [x,y] +genPrim d t BSwapOp [r] [x] = genPrim d t BSwap32Op [r] [x] + +genPrim _ _ Narrow8IntOp [r] [x] = PrimInline $ r |= (BAnd x (Int 0x7F)) `Sub` (BAnd x (Int 0x80)) +genPrim _ _ Narrow16IntOp [r] [x] = PrimInline $ r |= (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000)) +genPrim _ _ Narrow32IntOp [r] [x] = PrimInline $ r |= trunc x +genPrim _ _ Narrow8WordOp [r] [x] = PrimInline $ r |= mask8 x +genPrim _ _ Narrow16WordOp [r] [x] = PrimInline $ r |= mask16 x +genPrim _ _ Narrow32WordOp [r] [x] = PrimInline $ r |= trunc x + +genPrim _ _ DoubleGtOp [r] [x,y] = PrimInline $ r |= if10 (x .>. y) +genPrim _ _ DoubleGeOp [r] [x,y] = PrimInline $ r |= if10 (x .>=. y) +genPrim _ _ DoubleEqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ DoubleNeOp [r] [x,y] = PrimInline $ r |= if10 (x .!==. y) +genPrim _ _ DoubleLtOp [r] [x,y] = PrimInline $ r |= if10 (x .<. y) +genPrim _ _ DoubleLeOp [r] [x,y] = PrimInline $ r |= if10 (x .<=. y) +genPrim _ _ DoubleAddOp [r] [x,y] = PrimInline $ r |= Add x y +genPrim _ _ DoubleSubOp [r] [x,y] = PrimInline $ r |= Sub x y +genPrim _ _ DoubleMulOp [r] [x,y] = PrimInline $ r |= Mul x y +genPrim _ _ DoubleDivOp [r] [x,y] = PrimInline $ r |= Div x y +genPrim _ _ DoubleNegOp [r] [x] = PrimInline $ r |= Negate x +genPrim _ _ DoubleFabsOp [r] [x] = PrimInline $ r |= math_abs [x] +genPrim _ _ DoubleToIntOp [r] [x] = PrimInline $ r |= trunc x +genPrim _ _ DoubleToFloatOp [r] [x] = PrimInline $ r |= app "h$fround" [x] +genPrim _ _ DoubleExpOp [r] [x] = PrimInline $ r |= math_exp [x] +genPrim _ _ DoubleLogOp [r] [x] = PrimInline $ r |= math_log [x] +genPrim _ _ DoubleSqrtOp [r] [x] = PrimInline $ r |= math_sqrt [x] +genPrim _ _ DoubleSinOp [r] [x] = PrimInline $ r |= math_sin [x] +genPrim _ _ DoubleCosOp [r] [x] = PrimInline $ r |= math_cos [x] +genPrim _ _ DoubleTanOp [r] [x] = PrimInline $ r |= math_tan [x] +genPrim _ _ DoubleAsinOp [r] [x] = PrimInline $ r |= math_asin [x] +genPrim _ _ DoubleAcosOp [r] [x] = PrimInline $ r |= math_acos [x] +genPrim _ _ DoubleAtanOp [r] [x] = PrimInline $ r |= math_atan [x] +genPrim _ _ DoubleSinhOp [r] [x] = PrimInline $ r |= (math_exp [x] `Sub` math_exp [Negate x]) `Div` two_ +genPrim _ _ DoubleCoshOp [r] [x] = PrimInline $ r |= (math_exp [x] `Add` math_exp [Negate x]) `Div` two_ +genPrim _ _ DoubleTanhOp [r] [x] = PrimInline $ r |= (math_exp [Mul two_ x] `Sub` one_) `Div` (math_exp [Mul two_ x] `Add` one_) +genPrim _ _ DoubleAsinhOp [r] [x] = PrimInline $ r |= math_asinh [x] +genPrim _ _ DoubleAcoshOp [r] [x] = PrimInline $ r |= math_acosh [x] +genPrim _ _ DoubleAtanhOp [r] [x] = PrimInline $ r |= math_atanh [x] +genPrim _ _ DoublePowerOp [r] [x,y] = PrimInline $ r |= math_pow [x,y] +genPrim _ _ DoubleDecode_2IntOp [s,h,l,e] [x] = PrimInline $ appT [s,h,l,e] "h$decodeDouble2Int" [x] +genPrim _ _ DoubleDecode_Int64Op [s1,s2,e] [d] = + PrimInline $ appT [e,s1,s2] "h$decodeDoubleInt64" [d] + +genPrim _ _ FloatGtOp [r] [x,y] = PrimInline $ r |= if10 (x .>. y) +genPrim _ _ FloatGeOp [r] [x,y] = PrimInline $ r |= if10 (x .>=. y) +genPrim _ _ FloatEqOp [r] [x,y] = PrimInline $ r |= if10 (x .===. y) +genPrim _ _ FloatNeOp [r] [x,y] = PrimInline $ r |= if10 (x .!==. y) +genPrim _ _ FloatLtOp [r] [x,y] = PrimInline $ r |= if10 (x .<. y) +genPrim _ _ FloatLeOp [r] [x,y] = PrimInline $ r |= if10 (x .<=. y) +genPrim _ _ FloatAddOp [r] [x,y] = PrimInline $ r |= Add x y +genPrim _ _ FloatSubOp [r] [x,y] = PrimInline $ r |= Sub x y +genPrim _ _ FloatMulOp [r] [x,y] = PrimInline $ r |= Mul x y +genPrim _ _ FloatDivOp [r] [x,y] = PrimInline $ r |= Div x y +genPrim _ _ FloatNegOp [r] [x] = PrimInline $ r |= Negate x +genPrim _ _ FloatFabsOp [r] [x] = PrimInline $ r |= math_abs [x] +genPrim _ _ FloatToIntOp [r] [x] = PrimInline $ r |= trunc x +genPrim _ _ FloatExpOp [r] [x] = PrimInline $ r |= math_exp [x] +genPrim _ _ FloatLogOp [r] [x] = PrimInline $ r |= math_log [x] +genPrim _ _ FloatSqrtOp [r] [x] = PrimInline $ r |= math_sqrt [x] +genPrim _ _ FloatSinOp [r] [x] = PrimInline $ r |= math_sin [x] +genPrim _ _ FloatCosOp [r] [x] = PrimInline $ r |= math_cos [x] +genPrim _ _ FloatTanOp [r] [x] = PrimInline $ r |= math_tan [x] +genPrim _ _ FloatAsinOp [r] [x] = PrimInline $ r |= math_asin [x] +genPrim _ _ FloatAcosOp [r] [x] = PrimInline $ r |= math_acos [x] +genPrim _ _ FloatAtanOp [r] [x] = PrimInline $ r |= math_atan [x] +genPrim _ _ FloatSinhOp [r] [x] = PrimInline $ r |= (math_exp [x] `Sub` math_exp [Negate x]) `Div` two_ +genPrim _ _ FloatCoshOp [r] [x] = PrimInline $ r |= (math_exp [x] `Add` math_exp [Negate x]) `Div` two_ +genPrim _ _ FloatTanhOp [r] [x] = PrimInline $ r |= (math_exp [Mul two_ x] `Sub` one_) `Div` (math_exp [Mul two_ x] `Add` one_) +genPrim _ _ FloatAsinhOp [r] [x] = PrimInline $ r |= math_asinh [x] +genPrim _ _ FloatAcoshOp [r] [x] = PrimInline $ r |= math_acosh [x] +genPrim _ _ FloatAtanhOp [r] [x] = PrimInline $ r |= math_atanh [x] +genPrim _ _ FloatPowerOp [r] [x,y] = PrimInline $ r |= math_pow [x,y] +genPrim _ _ FloatToDoubleOp [r] [x] = PrimInline $ r |= x +genPrim _ _ FloatDecode_IntOp [s,e] [x] = PrimInline $ appT [s,e] "h$decodeFloatInt" [x] + +-- Arrays + +genPrim _ _ NewArrayOp [r] [l,e] = PrimInline (newArray r l e) +genPrim _ _ ReadArrayOp [r] [a,i] = PrimInline $ r |= a .! i +genPrim _ _ WriteArrayOp [] [a,i,v] = PrimInline $ a .! i |= v +genPrim _ _ SizeofArrayOp [r] [a] = PrimInline $ r |= a .^ "length" +genPrim _ _ SizeofMutableArrayOp [r] [a] = PrimInline $ r |= a .^ "length" +genPrim _ _ IndexArrayOp [r] [a,i] = PrimInline $ r |= a .! i +genPrim _ _ UnsafeFreezeArrayOp [r] [a] = PrimInline $ r |= a +genPrim _ _ UnsafeThawArrayOp [r] [a] = PrimInline $ r |= a +genPrim _ _ CopyArrayOp [] [a,o1,ma,o2,n] = + PrimInline $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] +genPrim d t CopyMutableArrayOp [] [a1,o1,a2,o2,n] = genPrim d t CopyArrayOp [] [a1,o1,a2,o2,n] +genPrim _ _ CloneArrayOp [r] [a,start,n] = PrimInline $ r |= app "h$sliceArray" [a,start,n] +genPrim d t CloneMutableArrayOp [r] [a,start,n] = genPrim d t CloneArrayOp [r] [a,start,n] +genPrim _ _ FreezeArrayOp [r] [a,start,n] = PrimInline $ r |= app "h$sliceArray" [a,start,n] +genPrim _ _ ThawArrayOp [r] [a,start,n] = PrimInline $ r |= app "h$sliceArray" [a,start,n] +genPrim _ _ 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 + +genPrim _ _ NewSmallArrayOp [a] [n,e] = PrimInline $ a |= app "h$newArray" [n,e] +genPrim _ _ ReadSmallArrayOp [r] [a,i] = PrimInline $ r |= a .! i +genPrim _ _ WriteSmallArrayOp [] [a,i,e] = PrimInline $ a .! i |= e +genPrim _ _ SizeofSmallArrayOp [r] [a] = PrimInline $ r |= a .^ "length" +genPrim _ _ SizeofSmallMutableArrayOp [r] [a] = PrimInline $ r |= a .^ "length" +genPrim _ _ IndexSmallArrayOp [r] [a,i] = PrimInline $ r |= a .! i +genPrim _ _ UnsafeFreezeSmallArrayOp [r] [a] = PrimInline $ r |= a +genPrim _ _ UnsafeThawSmallArrayOp [r] [a] = PrimInline $ r |= a +genPrim _ _ CopySmallArrayOp [] [s,si,d,di,n] = PrimInline $ + loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] +genPrim _ _ CopySmallMutableArrayOp [] [s,si,d,di,n] = PrimInline $ + loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] +genPrim _ _ CloneSmallArrayOp [r] [a,o,n] = PrimInline $ cloneArray r a (Just o) n +genPrim _ _ CloneSmallMutableArrayOp [r] [a,o,n] = PrimInline $ cloneArray r a (Just o) n +genPrim _ _ FreezeSmallArrayOp [r] [a,o,n] = PrimInline $ cloneArray r a (Just o) n +genPrim _ _ ThawSmallArrayOp [r] [a,o,n] = PrimInline $ cloneArray r a (Just o) n +genPrim _ _ CasSmallArrayOp [s,o] [a,i,old,new] = PrimInline $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + -- fixme both new? + [ s |= one_ + , o |= x + ] + ] + +-- Byte Arrays + +genPrim _ _ NewByteArrayOp_Char [r] [l] = PrimInline (newByteArray r l) +genPrim _ _ NewPinnedByteArrayOp_Char [r] [l] = PrimInline (newByteArray r l) +genPrim _ _ NewAlignedPinnedByteArrayOp_Char [r] [l,_align] = PrimInline (newByteArray r l) +genPrim _ _ MutableByteArrayIsPinnedOp [r] [_] = PrimInline $ r |= one_ +genPrim _ _ ByteArrayIsPinnedOp [r] [_] = PrimInline $ r |= one_ +genPrim _ _ ByteArrayContents_Char [a,o] [b] = PrimInline $ mconcat [a |= b, o |= zero_] +genPrim _ _ ShrinkMutableByteArrayOp_Char [] [a,n] = PrimInline $ appS "h$shrinkMutableByteArray" [a,n] +genPrim _ _ ResizeMutableByteArrayOp_Char [r] [a,n] = PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] +genPrim _ _ UnsafeFreezeByteArrayOp [a] [b] = PrimInline $ a |= b +genPrim _ _ SizeofByteArrayOp [r] [a] = PrimInline $ r |= a .^ "len" +genPrim _ _ SizeofMutableByteArrayOp [r] [a] = PrimInline $ r |= a .^ "len" +genPrim _ _ GetSizeofMutableByteArrayOp [r] [a] = PrimInline $ r |= a .^ "len" +genPrim _ _ IndexByteArrayOp_Char [r] [a,i] = PrimInline $ r |= u8_ a i +genPrim _ _ IndexByteArrayOp_WideChar [r] [a,i] = PrimInline $ r |= i3_ a i +genPrim _ _ IndexByteArrayOp_Int [r] [a,i] = PrimInline $ r |= i3_ a i +genPrim _ _ IndexByteArrayOp_Word [r] [a,i] = PrimInline $ r |= i3_ a i +genPrim _ _ IndexByteArrayOp_Addr [r1,r2] [a,i] = PrimInline $ 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_ + ] + ] + +genPrim _ _ IndexByteArrayOp_Float [r] [a,i] = + PrimInline $ r |= f3_ a i +genPrim _ _ IndexByteArrayOp_Double [r] [a,i] = + PrimInline $ r |= f6_ a i +genPrim _ _ IndexByteArrayOp_StablePtr [r1,r2] [a,i] = + PrimInline $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= i3_ a i + ] +genPrim _ _ IndexByteArrayOp_Int8 [r] [a,i] = PrimInline $ r |= dv_i8 a i +genPrim _ _ IndexByteArrayOp_Int16 [r] [a,i] = PrimInline $ r |= dv_i16 a (i .<<. one_) +genPrim _ _ IndexByteArrayOp_Int32 [r] [a,i] = PrimInline $ r |= i3_ a i +genPrim _ _ IndexByteArrayOp_Int64 [r1,r2] [a,i] = PrimInline $ mconcat + [ r1 |= i3_ a (Add (i .<<. one_) one_) + , r2 |= i3_ a (i .<<. one_) + ] +genPrim _ _ IndexByteArrayOp_Word8 [r] [a,i] = PrimInline $ r |= u8_ a i +genPrim _ _ IndexByteArrayOp_Word16 [r] [a,i] = PrimInline $ r |= dv_u16 a (i .<<. one_) +genPrim _ _ IndexByteArrayOp_Word32 [r] [a,i] = PrimInline $ r |= i3_ a i +genPrim _ _ IndexByteArrayOp_Word64 [r1,r2] [a,i] = PrimInline $ mconcat + [ r1 |= i3_ a (Add (i .<<. one_) one_) + , r2 |= i3_ a (i .<<. one_) + ] +{- new ops in 8.6 + , IndexByteArrayOp_Word8AsChar + , IndexByteArrayOp_Word8AsWideChar + , IndexByteArrayOp_Word8AsAddr + , IndexByteArrayOp_Word8AsFloat + , IndexByteArrayOp_Word8AsDouble + , IndexByteArrayOp_Word8AsStablePtr + , IndexByteArrayOp_Word8AsInt16 + , IndexByteArrayOp_Word8AsInt32 + , IndexByteArrayOp_Word8AsInt64 + , IndexByteArrayOp_Word8AsInt + , IndexByteArrayOp_Word8AsWord16 + , IndexByteArrayOp_Word8AsWord32 + , IndexByteArrayOp_Word8AsWord64 + , IndexByteArrayOp_Word8AsWord + -} +genPrim _ _ ReadByteArrayOp_Char [r] [a,i] = + PrimInline $ r |= u8_ a i +genPrim _ _ ReadByteArrayOp_WideChar [r] [a,i] = + PrimInline $ r |= i3_ a i +genPrim _ _ ReadByteArrayOp_Int [r] [a,i] = + PrimInline $ r |= i3_ a i +genPrim _ _ ReadByteArrayOp_Word [r] [a,i] = + PrimInline $ r |= i3_ a i +genPrim _ _ 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_]) + ] +genPrim _ _ ReadByteArrayOp_Float [r] [a,i] = + PrimInline $ r |= f3_ a i +genPrim _ _ ReadByteArrayOp_Double [r] [a,i] = + PrimInline $ r |= f6_ a i +genPrim _ _ ReadByteArrayOp_StablePtr [r1,r2] [a,i] = + PrimInline $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= i3_ a i + ] +genPrim _ _ ReadByteArrayOp_Int8 [r] [a,i] = + PrimInline $ r |= dv_i8 a i +genPrim _ _ ReadByteArrayOp_Int16 [r] [a,i] = + PrimInline $ r |= dv_i16 a (i .<<. one_) +genPrim _ _ ReadByteArrayOp_Int32 [r] [a,i] = + PrimInline $ r |= i3_ a i +genPrim _ _ ReadByteArrayOp_Int64 [r1,r2] [a,i] = + PrimInline $ mconcat + [ r1 |= i3_ a (Add (i .<<. one_) one_) + , r2 |= i3_ a (i .<<. one_) + ] +genPrim _ _ ReadByteArrayOp_Word8 [r] [a,i] = PrimInline $ r |= u8_ a i +genPrim _ _ ReadByteArrayOp_Word16 [r] [a,i] = PrimInline $ r |= u1_ a i +genPrim _ _ ReadByteArrayOp_Word32 [r] [a,i] = PrimInline $ r |= i3_ a i +genPrim _ _ ReadByteArrayOp_Word64 [r1,r2] [a,i] = + PrimInline $ mconcat + [ r1 |= i3_ a (Add (i .<<. one_) one_) + , r2 |= i3_ a (i .<<. one_) + ] +{- new ops in 8.6 + , ReadByteArrayOp_Word8AsChar + , ReadByteArrayOp_Word8AsWideChar + , ReadByteArrayOp_Word8AsAddr + , ReadByteArrayOp_Word8AsFloat + , ReadByteArrayOp_Word8AsDouble + , ReadByteArrayOp_Word8AsStablePtr + , ReadByteArrayOp_Word8AsInt16 + , ReadByteArrayOp_Word8AsInt32 + , ReadByteArrayOp_Word8AsInt64 + , ReadByteArrayOp_Word8AsInt + , ReadByteArrayOp_Word8AsWord16 + , ReadByteArrayOp_Word8AsWord32 + , ReadByteArrayOp_Word8AsWord64 + , ReadByteArrayOp_Word8AsWord + -} +genPrim _ _ WriteByteArrayOp_Char [] [a,i,e] = PrimInline $ u8_ a i |= e +genPrim _ _ WriteByteArrayOp_WideChar [] [a,i,e] = PrimInline $ i3_ a i |= e +genPrim _ _ WriteByteArrayOp_Int [] [a,i,e] = PrimInline $ i3_ a i |= e +genPrim _ _ WriteByteArrayOp_Word [] [a,i,e] = PrimInline $ i3_ a i |= e +genPrim _ _ 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]) + ] +genPrim _ _ WriteByteArrayOp_Float [] [a,i,e] = PrimInline $ f3_ a i |= e +genPrim _ _ WriteByteArrayOp_Double [] [a,i,e] = PrimInline $ f6_ a i |= e +genPrim _ _ WriteByteArrayOp_StablePtr [] [a,i,_e1,e2] = PrimInline $ i3_ a i |= e2 + +genPrim _ _ WriteByteArrayOp_Int8 [] [a,i,e] = PrimInline $ dv_s_i8 a i e +genPrim _ _ WriteByteArrayOp_Int16 [] [a,i,e] = PrimInline $ dv_s_i16 a (i .<<. one_) e +genPrim _ _ WriteByteArrayOp_Int32 [] [a,i,e] = PrimInline $ i3_ a i |= e +genPrim _ _ WriteByteArrayOp_Int64 [] [a,i,e1,e2] = + PrimInline $ mconcat + [ i3_ a (Add (i .<<. one_) one_) |= e1 + , i3_ a (i .<<. one_) |= e2 + ] +genPrim _ _ WriteByteArrayOp_Word8 [] [a,i,e] = PrimInline $ u8_ a i |= e +genPrim _ _ WriteByteArrayOp_Word16 [] [a,i,e] = PrimInline $ u1_ a i |= e +genPrim _ _ WriteByteArrayOp_Word32 [] [a,i,e] = PrimInline $ i3_ a i |= e +genPrim _ _ WriteByteArrayOp_Word64 [] [a,i,e1,e2] = + PrimInline $ mconcat + [ i3_ a (Add (i .<<. one_) one_) |= e1 + , i3_ a (i .<<. one_) |= e2 + ] +{- implement new ops in 8.6 + , WriteByteArrayOp_Word8AsChar + , WriteByteArrayOp_Word8AsWideChar + , WriteByteArrayOp_Word8AsAddr + , WriteByteArrayOp_Word8AsFloat + , WriteByteArrayOp_Word8AsDouble + , WriteByteArrayOp_Word8AsStablePtr + , WriteByteArrayOp_Word8AsInt16 + , WriteByteArrayOp_Word8AsInt32 + , WriteByteArrayOp_Word8AsInt64 + , WriteByteArrayOp_Word8AsInt + , WriteByteArrayOp_Word8AsWord16 + , WriteByteArrayOp_Word8AsWord32 + , WriteByteArrayOp_Word8AsWord64 + , WriteByteArrayOp_Word8AsWord + -} + +genPrim _ _ CompareByteArraysOp [r] [a1,o1,a2,o2,n] = + PrimInline $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] +-- fixme we can do faster by copying 32 bit ints or doubles +genPrim _ _ CopyByteArrayOp [] [a1,o1,a2,o2,n] = + PrimInline $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ u8_ a2 (Add i o2) |= u8_ a1 (Add i o1) + , postDecrS i + ] +genPrim d t CopyMutableByteArrayOp [] xs@[_a1,_o1,_a2,_o2,_n] = genPrim d t CopyByteArrayOp [] xs +genPrim d t CopyByteArrayToAddrOp [] xs@[_a1,_o1,_a2,_o2,_n] = genPrim d t CopyByteArrayOp [] xs +genPrim d t CopyMutableByteArrayToAddrOp [] xs@[_a1,_o1,_a2,_o2,_n] = genPrim d t CopyByteArrayOp [] xs +genPrim d t CopyAddrToByteArrayOp [] xs@[_ba,_bo,_aa,_ao,_n] = genPrim d t CopyByteArrayOp [] xs + +genPrim _ _ SetByteArrayOp [] [a,o,n,v] = + PrimInline $ loopBlockS zero_ (.<. n) \i -> + [ u8_ a (Add o i) |= v + , postIncrS i + ] + +genPrim _ _ AtomicReadByteArrayOp_Int [r] [a,i] = PrimInline $ r |= i3_ a i +genPrim _ _ AtomicWriteByteArrayOp_Int [] [a,i,v] = PrimInline $ i3_ a i |= v +genPrim _ _ CasByteArrayOp_Int [r] [a,i,old,new] = PrimInline $ + jVar \t -> mconcat + [ t |= i3_ a i + , r |= t + , ifS (t .===. old) (i3_ a i |= new) mempty + ] +genPrim _ _ FetchAddByteArrayOp_Int [r] [a,i,v] = PrimInline $ fetchOpByteArray Add r a i v +genPrim _ _ FetchSubByteArrayOp_Int [r] [a,i,v] = PrimInline $ fetchOpByteArray Sub r a i v +genPrim _ _ FetchAndByteArrayOp_Int [r] [a,i,v] = PrimInline $ fetchOpByteArray BAnd r a i v +genPrim _ _ FetchOrByteArrayOp_Int [r] [a,i,v] = PrimInline $ fetchOpByteArray BOr r a i v +genPrim _ _ FetchNandByteArrayOp_Int [r] [a,i,v] = PrimInline $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v +genPrim _ _ FetchXorByteArrayOp_Int [r] [a,i,v] = PrimInline $ fetchOpByteArray BXor r a i v + +-- Addr# + +genPrim _ _ AddrAddOp [a',o'] [a,o,i] = PrimInline $ mconcat [a' |= a, o' |= Add o i] +genPrim _ _ AddrSubOp [i] [_a1,o1,_a2,o2] = PrimInline $ i |= Sub o1 o2 +genPrim _ _ AddrRemOp [r] [_a,o,i] = PrimInline $ r |= Mod o i +genPrim _ _ AddrToIntOp [i] [_a,o] = PrimInline $ i |= o -- only usable for comparisons within one range +genPrim _ _ IntToAddrOp [a,o] [i] = PrimInline $ mconcat [a |= null_, o |= i] -- FIXME: unsupported +genPrim _ _ AddrGtOp [r] [a1,o1,a2,o2] = + PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>. zero_) +genPrim _ _ AddrGeOp [r] [a1,o1,a2,o2] = + PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>=. zero_) +genPrim _ _ AddrEqOp [r] [a1,o1,a2,o2] = + PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .===. zero_) +genPrim _ _ AddrNeOp [r] [a1,o1,a2,o2] = + PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .!==. zero_) +genPrim _ _ AddrLtOp [r] [a1,o1,a2,o2] = + PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<. zero_) +genPrim _ _ AddrLeOp [r] [a1,o1,a2,o2] = + PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<=. zero_) + +-- addr indexing: unboxed arrays +genPrim _ _ IndexOffAddrOp_Char [c] [a,o,i] = PrimInline $ c |= u8_ a (off8 o i) +genPrim _ _ IndexOffAddrOp_WideChar [c] [a,o,i] = PrimInline $ c |= dv_u32 a (off32 o i) +genPrim _ _ IndexOffAddrOp_Int [c] [a,o,i] = PrimInline $ c |= dv_i32 a (off32 o i) +genPrim _ _ IndexOffAddrOp_Word [c] [a,o,i] = PrimInline $ c |= dv_i32 a (off32 o i) +genPrim _ _ IndexOffAddrOp_Addr [ca,co] [a,o,i] = + PrimInline $ 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_ + ] +genPrim _ _ IndexOffAddrOp_Float [c] [a,o,i] = PrimInline $ c |= dv_f32 a (off32 o i) +genPrim _ _ IndexOffAddrOp_Double [c] [a,o,i] = PrimInline $ c |= dv_f64 a (off64 o i) +genPrim _ _ IndexOffAddrOp_StablePtr [c1,c2] [a,o,i] = PrimInline $ mconcat + [ c1 |= var "h$stablePtrBuf" + , c2 |= dv_i32 a (off32 o i) + ] +genPrim _ _ IndexOffAddrOp_Int8 [c] [a,o,i] = PrimInline $ c |= u8_ a (off8 o i) +genPrim _ _ IndexOffAddrOp_Int16 [c] [a,o,i] = PrimInline $ c |= dv_i16 a (off16 o i) +genPrim _ _ IndexOffAddrOp_Int32 [c] [a,o,i] = PrimInline $ c |= dv_i32 a (off32 o i) +genPrim _ _ IndexOffAddrOp_Int64 [c1,c2] [a,o,i] = + PrimInline $ mconcat + [ c1 |= dv_i32 a (Add (off64 o i) (Int 4)) + , c2 |= dv_i32 a (off64 o i) + ] +genPrim _ _ IndexOffAddrOp_Word8 [c] [a,o,i] = PrimInline $ c |= u8_ a (off8 o i) +genPrim _ _ IndexOffAddrOp_Word16 [c] [a,o,i] = PrimInline $ c |= dv_u16 a (off16 o i) +genPrim _ _ IndexOffAddrOp_Word32 [c] [a,o,i] = PrimInline $ c |= dv_i32 a (off32 o i) +genPrim _ _ IndexOffAddrOp_Word64 [c1,c2] [a,o,i] = + PrimInline $ mconcat + [ c1 |= dv_i32 a (Add (off64 o i) (Int 4)) + , c2 |= dv_i32 a (off64 o i) + ] +genPrim _ _ ReadOffAddrOp_Char [c] [a,o,i] = PrimInline $ c |= u8_ a (off8 o i) +genPrim _ _ ReadOffAddrOp_WideChar [c] [a,o,i] = PrimInline $ c |= dv_u32 a (off32 o i) +genPrim _ _ ReadOffAddrOp_Int [c] [a,o,i] = PrimInline $ c |= dv_i32 a (off32 o i) +genPrim _ _ ReadOffAddrOp_Word [c] [a,o,i] = PrimInline $ c |= dv_i32 a (off32 o i) +genPrim _ _ ReadOffAddrOp_Addr [c1,c2] [a,o,i] = + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , 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_ + ] + ] +genPrim _ _ ReadOffAddrOp_Float [c] [a,o,i] = PrimInline $ c |= dv_f32 a (off32 o i) +genPrim _ _ ReadOffAddrOp_Double [c] [a,o,i] = PrimInline $ c |= dv_f64 a (off64 o i) +genPrim _ _ ReadOffAddrOp_StablePtr [c1,c2] [a,o,i] = PrimInline $ mconcat + [ c1 |= var "h$stablePtrBuf" + , c2 |= dv_u32 a (off32 o i) + ] +genPrim _ _ ReadOffAddrOp_Int8 [c] [a,o,i] = PrimInline $ AssignStat c $ dv_i8 a (off8 o i) +genPrim _ _ ReadOffAddrOp_Int16 [c] [a,o,i] = PrimInline $ AssignStat c $ dv_i16 a (off16 o i) +genPrim _ _ ReadOffAddrOp_Int32 [c] [a,o,i] = PrimInline $ AssignStat c $ dv_i32 a (off32 o i) +genPrim _ _ ReadOffAddrOp_Int64 [c1,c2] [a,o,i] = + PrimInline $ mconcat + [ c1 |= dv_i32 a (Add (off64 o i) (Int 4)) + , c2 |= dv_i32 a (off64 o i) + ] +genPrim _ _ ReadOffAddrOp_Word8 [c] [a,o,i] = PrimInline $ AssignStat c $ u8_ a (off8 o i) +genPrim _ _ ReadOffAddrOp_Word16 [c] [a,o,i] = PrimInline $ AssignStat c $ dv_u16 a (off16 o i) +genPrim _ _ ReadOffAddrOp_Word32 [c] [a,o,i] = PrimInline $ AssignStat c $ dv_i32 a (off32 o i) +genPrim _ _ ReadOffAddrOp_Word64 [c1,c2] [a,o,i] = + PrimInline $ mconcat + [ c1 |= dv_i32 a (Add (off64 o i) (Int 4)) + , c2 |= dv_i32 a (off64 o i) + ] +genPrim _ _ WriteOffAddrOp_Char [] [a,o,i,v] = PrimInline $ u8_ a (off8 o i) |= v +genPrim _ _ WriteOffAddrOp_WideChar [] [a,o,i,v] = PrimInline $ dv_s_u32 a (off32 o i) v +genPrim _ _ WriteOffAddrOp_Int [] [a,o,i,v] = PrimInline $ dv_s_i32 a (off32 o i) v +genPrim _ _ WriteOffAddrOp_Word [] [a,o,i,v] = PrimInline $ dv_s_i32 a (off32 o i) v +genPrim _ _ WriteOffAddrOp_Addr [] [a,o,i,va,vo] = + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) + ] +genPrim _ _ WriteOffAddrOp_Float [] [a,o,i,v] = PrimInline $ dv_s_f32 a (off32 o i) v +genPrim _ _ WriteOffAddrOp_Double [] [a,o,i,v] = PrimInline $ dv_s_f64 a (off64 o i) v +genPrim _ _ WriteOffAddrOp_StablePtr [] [a,o,i,_v1,v2] = PrimInline $ dv_s_u32 a (off32 o i) v2 +genPrim _ _ WriteOffAddrOp_Int8 [] [a,o,i,v] = PrimInline $ dv_s_i8 a (off8 o i) v +genPrim _ _ WriteOffAddrOp_Int16 [] [a,o,i,v] = PrimInline $ dv_s_i16 a (off16 o i) v +genPrim _ _ WriteOffAddrOp_Int32 [] [a,o,i,v] = PrimInline $ dv_s_i32 a (off32 o i) v +genPrim _ _ WriteOffAddrOp_Int64 [] [a,o,i,v1,v2] = PrimInline $ mconcat + [ dv_s_i32 a (Add (off64 o i) (Int 4)) v1 + , dv_s_i32 a (off64 o i) v2 + ] +genPrim _ _ WriteOffAddrOp_Word8 [] [a,o,i,v] = PrimInline $ u8_ a (off8 o i) |= v +genPrim _ _ WriteOffAddrOp_Word16 [] [a,o,i,v] = PrimInline $ dv_s_u16 a (off16 o i) v +genPrim _ _ WriteOffAddrOp_Word32 [] [a,o,i,v] = PrimInline $ dv_s_i32 a (off32 o i) v +genPrim _ _ WriteOffAddrOp_Word64 [] [a,o,i,v1,v2] = PrimInline $ mconcat + [ dv_s_i32 a (Add (off64 o i) (Int 4)) v1 + , dv_s_i32 a (off64 o i) v2 + ] +-- Mutable variables +genPrim _ _ NewMutVarOp [r] [x] = PrimInline $ r |= New (app "h$MutVar" [x]) +genPrim _ _ ReadMutVarOp [r] [m] = PrimInline $ r |= m .^ "val" +genPrim _ _ WriteMutVarOp [] [m,x] = PrimInline $ m .^ "val" |= x +genPrim _ _ AtomicModifyMutVar2Op [r1,r2] [m,f] = PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f] +genPrim _ _ AtomicModifyMutVar_Op [r1,r2] [m,f] = PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f] + +genPrim _ _ 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 + +genPrim _ _ CatchOp [_r] [a,handler] = PRPrimCall $ + returnS (app "h$catch" [a, handler]) +genPrim _ _ RaiseOp [_r] [a] = PRPrimCall $ returnS (app "h$throw" [a, false_]) +genPrim _ _ RaiseIOOp [_r] [a] = PRPrimCall $ returnS (app "h$throw" [a, false_]) + +genPrim _ _ MaskAsyncExceptionsOp [_r] [a] = + PRPrimCall $ returnS (app "h$maskAsync" [a]) +genPrim _ _ MaskUninterruptibleOp [_r] [a] = + PRPrimCall $ returnS (app "h$maskUnintAsync" [a]) +genPrim _ _ UnmaskAsyncExceptionsOp [_r] [a] = + PRPrimCall $ returnS (app "h$unmaskAsync" [a]) + +genPrim _ _ MaskStatus [r] [] = PrimInline $ r |= app "h$maskStatus" [] + +-- STM-accessible Mutable Variables + +genPrim _ _ AtomicallyOp [_r] [a] = PRPrimCall $ returnS (app "h$atomically" [a]) +genPrim _ _ RetryOp [_r] [] = PRPrimCall $ returnS (app "h$stmRetry" []) +genPrim _ _ CatchRetryOp [_r] [a,b] = PRPrimCall $ returnS (app "h$stmCatchRetry" [a,b]) +genPrim _ _ CatchSTMOp [_r] [a,h] = PRPrimCall $ returnS (app "h$catchStm" [a,h]) +genPrim _ _ NewTVarOp [tv] [v] = PrimInline $ tv |= app "h$newTVar" [v] +genPrim _ _ ReadTVarOp [r] [tv] = PrimInline $ r |= app "h$readTVar" [tv] +genPrim _ _ ReadTVarIOOp [r] [tv] = PrimInline $ r |= app "h$readTVarIO" [tv] +genPrim _ _ WriteTVarOp [] [tv,v] = PrimInline $ appS "h$writeTVar" [tv,v] + +-- Synchronized Mutable Variables + +genPrim _ _ NewMVarOp [r] [] = PrimInline $ r |= New (app "h$MVar" []) +genPrim _ _ TakeMVarOp [_r] [m] = PRPrimCall $ returnS (app "h$takeMVar" [m]) +genPrim _ _ TryTakeMVarOp [r,v] [m] = PrimInline $ appT [r,v] "h$tryTakeMVar" [m] +genPrim _ _ PutMVarOp [] [m,v] = PRPrimCall $ returnS (app "h$putMVar" [m,v]) +genPrim _ _ TryPutMVarOp [r] [m,v] = PrimInline $ r |= app "h$tryPutMVar" [m,v] +genPrim _ _ ReadMVarOp [_r] [m] = PRPrimCall $ returnS (app "h$readMVar" [m]) +genPrim _ _ TryReadMVarOp [r,v] [m] = PrimInline $ mconcat + [ v |= m .^ "val" + , r |= if01 (v .===. null_) + ] +genPrim _ _ IsEmptyMVarOp [r] [m] = PrimInline $ r |= if10 (m .^ "val" .===. null_) + +-- Delay/wait operations + +genPrim _ _ DelayOp [] [t] = PRPrimCall $ returnS (app "h$delayThread" [t]) +genPrim _ _ WaitReadOp [] [fd] = PRPrimCall $ returnS (app "h$waidRead" [fd]) +genPrim _ _ WaitWriteOp [] [fd] = PRPrimCall $ returnS (app "h$waitWrite" [fd]) + +-- Concurrency primitives + +genPrim _ _ ForkOp [_tid] [x] = PRPrimCall $ returnS (app "h$fork" [x, true_]) +genPrim _ _ ForkOnOp [_tid] [_p,x] = PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument +genPrim _ _ KillThreadOp [] [tid,ex] = + PRPrimCall $ returnS (app "h$killThread" [tid,ex]) +genPrim _ _ YieldOp [] [] = PRPrimCall $ returnS (app "h$yield" []) +genPrim _ _ MyThreadIdOp [r] [] = PrimInline $ r |= var "h$currentThread" +genPrim _ _ LabelThreadOp [] [t,la,lo] = PrimInline $ t .^ "label" |= ValExpr (JList [la, lo]) +genPrim _ _ IsCurrentThreadBoundOp [r] [] = PrimInline $ r |= one_ +genPrim _ _ NoDuplicateOp [] [] = PrimInline mempty -- don't need to do anything as long as we have eager blackholing +genPrim _ _ ThreadStatusOp [stat,cap,locked] [tid] = PrimInline $ + appT [stat, cap, locked] "h$threadStatus" [tid] + +-- Weak pointers + +genPrim _ _ MkWeakOp [r] [o,b,c] = PrimInline $ r |= app "h$makeWeak" [o,b,c] +genPrim _ _ MkWeakNoFinalizerOp [r] [o,b] = PrimInline $ r |= app "h$makeWeakNoFinalizer" [o,b] +genPrim _ _ AddCFinalizerToWeakOp [r] [_a1,_a1o,_a2,_a2o,_i,_a3,_a3o,_w] = + PrimInline $ r |= one_ -- fixme? +genPrim _ _ DeRefWeakOp [f,v] [w] = PrimInline $ mconcat + [ v |= w .^ "val" + , f |= if01 (v .===. null_) + ] +genPrim _ _ FinalizeWeakOp [fl,fin] [w] = + PrimInline $ appT [fin, fl] "h$finalizeWeak" [w] +genPrim _ _ TouchOp [] [_e] = PrimInline mempty -- fixme what to do? + +-- Stable pointers and names + +genPrim _ _ MakeStablePtrOp [s1,s2] [a] = PrimInline $ mconcat + [ s1 |= var "h$stablePtrBuf" + , s2 |= app "h$makeStablePtr" [a] + ] +genPrim _ _ DeRefStablePtrOp [r] [_s1,s2] = PrimInline $ + r |= app "h$deRefStablePtr" [s2] +genPrim _ _ EqStablePtrOp [r] [_sa1,sa2,_sb1,sb2] = PrimInline $ + r |= if10 (sa2 .===. sb2) + +genPrim _ _ MakeStableNameOp [r] [a] = PrimInline $ r |= app "h$makeStableName" [a] +genPrim _ _ StableNameToIntOp [r] [s] = PrimInline $ r |= app "h$stableNameInt" [s] + +-- Compact normal form + +genPrim _ _ CompactNewOp [c] [s] = PrimInline $ c |= app "h$compactNew" [s] +genPrim _ _ CompactResizeOp [] [s] = PrimInline $ appS "h$compactResize" [s] +genPrim _ _ CompactContainsOp [r] [c,v] = PrimInline $ r |= app "h$compactContains" [c,v] +genPrim _ _ CompactContainsAnyOp [r] [v] = PrimInline $ r |= app "h$compactContainsAny" [v] +genPrim _ _ CompactGetFirstBlockOp [ra,ro,s] [c] = + PrimInline $ appT [ra,ro,s] "h$compactGetFirstBlock" [c] +genPrim _ _ CompactGetNextBlockOp [ra,ro,s] [c,a,o] = + PrimInline $ appT [ra,ro,s] "h$compactGetNextBlock" [c,a,o] +genPrim _ _ CompactAllocateBlockOp [ra,ro] [size,sa,so] = + PrimInline $ appT [ra,ro] "h$compactAllocateBlock" [size,sa,so] +genPrim _ _ CompactFixupPointersOp [newroota, newrooto] [blocka,blocko,roota,rooto] = + PrimInline $ appT [newroota,newrooto] "h$compactFixupPointers" [blocka,blocko,roota,rooto] +genPrim _ _ CompactAdd [_r] [c,o] = + PRPrimCall $ returnS (app "h$compactAdd" [c,o]) +genPrim _ _ CompactAddWithSharing [_r] [c,o] = + PRPrimCall $ returnS (app "h$compactAddWithSharing" [c,o]) +genPrim _ _ CompactSize [s] [c] = + PrimInline $ s |= app "h$compactSize" [c] + +-- Unsafe pointer equality + +genPrim _ _ ReallyUnsafePtrEqualityOp [r] [p1,p2] = PrimInline $ r |= if10 (p1 .===. p2) + +-- Parallelism + +genPrim _ _ ParOp [r] [_a] = PrimInline $ r |= zero_ +genPrim _ _ SparkOp [r] [a] = PrimInline $ r |= a +genPrim _ _ SeqOp [_r] [e] = PRPrimCall $ returnS (app "h$e" [e]) +{- +GetSparkOp +-} +genPrim _ _ NumSparks [r] [] = PrimInline $ r |= zero_ + +-- Tag to enum stuff + +genPrim _ _t DataToTagOp [_r] [d] = PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] +genPrim _ t TagToEnumOp [r] [tag] + | isBoolTy t = PrimInline $ r |= IfExpr tag true_ false_ + | otherwise = PrimInline $ r |= app "h$tagToEnum" [tag] + +-- Bytecode operations + +genPrim _ _ AddrToAnyOp [r] [d,_o] = PrimInline $ r |= d + +{- +AnyToAddrOp +MkApUpd0_Op +NewBCOOp +UnpackClosureOp +GetApStackValOp +-} + +-- Misc + +genPrim prof _ GetCCSOfOp [a, o] [obj] + | prof = PrimInline $ mconcat + [ a |= if_ (isObject obj) + (app "h$buildCCSPtr" [obj .^ "cc"]) + null_ + , o |= zero_ + ] + | otherwise = PrimInline $ mconcat + [ a |= null_ + , o |= zero_ + ] + +genPrim prof _ GetCurrentCCSOp [a, o] [_dummy_arg] = + let ptr = if prof then app "h$buildCCSPtr" [jCurrentCCS] + else null_ + in PrimInline $ mconcat + [ a |= ptr + , o |= zero_ + ] + +genPrim _ _ ClearCCSOp [_r] [x] = PRPrimCall $ ReturnStat (app "h$clearCCS" [x]) + +-- Etc (Miscellaneous built-ins) + +genPrim _ _ TraceEventOp [] [ed,eo] = PrimInline $ appS "h$traceEvent" [ed,eo] +genPrim _ _ TraceEventBinaryOp [] [ed,eo,len] = PrimInline $ appS "h$traceEventBinary" [ed,eo,len] +genPrim _ _ TraceMarkerOp [] [ed,eo] = PrimInline $ appS "h$traceMarker" [ed,eo] + +genPrim _ _ op rs as = PrimInline $ mconcat + [ appS "h$log" [toJExpr $ mconcat + [ "warning, unhandled primop: " + , renderWithContext defaultSDocContext (ppr op) + , " " + , show (length rs, length as) + ]] + , appS (ST.pack $ "h$primop_" ++ renderWithContext defaultSDocContext (ppr op)) as + -- copyRes + , mconcat $ zipWith (\r reg -> r |= toJExpr reg) rs (enumFrom Ret1) + ] + +-- tuple returns +appT :: [JExpr] -> ShortText -> [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)) + ] + +i3_, u8_, f6_, f3_, u1_ :: JExpr -> JExpr -> JExpr +i3_ a i = IdxExpr (a .^ "i3") i +u8_ a i = IdxExpr (a .^ "u8") i +f6_ a i = IdxExpr (a .^ "f6") i +f3_ a i = IdxExpr (a .^ "f3") i +u1_ a i = IdxExpr (a .^ "u1") i + +dv_s_i8, dv_s_i16, dv_s_u16, dv_s_i32, dv_s_u32, dv_s_f32, dv_s_f64 :: JExpr -> JExpr -> JExpr -> JStat +dv_s_i8 a i v = ApplStat (a .^ "dv" .^ "setInt8" ) [i, v, true_] +dv_s_u16 a i v = ApplStat (a .^ "dv" .^ "setUint16" ) [i, v, true_] +dv_s_i16 a i v = ApplStat (a .^ "dv" .^ "setInt16" ) [i, v, true_] +dv_s_i32 a i v = ApplStat (a .^ "dv" .^ "setInt32" ) [i, v, true_] +dv_s_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] +dv_s_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] +dv_s_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] + +dv_i8, dv_i16, dv_u16, dv_i32, dv_u32, dv_f32, dv_f64 :: JExpr -> JExpr -> JExpr +dv_i8 a i = ApplExpr (a .^ "dv" .^ "getInt8" ) [i, true_] +dv_i16 a i = ApplExpr (a .^ "dv" .^ "getInt16" ) [i, true_] +dv_u16 a i = ApplExpr (a .^ "dv" .^ "getUint16" ) [i, true_] +dv_i32 a i = ApplExpr (a .^ "dv" .^ "getInt32" ) [i, true_] +dv_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] +dv_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] +dv_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 |= i3_ src i + , i3_ src i |= op tgt v + ] + +-- 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] + +math :: JExpr +math = var "Math" + +math_ :: ShortText -> [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 + :: [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" + +-- e|0 (32 bit signed integer truncation) +trunc :: JExpr -> JExpr +trunc e = BOr 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/Profiling.hs b/compiler/GHC/StgToJS/Profiling.hs new file mode 100644 index 0000000000..aac8e66ca4 --- /dev/null +++ b/compiler/GHC/StgToJS/Profiling.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Profiling + ( initCostCentres + , emitCostCentreDecl + , emitCostCentreStackDecl + , enterCostCentreFun + , enterCostCentreThunk + , setCC + , pushRestoreCCS + , jCurrentCCS + , jCafCCS + , jSystemCCS + , costCentreLbl + , costCentreStackLbl + , singletonCCSLbl + , ccsVarJ + -- * Predicates + , profiling + , ifProfiling + , ifProfilingM + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Regs +import GHC.StgToJS.Types +import GHC.StgToJS.UnitUtils +import GHC.StgToJS.Monad + +import GHC.Types.CostCentre + +import qualified GHC.Data.ShortText as ST +import GHC.Unit.Module +import GHC.Utils.Encoding +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified GHC.Utils.Monad.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 +-- FIXME: ignoring tick flags for now +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 + +-------------------------------------------------------------------------------- +-- 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 CStyle) (ppr cc) + return . ("h$"++) . zEncodeString $ + moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl + +costCentreLbl :: CostCentre -> G Ident +costCentreLbl cc = TxtI . ST.pack <$> costCentreLbl' cc + +costCentreStackLbl' :: CostCentreStack -> G (Maybe String) +costCentreStackLbl' ccs = do + ifProfilingM f + where + f | isCurrentCCS ccs = return $ Just "h$currentThread.ccs" -- FIXME + | 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 . ST.pack) <$> 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 . ST.pack <$> 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..b03bb87907 --- /dev/null +++ b/compiler/GHC/StgToJS/Regs.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Regs + ( StgReg (..) + , Special(..) + , sp + , stack + , r1 + , StgRet (..) + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import qualified GHC.Data.ShortText as ST + +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 :: JExpr +r1 = toJExpr R1 + +--------------------------------------------------- +-- caches +--------------------------------------------------- + +-- cache JExpr representing StgReg +registers :: Array StgReg JExpr +registers = listArray (minBound, maxBound) (map regN (enumFrom R1)) + where + regN r + | fromEnum r < 32 = var . ST.pack . ("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 . ST.pack . ("h$"++) . map toLower . show 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/StaticPtr.hs b/compiler/GHC/StgToJS/StaticPtr.hs new file mode 100644 index 0000000000..6f3ab6205d --- /dev/null +++ b/compiler/GHC/StgToJS/StaticPtr.hs @@ -0,0 +1,29 @@ +{-# 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.Monad + +initStaticPtrs :: [SptEntry] -> G JStat +initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs + where + initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do + i <- jsId sp_id + fpa <- concat <$> mapM (genLit . mkLitWord64 . fromIntegral) [w1,w2] + let sptInsert = ApplExpr (var "h$hs_spt_insert") (fpa ++ [i]) + -- fixme can precedence be so that parens aren't needed? + 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..3df3eaa0b9 --- /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 || + isStrictId i + [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/Types.hs b/compiler/GHC/StgToJS/Types.hs new file mode 100644 index 0000000000..e0d6e9c86c --- /dev/null +++ b/compiler/GHC/StgToJS/Types.hs @@ -0,0 +1,270 @@ +module GHC.StgToJS.Types where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Stg.Syntax +import GHC.Core.TyCon + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Var +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc + +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Outputable (Outputable (..), text) + +import GHC.Data.ShortText + +import GHC.Unit.Module + +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.ByteString as BS +import Data.Monoid + +type G = State GenState + +data GenState = GenState + { gsSettings :: StgToJSConfig -- ^ codegen settings, read-only + , gsModule :: !Module -- ^ current module + , gsId :: !Int -- ^ 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 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] + } + +data StgToJSConfig = StgToJSConfig + { csInlinePush :: !Bool + , csInlineBlackhole :: !Bool + , csInlineLoadRegs :: !Bool + , csInlineEnter :: !Bool + , csInlineAlloc :: !Bool + , csTraceRts :: !Bool + , csAssertRts :: !Bool + , csDebugAlloc :: !Bool + , csTraceForeign :: !Bool + , csProf :: !Bool -- ^ Profiling enabled + , csRuntimeAssert :: !Bool -- ^ Enable runtime assertions + } + +data ClosureInfo = ClosureInfo + { ciVar :: ShortText -- ^ object being infod + , ciRegs :: CIRegs -- ^ things in registers when this is the next closure to enter + , ciName :: ShortText -- ^ 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 (Eq, Ord) + +data CIRegs + = CIRegsUnknown + | CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start + , ciRegsTypes :: [VarType] -- ^ args + } + deriving (Eq, Ord) + +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] + } + deriving (Eq, Ord) + +data CIType + = CIFun { citArity :: !Int -- ^ function arity + , citRegs :: !Int -- ^ number of registers for the args + } + | CIThunk + | CICon { citConstructor :: !Int } + | CIPap + | CIBlackhole + | CIStackFrame + deriving (Eq, Ord) + +data CIStatic + = -- CIStaticParent { staticParent :: Ident } -- ^ static refs are stored in parent in fungroup + CIStaticRefs { staticRefs :: [ShortText] } -- ^ list of refs that need to be kept alive + deriving (Eq, Ord) + +-- function argument and free variable types +data VarType + = PtrV -- pointer = reference to heap object (closure object) + | VoidV -- no fields + -- | FloatV -- one field -- no single precision supported + | DoubleV -- one field + | IntV -- one field + | LongV -- two fields + | 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 (Eq, Ord, Enum, Bounded) + +data IdType + = IdPlain + | IdEntry + | IdConEntry + deriving (Enum, Eq, Ord) + +data IdKey + = IdKey !Int !Int !IdType + deriving (Eq, Ord) + +data OtherSymb + = OtherSymb !Module !ShortText + deriving Eq + +instance Ord OtherSymb where + compare (OtherSymb m1 t1) (OtherSymb m2 t2) + = stableModuleCmp m1 m2 <> compare t1 t2 + +newtype IdCache = IdCache (M.Map IdKey Ident) +newtype GlobalIdCache = GlobalIdCache (M.Map Ident (IdKey, Id)) + +data StackSlot + = SlotId !Id !Int + | SlotUnknown + deriving (Eq, Ord) + + +data StaticInfo = StaticInfo + { siVar :: !ShortText -- ^ global object + , siVal :: !StaticVal -- ^ static initialization + , siCC :: !(Maybe Ident) -- ^ optional CCS name + } + +data StaticVal + = StaticFun !ShortText [StaticArg] + -- ^ heap object for function + | StaticThunk !(Maybe (ShortText,[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 !ShortText [StaticArg] + -- ^ regular datacon app + | StaticList [StaticArg] (Maybe ShortText) + -- ^ list initializer (with optional tail) + deriving (Eq, Ord) + +data StaticUnboxed + = StaticUnboxedBool !Bool + | StaticUnboxedInt !Integer + | StaticUnboxedDouble !SaneDouble + | StaticUnboxedString !BS.ByteString + | StaticUnboxedStringOffset !BS.ByteString + deriving (Eq, Ord) + +data StaticArg + = StaticObjArg !ShortText -- ^ reference to a heap object + | StaticLitArg !StaticLit -- ^ literal + | StaticConArg !ShortText [StaticArg] -- ^ unfloated constructor + deriving (Eq, Ord, Show) + +instance Outputable StaticArg where + ppr x = text (show x) + +data StaticLit + = BoolLit !Bool + | IntLit !Integer + | NullLit + | DoubleLit !SaneDouble -- should we actually use double here? + | StringLit !ShortText + | BinLit !BS.ByteString + | LabelLit !Bool !ShortText -- ^ is function pointer, label (also used for string / binary init) + deriving (Eq, Ord, Show) + +instance Outputable StaticLit where + ppr x = text (show x) + +data ForeignJSRef = ForeignJSRef + { foreignRefSrcSpan :: !ShortText + , foreignRefPattern :: !ShortText + , foreignRefSafety :: !Safety + , foreignRefCConv :: !CCallConv + , foreignRefArgs :: ![ShortText] + , foreignRefResult :: !ShortText + } + +-- | data used to generate one ObjUnit in our object file +data LinkableUnit = LinkableUnit + { luStat :: BS.ByteString -- ^ serialized JS AST + , luIdExports :: [Id] -- ^ exported names from haskell identifiers + , luOtherExports :: [ShortText] -- ^ 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] + } + +-- | Typed expression +data TypedExpr = TypedExpr + { typex_typ :: !PrimRep + , typex_expr :: [JExpr] + } + +data ExprCtx = ExprCtx + { ctxTop :: Id + , ctxTarget :: [TypedExpr] + , ctxEval :: UniqSet Id + , ctxLne :: UniqSet Id -- ^ all lne-bound things + , ctxLneFrameBs :: UniqFM Id Int -- ^ binds in current lne frame (defined at size) + , ctxLneFrame :: [(Id,Int)] -- ^ contents of current lne frame + , ctxSrcSpan :: Maybe RealSrcSpan + } + +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, Ord, Show) + +data ExprValData = ExprValData [JExpr] + deriving (Eq, Ord, Show) + + + +-- closure types +data ClosureType = Thunk | Fun | Pap | Con | Blackhole | StackFrame + deriving (Show, Eq, Ord, Enum, Bounded) + +-- +ctNum :: ClosureType -> Int +ctNum Fun = 1 +ctNum Con = 2 +ctNum Thunk = 0 -- 4 +ctNum Pap = 3 -- 8 +-- ctNum Ind = 4 -- 16 +ctNum Blackhole = 5 -- 32 +ctNum StackFrame = -1 + +instance ToJExpr ClosureType where + toJExpr e = toJExpr (ctNum e) diff --git a/compiler/GHC/StgToJS/UnitUtils.hs b/compiler/GHC/StgToJS/UnitUtils.hs new file mode 100644 index 0000000000..2eb37ca72d --- /dev/null +++ b/compiler/GHC/StgToJS/UnitUtils.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.UnitUtils + ( unitModuleString + , moduleGlobalSymbol + , moduleExportsSymbol + ) +where + +import GHC.Prelude +import GHC.Data.ShortText as ST +import GHC.Unit.Module +import GHC.Utils.Encoding + +unitModuleString :: Module -> String +unitModuleString mod = mconcat + [ unitIdString (moduleUnitId mod) + , ":" + , moduleNameString (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 -> ShortText +moduleGlobalSymbol m = mconcat + [ "h$" + , ST.pack (zEncodeString $ unitModuleString m) + , "_<global>" + ] + +moduleExportsSymbol :: Module -> ShortText +moduleExportsSymbol m = mconcat + [ "h$" + , ST.pack (zEncodeString $ unitModuleString m) + , "_<exports>" + ] diff --git a/compiler/GHC/StgToJS/Utils.hs b/compiler/GHC/StgToJS/Utils.hs new file mode 100644 index 0000000000..075636e4aa --- /dev/null +++ b/compiler/GHC/StgToJS/Utils.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Utils + ( assignToTypedExprs + , assignCoerce1 + , assignToExprCtx + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Core.TyCon + +import GHC.Utils.Misc +import GHC.Utils.Panic + +assignToTypedExprs :: [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 :: 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 _ _ = panic $ "assignTypedExprs1: lengths do not match" + +-- | 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]) = + -- FIXME: (Sylvain 2022-03-11): why can we ignore a_val? + sptr |= a_off +assignCoerce p1 p2 = assignTypedExprs [p1] [p2] + diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs index f4538bf579..b20324a872 100644 --- a/compiler/GHC/Types/Unique.hs +++ b/compiler/GHC/Types/Unique.hs @@ -40,6 +40,8 @@ module GHC.Types.Unique ( nonDetCmpUnique, isValidKnownKeyUnique, + iToBase62, + -- ** Local uniques -- | These are exposed exclusively for use by 'GHC.Types.Var.Env.uniqAway', which -- has rather peculiar needs. See Note [Local uniques]. diff --git a/compiler/GHC/Unit/Module/Name.hs b/compiler/GHC/Unit/Module/Name.hs index cc5e430bd6..9069124279 100644 --- a/compiler/GHC/Unit/Module/Name.hs +++ b/compiler/GHC/Unit/Module/Name.hs @@ -1,7 +1,7 @@ -- | The ModuleName type module GHC.Unit.Module.Name - ( ModuleName + ( ModuleName (..) , pprModuleName , moduleNameFS , moduleNameString diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index 51a09f72e1..f0e6f47912 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -34,6 +34,7 @@ module GHC.Unit.Types , Instantiations , GenInstantiations , mkInstantiatedUnit + , mkInstantiatedUnitSorted , mkInstantiatedUnitHash , mkVirtUnit , mapGenUnit @@ -303,17 +304,7 @@ instance Binary InstantiatedUnit where put_ bh indef = do put_ bh (instUnitInstanceOf indef) put_ bh (instUnitInsts indef) - get bh = do - cid <- get bh - insts <- get bh - let fs = mkInstantiatedUnitHash cid insts - return InstantiatedUnit { - instUnitInstanceOf = cid, - instUnitInsts = insts, - instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - instUnitFS = fs, - instUnitKey = getUnique fs - } + get bh = mkInstantiatedUnitSorted <$> get bh <*> get bh instance IsUnitId u => Eq (GenUnit u) where uid1 == uid2 = unitUnique uid1 == unitUnique uid2 @@ -383,18 +374,30 @@ moduleFreeHoles (Module u _ ) = unitFreeModuleHoles u -- | Create a new 'GenInstantiatedUnit' given an explicit module substitution. mkInstantiatedUnit :: IsUnitId u => u -> GenInstantiations u -> GenInstantiatedUnit u -mkInstantiatedUnit cid insts = - InstantiatedUnit { - instUnitInstanceOf = cid, - instUnitInsts = sorted_insts, - instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - instUnitFS = fs, - instUnitKey = getUnique fs - } +mkInstantiatedUnit cid insts = mkInstantiatedUnitSorted cid sorted_insts where - fs = mkInstantiatedUnitHash cid sorted_insts sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts +-- | Like mkInstantiatedUnit but assumes that instatiations are sorted +-- +-- Useful to make deserialization code faster by not sorting instantiations +-- (that are stored sorted). +-- +mkInstantiatedUnitSorted + :: IsUnitId u + => u + -> [(ModuleName, GenModule (GenUnit u))] + -> GenInstantiatedUnit u +mkInstantiatedUnitSorted cid insts = + let fs = mkInstantiatedUnitHash cid insts + in InstantiatedUnit + { instUnitInstanceOf = cid + , instUnitInsts = insts + , instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles . snd) insts) + , instUnitFS = fs + , instUnitKey = getUnique fs + } + -- | Smart constructor for instantiated GenUnit mkVirtUnit :: IsUnitId u => u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u diff --git a/compiler/GHC/Utils/BufHandle.hs b/compiler/GHC/Utils/BufHandle.hs index aed15610cb..2baaecc7d1 100644 --- a/compiler/GHC/Utils/BufHandle.hs +++ b/compiler/GHC/Utils/BufHandle.hs @@ -20,6 +20,7 @@ module GHC.Utils.BufHandle ( bPutFS, bPutFZS, bPutPtrString, + bPutShortText, bPutReplicate, bFlush, ) where @@ -28,6 +29,7 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Data.FastMutInt +import GHC.Data.ShortText as ST import Control.Monad ( when ) import Data.ByteString (ByteString) @@ -84,6 +86,10 @@ bPutFZS b fs = bPutBS b $ fastZStringToByteString fs bPutBS :: BufHandle -> ByteString -> IO () bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b +bPutShortText :: BufHandle -> ShortText -> IO () +bPutShortText b t = bPutStr b (ST.unpack t) + -- TODO: optimize this! Don't pass through String + bPutCStringLen :: BufHandle -> CStringLen -> IO () bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do i <- readFastMutInt r diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index 878e6d52f4..e6338806d9 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -203,6 +203,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/Ppr.hs b/compiler/GHC/Utils/Ppr.hs index af2b6f977a..4e9548960b 100644 --- a/compiler/GHC/Utils/Ppr.hs +++ b/compiler/GHC/Utils/Ppr.hs @@ -71,7 +71,7 @@ module GHC.Utils.Ppr ( -- * Constructing documents -- ** Converting values into documents - char, text, ftext, ptext, ztext, sizedText, zeroWidthText, emptyText, + char, text, ftext, stext, ptext, ztext, sizedText, zeroWidthText, emptyText, int, integer, float, double, rational, hex, -- ** Simple derived documents @@ -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 @@ -115,6 +115,7 @@ import GHC.Prelude hiding (error) import GHC.Utils.BufHandle import GHC.Data.FastString +import GHC.Data.ShortText as ST import GHC.Utils.Panic.Plain import System.IO import Numeric (showHex) @@ -263,14 +264,14 @@ type RDoc = Doc -- -- A TextDetails represents a fragment of text that will be -- output at some point. -data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment - | Str String -- ^ A whole String fragment - | PStr FastString -- a hashed string - | ZStr FastZString -- a z-encoded string - | LStr {-# UNPACK #-} !PtrString - -- a '\0'-terminated array of bytes - | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char - -- a repeated character (e.g., ' ') +data TextDetails + = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment + | Str String -- ^ A whole String fragment + | SText ShortText -- ^ A ShortText + | PStr FastString -- a hashed string + | ZStr FastZString -- a z-encoded string + | LStr {-# UNPACK #-} !PtrString -- a '\0'-terminated array of bytes + | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char -- a repeated character (e.g., ' ') instance Show Doc where showsPrec _ doc cont = fullRender (mode style) (lineLength style) @@ -318,6 +319,10 @@ text s = textBeside_ (Str s) (length s) Empty ftext :: FastString -> Doc ftext s = textBeside_ (PStr s) (lengthFS s) Empty +stext :: ShortText -> Doc +stext s = textBeside_ (SText s) (codepointLength s) Empty + + ptext :: PtrString -> Doc ptext s = textBeside_ (LStr s) (lengthPS s) Empty @@ -429,10 +434,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 ')' @@ -959,6 +966,7 @@ txtPrinter :: TextDetails -> String -> String txtPrinter (Chr c) s = c:s txtPrinter (Str s1) s2 = s1 ++ s2 txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 +txtPrinter (SText s1) s2 = ST.unpack s1 ++ s2 txtPrinter (ZStr s1) s2 = zString s1 ++ s2 txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 txtPrinter (RStr n c) s2 = replicate n c ++ s2 @@ -1082,6 +1090,7 @@ printDoc_ mode pprCols hdl doc where put (Chr c) next = hPutChar hdl c >> next put (Str s) next = hPutStr hdl s >> next + put (SText s) next = hPutStr hdl (ST.unpack s) >> next put (PStr s) next = hPutStr hdl (unpackFS s) >> next -- NB. not hPutFS, we want this to go through -- the I/O library's encoding layer. (#3398) @@ -1137,21 +1146,20 @@ 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 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 !_ 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) = 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 (Str s) = bPutStr b s - put b (PStr s) = bPutFS b s - put b (ZStr s) = bPutFZS b s - put b (LStr s) = bPutPtrString b s - put b (RStr n c) = bPutReplicate b n 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 + put b (LStr s) = bPutPtrString b s + put b (SText s) = bPutShortText b s + put b (RStr n c) = bPutReplicate b n c layLeft _ _ = panic "layLeft: Unhandled case" -- Define error=panic, for easier comparison with libraries/pretty. diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2bc5acba4f..0ca1aed531 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -415,6 +415,7 @@ Library GHC.Driver.Config.Stg.Ppr GHC.Driver.Config.StgToCmm GHC.Driver.Config.Tidy + GHC.Driver.Config.StgToJS GHC.Driver.Env GHC.Driver.Env.KnotVars GHC.Driver.Env.Types @@ -507,6 +508,10 @@ Library GHC.Iface.Tidy.StaticPtrTable GHC.IfaceToCore GHC.Iface.Type + GHC.JS.Make + GHC.JS.Ppr + GHC.JS.Syntax + GHC.JS.Transform GHC.Linker GHC.Linker.Dynamic GHC.Linker.ExtraObj @@ -619,6 +624,28 @@ Library GHC.StgToCmm.Ticky GHC.StgToCmm.Types GHC.StgToCmm.Utils + GHC.StgToJS + GHC.StgToJS.Apply + GHC.StgToJS.Arg + GHC.StgToJS.CodeGen + GHC.StgToJS.CoreUtils + GHC.StgToJS.DataCon + GHC.StgToJS.Deps + GHC.StgToJS.Expr + GHC.StgToJS.FFI + GHC.StgToJS.Heap + GHC.StgToJS.Literal + GHC.StgToJS.Monad + GHC.StgToJS.Object + GHC.StgToJS.Prim + GHC.StgToJS.Profiling + GHC.StgToJS.Regs + GHC.StgToJS.Sinker + GHC.StgToJS.StaticPtr + GHC.StgToJS.StgUtils + GHC.StgToJS.Types + GHC.StgToJS.UnitUtils + GHC.StgToJS.Utils GHC.Stg.Unarise GHC.SysTools GHC.SysTools.Ar diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst index abc685099b..b69644dd4e 100644 --- a/docs/users_guide/debugging.rst +++ b/docs/users_guide/debugging.rst @@ -703,6 +703,12 @@ assembler. Dump the final assembly produced by the native code generator. +.. ghc-flag:: -ddump-js + :shortdesc: Dump final JavaScript code + :type: dynamic + + Dump the final JavaScript code produced by the JavaScript code generator. + Miscellaneous backend dumps ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/expected-undocumented-flags.txt b/docs/users_guide/expected-undocumented-flags.txt index 33958b1578..c7e3f10ae6 100644 --- a/docs/users_guide/expected-undocumented-flags.txt +++ b/docs/users_guide/expected-undocumented-flags.txt @@ -54,6 +54,7 @@ -fimplicit-params -fimplicit-prelude -firrefutable-tuples +-fjavascript -fmax-errors -fmax-pmcheck-iterations -fmonomorphism-restriction |