diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2022-02-10 08:24:24 +0000 |
|---|---|---|
| committer | Sylvain Henry <sylvain@haskus.fr> | 2022-11-29 09:44:31 +0100 |
| commit | cc25d52e0f65d54c052908c7d91d5946342ab88a (patch) | |
| tree | 0f35764ee3b9b0451ac999b64d2db9fa074fa3dd | |
| parent | def47dd32491311289bff26230b664c895f178cc (diff) | |
| download | haskell-cc25d52e0f65d54c052908c7d91d5946342ab88a.tar.gz | |
Add Javascript backend
Add JS backend adapted from the GHCJS project by Luite Stegeman.
Some features haven't been ported or implemented yet. Tests for these
features have been disabled with an associated gitlab ticket.
Bump array submodule
Work funded by IOG.
Co-authored-by: Jeffrey Young <jeffrey.young@iohk.io>
Co-authored-by: Luite Stegeman <stegeman@gmail.com>
Co-authored-by: Josh Meredith <joshmeredith2008@gmail.com>
283 files changed, 28330 insertions, 1476 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3c773c4aad..f19c78c561 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -17,6 +17,9 @@ variables: # Overridden by individual jobs CONFIGURE_ARGS: "" + # Overridden by individual jobs + CONFIGURE_WRAPPER: "" + GIT_SUBMODULE_STRATEGY: "normal" # Makes ci.sh isolate CABAL_DIR diff --git a/.gitlab/ci.sh b/.gitlab/ci.sh index 217440bbaf..b840500aa4 100755 --- a/.gitlab/ci.sh +++ b/.gitlab/ci.sh @@ -65,6 +65,7 @@ Environment variables affecting both build systems: "decreases", or "all") HERMETIC Take measures to avoid looking at anything in \$HOME CONFIGURE_ARGS Arguments passed to configure script. + CONFIGURE_WRAPPER Wrapper for the configure script (e.g. Emscripten's emconfigure). ENABLE_NUMA Whether to enable numa support for the build (disabled by default) INSTALL_CONFIGURE_ARGS Arguments passed to the binary distribution configure script @@ -249,6 +250,11 @@ function setup() { cp -Rf "$CABAL_CACHE"/* "$CABAL_DIR" fi + case "${CONFIGURE_WRAPPER:-}" in + emconfigure) time_it "setup" setup_emscripten ;; + *) ;; + esac + case $toolchain_source in extracted) time_it "setup" setup_toolchain ;; *) ;; @@ -365,6 +371,14 @@ function setup_toolchain() { $cabal_install alex --constraint="alex>=$MIN_ALEX_VERSION" } +function setup_emscripten() { + git clone https://github.com/emscripten-core/emsdk.git + cd emsdk + ./emsdk install latest + ./emsdk activate latest + cd .. +} + function cleanup_submodules() { start_section "clean submodules" if [ -d .git ]; then @@ -402,6 +416,11 @@ EOF } function configure() { + case "${CONFIGURE_WRAPPER:-}" in + emconfigure) source emsdk/emsdk_env.sh ;; + *) ;; + esac + if [[ -z "${NO_BOOT:-}" ]]; then start_section "booting" run python3 boot @@ -421,7 +440,7 @@ function configure() { start_section "configuring" # See https://stackoverflow.com/questions/7577052 for a rationale for the # args[@] symbol-soup below. - run ./configure \ + run ${CONFIGURE_WRAPPER:-} ./configure \ --enable-tarballs-autodownload \ "${args[@]+"${args[@]}"}" \ GHC="$GHC" \ @@ -528,6 +547,11 @@ function make_install_destdir() { # install the binary distribution in directory $1 to $2. function install_bindist() { + case "${CONFIGURE_WRAPPER:-}" in + emconfigure) source emsdk/emsdk_env.sh ;; + *) ;; + esac + local bindist="$1" local instdir="$2" pushd "$bindist" @@ -545,7 +569,7 @@ function install_bindist() { args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" ) fi - run ./configure \ + run ${CONFIGURE_WRAPPER:-} ./configure \ --prefix="$instdir" \ "${args[@]+"${args[@]}"}" make_install_destdir "$TOP"/destdir "$instdir" @@ -575,19 +599,17 @@ function test_hadrian() { fi - if [ -n "${CROSS_TARGET:-}" ]; then - if [ -n "${CROSS_EMULATOR:-}" ]; then - local instdir="$TOP/_build/install" - local test_compiler="$instdir/bin/${cross_prefix}ghc$exe" - install_bindist _build/bindist/ghc-*/ "$instdir" - echo 'main = putStrLn "hello world"' > expected - run "$test_compiler" -package ghc "$TOP/.gitlab/hello.hs" -o hello - $CROSS_EMULATOR ./hello > actual - run diff expected actual - else - info "Cannot test cross-compiled build without CROSS_EMULATOR being set." - return - fi + if [[ "${CROSS_EMULATOR:-}" == "NOT_SET" ]]; then + info "Cannot test cross-compiled build without CROSS_EMULATOR being set." + return + elif [ -n "${CROSS_TARGET:-}" ]; then + local instdir="$TOP/_build/install" + local test_compiler="$instdir/bin/${cross_prefix}ghc$exe" + install_bindist _build/bindist/ghc-*/ "$instdir" + echo 'main = putStrLn "hello world"' > expected + run "$test_compiler" -package ghc "$TOP/.gitlab/hello.hs" -o hello + ${CROSS_EMULATOR:-} ./hello > actual + run diff expected actual elif [[ -n "${REINSTALL_GHC:-}" ]]; then run_hadrian \ test \ @@ -598,10 +620,11 @@ function test_hadrian() { "runtest.opts+=${RUNTEST_ARGS:-}" || fail "hadrian cabal-install test" else local instdir="$TOP/_build/install" - local test_compiler="$instdir/bin/ghc$exe" + local test_compiler="$instdir/bin/${cross_prefix}ghc$exe" install_bindist _build/bindist/ghc-*/ "$instdir" - if [[ "${WINDOWS_HOST}" == "no" ]]; then + if [[ "${WINDOWS_HOST}" == "no" ]] && [ -z "${CROSS_TARGET:-}" ] + then run_hadrian \ test \ --test-root-dirs=testsuite/tests/stage1 \ @@ -610,10 +633,14 @@ function test_hadrian() { info "STAGE1_TEST=$?" fi - # Ensure the resulting compiler has the correct bignum-flavour - test_compiler_backend=$(${test_compiler} -e "GHC.Num.Backend.backendName") - if [ $test_compiler_backend != "\"$BIGNUM_BACKEND\"" ]; then - fail "Test compiler has a different BIGNUM_BACKEND ($test_compiler_backend) thean requested ($BIGNUM_BACKEND)" + # Ensure the resulting compiler has the correct bignum-flavour, + # except for cross-compilers as they may not support the interpreter + if [ -z "${CROSS_TARGET:-}" ] + then + test_compiler_backend=$(${test_compiler} -e "GHC.Num.Backend.backendName") + if [ $test_compiler_backend != "\"$BIGNUM_BACKEND\"" ]; then + fail "Test compiler has a different BIGNUM_BACKEND ($test_compiler_backend) thean requested ($BIGNUM_BACKEND)" + fi fi # If we are doing a release job, check the compiler can build a profiled executable diff --git a/.gitlab/gen_ci.hs b/.gitlab/gen_ci.hs index db338b88d4..bf2ad41025 100755 --- a/.gitlab/gen_ci.hs +++ b/.gitlab/gen_ci.hs @@ -109,6 +109,11 @@ bignumString :: BignumBackend -> String bignumString Gmp = "gmp" bignumString Native = "native" +data CrossEmulator + = NoEmulator + | NoEmulatorNeeded + | Emulator String + -- | A BuildConfig records all the options which can be modified to affect the -- bindists produced by the compiler. data BuildConfig @@ -120,7 +125,8 @@ data BuildConfig , withAssertions :: Bool , withNuma :: Bool , crossTarget :: Maybe String - , crossEmulator :: Maybe String + , crossEmulator :: CrossEmulator + , configureWrapper :: Maybe String , fullyStatic :: Bool , tablesNextToCode :: Bool , threadSanitiser :: Bool @@ -163,7 +169,8 @@ vanilla = BuildConfig , withAssertions = False , withNuma = False , crossTarget = Nothing - , crossEmulator = Nothing + , crossEmulator = NoEmulator + , configureWrapper = Nothing , fullyStatic = False , tablesNextToCode = True , threadSanitiser = False @@ -195,11 +202,13 @@ staticNativeInt :: BuildConfig staticNativeInt = static { bignumBackend = Native } crossConfig :: String -- ^ target triple - -> Maybe String -- ^ emulator for testing + -> CrossEmulator -- ^ emulator for testing + -> Maybe String -- ^ Configure wrapper -> BuildConfig -crossConfig triple emulator = +crossConfig triple emulator configure_wrapper = vanilla { crossTarget = Just triple , crossEmulator = emulator + , configureWrapper = configure_wrapper } llvm :: BuildConfig @@ -636,8 +645,14 @@ job arch opsys buildConfig = (jobName, Job {..}) , "BUILD_FLAVOUR" =: flavourString jobFlavour , "BIGNUM_BACKEND" =: bignumString (bignumBackend buildConfig) , "CONFIGURE_ARGS" =: configureArgsStr buildConfig + , maybe mempty ("CONFIGURE_WRAPPER" =:) (configureWrapper buildConfig) , maybe mempty ("CROSS_TARGET" =:) (crossTarget buildConfig) - , maybe mempty ("CROSS_EMULATOR" =:) (crossEmulator buildConfig) + , case crossEmulator buildConfig of + NoEmulator -> case crossTarget buildConfig of + Nothing -> mempty + Just _ -> "CROSS_EMULATOR" =: "NOT_SET" -- we need an emulator but it isn't set. Won't run the testsuite + Emulator s -> "CROSS_EMULATOR" =: s + NoEmulatorNeeded -> mempty , if withNuma buildConfig then "ENABLE_NUMA" =: "1" else mempty ] @@ -813,7 +828,11 @@ jobs = Map.fromList $ concatMap flattenJobGroup $ , standardBuilds I386 (Linux Debian9) , allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) static) , disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt)) - , validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Just "qemu-aarch64 -L /usr/aarch64-linux-gnu")) + , validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing) + , validateBuilds Amd64 (Linux Debian11) (crossConfig "js-unknown-ghcjs" NoEmulatorNeeded (Just "emconfigure") + ) + { bignumBackend = Native + } ] where diff --git a/.gitlab/jobs.yaml b/.gitlab/jobs.yaml index 07e91da267..fafb8c9357 100644 --- a/.gitlab/jobs.yaml +++ b/.gitlab/jobs.yaml @@ -1328,6 +1328,67 @@ "XZ_OPT": "-9" } }, + "nightly-x86_64-linux-deb11-int_native-cross_js-unknown-ghcjs-validate": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh clean", + "cat ci_timings" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "8 weeks", + "paths": [ + "ghc-x86_64-linux-deb11-int_native-cross_js-unknown-ghcjs-validate.tar.xz", + "junit.xml" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-deb11-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb11:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "native", + "BIN_DIST_NAME": "ghc-x86_64-linux-deb11-int_native-cross_js-unknown-ghcjs-validate", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--with-intree-gmp", + "CONFIGURE_WRAPPER": "emconfigure", + "CROSS_TARGET": "js-unknown-ghcjs", + "TEST_ENV": "x86_64-linux-deb11-int_native-cross_js-unknown-ghcjs-validate", + "XZ_OPT": "-9" + } + }, "nightly-x86_64-linux-deb11-validate": { "after_script": [ ".gitlab/ci.sh save_cache", @@ -3810,6 +3871,66 @@ "TEST_ENV": "x86_64-linux-deb11-cross_aarch64-linux-gnu-validate" } }, + "x86_64-linux-deb11-int_native-cross_js-unknown-ghcjs-validate": { + "after_script": [ + ".gitlab/ci.sh save_cache", + ".gitlab/ci.sh clean", + "cat ci_timings" + ], + "allow_failure": false, + "artifacts": { + "expire_in": "2 weeks", + "paths": [ + "ghc-x86_64-linux-deb11-int_native-cross_js-unknown-ghcjs-validate.tar.xz", + "junit.xml" + ], + "reports": { + "junit": "junit.xml" + }, + "when": "always" + }, + "cache": { + "key": "x86_64-linux-deb11-$CACHE_REV", + "paths": [ + "cabal-cache", + "toolchain" + ] + }, + "dependencies": [], + "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb11:$DOCKER_REV", + "needs": [ + { + "artifacts": false, + "job": "hadrian-ghc-in-ghci" + } + ], + "rules": [ + { + "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")", + "when": "on_success" + } + ], + "script": [ + "sudo chown ghc:ghc -R .", + ".gitlab/ci.sh setup", + ".gitlab/ci.sh configure", + ".gitlab/ci.sh build_hadrian", + ".gitlab/ci.sh test_hadrian" + ], + "stage": "full-build", + "tags": [ + "x86_64-linux" + ], + "variables": { + "BIGNUM_BACKEND": "native", + "BIN_DIST_NAME": "ghc-x86_64-linux-deb11-int_native-cross_js-unknown-ghcjs-validate", + "BUILD_FLAVOUR": "validate", + "CONFIGURE_ARGS": "--with-intree-gmp", + "CONFIGURE_WRAPPER": "emconfigure", + "CROSS_TARGET": "js-unknown-ghcjs", + "TEST_ENV": "x86_64-linux-deb11-int_native-cross_js-unknown-ghcjs-validate" + } + }, "x86_64-linux-deb11-validate": { "after_script": [ ".gitlab/ci.sh save_cache", diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 8b4fc099cd..c9f0d56aaf 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module GHC.Builtin.PrimOps ( PrimOp(..), PrimOpVecCat(..), allThePrimOps, @@ -18,7 +19,7 @@ module GHC.Builtin.PrimOps ( primOpOutOfLine, primOpCodeSize, primOpOkForSpeculation, primOpOkForSideEffects, primOpIsCheap, primOpFixity, primOpDocs, - primOpIsDiv, + primOpIsDiv, primOpIsReallyInline, getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), @@ -807,3 +808,12 @@ data PrimCall = PrimCall CLabelString Unit instance Outputable PrimCall where ppr (PrimCall lbl pkgId) = text "__primcall" <+> ppr pkgId <+> ppr lbl + +-- | Indicate if a primop is really inline: that is, it isn't out-of-line and it +-- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- hence induce thread/stack/heap changes. +primOpIsReallyInline :: PrimOp -> Bool +primOpIsReallyInline = \case + SeqOp -> False + DataToTagOp -> False + p -> not (primOpOutOfLine p) diff --git a/compiler/GHC/Data/Graph/Directed.hs b/compiler/GHC/Data/Graph/Directed.hs index 2e1d13bec5..74e619ef90 100644 --- a/compiler/GHC/Data/Graph/Directed.hs +++ b/compiler/GHC/Data/Graph/Directed.hs @@ -7,6 +7,7 @@ module GHC.Data.Graph.Directed ( Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, + graphFromVerticesAndAdjacency, SCC(..), Node(..), flattenSCC, flattenSCCs, stronglyConnCompG, @@ -547,3 +548,21 @@ classifyEdges root getSucc edges = ends'' = addToUFM ends' n time'' in (time'' + 1, starts'', ends'') + +graphFromVerticesAndAdjacency + :: Ord key + => [Node key payload] + -> [(key, key)] -- First component is source vertex key, + -- second is target vertex key (thing depended on) + -- Unlike the other interface I insist they correspond to + -- actual vertices because the alternative hides bugs. I can't + -- do the same thing for the other one for backcompat reasons. + -> Graph (Node key payload) +graphFromVerticesAndAdjacency [] _ = emptyGraph +graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) + where key_extractor = node_key + (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVerticesOrd vertices key_extractor + key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, + expectJust "graphFromVerticesAndAdjacency" $ key_vertex b) + reduced_edges = map key_vertex_pair edges + graph = buildG bounds reduced_edges diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs index 776e5eb675..b02d5c76f4 100644 --- a/compiler/GHC/Driver/Backend.hs +++ b/compiler/GHC/Driver/Backend.hs @@ -45,6 +45,7 @@ module GHC.Driver.Backend -- * Available back ends , ncgBackend , llvmBackend + , jsBackend , viaCBackend , interpreterBackend , noBackend @@ -96,6 +97,7 @@ module GHC.Driver.Backend , backendAssemblerInfoGetter , backendCDefs , backendCodeOutput + , backendUseJSLinker , backendPostHscPipeline , backendNormalSuccessorPhase , backendName @@ -193,12 +195,11 @@ import GHC.Platform --------------------------------------------------------------------------------- - - platformDefaultBackend :: Platform -> Backend platformDefaultBackend platform = if | platformUnregisterised platform -> viaCBackend | platformNcgSupported platform -> ncgBackend + | platformJSSupported platform -> jsBackend | otherwise -> llvmBackend -- | Is the platform supported by the Native Code Generator? @@ -217,6 +218,11 @@ platformNcgSupported platform = if ArchWasm32 -> True _ -> False +-- | Is the platform supported by the JS backend? +platformJSSupported :: Platform -> Bool +platformJSSupported platform + | platformArch platform == ArchJavaScript = True + | otherwise = False -- | A value of type @Backend@ represents one of GHC's back ends. @@ -247,7 +253,7 @@ instance Show Backend where show = backendDescription -ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend +ncgBackend, llvmBackend, viaCBackend, interpreterBackend, jsBackend, noBackend :: Backend -- | The native code generator. @@ -274,6 +280,11 @@ ncgBackend = Named NCG -- See "GHC.CmmToLlvm" llvmBackend = Named LLVM +-- | The JavaScript Backend +-- +-- See documentation in GHC.StgToJS +jsBackend = Named JavaScript + -- | Via-C ("unregisterised") backend. -- -- Compiles Cmm code into C code, then relies on a C compiler @@ -329,8 +340,9 @@ noBackend = Named NoBackend -- it without mutual recursion across module boundaries.) data PrimitiveImplementation - = LlvmPrimitives -- ^ Primitives supported by LLVM - | NcgPrimitives -- ^ Primitives supported by the native code generator + = LlvmPrimitives -- ^ Primitives supported by LLVM + | NcgPrimitives -- ^ Primitives supported by the native code generator + | JSPrimitives -- ^ Primitives supported by JS backend | GenericPrimitives -- ^ Primitives supported by all back ends deriving Show @@ -344,6 +356,8 @@ data PrimitiveImplementation data DefunctionalizedAssemblerProg = StandardAssemblerProg -- ^ Use the standard system assembler + | JSAssemblerProg + -- ^ JS Backend compile to JS via Stg, and so does not use any assembler | DarwinClangAssemblerProg -- ^ If running on Darwin, use the assembler from the @clang@ -- toolchain. Otherwise use the standard system assembler. @@ -360,6 +374,8 @@ data DefunctionalizedAssemblerProg data DefunctionalizedAssemblerInfoGetter = StandardAssemblerInfoGetter -- ^ Interrogate the standard system assembler + | JSAssemblerInfoGetter + -- ^ If using the JS backend; return 'Emscripten' | DarwinClangAssemblerInfoGetter -- ^ If running on Darwin, return `Clang`; otherwise -- interrogate the standard system assembler. @@ -387,6 +403,7 @@ data DefunctionalizedCodeOutput = NcgCodeOutput | ViaCCodeOutput | LlvmCodeOutput + | JSCodeOutput -- | Names a function that tells the driver what should happen after @@ -407,6 +424,7 @@ data DefunctionalizedPostHscPipeline = NcgPostHscPipeline | ViaCPostHscPipeline | LlvmPostHscPipeline + | JSPostHscPipeline | NoPostHscPipeline -- ^ After code generation, nothing else need happen. -- | Names a function that tells the driver what command-line options @@ -432,42 +450,46 @@ data DefunctionalizedCDefs -- issuing warning messages /only/. If code depends on -- what's in the string, you deserve what happens to you. backendDescription :: Backend -> String -backendDescription (Named NCG) = "native code generator" -backendDescription (Named LLVM) = "LLVM" -backendDescription (Named ViaC) = "compiling via C" +backendDescription (Named NCG) = "native code generator" +backendDescription (Named LLVM) = "LLVM" +backendDescription (Named ViaC) = "compiling via C" +backendDescription (Named JavaScript) = "compiling to JavaScript" backendDescription (Named Interpreter) = "byte-code interpreter" -backendDescription (Named NoBackend) = "no code generated" +backendDescription (Named NoBackend) = "no code generated" -- | This flag tells the compiler driver whether the back -- end will write files: interface files and object files. -- It is typically true for "real" back ends that generate -- code into the filesystem. (That means, not the interpreter.) backendWritesFiles :: Backend -> Bool -backendWritesFiles (Named NCG) = True -backendWritesFiles (Named LLVM) = True -backendWritesFiles (Named ViaC) = True +backendWritesFiles (Named NCG) = True +backendWritesFiles (Named LLVM) = True +backendWritesFiles (Named ViaC) = True +backendWritesFiles (Named JavaScript) = True backendWritesFiles (Named Interpreter) = False -backendWritesFiles (Named NoBackend) = False +backendWritesFiles (Named NoBackend) = False -- | When the back end does write files, this value tells -- the compiler in what manner of file the output should go: -- temporary, persistent, or specific. backendPipelineOutput :: Backend -> PipelineOutput -backendPipelineOutput (Named NCG) = Persistent +backendPipelineOutput (Named NCG) = Persistent backendPipelineOutput (Named LLVM) = Persistent backendPipelineOutput (Named ViaC) = Persistent +backendPipelineOutput (Named JavaScript) = Persistent backendPipelineOutput (Named Interpreter) = NoOutputFile -backendPipelineOutput (Named NoBackend) = NoOutputFile +backendPipelineOutput (Named NoBackend) = NoOutputFile -- | This flag tells the driver whether the back end can -- reuse code (bytecode or object code) that has been -- loaded dynamically. Likely true only of the interpreter. backendCanReuseLoadedCode :: Backend -> Bool -backendCanReuseLoadedCode (Named NCG) = False -backendCanReuseLoadedCode (Named LLVM) = False -backendCanReuseLoadedCode (Named ViaC) = False +backendCanReuseLoadedCode (Named NCG) = False +backendCanReuseLoadedCode (Named LLVM) = False +backendCanReuseLoadedCode (Named ViaC) = False +backendCanReuseLoadedCode (Named JavaScript) = False backendCanReuseLoadedCode (Named Interpreter) = True -backendCanReuseLoadedCode (Named NoBackend) = False +backendCanReuseLoadedCode (Named NoBackend) = False -- | It is is true of every back end except @-fno-code@ -- that it "generates code." Surprisingly, this property @@ -487,33 +509,36 @@ backendCanReuseLoadedCode (Named NoBackend) = False -- to date). -- backendGeneratesCode :: Backend -> Bool -backendGeneratesCode (Named NCG) = True -backendGeneratesCode (Named LLVM) = True -backendGeneratesCode (Named ViaC) = True +backendGeneratesCode (Named NCG) = True +backendGeneratesCode (Named LLVM) = True +backendGeneratesCode (Named ViaC) = True +backendGeneratesCode (Named JavaScript) = True backendGeneratesCode (Named Interpreter) = True -backendGeneratesCode (Named NoBackend) = False +backendGeneratesCode (Named NoBackend) = False -- | When set, this flag turns on interface writing for -- Backpack. It should probably be the same as -- `backendGeneratesCode`, but it is kept distinct for -- reasons described in Note [-fno-code mode]. backendSupportsInterfaceWriting :: Backend -> Bool -backendSupportsInterfaceWriting (Named NCG) = True -backendSupportsInterfaceWriting (Named LLVM) = True -backendSupportsInterfaceWriting (Named ViaC) = True +backendSupportsInterfaceWriting (Named NCG) = True +backendSupportsInterfaceWriting (Named LLVM) = True +backendSupportsInterfaceWriting (Named ViaC) = True +backendSupportsInterfaceWriting (Named JavaScript) = True backendSupportsInterfaceWriting (Named Interpreter) = True -backendSupportsInterfaceWriting (Named NoBackend) = False +backendSupportsInterfaceWriting (Named NoBackend) = False -- | When preparing code for this back end, the type -- checker should pay attention to SPECIALISE pragmas. If -- this flag is `False`, then the type checker ignores -- SPECIALISE pragmas (for imported things?). backendRespectsSpecialise :: Backend -> Bool -backendRespectsSpecialise (Named NCG) = True -backendRespectsSpecialise (Named LLVM) = True -backendRespectsSpecialise (Named ViaC) = True +backendRespectsSpecialise (Named NCG) = True +backendRespectsSpecialise (Named LLVM) = True +backendRespectsSpecialise (Named ViaC) = True +backendRespectsSpecialise (Named JavaScript) = True backendRespectsSpecialise (Named Interpreter) = False -backendRespectsSpecialise (Named NoBackend) = False +backendRespectsSpecialise (Named NoBackend) = False -- | This back end wants the `mi_globals` field of a -- `ModIface` to be populated (with the top-level bindings @@ -522,11 +547,12 @@ backendRespectsSpecialise (Named NoBackend) = False -- (After typechecking a module, Haddock wants access to -- the module's `GlobalRdrEnv`.) backendWantsGlobalBindings :: Backend -> Bool -backendWantsGlobalBindings (Named NCG) = False -backendWantsGlobalBindings (Named LLVM) = False -backendWantsGlobalBindings (Named ViaC) = False +backendWantsGlobalBindings (Named NCG) = False +backendWantsGlobalBindings (Named LLVM) = False +backendWantsGlobalBindings (Named ViaC) = False +backendWantsGlobalBindings (Named JavaScript) = False backendWantsGlobalBindings (Named Interpreter) = True -backendWantsGlobalBindings (Named NoBackend) = True +backendWantsGlobalBindings (Named NoBackend) = True -- | The back end targets a technology that implements -- `switch` natively. (For example, LLVM or C.) Therefore @@ -534,11 +560,12 @@ backendWantsGlobalBindings (Named NoBackend) = True -- form into a decision tree with jump tables at the -- leaves. backendHasNativeSwitch :: Backend -> Bool -backendHasNativeSwitch (Named NCG) = False -backendHasNativeSwitch (Named LLVM) = True -backendHasNativeSwitch (Named ViaC) = True +backendHasNativeSwitch (Named NCG) = False +backendHasNativeSwitch (Named LLVM) = True +backendHasNativeSwitch (Named ViaC) = True +backendHasNativeSwitch (Named JavaScript) = True backendHasNativeSwitch (Named Interpreter) = False -backendHasNativeSwitch (Named NoBackend) = False +backendHasNativeSwitch (Named NoBackend) = False -- | As noted in the documentation for -- `PrimitiveImplementation`, certain primitives have @@ -547,32 +574,35 @@ backendHasNativeSwitch (Named NoBackend) = False -- "GHC.StgToCmm.Prim" what implementations to use with -- this back end. backendPrimitiveImplementation :: Backend -> PrimitiveImplementation -backendPrimitiveImplementation (Named NCG) = NcgPrimitives -backendPrimitiveImplementation (Named LLVM) = LlvmPrimitives -backendPrimitiveImplementation (Named ViaC) = GenericPrimitives +backendPrimitiveImplementation (Named NCG) = NcgPrimitives +backendPrimitiveImplementation (Named LLVM) = LlvmPrimitives +backendPrimitiveImplementation (Named JavaScript) = JSPrimitives +backendPrimitiveImplementation (Named ViaC) = GenericPrimitives backendPrimitiveImplementation (Named Interpreter) = GenericPrimitives -backendPrimitiveImplementation (Named NoBackend) = GenericPrimitives +backendPrimitiveImplementation (Named NoBackend) = GenericPrimitives -- | When this value is `IsValid`, the back end is -- compatible with vector instructions. When it is -- `NotValid`, it carries a message that is shown to -- users. backendSimdValidity :: Backend -> Validity' String -backendSimdValidity (Named NCG) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] -backendSimdValidity (Named LLVM) = IsValid -backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named NCG) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named LLVM) = IsValid +backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named JavaScript) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] -backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] -- | This flag says whether the back end supports large -- binary blobs. See Note [Embedding large binary blobs] -- in "GHC.CmmToAsm.Ppr". backendSupportsEmbeddedBlobs :: Backend -> Bool -backendSupportsEmbeddedBlobs (Named NCG) = True -backendSupportsEmbeddedBlobs (Named LLVM) = False -backendSupportsEmbeddedBlobs (Named ViaC) = False +backendSupportsEmbeddedBlobs (Named NCG) = True +backendSupportsEmbeddedBlobs (Named LLVM) = False +backendSupportsEmbeddedBlobs (Named ViaC) = False +backendSupportsEmbeddedBlobs (Named JavaScript) = False backendSupportsEmbeddedBlobs (Named Interpreter) = False -backendSupportsEmbeddedBlobs (Named NoBackend) = False +backendSupportsEmbeddedBlobs (Named NoBackend) = False -- | This flag tells the compiler driver that the back end -- does not support every target platform; it supports @@ -582,22 +612,24 @@ backendSupportsEmbeddedBlobs (Named NoBackend) = False -- platform support, the driver fails over to the LLVM -- back end. backendNeedsPlatformNcgSupport :: Backend -> Bool -backendNeedsPlatformNcgSupport (Named NCG) = True -backendNeedsPlatformNcgSupport (Named LLVM) = False -backendNeedsPlatformNcgSupport (Named ViaC) = False +backendNeedsPlatformNcgSupport (Named NCG) = True +backendNeedsPlatformNcgSupport (Named LLVM) = False +backendNeedsPlatformNcgSupport (Named ViaC) = False +backendNeedsPlatformNcgSupport (Named JavaScript) = False backendNeedsPlatformNcgSupport (Named Interpreter) = False -backendNeedsPlatformNcgSupport (Named NoBackend) = False +backendNeedsPlatformNcgSupport (Named NoBackend) = False -- | This flag is set if the back end can generate code -- for proc points. If the flag is not set, then a Cmm -- pass needs to split proc points (that is, turn each -- proc point into a standalone procedure). backendSupportsUnsplitProcPoints :: Backend -> Bool -backendSupportsUnsplitProcPoints (Named NCG) = True -backendSupportsUnsplitProcPoints (Named LLVM) = False -backendSupportsUnsplitProcPoints (Named ViaC) = False +backendSupportsUnsplitProcPoints (Named NCG) = True +backendSupportsUnsplitProcPoints (Named LLVM) = False +backendSupportsUnsplitProcPoints (Named ViaC) = False +backendSupportsUnsplitProcPoints (Named JavaScript) = False backendSupportsUnsplitProcPoints (Named Interpreter) = False -backendSupportsUnsplitProcPoints (Named NoBackend) = False +backendSupportsUnsplitProcPoints (Named NoBackend) = False -- | This flag guides the driver in resolving issues about -- API support on the target platform. If the flag is set, @@ -610,113 +642,124 @@ backendSupportsUnsplitProcPoints (Named NoBackend) = False -- this back end can replace compilation via C. -- backendSwappableWithViaC :: Backend -> Bool -backendSwappableWithViaC (Named NCG) = True -backendSwappableWithViaC (Named LLVM) = True -backendSwappableWithViaC (Named ViaC) = False +backendSwappableWithViaC (Named NCG) = True +backendSwappableWithViaC (Named LLVM) = True +backendSwappableWithViaC (Named ViaC) = False +backendSwappableWithViaC (Named JavaScript) = False backendSwappableWithViaC (Named Interpreter) = False -backendSwappableWithViaC (Named NoBackend) = False +backendSwappableWithViaC (Named NoBackend) = False -- | This flag is true if the back end works *only* with -- the unregisterised ABI. backendUnregisterisedAbiOnly :: Backend -> Bool -backendUnregisterisedAbiOnly (Named NCG) = False -backendUnregisterisedAbiOnly (Named LLVM) = False -backendUnregisterisedAbiOnly (Named ViaC) = True +backendUnregisterisedAbiOnly (Named NCG) = False +backendUnregisterisedAbiOnly (Named LLVM) = False +backendUnregisterisedAbiOnly (Named ViaC) = True +backendUnregisterisedAbiOnly (Named JavaScript) = False backendUnregisterisedAbiOnly (Named Interpreter) = False -backendUnregisterisedAbiOnly (Named NoBackend) = False +backendUnregisterisedAbiOnly (Named NoBackend) = False -- | This flag is set if the back end generates C code in -- a @.hc@ file. The flag lets the compiler driver know -- if the command-line flag @-C@ is meaningful. backendGeneratesHc :: Backend -> Bool -backendGeneratesHc (Named NCG) = False -backendGeneratesHc (Named LLVM) = False -backendGeneratesHc (Named ViaC) = True +backendGeneratesHc (Named NCG) = False +backendGeneratesHc (Named LLVM) = False +backendGeneratesHc (Named ViaC) = True +backendGeneratesHc (Named JavaScript) = False backendGeneratesHc (Named Interpreter) = False -backendGeneratesHc (Named NoBackend) = False +backendGeneratesHc (Named NoBackend) = False -- | This flag says whether SPT (static pointer table) -- entries will be inserted dynamically if needed. If -- this flag is `False`, then "GHC.Iface.Tidy" should emit C -- stubs that initialize the SPT entries. backendSptIsDynamic :: Backend -> Bool -backendSptIsDynamic (Named NCG) = False -backendSptIsDynamic (Named LLVM) = False -backendSptIsDynamic (Named ViaC) = False +backendSptIsDynamic (Named NCG) = False +backendSptIsDynamic (Named LLVM) = False +backendSptIsDynamic (Named ViaC) = False +backendSptIsDynamic (Named JavaScript) = False backendSptIsDynamic (Named Interpreter) = True -backendSptIsDynamic (Named NoBackend) = False +backendSptIsDynamic (Named NoBackend) = False -- | If this flag is set, then "GHC.HsToCore.Ticks" -- inserts `Breakpoint` ticks. Used only for the -- interpreter. backendWantsBreakpointTicks :: Backend -> Bool -backendWantsBreakpointTicks (Named NCG) = False -backendWantsBreakpointTicks (Named LLVM) = False -backendWantsBreakpointTicks (Named ViaC) = False +backendWantsBreakpointTicks (Named NCG) = False +backendWantsBreakpointTicks (Named LLVM) = False +backendWantsBreakpointTicks (Named ViaC) = False +backendWantsBreakpointTicks (Named JavaScript) = False backendWantsBreakpointTicks (Named Interpreter) = True -backendWantsBreakpointTicks (Named NoBackend) = False +backendWantsBreakpointTicks (Named NoBackend) = False -- | If this flag is set, then the driver forces the -- optimization level to 0, issuing a warning message if -- the command line requested a higher optimization level. backendForcesOptimization0 :: Backend -> Bool -backendForcesOptimization0 (Named NCG) = False -backendForcesOptimization0 (Named LLVM) = False -backendForcesOptimization0 (Named ViaC) = False +backendForcesOptimization0 (Named NCG) = False +backendForcesOptimization0 (Named LLVM) = False +backendForcesOptimization0 (Named ViaC) = False +backendForcesOptimization0 (Named JavaScript) = False backendForcesOptimization0 (Named Interpreter) = True -backendForcesOptimization0 (Named NoBackend) = False +backendForcesOptimization0 (Named NoBackend) = False -- | I don't understand exactly how this works. But if -- this flag is set *and* another condition is met, then -- @ghc/Main.hs@ will alter the `DynFlags` so that all the -- `hostFullWays` are asked for. It is set only for the interpreter. backendNeedsFullWays :: Backend -> Bool -backendNeedsFullWays (Named NCG) = False -backendNeedsFullWays (Named LLVM) = False -backendNeedsFullWays (Named ViaC) = False +backendNeedsFullWays (Named NCG) = False +backendNeedsFullWays (Named LLVM) = False +backendNeedsFullWays (Named ViaC) = False +backendNeedsFullWays (Named JavaScript) = False backendNeedsFullWays (Named Interpreter) = True -backendNeedsFullWays (Named NoBackend) = False +backendNeedsFullWays (Named NoBackend) = False -- | This flag is also special for the interpreter: if a -- message about a module needs to be shown, do we know -- anything special about where the module came from? The -- Boolean argument is a `recomp` flag. backendSpecialModuleSource :: Backend -> Bool -> Maybe String -backendSpecialModuleSource (Named NCG) = const Nothing -backendSpecialModuleSource (Named LLVM) = const Nothing -backendSpecialModuleSource (Named ViaC) = const Nothing +backendSpecialModuleSource (Named NCG) = const Nothing +backendSpecialModuleSource (Named LLVM) = const Nothing +backendSpecialModuleSource (Named ViaC) = const Nothing +backendSpecialModuleSource (Named JavaScript) = const Nothing backendSpecialModuleSource (Named Interpreter) = \b -> if b then Just "interpreted" else Nothing -backendSpecialModuleSource (Named NoBackend) = const (Just "nothing") +backendSpecialModuleSource (Named NoBackend) = const (Just "nothing") -- | This flag says whether the back end supports Haskell -- Program Coverage (HPC). If not, the compiler driver -- will ignore the `-fhpc` option (and will issue a -- warning message if it is used). backendSupportsHpc :: Backend -> Bool -backendSupportsHpc (Named NCG) = True -backendSupportsHpc (Named LLVM) = True -backendSupportsHpc (Named ViaC) = True +backendSupportsHpc (Named NCG) = True +backendSupportsHpc (Named LLVM) = True +backendSupportsHpc (Named ViaC) = True +backendSupportsHpc (Named JavaScript) = False backendSupportsHpc (Named Interpreter) = False -backendSupportsHpc (Named NoBackend) = True +backendSupportsHpc (Named NoBackend) = True -- | This flag says whether the back end supports foreign -- import of C functions. ("Supports" means "does not -- barf on," so @-fno-code@ supports foreign C imports.) backendSupportsCImport :: Backend -> Bool -backendSupportsCImport (Named NCG) = True -backendSupportsCImport (Named LLVM) = True -backendSupportsCImport (Named ViaC) = True +backendSupportsCImport (Named NCG) = True +backendSupportsCImport (Named LLVM) = True +backendSupportsCImport (Named ViaC) = True +backendSupportsCImport (Named JavaScript) = True backendSupportsCImport (Named Interpreter) = True -backendSupportsCImport (Named NoBackend) = True +backendSupportsCImport (Named NoBackend) = True -- | This flag says whether the back end supports foreign -- export of Haskell functions to C. backendSupportsCExport :: Backend -> Bool -backendSupportsCExport (Named NCG) = True -backendSupportsCExport (Named LLVM) = True -backendSupportsCExport (Named ViaC) = True +backendSupportsCExport (Named NCG) = True +backendSupportsCExport (Named LLVM) = True +backendSupportsCExport (Named ViaC) = True +backendSupportsCExport (Named JavaScript) = True backendSupportsCExport (Named Interpreter) = False -backendSupportsCExport (Named NoBackend) = True +backendSupportsCExport (Named NoBackend) = True -- | This (defunctionalized) function runs the assembler -- used on the code that is written by this back end. A @@ -731,11 +774,12 @@ backendSupportsCExport (Named NoBackend) = True -- -- This field is usually defaulted. backendAssemblerProg :: Backend -> DefunctionalizedAssemblerProg -backendAssemblerProg (Named NCG) = StandardAssemblerProg +backendAssemblerProg (Named NCG) = StandardAssemblerProg backendAssemblerProg (Named LLVM) = DarwinClangAssemblerProg backendAssemblerProg (Named ViaC) = StandardAssemblerProg +backendAssemblerProg (Named JavaScript) = JSAssemblerProg backendAssemblerProg (Named Interpreter) = StandardAssemblerProg -backendAssemblerProg (Named NoBackend) = StandardAssemblerProg +backendAssemblerProg (Named NoBackend) = StandardAssemblerProg -- | This (defunctionalized) function is used to retrieve -- an enumeration value that characterizes the C/assembler @@ -749,11 +793,12 @@ backendAssemblerProg (Named NoBackend) = StandardAssemblerProg -- -- This field is usually defaulted. backendAssemblerInfoGetter :: Backend -> DefunctionalizedAssemblerInfoGetter -backendAssemblerInfoGetter (Named NCG) = StandardAssemblerInfoGetter -backendAssemblerInfoGetter (Named LLVM) = DarwinClangAssemblerInfoGetter -backendAssemblerInfoGetter (Named ViaC) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named NCG) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named LLVM) = DarwinClangAssemblerInfoGetter +backendAssemblerInfoGetter (Named ViaC) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named JavaScript) = JSAssemblerInfoGetter backendAssemblerInfoGetter (Named Interpreter) = StandardAssemblerInfoGetter -backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter -- | When using this back end, it may be necessary or -- advisable to pass some `-D` options to a C compiler. @@ -769,11 +814,12 @@ backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter -- -- This field is usually defaulted. backendCDefs :: Backend -> DefunctionalizedCDefs -backendCDefs (Named NCG) = NoCDefs -backendCDefs (Named LLVM) = LlvmCDefs -backendCDefs (Named ViaC) = NoCDefs +backendCDefs (Named NCG) = NoCDefs +backendCDefs (Named LLVM) = LlvmCDefs +backendCDefs (Named ViaC) = NoCDefs +backendCDefs (Named JavaScript) = NoCDefs backendCDefs (Named Interpreter) = NoCDefs -backendCDefs (Named NoBackend) = NoCDefs +backendCDefs (Named NoBackend) = NoCDefs -- | This (defunctionalized) function generates code and -- writes it to a file. The type of the function is @@ -787,11 +833,20 @@ backendCDefs (Named NoBackend) = NoCDefs -- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` -- > -> IO a backendCodeOutput :: Backend -> DefunctionalizedCodeOutput -backendCodeOutput (Named NCG) = NcgCodeOutput -backendCodeOutput (Named LLVM) = LlvmCodeOutput -backendCodeOutput (Named ViaC) = ViaCCodeOutput +backendCodeOutput (Named NCG) = NcgCodeOutput +backendCodeOutput (Named LLVM) = LlvmCodeOutput +backendCodeOutput (Named ViaC) = ViaCCodeOutput +backendCodeOutput (Named JavaScript) = JSCodeOutput backendCodeOutput (Named Interpreter) = panic "backendCodeOutput: interpreterBackend" -backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" +backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" + +backendUseJSLinker :: Backend -> Bool +backendUseJSLinker (Named NCG) = False +backendUseJSLinker (Named LLVM) = False +backendUseJSLinker (Named ViaC) = False +backendUseJSLinker (Named JavaScript) = True +backendUseJSLinker (Named Interpreter) = False +backendUseJSLinker (Named NoBackend) = False -- | This (defunctionalized) function tells the compiler -- driver what else has to be run after code output. @@ -805,9 +860,10 @@ backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" -- > -> FilePath -- > -> m (Maybe FilePath) backendPostHscPipeline :: Backend -> DefunctionalizedPostHscPipeline -backendPostHscPipeline (Named NCG) = NcgPostHscPipeline +backendPostHscPipeline (Named NCG) = NcgPostHscPipeline backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline +backendPostHscPipeline (Named JavaScript) = JSPostHscPipeline backendPostHscPipeline (Named Interpreter) = NoPostHscPipeline backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline @@ -818,21 +874,23 @@ backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline -- value gives instructions like "run the C compiler", -- "run the assembler," or "run the LLVM Optimizer." backendNormalSuccessorPhase :: Backend -> Phase -backendNormalSuccessorPhase (Named NCG) = As False +backendNormalSuccessorPhase (Named NCG) = As False backendNormalSuccessorPhase (Named LLVM) = LlvmOpt backendNormalSuccessorPhase (Named ViaC) = HCc +backendNormalSuccessorPhase (Named JavaScript) = StopLn backendNormalSuccessorPhase (Named Interpreter) = StopLn -backendNormalSuccessorPhase (Named NoBackend) = StopLn +backendNormalSuccessorPhase (Named NoBackend) = StopLn -- | Name of the back end, if any. Used to migrate legacy -- clients of the GHC API. Code within the GHC source -- tree should not refer to a back end's name. backendName :: Backend -> BackendName -backendName (Named NCG) = NCG +backendName (Named NCG) = NCG backendName (Named LLVM) = LLVM backendName (Named ViaC) = ViaC +backendName (Named JavaScript) = JavaScript backendName (Named Interpreter) = Interpreter -backendName (Named NoBackend) = NoBackend +backendName (Named NoBackend) = NoBackend @@ -843,6 +901,7 @@ allBackends :: [Backend] allBackends = [ ncgBackend , llvmBackend , viaCBackend + , jsBackend , interpreterBackend , noBackend ] @@ -911,7 +970,7 @@ Such a function may be applied in one of two ways: applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] @ - Function `applyCDefs` is defined in module "GHC.Driver.Pipeline.Execute". + Function `applyCDefs` is defined in module "GHC.SysTools.Cpp". I don't love this solution, but defunctionalization is a standard thing, and it makes the meanings of the enumeration values clear. diff --git a/compiler/GHC/Driver/Backend/Internal.hs b/compiler/GHC/Driver/Backend/Internal.hs index 99484b752e..596755dd1f 100644 --- a/compiler/GHC/Driver/Backend/Internal.hs +++ b/compiler/GHC/Driver/Backend/Internal.hs @@ -27,6 +27,7 @@ data BackendName = NCG -- ^ Names the native code generator backend. | LLVM -- ^ Names the LLVM backend. | ViaC -- ^ Names the Via-C backend. + | JavaScript -- ^ Names the JS backend. | Interpreter -- ^ Names the ByteCode interpreter. | NoBackend -- ^ Names the `-fno-code` backend. deriving (Eq, Show) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 2e56336cba..934d958120 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -28,9 +28,9 @@ import GHC.Cmm import GHC.Cmm.CLabel import GHC.Driver.Session -import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Driver.Config.CmmToAsm (initNCGConfig) -import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig) +import GHC.Driver.Config.Finder ( initFinderOpts ) +import GHC.Driver.Config.CmmToAsm ( initNCGConfig ) +import GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig ) import GHC.Driver.LlvmConfigCache (LlvmConfigCache) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -45,8 +45,9 @@ import GHC.Utils.TmpFs import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger -import GHC.Utils.Exception (bracket) +import GHC.Utils.Exception ( bracket ) import GHC.Utils.Ppr (Mode(..)) +import GHC.Utils.Panic.Plain ( pgmError ) import GHC.Unit import GHC.Unit.Finder ( mkStubPaths ) @@ -125,6 +126,7 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g final_stream ViaCCodeOutput -> outputC logger dflags filenm final_stream pkg_deps LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm final_stream + JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs ; return (filenm, stubs_exist, foreign_fps, a) } @@ -219,6 +221,18 @@ outputLlvm logger llvm_config dflags filenm cmm_stream = do {- ************************************************************************ * * +\subsection{JavaScript} +* * +************************************************************************ +-} +outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputJS _ _ _ _ _ = pgmError $ "codeOutput: Hit JavaScript case. We should never reach here!" + ++ "\nThe JS backend should shortcircuit to StgToJS after Stg." + ++ "\nIf you reached this point then you've somehow made it to Cmm!" + +{- +************************************************************************ +* * \subsection{Foreign import/export} * * ************************************************************************ diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs index c7f716bbfc..283ece1d50 100644 --- a/compiler/GHC/Driver/Config/StgToCmm.hs +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -63,8 +63,9 @@ initStgToCmmConfig dflags mod = StgToCmmConfig b_blob = if not ncg then Nothing else binBlobThreshold dflags (ncg, llvm) = case backendPrimitiveImplementation bk_end of GenericPrimitives -> (False, False) - NcgPrimitives -> (True, False) - LlvmPrimitives -> (False, True) + JSPrimitives -> (False, False) + NcgPrimitives -> (True, False) + LlvmPrimitives -> (False, True) x86ish = case platformArch platform of ArchX86 -> True ArchX86_64 -> True diff --git a/compiler/GHC/Driver/Config/StgToJS.hs b/compiler/GHC/Driver/Config/StgToJS.hs new file mode 100644 index 0000000000..087767d39b --- /dev/null +++ b/compiler/GHC/Driver/Config/StgToJS.hs @@ -0,0 +1,32 @@ +module GHC.Driver.Config.StgToJS + ( initStgToJSConfig + ) +where + +import GHC.StgToJS.Types + +import GHC.Driver.Session +import GHC.Platform.Ways +import GHC.Utils.Outputable + +import GHC.Prelude + +-- | Initialize StgToJS settings from DynFlags +initStgToJSConfig :: DynFlags -> StgToJSConfig +initStgToJSConfig dflags = StgToJSConfig + -- flags + { csInlinePush = False + , csInlineBlackhole = False + , csInlineLoadRegs = False + , csInlineEnter = False + , csInlineAlloc = False + , csTraceRts = False + , csAssertRts = False + , csBoundsCheck = gopt Opt_DoBoundsChecking dflags + , csDebugAlloc = False + , csTraceForeign = False + , csProf = ways dflags `hasWay` WayProf + , csRuntimeAssert = False + -- settings + , csContext = initSDocContext dflags defaultDumpStyle + } diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index b1154b6398..0144454abf 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -77,6 +77,7 @@ data DumpFlag | Opt_D_dump_asm_stats | Opt_D_dump_c_backend | Opt_D_dump_llvm + | Opt_D_dump_js | Opt_D_dump_core_stats | Opt_D_dump_deriv | Opt_D_dump_ds diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 4a22645223..b6ff27621b 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -132,6 +132,7 @@ import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) import GHC.Driver.Config.Cmm (initCmmConfig) import GHC.Driver.LlvmConfigCache (initLlvmConfigCache) +import GHC.Driver.Config.StgToJS (initStgToJSConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Tidy import GHC.Driver.Hooks @@ -153,6 +154,7 @@ import GHC.Hs.Stats ( ppSourceStats ) import GHC.HsToCore import GHC.StgToByteCode ( byteCodeGen ) +import GHC.StgToJS ( stgToJS ) import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) @@ -1789,7 +1791,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do cg_foreign = foreign_stubs0, cg_foreign_files = foreign_files, cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info } = cgguts + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries + } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env @@ -1849,38 +1853,53 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------ Code generation ------------------ -- The back-end is streamed: each top-level function goes -- from Stg all the way to asm before dealing with the next - -- top-level function, so showPass isn't very useful here. - -- Hence we have one showPass for the whole backend, the - -- next showPass after this will be "Assembler". - withTiming logger - (text "CodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - cmms <- {-# SCC "StgToCmm" #-} - doCodeGen hsc_env this_mod denv data_tycons - cost_centre_info - stg_binds hpc_info - - ------------------ Code output ----------------------- - rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger profile cmms - Just h -> h dflags (Just this_mod) cmms - - let dump a = do - unless (null a) $ - putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) - return a - rawcmms1 = Stream.mapM dump rawcmms0 - - let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init - `appendStubC` cgIPEStub st - - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos) - <- {-# SCC "codeOutput" #-} - codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location - foreign_stubs foreign_files dependencies rawcmms1 - return ( output_filename, stub_c_exists, foreign_fps - , Just stg_cg_infos, Just cmm_cg_infos) + -- top-level function, so withTiming isn't very useful here. + -- Hence we have one withTiming for the whole backend, the + -- next withTiming after this will be "Assembler" (hard code only). + withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) + $ case backendCodeOutput (backend dflags) of + JSCodeOutput -> + do + let js_config = initStgToJSConfig dflags + cmm_cg_infos = Nothing + stub_c_exists = Nothing + foreign_fps = [] + + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG + (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds) + + -- do the unfortunately effectual business + stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename + return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, cmm_cg_infos) + + _ -> + do + cmms <- {-# SCC "StgToCmm" #-} + doCodeGen hsc_env this_mod denv data_tycons + cost_centre_info + stg_binds hpc_info + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + case cmmToRawCmmHook hooks of + Nothing -> cmmToRawCmm logger profile cmms + Just h -> h dflags (Just this_mod) cmms + + let dump a = do + unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) + return a + rawcmms1 = Stream.mapM dump rawcmms0 + + let foreign_stubs st = foreign_stubs0 + `appendStubC` prof_init + `appendStubC` cgIPEStub st + + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos) + <- {-# SCC "codeOutput" #-} + codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location + foreign_stubs foreign_files dependencies rawcmms1 + return ( output_filename, stub_c_exists, foreign_fps + , Just stg_cg_infos, Just cmm_cg_infos) -- The part of CgGuts that we need for HscInteractive diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs index c4be206fbf..2cfcd6d9f6 100644 --- a/compiler/GHC/Driver/Phases.hs +++ b/compiler/GHC/Driver/Phases.hs @@ -99,6 +99,7 @@ data Phase | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code | MergeForeign -- merge in the foreign object files + | Js -- pre-process Js source -- The final phase is a pseudo-phase that tells the pipeline to stop. | StopLn -- Stop, but linking will follow, so generate .o file @@ -134,6 +135,7 @@ eqPhase MergeForeign MergeForeign = True eqPhase StopLn StopLn = True eqPhase Ccxx Ccxx = True eqPhase Cobjcxx Cobjcxx = True +eqPhase Js Js = True eqPhase _ _ = False -- MP: happensBefore is only used in preprocessPipeline, that usage should @@ -165,6 +167,7 @@ nextPhase platform p Cmm -> maybeHCc HCc -> MergeForeign MergeForeign -> StopLn + Js -> StopLn StopLn -> panic "nextPhase: nothing after StopLn" where maybeHCc = if platformUnregisterised platform then HCc @@ -198,6 +201,7 @@ startPhase "lm_s" = LlvmMangle startPhase "o" = StopLn startPhase "cmm" = CmmCpp startPhase "cmmcpp" = Cmm +startPhase "js" = Js startPhase _ = StopLn -- all unknown file types -- This is used to determine the extension for the output from the @@ -226,10 +230,11 @@ phaseInputExt LlvmMangle = "lm_s" phaseInputExt CmmCpp = "cmmcpp" phaseInputExt Cmm = "cmm" phaseInputExt MergeForeign = "o" +phaseInputExt Js = "js" phaseInputExt StopLn = "o" haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - haskellish_user_src_suffixes, haskellish_sig_suffixes + js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes :: [String] -- When a file with an extension in the haskellish_src_suffixes group is -- loaded in --make mode, its imports will be loaded too. @@ -238,6 +243,7 @@ haskellish_src_suffixes = haskellish_user_src_suffixes ++ haskellish_suffixes = haskellish_src_suffixes ++ [ "hc", "cmm", "cmmcpp" ] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] +js_suffixes = [ "js" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = @@ -259,13 +265,14 @@ dynlib_suffixes platform = case platformOS platform of _ -> ["so"] isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isHaskellSigSuffix + isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isBackpackishSuffix s = s `elem` backpackish_suffixes isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes +isJsSuffix s = s `elem` js_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool @@ -275,6 +282,7 @@ isDynLibSuffix platform s = s `elem` dynlib_suffixes platform isSourceSuffix :: String -> Bool isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff + || isJsSuffix suff || isBackpackishSuffix suff -- | When we are given files (modified by -x arguments) we need @@ -291,7 +299,7 @@ isHaskellishTarget :: (String, Maybe Phase) -> Bool isHaskellishTarget (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) isHaskellishTarget (_,Just phase) = - phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, Js , StopLn] isHaskellishFilename, isHaskellSrcFilename, isCishFilename, @@ -319,4 +327,5 @@ phaseForeignLanguage phase = case phase of HCc -> Just LangC As _ -> Just LangAsm MergeForeign -> Just RawObject + Js -> Just LangJs _ -> Nothing diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index d05dd751ce..25e082c62f 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -42,7 +42,7 @@ module GHC.Driver.Pipeline ( TPipelineClass, MonadUse(..), preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline, - hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, + hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, jsPipeline, llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart, -- * Default method of running a pipeline @@ -62,6 +62,7 @@ import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Pipeline.Monad import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.StgToJS import GHC.Driver.Phases import GHC.Driver.Pipeline.Execute import GHC.Driver.Pipeline.Phases @@ -81,6 +82,9 @@ import GHC.Linker.Static import GHC.Linker.Static.Utils import GHC.Linker.Types +import GHC.StgToJS.Linker.Linker +import GHC.StgToJS.Linker.Types (defaultJSLinkConfig) + import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Panic @@ -364,17 +368,17 @@ link :: GhcLink -- ^ interactive or batch link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt = case linkHook hooks of Nothing -> case ghcLink of - NoLink -> return Succeeded - LinkBinary -> normal_link - LinkStaticLib -> normal_link - LinkDynLib -> normal_link - LinkMergedObj -> normal_link - LinkInMemory - | platformMisc_ghcWithInterpreter $ platformMisc dflags - -> -- Not Linking...(demand linker will do the job) - return Succeeded - | otherwise - -> panicBadLink LinkInMemory + NoLink -> return Succeeded + LinkBinary -> normal_link + LinkStaticLib -> normal_link + LinkDynLib -> normal_link + LinkMergedObj -> normal_link + LinkInMemory + | platformMisc_ghcWithInterpreter $ platformMisc dflags + -- Not Linking...(demand linker will do the job) + -> return Succeeded + | otherwise + -> panicBadLink LinkInMemory Just h -> h ghcLink dflags batch_attempt_linking hpt where normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt @@ -412,7 +416,9 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt -- the linkables to link linkables = map (expectJust "link". homeModInfoObject) home_mod_infos + debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos)) debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps)) -- check for the -no-link flag if isNoLink (ghcLink dflags) @@ -423,7 +429,8 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked) obj_files = concatMap getOfiles linkables platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile_ dflags) + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps @@ -435,12 +442,13 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt -- Don't showPass in Batch mode; doLink will do that for us. - let link = case ghcLink dflags of - LinkBinary -> linkBinary logger tmpfs - LinkStaticLib -> linkStaticLib logger - LinkDynLib -> linkDynLibCheck logger tmpfs - other -> panicBadLink other - link dflags unit_env obj_files pkg_deps + case ghcLink dflags of + LinkBinary + | backendUseJSLinker (backend dflags) -> linkJSBinary logger dflags unit_env obj_files pkg_deps + | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps + LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps + LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps + other -> panicBadLink other debugTraceMsg logger 3 (text "link: done") @@ -453,6 +461,15 @@ link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt return Succeeded +linkJSBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkJSBinary logger dflags unit_env obj_files pkg_deps = do + -- we use the default configuration for now. In the future we may expose + -- settings to the user via DynFlags. + let lc_cfg = defaultJSLinkConfig + let cfg = initStgToJSConfig dflags + let extra_js = mempty + jsLinkBinary lc_cfg cfg extra_js logger dflags unit_env obj_files pkg_deps + linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the @@ -460,7 +477,8 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do -- linking (unless the -fforce-recomp flag was given). let platform = ue_platform unit_env unit_state = ue_units unit_env - exe_file = exeFileName platform staticLink (outputFile_ dflags) + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return $ NeedsRecompile MustCompile @@ -544,23 +562,27 @@ compileFile hsc_env stop_phase (src, mb_phase) = do doLink :: HscEnv -> [FilePath] -> IO () -doLink hsc_env o_files = - let - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - unit_env = hsc_unit_env hsc_env - tmpfs = hsc_tmpfs hsc_env - in case ghcLink dflags of - NoLink -> return () - LinkBinary -> linkBinary logger tmpfs dflags unit_env o_files [] - LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] - LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] - LinkMergedObj - | Just out <- outputFile dflags - , let objs = [ f | FileOption _ f <- ldInputs dflags ] - -> joinObjectFiles hsc_env (o_files ++ objs) out - | otherwise -> panic "Output path must be specified for LinkMergedObj" - other -> panicBadLink other +doLink hsc_env o_files = do + let + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env + tmpfs = hsc_tmpfs hsc_env + + case ghcLink dflags of + NoLink -> return () + LinkBinary + | backendUseJSLinker (backend dflags) + -> linkJSBinary logger dflags unit_env o_files [] + | otherwise -> linkBinary logger tmpfs dflags unit_env o_files [] + LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] + LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] + LinkMergedObj + | Just out <- outputFile dflags + , let objs = [ f | FileOption _ f <- ldInputs dflags ] + -> joinObjectFiles hsc_env (o_files ++ objs) out + | otherwise -> panic "Output path must be specified for LinkMergedObj" + other -> panicBadLink other ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support), and cc files. @@ -585,6 +607,7 @@ compileForeign hsc_env lang stub_c = do LangObjc -> viaCPipeline Cobjc LangObjcxx -> viaCPipeline Cobjcxx LangAsm -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp + LangJs -> \pe hsc_env ml fp -> Just <$> jsPipeline pe hsc_env ml fp #if __GLASGOW_HASKELL__ < 811 RawObject -> panic "compileForeign: should be unreachable" #endif @@ -608,14 +631,27 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- and https://github.com/haskell/cabal/issues/2257 let logger = hsc_logger hsc_env let tmpfs = hsc_tmpfs hsc_env - empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" let home_unit = hsc_home_unit hsc_env - src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" - writeFile empty_stub (showSDoc dflags (pprCode src)) - let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} - pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub - _ <- runPipeline (hsc_hooks hsc_env) pipeline - return () + + case backendCodeOutput (backend dflags) of + JSCodeOutput -> do + empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode src)) + let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} + pipeline = Just <$> jsPipeline pipe_env hsc_env (Just location) empty_stub + _ <- runPipeline (hsc_hooks hsc_env) pipeline + pure () + + _ -> do + empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" + let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode src)) + let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} + pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub + _ <- runPipeline (hsc_hooks hsc_env) pipeline + pure () + {- Environment Initialisation -} @@ -818,6 +854,10 @@ cmmPipeline pipe_env hsc_env input_fn = do Nothing -> panic "CMM pipeline - produced no .o file" Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos) +jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +jsPipeline pipe_env hsc_env location input_fn = do + use (T_Js pipe_env hsc_env location input_fn) + hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing @@ -833,9 +873,10 @@ applyPostHscPipeline NcgPostHscPipeline = applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc applyPostHscPipeline LlvmPostHscPipeline = \pe he ml fp -> llvmPipeline pe he ml fp +applyPostHscPipeline JSPostHscPipeline = + \pe he ml fp -> Just <$> jsPipeline pe he ml fp applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing - -- Pipeline from a given suffix pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath) pipelineStart pipe_env hsc_env input_fn mb_phase = @@ -870,7 +911,6 @@ pipelineStart pipe_env hsc_env input_fn mb_phase = objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk objFromLinkable _ = Nothing - fromPhase :: P m => Phase -> m (Maybe FilePath) fromPhase (Unlit p) = frontend p fromPhase (Cpp p) = frontend p @@ -888,6 +928,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase = fromPhase StopLn = return (Just input_fn) fromPhase CmmCpp = Just <$> cmmCppPipeline pipe_env hsc_env input_fn fromPhase Cmm = Just <$> cmmPipeline pipe_env hsc_env input_fn + fromPhase Js = Just <$> jsPipeline pipe_env hsc_env Nothing input_fn fromPhase MergeForeign = panic "fromPhase: MergeForeign" {- diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index 2a1e877292..bd9ee7805a 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -46,6 +46,7 @@ import GHC.Utils.Error import Data.Maybe import GHC.CmmToLlvm.Mangler import GHC.SysTools +import GHC.SysTools.Cpp import GHC.Utils.Panic.Plain import System.Directory import System.FilePath @@ -72,13 +73,12 @@ import GHC.Settings import System.IO import GHC.Linker.ExtraObj import GHC.Linker.Dynamic -import Data.Version import GHC.Utils.Panic import GHC.Unit.Module.Env import GHC.Driver.Env.KnotVars import GHC.Driver.Config.Finder import GHC.Rename.Names -import GHC.SysTools.Cpp +import GHC.StgToJS.Linker.Linker (embedJsFile) import Language.Haskell.Syntax.Module.Name import GHC.Unit.Home.ModInfo @@ -127,6 +127,7 @@ runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do }) input_fn output_fn return output_fn +runPhase (T_Js pipe_env hsc_env _mb_location js_src) = runJsPhase pipe_env hsc_env js_src runPhase (T_Cmm pipe_env hsc_env input_fn) = do let dflags = hsc_dflags hsc_env let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) @@ -345,11 +346,62 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do return output_fn + +-- Note [JS Backend .o file procedure] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The JS backend breaks some of the assumptions on file generation order +-- because it directly produces .o files. This violation breaks some of the +-- assumptions on file timestamps, particularly in the postHsc phase. The +-- postHsc phase for the JS backend is performed in 'runJsPhase'. Consider +-- what the NCG does: +-- +-- With other NCG backends we have the following order: +-- 1. The backend produces a .s file +-- 2. Then we write the interface file, .hi +-- 3. Then we generate a .o file in a postHsc phase (calling the asm phase etc.) +-- +-- For the JS Backend this order is different +-- 1. The JS Backend _directly_ produces .o files +-- 2. Then we write the interface file. Notice that this breaks the ordering +-- of .hi > .o (step 2 and step 3 in the NCG above). +-- +-- This violation results in timestamp checks which pass on the NCG but fail +-- in the JS backend. In particular, checks that compare 'ms_obj_date', and +-- 'ms_iface_date' in 'GHC.Unit.Module.ModSummary'. +-- +-- Thus to fix this ordering we touch the object files we generated earlier +-- to ensure these timestamps abide by the proper ordering. + +-- | Run the JS Backend postHsc phase. +runJsPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath +runJsPhase pipe_env hsc_env input_fn = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + let unit_env = hsc_unit_env hsc_env + + output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing + + -- if the input filename is the same as the output, then we've probably + -- generated the object ourselves. In this case, we touch the object file to + -- ensure the timestamp is refreshed, see Note [JS Backend .o file procedure]. If + -- they are not the same then we embed the .js file into a .o file with the + -- addition of a header + if (input_fn /= output_fn) + then embedJsFile logger dflags tmpfs unit_env input_fn output_fn + else touchObjectFile logger dflags output_fn + + return output_fn + + applyAssemblerInfoGetter :: DefunctionalizedAssemblerInfoGetter -> Logger -> DynFlags -> Platform -> IO CompilerInfo applyAssemblerInfoGetter StandardAssemblerInfoGetter logger dflags _platform = getAssemblerInfo logger dflags +applyAssemblerInfoGetter JSAssemblerInfoGetter _ _ _ = + pure Emscripten applyAssemblerInfoGetter DarwinClangAssemblerInfoGetter logger dflags platform = if platformOS platform == OSDarwin then pure Clang @@ -361,6 +413,8 @@ applyAssemblerProg -> Logger -> DynFlags -> Platform -> [Option] -> IO () applyAssemblerProg StandardAssemblerProg logger dflags _platform = runAs logger dflags +applyAssemblerProg JSAssemblerProg logger dflags _platform = + runEmscripten logger dflags applyAssemblerProg DarwinClangAssemblerProg logger dflags platform = if platformOS platform == OSDarwin then runClang logger dflags @@ -1113,36 +1167,6 @@ linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [UnitInfo] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = unitPackageVersion pkg - pkgname = map fixchar (unitPackageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - - -- ----------------------------------------------------------------------------- -- Misc. diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs b/compiler/GHC/Driver/Pipeline/Phases.hs index c54bf2d838..a999a40343 100644 --- a/compiler/GHC/Driver/Pipeline/Phases.hs +++ b/compiler/GHC/Driver/Pipeline/Phases.hs @@ -44,6 +44,7 @@ data TPhase res where T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath) T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_Js :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 168a204fbc..ea3866b00d 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2443,6 +2443,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_core_stats) , make_ord_flag defGhcFlag "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-js" + (setDumpFlag Opt_D_dump_js) , make_ord_flag defGhcFlag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) , make_ord_flag defGhcFlag "ddump-asm-liveness" @@ -4943,6 +4945,7 @@ data CompilerInfo | Clang | AppleClang | AppleClang51 + | Emscripten | UnknownCC deriving Eq diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 89be7cca40..32730030e9 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -19,6 +19,7 @@ import GHC.Data.FastString import GHC.Tc.Utils.Monad -- temp import GHC.HsToCore.Foreign.C +import GHC.HsToCore.Foreign.JavaScript import GHC.HsToCore.Foreign.Utils import GHC.HsToCore.Monad @@ -35,7 +36,6 @@ import GHC.Utils.Outputable import GHC.Driver.Session import GHC.Platform import GHC.Data.OrdList -import GHC.Utils.Panic import GHC.Driver.Hooks import Data.List (unzip4) @@ -127,8 +127,11 @@ dsFImport :: Id -> Coercion -> ForeignImport (GhcPass p) -> DsM ([Binding], CHeader, CStub) -dsFImport id co (CImport _ cconv safety mHeader spec) = - dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader +dsFImport id co (CImport _ cconv safety mHeader spec) = do + platform <- getPlatform + case platformArch platform of + ArchJavaScript -> dsJsImport id co spec (unLoc cconv) (unLoc safety) mHeader + _ -> dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader {- ************************************************************************ @@ -163,9 +166,11 @@ dsFExport :: Id -- Either the exported Id, , String -- string describing type to pass to createAdj. , Int -- size of args to stub function ) -dsFExport fn_id co ext_name cconv is_dyn = case cconv of - JavaScriptCallConv -> panic "dsFExport: JavaScript foreign exports not supported yet" - _ -> dsCFExport fn_id co ext_name cconv is_dyn +dsFExport fn_id co ext_name cconv is_dyn = do + platform <- getPlatform + case platformArch platform of + ArchJavaScript -> dsJsFExport fn_id co ext_name cconv is_dyn + _ -> dsCFExport fn_id co ext_name cconv is_dyn foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub diff --git a/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs new file mode 100644 index 0000000000..820ab80275 --- /dev/null +++ b/compiler/GHC/HsToCore/Foreign/JavaScript.hs @@ -0,0 +1,683 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handling of JavaScript foreign imports/exports +module GHC.HsToCore.Foreign.JavaScript + ( dsJsImport + , dsJsFExport + , dsJsFExportDynamic + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Hs + +import GHC.HsToCore.Monad +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.Prim +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Utils + +import GHC.Core +import GHC.Core.Make +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.Unfold.Make +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Multiplicity + +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Literal +import GHC.Types.ForeignStubs +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Basic +import GHC.Types.Unique + +import GHC.Unit.Module + +import GHC.Tc.Utils.TcType + +import GHC.Cmm.Expr +import GHC.Cmm.Utils + +import GHC.JS.Ppr + +import GHC.Driver.Session +import GHC.Driver.Config + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names + +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.Maybe + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Encoding + +dsJsFExport + :: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> DsM ( CHeader -- contents of Module_stub.h + , CStub -- contents of Module_stub.c + , String -- string describing type to pass to createAdj. + , Int -- size of args to stub function + ) + +dsJsFExport fn_id co ext_name cconv isDyn = do + let + ty = pSnd $ coercionKind co + (_tvs,sans_foralls) = tcSplitForAllTyVars ty + (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + platform <- targetPlatform <$> getDynFlags + return $ + mkFExportJSBits platform ext_name + (if isDyn then Nothing else Just fn_id) + (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv + +mkFExportJSBits + :: Platform + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (CHeader, + CStub, + String, -- the argument reps + Int -- total size of arguments + ) +mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv + = (header_bits, js_bits, type_string, + sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- arg_info] -- all the args + -- NB. the calculation here isn't strictly speaking correct. + -- We have a primitive Haskell type (eg. Int#, Double#), and + -- we want to know the size, when passed on the C stack, of + -- the associated C type (eg. HsInt, HsDouble). We don't have + -- this information to hand, but we know what GHC's conventions + -- are for passing around the primitive Haskell types, so we + -- use that instead. I hope the two coincide --SDM + ) + where + -- list the arguments to the JS function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, + stg_type, + ty, + typeCmmType platform (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + arg_cname n _stg_ty = text ('a':show n) + + type_string = primTyDescChar platform res_hty : arg_type_string + + arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] + + -- stuff to do with the return type of the JS function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + unboxResType | res_hty_is_unit = text "h$rts_getUnit" + | otherwise = unpackHObj res_hty + + header_bits = maybe mempty idTag maybe_target + idTag i = let (tag, u) = unpkUnique (getUnique i) + in CHeader (char tag <> int u) + + fun_args + | null arg_info = empty -- text "void" + | otherwise = hsep $ punctuate comma + $ map (\(nm,_ty,_,_) -> nm) arg_info + + fun_proto + = text "async" <+> + text "function" <+> + (if isNothing maybe_target + then text "h$" <> ftext c_nm + else ftext c_nm) <> + parens fun_args + + fun_export + = case maybe_target of + Just hs_fn | Just m <- nameModule_maybe (getName hs_fn) -> + text "h$foreignExport" <> + parens ( + ftext c_nm <> comma <> + strlit (unitIdString (moduleUnitId m)) <> comma <> + strlit (moduleNameString (moduleName m)) <> comma <> + strlit (unpackFS c_nm) <> comma <> + strlit type_string + ) <> semi + _ -> empty + + strlit xs = docToSDoc (pprStringLit (mkFastString xs)) + + -- the target which will form the root of what we ask rts_evalIO to run + the_cfun + = case maybe_target of + Nothing -> text "h$deRefStablePtr(the_stableptr)" + Just hs_fn -> idClosureText hs_fn + + -- the expression we give to rts_eval + expr_to_run :: SDoc + expr_to_run + = foldl appArg the_cfun arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "h$rts_apply" + <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname) + + -- finally, the whole darn thing + js_bits = CStub { getCStub = js_sdoc + , getInitializers = mempty + , getFinalizers = mempty + } + where js_sdoc = space + $$ fun_proto + $$ vcat + [ lbrace + , text "return" + <+> text "await" + <+> text "h$rts_eval" + <> parens ((if is_IO_res_ty + then expr_to_run + else text "h$rts_toIO" <> parens expr_to_run) + <> comma <+> unboxResType) + <> semi + , rbrace + ] + $$ fun_export + +idClosureText :: Id -> SDoc +idClosureText i + | isExportedId i + , name <- getName i + , Just m <- nameModule_maybe name + = let str = renderWithContext defaultSDocContext (pprFullName m (localiseName name)) + in text "h$" <> text (zEncodeString str) + | otherwise + = panic "idClosureText: unknown module" + +-- | Desugaring of JavaScript foreign imports +dsJsImport + :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], CHeader, CStub) +dsJsImport id co (CLabel cid) cconv _ _ = do + let ty = pFst $ coercionKind co + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (_resTy, foRhs) <- jsResultWrapper ty +-- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this + let rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) + rhs' = Cast rhs co + stdcall_info = fun_type_arg_stdcall_info cconv ty + + return ([(id, rhs')], mempty, mempty) + +dsJsImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsJsImport id co (CFunction target) cconv safety mHeader + = dsJsCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsJsImport id co CWrapper cconv _ _ + = dsJsFExportDynamic id co cconv + +-- fixme work in progress +-- FIXME (Sylvain 2022-03): possibility of code sharing with dsFExportDynamic? +-- Lot of duplication +dsJsFExportDynamic :: Id + -> Coercion + -> CCallConv + -> DsM ([Binding], CHeader, CStub) +dsJsFExportDynamic id co0 cconv = do + let + ty = pFst (coercionKind co0) + (tvs,sans_foralls) = tcSplitForAllTyVars ty + ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + (io_tc, res_ty) = expectJust "dsJsFExportDynamic: IO type expected" + -- Must have an IO type; hence Just + $ tcSplitIOType_maybe fn_res_ty + mod <- getModule + platform <- targetPlatform <$> getDynFlags + let fe_nm = mkFastString $ zEncodeString + ("h$" ++ moduleStableString mod ++ "$" ++ toJsName id) + -- Construct the label based on the passed id, don't use names + -- depending on Unique. See #13807 and Note [Unique Determinism]. + cback <- newSysLocalDs arg_mult arg_ty + newStablePtrId <- dsLookupGlobalId newStablePtrName + stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName + let + stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] + export_ty = mkVisFunTyMany stable_ptr_ty arg_ty + bindIOId <- dsLookupGlobalId bindIOName + stbl_value <- newSysLocalDs ManyTy stable_ptr_ty + (h_code, c_code, typestring, args_size) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True + let + {- + The arguments to the external function which will + create a little bit of (template) code on the fly + for allowing the (stable pointed) Haskell closure + to be entered using an external calling convention + (stdcall, ccall). + -} + adj_args = [ mkIntLit platform (toInteger (ccallConvToInt cconv)) + , Var stbl_value + , Lit (LitLabel fe_nm mb_sz_args IsFunction) + , Lit (mkLitString typestring) + ] + -- name of external entry point providing these services. + -- (probably in the RTS.) + adjustor = fsLit "createAdjustor" + + -- Determine the number of bytes of arguments to the stub function, + -- so that we can attach the '@N' suffix to its label if it is a + -- stdcall on Windows. + mb_sz_args = case cconv of + StdCallConv -> Just args_size + _ -> Nothing + + ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) + -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + return ([fed], h_code, c_code) + +toJsName :: Id -> String +toJsName i = renderWithContext defaultSDocContext (pprCode (ppr (idName i))) + +dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], CHeader, CStub) +dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do + let + ty = pFst $ coercionKind co + (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty + (arg_tys, io_res_ty) = tcSplitFunTys rho + + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + (val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + simpl_opts <- initSimpleOpts <$> getDynFlags + + let + -- Build the worker + fcall = CCall (CCallSpec target cconv safety) + worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs + the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + fn_id_w_inl = fn_id + `setIdUnfolding` + mkInlineUnfoldingWithArity simpl_opts VanillaSrc + (length args) wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, mempty) + + +mkHObj :: Type -> SDoc +mkHObj t = text "h$rts_mk" <> text (showFFIType t) + +unpackHObj :: Type -> SDoc +unpackHObj t = text "h$rts_get" <> text (showFFIType t) + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> text (showFFIType t) + +showFFIType :: Type -> String +showFFIType t = getOccString (getName (typeTyCon t)) + +typeTyCon :: Type -> TyCon +typeTyCon ty + -- UnaryRep rep_ty <- repType ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) -- rep_ty + = tc + | otherwise + = pprPanic "typeTyCon" (ppr ty) + + +{- + We unbox arguments for JS calls a bit different from native code: + - Bool is marshalled to true/false, not 0/1 + - All int types are narrowed, since JS floats have a greater range than Int32 + -} + +unboxJsArg :: CoreExpr -- The supplied argument + -> DsM (CoreExpr, -- To pass as the actual argument + CoreExpr -> CoreExpr -- Wrapper to unbox the arg + ) +unboxJsArg arg + -- Primtive types: nothing to unbox + | isPrimitiveType arg_ty + = return (arg, \body -> body) + + -- Recursive newtypes + | Just (co, _rep_ty) <- topNormaliseNewType_maybe arg_ty + = unboxJsArg (mkCast arg co) + + -- Booleans, do not convert to 0/1, only force them + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` boolTyConKey + = return (arg, + \ body -> mkWildCase arg (unrestricted boolTy) (exprType body) [Alt DEFAULT [] body]) + + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` anyTyConKey + = return (arg, + \ body -> mkWildCase arg (unrestricted arg_ty) (exprType body) [Alt DEFAULT [] body]) + -- Data types with a single constructor, which has a single, primitive-typed arg + -- This deals with Int, Float etc; also Ptr, ForeignPtr + | is_product_type && data_con_arity == 1 + = do case_bndr <- newSysLocalDs ManyTy arg_ty + prim_arg <- newSysLocalDs ManyTy (scaledThing data_con_arg_ty1) + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] + ) + + -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- data ByteArray ix = ByteArray ix ix ByteArray# + -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) + | is_product_type && + data_con_arity == 3 && + isJust maybe_arg3_tycon && + (arg3_tycon == byteArrayPrimTyCon || + arg3_tycon == mutableByteArrayPrimTyCon) + = do case_bndr <- newSysLocalDs ManyTy arg_ty + vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys + return (Var arr_cts_var, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body] + ) + + | otherwise + = do l <- getSrcSpanDs + pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty) + where + arg_ty = exprType arg + maybe_product_type = splitDataProductType_maybe arg_ty + is_product_type = isJust maybe_product_type + Just (_, _, data_con, data_con_arg_tys) = maybe_product_type + data_con_arity = dataConSourceArity data_con + (data_con_arg_ty1 : _) = data_con_arg_tys + + (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys + maybe_arg3_tycon = tyConAppTyCon_maybe (scaledThing data_con_arg_ty3) + Just arg3_tycon = maybe_arg3_tycon + + +boxJsResult :: Type + -> DsM (Type, CoreExpr -> CoreExpr) +boxJsResult result_ty + | isRuntimeRepKindedTy result_ty = panic "boxJsResult: runtime rep ty" -- fixme +-- Takes the result of the user-level ccall: +-- either (IO t), +-- or maybe just t for an side-effect-free call +-- Returns a wrapper for the primitive ccall itself, along with the +-- type of the result of the primitive ccall. This result type +-- will be of the form +-- State# RealWorld -> (# State# RealWorld, t' #) +-- where t' is the unwrapped form of t. If t is simply (), then +-- the result type will be +-- State# RealWorld -> (# State# RealWorld #) + +boxJsResult result_ty + | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty + -- isIOType_maybe handles the case where the type is a + -- simple wrapping of IO. E.g. + -- newtype Wrap a = W (IO a) + -- No coercion necessary because its a non-recursive newtype + -- (If we wanted to handle a *recursive* newtype too, we'd need + -- another case, and a coercion.) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- jsResultWrapper io_res_ty + ; let return_result state ans + = mkCoreUnboxedTuple [state, ans] + + ; (ccall_res_ty, the_alt) <- mk_alt return_result res + + ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) } + +boxJsResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- jsResultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + where + return_result _ ans = ans + +mk_alt :: (Expr Var -> Expr Var -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, CoreAlt) +mk_alt return_result (Nothing, wrap_result) + = do -- The ccall returns () + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result $ panic "jsBoxResult") + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs + return (ccall_res_ty, the_alt) + +mk_alt return_result (Just prim_res_ty, wrap_result) + -- The ccall returns a non-() value + | isUnboxedTupleType prim_res_ty = do + let + Just ls = fmap dropRuntimeRepArgs (tyConAppArgs_maybe prim_res_ty) + arity = 1 + length ls + args_ids <- mapM (newSysLocalDs ManyTy) ls + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + result_tup = mkCoreUnboxedTuple (map Var args_ids) + the_rhs = return_result (Var state_id) + (wrap_result result_tup) + ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls) + the_alt = Alt (DataAlt (tupleDataCon Unboxed arity)) + (state_id : args_ids) + the_rhs + return (ccall_res_ty, the_alt) + + | otherwise = do + result_id <- newSysLocalDs ManyTy prim_res_ty + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result (Var result_id)) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs + return (ccall_res_ty, the_alt) + +fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int +fun_type_arg_stdcall_info _other_conv _ = Nothing + + +jsResultWrapper + :: Type + -> DsM ( Maybe Type -- Type of the expected result, if any + , CoreExpr -> CoreExpr -- Wrapper for the result + ) +-- resultWrapper deals with the result *value* +-- E.g. foreign import foo :: Int -> IO T +-- Then resultWrapper deals with marshalling the 'T' part +jsResultWrapper result_ty + | isRuntimeRepKindedTy result_ty = return (Nothing, id) -- fixme this seems like a hack + -- Base case 1a: unboxed tuples + | Just (tc, args) <- splitTyConApp_maybe result_ty + , isUnboxedTupleTyCon tc {- && False -} = do + let args' = dropRuntimeRepArgs args + (tys, wrappers) <- unzip <$> mapM jsResultWrapper args' + matched <- mapM (mapM (newSysLocalDs ManyTy)) tys + let tys' = catMaybes tys + -- arity = length args' + -- resCon = tupleDataCon Unboxed (length args) + err = panic "jsResultWrapper: used Id with result type Nothing" + resWrap :: CoreExpr + resWrap = mkCoreUnboxedTuple (zipWith (\w -> w . Var . fromMaybe err) wrappers matched) + return $ + if null tys' + then (Nothing, \_ -> resWrap) + else let innerArity = length tys' + innerTy = mkTupleTy Unboxed tys' + innerCon = tupleDataCon Unboxed innerArity + inner :: CoreExpr -> CoreExpr + inner e = mkWildCase e (unrestricted innerTy) result_ty + [Alt (DataAlt innerCon) + (catMaybes matched) + resWrap + ] + in (Just innerTy, inner) + + -- Base case 1b: primitive types + | isPrimitiveType result_ty + = return (Just result_ty, \e -> e) + -- Base case 1c: boxed tuples + -- fixme: levity args? + | Just (tc, args) <- splitTyConApp_maybe result_ty + , isBoxedTupleTyCon tc = do + let args' = dropRuntimeRepArgs args + innerTy = mkTupleTy Unboxed args' + (inner_res, w) <- jsResultWrapper innerTy + matched <- mapM (newSysLocalDs ManyTy) args' + let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty + [ Alt (DataAlt (tupleDataCon Unboxed (length args'))) + matched + (mkCoreTup (map Var matched)) + -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched) + ] + return (inner_res, inner) + + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey + = return (Nothing, \_ -> Var unitDataConId) + + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do +-- result_id <- newSysLocalDs boolTy + ccall_uniq <- newUnique + let forceBool e = mkJsCall ccall_uniq "$r = !(!$1)" [e] boolTy + return + (Just intPrimTy, \e -> forceBool e) + + -- Base case 4: the any type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` anyTyConKey + = return (Just result_ty, \e -> e) + + -- Newtypes + | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty + = do (maybe_ty, wrapper) <- jsResultWrapper rep_ty + return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) + + -- The type might contain foralls (eg. for dummy type arguments, + -- referring to 'Ptr a' is legal). + | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty + = do (maybe_ty, wrapper) <- jsResultWrapper rest + return (maybe_ty, \e -> Lam tyvar (wrapper e)) + + -- Data types with a single constructor, which has a single arg + -- This includes types like Ptr and ForeignPtr + | Just (_tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty, + dataConSourceArity data_con == 1 + = do let (unwrapped_res_ty : _) = data_con_arg_tys + (maybe_ty, wrapper) <- jsResultWrapper (scaledThing unwrapped_res_ty) + return + (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) + (map Type tycon_arg_tys ++ [wrapper e])) + + | otherwise + = pprPanic "jsResultWrapper" (ppr result_ty) + where + maybe_tc_app = splitTyConApp_maybe result_ty + +-- low-level primitive JavaScript call: +mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr +mkJsCall u tgt args t = mkFCall u ccall args t + where + ccall = CCall $ CCallSpec + (StaticTarget NoSourceText (mkFastString tgt) (Just primUnit) True) + JavaScriptCallConv + PlayRisky diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index db0218d73d..78045aa782 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-} -- -- (c) The University of Glasgow 2002-2006 @@ -15,7 +15,6 @@ module GHC.Iface.Binary ( readBinIface, readBinIfaceHeader, getSymtabName, - getDictFastString, CheckHiWay(..), TraceBinIFace(..), getWithUserData, @@ -24,11 +23,8 @@ module GHC.Iface.Binary ( -- * Internal serialisation functions getSymbolTable, putName, - putDictionary, - putFastString, putSymbolTable, BinSymbolTable(..), - BinDictionary(..) ) where import GHC.Prelude @@ -48,7 +44,6 @@ import GHC.Utils.Outputable import GHC.Types.Name.Cache import GHC.Types.SrcLoc import GHC.Platform -import GHC.Data.FastString import GHC.Settings.Constants import GHC.Utils.Fingerprint @@ -153,31 +148,28 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do -- Names or FastStrings. getWithUserData :: Binary a => NameCache -> BinHandle -> IO a getWithUserData name_cache bh = do + bh <- getTables name_cache bh + get bh + +-- | Setup a BinHandle to read something written using putWithTables +-- +-- Reading names has the side effect of adding them into the given NameCache. +getTables :: NameCache -> BinHandle -> IO BinHandle +getTables name_cache bh = do -- Read the dictionary -- The next word in the file is a pointer to where the dictionary is -- (probably at the end of the file) - dict_p <- Binary.get bh - data_p <- tellBin bh -- Remember where we are now - seekBin bh dict_p - dict <- getDictionary bh - seekBin bh data_p -- Back to where we were before + dict <- Binary.forwardGet bh (getDictionary bh) -- Initialise the user-data field of bh - bh <- do - bh <- return $ setUserData bh $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab_p <- Binary.get bh -- Get the symtab ptr - data_p <- tellBin bh -- Remember where we are now - seekBin bh symtab_p - symtab <- getSymbolTable bh name_cache - seekBin bh data_p -- Back to where we were before - - -- It is only now that we know how to get a Name - return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab) - (getDictFastString dict) - - -- Read the interface file - get bh + let bh_fs = setUserData bh $ newReadState (error "getSymtabName") + (getDictFastString dict) + + symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache) + + -- It is only now that we know how to get a Name + return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab) + (getDictFastString dict) -- | Write an interface file writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO () @@ -211,64 +203,63 @@ writeBinIface profile traceBinIface hi_path mod_iface = do -- This segment should be read using `getWithUserData`. putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO () putWithUserData traceBinIface bh payload = do - -- Remember where the dictionary pointer will go - dict_p_p <- tellBin bh - -- Placeholder for ptr to dictionary - put_ bh dict_p_p - - -- Remember where the symbol table pointer will go - symtab_p_p <- tellBin bh - put_ bh symtab_p_p - -- Make some initial state + (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload) + + case traceBinIface of + QuietBinIFace -> return () + TraceBinIFace printer -> do + printer (text "writeBinIface:" <+> int name_count + <+> text "Names") + printer (text "writeBinIface:" <+> int fs_count + <+> text "dict entries") + +-- | Write name/symbol tables +-- +-- 1. setup the given BinHandle with Name/FastString table handling +-- 2. write the following +-- - FastString table pointer +-- - Name table pointer +-- - payload +-- - Name table +-- - FastString table +-- +-- It returns (number of names, number of FastStrings, payload write result) +-- +putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b) +putWithTables bh put_payload = do + -- initialize state for the name table and the FastString table. symtab_next <- newFastMutInt 0 symtab_map <- newIORef emptyUFM - let bin_symtab = BinSymbolTable { - bin_symtab_next = symtab_next, - bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt 0 - dict_map_ref <- newIORef emptyUFM - let bin_dict = BinDictionary { - bin_dict_next = dict_next_ref, - bin_dict_map = dict_map_ref } - - -- Put the main thing, - bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) - (putName bin_dict bin_symtab) - (putFastString bin_dict) - put_ bh payload - - -- Write the symtab pointer at the front of the file - symtab_p <- tellBin bh -- This is where the symtab will start - putAt bh symtab_p_p symtab_p -- Fill in the placeholder - seekBin bh symtab_p -- Seek back to the end of the file - - -- Write the symbol table itself - symtab_next <- readFastMutInt symtab_next - symtab_map <- readIORef symtab_map - putSymbolTable bh symtab_next symtab_map - case traceBinIface of - QuietBinIFace -> return () - TraceBinIFace printer -> - printer (text "writeBinIface:" <+> int symtab_next - <+> text "Names") - - -- NB. write the dictionary after the symbol table, because - -- writing the symbol table may create more dictionary entries. - - -- Write the dictionary pointer at the front of the file - dict_p <- tellBin bh -- This is where the dictionary will start - putAt bh dict_p_p dict_p -- Fill in the placeholder - seekBin bh dict_p -- Seek back to the end of the file - - -- Write the dictionary itself - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - case traceBinIface of - QuietBinIFace -> return () - TraceBinIFace printer -> - printer (text "writeBinIface:" <+> int dict_next - <+> text "dict entries") + let bin_symtab = BinSymbolTable + { bin_symtab_next = symtab_next + , bin_symtab_map = symtab_map + } + + (bh_fs, bin_dict, put_dict) <- initFSTable bh + + (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do + + -- NB. write the dictionary after the symbol table, because + -- writing the symbol table may create more dictionary entries. + let put_symtab = do + name_count <- readFastMutInt symtab_next + symtab_map <- readIORef symtab_map + putSymbolTable bh_fs name_count symtab_map + pure name_count + + forwardPut bh_fs (const put_symtab) $ do + + -- BinHandle with FastString and Name writing support + let ud_fs = getUserData bh_fs + let ud_name = ud_fs + { ud_put_nonbinding_name = putName bin_dict bin_symtab + , ud_put_binding_name = putName bin_dict bin_symtab + } + let bh_name = setUserData bh ud_name + + put_payload bh_name + + return (name_count, fs_count, r) @@ -287,9 +278,9 @@ binaryInterfaceMagic platform -- putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) +putSymbolTable bh name_count symtab = do + put_ bh name_count + let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab)) -- It's OK to use nonDetEltsUFM here because the elements have -- indices that array uses to create order mapM_ (\n -> serialiseName bh n symtab) names @@ -340,7 +331,7 @@ serialiseName bh name _ = do -- See Note [Symbol table representation of names] -putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () +putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO () putName _dict BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } @@ -392,30 +383,3 @@ data BinSymbolTable = BinSymbolTable { -- indexed by Name } -putFastString :: BinDictionary -> BinHandle -> FastString -> IO () -putFastString dict bh fs = allocateFastString dict fs >>= put_ bh - -allocateFastString :: BinDictionary -> FastString -> IO Word32 -allocateFastString BinDictionary { bin_dict_next = j_r, - bin_dict_map = out_r} f = do - out <- readIORef out_r - let !uniq = getUnique f - case lookupUFM_Directly out uniq of - Just (j, _) -> return (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM_Directly out uniq (j, f) - return (fromIntegral j :: Word32) - -getDictFastString :: Dictionary -> BinHandle -> IO FastString -getDictFastString dict bh = do - j <- get bh - return $! (dict ! fromIntegral (j :: Word32)) - -data BinDictionary = BinDictionary { - bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) - -- indexed by FastString - } - diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs index e492bb726b..6474fbeb8e 100644 --- a/compiler/GHC/Iface/Ext/Binary.hs +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -21,7 +21,6 @@ import GHC.Settings.Utils ( maybeRead ) import GHC.Settings.Config ( cProjectVersion ) import GHC.Prelude import GHC.Utils.Binary -import GHC.Iface.Binary ( getDictFastString ) import GHC.Data.FastMutInt import GHC.Data.FastString ( FastString ) import GHC.Types.Name diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index d53fddb943..0b72f57f56 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -240,8 +240,13 @@ sptCreateStaticBinds opts this_mod binds = do -- @fps@ is a list associating each binding corresponding to a static entry with -- its fingerprint. sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub -sptModuleInitCode _ _ [] = mempty -sptModuleInitCode platform this_mod entries = +sptModuleInitCode platform this_mod entries + -- no CStub if there is no entry + | [] <- entries = mempty + -- no CStub for the JS backend: it deals with it directly during JS code + -- generation + | ArchJavaScript <- platformArch platform = mempty + | otherwise = initializerCStub platform init_fn_nm empty init_fn_body `mappend` finalizerCStub platform fini_fn_nm empty fini_fn_body where diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs new file mode 100644 index 0000000000..fc30d0d915 --- /dev/null +++ b/compiler/GHC/JS/Make.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Make +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Make defines helper functions to ease the creation of JavaScript +-- ASTs as defined in 'GHC.JS.Syntax'. Its purpose is twofold: make the EDSL +-- more ergonomic to program in, and make errors in the EDSL /look/ obvious +-- because the EDSL is untyped. It is primarily concerned with injecting +-- terms into the domain of the EDSL to construct JS programs in Haskell. +-- +-- * Strategy +-- +-- The strategy for this module comes straight from gentzen; where we have +-- two types of helper functions. Functions which inject terms into the +-- EDSL, and combinator functions which operate on terms in the EDSL to +-- construct new terms in the EDSL. Crucially, missing from this module are +-- corresponding /elimination/ or /destructing/ functions which would +-- project information from the EDSL back to Haskell. See +-- 'GHC.StgToJS.UnitUtils' and 'GHC.StgToJS.CoreUtils' for such functions. +-- +-- * /Introduction/ functions +-- +-- We define various primitive helpers which /introduce/ terms in the +-- EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'. Notice +-- that the type of each of these functions have the domain @isSat a +-- => a -> ...@; indicating that they each take something that /can/ +-- be injected into the EDSL domain, and the range 'JExpr' or 'JStat'; +-- indicating the corresponding value in the EDSL domain. Similarly +-- this module exports two typeclasses 'ToExpr' and 'ToSat', 'ToExpr' +-- injects values as a JS expression into the EDSL. 'ToSat' ensures +-- that terms introduced into the EDSL carry identifier information so +-- terms in the EDSL must have meaning. +-- +-- * /Combinator/ functions +-- +-- The rest of the module defines combinators which create terms in +-- the EDSL from terms in the EDSL. Notable examples are '|=' and +-- '||=', '|=' is sugar for 'AssignStat', it is a binding form that +-- declares @foo = bar@ /assuming/ foo has been already declared. +-- '||=' is more sugar on top of '|=', it is also a binding form that +-- declares the LHS of '|=' before calling '|=' to bind a value, bar, +-- to a variable foo. Other common examples are the 'if_' and 'math_' +-- helpers such as 'math_cos'. +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. +-- +-- * Notation +-- +-- In this module we use @==>@ in docstrings to show the translation from +-- the JS EDSL domain to JS code. For example, @foo ||= bar ==> var foo; foo +-- = bar;@ should be read as @foo ||= bar@ is in the EDSL domain and results +-- in the JS code @var foo; foo = bar;@ when compiled. +----------------------------------------------------------------------------- +module GHC.JS.Make + ( -- * Injection Type classes + -- $classes + ToJExpr(..) + , ToStat(..) + -- * Introduction functions + -- $intro_funcs + , var + , jString + , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally + -- * Combinators + -- $combinators + , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) + , (.>.), (.>=.), (.<.), (.<=.) + , (.<<.), (.>>.), (.>>>.) + , (.|.), (.||.), (.&&.) + , if_, if10, if01, ifS, ifBlockS + , jwhenS + , app, appS, returnS + , loop, loopBlockS + , preIncrS, postIncrS + , preDecrS, postDecrS + , off8, off16, off32, off64 + , mask8, mask16 + , signExtend8, signExtend16 + , typeof + , returnStack, assignAllEqual, assignAll, assignAllReverseOrder + , declAssignAll + , nullStat, (.^) + , trace + -- ** Hash combinators + , jhEmpty + , jhSingle + , jhAdd + , jhFromList + -- * Literals + -- $literals + , null_ + , undefined_ + , false_ + , true_ + , zero_ + , one_ + , two_ + , three_ + -- ** Math functions + -- $math + , math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, + math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, + math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround + -- * Statement helpers + , decl + -- * Miscellaneous + -- $misc + , allocData, allocClsA + , dataFieldName, dataFieldNames + ) +where + +import GHC.Prelude hiding ((.|.)) + +import GHC.JS.Syntax + +import Control.Arrow ((***)) + +import Data.Array +import qualified Data.Map as M +import qualified Data.List as List + +import GHC.Utils.Outputable (Outputable (..)) +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Types.Unique.Map + +-------------------------------------------------------------------------------- +-- Type Classes +-------------------------------------------------------------------------------- +-- $classes +-- The 'ToJExpr' class handles injection of of things into the EDSL as a JS +-- expression + +-- | Things that can be marshalled into javascript values. +-- Instantiate for any necessary data structures. +class ToJExpr a where + toJExpr :: a -> JExpr + toJExprFromList :: [a] -> JExpr + toJExprFromList = ValExpr . JList . map toJExpr + +instance ToJExpr a => ToJExpr [a] where + toJExpr = toJExprFromList + +instance ToJExpr JExpr where + toJExpr = id + +instance ToJExpr () where + toJExpr _ = ValExpr $ JList [] + +instance ToJExpr Bool where + toJExpr True = var "true" + toJExpr False = var "false" + +instance ToJExpr JVal where + toJExpr = ValExpr + +instance ToJExpr a => ToJExpr (UniqMap FastString a) where + toJExpr = ValExpr . JHash . mapUniqMap toJExpr + +instance ToJExpr a => ToJExpr (M.Map String a) where + toJExpr = ValExpr . JHash . listToUniqMap . map (mkFastString *** toJExpr) . M.toList + +instance ToJExpr Double where + toJExpr = ValExpr . JDouble . SaneDouble + +instance ToJExpr Int where + toJExpr = ValExpr . JInt . fromIntegral + +instance ToJExpr Integer where + toJExpr = ValExpr . JInt + +instance ToJExpr Char where + toJExpr = ValExpr . JStr . mkFastString . (:[]) + toJExprFromList = ValExpr . JStr . mkFastString +-- where escQuotes = tailDef "" . initDef "" . show + +instance ToJExpr Ident where + toJExpr = ValExpr . JVar + +instance ToJExpr FastString where + toJExpr = ValExpr . JStr + +instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where + toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b] + +instance (ToJExpr a, ToJExpr b, ToJExpr c) => ToJExpr (a,b,c) where + toJExpr (a,b,c) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c] + +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d) => ToJExpr (a,b,c,d) where + toJExpr (a,b,c,d) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d] +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e) => ToJExpr (a,b,c,d,e) where + toJExpr (a,b,c,d,e) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e] +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e, ToJExpr f) => ToJExpr (a,b,c,d,e,f) where + toJExpr (a,b,c,d,e,f) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f] + + +-- | The 'ToStat' class handles injection of of things into the EDSL as a JS +-- statement. This ends up being polymorphic sugar for JS blocks, see helper +-- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data +-- structures. +class ToStat a where + toStat :: a -> JStat + +instance ToStat JStat where + toStat = id + +instance ToStat [JStat] where + toStat = BlockStat + +instance ToStat JExpr where + toStat = expr2stat + +instance ToStat [JExpr] where + toStat = BlockStat . map expr2stat + +-------------------------------------------------------------------------------- +-- Introduction Functions +-------------------------------------------------------------------------------- +-- $intro_functions +-- Introduction functions are functions that map values or terms in the Haskell +-- domain to the JS EDSL domain + +-- | Create a new anonymous function. The result is a 'GHC.JS.Syntax.JExpr' +-- expression. +-- Usage: +-- +-- > jLam $ \x -> jVar x + one_ +-- > jLam $ \f -> (jLam $ \x -> (f `app` (x `app` x))) `app` (jLam $ \x -> (f `app` (x `app` x))) +jLam :: ToSat a => a -> JExpr +jLam f = ValExpr . UnsatVal . IS $ do + (block,is) <- runIdentSupply $ toSat_ f [] + return $ JFunc is block + +-- | Introduce a new variable into scope for the duration +-- of the enclosed expression. The result is a block statement. +-- Usage: +-- +-- @jVar $ \x y -> mconcat [jVar x ||= one_, jVar y ||= two_, jVar x + jVar y]@ +jVar :: ToSat a => a -> JStat +jVar f = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let addDecls (BlockStat ss) = + BlockStat $ map decl is ++ ss + addDecls x = x + return $ addDecls block + +-- | Create a 'for in' statement. +-- Usage: +-- +-- @jForIn {expression} $ \x -> {block involving x}@ +jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat +jForIn e f = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let i = List.head is + return $ decl i `mappend` ForInStat False i e block + +-- | As with "jForIn" but creating a \"for each in\" statement. +jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat +jForEachIn e f = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let i = List.head is + return $ decl i `mappend` ForInStat True i e block + +-- | As with "jForIn" but creating a \"for each in\" statement. +jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat +jTryCatchFinally s f s2 = UnsatBlock . IS $ do + (block, is) <- runIdentSupply $ toSat_ f [] + let i = List.head is + return $ TryStat s i block s2 + +-- | construct a JS variable reference +var :: FastString -> JExpr +var = ValExpr . JVar . TxtI + +-- | Convert a ShortText to a Javascript String +jString :: FastString -> JExpr +jString = toJExpr + +-- | Create a 'for' statement +jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat +jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b'] + where b' = case toStat b of + BlockStat xs -> BlockStat $ xs ++ [after] + x -> BlockStat [x,after] + +-- | construct a js declaration with the given identifier +decl :: Ident -> JStat +decl i = DeclStat i Nothing + +-- | The empty JS HashMap +jhEmpty :: M.Map k JExpr +jhEmpty = M.empty + +-- | A singleton JS HashMap +jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr +jhSingle k v = jhAdd k v jhEmpty + +-- | insert a key-value pair into a JS HashMap +jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -> M.Map k JExpr +jhAdd k v m = M.insert k (toJExpr v) m + +-- | Construct a JS HashMap from a list of key-value pairs +jhFromList :: [(FastString, JExpr)] -> JVal +jhFromList = JHash . listToUniqMap + +-- | The empty JS statement +nullStat :: JStat +nullStat = BlockStat [] + + +-------------------------------------------------------------------------------- +-- Combinators +-------------------------------------------------------------------------------- +-- $combinators +-- Combinators operate on terms in the JS EDSL domain to create new terms in the +-- EDSL domain. + +-- | JS infix Equality operators +(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr +(.==.) = InfixExpr EqOp +(.===.) = InfixExpr StrictEqOp +(.!=.) = InfixExpr NeqOp +(.!==.) = InfixExpr StrictNeqOp + +infixl 6 .==., .===., .!=., .!==. + +-- | JS infix Ord operators +(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr +(.>.) = InfixExpr GtOp +(.>=.) = InfixExpr GeOp +(.<.) = InfixExpr LtOp +(.<=.) = InfixExpr LeOp + +infixl 7 .>., .>=., .<., .<=. + +-- | JS infix bit operators +(.|.), (.||.), (.&&.) :: JExpr -> JExpr -> JExpr +(.|.) = InfixExpr BOrOp +(.||.) = InfixExpr LOrOp +(.&&.) = InfixExpr LAndOp + +infixl 8 .||., .&&. + +-- | JS infix bit shift operators +(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr +(.<<.) = InfixExpr LeftShiftOp +(.>>.) = InfixExpr RightShiftOp +(.>>>.) = InfixExpr ZRightShiftOp + +infixl 9 .<<., .>>., .>>>. + +-- | Given a 'JExpr', return the its type. +typeof :: JExpr -> JExpr +typeof = UOpExpr TypeofOp + +-- | JS if-expression +-- +-- > if_ e1 e2 e3 ==> e1 ? e2 : e3 +if_ :: JExpr -> JExpr -> JExpr -> JExpr +if_ e1 e2 e3 = IfExpr e1 e2 e3 + +-- | If-expression which returns statements, see related 'ifBlockS' +-- +-- > if e s1 s2 ==> if(e) { s1 } else { s2 } +ifS :: JExpr -> JStat -> JStat -> JStat +ifS e s1 s2 = IfStat e s1 s2 + +-- | A when-statement as syntactic sugar via `ifS` +-- +-- > jwhenS cond block ==> if(cond) { block } else { } +jwhenS :: JExpr -> JStat -> JStat +jwhenS cond block = ifS cond block mempty + +-- | If-expression which returns blocks +-- +-- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 } +ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat +ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2) + +-- | if-expression that returns 1 if condition <=> true, 0 otherwise +-- +-- > if10 e ==> e ? 1 : 0 +if10 :: JExpr -> JExpr +if10 e = IfExpr e one_ zero_ + +-- | if-expression that returns 0 if condition <=> true, 1 otherwise +-- +-- > if01 e ==> e ? 0 : 1 +if01 :: JExpr -> JExpr +if01 e = IfExpr e zero_ one_ + +-- | an expression application, see related 'appS' +-- +-- > app f xs ==> f(xs) +app :: FastString -> [JExpr] -> JExpr +app f xs = ApplExpr (var f) xs + +-- | A statement application, see the expression form 'app' +appS :: FastString -> [JExpr] -> JStat +appS f xs = ApplStat (var f) xs + +-- | Return a 'JExpr' +returnS :: JExpr -> JStat +returnS e = ReturnStat e + +-- | "for" loop with increment at end of body +loop :: JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat +loop initial test body = jVar $ \i -> + mconcat [ i |= initial + , WhileStat False (test i) (body i) + ] + +-- | "for" loop with increment at end of body +loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat +loopBlockS initial test body = jVar $ \i -> + mconcat [ i |= initial + , WhileStat False (test i) (mconcat (body i)) + ] + +-- | Prefix-increment a 'JExpr' +preIncrS :: JExpr -> JStat +preIncrS x = UOpStat PreIncOp x + +-- | Postfix-increment a 'JExpr' +postIncrS :: JExpr -> JStat +postIncrS x = UOpStat PostIncOp x + +-- | Prefix-decrement a 'JExpr' +preDecrS :: JExpr -> JStat +preDecrS x = UOpStat PreDecOp x + +-- | Postfix-decrement a 'JExpr' +postDecrS :: JExpr -> JStat +postDecrS x = UOpStat PostDecOp x + +-- | Byte indexing of o with a 64-bit offset +off64 :: JExpr -> JExpr -> JExpr +off64 o i = Add o (i .<<. three_) + +-- | Byte indexing of o with a 32-bit offset +off32 :: JExpr -> JExpr -> JExpr +off32 o i = Add o (i .<<. two_) + +-- | Byte indexing of o with a 16-bit offset +off16 :: JExpr -> JExpr -> JExpr +off16 o i = Add o (i .<<. one_) + +-- | Byte indexing of o with a 8-bit offset +off8 :: JExpr -> JExpr -> JExpr +off8 o i = Add o i + +-- | a bit mask to retrieve the lower 8-bits +mask8 :: JExpr -> JExpr +mask8 x = BAnd x (Int 0xFF) + +-- | a bit mask to retrieve the lower 16-bits +mask16 :: JExpr -> JExpr +mask16 x = BAnd x (Int 0xFFFF) + +-- | Sign-extend/narrow a 8-bit value +signExtend8 :: JExpr -> JExpr +signExtend8 x = (BAnd x (Int 0x7F )) `Sub` (BAnd x (Int 0x80)) + +-- | Sign-extend/narrow a 16-bit value +signExtend16 :: JExpr -> JExpr +signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000)) + +-- | Select a property 'prop', from and object 'obj' +-- +-- > obj .^ prop ==> obj.prop +(.^) :: JExpr -> FastString -> JExpr +obj .^ prop = SelExpr obj (TxtI prop) +infixl 8 .^ + +-- | Assign a variable to an expression +-- +-- > foo |= expr ==> var foo = expr; +(|=) :: JExpr -> JExpr -> JStat +(|=) = AssignStat + +-- | Declare a variable and then Assign the variable to an expression +-- +-- > foo |= expr ==> var foo; foo = expr; +(||=) :: Ident -> JExpr -> JStat +i ||= ex = DeclStat i (Just ex) + +infixl 2 ||=, |= + +-- | return the expression at idx of obj +-- +-- > obj .! idx ==> obj[idx] +(.!) :: JExpr -> JExpr -> JExpr +(.!) = IdxExpr + +infixl 8 .! + +assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat +assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys) + +assignAll :: [JExpr] -> [JExpr] -> JStat +assignAll xs ys = mconcat (zipWith (|=) xs ys) + +assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat +assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys)) + +declAssignAll :: [Ident] -> [JExpr] -> JStat +declAssignAll xs ys = mconcat (zipWith (||=) xs ys) + +trace :: ToJExpr a => a -> JStat +trace ex = appS "h$log" [toJExpr ex] + + +-------------------------------------------------------------------------------- +-- Literals +-------------------------------------------------------------------------------- +-- $literals +-- Literals in the JS EDSL are constants in the Haskell domain. These are useful +-- helper values and never change + +-- | The JS literal 'null' +null_ :: JExpr +null_ = var "null" + +-- | The JS literal 0 +zero_ :: JExpr +zero_ = Int 0 + +-- | The JS literal 1 +one_ :: JExpr +one_ = Int 1 + +-- | The JS literal 2 +two_ :: JExpr +two_ = Int 2 + +-- | The JS literal 3 +three_ :: JExpr +three_ = Int 3 + +-- | The JS literal 'undefined' +undefined_ :: JExpr +undefined_ = var "undefined" + +-- | The JS literal 'true' +true_ :: JExpr +true_ = var "true" + +-- | The JS literal 'false' +false_ :: JExpr +false_ = var "false" + +returnStack :: JStat +returnStack = ReturnStat (ApplExpr (var "h$rs") []) + + +-------------------------------------------------------------------------------- +-- Math functions +-------------------------------------------------------------------------------- +-- $math +-- Math functions in the EDSL are literals, with the exception of 'math_' which +-- is the sole math introduction function. + +math :: JExpr +math = var "Math" + +math_ :: FastString -> [JExpr] -> JExpr +math_ op args = ApplExpr (math .^ op) args + +math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan, + math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign, + math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround + :: [JExpr] -> JExpr +math_log = math_ "log" +math_sin = math_ "sin" +math_cos = math_ "cos" +math_tan = math_ "tan" +math_exp = math_ "exp" +math_acos = math_ "acos" +math_asin = math_ "asin" +math_atan = math_ "atan" +math_abs = math_ "abs" +math_pow = math_ "pow" +math_sign = math_ "sign" +math_sqrt = math_ "sqrt" +math_asinh = math_ "asinh" +math_acosh = math_ "acosh" +math_atanh = math_ "atanh" +math_sinh = math_ "sinh" +math_cosh = math_ "cosh" +math_tanh = math_ "tanh" +math_expm1 = math_ "expm1" +math_log1p = math_ "log1p" +math_fround = math_ "fround" + +instance Num JExpr where + x + y = InfixExpr AddOp x y + x - y = InfixExpr SubOp x y + x * y = InfixExpr MulOp x y + abs x = math_abs [x] + negate x = UOpExpr NegOp x + signum x = math_sign [x] + fromInteger x = ValExpr (JInt x) + +instance Fractional JExpr where + x / y = InfixExpr DivOp x y + fromRational x = ValExpr (JDouble (realToFrac x)) + + +-------------------------------------------------------------------------------- +-- Miscellaneous +-------------------------------------------------------------------------------- +-- $misc +-- Everything else, + +-- | Cache "dXXX" field names +dataFieldCache :: Array Int FastString +dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) + +nFieldCache :: Int +nFieldCache = 16384 + +dataFieldName :: Int -> FastString +dataFieldName i + | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i) + | otherwise = dataFieldCache ! i + +dataFieldNames :: [FastString] +dataFieldNames = fmap dataFieldName [1..nFieldCache] + + +-- | Cache "h$dXXX" names +dataCache :: Array Int FastString +dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024]) + +allocData :: Int -> JExpr +allocData i = toJExpr (TxtI (dataCache ! i)) + +-- | Cache "h$cXXX" names +clsCache :: Array Int FastString +clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024]) + +allocClsA :: Int -> JExpr +allocClsA i = toJExpr (TxtI (clsCache ! i)) + + +-------------------------------------------------------------------------------- +-- New Identifiers +-------------------------------------------------------------------------------- + +-- | The 'ToSat' class is heavily used in the Introduction function. It ensures +-- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'. +class ToSat a where + toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident]) + +instance ToSat [JStat] where + toSat_ f vs = IS $ return $ (BlockStat f, reverse vs) + +instance ToSat JStat where + toSat_ f vs = IS $ return $ (f, reverse vs) + +instance ToSat JExpr where + toSat_ f vs = IS $ return $ (toStat f, reverse vs) + +instance ToSat [JExpr] where + toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs) + +instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where + toSat_ f vs = IS $ do + x <- takeOneIdent + runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs) + +-- | Convert A JS expression to a JS statement where applicable. This only +-- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary +-- expression; 'UOpExpr'. +expr2stat :: JExpr -> JStat +expr2stat (ApplExpr x y) = (ApplStat x y) +expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z) +expr2stat (UOpExpr o x) = UOpStat o x +expr2stat _ = nullStat + +takeOneIdent :: State [Ident] Ident +takeOneIdent = do + xxs <- get + case xxs of + (x:xs) -> do + put xs + return x + _ -> error "takeOneIdent: empty list" + diff --git a/compiler/GHC/JS/Ppr.hs b/compiler/GHC/JS/Ppr.hs new file mode 100644 index 0000000000..02529a928f --- /dev/null +++ b/compiler/GHC/JS/Ppr.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} + +-- For Outputable instances for JS syntax +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Pretty-printing JavaScript +module GHC.JS.Ppr + ( renderJs + , renderJs' + , renderPrefixJs + , renderPrefixJs' + , JsToDoc(..) + , defaultRenderJs + , RenderJs(..) + , jsToDoc + , pprStringLit + , flattenBlocks + , braceNest + , hangBrace + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Transform + + +import Data.Char (isControl, ord) +import Data.List (sortOn) + +import Numeric(showHex) + +import GHC.Utils.Outputable (Outputable (..), docToSDoc) +import GHC.Utils.Ppr as PP +import GHC.Data.FastString +import GHC.Types.Unique.Map + +instance Outputable JExpr where + ppr = docToSDoc . renderJs + +instance Outputable JVal where + ppr = docToSDoc . renderJs + + +($$$) :: Doc -> Doc -> Doc +x $$$ y = nest 2 $ x $+$ y + +-- | Render a syntax tree as a pretty-printable document +-- (simply showing the resultant doc produces a nice, +-- well formatted String). +renderJs :: (JsToDoc a, JMacro a) => a -> Doc +renderJs = renderJs' defaultRenderJs + +renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc +renderJs' r = jsToDocR r . jsSaturate Nothing + +data RenderJs = RenderJs + { renderJsS :: !(RenderJs -> JStat -> Doc) + , renderJsE :: !(RenderJs -> JExpr -> Doc) + , renderJsV :: !(RenderJs -> JVal -> Doc) + , renderJsI :: !(RenderJs -> Ident -> Doc) + } + +defaultRenderJs :: RenderJs +defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI + +jsToDoc :: JsToDoc a => a -> Doc +jsToDoc = jsToDocR defaultRenderJs + +-- | Render a syntax tree as a pretty-printable document, using a given prefix +-- to all generated names. Use this with distinct prefixes to ensure distinct +-- generated names between independent calls to render(Prefix)Js. +renderPrefixJs :: (JsToDoc a, JMacro a) => FastString -> a -> Doc +renderPrefixJs pfx = renderPrefixJs' defaultRenderJs pfx + +renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> FastString -> a -> Doc +renderPrefixJs' r pfx = jsToDocR r . jsSaturate (Just $ "jmId_" `mappend` pfx) + +braceNest :: Doc -> Doc +braceNest x = char '{' <+> nest 2 x $$ char '}' + +-- | Hang with braces: +-- +-- hdr { +-- body +-- } +hangBrace :: Doc -> Doc -> Doc +hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] + +class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc +instance JsToDoc JStat where jsToDocR r = renderJsS r r +instance JsToDoc JExpr where jsToDocR r = renderJsE r r +instance JsToDoc JVal where jsToDocR r = renderJsV r r +instance JsToDoc Ident where jsToDocR r = renderJsI r r +instance JsToDoc [JExpr] where + jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc [JStat] where + jsToDocR r = vcat . map ((<> semi) . jsToDocR r) + +defRenderJsS :: RenderJs -> JStat -> Doc +defRenderJsS r = \case + IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond)) + (jsToDocR r x) + $$ mbElse + where mbElse | y == BlockStat [] = PP.empty + | otherwise = hangBrace (text "else") (jsToDocR r y) + DeclStat x Nothing -> text "var" <+> jsToDocR r x + DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e + WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b) + WhileStat True p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p) + UnsatBlock e -> jsToDocR r $ pseudoSaturate e + BreakStat l -> maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l + ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l + LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s + where + printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss + printBS x = jsToDocR r x + interSemi [x] = [jsToDocR r x] + interSemi [] = [] + interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs + + ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b) + where txt | each = "for each" + | otherwise = "for" + SwitchStat e l d -> hangBrace (text "switch" <+> parens (jsToDocR r e)) cases + where l' = map (\(c,s) -> (text "case" <+> parens (jsToDocR r c) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)] + cases = vcat l' + ReturnStat e -> text "return" <+> jsToDocR r e + ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es) + TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally + where mbCatch | s1 == BlockStat [] = PP.empty + | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1) + mbFinally | s2 == BlockStat [] = PP.empty + | otherwise = hangBrace (text "finally") (jsToDocR r s2) + AssignStat i x -> case x of + -- special treatment for functions, otherwise there is too much left padding + -- (more than the length of the expression assigned to). E.g. + -- + -- var long_variable_name = (function() + -- { + -- ... + -- }); + -- + ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] + _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x + UOpStat op x + | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x + | isPre op -> ftext (uOpText op) <> optParens r x + | otherwise -> optParens r x <> ftext (uOpText op) + BlockStat xs -> jsToDocR r (flattenBlocks xs) + +flattenBlocks :: [JStat] -> [JStat] +flattenBlocks = \case + BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys + y:ys -> y : flattenBlocks ys + [] -> [] + +optParens :: RenderJs -> JExpr -> Doc +optParens r x = case x of + UOpExpr _ _ -> parens (jsToDocR r x) + _ -> jsToDocR r x + +defRenderJsE :: RenderJs -> JExpr -> Doc +defRenderJsE r = \case + ValExpr x -> jsToDocR r x + SelExpr x y -> jsToDocR r x <> char '.' <> jsToDocR r y + IdxExpr x y -> jsToDocR r x <> brackets (jsToDocR r y) + IfExpr x y z -> parens (jsToDocR r x <+> char '?' <+> jsToDocR r y <+> char ':' <+> jsToDocR r z) + InfixExpr op x y -> parens $ hsep [jsToDocR r x, ftext (opText op), jsToDocR r y] + UOpExpr op x + | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x + | isPre op -> ftext (uOpText op) <> optParens r x + | otherwise -> optParens r x <> ftext (uOpText op) + ApplExpr je xs -> jsToDocR r je <> (parens . hsep . punctuate comma $ map (jsToDocR r) xs) + UnsatExpr e -> jsToDocR r $ pseudoSaturate e + +defRenderJsV :: RenderJs -> JVal -> Doc +defRenderJsV r = \case + JVar i -> jsToDocR r i + JList xs -> brackets . hsep . punctuate comma $ map (jsToDocR r) xs + JDouble (SaneDouble d) + | d < 0 || isNegativeZero d -> parens (double d) + | otherwise -> double d + JInt i + | i < 0 -> parens (integer i) + | otherwise -> integer i + JStr s -> pprStringLit s + JRegEx s -> hcat [char '/',ftext s, char '/'] + JHash m + | isNullUniqMap m -> text "{}" + | otherwise -> braceNest . hsep . punctuate comma . + map (\(x,y) -> squotes (ftext x) <> colon <+> jsToDocR r y) + -- nonDetEltsUniqMap doesn't introduce non-determinism here + -- because we sort the elements lexically + $ sortOn (LexicalFastString . fst) (nonDetEltsUniqMap m) + JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b) + UnsatVal f -> jsToDocR r $ pseudoSaturate f + +defRenderJsI :: RenderJs -> Ident -> Doc +defRenderJsI _ (TxtI t) = ftext t + + +pprStringLit :: FastString -> Doc +pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] + +encodeJson :: FastString -> Doc +encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) + +encodeJsonChar :: Char -> Doc +encodeJsonChar = \case + '/' -> text "\\/" + '\b' -> text "\\b" + '\f' -> text "\\f" + '\n' -> text "\\n" + '\r' -> text "\\r" + '\t' -> text "\\t" + '"' -> text "\\\"" + '\\' -> text "\\\\" + c + | not (isControl c) && ord c <= 127 -> char c + | ord c <= 0xff -> hexxs "\\x" 2 (ord c) + | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) + | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair + in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> + hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) + where hexxs prefix pad cp = + let h = showHex cp "" + in text (prefix ++ replicate (pad - length h) '0' ++ h) + +uOpText :: JUOp -> FastString +uOpText = \case + NotOp -> "!" + BNotOp -> "~" + NegOp -> "-" + PlusOp -> "+" + NewOp -> "new" + TypeofOp -> "typeof" + DeleteOp -> "delete" + YieldOp -> "yield" + VoidOp -> "void" + PreIncOp -> "++" + PostIncOp -> "++" + PreDecOp -> "--" + PostDecOp -> "--" + +opText :: JOp -> FastString +opText = \case + EqOp -> "==" + StrictEqOp -> "===" + NeqOp -> "!=" + StrictNeqOp -> "!==" + GtOp -> ">" + GeOp -> ">=" + LtOp -> "<" + LeOp -> "<=" + AddOp -> "+" + SubOp -> "-" + MulOp -> "*" + DivOp -> "/" + ModOp -> "%" + LeftShiftOp -> "<<" + RightShiftOp -> ">>" + ZRightShiftOp -> ">>>" + BAndOp -> "&" + BOrOp -> "|" + BXorOp -> "^" + LAndOp -> "&&" + LOrOp -> "||" + InstanceofOp -> "instanceof" + InOp -> "in" + + +isPre :: JUOp -> Bool +isPre = \case + PostIncOp -> False + PostDecOp -> False + _ -> True + +isAlphaOp :: JUOp -> Bool +isAlphaOp = \case + NewOp -> True + TypeofOp -> True + DeleteOp -> True + YieldOp -> True + VoidOp -> True + _ -> False diff --git a/compiler/GHC/JS/Syntax.hs b/compiler/GHC/JS/Syntax.hs new file mode 100644 index 0000000000..66067ced9e --- /dev/null +++ b/compiler/GHC/JS/Syntax.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Syntax +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Syntax defines the Syntax for the JS backend in GHC. It comports +-- with the [ECMA-262](https://tc39.es/ecma262/) although not every +-- production rule of the standard is represented. Code in this module is a +-- fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3 +-- Clause) by Gershom Bazerman, heavily modified to accomodate GHC's +-- constraints. +-- +-- +-- * Strategy +-- +-- Nothing fancy in this module, this is a classic deeply embeded AST for +-- JS. We define numerous ADTs and pattern synonyms to make pattern matching +-- and constructing ASTs easier. +-- +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides +-- helper functions that use the deeply embedded DSL defined in this module +-- to provide some of the benefits of a shallow embedding. +----------------------------------------------------------------------------- +module GHC.JS.Syntax + ( -- * Deeply embedded JS datatypes + JStat(..) + , JExpr(..) + , JVal(..) + , JOp(..) + , JUOp(..) + , Ident(..) + , identFS + , JsLabel + -- * pattern synonyms over JS operators + , pattern New + , pattern Not + , pattern Negate + , pattern Add + , pattern Sub + , pattern Mul + , pattern Div + , pattern Mod + , pattern BOr + , pattern BAnd + , pattern BXor + , pattern BNot + , pattern LOr + , pattern LAnd + , pattern Int + , pattern String + , pattern PreInc + , pattern PostInc + , pattern PreDec + , pattern PostDec + -- * Ident supply + , IdentSupply(..) + , newIdentSupply + , pseudoSaturate + -- * Utility + , SaneDouble(..) + ) where + +import GHC.Prelude + +import Control.DeepSeq + +import Data.Function +import Data.Data +import Data.Word +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Types.Unique +import GHC.Types.Unique.Map + +-- | A supply of identifiers, possibly empty +newtype IdentSupply a + = IS {runIdentSupply :: State [Ident] a} + deriving Typeable + +instance NFData (IdentSupply a) where rnf IS{} = () + +inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b +inIdentSupply f x = IS $ f (runIdentSupply x) + +instance Functor IdentSupply where + fmap f x = inIdentSupply (fmap f) x + +newIdentSupply :: Maybe FastString -> [Ident] +newIdentSupply Nothing = newIdentSupply (Just "jmId") +newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) + | x <- [(0::Word64)..] + ] + +-- | Given a Pseudo-saturate a value with garbage @<<unsatId>>@ identifiers. +pseudoSaturate :: IdentSupply a -> a +pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<<unsatId>>") + +instance Eq a => Eq (IdentSupply a) where + (==) = (==) `on` pseudoSaturate +instance Ord a => Ord (IdentSupply a) where + compare = compare `on` pseudoSaturate +instance Show a => Show (IdentSupply a) where + show x = "(" ++ show (pseudoSaturate x) ++ ")" + + +-------------------------------------------------------------------------------- +-- Statements +-------------------------------------------------------------------------------- +-- | JavaScript statements, see the [ECMA262 +-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) +-- for details +data JStat + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If + | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True + | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch + | TryStat JStat Ident JStat JStat -- ^ Try + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat JUOp JExpr -- ^ Unary operators + | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ + | UnsatBlock (IdentSupply JStat) -- ^ /Unsaturated/ blocks see 'pseudoSaturate' + | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JsLabel) -- ^ Break + | ContinueStat (Maybe JsLabel) -- ^ Continue + deriving (Eq, Typeable, Generic) + +-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of +-- course 'LabelStat' +type JsLabel = LexicalFastString + +instance Semigroup JStat where + (<>) = appendJStat + +instance Monoid JStat where + mempty = BlockStat [] + +-- | Append a statement to another statement. 'appendJStat' only returns a +-- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty +-- 'BlockStat'. That is: +-- > (BlockStat [] , y ) = y +-- > (x , BlockStat []) = x +appendJStat :: JStat -> JStat -> JStat +appendJStat mx my = case (mx,my) of + (BlockStat [] , y ) -> y + (x , BlockStat []) -> x + (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys + (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $ xs : ys + (xs , ys ) -> BlockStat [xs,ys] + + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- +-- | JavaScript Expressions +data JExpr + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr JOp JExpr JExpr -- ^ Infix Expressions, see 'JExpr' + -- pattern synonyms + | UOpExpr JUOp JExpr -- ^ Unary Expressions + | IfExpr JExpr JExpr JExpr -- ^ If-expression + | ApplExpr JExpr [JExpr] -- ^ Application + | UnsatExpr (IdentSupply JExpr) -- ^ An /Unsaturated/ expression. + -- See 'pseudoSaturate' + deriving (Eq, Typeable, Generic) + +-- * Useful pattern synonyms to ease programming with the deeply embedded JS +-- AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and +-- for convienience. In addition we include a string wrapper for JS string +-- and Integer literals. + +-- | pattern synonym for a unary operator new +pattern New :: JExpr -> JExpr +pattern New x = UOpExpr NewOp x + +-- | pattern synonym for prefix increment @++x@ +pattern PreInc :: JExpr -> JExpr +pattern PreInc x = UOpExpr PreIncOp x + +-- | pattern synonym for postfix increment @x++@ +pattern PostInc :: JExpr -> JExpr +pattern PostInc x = UOpExpr PostIncOp x + +-- | pattern synonym for prefix decrement @--x@ +pattern PreDec :: JExpr -> JExpr +pattern PreDec x = UOpExpr PreDecOp x + +-- | pattern synonym for postfix decrement @--x@ +pattern PostDec :: JExpr -> JExpr +pattern PostDec x = UOpExpr PostDecOp x + +-- | pattern synonym for logical not @!@ +pattern Not :: JExpr -> JExpr +pattern Not x = UOpExpr NotOp x + +-- | pattern synonym for unary negation @-@ +pattern Negate :: JExpr -> JExpr +pattern Negate x = UOpExpr NegOp x + +-- | pattern synonym for addition @+@ +pattern Add :: JExpr -> JExpr -> JExpr +pattern Add x y = InfixExpr AddOp x y + +-- | pattern synonym for subtraction @-@ +pattern Sub :: JExpr -> JExpr -> JExpr +pattern Sub x y = InfixExpr SubOp x y + +-- | pattern synonym for multiplication @*@ +pattern Mul :: JExpr -> JExpr -> JExpr +pattern Mul x y = InfixExpr MulOp x y + +-- | pattern synonym for division @*@ +pattern Div :: JExpr -> JExpr -> JExpr +pattern Div x y = InfixExpr DivOp x y + +-- | pattern synonym for remainder @%@ +pattern Mod :: JExpr -> JExpr -> JExpr +pattern Mod x y = InfixExpr ModOp x y + +-- | pattern synonym for Bitwise Or @|@ +pattern BOr :: JExpr -> JExpr -> JExpr +pattern BOr x y = InfixExpr BOrOp x y + +-- | pattern synonym for Bitwise And @&@ +pattern BAnd :: JExpr -> JExpr -> JExpr +pattern BAnd x y = InfixExpr BAndOp x y + +-- | pattern synonym for Bitwise XOr @^@ +pattern BXor :: JExpr -> JExpr -> JExpr +pattern BXor x y = InfixExpr BXorOp x y + +-- | pattern synonym for Bitwise Not @~@ +pattern BNot :: JExpr -> JExpr +pattern BNot x = UOpExpr BNotOp x + +-- | pattern synonym for logical Or @||@ +pattern LOr :: JExpr -> JExpr -> JExpr +pattern LOr x y = InfixExpr LOrOp x y + +-- | pattern synonym for logical And @&&@ +pattern LAnd :: JExpr -> JExpr -> JExpr +pattern LAnd x y = InfixExpr LAndOp x y + + +-- | pattern synonym to create integer values +pattern Int :: Integer -> JExpr +pattern Int x = ValExpr (JInt x) + +-- | pattern synonym to create string values +pattern String :: FastString -> JExpr +pattern String x = ValExpr (JStr x) + + +-------------------------------------------------------------------------------- +-- Values +-------------------------------------------------------------------------------- +-- | JavaScript values +data JVal + = JVar Ident -- ^ A variable reference + | JList [JExpr] -- ^ A JavaScript list, or what JS + -- calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex + | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ + | JFunc [Ident] JStat -- ^ A function + | UnsatVal (IdentSupply JVal) -- ^ An /Unsaturated/ value, see 'pseudoSaturate' + deriving (Eq, Typeable, Generic) + +-------------------------------------------------------------------------------- +-- Operators +-------------------------------------------------------------------------------- +-- | JS Binary Operators. We do not deeply embed the comma operator and the +-- assignment operators +data JOp + = EqOp -- ^ Equality: `==` + | StrictEqOp -- ^ Strict Equality: `===` + | NeqOp -- ^ InEquality: `!=` + | StrictNeqOp -- ^ Strict InEquality `!==` + | GtOp -- ^ Greater Than: `>` + | GeOp -- ^ Greater Than or Equal: `>=` + | LtOp -- ^ Less Than: < + | LeOp -- ^ Less Than or Equal: <= + | AddOp -- ^ Addition: + + | SubOp -- ^ Subtraction: - + | MulOp -- ^ Multiplication \* + | DivOp -- ^ Division: \/ + | ModOp -- ^ Remainder: % + | LeftShiftOp -- ^ Left Shift: \<\< + | RightShiftOp -- ^ Right Shift: \>\> + | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> + | BAndOp -- ^ Bitwise And: & + | BOrOp -- ^ Bitwise Or: | + | BXorOp -- ^ Bitwise XOr: ^ + | LAndOp -- ^ Logical And: && + | LOrOp -- ^ Logical Or: || + | InstanceofOp -- ^ @instanceof@ + | InOp -- ^ @in@ + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JOp + +-- | JS Unary Operators +data JUOp + = NotOp -- ^ Logical Not: @!@ + | BNotOp -- ^ Bitwise Not: @~@ + | NegOp -- ^ Negation: @-@ + | PlusOp -- ^ Unary Plus: @+x@ + | NewOp -- ^ new x + | TypeofOp -- ^ typeof x + | DeleteOp -- ^ delete x + | YieldOp -- ^ yield x + | VoidOp -- ^ void x + | PreIncOp -- ^ Prefix Increment: @++x@ + | PostIncOp -- ^ Postfix Increment: @x++@ + | PreDecOp -- ^ Prefix Decrement: @--x@ + | PostDecOp -- ^ Postfix Decrement: @x--@ + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JUOp + +-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' +-- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on +-- Sane-ness +newtype SaneDouble = SaneDouble + { unSaneDouble :: Double + } + deriving (Data, Typeable, Fractional, Num, Generic, NFData) + +instance Eq SaneDouble where + (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y) + +instance Ord SaneDouble where + compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y) + where fromNaN z | isNaN z = Nothing + | otherwise = Just z + +instance Show SaneDouble where + show (SaneDouble x) = show x + + +-------------------------------------------------------------------------------- +-- Identifiers +-------------------------------------------------------------------------------- +-- We use FastString for identifiers in JS backend + +-- | A newtype wrapper around 'FastString' for JS identifiers. +newtype Ident = TxtI { itxt :: FastString } + deriving stock (Show, Eq) + deriving newtype (Uniquable) + +identFS :: Ident -> FastString +identFS = \case + TxtI fs -> fs diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs new file mode 100644 index 0000000000..72b3980537 --- /dev/null +++ b/compiler/GHC/JS/Transform.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} + +module GHC.JS.Transform + ( mapIdent + , mapStatIdent + , mapExprIdent + , identsS + , identsV + , identsE + -- * Saturation + , jsSaturate + -- * Generic traversal (via compos) + , JMacro(..) + , JMGadt(..) + , Compos(..) + , composOp + , composOpM + , composOpM_ + , composOpFold + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax + +import Data.Functor.Identity +import Control.Monad +import Data.Bifunctor + +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Types.Unique.Map + +mapExprIdent :: (Ident -> JExpr) -> JExpr -> JExpr +mapExprIdent f = fst (mapIdent f) + +mapStatIdent :: (Ident -> JExpr) -> JStat -> JStat +mapStatIdent f = snd (mapIdent f) + +-- | Map on every variable ident +mapIdent :: (Ident -> JExpr) -> (JExpr -> JExpr, JStat -> JStat) +mapIdent f = (map_expr, map_stat) + where + map_expr = \case + ValExpr v -> map_val v + SelExpr e i -> SelExpr (map_expr e) i + IdxExpr e1 e2 -> IdxExpr (map_expr e1) (map_expr e2) + InfixExpr o e1 e2 -> InfixExpr o (map_expr e1) (map_expr e2) + UOpExpr o e -> UOpExpr o (map_expr e) + IfExpr e1 e2 e3 -> IfExpr (map_expr e1) (map_expr e2) (map_expr e3) + ApplExpr e es -> ApplExpr (map_expr e) (fmap map_expr es) + UnsatExpr me -> UnsatExpr (fmap map_expr me) + + map_val v = case v of + JVar i -> f i + JList es -> ValExpr $ JList (fmap map_expr es) + JDouble{} -> ValExpr $ v + JInt{} -> ValExpr $ v + JStr{} -> ValExpr $ v + JRegEx{} -> ValExpr $ v + JHash me -> ValExpr $ JHash (fmap map_expr me) + JFunc is s -> ValExpr $ JFunc is (map_stat s) + UnsatVal v2 -> ValExpr $ UnsatVal v2 + + map_stat s = case s of + DeclStat i e -> DeclStat i (fmap map_expr e) + ReturnStat e -> ReturnStat (map_expr e) + IfStat e s1 s2 -> IfStat (map_expr e) (map_stat s1) (map_stat s2) + WhileStat b e s2 -> WhileStat b (map_expr e) (map_stat s2) + ForInStat b i e s2 -> ForInStat b i (map_expr e) (map_stat s2) + SwitchStat e les s2 -> SwitchStat (map_expr e) (fmap (bimap map_expr map_stat) les) (map_stat s2) + TryStat s2 i s3 s4 -> TryStat (map_stat s2) i (map_stat s3) (map_stat s4) + BlockStat ls -> BlockStat (fmap map_stat ls) + ApplStat e es -> ApplStat (map_expr e) (fmap map_expr es) + UOpStat o e -> UOpStat o (map_expr e) + AssignStat e1 e2 -> AssignStat (map_expr e1) (map_expr e2) + UnsatBlock ms -> UnsatBlock (fmap map_stat ms) + LabelStat l s2 -> LabelStat l (map_stat s2) + BreakStat{} -> s + ContinueStat{} -> s + +{-# INLINE identsS #-} +identsS :: JStat -> [Ident] +identsS = \case + DeclStat i e -> [i] ++ maybe [] identsE e + ReturnStat e -> identsE e + IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 + WhileStat _ e s -> identsE e ++ identsS s + ForInStat _ i e s -> [i] ++ identsE e ++ identsS s + SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s + where traverseCase (e,s) = identsE e ++ identsS s + TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3 + BlockStat xs -> concatMap identsS xs + ApplStat e es -> identsE e ++ concatMap identsE es + UOpStat _op e -> identsE e + AssignStat e1 e2 -> identsE e1 ++ identsE e2 + UnsatBlock{} -> error "identsS: UnsatBlock" + LabelStat _l s -> identsS s + BreakStat{} -> [] + ContinueStat{} -> [] + +{-# INLINE identsE #-} +identsE :: JExpr -> [Ident] +identsE = \case + ValExpr v -> identsV v + SelExpr e _i -> identsE e -- do not rename properties + IdxExpr e1 e2 -> identsE e1 ++ identsE e2 + InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2 + UOpExpr _ e -> identsE e + IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3 + ApplExpr e es -> identsE e ++ concatMap identsE es + UnsatExpr{} -> error "identsE: UnsatExpr" + +{-# INLINE identsV #-} +identsV :: JVal -> [Ident] +identsV = \case + JVar i -> [i] + JList xs -> concatMap identsE xs + JDouble{} -> [] + JInt{} -> [] + JStr{} -> [] + JRegEx{} -> [] + JHash m -> concatMap (identsE . snd) (nonDetEltsUniqMap m) + JFunc args s -> args ++ identsS s + UnsatVal{} -> error "identsV: UnsatVal" + + +{-------------------------------------------------------------------- + Compos +--------------------------------------------------------------------} +-- | Compos and ops for generic traversal as defined over +-- the JMacro ADT. + +-- | Utility class to coerce the ADT into a regular structure. + +class JMacro a where + jtoGADT :: a -> JMGadt a + jfromGADT :: JMGadt a -> a + +instance JMacro Ident where + jtoGADT = JMGId + jfromGADT (JMGId x) = x + +instance JMacro JStat where + jtoGADT = JMGStat + jfromGADT (JMGStat x) = x + +instance JMacro JExpr where + jtoGADT = JMGExpr + jfromGADT (JMGExpr x) = x + +instance JMacro JVal where + jtoGADT = JMGVal + jfromGADT (JMGVal x) = x + +-- | Union type to allow regular traversal by compos. +data JMGadt a where + JMGId :: Ident -> JMGadt Ident + JMGStat :: JStat -> JMGadt JStat + JMGExpr :: JExpr -> JMGadt JExpr + JMGVal :: JVal -> JMGadt JVal + +composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b +composOp f = runIdentity . composOpM (Identity . f) + +composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b) +composOpM = compos return ap + +composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m () +composOpM_ = composOpFold (return ()) (>>) + +composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b +composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f) + +newtype C b a = C { unC :: b } + +class Compos t where + compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) + -> (forall a. t a -> m (t a)) -> t c -> m (t c) + +instance Compos JMGadt where + compos = jmcompos + +jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c) +jmcompos ret app f' v = + case v of + JMGId _ -> ret v + JMGStat v' -> ret JMGStat `app` case v' of + DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e + ReturnStat i -> ret ReturnStat `app` f i + IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s' + WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s + ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s + SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d + where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l + BlockStat xs -> ret BlockStat `app` mapM' f xs + ApplStat e xs -> ret ApplStat `app` f e `app` mapM' f xs + TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2 + UOpStat o e -> ret (UOpStat o) `app` f e + AssignStat e e' -> ret AssignStat `app` f e `app` f e' + UnsatBlock _ -> ret v' + ContinueStat l -> ret (ContinueStat l) + BreakStat l -> ret (BreakStat l) + LabelStat l s -> ret (LabelStat l) `app` f s + JMGExpr v' -> ret JMGExpr `app` case v' of + ValExpr e -> ret ValExpr `app` f e + SelExpr e e' -> ret SelExpr `app` f e `app` f e' + IdxExpr e e' -> ret IdxExpr `app` f e `app` f e' + InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e' + UOpExpr o e -> ret (UOpExpr o) `app` f e + IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e'' + ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs + UnsatExpr _ -> ret v' + JMGVal v' -> ret JMGVal `app` case v' of + JVar i -> ret JVar `app` f i + JList xs -> ret JList `app` mapM' f xs + JDouble _ -> ret v' + JInt _ -> ret v' + JStr _ -> ret v' + JRegEx _ -> ret v' + JHash m -> ret JHash `app` m' + -- nonDetEltsUniqMap doesn't introduce nondeterminism here because the + -- elements are treated independently before being re-added to a UniqMap + where (ls, vs) = unzip (nonDetEltsUniqMap m) + m' = ret (listToUniqMap . zip ls) `app` mapM' f vs + JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s + UnsatVal _ -> ret v' + + where + mapM' :: forall a. (a -> m a) -> [a] -> m [a] + mapM' g = foldr (app . app (ret (:)) . g) (ret []) + mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a) + mapMaybeM' g = \case + Nothing -> ret Nothing + Just a -> app (ret Just) (g a) + f :: forall b. JMacro b => b -> m b + f x = ret jfromGADT `app` f' (jtoGADT x) + +{-------------------------------------------------------------------- + Saturation +--------------------------------------------------------------------} + +-- | Given an optional prefix, fills in all free variable names with a supply +-- of names generated by the prefix. +jsSaturate :: (JMacro a) => Maybe FastString -> a -> a +jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) + +jsSaturate_ :: (JMacro a) => a -> IdentSupply a +jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) + where + go :: forall a. JMGadt a -> State [Ident] (JMGadt a) + go v = case v of + JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) + JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) + JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) + _ -> composOpM go v diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index b81b286d54..2bbe6dfc17 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -64,23 +64,27 @@ it is supported by both gcc and clang. Anecdotally nvcc supports -} linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary logger tmpfs dflags unit_env o_files dep_units = do +linkBinary = linkBinary' False + +linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do let platform = ue_platform unit_env unit_state = ue_units unit_env toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags - output_fn = exeFileName platform False (outputFile_ dflags) + arch_os = platformArchOS platform + output_fn = exeFileName arch_os staticLink (outputFile_ dflags) namever = ghcNameVersion dflags ways_ = ways dflags - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. - full_output_fn <- if isAbsolute output_fn then return output_fn else do d <- getCurrentDirectory return $ normalise (d </> output_fn) + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) let pkg_lib_paths = collectLibraryDirs ways_ pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths @@ -267,7 +271,8 @@ linkStaticLib logger dflags unit_env o_files dep_units = do let platform = ue_platform unit_env extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs - output_fn = exeFileName platform True (outputFile_ dflags) + arch_os = platformArchOS platform + output_fn = exeFileName arch_os True (outputFile_ dflags) namever = ghcNameVersion dflags ways_ = ways dflags diff --git a/compiler/GHC/Linker/Static/Utils.hs b/compiler/GHC/Linker/Static/Utils.hs index 6439d197d8..787147caac 100644 --- a/compiler/GHC/Linker/Static/Utils.hs +++ b/compiler/GHC/Linker/Static/Utils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} + module GHC.Linker.Static.Utils where import GHC.Prelude @@ -12,20 +14,18 @@ import System.FilePath -- Use the provided filename (if any), otherwise use "main.exe" (Windows), -- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the -- extension if it is missing. -exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath -exeFileName platform staticLink output_fn - | Just s <- output_fn = - case platformOS platform of - OSMinGW32 -> s <?.> "exe" - _ -> if staticLink - then s <?.> "a" - else s - | otherwise = - if platformOS platform == OSMinGW32 - then "main.exe" - else if staticLink - then "liba.a" - else "a.out" +exeFileName :: ArchOS -> Bool -> Maybe FilePath -> FilePath +exeFileName (ArchOS arch os) staticLink output_fn + | Just s <- output_fn = if + | OSMinGW32 <- os -> s <?.> "exe" + | ArchJavaScript <- arch -> s <?.> "jsexe" + | staticLink -> s <?.> "a" + | otherwise -> s + | otherwise = if + | OSMinGW32 <- os -> "main.exe" + | ArchJavaScript <- arch -> "main.jsexe" + | staticLink -> "liba.a" + | otherwise -> "a.out" where s <?.> ext | null (takeExtension s) = s <.> ext | otherwise = s diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 4956920fb1..a94eebfc83 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -61,7 +61,7 @@ module GHC.Stg.Syntax ( -- ppr StgPprOpts(..), panicStgPprOpts, shortStgPprOpts, - pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, + pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, pprStgAlt, pprGenStgTopBinding, pprStgTopBinding, pprGenStgTopBindings, pprStgTopBindings ) where diff --git a/compiler/GHC/StgToJS.hs b/compiler/GHC/StgToJS.hs new file mode 100644 index 0000000000..8a0b1e59fe --- /dev/null +++ b/compiler/GHC/StgToJS.hs @@ -0,0 +1,216 @@ +module GHC.StgToJS + ( stgToJS + ) +where + +import GHC.StgToJS.CodeGen + + +-- Note [StgToJS design] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- +-- StgToJS ("JS backend") is adapted from GHCJS [GHCJS2013]. +-- +-- Haskell to JavaScript +-- ~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS converts STG into a JavaScript AST (in GHC.JS) that has been adapted +-- from JMacro [JMacro]. +-- +-- Tail calls: translated code is tail call optimized through a trampoline, +-- since JavaScript implementations don't always support tail calls. +-- +-- JavaScript ASTs are then optimized. A dataflow analysis is performed and then +-- dead code and redundant assignments are removed. +-- +-- Primitives +-- ~~~~~~~~~~ +-- Haskell primitives have to be represented as JavaScript values. This is done +-- as follows: +-- +-- - Int#/Int32# -> number in Int32 range +-- - Int16# -> number in Int16 range +-- - Int8# -> number in Int8 range +-- - Word#/Word32# -> number in Word32 range +-- - Word16# -> number in Word16 range +-- - Word8# -> number in Word8 range +-- +-- - Float#/Double# -> both represented as Javascript Double (no Float!) +-- +-- - Int64# -> represented with two fields: +-- high -> number in Int32 range +-- low -> number in Word32 range +-- - Word64# -> represented with two fields: high, low +-- high -> number in Word32 range +-- low -> number in Word32 range +-- +-- - Addr# -> represented with two fields: array (used as a namespace) and index +-- - StablePtr# -> similar to Addr# with array fixed to h$stablePtrBuf +-- +-- - JSVal# -> any Javascript object (used to pass JS objects via FFI) +-- +-- - TVar#, MVar#, etc. are represented with JS objects +-- +-- Foreign JavaScript imports +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS supports inline JavaScript code. Example: +-- +-- > foreign import javascript unsafe +-- > "((x,y) => x + y)" +-- > plus :: Int -> Int -> Int +-- +-- Currently the JS backend only supports functions as JS imports. +-- +-- In comparison, GHCJS supports JavaScript snippets with $1, $2... variables +-- as placeholders for the arguments. It requires a JavaScript parser that the +-- JS backend lacks. In GHCJS, the parser is inherited from JMacro and supports +-- local variable declarations, loops, etc. Local variables are converted to +-- hygienic names to avoid capture. +-- +-- Primitives that are represented as multiple values (Int64#, Word64#, Addr#) +-- are passed to FFI functions with multiple arguments. +-- +-- Interruptible convention: FFI imports with the "interruptible" calling +-- convention are passed an extra argument (usually named "$c") that is a +-- continuation function. The FFI function must call this function to return to +-- Haskell code. +-- +-- Unboxed tuples: returning an unboxed tuple can be done with the predefined +-- macros RETURN_UBX_TUPn where n is the size of the tuples. Internally it uses +-- predefined "h$retN" global variables to pass additional values; the first +-- element of the tuple is returned normally. +-- +-- Memory management +-- ~~~~~~~~~~~~~~~~~ +-- Heap objects are represented as JavaScript values. +-- +-- Most heap objects are represented generically as JavaScript "objects" (hash +-- maps). However, some Haskell heap objects can use use a more memory efficient +-- JavaScript representation: number, string... An example of a consequence of +-- this is that both Int# and Int are represented the same as a JavaScript +-- number. JavaScript introspection (e.g. typeof) is used to differentiate +-- heap object representations when necessary. +-- +-- Generic representation: objects on the heap ("closures") are represented as +-- JavaScript objects with the following fields: +-- +-- { f -- (function) entry function + info table +-- , d1 -- two fields of payload +-- , d2 +-- , m -- GC mark +-- , cc -- optional cost-center +-- } +-- +-- Payload: payload only consists of two fields (d1, d2). When more than two +-- fields of payload are required, the second field is itself an object. +-- payload [] ==> { d1 = null, d2 = null } +-- payload [a] ==> { d1 = a , d2 = null } +-- payload [a,b] ==> { d1 = a , d2 = b } +-- payload [a,b,c] ==> { d1 = a , d2 = { d1 = b, d2 = c} } +-- payload [a,b,c...] ==> { d1 = a , d2 = { d1 = b, d2 = c, ...} } +-- +-- Entry function/ info tables: JavaScript functions are JavaScript objects. If +-- "f" is a function, we can: +-- - call it, e.g. "f(arg0,arg1...)" +-- - get/set its fields, e.g. "f.xyz = abc" +-- This is used to implement the equivalent of tables-next-to-code in +-- JavaScript: every heap object has an entry function "f" that also contains +-- some metadata (info table) about the Haskell object: +-- { t -- object type +-- , size -- number of fields in the payload (-1 if variable layout) +-- , i -- (array) fields layout (empty if variable layout) +-- , n -- (string) object name for easier dubugging +-- , a -- constructor tag / fun arity +-- , r -- ?? +-- , s -- static references? +-- , m -- GC mark? +-- } +-- +-- Payloads for each kind of heap object: +-- +-- THUNK = +-- { f = returns the object reduced to WHNF +-- , m = ? +-- , d1 = ? +-- , d2 = ? +-- } +-- +-- FUN = +-- { f = function itself +-- , m = ? +-- , d1 = free variable 1 +-- , d2 = free variable 2 +-- } +-- +-- There are two different kinds of partial application: +-- - pap_r : pre-generated PAP that contains r registers +-- - pap_gen : generic PAP, contains any number of registers +-- +-- PAP = +-- { f = ? +-- , m = ? +-- , d1 = function +-- , d2 = +-- { d1 & 0xff = number of args (PAP arity) +-- , d1 >> 8 = number of registers (r for h$pap_r) +-- , d2, d3... = args (r) +-- } +-- } +-- +-- CON = +-- { f = entry function of the datacon worker +-- , m = 0 +-- , d1 = first arg +-- , d2 = arity = 2: second arg +-- arity > 2: { d1, d2, ...} object with remaining args (starts with "d1 = x2"!) +-- } +-- +-- BLACKHOLE = +-- { f = h$blackhole +-- , m = ? +-- , d1 = owning TSO +-- , d2 = waiters array +-- } +-- +-- StackFrame closures are *not* represented as JS objects. Instead they are +-- "unpacked" in the stack, i.e. a stack frame occupies a few slots in the JS +-- array representing the stack ("h$stack"). +-- +-- When a shared thunk is entered, it is overriden with a black hole ("eager +-- blackholing") and an update frame is pushed on the stack. +-- +-- Stack: the Haskell stack is implemented with a dynamically growing JavaScript +-- array ("h$stack"). +-- TODO: does it shrink sometimes? +-- TODO: what are the elements of the stack? one JS object per stack frame? +-- +-- +-- Interaction with JavaScript's garbage collector +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Using JS objects to represent Haskell heap objects means that JS's GC does +-- most of the memory management work. +-- +-- However, GHC extends Haskell with features that rely on GC layer violation +-- (weak references, finalizers, etc.). To support these features, a heap scan +-- is can be performed (using TSOs, StablePtr, etc. as roots) to mark reachable +-- objects. Scanning the heap is an expensive operation, but fortunately it +-- doesn't need to happen too often and it can be disabled. +-- +-- TODO: importance of eager blackholing +-- +-- Concurrency +-- ~~~~~~~~~~~ +-- The scheduler is implemented in JS and runs in a single JavaScript thread +-- (similarly to the C RTS not using `-threaded`). +-- +-- The scheduler relies on callbacks/continuations to interact with other JS +-- codes (user interface, etc.). In particular, safe foreign import can use "$c" +-- as a continuation function to return to Haskell code. +-- +-- TODO: is this still true since 2013 or are we using more recent JS features now? +-- TODO: synchronous threads +-- +-- +-- REFERENCES +-- * [GHCJS2013] "Demo Proposal: GHCJS, Concurrent Haskell in the Browser", Luite Stegeman, +-- 2013 (https://www.haskell.org/haskell-symposium/2013/ghcjs.pdf) +-- * [JMacro] https://hackage.haskell.org/package/jmacro diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs new file mode 100644 index 0000000000..6d40f8a7ac --- /dev/null +++ b/compiler/GHC/StgToJS/Apply.hs @@ -0,0 +1,1152 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Apply +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- Module that deals with expression application in JavaScript. In some cases we +-- rely on pre-generated functions that are bundled with the RTS (see rtsApply). +----------------------------------------------------------------------------- + +module GHC.StgToJS.Apply + ( genApp + , rtsApply + ) +where + +import GHC.Prelude hiding ((.|.)) + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure +import GHC.StgToJS.DataCon +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Monad +import GHC.StgToJS.Types +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils +import GHC.StgToJS.Rts.Types +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Types.Literal +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.CostCentre + +import GHC.Stg.Syntax + +import GHC.Builtin.Names + +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Encoding +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Outputable (vcat, ppr) +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import Data.Monoid +import Data.Array + +-- | Pre-generated functions for fast Apply. +-- These are bundled with the RTS. +rtsApply :: StgToJSConfig -> JStat +rtsApply cfg = BlockStat $ + map (specApply cfg) applySpec + ++ map (pap cfg) specPap + ++ [ mkApplyArr + , genericStackApply cfg + , genericFastApply cfg + , zeroApply cfg + , updates cfg + , papGen cfg + , moveRegs2 + , selectors cfg + ] + + +-- | Generate an application of some args to an Id. +-- +-- The case where args is null is common as it's used to generate the evaluation +-- code for an Id. +genApp + :: HasDebugCallStack + => ExprCtx + -> Id + -> [StgArg] + -> G (JStat, ExprResult) +genApp ctx i args + + -- Case: unpackCStringAppend# "some string"# str + -- + -- Generates h$appendToHsStringA(str, "some string"), which has a faster + -- decoding loop. + | [StgLitArg (LitString bs), x] <- args + , [top] <- concatMap typex_expr (ctxTarget ctx) + , getUnique i == unpackCStringAppendIdKey + , d <- utf8DecodeByteString bs + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsStringA" ([toJExpr d, toJExpr a] ++ profArg) + , ExprInline Nothing + ) + + -- let-no-escape + | Just n <- ctxLneBindingStackSize ctx i + = do + as' <- concatMapM genArg args + ei <- varForEntryId i + let ra = mconcat . reverse $ + zipWith (\r a -> toJExpr r |= a) [R1 ..] as' + p <- pushLneFrame n ctx + a <- adjSp 1 -- for the header (which will only be written when the thread is suspended) + return (ra <> p <> a <> returnS ei, ExprCont) + + -- proxy# + | [] <- args + , getUnique i == proxyHashKey + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return (top |= null_, ExprInline Nothing) + + -- unboxed tuple or strict type: return fields individually + | [] <- args + , isUnboxedTupleType (idType i) || isStrictType (idType i) + = do + a <- storeIdFields i (ctxTarget ctx) + return (a, ExprInline Nothing) + + -- Handle alternative heap object representation: in some cases, a heap + -- object is not represented as a JS object but directly as a number or a + -- string. I.e. only the payload is stored because the box isn't useful. + -- It happens for "Int Int#" for example: no need to box the Int# in JS. + -- + -- We must check that: + -- - the object is subject to the optimization (cf isUnboxable predicate) + -- - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we + -- need to evaluate it properly first. + -- + -- In which case we generate a dynamic check (using isObject) that either: + -- - returns the payload of the heap object, if it uses the generic heap + -- object representation + -- - returns the object directly, otherwise + | [] <- args + , [vt] <- idVt i + , isUnboxable vt + , ctxIsEvaluated ctx i + = do + let c = head (concatMap typex_expr $ ctxTarget ctx) + is <- varsForId i + case is of + [i'] -> + return ( c |= if_ (isObject i') (closureField1 i') i' + , ExprInline Nothing + ) + _ -> panic "genApp: invalid size" + + -- case of Id without args and known to be already evaluated: return fields + -- individually + | [] <- args + , ctxIsEvaluated ctx i || isStrictType (idType i) + = do + a <- storeIdFields i (ctxTarget ctx) + -- optional runtime assert for detecting unexpected thunks (unevaluated) + settings <- getSettings + let ww = case concatMap typex_expr (ctxTarget ctx) of + [t] | csAssertRts settings -> + ifS (isObject t .&&. isThunk t) + (appS "throw" [String "unexpected thunk"]) -- yuck + mempty + _ -> mempty + return (a `mappend` ww, ExprInline Nothing) + + + -- Case: "newtype" datacon wrapper + -- + -- If the wrapped argument is known to be already evaluated, then we don't + -- need to enter it. + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + = do + as <- concatMapM genArg args + case as of + [ai] -> do + let t = head (concatMap typex_expr (ctxTarget ctx)) + a' = case args of + [StgVarArg a'] -> a' + _ -> panic "genApp: unexpected arg" + if isStrictId a' || ctxIsEvaluated ctx a' + then return (t |= ai, ExprInline Nothing) + else return (returnS (app "h$e" [ai]), ExprCont) + _ -> panic "genApp: invalid size" + + -- no args and Id can't be a function: just enter it + | [] <- args + , idFunRepArity i == 0 + , not (might_be_a_function (idType i)) + = do + enter_id <- genIdArg i >>= + \case + [x] -> return x + xs -> pprPanic "genApp: unexpected multi-var argument" + (vcat [ppr (length xs), ppr i]) + return (returnS (app "h$e" [enter_id]), ExprCont) + + -- fully saturated global function: + -- - deals with arguments + -- - jumps into the function + | n <- length args + , n /= 0 + , idFunRepArity i == n + , not (isLocalId i) + , isStrictId i + = do + as' <- concatMapM genArg args + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToII i as' is + return (jmp, ExprCont) + + -- oversaturated function: + -- - push continuation with extra args + -- - deals with arguments + -- - jumps into the function + | idFunRepArity i < length args + , isStrictId i + , idFunRepArity i > 0 + = do + let (reg,over) = splitAt (idFunRepArity i) args + reg' <- concatMapM genArg reg + pc <- pushCont over + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToII i reg' is + return (pc <> jmp, ExprCont) + + -- generic apply: + -- - try to find a pre-generated apply function that matches + -- - use it if any + -- - otherwise use generic apply function h$ap_gen_fast + | otherwise + = do + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToFast args is + return (jmp, ExprCont) + +-- avoid one indirection for global ids +-- fixme in many cases we can also jump directly to the entry for local? +jumpToII :: Id -> [JExpr] -> JStat -> G JStat +jumpToII i vars load_app_in_r1 + | isLocalId i = do + ii <- varForId i + return $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , returnS (closureEntry ii) + ] + | otherwise = do + ei <- varForEntryId i + return $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , returnS ei + ] + +-- | Try to use a specialized pre-generated application function. +-- If there is none, use h$ap_gen_fast instead +jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat +jumpToFast args load_app_in_r1 = do + -- get JS expressions for every argument + -- Arguments may have more than one expression (e.g. Word64#) + vars <- concatMapM genArg args + -- try to find a specialized apply function + let spec = mkApplySpec RegsConv args vars + ap_fun <- selectApply spec + pure $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , case ap_fun of + -- specialized apply: no tag + Right fun -> returnS (ApplExpr fun []) + -- generic apply: pass a tag indicating number of args/slots + Left fun -> returnS (ApplExpr fun [specTagExpr spec]) + ] + +-- | Calling convention for an apply function +data ApplyConv + = RegsConv -- ^ Fast calling convention: use registers + | StackConv -- ^ Slow calling convention: use the stack + deriving (Show,Eq,Ord) + +-- | Name of the generic apply function +genericApplyName :: ApplyConv -> FastString +genericApplyName = \case + RegsConv -> "h$ap_gen_fast" + StackConv -> "h$ap_gen" + +-- | Expr of the generic apply function +genericApplyExpr :: ApplyConv -> JExpr +genericApplyExpr conv = var (genericApplyName conv) + + +-- | Return the name of the specialized apply function for the given number of +-- args, number of arg variables, and calling convention. +specApplyName :: ApplySpec -> FastString +specApplyName = \case + -- specialize a few for compiler performance (avoid building FastStrings over + -- and over for common cases) + ApplySpec RegsConv 0 0 -> "h$ap_0_0_fast" + ApplySpec StackConv 0 0 -> "h$ap_0_0" + ApplySpec RegsConv 1 0 -> "h$ap_1_0_fast" + ApplySpec StackConv 1 0 -> "h$ap_1_0" + ApplySpec RegsConv 1 1 -> "h$ap_1_1_fast" + ApplySpec StackConv 1 1 -> "h$ap_1_1" + ApplySpec RegsConv 1 2 -> "h$ap_1_2_fast" + ApplySpec StackConv 1 2 -> "h$ap_1_2" + ApplySpec RegsConv 2 1 -> "h$ap_2_1_fast" + ApplySpec StackConv 2 1 -> "h$ap_2_1" + ApplySpec RegsConv 2 2 -> "h$ap_2_2_fast" + ApplySpec StackConv 2 2 -> "h$ap_2_2" + ApplySpec RegsConv 2 3 -> "h$ap_2_3_fast" + ApplySpec StackConv 2 3 -> "h$ap_2_3" + ApplySpec conv nargs nvars -> mkFastString $ mconcat + [ "h$ap_", show nargs + , "_" , show nvars + , case conv of + RegsConv -> "_fast" + StackConv -> "" + ] + +-- | Return the expression of the specialized apply function for the given +-- number of args, number of arg variables, and calling convention. +-- +-- Warning: the returned function may not be generated! Use specApplyExprMaybe +-- if you want to ensure that it exists. +specApplyExpr :: ApplySpec -> JExpr +specApplyExpr spec = var (specApplyName spec) + +-- | Return the expression of the specialized apply function for the given +-- number of args, number of arg variables, and calling convention. +-- Return Nothing if it isn't generated. +specApplyExprMaybe :: ApplySpec -> Maybe JExpr +specApplyExprMaybe spec = + if spec `elem` applySpec + then Just (specApplyExpr spec) + else Nothing + +-- | Make an ApplySpec from a calling convention, a list of Haskell args, and a +-- list of corresponding JS variables +mkApplySpec :: ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec +mkApplySpec conv args vars = ApplySpec + { specConv = conv + , specArgs = length args + , specVars = length vars + } + +-- | Find a specialized application function if there is one +selectApply + :: ApplySpec + -> G (Either JExpr JExpr) -- ^ the function to call (Left for generic, Right for specialized) +selectApply spec = + case specApplyExprMaybe spec of + Just e -> return (Right e) + Nothing -> return (Left (genericApplyExpr (specConv spec))) + + +-- | Apply specification +data ApplySpec = ApplySpec + { specConv :: !ApplyConv -- ^ Calling convention + , specArgs :: !Int -- ^ number of Haskell arguments + , specVars :: !Int -- ^ number of JavaScript variables for the arguments + } + deriving (Show,Eq,Ord) + +-- | List of specialized apply function templates +applySpec :: [ApplySpec] +applySpec = [ ApplySpec conv nargs nvars + | conv <- [RegsConv, StackConv] + , nargs <- [0..4] + , nvars <- [max 0 (nargs-1)..(nargs*2)] + ] + +-- | Generate a tag for the given ApplySpec +-- +-- Warning: tag doesn't take into account the calling convention +specTag :: ApplySpec -> Int +specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. (specArgs spec) + +-- | Generate a tag expression for the given ApplySpec +specTagExpr :: ApplySpec -> JExpr +specTagExpr = toJExpr . specTag + +-- | Build arrays to quickly lookup apply functions +-- +-- h$apply[r << 8 | n] = function application for r regs, n args +-- h$paps[r] = partial application for r registers (number of args is in the object) +mkApplyArr :: JStat +mkApplyArr = mconcat + [ TxtI "h$apply" ||= toJExpr (JList []) + , TxtI "h$paps" ||= toJExpr (JList []) + , ApplStat (var "h$initStatic" .^ "push") + [ ValExpr $ JFunc [] $ jVar \i -> mconcat + [ i |= zero_ + , WhileStat False (i .<. Int 65536) $ mconcat + [ var "h$apply" .! i |= var "h$ap_gen" + , preIncrS i + ] + , i |= zero_ + , WhileStat False (i .<. Int 128) $ mconcat + [ var "h$paps" .! i |= var "h$pap_gen" + , preIncrS i + ] + , mconcat (map assignSpec applySpec) + , mconcat (map assignPap specPap) + ] + ] + ] + where + assignSpec :: ApplySpec -> JStat + assignSpec spec = case specConv spec of + -- both fast/slow (regs/stack) specialized apply functions have the same + -- tags. We store the stack ones in the array because they are used as + -- continuation stack frames. + StackConv -> var "h$apply" .! specTagExpr spec |= specApplyExpr spec + RegsConv -> mempty + + assignPap :: Int -> JStat + assignPap p = var "h$paps" .! toJExpr p |= + (var (mkFastString $ ("h$pap_" ++ show p))) + +-- | Push a continuation on the stack +-- +-- First push the given args, then push an apply function (specialized if +-- possible, otherwise the generic h$ap_gen function). +pushCont :: HasDebugCallStack + => [StgArg] + -> G JStat +pushCont args = do + vars <- concatMapM genArg args + let spec = mkApplySpec StackConv args vars + selectApply spec >>= \case + Right app -> push $ reverse $ app : vars + Left app -> push $ reverse $ app : specTagExpr spec : vars + +-- | Generic stack apply function (h$ap_gen) that can do everything, but less +-- efficiently than other more specialized functions. +-- +-- Stack layout: +-- -3: ... +-- -2: args +-- -1: tag (number of arg slots << 8 | number of args) +-- +-- Regs: +-- R1 = applied closure +-- +genericStackApply :: StgToJSConfig -> JStat +genericStackApply cfg = closure info body + where + -- h$ap_gen body + body = jVar \cf -> + [ traceRts cfg (jString "h$ap_gen") + , cf |= closureEntry r1 + -- switch on closure type + , SwitchStat (entryClosureType cf) + [ (toJExpr Thunk , thunk_case cfg cf) + , (toJExpr Fun , fun_case cf (funArity' cf)) + , (toJExpr Pap , fun_case cf (papArity r1)) + , (toJExpr Blackhole, blackhole_case cfg) + ] + (default_case cf) + ] + + -- info table for h$ap_gen + info = ClosureInfo + { ciVar = TxtI "h$ap_gen" + , ciRegs = CIRegs 0 [PtrV] -- closure to apply to + , ciName = "h$ap_gen" + , ciLayout = CILayoutVariable + , ciType = CIStackFrame + , ciStatic = mempty + } + + default_case cf = appS "throw" [jString "h$ap_gen: unexpected closure type " + + (entryClosureType cf)] + + thunk_case cfg cf = mconcat + [ profStat cfg pushRestoreCCS + , returnS cf + ] + + blackhole_case cfg = mconcat + [ push' cfg [r1, var "h$return"] + , returnS (app "h$blockOnBlackhole" [r1]) + ] + + fun_case c arity = jVar \tag needed_args needed_regs given_args given_regs newTag newAp p dat -> + [ tag |= stack .! (sp - 1) -- tag on the stack + , given_args |= mask8 tag -- indicates the number of passed args + , given_regs |= tag .>>. 8 -- and the number of passed values for registers + , needed_args |= mask8 arity + , needed_regs |= arity .>>. 8 + , traceRts cfg (jString "h$ap_gen: args: " + given_args + + jString " regs: " + given_regs) + , ifBlockS (given_args .===. needed_args) + -------------------------------- + -- exactly saturated application + -------------------------------- + [ traceRts cfg (jString "h$ap_gen: exact") + -- Set registers to register values on the stack + , loop 0 (.<. given_regs) \i -> mconcat + [ appS "h$setReg" [i+2, stack .! (sp-2-i)] + , postIncrS i + ] + -- drop register values from the stack + , sp |= sp - given_regs - 2 + -- enter closure in R1 + , returnS c + ] + [ ifBlockS (given_args .>. needed_args) + ---------------------------- + -- oversaturated application + ---------------------------- + [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args + + jString " regs: " + needed_regs) + -- load needed register values + , loop 0 (.<. needed_regs) \i -> mconcat + [ traceRts cfg (jString "h$ap_gen: loading register: " + i) + , appS "h$setReg" [i+2, stack .! (sp-2-i)] + , postIncrS i + ] + -- compute new tag with consumed register values and args removed + , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args) + -- find application function for the remaining regs/args + , newAp |= var "h$apply" .! newTag + , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n")) + + -- Drop used registers from the stack. + -- Test if the application function needs a tag and push it. + , ifS (newAp .===. var "h$ap_gen") + ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp - needed_regs - 1) + + -- Push generic application function as continuation + , stack .! sp |= newAp + + -- Push "current thread CCS restore" function as continuation + , profStat cfg pushRestoreCCS + + -- enter closure in R1 + , returnS c + ] + + ----------------------------- + -- undersaturated application + ----------------------------- + [ traceRts cfg (jString "h$ap_gen: undersat") + -- find PAP entry function corresponding to given_regs count + , p |= var "h$paps" .! given_regs + + -- build PAP payload: R1 + tag + given register values + , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args) + , dat |= toJExpr [r1, newTag] + , loop 0 (.<. given_regs) \i -> mconcat + [ (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)] + , postIncrS i + ] + + -- remove register values from the stack. + , sp |= sp - given_regs - 2 + + -- alloc PAP closure, store reference to it in R1. + , r1 |= initClosure cfg p dat jCurrentCCS + + -- return to the continuation on the stack + , returnStack + ] + ] + ] + +-- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less +-- efficiently than other more specialized functions. +-- +-- Signature tag in argument. Tag: (regs << 8 | arity) +-- +-- Regs: +-- R1 = closure to apply to +-- +genericFastApply :: StgToJSConfig -> JStat +genericFastApply s = + TxtI "h$ap_gen_fast" ||= jLam \tag -> jVar \c -> + [traceRts s (jString "h$ap_gen_fast: " + tag) + , c |= closureEntry r1 + , SwitchStat (entryClosureType c) + [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk") + <> pushStackApply c tag + <> returnS c) + , (toJExpr Fun, jVar \farity -> + [ farity |= funArity' c + , traceRts s (jString "h$ap_gen_fast: fun " + farity) + , funCase c tag farity + ]) + , (toJExpr Pap, jVar \parity -> + [ parity |= papArity r1 + , traceRts s (jString "h$ap_gen_fast: pap " + parity) + , funCase c tag parity + ]) + , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con") + <> jwhenS (tag .!=. 0) + (appS "throw" [jString "h$ap_gen_fast: invalid apply"]) + <> returnS c) + , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole") + <> pushStackApply c tag + <> push' s [r1, var "h$return"] + <> returnS (app "h$blockOnBlackhole" [r1])) + ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + entryClosureType c] + ] + + where + -- thunk: push everything to stack frame, enter thunk first + pushStackApply :: JExpr -> JExpr -> JStat + pushStackApply _c tag = + jVar \ap -> + [ pushAllRegs tag + , ap |= var "h$apply" .! tag + , ifS (ap .===. var "h$ap_gen") + ((sp |= sp + 2) <> (stack .! (sp-1) |= tag)) + (sp |= sp + 1) + , stack .! sp |= ap + , profStat s pushRestoreCCS + ] + + funCase :: JExpr -> JExpr -> JExpr -> JStat + funCase c tag arity = + jVar \ar myAr myRegs regsStart newTag newAp dat p -> + [ ar |= mask8 arity + , myAr |= mask8 tag + , myRegs |= tag .>>. 8 + , traceRts s (jString "h$ap_gen_fast: args: " + myAr + + jString " regs: " + myRegs) + , ifS (myAr .===. ar) + -- call the function directly + (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c) + (ifBlockS (myAr .>. ar) + -- push stack frame with remaining args, then call fun + [ traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , regsStart |= (arity .>>. 8) + 1 + , sp |= sp + myRegs - regsStart + 1 + , traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , pushArgs regsStart myRegs + , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar + , newAp |= var "h$apply" .! newTag + , ifS (newAp .===. var "h$ap_gen") + ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp + 1) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , returnS c + ] + -- else + [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag) + , jwhenS (tag .!=. 0) $ mconcat + [ p |= var "h$paps" .! myRegs + , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr] + , loop 0 (.<. myRegs) + (\i -> (dat .^ "push") + `ApplStat` [app "h$getReg" [i+2]] <> postIncrS i) + , r1 |= initClosure s p dat jCurrentCCS + ] + , returnStack + ]) + ] + + + pushAllRegs :: JExpr -> JStat + pushAllRegs tag = + jVar \regs -> + [ regs |= tag .>>. 8 + , sp |= sp + regs + , SwitchStat regs (map pushReg [65,64..2]) mempty + ] + where + pushReg :: Int -> (JExpr, JStat) + pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= jsReg r) + + pushArgs :: JExpr -> JExpr -> JStat + pushArgs start end = + loop end (.>=.start) (\i -> traceRts s (jString "pushing register: " + i) + <> (stack .! (sp + start - i) |= app "h$getReg" [i+1]) + <> postDecrS i + ) + +-- | Make specialized apply function for the given ApplySpec +specApply :: StgToJSConfig -> ApplySpec -> JStat +specApply cfg spec@(ApplySpec conv nargs nvars) = + let fun_name = specApplyName spec + in case conv of + RegsConv -> fastApply cfg fun_name nargs nvars + StackConv -> stackApply cfg fun_name nargs nvars + +-- | Make specialized apply function with Stack calling convention +stackApply + :: StgToJSConfig + -> FastString + -> Int + -> Int + -> JStat +stackApply s fun_name nargs nvars = + -- special case for h$ap_0_0 + if nargs == 0 && nvars == 0 + then closure info0 body0 + else closure info body + where + info = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutUnknown nvars) CIStackFrame mempty + info0 = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutFixed 0 []) CIStackFrame mempty + + body0 = adjSpN' 1 <> enter s r1 + + body = jVar \c -> + [ c |= closureEntry r1 + , traceRts s (toJExpr fun_name + + jString " " + + (c .^ "n") + + jString " sp: " + sp + + jString " a: " + (c .^ "a")) + , SwitchStat (entryClosureType c) + [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c) + , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> funCase c) + , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> papCase c) + , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1])) + ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (entryClosureType c)]) + ] + + funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c + stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..nvars] + + papCase :: JExpr -> JStat + papCase c = jVar \expr arity0 arity -> + case expr of + ValExpr (JVar pap) -> [ arity0 |= papArity r1 + , arity |= mask8 arity0 + , traceRts s (toJExpr (fun_name <> ": found pap, arity: ") + arity) + , ifS (toJExpr nargs .===. arity) + --then + (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) + -- else + (ifS (toJExpr nargs .>. arity) + (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversatCase c arity0 arity) + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap r1 (toJExpr nargs) stackArgs + <> (sp |= sp - toJExpr (nvars + 1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + + funCase :: JExpr -> JStat + funCase c = jVar \expr ar0 ar -> + case expr of + ValExpr (JVar pap) -> [ ar0 |= funArity' c + , ar |= mask8 ar0 + , ifS (toJExpr nargs .===. ar) + (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) + (ifS (toJExpr nargs .>. ar) + (traceRts s (toJExpr (fun_name <> ": oversat")) + <> oversatCase c ar0 ar) + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap (toJExpr R1) (toJExpr nargs) stackArgs + <> (sp |= sp - toJExpr (nvars+1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + + -- oversat: call the function but keep enough on the stack for the next + oversatCase :: JExpr -- function + -> JExpr -- the arity tag + -> JExpr -- real arity (arity & 0xff) + -> JStat + oversatCase c arity arity0 = + jVar \rs newAp -> + [ rs |= (arity .>>. 8) + , loadRegs rs + , sp |= sp - rs + , newAp |= (var "h$apply" .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8))) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n")) + , returnS c + ] + where + loadRegs rs = SwitchStat rs switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, jsReg (x+1) |= stack .! (sp - toJExpr x))) [nvars,nvars-1..1] + +-- | Make specialized apply function with Regs calling convention +-- +-- h$ap_n_r_fast is entered if a function of unknown arity is called, n +-- arguments are already in r registers +fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat +fastApply s fun_name nargs nvars = func ||= body0 + where + -- special case for h$ap_0_0_fast + body0 = if nargs == 0 && nvars == 0 + then jLam (enter s r1) + else toJExpr (JFunc myFunArgs body) + + func = TxtI fun_name + + myFunArgs = [] + + regArgs = take nvars jsRegsFromR2 + + mkAp :: Int -> Int -> [JExpr] + mkAp n' r' = [ specApplyExpr (ApplySpec StackConv n' r') ] + + body = + jVar \c farity arity -> + [ c |= closureEntry r1 + , traceRts s (toJExpr (fun_name <> ": sp ") + sp) + , SwitchStat (entryClosureType c) + [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ") + + clName c + + jString " (arity: " + (c .^ "a") + jString ")") + <> (farity |= funArity' c) + <> funCase c farity) + ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> funCase c arity) + ,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c) + ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))] + (appS "throw" [toJExpr (fun_name <> ": unexpected closure type: ") + entryClosureType c]) + ] + + funCase :: JExpr -> JExpr -> JStat + funCase c arity = jVar \arg ar -> case arg of + ValExpr (JVar pap) -> [ ar |= mask8 arity + , ifS (toJExpr nargs .===. ar) + -- then + (traceRts s (toJExpr (fun_name <> ": exact")) <> returnS c) + -- else + (ifS (toJExpr nargs .>. ar) + --then + (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversatCase c arity) + -- else + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap r1 (toJExpr nargs) regArgs + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + oversatCase :: JExpr -> JExpr -> JStat + oversatCase c arity = + jVar \rs rsRemain -> + [ rs |= arity .>>. 8 + , rsRemain |= toJExpr nvars - rs + , traceRts s (toJExpr + (fun_name <> " regs oversat ") + + rs + + jString " remain: " + + rsRemain) + , saveRegs rs + , sp |= sp + rsRemain + 1 + , stack .! sp |= var "h$apply" .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity)) + , profStat s pushRestoreCCS + , returnS c + ] + where + saveRegs n = SwitchStat n switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (nvars-x)) |= jsReg (x+2))) [0..nvars-1] + +zeroApply :: StgToJSConfig -> JStat +zeroApply s = mconcat + [ TxtI "h$e" ||= jLam (\c -> (r1 |= c) <> enter s c) + ] + +-- carefully enter a closure that might be a thunk or a function + +-- ex may be a local var, but must've been copied to R1 before calling this +enter :: StgToJSConfig -> JExpr -> JStat +enter s ex = jVar \c -> + [ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack + , c |= closureEntry ex + , jwhenS (c .===. var "h$unbox_e") ((r1 |= closureField1 ex) <> returnStack) + , SwitchStat (entryClosureType c) + [ (toJExpr Con, mempty) + , (toJExpr Fun, mempty) + , (toJExpr Pap, returnStack) + , (toJExpr Blackhole, push' s [var "h$ap_0_0", ex, var "h$return"] + <> returnS (app "h$blockOnBlackhole" [ex])) + ] (returnS c) + ] + +updates :: StgToJSConfig -> JStat +updates s = BlockStat + [ closure + (ClosureInfo (TxtI "h$upd_frame") (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + $ jVar \updatee waiters ss si sir -> + let unbox_closure = Closure + { clEntry = var "h$unbox_e" + , clField1 = sir + , clField2 = null_ + , clMeta = 0 + , clCC = Nothing + } + updateCC updatee = closureCC updatee |= jCurrentCCS + in [ updatee |= stack .! (sp - 1) + , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc") + , -- wake up threads blocked on blackhole + waiters |= closureField2 updatee + , jwhenS (waiters .!==. null_) + (loop 0 (.<. waiters .^ "length") + (\i -> appS "h$wakeupThread" [waiters .! i] <> postIncrS i)) + , -- update selectors + jwhenS ((app "typeof" [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel")) + ((ss |= closureMeta updatee .^ "sel") + <> loop 0 (.<. ss .^ "length") \i -> mconcat + [ si |= ss .! i + , sir |= (closureField2 si) `ApplExpr` [r1] + , ifS (app "typeof" [sir] .===. jTyObject) + (copyClosure DontCopyCC si sir) + (assignClosure si unbox_closure) + , postIncrS i + ]) + , -- overwrite the object + ifS (app "typeof" [r1] .===. jTyObject) + (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureEntry r1) .^ "n")) + , copyClosure DontCopyCC updatee r1 + ]) + -- the heap object is represented by another type of value + -- (e.g. a JS number or string) so the unboxing closure + -- will simply return it. + (assignClosure updatee (unbox_closure { clField1 = r1 })) + , profStat s (updateCC updatee) + , adjSpN' 2 + , traceRts s (jString "h$upd_frame: updating: " + + updatee + + jString " -> " + + r1) + , returnStack + ] + + , closure + (ClosureInfo (TxtI "h$upd_frame_lne") (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + $ jVar \updateePos -> + [ updateePos |= stack .! (sp - 1) + , (stack .! updateePos |= r1) + , adjSpN' 2 + , traceRts s (jString "h$upd_frame_lne: updating: " + + updateePos + + jString " -> " + + r1) + , returnStack + ] + ] + +selectors :: StgToJSConfig -> JStat +selectors s = + mkSel "1" closureField1 + <> mkSel "2a" closureField2 + <> mkSel "2b" (closureField1 . closureField2) + <> mconcat (map mkSelN [3..16]) + where + mkSelN :: Int -> JStat + mkSelN x = mkSel (mkFastString $ show x) + (\e -> SelExpr (closureField2 (toJExpr e)) + (TxtI $ mkFastString ("d" ++ show (x-1)))) + + + mkSel :: FastString -> (JExpr -> JExpr) -> JStat + mkSel name sel = mconcat + [TxtI createName ||= jLam \r -> mconcat + [ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc")) + , ifS (isThunk r .||. isBlackhole r) + (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)])) + (returnS (sel r)) + ] + , TxtI resName ||= jLam \r -> mconcat + [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc")) + , returnS (sel r) + ] + , closure + (ClosureInfo (TxtI entryName) (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar \tgt -> + [ tgt |= closureField1 r1 + , traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc")) + , ifS (isThunk tgt .||. isBlackhole tgt) + (preIncrS sp + <> (stack .! sp |= var frameName) + <> returnS (app "h$e" [tgt])) + (returnS (app "h$e" [sel tgt])) + ]) + , closure + (ClosureInfo (TxtI frameName) (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ traceRts s (toJExpr ("selector frame: " <> name)) + , postDecrS sp + , returnS (app "h$e" [sel r1]) + ] + ] + + where + v x = JVar (TxtI x) + n ext = "h$c_sel_" <> name <> ext + createName = n "" + resName = n "_res" + entryName = n "_e" + frameName = n "_frame_e" + + +-- arity is the remaining arity after our supplied arguments are applied +mkPap :: StgToJSConfig + -> Ident -- ^ id of the pap object + -> JExpr -- ^ the function that's called (can be a second pap) + -> JExpr -- ^ number of arguments in pap + -> [JExpr] -- ^ values for the supplied arguments + -> JStat +mkPap s tgt fun n values = + traceRts s (toJExpr $ "making pap with: " ++ show (length values) ++ " items") + `mappend` + allocDynamic s True tgt (toJExpr entry) (fun:papAr:map toJExpr values') + (if csProf s then Just jCurrentCCS else Nothing) + where + papAr = funOrPapArity fun Nothing - toJExpr (length values * 256) - n + + values' | GHC.Prelude.null values = [null_] + | otherwise = values + entry | length values > numSpecPap = TxtI "h$pap_gen" + | otherwise = specPapIdents ! length values + +-- | Number of specialized PAPs (pre-generated for a given number of args) +numSpecPap :: Int +numSpecPap = 6 + +-- specialized (faster) pap generated for [0..numSpecPap] +-- others use h$pap_gen +specPap :: [Int] +specPap = [0..numSpecPap] + +-- | Cache of specialized PAP idents +specPapIdents :: Array Int Ident +specPapIdents = listArray (0,numSpecPap) $ map (TxtI . mkFastString . ("h$pap_"++) . show) specPap + +pap :: StgToJSConfig + -> Int + -> JStat +pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body + where + funcIdent = TxtI funcName + funcName = mkFastString ("h$pap_" ++ show r) + + body = jVar \c d f extra -> + [ c |= closureField1 r1 + , d |= closureField2 r1 + , f |= closureEntry c + , assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap") + , profStat s (enterCostCentreFun currentCCS) + , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r + , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra) + , moveBy extra + , loadOwnArgs d + , r1 |= c + , returnS f + ] + moveBy extra = SwitchStat extra + (reverse $ map moveCase [1..maxReg-r-1]) mempty + moveCase m = (toJExpr m, jsReg (m+r+1) |= jsReg (m+1)) + loadOwnArgs d = mconcat $ map (\r -> + jsReg (r+1) |= dField d (r+2)) [1..r] + dField d n = SelExpr d (TxtI . mkFastString $ ('d':show (n-1))) + +-- Construct a generic PAP +papGen :: StgToJSConfig -> JStat +papGen cfg = + closure (ClosureInfo funcIdent CIRegsUnknown funcName CILayoutVariable CIPap mempty) + (jVar \c f d pr or r -> + [ c |= closureField1 r1 + , d |= closureField2 r1 + , f |= closureEntry c + , pr |= funOrPapArity c (Just f) .>>. 8 + , or |= papArity r1 .>>. 8 + , r |= pr - or + , assertRts cfg + (isFun' f .||. isPap' f) + (jString "h$pap_gen: expected function or pap") + , profStat cfg (enterCostCentreFun currentCCS) + , traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or) + , appS "h$moveRegs2" [or, r] + , loadOwnArgs d r + , r1 |= c + , returnS f + ]) + + + where + funcIdent = TxtI funcName + funcName = "h$pap_gen" + loadOwnArgs d r = + let prop n = d .^ ("d" <> mkFastString (show $ n+1)) + loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n) + in SwitchStat r (map loadOwnArg [127,126..1]) mempty + +-- general utilities +-- move the first n registers, starting at R2, m places up (do not use with negative m) +moveRegs2 :: JStat +moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch + where + moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m) + -- fast cases + switchCases = [switchCase n m | n <- [1..5], m <- [1..4]] + switchCase :: Int -> Int -> (JExpr, JStat) + switchCase n m = (toJExpr $ + (n `Bits.shiftL` 8) Bits..|. m + , mconcat (map (`moveRegFast` m) [n+1,n..2]) + <> BreakStat Nothing {-[j| break; |]-}) + moveRegFast n m = jsReg (n+m) |= jsReg n + -- fallback + defaultCase n m = + loop n (.>.0) (\i -> appS "h$setReg" [i+1+m, app "h$getReg" [i+1]] `mappend` postDecrS i) + + +-- Initalize a variable sized object from an array of values +initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr +initClosure cfg entry values ccs = app "h$init_closure" + [ newClosure $ Closure + { clEntry = entry + , clField1 = null_ + , clField2 = null_ + , clMeta = 0 + , clCC = if csProf cfg then Just ccs else Nothing + } + , values + ] + +-- | Return an expression for every field of the given Id +getIdFields :: Id -> G [TypedExpr] +getIdFields i = assocIdExprs i <$> varsForId i + +-- | Store fields of Id into the given target expressions +storeIdFields :: Id -> [TypedExpr] -> G JStat +storeIdFields i dst = do + fields <- getIdFields i + pure (assignCoerce1 dst fields) diff --git a/compiler/GHC/StgToJS/Arg.hs b/compiler/GHC/StgToJS/Arg.hs new file mode 100644 index 0000000000..854bf7cc17 --- /dev/null +++ b/compiler/GHC/StgToJS/Arg.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Args +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Code generation of application arguments +----------------------------------------------------------------------------- + +module GHC.StgToJS.Arg + ( genArg + , genIdArg + , genIdArgI + , genIdStackArgI + , allocConStatic + , allocUnboxedConStatic + , allocateStaticList + , jsStaticArg + , jsStaticArgs + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.DataCon +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Literal +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Profiling +import GHC.StgToJS.Ids + +import GHC.Builtin.Types +import GHC.Stg.Syntax +import GHC.Core.DataCon + +import GHC.Types.CostCentre +import GHC.Types.Unique.FM +import GHC.Types.Id + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Control.Monad.Trans.State.Strict as State + +{- +Note [ Unboxable Literals Optimization ] +~~~~~~~~~~~~~~~~~~ + +Boxable types in the JS backend are represented as heap objects. See Note +[StgToJS design] in GHC.StgToJS.hs for more details. Some types, such as Int8 +do not benefit from not being wrapped in an object in the JS runtime. This optimization +detects such types and changes the code generator to generate a more efficient +representation. The change is minor and saves one level on indirection. Instead +of generating a wrapper object with a field for the value's payload, such as: + +// a JS object for an Int8 +var anInt8 = { d1 = <Int8# payload> + , f : entry function which would scrutinize the payload + } + +we instead generate: + +// notice, no wrapper object. This representation is essentially an Int8# in the JS backend +var anInt8 = <Int8# payload> + +This optimization fires when the follow invariants hold: + 1. The value in question has a Type which has a single data constructor + 2. The data constructor holds a single field that is monomorphic + 3. The value in question is distinguishable from a THUNK using the JavaScript typeof operator. + +From the haskell perspective this means that: + 1. An Int8# is always a JavaScript 'number', never a JavaScript object. + 2. An Int8 is either a JavaScript 'number' _or_ a JavaScript object depending on + its use case and this optimization. + +How is this sound? +~~~~~~~~~~~~~~~~~~ + +Normally this optimization would violate the guarantees of call-by-need, however +we are able to statically detect whether the type in question will be a THUNK or +not during code gen because the JS backend is consuming STG and we can check +during runtime with the typeof operator. Similarly we can check at runtime using +JavaScript's introspection operator `typeof`. Thus, when we know the value in +question will not be a THUNK we can safely elide the wrapping object, which +unboxes the value in the JS runtime. For example, an Int8 contains an Int8# +which has the JavaScript type 'number'. A THUNK of type Int8 would have a +JavaScript type 'object', so using 'typeof' allows us to check if we have +something that is definitely evaluated (i.e., a 'number') or something else. If +it is an 'object' then we may need to enter it to begin its evaluation. Consider +a type which has a 'ThreadId#' field; such as type would not be subject to this +optimization because it has to be represented as a JavaScript 'object' and thus +cannot be unboxed in this way. Another (edge) case is Int64#. Int64# is +similarly not unboxable in this way because Int64# does not fit in one +JavaScript variable and thus requires an 'object' for its representation in the +JavaScript runtime. + +-} + +-- | Generate JS code for static arguments +genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg] +genStaticArg a = case a of + StgLitArg l -> map StaticLitArg <$> genStaticLit l + StgVarArg i -> do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Nothing -> reg + Just expr -> unfloated expr + where + r = uTypeVt . stgArgType $ a + reg + | isVoid r = + return [] + | i == trueDataConId = + return [StaticLitArg (BoolLit True)] + | i == falseDataConId = + return [StaticLitArg (BoolLit False)] + | isMultiVar r = + map (\(TxtI t) -> StaticObjArg t) <$> mapM (identForIdN i) [1..varSize r] -- this seems wrong, not an obj? + | otherwise = (\(TxtI it) -> [StaticObjArg it]) <$> identForId i + + unfloated :: CgStgExpr -> G [StaticArg] + unfloated (StgLit l) = map StaticLitArg <$> genStaticLit l + unfloated (StgConApp dc _n args _) + | isBoolDataCon dc || isUnboxableCon dc = + (:[]) . allocUnboxedConStatic dc . concat <$> mapM genStaticArg args -- fixme what is allocunboxedcon? + | null args = (\(TxtI t) -> [StaticObjArg t]) <$> identForId (dataConWorkId dc) + | otherwise = do + as <- concat <$> mapM genStaticArg args + (TxtI e) <- identForDataConWorker dc + return [StaticConArg e as] + unfloated x = pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) + +-- | Generate JS code for an StgArg +genArg :: HasDebugCallStack => StgArg -> G [JExpr] +genArg a = case a of + StgLitArg l -> genLit l + StgVarArg i -> do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Just expr -> unfloated expr + Nothing + | isVoid r -> return [] + | i == trueDataConId -> return [true_] + | i == falseDataConId -> return [false_] + | isMultiVar r -> mapM (varForIdN i) [1..varSize r] + | otherwise -> (:[]) <$> varForId i + + where + -- if our argument is a joinid, it can be an unboxed tuple + r :: HasDebugCallStack => VarType + r = uTypeVt . stgArgType $ a + + unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr] + unfloated = \case + StgLit l -> genLit l + StgConApp dc _n args _ + | isBoolDataCon dc || isUnboxableCon dc + -> (:[]) . allocUnboxedCon dc . concat <$> mapM genArg args + | null args -> (:[]) <$> varForId (dataConWorkId dc) + | otherwise -> do + as <- concat <$> mapM genArg args + e <- varForDataConWorker dc + inl_alloc <- csInlineAlloc <$> getSettings + return [allocDynamicE inl_alloc e as Nothing] + x -> pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) + +-- | Generate a Var as JExpr +genIdArg :: HasDebugCallStack => Id -> G [JExpr] +genIdArg i = genArg (StgVarArg i) + +-- | Generate an Id as an Ident +genIdArgI :: HasDebugCallStack => Id -> G [Ident] +genIdArgI i + | isVoid r = return [] + | isMultiVar r = mapM (identForIdN i) [1..varSize r] + | otherwise = (:[]) <$> identForId i + where + r = uTypeVt . idType $ i + +-- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case +genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)] +genIdStackArgI i = zipWith f [1..] <$> genIdArgI i + where + f :: Int -> Ident -> (Ident,StackSlot) + f n ident = (ident, SlotId i n) + +-- | Allocate Static Constructors +allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G () +allocConStatic (TxtI to) cc con args = do + as <- mapM genStaticArg args + cc' <- costCentreStackLbl cc + allocConStatic' cc' (concat as) + where + -- see Note [ Unboxable Literals Optimization ] for the purpose of these + -- checks + allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G () + allocConStatic' cc' [] + | isBoolDataCon con && dataConTag con == 1 = + emitStatic to (StaticUnboxed $ StaticUnboxedBool False) cc' + | isBoolDataCon con && dataConTag con == 2 = + emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc' + | otherwise = do + (TxtI e) <- identForDataConWorker con + emitStatic to (StaticData e []) cc' + allocConStatic' cc' [x] + | isUnboxableCon con = + case x of + StaticLitArg (IntLit i) -> + emitStatic to (StaticUnboxed $ StaticUnboxedInt i) cc' + StaticLitArg (BoolLit b) -> + emitStatic to (StaticUnboxed $ StaticUnboxedBool b) cc' + StaticLitArg (DoubleLit d) -> + emitStatic to (StaticUnboxed $ StaticUnboxedDouble d) cc' + _ -> + pprPanic "allocConStatic: invalid unboxed literal" (ppr x) + allocConStatic' cc' xs = + if con == consDataCon + then case args of + (a0:a1:_) -> flip (emitStatic to) cc' =<< allocateStaticList [a0] a1 + _ -> panic "allocConStatic: invalid args for consDataCon" + else do + (TxtI e) <- identForDataConWorker con + emitStatic to (StaticData e xs) cc' + +-- | Allocate unboxed constructors +allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg +allocUnboxedConStatic con = \case + [] + | isBoolDataCon con && dataConTag con == 1 + -> StaticLitArg (BoolLit False) + | isBoolDataCon con && dataConTag con == 2 + -> StaticLitArg (BoolLit True) + [a@(StaticLitArg (IntLit _i))] -> a + [a@(StaticLitArg (DoubleLit _d))] -> a + _ -> pprPanic "allocUnboxedConStatic: not an unboxed constructor" (ppr con) + + +-- | Allocate Static list +allocateStaticList :: [StgArg] -> StgArg -> G StaticVal +allocateStaticList xs a@(StgVarArg i) + | isDataConId_maybe i == Just nilDataCon = listAlloc xs Nothing + | otherwise = do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Just (StgConApp dc _n [h,t] _) + | dc == consDataCon -> allocateStaticList (h:xs) t + _ -> listAlloc xs (Just a) + where + listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal + listAlloc xs Nothing = do + as <- concat . reverse <$> mapM genStaticArg xs + return (StaticList as Nothing) + listAlloc xs (Just r) = do + as <- concat . reverse <$> mapM genStaticArg xs + r' <- genStaticArg r + case r' of + [StaticObjArg ri] -> return (StaticList as (Just ri)) + _ -> + pprPanic "allocateStaticList: invalid argument (tail)" (ppr (xs, r)) +allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list" + +-- | Generate JS code corresponding to a static arg +jsStaticArg :: StaticArg -> JExpr +jsStaticArg = \case + StaticLitArg l -> toJExpr l + StaticObjArg t -> ValExpr (JVar (TxtI t)) + StaticConArg c args -> + allocDynamicE False (ValExpr . JVar . TxtI $ c) (map jsStaticArg args) Nothing + +-- | Generate JS code corresponding to a list of static args +jsStaticArgs :: [StaticArg] -> JExpr +jsStaticArgs = ValExpr . JList . map jsStaticArg + diff --git a/compiler/GHC/StgToJS/Closure.hs b/compiler/GHC/StgToJS/Closure.hs new file mode 100644 index 0000000000..7c758ede95 --- /dev/null +++ b/compiler/GHC/StgToJS/Closure.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module GHC.StgToJS.Closure + ( closureInfoStat + , closure + , conClosure + , Closure (..) + , newClosure + , assignClosure + , CopyCC (..) + , copyClosure + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Regs (stack,sp) + +import GHC.JS.Make +import GHC.JS.Syntax + +import Data.Monoid +import qualified Data.Bits as Bits + +closureInfoStat :: Bool -> ClosureInfo -> JStat +closureInfoStat debug (ClosureInfo obj rs name layout ctype srefs) + = setObjInfoL debug obj rs layout ty name tag srefs + where + !ty = case ctype of + CIThunk -> Thunk + CIFun {} -> Fun + CICon {} -> Con + CIBlackhole -> Blackhole + CIPap -> Pap + CIStackFrame -> StackFrame + !tag = case ctype of + CIThunk -> 0 + CIFun arity nregs -> mkArityTag arity nregs + CICon con -> con + CIBlackhole -> 0 + CIPap -> 0 + CIStackFrame -> 0 + + +setObjInfoL :: Bool -- ^ debug: output symbol names + -> Ident -- ^ the object name + -> CIRegs -- ^ things in registers + -> CILayout -- ^ layout of the object + -> ClosureType -- ^ closure type + -> FastString -- ^ object name, for printing + -> Int -- ^ `a' argument, depends on type (arity, conid) + -> CIStatic -- ^ static refs + -> JStat +setObjInfoL debug obj rs layout t n a + = setObjInfo debug obj t n field_types a size rs + where + size = case layout of + CILayoutVariable -> (-1) + CILayoutUnknown sz -> sz + CILayoutFixed sz _ -> sz + field_types = case layout of + CILayoutVariable -> [] + CILayoutUnknown size -> toTypeList (replicate size ObjV) + CILayoutFixed _ fs -> toTypeList fs + +setObjInfo :: Bool -- ^ debug: output all symbol names + -> Ident -- ^ the thing to modify + -> ClosureType -- ^ closure type + -> FastString -- ^ object name, for printing + -> [Int] -- ^ list of item types in the object, if known (free variables, datacon fields) + -> Int -- ^ extra 'a' parameter, for constructor tag or arity + -> Int -- ^ object size, -1 (number of vars) for unknown + -> CIRegs -- ^ things in registers + -> CIStatic -- ^ static refs + -> JStat +setObjInfo debug obj t name fields a size regs static + | debug = appS "h$setObjInfo" [ toJExpr obj + , toJExpr t + , toJExpr name + , toJExpr fields + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] + | otherwise = appS "h$o" [ toJExpr obj + , toJExpr t + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] + where + regTag CIRegsUnknown = -1 + regTag (CIRegs skip types) = + let nregs = sum $ map varSize types + in skip + (nregs `Bits.shiftL` 8) + +closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@ + -> JStat -- ^ rhs + -> JStat +closure ci body = (ciVar ci ||= jLam body) `mappend` closureInfoStat False ci + +conClosure :: Ident -> FastString -> CILayout -> Int -> JStat +conClosure symbol name layout constr = + closure (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty) + (returnS (stack .! sp)) + +-- | Used to pass arguments to newClosure with some safety +data Closure = Closure + { clEntry :: JExpr + , clField1 :: JExpr + , clField2 :: JExpr + , clMeta :: JExpr + , clCC :: Maybe JExpr + } + +newClosure :: Closure -> JExpr +newClosure Closure{..} = + let xs = [ (closureEntry_ , clEntry) + , (closureField1_, clField1) + , (closureField2_, clField2) + , (closureMeta_ , clMeta) + ] + in case clCC of + -- CC field is optional (probably to minimize code size as we could assign + -- null_, but we get the same effect implicitly) + Nothing -> ValExpr (jhFromList xs) + Just cc -> ValExpr (jhFromList $ (closureCC_,cc) : xs) + +assignClosure :: JExpr -> Closure -> JStat +assignClosure t Closure{..} = BlockStat + [ closureEntry t |= clEntry + , closureField1 t |= clField1 + , closureField2 t |= clField2 + , closureMeta t |= clMeta + ] <> case clCC of + Nothing -> mempty + Just cc -> closureCC t |= cc + +data CopyCC = CopyCC | DontCopyCC + +copyClosure :: CopyCC -> JExpr -> JExpr -> JStat +copyClosure copy_cc t s = BlockStat + [ closureEntry t |= closureEntry s + , closureField1 t |= closureField1 s + , closureField2 t |= closureField2 s + , closureMeta t |= closureMeta s + ] <> case copy_cc of + DontCopyCC -> mempty + CopyCC -> closureCC t |= closureCC s diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs new file mode 100644 index 0000000000..7703398aea --- /dev/null +++ b/compiler/GHC/StgToJS/CodeGen.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +-- | JavaScript code generator +module GHC.StgToJS.CodeGen + ( stgToJS + ) +where + +import GHC.Prelude + +import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js)) + +import GHC.JS.Ppr +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Arg +import GHC.StgToJS.Sinker +import GHC.StgToJS.Types +import qualified GHC.StgToJS.Object as Object +import GHC.StgToJS.StgUtils +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Deps +import GHC.StgToJS.Expr +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StaticPtr +import GHC.StgToJS.Symbols +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Stg.Syntax +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep (scaledThing) + +import GHC.Unit.Module +import GHC.Linker.Types (SptEntry (..)) + +import GHC.Types.CostCentre +import GHC.Types.ForeignStubs (ForeignStubs (..), getCHeader, getCStub) +import GHC.Types.RepType +import GHC.Types.Id +import GHC.Types.Unique + +import GHC.Data.FastString +import GHC.Utils.Encoding +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Binary +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Utils.Outputable hiding ((<>)) + +import qualified Data.Set as S +import Data.Monoid +import Control.Monad +import System.Directory +import System.FilePath + +-- | Code generator for JavaScript +stgToJS + :: Logger + -> StgToJSConfig + -> [CgStgTopBinding] + -> Module + -> [SptEntry] + -> ForeignStubs + -> CollectedCCs + -> FilePath -- ^ Output file name + -> IO () +stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_fn = do + + let (unfloated_binds, stg_binds) = sinkPgm this_mod stg_binds0 + -- TODO: avoid top level lifting in core-2-core when the JS backend is + -- enabled instead of undoing it here + + -- TODO: add dump pass for optimized STG ast for JS + + (deps,lus) <- runG config this_mod unfloated_binds $ do + ifProfilingM $ initCostCentres cccs + lus <- genUnits this_mod stg_binds spt_entries foreign_stubs + deps <- genDependencyData this_mod lus + pure (deps,lus) + + -- Doc to dump when -ddump-js is enabled + when (logHasDumpFlag logger Opt_D_dump_js) $ do + putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS + $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus) + + -- Write the object file + bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB + Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus) + + createDirectoryIfMissing True (takeDirectory output_fn) + writeBinMem bh output_fn + + + +-- | Generate the ingredients for the linkable units for this module +genUnits :: HasDebugCallStack + => Module + -> [CgStgTopBinding] + -> [SptEntry] + -> ForeignStubs + -> G [LinkableUnit] -- ^ the linkable units +genUnits m ss spt_entries foreign_stubs = do + gbl <- generateGlobalBlock + exports <- generateExportsBlock + others <- go 2 ss + pure (gbl:exports:others) + where + go :: HasDebugCallStack + => Int -- the block we're generating (block 0 is the global unit for the module) + -> [CgStgTopBinding] + -> G [LinkableUnit] + go !n = \case + [] -> pure [] + (x:xs) -> do + mlu <- generateBlock x n + lus <- go (n+1) xs + return (maybe lus (:lus) mlu) + + -- Generate the global unit that all other blocks in the module depend on + -- used for cost centres and static initializers + -- the global unit has no dependencies, exports the moduleGlobalSymbol + generateGlobalBlock :: HasDebugCallStack => G LinkableUnit + generateGlobalBlock = do + glbl <- State.gets gsGlobal + staticInit <- + initStaticPtrs spt_entries + let stat = ( -- O.optimize . + jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) + let syms = [moduleGlobalSymbol m] + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = stat + , oiRaw = mempty + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure lu + + generateExportsBlock :: HasDebugCallStack => G LinkableUnit + generateExportsBlock = do + let (f_hdr, f_c) = case foreign_stubs of + NoStubs -> (empty, empty) + ForeignStubs hdr c -> (getCHeader hdr, getCStub c) + unique_deps = map mkUniqueDep (lines $ renderWithContext defaultSDocContext f_hdr) + mkUniqueDep (tag:xs) = mkUnique tag (read xs) + mkUniqueDep [] = panic "mkUniqueDep" + + let syms = [moduleExportsSymbol m] + let raw = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = mempty + , oiRaw = raw + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = unique_deps + , luOtherDeps = [] + , luRequired = True + , luForeignRefs = [] + } + pure lu + + -- Generate the linkable unit for one binding or group of + -- mutually recursive bindings + generateBlock :: HasDebugCallStack + => CgStgTopBinding + -> Int + -> G (Maybe LinkableUnit) + generateBlock top_bind n = case top_bind of + StgTopStringLit bnd str -> do + bids <- identsForId bnd + case bids of + [(TxtI b1t),(TxtI b2t)] -> do + -- [e1,e2] <- genLit (MachStr str) + emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing + emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing + _extraTl <- State.gets (ggsToplevelStats . gsGroup) + si <- State.gets (ggsStatic . gsGroup) + let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 + let stat = jsSaturate (Just $ modulePrefix m n) body + let ids = [bnd] + syms <- (\(TxtI i) -> [i]) <$> identForId bnd + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = si + , oiStat = stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = ids + , luOtherExports = [] + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure (Just lu) + _ -> panic "generateBlock: invalid size" + + StgTopLifted decl -> do + tl <- genToplevel decl + extraTl <- State.gets (ggsToplevelStats . gsGroup) + ci <- State.gets (ggsClosureInfo . gsGroup) + si <- State.gets (ggsStatic . gsGroup) + unf <- State.gets gsUnfloated + extraDeps <- State.gets (ggsExtraDeps . gsGroup) + fRefs <- State.gets (ggsForeignRefs . gsGroup) + resetGroup + let allDeps = collectIds unf decl + topDeps = collectTopIds decl + required = hasExport decl + stat = -- Opt.optimize . + jsSaturate (Just $ modulePrefix m n) + $ mconcat (reverse extraTl) <> tl + syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = ci + , oiStatic = si + , oiStat = stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = fRefs + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = topDeps + , luOtherExports = [] + , luIdDeps = allDeps + , luPseudoIdDeps = [] + , luOtherDeps = S.toList extraDeps + , luRequired = required + , luForeignRefs = fRefs + } + pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu + +-- | variable prefix for the nth block in module +modulePrefix :: Module -> Int -> FastString +modulePrefix m n = + let encMod = zEncodeString . moduleNameString . moduleName $ m + in mkFastString $ "h$" ++ encMod ++ "_id_" ++ show n + +genToplevel :: CgStgBinding -> G JStat +genToplevel (StgNonRec bndr rhs) = genToplevelDecl bndr rhs +genToplevel (StgRec bs) = + mconcat <$> mapM (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs + +genToplevelDecl :: Id -> CgStgRhs -> G JStat +genToplevelDecl i rhs = do + s1 <- resetSlots (genToplevelConEntry i rhs) + s2 <- resetSlots (genToplevelRhs i rhs) + return (s1 <> s2) + +genToplevelConEntry :: Id -> CgStgRhs -> G JStat +genToplevelConEntry i rhs = case rhs of + StgRhsCon _cc con _mu _ts _args + | isDataConWorkId i + -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT + StgRhsClosure _ _cc _upd_flag _args _body + | Just dc <- isDataConWorkId_maybe i + -> genSetConInfo i dc (stgRhsLive rhs) -- srt + _ -> pure mempty + +genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat +genSetConInfo i d l {- srt -} = do + ei <- identForDataConEntryId i + sr <- genStaticRefs l + emitClosureInfo $ ClosureInfo ei + (CIRegs 0 [PtrV]) + (mkFastString $ renderWithContext defaultSDocContext (ppr d)) + (fixedLayout $ map uTypeVt fields) + (CICon $ dataConTag d) + sr + return (ei ||= mkDataEntry) + where + -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug? + fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing) + (dataConRepArgTys d) + -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d) + +mkDataEntry :: JExpr +mkDataEntry = ValExpr $ JFunc [] returnStack + +genToplevelRhs :: Id -> CgStgRhs -> G JStat +-- general cases: +genToplevelRhs i rhs = case rhs of + StgRhsCon cc con _mu _tys args -> do + ii <- identForId i + allocConStatic ii cc con args + return mempty + StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do + {- + algorithm: + - collect all Id refs that are in the global id cache + - count usage in body for each ref + - order by increasing use + - prepend loading lives var to body: body can stay the same + -} + eid@(TxtI eidt) <- identForEntryId i + (TxtI idt) <- identForId i + body <- genBody (initExprCtx i) i R2 args body + global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body) + let lidents = map global_ident global_occs + let lids = map global_id global_occs + let lidents' = map identFS lidents + CIStaticRefs sr0 <- genStaticRefsRhs rhs + let sri = filter (`notElem` lidents') sr0 + sr = CIStaticRefs sri + et <- genEntryType args + ll <- loadLiveFun lids + (static, regs, upd) <- + if et == CIThunk + then do + r <- updateThunk + pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r) + else return (StaticFun eidt (map StaticObjArg lidents'), + (if null lidents then CIRegs 1 (concatMap idVt args) + else CIRegs 0 (PtrV : concatMap idVt args)) + , mempty) + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + emitClosureInfo (ClosureInfo eid + regs + idt + (fixedLayout $ map (uTypeVt . idType) lids) + et + sr) + ccId <- costCentreStackLbl cc + emitStatic idt static ccId + return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body))) diff --git a/compiler/GHC/StgToJS/CoreUtils.hs b/compiler/GHC/StgToJS/CoreUtils.hs new file mode 100644 index 0000000000..0fdf7a5ed8 --- /dev/null +++ b/compiler/GHC/StgToJS/CoreUtils.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Core utils +module GHC.StgToJS.CoreUtils where + +import GHC.Prelude + +import GHC.JS.Syntax + +import GHC.StgToJS.Types + +import GHC.Stg.Syntax + +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep +import GHC.Core.TyCon +import GHC.Core.Type + +import GHC.Types.RepType +import GHC.Types.Var +import GHC.Types.Id + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import qualified Data.Bits as Bits + +-- | can we unbox C x to x, only if x is represented as a Number +isUnboxableCon :: DataCon -> Bool +isUnboxableCon dc + | [t] <- dataConRepArgTys dc + , [t1] <- typeVt (scaledThing t) + = isUnboxable t1 && + dataConTag dc == 1 && + length (tyConDataCons $ dataConTyCon dc) == 1 + | otherwise = False + +-- | one-constructor types with one primitive field represented as a JS Number +-- can be unboxed +isUnboxable :: VarType -> Bool +isUnboxable DoubleV = True +isUnboxable IntV = True -- includes Char# +isUnboxable _ = False + +-- | Number of slots occupied by a PrimRep +data SlotCount + = NoSlot + | OneSlot + | TwoSlots + deriving (Show,Eq,Ord) + +instance Outputable SlotCount where + ppr = text . show + +-- | Return SlotCount as an Int +slotCount :: SlotCount -> Int +slotCount = \case + NoSlot -> 0 + OneSlot -> 1 + TwoSlots -> 2 + + +-- | Number of slots occupied by a value with the given VarType +varSize :: VarType -> Int +varSize = slotCount . varSlotCount + +varSlotCount :: VarType -> SlotCount +varSlotCount VoidV = NoSlot +varSlotCount LongV = TwoSlots -- hi, low +varSlotCount AddrV = TwoSlots -- obj/array, offset +varSlotCount _ = OneSlot + +typeSize :: Type -> Int +typeSize t = sum . map varSize . typeVt $ t + +isVoid :: VarType -> Bool +isVoid VoidV = True +isVoid _ = False + +isPtr :: VarType -> Bool +isPtr PtrV = True +isPtr _ = False + +isSingleVar :: VarType -> Bool +isSingleVar v = varSlotCount v == OneSlot + +isMultiVar :: VarType -> Bool +isMultiVar v = case varSlotCount v of + NoSlot -> False + OneSlot -> False + TwoSlots -> True + +-- | can we pattern match on these values in a case? +isMatchable :: [VarType] -> Bool +isMatchable [DoubleV] = True +isMatchable [IntV] = True +isMatchable _ = False + +tyConVt :: HasDebugCallStack => TyCon -> [VarType] +tyConVt = typeVt . mkTyConTy + +idVt :: HasDebugCallStack => Id -> [VarType] +idVt = typeVt . idType + +typeVt :: HasDebugCallStack => Type -> [VarType] +typeVt t | isRuntimeRepKindedTy t = [] +typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs t) + +-- only use if you know it's not an unboxed tuple +uTypeVt :: HasDebugCallStack => UnaryType -> VarType +uTypeVt ut + | isRuntimeRepKindedTy ut = VoidV +-- | isRuntimeRepTy ut = VoidV + -- GHC panics on this otherwise + | Just (tc, ty_args) <- splitTyConApp_maybe ut + , length ty_args /= tyConArity tc = PtrV + | isPrimitiveType ut = (primTypeVt ut) + | otherwise = + case typePrimRep' ut of + [] -> VoidV + [pt] -> primRepVt pt + _ -> pprPanic "uTypeVt: not unary" (ppr ut) + +primRepVt :: HasDebugCallStack => PrimRep -> VarType +primRepVt VoidRep = VoidV +primRepVt LiftedRep = PtrV -- fixme does ByteArray# ever map to this? +primRepVt UnliftedRep = RtsObjV +primRepVt IntRep = IntV +primRepVt Int8Rep = IntV +primRepVt Int16Rep = IntV +primRepVt Int32Rep = IntV +primRepVt WordRep = IntV +primRepVt Word8Rep = IntV +primRepVt Word16Rep = IntV +primRepVt Word32Rep = IntV +primRepVt Int64Rep = LongV +primRepVt Word64Rep = LongV +primRepVt AddrRep = AddrV +primRepVt FloatRep = DoubleV +primRepVt DoubleRep = DoubleV +primRepVt (VecRep{}) = error "uTypeVt: vector types are unsupported" + +typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep] +typePrimRep' ty = kindPrimRep' empty (typeKind ty) + +-- | Find the primitive representation of a 'TyCon'. Defined here to +-- avoid module loops. Call this only on unlifted tycons. +tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep] +tyConPrimRep' tc = kindPrimRep' empty res_kind + where + res_kind = tyConResKind tc + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's +-- of values of types of this kind. +kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] +kindPrimRep' doc ki + | Just ki' <- coreView ki + = kindPrimRep' doc ki' +kindPrimRep' doc (TyConApp _typ [runtime_rep]) + = -- ASSERT( typ `hasKey` tYPETyConKey ) + runtimeRepPrimRep doc runtime_rep +kindPrimRep' doc ki + = pprPanic "kindPrimRep'" (ppr ki $$ doc) + +primTypeVt :: HasDebugCallStack => Type -> VarType +primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of + Nothing -> error "primTypeVt: not a TyCon" + Just tc + | tc == charPrimTyCon -> IntV + | tc == intPrimTyCon -> IntV + | tc == wordPrimTyCon -> IntV + | tc == floatPrimTyCon -> DoubleV + | tc == doublePrimTyCon -> DoubleV + | tc == int8PrimTyCon -> IntV + | tc == word8PrimTyCon -> IntV + | tc == int16PrimTyCon -> IntV + | tc == word16PrimTyCon -> IntV + | tc == int32PrimTyCon -> IntV + | tc == word32PrimTyCon -> IntV + | tc == int64PrimTyCon -> LongV + | tc == word64PrimTyCon -> LongV + | tc == addrPrimTyCon -> AddrV + | tc == stablePtrPrimTyCon -> AddrV + | tc == stableNamePrimTyCon -> RtsObjV + | tc == statePrimTyCon -> VoidV + | tc == proxyPrimTyCon -> VoidV + | tc == realWorldTyCon -> VoidV + | tc == threadIdPrimTyCon -> RtsObjV + | tc == weakPrimTyCon -> RtsObjV + | tc == arrayPrimTyCon -> ArrV + | tc == smallArrayPrimTyCon -> ArrV + | tc == byteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal + | tc == mutableArrayPrimTyCon -> ArrV + | tc == smallMutableArrayPrimTyCon -> ArrV + | tc == mutableByteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal + | tc == mutVarPrimTyCon -> RtsObjV + | tc == mVarPrimTyCon -> RtsObjV + | tc == tVarPrimTyCon -> RtsObjV + | tc == bcoPrimTyCon -> RtsObjV -- unsupported? + | tc == stackSnapshotPrimTyCon -> RtsObjV + | tc == ioPortPrimTyCon -> RtsObjV -- unsupported? + | tc == anyTyCon -> PtrV + | tc == compactPrimTyCon -> ObjV -- unsupported? + | tc == eqPrimTyCon -> VoidV -- coercion token? + | tc == eqReprPrimTyCon -> VoidV -- role + | tc == unboxedUnitTyCon -> VoidV -- Void# + | otherwise -> PtrV -- anything else must be some boxed thing + +argVt :: StgArg -> VarType +argVt a = uTypeVt . stgArgType $ a + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +isBoolDataCon :: DataCon -> Bool +isBoolDataCon dc = isBoolTy (dataConType dc) + +-- standard fixed layout: payload types +-- payload starts at .d1 for heap objects, entry closest to Sp for stack frames +fixedLayout :: [VarType] -> CILayout +fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts + +-- 2-var values might have been moved around separately, use DoubleV as substitute +-- ObjV is 1 var, so this is no problem for implicit metadata +stackSlotType :: Id -> VarType +stackSlotType i + | OneSlot <- varSlotCount otype = otype + | otherwise = DoubleV + where otype = uTypeVt (idType i) + +idPrimReps :: Id -> [PrimRep] +idPrimReps = typePrimReps . idType + +typePrimReps :: Type -> [PrimRep] +typePrimReps = typePrimRep . unwrapType + +primRepSize :: PrimRep -> SlotCount +primRepSize p = varSlotCount (primRepVt p) + +-- | Associate the given values to each RrimRep in the given order, taking into +-- account the number of slots per PrimRep +assocPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])] +assocPrimReps [] _ = [] +assocPrimReps (r:rs) vs = case (primRepSize r,vs) of + (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs + (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs + (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs + err -> pprPanic "assocPrimReps" (ppr err) + +-- | Associate the given values to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +assocIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])] +assocIdPrimReps i = assocPrimReps (idPrimReps i) + +-- | Associate the given JExpr to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +assocIdExprs :: Id -> [JExpr] -> [TypedExpr] +assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es) + +-- | Return False only if we are *sure* it's a data type +-- Look through newtypes etc as much as possible +might_be_a_function :: HasDebugCallStack => Type -> Bool +might_be_a_function ty + | [LiftedRep] <- typePrimRep ty + , Just tc <- tyConAppTyCon_maybe (unwrapType ty) + , isDataTyCon tc + = False + | otherwise + = True + +mkArityTag :: Int -> Int -> Int +mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) + +toTypeList :: [VarType] -> [Int] +toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x)) diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs new file mode 100644 index 0000000000..242ea7f189 --- /dev/null +++ b/compiler/GHC/StgToJS/DataCon.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.DataCon +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Code generation of data constructors +----------------------------------------------------------------------------- + +module GHC.StgToJS.DataCon + ( genCon + , allocCon + , allocUnboxedCon + , allocDynamicE + , allocDynamic + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Closure +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Profiling +import GHC.StgToJS.Utils +import GHC.StgToJS.Ids + +import GHC.Core.DataCon + +import GHC.Types.CostCentre +import GHC.Types.Unique.Map + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString + +import Data.Maybe + +-- | Generate a data constructor. Special handling for unboxed tuples +genCon :: ExprCtx -> DataCon -> [JExpr] -> G JStat +genCon ctx con args + | isUnboxedTupleDataCon con + = return $ assignToExprCtx ctx args + + | [ValExpr (JVar ctxi)] <- concatMap typex_expr (ctxTarget ctx) + = allocCon ctxi con currentCCS args + + | xs <- concatMap typex_expr (ctxTarget ctx) + = pprPanic "genCon: unhandled DataCon" (ppr (con, args, xs)) + +-- | Allocate a data constructor. Allocate in this context means bind the data +-- constructor to 'to' +allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat +allocCon to con cc xs + | isBoolDataCon con || isUnboxableCon con = + return (toJExpr to |= allocUnboxedCon con xs) +{- | null xs = do + i <- varForId (dataConWorkId con) + return (assignj to i) -} + | otherwise = do + e <- varForDataConWorker con + cs <- getSettings + prof <- profiling + ccsJ <- if prof then ccsVarJ cc else return Nothing + return $ allocDynamic cs False to e xs ccsJ + +-- | Allocate an unboxed data constructor. If we have a bool we calculate the +-- right value. If not then we expect a singleton list and unbox by converting +-- ''C x' to 'x'. NB. This function may panic. +allocUnboxedCon :: DataCon -> [JExpr] -> JExpr +allocUnboxedCon con = \case + [] + | isBoolDataCon con && dataConTag con == 1 -> false_ + | isBoolDataCon con && dataConTag con == 2 -> true_ + [x] + | isUnboxableCon con -> x + xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con,xs)) + +-- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. +allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig + -> JExpr + -> [JExpr] + -> Maybe JExpr + -> JExpr +allocDynamicE inline_alloc entry free cc + | inline_alloc || length free > 24 = newClosure $ Closure + { clEntry = entry + , clField1 = fillObj1 + , clField2 = fillObj2 + , clMeta = ValExpr (JInt 0) + , clCC = cc + } + | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc) + where + allocFun = allocClsA (length free) + (fillObj1,fillObj2) + = case free of + [] -> (null_, null_) + [x] -> (x,null_) + [x,y] -> (x,y) + (x:xs) -> (x,toJExpr (JHash $ listToUniqMap (zip dataFields xs))) + dataFields = map (mkFastString . ('d':) . show) [(1::Int)..] + +-- | Allocate a dynamic object +allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat +allocDynamic s need_decl to entry free cc + | need_decl = DeclStat to (Just value) + | otherwise = toJExpr to |= value + where + value = allocDynamicE (csInlineAlloc s) entry free cc diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs new file mode 100644 index 0000000000..229daf51a4 --- /dev/null +++ b/compiler/GHC/StgToJS/Deps.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Deps +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Module to calculate the transitive dependencies of a module +----------------------------------------------------------------------------- + +module GHC.StgToJS.Deps + ( genDependencyData + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Object as Object +import GHC.StgToJS.Types +import GHC.StgToJS.Ids + +import GHC.JS.Syntax + +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Name + +import GHC.Unit.Module + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString + +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) +import Data.Array +import Data.Either +import Control.Monad + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +data DependencyDataCache = DDC + { ddcModule :: !(IntMap Unit) -- ^ Unique Module -> Unit + , ddcId :: !(IntMap Object.ExportedFun) -- ^ Unique Id -> Object.ExportedFun (only to other modules) + , ddcOther :: !(Map OtherSymb Object.ExportedFun) + } + +-- | Generate module dependency data +-- +-- Generate the object's dependency data, taking care that package and module names +-- are only stored once +genDependencyData + :: HasDebugCallStack + => Module + -> [LinkableUnit] + -> G Object.Deps +genDependencyData mod units = do + -- [(blockindex, blockdeps, required, exported)] + ds <- evalStateT (mapM (uncurry oneDep) blocks) + (DDC IM.empty IM.empty M.empty) + return $ Object.Deps + { depsModule = mod + , depsRequired = IS.fromList [ n | (n, _, True, _) <- ds ] + , depsHaskellExported = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds + , depsBlocks = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) + } + where + -- Id -> Block + unitIdExports :: UniqFM Id Int + unitIdExports = listToUFM $ + concatMap (\(u,n) -> map (,n) (luIdExports u)) blocks + + -- OtherSymb -> Block + unitOtherExports :: Map OtherSymb Int + unitOtherExports = M.fromList $ + concatMap (\(u,n) -> map (,n) + (map (OtherSymb mod) + (luOtherExports u))) + blocks + + blocks :: [(LinkableUnit, Int)] + blocks = zip units [0..] + + -- generate the list of exports and set of dependencies for one unit + oneDep :: LinkableUnit + -> Int + -> StateT DependencyDataCache G (Int, Object.BlockDeps, Bool, [Object.ExportedFun]) + oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do + (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps + (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps + (edp, bdp) <- partitionEithers <$> mapM (lookupPseudoIdFun n) pseudoIdDeps + expi <- mapM lookupExportedId (filter isExportedId idExports) + expo <- mapM lookupExportedOther otherExports + -- fixme thin deps, remove all transitive dependencies! + let bdeps = Object.BlockDeps + (IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp) + (S.toList . S.fromList $ edi++edo++edp) + return (n, bdeps, req, expi++expo) + + idModule :: Id -> Maybe Module + idModule i = nameModule_maybe (getName i) >>= \m -> + guard (m /= mod) >> return m + + lookupPseudoIdFun :: Int -> Unique + -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + lookupPseudoIdFun _n u = + case lookupUFM_Directly unitIdExports u of + Just k -> return (Right k) + _ -> panic "lookupPseudoIdFun" + + -- get the function for an Id from the cache, add it if necessary + -- result: Left Object.ExportedFun if function refers to another module + -- Right blockNumber if function refers to current module + -- + -- assumes function is internal to the current block if it's + -- from teh current module and not in the unitIdExports map. + lookupIdFun :: Int -> Id + -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + lookupIdFun n i = case lookupUFM unitIdExports i of + Just k -> return (Right k) + Nothing -> case idModule i of + Nothing -> return (Right n) + Just m -> + let k = getKey . getUnique $ i + addEntry :: StateT DependencyDataCache G Object.ExportedFun + addEntry = do + (TxtI idTxt) <- lift (identForId i) + lookupExternalFun (Just k) (OtherSymb m idTxt) + in if m == mod + then pprPanic "local id not found" (ppr m) + else Left <$> do + mr <- gets (IM.lookup k . ddcId) + maybe addEntry return mr + + -- get the function for an OtherSymb from the cache, add it if necessary + lookupOtherFun :: OtherSymb + -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + lookupOtherFun od@(OtherSymb m idTxt) = + case M.lookup od unitOtherExports of + Just n -> return (Right n) + Nothing | m == mod -> panic ("genDependencyData.lookupOtherFun: unknown local other id: " ++ unpackFS idTxt) + Nothing -> Left <$> (maybe (lookupExternalFun Nothing od) return =<< + gets (M.lookup od . ddcOther)) + + lookupExportedId :: Id -> StateT DependencyDataCache G Object.ExportedFun + lookupExportedId i = do + (TxtI idTxt) <- lift (identForId i) + lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt) + + lookupExportedOther :: FastString -> StateT DependencyDataCache G Object.ExportedFun + lookupExportedOther = lookupExternalFun Nothing . OtherSymb mod + + -- lookup a dependency to another module, add to the id cache if there's + -- an id key, otherwise add to other cache + lookupExternalFun :: Maybe Int + -> OtherSymb -> StateT DependencyDataCache G Object.ExportedFun + lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do + let mk = getKey . getUnique $ m + mpk = moduleUnit m + exp_fun = Object.ExportedFun m (LexicalFastString idTxt) + addCache = do + ms <- gets ddcModule + let !cache' = IM.insert mk mpk ms + modify (\s -> s { ddcModule = cache'}) + pure exp_fun + f <- do + mbm <- gets (IM.member mk . ddcModule) + case mbm of + False -> addCache + True -> pure exp_fun + + case mbIdKey of + Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) }) + Just k -> modify (\s -> s { ddcId = IM.insert k f (ddcId s) }) + + return f diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs new file mode 100644 index 0000000000..fd6d09585f --- /dev/null +++ b/compiler/GHC/StgToJS/Expr.hs @@ -0,0 +1,1045 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Expr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Code generation of Expressions +----------------------------------------------------------------------------- + +module GHC.StgToJS.Expr + ( genExpr + , genEntryType + , loadLiveFun + , genStaticRefsRhs + , genStaticRefs + , genBody + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Apply +import GHC.StgToJS.Arg +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.FFI +import GHC.StgToJS.Heap +import GHC.StgToJS.Monad +import GHC.StgToJS.DataCon +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Prim +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StgUtils +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Types.Basic +import GHC.Types.CostCentre +import GHC.Types.Tickish +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Unique.FM +import GHC.Types.RepType + +import GHC.Stg.Syntax +import GHC.Stg.Utils + +import GHC.Builtin.PrimOps + +import GHC.Core +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Opt.Arity (isOneShotBndr) +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext) +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Data.FastString +import qualified GHC.Data.List.SetOps as ListSetOps + +import Data.Monoid +import Data.Maybe +import Data.Function +import Data.Either +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Map as M +import Control.Monad +import Control.Arrow ((&&&)) + +-- | Evaluate an expression in the given expression context (continuation) +genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult) +genExpr ctx stg = case stg of + StgApp f args -> genApp ctx f args + StgLit l -> do + ls <- genLit l + let r = assignToExprCtx ctx ls + pure (r,ExprInline Nothing) + StgConApp con _n args _ -> do + as <- concatMapM genArg args + c <- genCon ctx con as + return (c, ExprInline (Just as)) + StgOpApp (StgFCallOp f _) args t + -> genForeignCall ctx f t (concatMap typex_expr $ ctxTarget ctx) args + StgOpApp (StgPrimOp op) args t + -> genPrimOp ctx op args t + StgOpApp (StgPrimCallOp c) args t + -> genPrimCall ctx c args t + StgCase e b at alts + -> genCase ctx b e at alts (liveVars $ stgExprLive False stg) + StgLet _ b e -> do + (b',ctx') <- genBind ctx b + (s,r) <- genExpr ctx' e + return (b' <> s, r) + StgLetNoEscape _ b e -> do + (b', ctx') <- genBindLne ctx b + (s, r) <- genExpr ctx' e + return (b' <> s, r) + StgTick (ProfNote cc count scope) e -> do + setSCCstats <- ifProfilingM $ setCC cc count scope + (stats, result) <- genExpr ctx e + return (setSCCstats <> stats, result) + StgTick (SourceNote span _sname) e + -> genExpr (ctxSetSrcSpan span ctx) e + StgTick _m e + -> genExpr ctx e + +-- | regular let binding: allocate heap object +genBind :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStat, ExprCtx) +genBind ctx bndr = + case bndr of + StgNonRec b r -> do + j <- assign b r >>= \case + Just ja -> return ja + Nothing -> allocCls Nothing [(b,r)] + return (j, addEvalRhs ctx [(b,r)]) + StgRec bs -> do + jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls + let m = if null jas then Nothing else Just (mconcat $ catMaybes jas) + j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs + return (j, addEvalRhs ctx bs) + where + ctx' = ctxClearLneFrame ctx + + assign :: Id -> CgStgRhs -> G (Maybe JStat) + assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr) + | let strip = snd . stripStgTicksTop (not . tickishIsCode) + , StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr + , StgApp selectee [] <- strip sel_expr + , let params_w_offsets = zip params (L.scanl' (+) 1 $ map (typeSize . idType) params) + , let total_size = sum (map (typeSize . idType) params) + -- , the_fv == scrutinee -- fixme check + , Just the_offset <- ListSetOps.assocMaybe params_w_offsets selectee + , the_offset <= 16 -- fixme make this some configurable constant + = do + let the_fv = scrutinee -- error "the_fv" -- fixme + let sel_tag | the_offset == 2 = if total_size == 2 then "2a" + else "2b" + | otherwise = show the_offset + tgts <- identsForId b + the_fvjs <- varsForId the_fv + case (tgts, the_fvjs) of + ([tgt], [the_fvj]) -> return $ Just + (tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj]) + _ -> panic "genBind.assign: invalid size" + assign b (StgRhsClosure _ext _ccs _upd [] expr) + | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do + d <- declVarsForId b + tgt <- varsForId b + let ctx' = ctx { ctxTarget = assocIdExprs b tgt } + (j, _) <- genExpr ctx' expr + return (Just (d <> j)) + assign _b StgRhsCon{} = return Nothing + assign b r = genEntry ctx' b r >> return Nothing + + addEvalRhs c [] = c + addEvalRhs c ((b,r):xs) + | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs + | (StgRhsClosure _ _ ReEntrant _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs + | otherwise = addEvalRhs c xs + +genBindLne :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStat, ExprCtx) +genBindLne ctx bndr = do + -- compute live variables and the offsets where they will be stored in the + -- stack + vis <- map (\(x,y,_) -> (x,y)) <$> + optimizeFree oldFrameSize (newLvs++map fst updBinds) + -- initialize updatable bindings to null_ + declUpds <- mconcat <$> mapM (fmap (||= null_) . identForId . fst) updBinds + -- update expression context to include the updated LNE frame + let ctx' = ctxUpdateLneFrame vis bound ctx + mapM_ (uncurry $ genEntryLne ctx') binds + return (declUpds, ctx') + where + oldFrameSize = ctxLneFrameSize ctx + isOldLv i = ctxIsLneBinding ctx i || + ctxIsLneLiveVar ctx i + live = liveVars $ mkDVarSet $ stgLneLive' bndr + newLvs = filter (not . isOldLv) (dVarSetElems live) + binds = case bndr of + StgNonRec b e -> [(b,e)] + StgRec bs -> bs + bound = map fst binds + (updBinds, _nonUpdBinds) = L.partition (isUpdatableRhs . snd) binds + +-- | Generate let-no-escape entry +-- +-- Let-no-escape entries live on the stack. There is no heap object associated with them. +-- +-- A let-no-escape entry is called like a normal stack frame, although as an optimization, +-- `Stack`[`Sp`] is not set when making the call. This is done later if the +-- thread needs to be suspended. +-- +-- Updatable let-no-escape binders have one 'private' slot in the stack frame. This slot +-- is initially set to null, changed to h$blackhole when the thunk is being evaluated. +-- +genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () +genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) = + resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + vars = ctxLneFrameVars ctx + myOffset = + maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame") + ((payloadSize-) . fst) + (L.find ((==i) . fst . snd) (zip [0..] vars)) + bh | isUpdatable update = + jVar (\x -> mconcat + [ x |= ApplExpr (var "h$bh_lne") [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)] + , IfStat x (ReturnStat x) mempty + ]) + | otherwise = mempty + lvs <- popLneFrame True payloadSize ctx + body <- genBody ctx i R1 args body + ei@(TxtI eii) <- identForEntryId i + sr <- genStaticRefsRhs rhs + let f = JFunc [] (bh <> lvs <> body) + emitClosureInfo $ + ClosureInfo ei + (CIRegs 0 $ concatMap idVt args) + (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout . reverse $ + map (stackSlotType . fst) (ctxLneFrameVars ctx)) + CIStackFrame + sr + emitToplevel (ei ||= toJExpr f) +genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + ei@(TxtI _eii) <- identForEntryId i + -- di <- varForDataConWorker con + ii <- freshIdent + p <- popLneFrame True payloadSize ctx + args' <- concatMapM genArg args + ac <- allocCon ii con cc args' + emitToplevel (ei ||= toJExpr (JFunc [] + (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack]))) + +-- | Generate the entry function for a local closure +genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () +genEntry _ _i StgRhsCon {} = return () +genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = resetSlots $ do + let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body + ll <- loadLiveFun live + llv <- verifyRuntimeReps live + upd <- genUpdFrame upd_flag i + body <- genBody entryCtx i R2 args body + ei@(TxtI eii) <- identForEntryId i + et <- genEntryType args + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + sr <- genStaticRefsRhs rhs + emitClosureInfo $ ClosureInfo ei + (CIRegs 0 $ PtrV : concatMap idVt args) + (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout $ map (uTypeVt . idType) live) + et + sr + emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + where + entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) + +-- | Generate the entry function types for identifiers. Note that this only +-- returns either 'CIThunk' or 'CIFun'. Everything else (PAP Blackhole etc.) is +-- filtered as not a RuntimeRepKinded type. +genEntryType :: HasDebugCallStack => [Id] -> G CIType +genEntryType [] = return CIThunk +genEntryType args0 = do + args' <- mapM genIdArg args + return $ CIFun (length args) (length $ concat args') + where + args = filter (not . isRuntimeRepKindedTy . idType) args0 + +-- | Generate the body of an object +genBody :: HasDebugCallStack + => ExprCtx + -> Id + -> StgReg + -> [Id] + -> CgStgExpr + -> G JStat +genBody ctx i startReg args e = do + -- load arguments into local variables + la <- do + args' <- concatMapM genIdArgI args + return (declAssignAll args' (fmap toJExpr [startReg..])) + + -- assert that arguments have valid runtime reps + lav <- verifyRuntimeReps args + + -- compute PrimReps and their number of slots required to return the result of + -- i applied to args. + let res_vars = resultSize args i + + -- compute typed expressions for each slot and assign registers + let go_var regs = \case + [] -> [] + ((rep,size):rs) -> + let !(regs0,regs1) = splitAt size regs + !ts = go_var regs1 rs + in TypedExpr rep regs0 : ts + + let tgt = go_var jsRegsFromR1 res_vars + let !ctx' = ctx { ctxTarget = tgt } + + -- generate code for the expression + (e, _r) <- genExpr ctx' e + + return $ la <> lav <> e <> returnStack + +-- | Find the result type after applying the function to the arguments +-- +-- It's trickier than it looks because: +-- +-- 1. we don't have the Arity of the Id. The following functions return +-- different values in some cases: +-- - idArity +-- - typeArity . idType +-- - idFunRepArity +-- - typeArity . unwrapType . idType +-- Moreover the number of args may be different than all of these arities +-- +-- 2. sometimes the type is Any, perhaps after some unwrapping. For example +-- HappyAbsSyn is a newtype around HappyAny which is Any or (forall a. a). +-- +-- Se we're left to use the applied arguments to peel the type (unwrapped) one +-- arg at a time. But passed args are args after unarisation so we need to +-- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- number of passed args consumed by each type arg. +-- +-- In case of failure to determine the type, we default to LiftedRep as it's +-- probably what it is. +-- +resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)] +resultSize args i = result + where + result = result_reps `zip` result_slots + result_slots = fmap (slotCount . primRepSize) result_reps + result_reps = trim_args (unwrapType (idType i)) (length args) + + trim_args t 0 = typePrimRep t + trim_args t n + | Just (_af, _mult, arg, res) <- splitFunTy_maybe t + , nargs <- length (typePrimRepArgs arg) + , assert (n >= nargs) True + = trim_args (unwrapType res) (n - nargs) + | otherwise + = pprTrace "result_type: not a function type, assume LiftedRep" (ppr t) + [LiftedRep] + +-- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function +-- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False. +verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat +verifyRuntimeReps xs = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else mconcat <$> mapM verifyRuntimeRep xs + where + verifyRuntimeRep i = do + i' <- varsForId i + pure $ go i' (idVt i) + go js (VoidV:vs) = go js vs + go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs + go (j1:j2:js) (AddrV:vs) = v "h$verify_rep_addr" [j1,j2] <> go js vs + go (j:js) (v:vs) = ver j v <> go js vs + go [] [] = mempty + go _ _ = pprPanic "verifyRuntimeReps: inconsistent sizes" (ppr xs) + ver j PtrV = v "h$verify_rep_heapobj" [j] + ver j IntV = v "h$verify_rep_int" [j] + ver j RtsObjV = v "h$verify_rep_rtsobj" [j] + ver j DoubleV = v "h$verify_rep_double" [j] + ver j ArrV = v "h$verify_rep_arr" [j] + ver _ _ = mempty + v f as = ApplStat (var f) as + +-- | Given a set of 'Id's, bind each 'Id' to the appropriate data fields in N +-- registers. This assumes these data fields have already been populated in the +-- registers. For the empty, singleton, and binary case use register 1, for any +-- more use as many registers as necessary. +loadLiveFun :: [Id] -> G JStat +loadLiveFun l = do + l' <- concat <$> mapM identsForId l + case l' of + [] -> return mempty + -- set the ident to d1 field of register 1 + [v] -> return (v ||= r1 .^ closureField1_) + -- set the idents to d1 and d2 fields of register 1 + [v1,v2] -> return $ mconcat + [ v1 ||= r1 .^ closureField1_ + , v2 ||= r1 .^ closureField2_ + ] + -- and so on + (v:vs) -> do + d <- freshIdent + let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs + return $ mconcat + [ v ||= r1 .^ closureField1_ + , d ||= r1 .^ closureField2_ + , l'' + ] + where + loadLiveVar d n v = let ident = TxtI (dataFieldName n) + in v ||= SelExpr d ident + +-- | Pop a let-no-escape frame off the stack +popLneFrame :: Bool -> Int -> ExprCtx -> G JStat +popLneFrame inEntry size ctx = do + -- calculate the new stack size + let ctx' = ctxLneShrinkStack ctx size + + let gen_id_slot (i,n) = do + ids <- identsForId i + let !id_n = ids !! (n-1) + pure (id_n, SlotId i n) + + is <- mapM gen_id_slot (ctxLneFrameVars ctx') + + let skip = if inEntry then 1 else 0 -- pop the frame header + popSkipI skip is + +-- | Generate an updated given an 'Id' +genUpdFrame :: UpdateFlag -> Id -> G JStat +genUpdFrame u i + | isReEntrant u = pure mempty + | isOneShotBndr i = maybeBh + | isUpdatable u = updateThunk + | otherwise = maybeBh + where + isReEntrant ReEntrant = True + isReEntrant _ = False + maybeBh = do + settings <- getSettings + assertRtsStat (return $ bhSingleEntry settings) + +-- | Blackhole single entry +-- +-- Overwrite a single entry object with a special thunk that behaves like a +-- black hole (throws a JS exception when entered) but pretends to be a thunk. +-- Useful for making sure that the object is not accidentally entered multiple +-- times +-- +bhSingleEntry :: StgToJSConfig -> JStat +bhSingleEntry _settings = mconcat + [ r1 .^ closureEntry_ |= var "h$blackholeTrap" + , r1 .^ closureField1_ |= undefined_ + , r1 .^ closureField2_ |= undefined_ + ] + +genStaticRefsRhs :: CgStgRhs -> G CIStatic +genStaticRefsRhs lv = genStaticRefs (stgRhsLive lv) + +-- fixme, update to new way to compute static refs dynamically +genStaticRefs :: LiveVars -> G CIStatic +genStaticRefs lv + | isEmptyDVarSet sv = return (CIStaticRefs []) + | otherwise = do + unfloated <- State.gets gsUnfloated + let xs = filter (\x -> not (elemUFM x unfloated || + typeLevity_maybe (idType x) == Just Unlifted)) + (dVarSetElems sv) + CIStaticRefs . catMaybes <$> mapM getStaticRef xs + where + sv = liveStatic lv + + getStaticRef :: Id -> G (Maybe FastString) + getStaticRef = fmap (fmap itxt . listToMaybe) . identsForId + +-- | Reorder the things we need to push to reuse existing stack values as much +-- as possible True if already on the stack at that location +optimizeFree + :: HasDebugCallStack + => Int + -> [Id] + -> G [(Id,Int,Bool)] -- ^ A list of stack slots. + -- -- Id: stored on the slot + -- -- Int: the part of the value that is stored + -- -- Bool: True when the slot already contains a value +optimizeFree offset ids = do + -- this line goes wrong vvvvvvv + let -- ids' = concat $ map (\i -> map (i,) [1..varSize . uTypeVt . idType $ i]) ids + idSize :: Id -> Int + idSize i = sum $ map varSize (typeVt . idType $ i) + ids' = concatMap (\i -> map (i,) [1..idSize i]) ids + -- 1..varSize] . uTypeVt . idType $ i]) (typeVt ids) + l = length ids' + slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots + let slm = M.fromList (zip slots [0..]) + (remaining, fixed) = partitionEithers $ + map (\inp@(i,n) -> maybe (Left inp) (\j -> Right (i,n,j,True)) + (M.lookup (SlotId i n) slm)) ids' + takenSlots = S.fromList (fmap (\(_,_,x,_) -> x) fixed) + freeSlots = filter (`S.notMember` takenSlots) [0..l-1] + remaining' = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots + allSlots = L.sortBy (compare `on` \(_,_,x,_) -> x) (fixed ++ remaining') + return $ map (\(i,n,_,b) -> (i,n,b)) allSlots + +-- | Allocate local closures +allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat +allocCls dynMiddle xs = do + (stat, dyn) <- partitionEithers <$> mapM toCl xs + ac <- allocDynAll True dynMiddle dyn + pure (mconcat stat <> ac) + where + -- left = static, right = dynamic + toCl :: (Id, CgStgRhs) + -> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack)) + -- statics + {- making zero-arg constructors static is problematic, see #646 + proper candidates for this optimization should have been floated + already + toCl (i, StgRhsCon cc con []) = do + ii <- identForId i + Left <$> (return (decl ii) <> allocCon ii con cc []) -} + toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do + ii <- identForId i + ac <- allocCon ii con cc =<< genArg a + pure (Left (decl ii <> ac)) + + -- dynamics + toCl (i, StgRhsCon cc con _mu _ticks ar) = + -- fixme do we need to handle unboxed? + Right <$> ((,,,) <$> identForId i + <*> varForDataConWorker con + <*> concatMapM genArg ar + <*> pure cc) + toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) = + let live = stgLneLiveExpr cl + in Right <$> ((,,,) <$> identForId i + <*> varForEntryId i + <*> concatMapM varsForId live + <*> pure cc) + +-- fixme CgCase has a reps_compatible check here +-- | Consume Stg case statement and generate a case statement. See also +-- 'genAlts' +genCase :: HasDebugCallStack + => ExprCtx + -> Id + -> CgStgExpr + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G (JStat, ExprResult) +genCase ctx bnd e at alts l + | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do + bndi <- identsForId bnd + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi)) + $ ctx + (ej, r) <- genExpr ctx' e + let d = case r of + ExprInline d0 -> d0 + ExprCont -> pprPanic "genCase: expression was not inline" + (pprStgExpr panicStgPprOpts e) + + (aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts + (saveCCS,restoreCCS) <- ifProfilingM $ do + ccsVar <- freshIdent + pure ( ccsVar ||= toJExpr jCurrentCCS + , toJExpr jCurrentCCS |= toJExpr ccsVar + ) + return ( mconcat + [ mconcat (map decl bndi) + , saveCCS + , ej + , restoreCCS + , aj + ] + , ar + ) + | otherwise = do + rj <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..])) + $ ctx + (ej, _r) <- genExpr ctx' e + return (rj <> ej, ExprCont) + +genRet :: HasDebugCallStack + => ExprCtx + -> Id + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G JStat +genRet ctx e at as l = freshIdent >>= f + where + allRefs :: [Id] + allRefs = S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as + lneLive :: Int + lneLive = maximum $ 0 : catMaybes (map (ctxLneBindingStackSize ctx) allRefs) + ctx' = ctxLneShrinkStack ctx lneLive + lneVars = map fst $ ctxLneFrameVars ctx' + isLne i = ctxIsLneBinding ctx i || ctxIsLneLiveVar ctx' i + nonLne = filter (not . isLne) (dVarSetElems l) + + f :: Ident -> G JStat + f r@(TxtI ri) = do + pushLne <- pushLneFrame lneLive ctx + saveCCS <- ifProfilingM $ push [jCurrentCCS] + free <- optimizeFree 0 nonLne + pushRet <- pushRetArgs free (toJExpr r) + fun' <- fun free + sr <- genStaticRefs l -- srt + prof <- profiling + emitClosureInfo $ + ClosureInfo r + (CIRegs 0 altRegs) + ri + (fixedLayout . reverse $ + map (stackSlotType . fst3) free + ++ if prof then [ObjV] else map stackSlotType lneVars) + CIStackFrame + sr + emitToplevel $ r ||= toJExpr (JFunc [] fun') + return (pushLne <> saveCCS <> pushRet) + fst3 ~(x,_,_) = x + + altRegs :: HasDebugCallStack => [VarType] + altRegs = case at of + PrimAlt ptc -> [primRepVt ptc] + MultiValAlt _n -> idVt e + _ -> [PtrV] + + -- special case for popping CCS but preserving stack size + pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat + pop_handle_CCS [] = return mempty + pop_handle_CCS xs = do + -- grab the slots from 'xs' and push + addSlots (map snd xs) + -- move the stack pointer into the stack by ''length xs + n' + a <- adjSpN (length xs) + -- now load from the top of the stack + return (loadSkip 0 (map fst xs) <> a) + + fun free = resetSlots $ do + decs <- declVarsForId e + load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e + loadv <- verifyRuntimeReps [e] + ras <- loadRetArgs free + rasv <- verifyRuntimeReps (map (\(x,_,_)->x) free) + restoreCCS <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown) + rlne <- popLneFrame False lneLive ctx' + rlnev <- verifyRuntimeReps lneVars + (alts, _altr) <- genAlts ctx' e at Nothing as + return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <> + returnStack + +-- | Consume an Stg case alternative and generate the corresponding alternative +-- in JS land. If one alternative is a continuation then we must normalize the +-- other alternatives. See 'Branch' and 'normalizeBranches'. +genAlts :: HasDebugCallStack + => ExprCtx -- ^ lhs to assign expression result to + -> Id -- ^ id being matched + -> AltType -- ^ type + -> Maybe [JExpr] -- ^ if known, fields in datacon from earlier expression + -> [CgStgAlt] -- ^ the alternatives + -> G (JStat, ExprResult) +genAlts ctx e at me alts = do + (st, er) <- case at of + + PolyAlt -> case alts of + [alt] -> (branch_stat &&& branch_result) <$> mkAlgBranch ctx e alt + _ -> panic "genAlts: multiple polyalt" + + PrimAlt _tc + | [GenStgAlt _ bs expr] <- alts + -> do + ie <- varsForId e + dids <- mconcat <$> mapM declVarsForId bs + bss <- concatMapM varsForId bs + (ej, er) <- genExpr ctx expr + return (dids <> assignAll bss ie <> ej, er) + + PrimAlt tc + -> do + ie <- varsForId e + (r, bss) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkPrimIfBranch ctx [primRepVt tc]) alts + setSlots [] + return (mkSw ie bss, r) + + MultiValAlt n + | [GenStgAlt _ bs expr] <- alts + -> do + eids <- varsForId e + l <- loadUbxTup eids bs n + (ej, er) <- genExpr ctx expr + return (l <> ej, er) + + AlgAlt tc + | [_alt] <- alts + , isUnboxedTupleTyCon tc + -> panic "genAlts: unexpected unboxed tuple" + + AlgAlt _tc + | Just es <- me + , [GenStgAlt (DataAlt dc) bs expr] <- alts + , not (isUnboxableCon dc) + -> do + bsi <- mapM identsForId bs + (ej, er) <- genExpr ctx expr + return (declAssignAll (concat bsi) es <> ej, er) + + AlgAlt _tc + | [alt] <- alts + -> do + Branch _ s r <- mkAlgBranch ctx e alt + return (s, r) + + AlgAlt _tc + | [alt,_] <- alts + , DataAlt dc <- alt_con alt + , isBoolDataCon dc + -> do + i <- varForId e + nbs <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + case nbs of + (r, [Branch _ s1 _, Branch _ s2 _]) -> do + let s = if dataConTag dc == 2 + then IfStat i s1 s2 + else IfStat i s2 s1 + setSlots [] + return (s, r) + _ -> error "genAlts: invalid branches for Bool" + + AlgAlt _tc -> do + ei <- varForId e + (r, brs) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + setSlots [] + return (mkSwitch (ei .^ "f" .^ "a") brs, r) + + _ -> pprPanic "genAlts: unhandled case variant" (ppr (at, length alts)) + + ver <- verifyMatchRep e at + pure (ver <> st, er) + +-- | If 'StgToJSConfig.csRuntimeAssert' is set, then generate an assertion that +-- asserts the pattern match is valid, e.g., the match is attempted on a +-- Boolean, a Data Constructor, or some number. +verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStat +verifyMatchRep x alt = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else case alt of + AlgAlt tc -> do + ix <- varsForId x + pure $ ApplStat (var "h$verify_match_alg") (ValExpr(JStr(mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix) + _ -> pure mempty + +-- | A 'Branch' represents a possible branching path of an Stg case statement, +-- i.e., a possible code path from an 'StgAlt' +data Branch a = Branch + { branch_expr :: a + , branch_stat :: JStat + , branch_result :: ExprResult + } + deriving (Eq,Functor) + +-- | If one branch ends in a continuation but another is inline, we need to +-- adjust the inline branch to use the continuation convention +normalizeBranches :: ExprCtx + -> [Branch a] + -> (ExprResult, [Branch a]) +normalizeBranches ctx brs + | all (==ExprCont) (fmap branch_result brs) = + (ExprCont, brs) + | branchResult (fmap branch_result brs) == ExprCont = + (ExprCont, map mkCont brs) + | otherwise = + (ExprInline Nothing, brs) + where + mkCont b = case branch_result b of + ExprInline{} -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1 + (concatMap typex_expr $ ctxTarget ctx) + , branch_result = ExprCont + } + _ -> b + +-- | Load an unboxed tuple. "Loading" means getting all 'Idents' from the input +-- ID's, declaring them as variables in JS land and binding them, in order, to +-- 'es'. +loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat +loadUbxTup es bs _n = do + bs' <- concatMapM identsForId bs + return $ declAssignAll bs' es + +mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkSw [e] cases = mkSwitch e (fmap (fmap (fmap head)) cases) +mkSw es cases = mkIfElse es cases + +-- | Switch for pattern matching on constructors or prims +mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat +mkSwitch e cases + | [Branch (Just c1) s1 _] <- n + , [Branch _ s2 _] <- d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | [Branch (Just c1) s1 _, Branch _ s2 _] <- n + , null d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | null d + = SwitchStat e (map addBreak (init n)) (branch_stat (last n)) + + | [Branch _ d0 _] <- d + = SwitchStat e (map addBreak n) d0 + + | otherwise = panic "mkSwitch: multiple default cases" + where + addBreak (Branch (Just c) s _) = (c, mconcat [s, BreakStat Nothing]) + addBreak _ = panic "mkSwitch: addBreak" + (n,d) = L.partition (isJust . branch_expr) cases + +-- | if/else for pattern matching on things that js cannot switch on +-- the list of branches is expected to have the default alternative +-- first, if it exists +mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkIfElse e s = go (L.reverse s) + where + go = \case + [Branch _ s _] -> s -- only one 'nothing' allowed + (Branch (Just e0) s _ : xs) -> IfStat (mkEq e e0) s (go xs) + [] -> panic "mkIfElse: empty expression list" + _ -> panic "mkIfElse: multiple DEFAULT cases" + +-- | Wrapper to contruct sequences of (===), e.g., +-- +-- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2) +-- +mkEq :: [JExpr] -> [JExpr] -> JExpr +mkEq es1 es2 + | length es1 == length es2 = foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2) + | otherwise = panic "mkEq: incompatible expressions" + +mkAlgBranch :: ExprCtx -- ^ toplevel id for the result + -> Id -- ^ datacon to match + -> CgStgAlt -- ^ match alternative with binders + -> G (Branch (Maybe JExpr)) +mkAlgBranch top d alt + | DataAlt dc <- alt_con alt + , isUnboxableCon dc + , [b] <- alt_bndrs alt + = do + idd <- varForId d + fldx <- identsForId b + case fldx of + [fld] -> do + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch Nothing (mconcat [fld ||= idd, ej]) er) + _ -> panic "mkAlgBranch: invalid size" + + | otherwise + = do + cc <- caseCond (alt_con alt) + idd <- varForId d + b <- loadParams idd (alt_bndrs alt) + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch cc (b <> ej) er) + +-- | Generate a primitive If-expression +mkPrimIfBranch :: ExprCtx + -> [VarType] + -> CgStgAlt + -> G (Branch (Maybe [JExpr])) +mkPrimIfBranch top _vt alt = + (\ic (ej,er) -> Branch ic ej er) <$> ifCond (alt_con alt) <*> genExpr top (alt_rhs alt) + +-- fixme are bool things always checked correctly here? +ifCond :: AltCon -> G (Maybe [JExpr]) +ifCond = \case + DataAlt da -> return $ Just [toJExpr (dataConTag da)] + LitAlt l -> Just <$> genLit l + DEFAULT -> return Nothing + +caseCond :: AltCon -> G (Maybe JExpr) +caseCond = \case + DEFAULT -> return Nothing + DataAlt da -> return $ Just (toJExpr $ dataConTag da) + LitAlt l -> genLit l >>= \case + [e] -> pure (Just e) + es -> pprPanic "caseCond: expected single-variable literal" (ppr es) + +-- fixme use single tmp var for all branches +-- | Load parameters from constructor +loadParams :: JExpr -> [Id] -> G JStat +loadParams from args = do + as <- concat <$> zipWithM (\a u -> map (,u) <$> identsForId a) args use + return $ case as of + [] -> mempty + [(x,u)] -> loadIfUsed (from .^ closureField1_) x u + [(x1,u1),(x2,u2)] -> mconcat + [ loadIfUsed (from .^ closureField1_) x1 u1 + , loadIfUsed (from .^ closureField2_) x2 u2 + ] + ((x,u):xs) -> mconcat + [ loadIfUsed (from .^ closureField1_) x u + , jVar (\d -> mconcat [ d |= from .^ closureField2_ + , loadConVarsIfUsed d xs + ]) + ] + where + use = repeat True -- fixme clean up + loadIfUsed fr tgt True = tgt ||= fr + loadIfUsed _ _ _ = mempty + + loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..] + where f (x,u) n = loadIfUsed (SelExpr fr (TxtI (dataFieldName n))) x u + +-- | Determine if a branch will end in a continuation or not. If not the inline +-- branch must be normalized. See 'normalizeBranches' +-- NB. not a Monoid +branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult +branchResult = \case + [] -> panic "branchResult: empty list" + [e] -> e + (ExprCont:_) -> ExprCont + (_:es) + | elem ExprCont es -> ExprCont + | otherwise -> ExprInline Nothing + +-- | Push return arguments onto the stack. The 'Bool' tracks whether the value +-- is already on the stack or not, used in 'StgToJS.Stack.pushOptimized'. +pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JExpr -> G JStat +pushRetArgs free fun = do + rs <- mapM (\(i,n,b) -> (\es->(es!!(n-1),b)) <$> genIdArg i) free + pushOptimized (rs++[(fun,False)]) + +-- | Load the return arguments then pop the stack frame +loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStat +loadRetArgs free = do + ids <- mapM (\(i,n,_b) -> (!! (n-1)) <$> genIdStackArgI i) free + popSkipI 1 ids + +-- | allocate multiple, possibly mutually recursive, closures +allocDynAll :: Bool -> Maybe JStat -> [(Ident,JExpr,[JExpr],CostCentreStack)] -> G JStat +{- +XXX remove use of template and enable in-place init again +allocDynAll haveDecl middle [(to,entry,free,cc)] + | isNothing middle && to `notElem` (free ^.. template) = do + ccs <- ccsVarJ cc + return $ allocDynamic s haveDecl to entry free ccs -} +allocDynAll haveDecl middle cls = do + settings <- getSettings + let + middle' = fromMaybe mempty middle + + decl_maybe i e + | haveDecl = toJExpr i |= e + | otherwise = i ||= e + + makeObjs :: G JStat + makeObjs = + fmap mconcat $ forM cls $ \(i,f,_,cc) -> do + ccs <- maybeToList <$> costCentreStackLbl cc + pure $ mconcat + [ decl_maybe i $ if csInlineAlloc settings + then ValExpr (jhFromList $ [ (closureEntry_ , f) + , (closureField1_, null_) + , (closureField2_, null_) + , (closureMeta_ , zero_) + ] + ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs) + else ApplExpr (var "h$c") (f : fmap (ValExpr . JVar) ccs) + ] + + fillObjs = mconcat $ map fillObj cls + fillObj (i,_,es,_) + | csInlineAlloc settings || length es > 24 = + case es of + [] -> mempty + [ex] -> toJExpr i .^ closureField1_ |= toJExpr ex + [e1,e2] -> mconcat + [ toJExpr i .^ closureField1_ |= toJExpr e1 + , toJExpr i .^ closureField2_ |= toJExpr e2 + ] + (ex:es) -> mconcat + [ toJExpr i .^ closureField1_ |= toJExpr ex + , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip dataFieldNames es)) + ] + | otherwise = case es of + [] -> mempty + [ex] -> toJExpr i .^ closureField1_ |= ex + [e1,e2] -> mconcat + [ toJExpr i .^ closureField1_ |= e1 + , toJExpr i .^ closureField2_ |= e2 + ] + (ex:es) -> mconcat + [ toJExpr i .^ closureField1_ |= ex + , toJExpr i .^ closureField2_ |= fillFun es + ] + + fillFun [] = null_ + fillFun es = ApplExpr (allocData (length es)) es + + checkObjs | csAssertRts settings = mconcat $ + map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i]) cls + | otherwise = mempty + + objs <- makeObjs + pure $ mconcat [objs, middle', fillObjs, checkObjs] + +-- | Generate a primop. This function wraps around the real generator +-- 'GHC.StgToJS.genPrim', handling the 'ExprCtx' and all arguments before +-- generating the primop. +genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult) +genPrimOp ctx op args t = do + as <- concatMapM genArg args + prof <- csProf <$> getSettings + bound <- csBoundsCheck <$> getSettings + -- fixme: should we preserve/check the primreps? + return $ case genPrim prof bound t op (concatMap typex_expr $ ctxTarget ctx) as of + PrimInline s -> (s, ExprInline Nothing) + PRPrimCall s -> (s, ExprCont) diff --git a/compiler/GHC/StgToJS/ExprCtx.hs b/compiler/GHC/StgToJS/ExprCtx.hs new file mode 100644 index 0000000000..48a4483009 --- /dev/null +++ b/compiler/GHC/StgToJS/ExprCtx.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.ExprCtx +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- TODO: Write my description! +----------------------------------------------------------------------------- + +module GHC.StgToJS.ExprCtx + ( ExprCtx + , initExprCtx + , ctxAssertEvaluated + , ctxIsEvaluated + , ctxSetSrcSpan + , ctxSrcSpan + , ctxSetTop + , ctxTarget + , ctxSetTarget + , ctxEvaluatedIds + -- * Let-no-escape + , ctxClearLneFrame + , ctxUpdateLneFrame + , ctxLneFrameVars + , ctxLneFrameSize + , ctxIsLneBinding + , ctxIsLneLiveVar + , ctxLneBindingStackSize + , ctxLneShrinkStack + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types + +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Var +import GHC.Types.SrcLoc + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe + + +-- | Context into which an expression is evaluated +data ExprCtx = ExprCtx + { ctxTop :: Id + -- ^ Top-level binding Id + + , ctxTarget :: [TypedExpr] + -- ^ Target variables for the evaluated expression + + , ctxEvaluatedIds :: UniqSet Id + -- ^ Ids that we know to be evaluated (e.g. case binders when the expression + -- to evaluate is in an alternative) + + , ctxSrcSpan :: Maybe RealSrcSpan + -- ^ Source location + + ---------------------------- + -- Handling of let-no-escape + + , ctxLneFrameBs :: UniqFM Id Int + -- ^ LNE bindings with their expected stack size. + -- + -- The Int is the size of the stack when the LNE binding was defined. + -- We need to shrink the stack back to this size when we enter one of the + -- associated binder rhs: it expects its free variables at certain offsets + -- in the stack. + + , ctxLneFrameVars :: [(Id,Int)] + -- ^ Contents of current LNE frame + -- + -- Variables and their index on the stack + + , ctxLneFrameSize :: {-# UNPACK #-} !Int + -- ^ Cache the length of `ctxLneFrameVars` + + } + +-- | Initialize an expression context in the context of the given top-level +-- binding Id +initExprCtx :: Id -> ExprCtx +initExprCtx i = ExprCtx + { ctxTop = i + , ctxTarget = [] + , ctxEvaluatedIds = emptyUniqSet + , ctxLneFrameBs = emptyUFM + , ctxLneFrameVars = [] + , ctxLneFrameSize = 0 + , ctxSrcSpan = Nothing + } + +-- | Set target +ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx +ctxSetTarget t ctx = ctx { ctxTarget = t } + +-- | Set top-level binding Id +ctxSetTop :: Id -> ExprCtx -> ExprCtx +ctxSetTop i ctx = ctx { ctxTop = i } + +-- | Add an Id to the known-evaluated set +ctxAssertEvaluated :: Id -> ExprCtx -> ExprCtx +ctxAssertEvaluated i ctx = ctx { ctxEvaluatedIds = addOneToUniqSet (ctxEvaluatedIds ctx) i } + +-- | Set source location +ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx +ctxSetSrcSpan span ctx = ctx { ctxSrcSpan = Just span } + +-- | Update let-no-escape frame +ctxUpdateLneFrame :: [(Id,Int)] -> [Id] -> ExprCtx -> ExprCtx +ctxUpdateLneFrame new_spilled_vars new_lne_ids ctx = + let old_frame_size = ctxLneFrameSize ctx + new_frame_size = old_frame_size + length new_spilled_vars + in ctx + { ctxLneFrameBs = addListToUFM (ctxLneFrameBs ctx) (map (,new_frame_size) new_lne_ids) + , ctxLneFrameSize = new_frame_size + , ctxLneFrameVars = ctxLneFrameVars ctx ++ new_spilled_vars + } + +-- | Remove information about the current LNE frame +ctxClearLneFrame :: ExprCtx -> ExprCtx +ctxClearLneFrame ctx = + ctx + { ctxLneFrameBs = emptyUFM + , ctxLneFrameVars = [] + , ctxLneFrameSize = 0 + } + +-- | Predicate: do we know for sure that the given Id is evaluated? +ctxIsEvaluated :: ExprCtx -> Id -> Bool +ctxIsEvaluated ctx i = i `elementOfUniqSet` ctxEvaluatedIds ctx + +-- | Does the given Id correspond to a LNE binding +ctxIsLneBinding :: ExprCtx -> Id -> Bool +ctxIsLneBinding ctx i = isJust (ctxLneBindingStackSize ctx i) + +-- | Does the given Id correspond to a LNE live var on the stack +ctxIsLneLiveVar :: ExprCtx -> Id -> Bool +ctxIsLneLiveVar ctx i = i `elem` map fst (ctxLneFrameVars ctx) + +-- | Return the LNE stack size associated to the given Id. +-- Return Nothing when the Id doesn't correspond to a LNE binding. +ctxLneBindingStackSize :: ExprCtx -> Id -> Maybe Int +ctxLneBindingStackSize ctx i = lookupUFM (ctxLneFrameBs ctx) i + +-- | Shrink the LNE stack to the given size +ctxLneShrinkStack :: ExprCtx -> Int -> ExprCtx +ctxLneShrinkStack ctx n = + let l = ctxLneFrameSize ctx + in assertPpr + (l >= n) + (vcat [ text "ctxLneShrinkStack: let-no-escape stack too short:" + , ppr l + , text " < " + , ppr n + ]) + (ctx { ctxLneFrameVars = take n (ctxLneFrameVars ctx) + , ctxLneFrameSize = n + } + ) diff --git a/compiler/GHC/StgToJS/FFI.hs b/compiler/GHC/StgToJS/FFI.hs new file mode 100644 index 0000000000..0c1a713f70 --- /dev/null +++ b/compiler/GHC/StgToJS/FFI.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.FFI + ( genPrimCall + , genForeignCall + , saturateFFI + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Arg +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Monad +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Regs +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Ids + +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Unique.Map +import GHC.Types.Unique.FM + +import GHC.Stg.Syntax + +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim + +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr, vcat, text) +import GHC.Data.FastString + +import Data.Char +import Data.Monoid +import Data.Maybe +import qualified Data.List as L +import Control.Monad +import Control.Applicative +import qualified Text.ParserCombinators.ReadP as P + +genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult) +genPrimCall ctx (PrimCall lbl _) args t = do + j <- parseFFIPattern False False False ("h$" ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args + return (j, ExprInline Nothing) + +-- | generate the actual call +{- + parse FFI patterns: + "&value -> value + 1. "function" -> ret = function(...) + 2. "$r = $1.f($2) -> r1 = a1.f(a2) + + arguments, $1, $2, $3 unary arguments + $1_1, $1_2, for a binary argument + + return type examples + 1. $r unary return + 2. $r1, $r2 binary return + 3. $r1, $r2, $r3_1, $r3_2 unboxed tuple return + -} +parseFFIPattern :: Bool -- ^ catch exception and convert them to haskell exceptions + -> Bool -- ^ async (only valid with javascript calling conv) + -> Bool -- ^ using javascript calling convention + -> String + -> Type + -> [JExpr] + -> [StgArg] + -> G JStat +parseFFIPattern catchExcep async jscc pat t es as + | catchExcep = do + c <- parseFFIPatternA async jscc pat t es as + -- Generate: + -- try { + -- `c`; + -- } catch(except) { + -- return h$throwJSException(except); + -- } + let ex = TxtI "except" + return (TryStat c ex (ReturnStat (ApplExpr (var "h$throwJSException") [toJExpr ex])) mempty) + | otherwise = parseFFIPatternA async jscc pat t es as + +parseFFIPatternA :: Bool -- ^ async + -> Bool -- ^ using JavaScript calling conv + -> String + -> Type + -> [JExpr] + -> [StgArg] + -> G JStat +-- async calls get an extra callback argument +-- call it with the result +parseFFIPatternA True True pat t es as = do + cb <- freshIdent + x <- freshIdent + d <- freshIdent + stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as + return $ mconcat + [ x ||= (toJExpr (jhFromList [("mv", null_)])) + , cb ||= ApplExpr (var "h$mkForeignCallback") [toJExpr x] + , stat + , IfStat (InfixExpr StrictEqOp (toJExpr x .^ "mv") null_) + (mconcat + [ toJExpr x .^ "mv" |= UOpExpr NewOp (ApplExpr (var "h$MVar") []) + , sp |= Add sp one_ + , (IdxExpr stack sp) |= var "h$unboxFFIResult" + , ReturnStat $ ApplExpr (var "h$takeMVar") [toJExpr x .^ "mv"] + ]) + (mconcat + [ d ||= toJExpr x .^ "mv" + , copyResult (toJExpr d) + ]) + ] + where nrst = typeSize t + copyResult d = assignAllEqual es (map (IdxExpr d . toJExpr) [0..nrst-1]) +parseFFIPatternA _async javascriptCc pat t es as = + parseFFIPattern' Nothing javascriptCc pat t es as + +-- parseFFIPatternA _ _ _ _ _ _ = error "parseFFIPattern: non-JavaScript pattern must be synchronous" + +parseFFIPattern' :: Maybe JExpr -- ^ Nothing for sync, Just callback for async + -> Bool -- ^ javascript calling convention used + -> String -- ^ pattern called + -> Type -- ^ return type + -> [JExpr] -- ^ expressions to return in (may be more than necessary) + -> [StgArg] -- ^ arguments + -> G JStat +parseFFIPattern' callback javascriptCc pat t ret args + | not javascriptCc = mkApply pat + | otherwise = + if True + then mkApply pat + else do + u <- freshUnique + case parseFfiJME pat u of + Right (ValExpr (JVar (TxtI _ident))) -> mkApply pat + Right expr | not async && length tgt < 2 -> do + (statPre, ap) <- argPlaceholders javascriptCc args + let rp = resultPlaceholders async t ret + env = addListToUFM emptyUFM (rp ++ ap) + if length tgt == 1 + then return $ statPre <> (mapStatIdent (replaceIdent env) (var "$r" |= expr)) + else return $ statPre <> (mapStatIdent (replaceIdent env) (toStat expr)) + Right _ -> p $ "invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " ++ + " imports with result size 0 or 1.\n" ++ pat + Left _ -> case parseFfiJM pat u of + Left err -> p (show err) + Right stat -> do + let rp = resultPlaceholders async t ret + let cp = callbackPlaceholders callback + (statPre, ap) <- argPlaceholders javascriptCc args + let env = addListToUFM emptyUFM (rp ++ ap ++ cp) + return $ statPre <> (mapStatIdent (replaceIdent env) stat) -- fixme trace? + where + async = isJust callback + tgt = take (typeSize t) ret + -- automatic apply, build call and result copy + mkApply f + | Just cb <- callback = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as++[cb]) + | {-ts@-} + (t:ts') <- tgt = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as + <> mconcat stats + <> (t |= ApplExpr f' (concat as) ) + <> copyResult ts' + -- _ -> error "mkApply: empty list" + | otherwise = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as) + where f' = toJExpr (TxtI $ mkFastString f) + copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs + p e = error ("Parse error in FFI pattern: " ++ pat ++ "\n" ++ e) + + replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr + replaceIdent env i + | isFFIPlaceholder i = fromMaybe err (lookupUFM env i) + | otherwise = ValExpr (JVar i) + where + (TxtI i') = i + err = pprPanic "parseFFIPattern': invalid placeholder, check function type" + (vcat [text pat, ppr i', ppr args, ppr t]) + traceCall cs as + | csTraceForeign cs = ApplStat (var "h$traceForeign") [toJExpr pat, toJExpr as] + | otherwise = mempty + +-- ident is $N, $N_R, $rN, $rN_R or $r or $c +isFFIPlaceholder :: Ident -> Bool +isFFIPlaceholder (TxtI x) = not (null (P.readP_to_S parser (unpackFS x))) + where + digit = P.satisfy (`elem` ("0123456789" :: String)) + parser = void (P.string "$r" >> P.eof) <|> + void (P.string "$c" >> P.eof) <|> do + _ <- P.char '$' + P.optional (P.char 'r') + _ <- P.many1 digit + P.optional (P.char '_' >> P.many1 digit) + P.eof + +-- generate arg to be passed to FFI call, with marshalling JStat to be run +-- before the call +genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr]) +genFFIArg _isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l +genFFIArg isJavaScriptCc a@(StgVarArg i) + | not isJavaScriptCc && + (tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon) = + (\x -> (mempty,[x, zero_])) <$> varForId i + | isVoid r = return (mempty, []) +-- | Just x <- marshalFFIArg a = x + | isMultiVar r = (mempty,) <$> mapM (varForIdN i) [1..varSize r] + | otherwise = (\x -> (mempty,[x])) <$> varForId i + where + tycon = tyConAppTyCon (unwrapType arg_ty) + arg_ty = stgArgType a + r = uTypeVt arg_ty + +-- $1, $2, $3 for single, $1_1, $1_2 etc for dual +-- void args not counted +argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident,JExpr)]) +argPlaceholders isJavaScriptCc args = do + (stats, idents0) <- unzip <$> mapM (genFFIArg isJavaScriptCc) args + let idents = filter (not . null) idents0 + return $ (mconcat stats, concat + (zipWith (\is n -> mkPlaceholder True ("$"++show n) is) idents [(1::Int)..])) + +mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)] +mkPlaceholder undersc prefix aids = + case aids of + [] -> [] + [x] -> [(TxtI . mkFastString $ prefix, x)] + xs@(x:_) -> (TxtI . mkFastString $ prefix, x) : + zipWith (\x m -> (TxtI . mkFastString $ prefix ++ u ++ show m,x)) xs [(1::Int)..] + where u = if undersc then "_" else "" + +-- $r for single, $r1,$r2 for dual +-- $r1, $r2, etc for ubx tup, void args not counted +resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)] -- ident, replacement +resultPlaceholders True _ _ = [] -- async has no direct resuls, use callback +resultPlaceholders False t rs = + case typeVt (unwrapType t) of + [t'] -> mkUnary (varSize t') + uts -> + let sizes = filter (>0) (map varSize uts) + f _ 0 = [] + f n 1 = [["$r" ++ show n]] + f n k = ["$r" ++ sn, "$r" ++ sn ++ "_1"] : map (\x -> ["$r" ++ sn ++ "_" ++ show x]) [2..k] + where sn = show n + phs = zipWith (\size n -> f n size) sizes [(1::Int)..] + in case sizes of + [n] -> mkUnary n + _ -> concat $ zipWith (\phs' r -> map (\i -> (TxtI (mkFastString i), r)) phs') (concat phs) rs + where + mkUnary 0 = [] + mkUnary 1 = [(TxtI "$r",head rs)] -- single + mkUnary n = [(TxtI "$r",head rs),(TxtI "$r1", head rs)] ++ + zipWith (\n r -> (TxtI . mkFastString $ "$r" ++ show n, toJExpr r)) [2..n] (tail rs) + +callbackPlaceholders :: Maybe JExpr -> [(Ident,JExpr)] +callbackPlaceholders Nothing = [] +callbackPlaceholders (Just e) = [((TxtI "$c"), e)] + +parseFfiJME :: String -> Int -> Either String JExpr +parseFfiJME _xs _u = Left "parseFfiJME not yet implemented" + +parseFfiJM :: String -> Int -> Either String JStat +parseFfiJM _xs _u = Left "parseFfiJM not yet implemented" + +saturateFFI :: JMacro a => Int -> a -> a +saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) + +genForeignCall :: HasDebugCallStack + => ExprCtx + -> ForeignCall + -> Type + -> [JExpr] + -> [StgArg] + -> G (JStat, ExprResult) +genForeignCall _ctx + (CCall (CCallSpec (StaticTarget _ tgt Nothing True) + JavaScriptCallConv + PlayRisky)) + _t + [obj] + args + | tgt == fsLit "h$buildObject" + , Just pairs <- getObjectKeyValuePairs args = do + pairs' <- mapM (\(k,v) -> genArg v >>= \vs -> return (k, head vs)) pairs + return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs')) + , ExprInline Nothing + ) + +genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do + emitForeign (ctxSrcSpan ctx) (mkFastString lbl) safety cconv (map showArgType args) (showType t) + (,exprResult) <$> parseFFIPattern catchExcep async isJsCc lbl t tgt' args + where + isJsCc = cconv == JavaScriptCallConv + + lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget + = let clbl' = unpackFS clbl + in if | isJsCc -> clbl' + | wrapperPrefix `L.isPrefixOf` clbl' -> + ("h$" ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl')) + | otherwise -> "h$" ++ clbl' + | otherwise = "h$callDynamic" + + exprResult | async = ExprCont + | otherwise = ExprInline Nothing + + catchExcep = (cconv == JavaScriptCallConv) && + playSafe safety || playInterruptible safety + + async | isJsCc = playInterruptible safety + | otherwise = playInterruptible safety || playSafe safety + + tgt' | async = take (length tgt) jsRegsFromR1 + | otherwise = tgt + + wrapperPrefix = "ghczuwrapperZC" + +getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)] +getObjectKeyValuePairs [] = Just [] +getObjectKeyValuePairs (k:v:xs) + | Just t <- argJSStringLitUnfolding k = + fmap ((t,v):) (getObjectKeyValuePairs xs) +getObjectKeyValuePairs _ = Nothing + +argJSStringLitUnfolding :: StgArg -> Maybe FastString +argJSStringLitUnfolding (StgVarArg _v) = Nothing -- fixme +argJSStringLitUnfolding _ = Nothing + +showArgType :: StgArg -> FastString +showArgType a = showType (stgArgType a) + +showType :: Type -> FastString +showType t + | Just tc <- tyConAppTyCon_maybe (unwrapType t) = + mkFastString (renderWithContext defaultSDocContext (ppr tc)) + | otherwise = "<unknown>" diff --git a/compiler/GHC/StgToJS/Heap.hs b/compiler/GHC/StgToJS/Heap.hs new file mode 100644 index 0000000000..fe2955812d --- /dev/null +++ b/compiler/GHC/StgToJS/Heap.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Heap + ( closureType + , entryClosureType + , isObject + , isThunk + , isThunk' + , isBlackhole + , isFun + , isFun' + , isPap + , isPap' + , isCon + , isCon' + , conTag + , conTag' + , closureEntry + , closureMeta + , closureField1 + , closureField2 + , closureCC + , funArity + , funArity' + , papArity + , funOrPapArity + -- * Field names + , closureEntry_ + , closureMeta_ + , closureCC_ + , closureField1_ + , closureField2_ + -- * Javascript Type literals + , jTyObject + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.StgToJS.Types +import GHC.Data.FastString + +closureEntry_ :: FastString +closureEntry_ = "f" + +closureField1_ :: FastString +closureField1_ = "d1" + +closureField2_ :: FastString +closureField2_ = "d2" + +closureMeta_ :: FastString +closureMeta_ = "m" + +closureCC_ :: FastString +closureCC_ = "cc" + +entryClosureType_ :: FastString +entryClosureType_ = "t" + +entryConTag_ :: FastString +entryConTag_ = "a" + +entryFunArity_ :: FastString +entryFunArity_ = "a" + +jTyObject :: JExpr +jTyObject = jString "object" + +closureType :: JExpr -> JExpr +closureType = entryClosureType . closureEntry + +entryClosureType :: JExpr -> JExpr +entryClosureType f = f .^ entryClosureType_ + +isObject :: JExpr -> JExpr +isObject c = typeof c .===. String "object" + +isThunk :: JExpr -> JExpr +isThunk c = closureType c .===. toJExpr Thunk + +isThunk' :: JExpr -> JExpr +isThunk' f = entryClosureType f .===. toJExpr Thunk + +isBlackhole :: JExpr -> JExpr +isBlackhole c = closureType c .===. toJExpr Blackhole + +isFun :: JExpr -> JExpr +isFun c = closureType c .===. toJExpr Fun + +isFun' :: JExpr -> JExpr +isFun' f = entryClosureType f .===. toJExpr Fun + +isPap :: JExpr -> JExpr +isPap c = closureType c .===. toJExpr Pap + +isPap' :: JExpr -> JExpr +isPap' f = entryClosureType f .===. toJExpr Pap + +isCon :: JExpr -> JExpr +isCon c = closureType c .===. toJExpr Con + +isCon' :: JExpr -> JExpr +isCon' f = entryClosureType f .===. toJExpr Con + +conTag :: JExpr -> JExpr +conTag = conTag' . closureEntry + +conTag' :: JExpr -> JExpr +conTag' f = f .^ entryConTag_ + +-- | Get closure entry function +closureEntry :: JExpr -> JExpr +closureEntry p = p .^ closureEntry_ + +-- | Get closure metadata +closureMeta :: JExpr -> JExpr +closureMeta p = p .^ closureMeta_ + +-- | Get closure cost-center +closureCC :: JExpr -> JExpr +closureCC p = p .^ closureCC_ + +-- | Get closure extra field 1 +closureField1 :: JExpr -> JExpr +closureField1 p = p .^ closureField1_ + +-- | Get closure extra field 2 +closureField2 :: JExpr -> JExpr +closureField2 p = p .^ closureField2_ + +-- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +funArity :: JExpr -> JExpr +funArity = funArity' . closureEntry + +-- function arity with raw reference to the entry +funArity' :: JExpr -> JExpr +funArity' f = f .^ entryFunArity_ + +-- arity of a partial application +papArity :: JExpr -> JExpr +papArity cp = closureField1 (closureField2 cp) + +funOrPapArity + :: JExpr -- ^ heap object + -> Maybe JExpr -- ^ reference to entry, if you have one already (saves a c.f lookup twice) + -> JExpr -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments) +funOrPapArity c = \case + Nothing -> ((IfExpr (toJExpr (isFun c))) (toJExpr (funArity c))) + (toJExpr (papArity c)) + Just f -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (funArity' f))) + (toJExpr (papArity c)) diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs new file mode 100644 index 0000000000..5d28b511f6 --- /dev/null +++ b/compiler/GHC/StgToJS/Ids.hs @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Ids +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Module to deal with JS identifiers +----------------------------------------------------------------------------- + +module GHC.StgToJS.Ids + ( freshUnique + , freshIdent + , makeIdentForId + , cachedIdentForId + -- * Helpers for Idents + , identForId + , identForIdN + , identsForId + , identForEntryId + , identForDataConEntryId + , identForDataConWorker + -- * Helpers for variables + , varForId + , varForIdN + , varsForId + , varForEntryId + , varForDataConEntryId + , varForDataConWorker + , declVarsForId + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Symbols + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import Control.Monad +import Control.Monad.IO.Class +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Map as M +import Data.Maybe +import qualified Data.ByteString.Char8 as BSC + +-- | Get fresh unique number +freshUnique :: G Int +freshUnique = do + id_gen <- State.gets gsId + liftIO $ do + -- no need for atomicFetchAdd as we don't use threads in G + v <- readFastMutInt id_gen + writeFastMutInt id_gen (v+1) + pure v + +-- | Get fresh local Ident of the form: h$$unit:module_uniq +freshIdent :: G Ident +freshIdent = do + i <- freshUnique + mod <- State.gets gsModule + let !name = mkFreshJsSymbol mod i + return (TxtI name) + + +-- | Generate unique Ident for the given ID (uncached!) +-- +-- The ident has the following forms: +-- +-- global Id: h$unit:module.name[_num][_type_suffix] +-- local Id: h$$unit:module.name[_num][_type_suffix]_uniq +-- +-- Note that the string is z-encoded except for "_" delimiters. +-- +-- Optional "_type_suffix" can be: +-- - "_e" for IdEntry +-- - "_con_e" for IdConEntry +-- +-- Optional "_num" is passed as an argument to this function. It is used for +-- Haskell Ids that require several JS variables: e.g. 64-bit numbers (Word64#, +-- Int64#), Addr#, StablePtr#, unboxed tuples, etc. +-- +makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident +makeIdentForId i num id_type current_module = TxtI ident + where + exported = isExportedId i + name = getName i + mod + | exported + , Just m <- nameModule_maybe name + = m + | otherwise + = current_module + + !ident = mkFastStringByteString $ mconcat + [ mkJsSymbolBS exported mod (occNameFS (nameOccName name)) + + ------------- + -- suffixes + + -- suffix for Ids represented with more than one JS var ("_0", "_1", etc.) + , case num of + Nothing -> mempty + Just v -> mconcat [BSC.pack "_", intBS v] + + -- suffix for entry and constructor entry + , case id_type of + IdPlain -> mempty + IdEntry -> BSC.pack "_e" + IdConEntry -> BSC.pack "_con_e" + + -- unique suffix for non-exported Ids + , if exported + then mempty + else let (c,u) = unpkUnique (getUnique i) + in mconcat [BSC.pack ['_',c,'_'], intBS u] + ] + +-- | Retrieve the cached Ident for the given Id if there is one. Otherwise make +-- a new one with 'makeIdentForId' and cache it. +cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident +cachedIdentForId i mi id_type = do + + -- compute key + let !key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) id_type + + -- lookup Ident in the Ident cache + IdCache cache <- State.gets gsIdents + ident <- case M.lookup key cache of + Just ident -> pure ident + Nothing -> do + mod <- State.gets gsModule + let !ident = makeIdentForId i mi id_type mod + let !cache' = IdCache (M.insert key ident cache) + State.modify (\s -> s { gsIdents = cache' }) + pure ident + + -- Now update the GlobalId cache, if required + + let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain + -- fixme also allow caching entries for lifting? + + when (update_global_cache) $ do + GlobalIdCache gidc <- getGlobalIdCache + case elemUFM ident gidc of + False -> setGlobalIdCache $ GlobalIdCache (addToUFM gidc ident (key, i)) + True -> pure () + + pure ident + +-- | Retrieve default Ident for the given Id +identForId :: Id -> G Ident +identForId i = cachedIdentForId i Nothing IdPlain + +-- | Retrieve default Ident for the given Id with sub index +-- +-- Some types, Word64, Addr#, unboxed tuple have more than one corresponding JS +-- var, hence we use the sub index to identify each subpart / JS variable. +identForIdN :: Id -> Int -> G Ident +identForIdN i n = cachedIdentForId i (Just n) IdPlain + +-- | Retrieve all the idents for the given Id. +identsForId :: Id -> G [Ident] +identsForId i = case typeSize (idType i) of + 0 -> pure mempty + 1 -> (:[]) <$> identForId i + s -> mapM (identForIdN i) [1..s] + + +-- | Retrieve entry Ident for the given Id +identForEntryId :: Id -> G Ident +identForEntryId i = cachedIdentForId i Nothing IdEntry + +-- | Retrieve datacon entry Ident for the given Id +-- +-- Different name than the datacon wrapper. +identForDataConEntryId :: Id -> G Ident +identForDataConEntryId i = cachedIdentForId i Nothing IdConEntry + + +-- | Retrieve default variable name for the given Id +varForId :: Id -> G JExpr +varForId i = toJExpr <$> identForId i + +-- | Retrieve default variable name for the given Id with sub index +varForIdN :: Id -> Int -> G JExpr +varForIdN i n = toJExpr <$> identForIdN i n + +-- | Retrieve all the JS vars for the given Id +varsForId :: Id -> G [JExpr] +varsForId i = case typeSize (idType i) of + 0 -> pure mempty + 1 -> (:[]) <$> varForId i + s -> mapM (varForIdN i) [1..s] + + +-- | Retrieve entry variable name for the given Id +varForEntryId :: Id -> G JExpr +varForEntryId i = toJExpr <$> identForEntryId i + +-- | Retrieve datacon entry variable name for the given Id +varForDataConEntryId :: Id -> G JExpr +varForDataConEntryId i = ValExpr . JVar <$> identForDataConEntryId i + + +-- | Retrieve datacon worker entry variable name for the given datacon +identForDataConWorker :: DataCon -> G Ident +identForDataConWorker d = identForDataConEntryId (dataConWorkId d) + +-- | Retrieve datacon worker entry variable name for the given datacon +varForDataConWorker :: DataCon -> G JExpr +varForDataConWorker d = varForDataConEntryId (dataConWorkId d) + +-- | Declare all js vars for the id +declVarsForId :: Id -> G JStat +declVarsForId i = case typeSize (idType i) of + 0 -> return mempty + 1 -> decl <$> identForId i + s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s] + diff --git a/compiler/GHC/StgToJS/Linker/Linker.hs b/compiler/GHC/StgToJS/Linker/Linker.hs new file mode 100644 index 0000000000..6c4b011ce9 --- /dev/null +++ b/compiler/GHC/StgToJS/Linker/Linker.hs @@ -0,0 +1,953 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Linker +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- GHCJS linker, collects dependencies from the object files +-- which contain linkable units with dependency information +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Linker + ( jsLinkBinary + , embedJsFile + ) +where + +import Prelude + +import GHC.Platform.Host (hostPlatformArchOS) + +import GHC.JS.Make +import GHC.JS.Syntax + +import GHC.Driver.Session (DynFlags(..)) +import Language.Haskell.Syntax.Module.Name +import GHC.SysTools.Cpp +import GHC.SysTools + +import GHC.Linker.Static.Utils (exeFileName) + +import GHC.StgToJS.Linker.Types +import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Rts.Rts +import GHC.StgToJS.Object +import GHC.StgToJS.Types hiding (LinkableUnit) +import GHC.StgToJS.Symbols +import GHC.StgToJS.Printer +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure + +import GHC.Unit.State +import GHC.Unit.Env +import GHC.Unit.Home +import GHC.Unit.Types +import GHC.Unit.Module (moduleStableString) + +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Logger (Logger, logVerbAtLeast) +import GHC.Utils.Binary +import qualified GHC.Utils.Ppr as Ppr +import GHC.Utils.Monad +import GHC.Utils.TmpFs + +import GHC.Types.Unique.Set + +import qualified GHC.SysTools.Ar as Ar + +import qualified GHC.Data.ShortText as ST +import GHC.Data.FastString + +import Control.Concurrent.MVar +import Control.Monad + +import Data.Array +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS +import Data.Function (on) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.IORef +import Data.List ( partition, nub, intercalate, group, sort + , groupBy, intersperse, + ) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import Data.Word + +import System.IO +import System.FilePath ((<.>), (</>), dropExtension, takeDirectory) +import System.Directory ( createDirectoryIfMissing + , doesFileExist + , getCurrentDirectory + , Permissions(..) + , setPermissions + , getPermissions + ) + +data LinkerStats = LinkerStats + { bytesPerModule :: !(Map Module Word64) -- ^ number of bytes linked per module + , packedMetaDataSize :: !Word64 -- ^ number of bytes for metadata + } + +newtype ArchiveState = ArchiveState { loadedArchives :: IORef (Map FilePath Ar.Archive) } + +emptyArchiveState :: IO ArchiveState +emptyArchiveState = ArchiveState <$> newIORef M.empty + +jsLinkBinary + :: JSLinkConfig + -> StgToJSConfig + -> [FilePath] + -> Logger + -> DynFlags + -> UnitEnv + -> [FilePath] + -> [UnitId] + -> IO () +jsLinkBinary lc_cfg cfg js_srcs logger dflags u_env objs dep_pkgs + | lcNoJSExecutables lc_cfg = return () + | otherwise = do + -- additional objects to link are passed as FileOption ldInputs... + let cmdline_objs = [ f | FileOption _ f <- ldInputs dflags ] + -- discriminate JavaScript sources from real object files. + (cmdline_js_srcs, cmdline_js_objs) <- partitionM isJsFile cmdline_objs + let + objs' = map ObjFile (objs ++ cmdline_js_objs) + js_srcs' = js_srcs ++ cmdline_js_srcs + isRoot _ = True + exe = jsExeFileName dflags + + void $ link lc_cfg cfg logger u_env exe mempty dep_pkgs objs' js_srcs' isRoot mempty + +-- | link and write result to disk (jsexe directory) +link :: JSLinkConfig + -> StgToJSConfig + -> Logger + -> UnitEnv + -> FilePath -- ^ output file/directory + -> [FilePath] -- ^ include path for home package + -> [UnitId] -- ^ packages to link + -> [LinkedObj] -- ^ the object files we're linking + -> [FilePath] -- ^ extra js files to include + -> (ExportedFun -> Bool) -- ^ functions from the objects to use as roots (include all their deps) + -> Set ExportedFun -- ^ extra symbols to link in + -> IO () +link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun extraStaticDeps = do + + -- create output directory + createDirectoryIfMissing False out + + ------------------------------------------------------------- + -- link all Haskell code (program + dependencies) into out.js + + -- compute dependencies + (dep_map, dep_units, all_deps, _rts_wired_functions, dep_archives) + <- computeLinkDependencies cfg logger out unit_env units objFiles extraStaticDeps isRootFun + + -- retrieve code for dependencies + mods <- collectDeps dep_map dep_units all_deps + + -- LTO + rendering of JS code + link_stats <- withBinaryFile (out </> "out.js") WriteMode $ \h -> + renderLinker h mods jsFiles + + ------------------------------------------------------------- + + -- dump foreign references file (.frefs) + unless (lcOnlyOut lc_cfg) $ do + let frefsFile = "out.frefs" + -- frefs = concatMap mc_frefs mods + jsonFrefs = mempty -- FIXME: toJson frefs + + BL.writeFile (out </> frefsFile <.> "json") jsonFrefs + BL.writeFile (out </> frefsFile <.> "js") + ("h$checkForeignRefs(" <> jsonFrefs <> ");") + + -- dump stats + unless (lcNoStats lc_cfg) $ do + let statsFile = "out.stats" + writeFile (out </> statsFile) (renderLinkerStats link_stats) + + -- link generated RTS parts into rts.js + unless (lcNoRts lc_cfg) $ do + BL.writeFile (out </> "rts.js") ( BLC.pack rtsDeclsText + <> BLC.pack (rtsText cfg)) + + -- link dependencies' JS files into lib.js + withBinaryFile (out </> "lib.js") WriteMode $ \h -> do + forM_ dep_archives $ \archive_file -> do + Ar.Archive entries <- Ar.loadAr archive_file + forM_ entries $ \entry -> do + case getJsArchiveEntry entry of + Nothing -> return () + Just bs -> do + B.hPut h bs + hPutChar h '\n' + + -- link everything together into all.js + when (generateAllJs lc_cfg) $ do + _ <- combineFiles lc_cfg out + writeHtml out + writeRunMain out + writeRunner lc_cfg out + writeExterns out + + +computeLinkDependencies + :: StgToJSConfig + -> Logger + -> String + -> UnitEnv + -> [UnitId] + -> [LinkedObj] + -> Set ExportedFun + -> (ExportedFun -> Bool) + -> IO (Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit, Set ExportedFun, [FilePath]) +computeLinkDependencies cfg logger target unit_env units objFiles extraStaticDeps isRootFun = do + + (objDepsMap, objRequiredUnits) <- loadObjDeps objFiles + + let roots = S.fromList . filter isRootFun $ concatMap (M.keys . depsHaskellExported . fst) (M.elems objDepsMap) + rootMods = map (moduleNameString . moduleName . head) . group . sort . map funModule . S.toList $ roots + objPkgs = map moduleUnitId $ nub (M.keys objDepsMap) + + when (logVerbAtLeast logger 2) $ void $ do + compilationProgressMsg logger $ hcat + [ text "Linking ", text target, text " (", text (intercalate "," rootMods), char ')' ] + compilationProgressMsg logger $ hcat + [ text "objDepsMap ", ppr objDepsMap ] + compilationProgressMsg logger $ hcat + [ text "objFiles ", ppr objFiles ] + + let (rts_wired_units, rts_wired_functions) = rtsDeps units + + -- all the units we want to link together, without their dependencies + let root_units = filter (/= mainUnitId) + $ nub + $ rts_wired_units ++ reverse objPkgs ++ reverse units + + -- all the units we want to link together, including their dependencies, + -- preload units, and backpack instantiations + all_units_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env root_units) + + let all_units = fmap unitId all_units_infos + + dep_archives <- getPackageArchives cfg unit_env all_units + env <- newGhcjsEnv + (archsDepsMap, archsRequiredUnits) <- loadArchiveDeps env dep_archives + + when (logVerbAtLeast logger 2) $ + logInfo logger $ hang (text "Linking with archives:") 2 (vcat (fmap text dep_archives)) + + -- compute dependencies + let dep_units = all_units ++ [homeUnitId (ue_unsafeHomeUnit $ unit_env)] + dep_map = objDepsMap `M.union` archsDepsMap + excluded_units = S.empty + dep_fun_roots = roots `S.union` rts_wired_functions `S.union` extraStaticDeps + dep_unit_roots = archsRequiredUnits ++ objRequiredUnits + + all_deps <- getDeps (fmap fst dep_map) excluded_units dep_fun_roots dep_unit_roots + + when (logVerbAtLeast logger 2) $ + logInfo logger $ hang (text "Units to link:") 2 (vcat (fmap ppr dep_units)) + -- logInfo logger $ hang (text "All deps:") 2 (vcat (fmap ppr (S.toList all_deps))) + + return (dep_map, dep_units, all_deps, rts_wired_functions, dep_archives) + + +-- | Compiled module +data ModuleCode = ModuleCode + { mc_module :: !Module + , mc_js_code :: !JStat + , mc_exports :: !B.ByteString -- ^ rendered exports + , mc_closures :: ![ClosureInfo] + , mc_statics :: ![StaticInfo] + , mc_frefs :: ![ForeignJSRef] + } + +-- | ModuleCode after link with other modules. +-- +-- It contains less information than ModuleCode because they have been commoned +-- up into global "metadata" for the whole link. +data CompactedModuleCode = CompactedModuleCode + { cmc_module :: !Module + , cmc_js_code :: !JStat + , cmc_exports :: !B.ByteString -- ^ rendered exports + } + +-- | Link modules and pretty-print them into the given Handle +renderLinker + :: Handle + -> [ModuleCode] -- ^ linked code per module + -> [FilePath] -- ^ additional JS files + -> IO LinkerStats +renderLinker h mods jsFiles = do + + -- link modules + let (compacted_mods, meta) = linkModules mods + + let + putBS = B.hPut h + putJS x = do + before <- hTell h + Ppr.printLeftRender h (pretty x) + hPutChar h '\n' + after <- hTell h + pure $! (after - before) + + --------------------------------------------------------- + -- Pretty-print JavaScript code for all the dependencies. + -- + -- We have to pretty-print at link time because we want to be able to perform + -- global link-time optimisations (e.g. renamings) on the whole generated JS + -- file. + + -- modules themselves + mod_sizes <- forM compacted_mods $ \m -> do + !mod_size <- fromIntegral <$> putJS (cmc_js_code m) + let !mod_mod = cmc_module m + pure (mod_mod, mod_size) + + -- commoned up metadata + !meta_length <- fromIntegral <$> putJS meta + + -- module exports + mapM_ (putBS . cmc_exports) compacted_mods + + -- explicit additional JS files + mapM_ (\i -> B.readFile i >>= putBS) jsFiles + + -- stats + let link_stats = LinkerStats + { bytesPerModule = M.fromList mod_sizes + , packedMetaDataSize = meta_length + } + + pure link_stats + +-- | Render linker stats +renderLinkerStats :: LinkerStats -> String +renderLinkerStats s = + intercalate "\n\n" [meta_stats, package_stats, module_stats] <> "\n\n" + where + meta = packedMetaDataSize s + meta_stats = "number of modules: " <> show (length bytes_per_mod) + <> "\npacked metadata: " <> show meta + + bytes_per_mod = M.toList $ bytesPerModule s + + show_unit (UnitId fs) = unpackFS fs + + ps :: Map UnitId Word64 + ps = M.fromListWith (+) . map (\(m,s) -> (moduleUnitId m,s)) $ bytes_per_mod + + pad :: Int -> String -> String + pad n t = let l = length t + in if l < n then t <> replicate (n-l) ' ' else t + + pkgMods :: [[(Module,Word64)]] + pkgMods = groupBy ((==) `on` (moduleUnitId . fst)) bytes_per_mod + + showMod :: (Module, Word64) -> String + showMod (m,s) = pad 40 (" " <> moduleStableString m <> ":") <> show s <> "\n" + + package_stats :: String + package_stats = "code size summary per package (in bytes):\n\n" + <> concatMap (\(p,s) -> pad 25 (show_unit p <> ":") <> show s <> "\n") (M.toList ps) + + module_stats :: String + module_stats = "code size per module (in bytes):\n\n" <> unlines (map (concatMap showMod) pkgMods) + + +getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath] +getPackageArchives cfg unit_env units = + filterM doesFileExist [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a" + | u <- units + , p <- getInstalledPackageLibDirs ue_state u + , l <- getInstalledPackageHsLibs ue_state u + ] + where + ue_state = ue_units unit_env + + -- XXX the profiling library name is probably wrong now + profSuff | csProf cfg = "_p" + | otherwise = "" + + +-- | Combine rts.js, lib.js, out.js to all.js that can be run +-- directly with node.js or SpiderMonkey jsshell +combineFiles :: JSLinkConfig + -> FilePath + -> IO () +combineFiles cfg fp = do + let files = map (fp </>) ["rts.js", "lib.js", "out.js"] + withBinaryFile (fp </> "all.js") WriteMode $ \h -> do + let cpy i = B.readFile i >>= B.hPut h + mapM_ cpy files + unless (lcNoHsMain cfg) $ do + B.hPut h runMainJS + +-- | write the index.html file that loads the program if it does not exit +writeHtml + :: FilePath -- ^ output directory + -> IO () +writeHtml out = do + let htmlFile = out </> "index.html" + e <- doesFileExist htmlFile + unless e $ + B.writeFile htmlFile templateHtml + + +templateHtml :: B.ByteString +templateHtml = + "<!DOCTYPE html>\n\ + \<html>\n\ + \ <head>\n\ + \ </head>\n\ + \ <body>\n\ + \ </body>\n\ + \ <script language=\"javascript\" src=\"all.js\" defer></script>\n\ + \</html>" + +-- | write the runmain.js file that will be run with defer so that it runs after +-- index.html is loaded +writeRunMain + :: FilePath -- ^ output directory + -> IO () +writeRunMain out = do + let runMainFile = out </> "runmain.js" + e <- doesFileExist runMainFile + unless e $ + B.writeFile runMainFile runMainJS + +runMainJS :: B.ByteString +runMainJS = "h$main(h$mainZCZCMainzimain);\n" + +writeRunner :: JSLinkConfig -- ^ Settings + -> FilePath -- ^ Output directory + -> IO () +writeRunner _settings out = do + cd <- getCurrentDirectory + let arch_os = hostPlatformArchOS + let runner = cd </> exeFileName arch_os False (Just (dropExtension out)) + srcFile = out </> "all" <.> "js" + nodePgm :: B.ByteString + nodePgm = "node" + src <- B.readFile (cd </> srcFile) + B.writeFile runner ("#!/usr/bin/env " <> nodePgm <> "\n" <> src) + perms <- getPermissions runner + setPermissions runner (perms {executable = True}) + +rtsExterns :: FastString +rtsExterns = + "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <> + mconcat (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n") + [(7::Int)..16384]) + +writeExterns :: FilePath -> IO () +writeExterns out = writeFile (out </> "all.js.externs") + $ unpackFS rtsExterns + +-- | get all dependencies for a given set of roots +getDeps :: Map Module Deps -- ^ loaded deps + -> Set LinkableUnit -- ^ don't link these blocks + -> Set ExportedFun -- ^ start here + -> [LinkableUnit] -- ^ and also link these + -> IO (Set LinkableUnit) +getDeps loaded_deps base fun startlu = go' S.empty (S.fromList startlu) (S.toList fun) + where + go :: Set LinkableUnit + -> Set LinkableUnit + -> IO (Set LinkableUnit) + go result open = case S.minView open of + Nothing -> return result + Just (lu@(lmod,n), open') -> + case M.lookup lmod loaded_deps of + Nothing -> pprPanic "getDeps.go: object file not loaded for: " (pprModule lmod) + Just (Deps _ _ _ b) -> + let block = b!n + result' = S.insert lu result + in go' result' + (addOpen result' open' $ + map (lmod,) (blockBlockDeps block)) (blockFunDeps block) + + go' :: Set LinkableUnit + -> Set LinkableUnit + -> [ExportedFun] + -> IO (Set LinkableUnit) + go' result open [] = go result open + go' result open (f:fs) = + let key = funModule f + in case M.lookup key loaded_deps of + Nothing -> pprPanic "getDeps.go': object file not loaded for: " $ pprModule key + Just (Deps _m _r e _b) -> + let lun :: Int + lun = fromMaybe (pprPanic "exported function not found: " $ ppr f) + (M.lookup f e) + lu = (key, lun) + in go' result (addOpen result open [lu]) fs + + addOpen :: Set LinkableUnit -> Set LinkableUnit -> [LinkableUnit] + -> Set LinkableUnit + addOpen result open newUnits = + let alreadyLinked s = S.member s result || + S.member s open || + S.member s base + in open `S.union` S.fromList (filter (not . alreadyLinked) newUnits) + +-- | collect dependencies for a set of roots +collectDeps :: Map Module (Deps, DepsLocation) -- ^ Dependency map + -> [UnitId] -- ^ packages, code linked in this order + -> Set LinkableUnit -- ^ All dependencides + -> IO [ModuleCode] +collectDeps mod_deps packages all_deps = do + + -- read ghc-prim first, since we depend on that for static initialization + let packages' = uncurry (++) $ partition (== primUnitId) (nub packages) + + units_by_module :: Map Module IntSet + units_by_module = M.fromListWith IS.union $ + map (\(m,n) -> (m, IS.singleton n)) (S.toList all_deps) + + mod_deps_bypkg :: Map UnitId [(Deps, DepsLocation)] + mod_deps_bypkg = M.fromListWith (++) + (map (\(m,v) -> (moduleUnitId m,[v])) (M.toList mod_deps)) + + ar_state <- emptyArchiveState + fmap (catMaybes . concat) . forM packages' $ \pkg -> + mapM (uncurry $ extractDeps ar_state units_by_module) + (fromMaybe [] $ M.lookup pkg mod_deps_bypkg) + +extractDeps :: ArchiveState + -> Map Module IntSet + -> Deps + -> DepsLocation + -> IO (Maybe ModuleCode) +extractDeps ar_state units deps loc = + case M.lookup mod units of + Nothing -> return Nothing + Just mod_units -> Just <$> do + let selector n _ = fromIntegral n `IS.member` mod_units || isGlobalUnit (fromIntegral n) + case loc of + ObjectFile fp -> do + us <- readObjectUnits fp selector + pure (collectCode us) + ArchiveFile a -> do + obj <- readArObject ar_state mod a + us <- getObjectUnits obj selector + pure (collectCode us) + InMemory _n obj -> do + us <- getObjectUnits obj selector + pure (collectCode us) + where + mod = depsModule deps + newline = BC.pack "\n" + mk_exports = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw + mk_js_code = mconcat . map oiStat + collectCode l = ModuleCode + { mc_module = mod + , mc_js_code = mk_js_code l + , mc_exports = mk_exports l + , mc_closures = concatMap oiClInfo l + , mc_statics = concatMap oiStatic l + , mc_frefs = concatMap oiFImports l + } + +readArObject :: ArchiveState -> Module -> FilePath -> IO Object +readArObject ar_state mod ar_file = do + loaded_ars <- readIORef (loadedArchives ar_state) + (Ar.Archive entries) <- case M.lookup ar_file loaded_ars of + Just a -> pure a + Nothing -> do + a <- Ar.loadAr ar_file + modifyIORef (loadedArchives ar_state) (M.insert ar_file a) + pure a + + -- look for the right object in archive + let go_entries = \case + -- XXX this shouldn't be an exception probably + [] -> panic $ "could not find object for module " + ++ moduleNameString (moduleName mod) + ++ " in " + ++ ar_file + + (e:es) -> do + let bs = Ar.filedata e + bh <- unsafeUnpackBinBuffer bs + getObjectHeader bh >>= \case + Left _ -> go_entries es -- not a valid object entry + Right mod_name + | mod_name /= moduleName mod + -> go_entries es -- not the module we're looking for + | otherwise + -> getObjectBody bh mod_name -- found it + + go_entries entries + + +-- | A helper function to read system dependencies that are hardcoded +diffDeps + :: [UnitId] -- ^ Packages that are already Linked + -> ([UnitId], Set ExportedFun) -- ^ New units and functions to link + -> ([UnitId], Set ExportedFun) -- ^ Diff +diffDeps pkgs (deps_pkgs,deps_funs) = + ( filter linked_pkg deps_pkgs + , S.filter linked_fun deps_funs + ) + where + linked_fun f = moduleUnitId (funModule f) `S.member` linked_pkgs + linked_pkg p = S.member p linked_pkgs + linked_pkgs = S.fromList pkgs + +-- | dependencies for the RTS, these need to be always linked +rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun) +rtsDeps pkgs = diffDeps pkgs $ + ( [baseUnitId, primUnitId] + , S.fromList $ concat + [ mkBaseFuns "GHC.Conc.Sync" + ["reportError"] + , mkBaseFuns "Control.Exception.Base" + ["nonTermination"] + , mkBaseFuns "GHC.Exception.Type" + [ "SomeException" + , "underflowException" + , "overflowException" + , "divZeroException" + ] + , mkBaseFuns "GHC.TopHandler" + [ "runMainIO" + , "topHandler" + ] + , mkBaseFuns "GHC.Base" + ["$fMonadIO"] + , mkBaseFuns "GHC.Maybe" + [ "Nothing" + , "Just" + ] + , mkBaseFuns "GHC.Ptr" + ["Ptr"] + , mkBaseFuns "GHC.JS.Prim" + [ "JSVal" + , "JSException" + , "$fShowJSException" + , "$fExceptionJSException" + , "resolve" + , "resolveIO" + , "toIO" + ] + , mkBaseFuns "GHC.JS.Prim.Internal" + [ "wouldBlock" + , "blockedIndefinitelyOnMVar" + , "blockedIndefinitelyOnSTM" + , "ignoreException" + , "setCurrentThreadResultException" + , "setCurrentThreadResultValue" + ] + , mkPrimFuns "GHC.Types" + [ ":" + , "[]" + ] + , mkPrimFuns "GHC.Tuple.Prim" + [ "(,)" + , "(,,)" + , "(,,,)" + , "(,,,,)" + , "(,,,,,)" + , "(,,,,,,)" + , "(,,,,,,,)" + , "(,,,,,,,,)" + , "(,,,,,,,,,)" + ] + ] + ) + +-- | Export the functions in base +mkBaseFuns :: FastString -> [FastString] -> [ExportedFun] +mkBaseFuns = mkExportedFuns baseUnitId + +-- | Export the Prim functions +mkPrimFuns :: FastString -> [FastString] -> [ExportedFun] +mkPrimFuns = mkExportedFuns primUnitId + +-- | Given a @UnitId@, a module name, and a set of symbols in the module, +-- package these into an @ExportedFun@. +mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun] +mkExportedFuns uid mod_name symbols = map mk_fun symbols + where + mod = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod_name) + mk_fun sym = ExportedFun mod (LexicalFastString (mkJsSymbol True mod sym)) + +-- | read all dependency data from the to-be-linked files +loadObjDeps :: [LinkedObj] -- ^ object files to link + -> IO (Map Module (Deps, DepsLocation), [LinkableUnit]) +loadObjDeps objs = (prepareLoadedDeps . catMaybes) <$> mapM readDepsFromObj objs + +-- | Load dependencies for the Linker from Ar +loadArchiveDeps :: GhcjsEnv + -> [FilePath] + -> IO ( Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) +loadArchiveDeps env archives = modifyMVar (linkerArchiveDeps env) $ \m -> + case M.lookup archives' m of + Just r -> return (m, r) + Nothing -> loadArchiveDeps' archives >>= \r -> return (M.insert archives' r m, r) + where + archives' = S.fromList archives + +loadArchiveDeps' :: [FilePath] + -> IO ( Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) +loadArchiveDeps' archives = do + archDeps <- forM archives $ \file -> do + (Ar.Archive entries) <- Ar.loadAr file + catMaybes <$> mapM (readEntry file) entries + return (prepareLoadedDeps $ concat archDeps) + where + readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe (Deps, DepsLocation)) + readEntry ar_file ar_entry = do + let bs = Ar.filedata ar_entry + bh <- unsafeUnpackBinBuffer bs + getObjectHeader bh >>= \case + Left _ -> pure Nothing -- not a valid object entry + Right mod_name -> do + obj <- getObjectBody bh mod_name + let !deps = objDeps obj + pure $ Just (deps, ArchiveFile ar_file) + +-- | Predicate to check that an entry in Ar is a JS source +-- and to return it without its header +getJsArchiveEntry :: Ar.ArchiveEntry -> Maybe B.ByteString +getJsArchiveEntry entry = getJsBS (Ar.filedata entry) + +-- | Predicate to check that a file is a JS source +isJsFile :: FilePath -> IO Bool +isJsFile fp = withBinaryFile fp ReadMode $ \h -> do + bs <- B.hGet h jsHeaderLength + pure (isJsBS bs) + +isJsBS :: B.ByteString -> Bool +isJsBS bs = isJust (getJsBS bs) + +-- | Get JS source with its header (if it's one) +getJsBS :: B.ByteString -> Maybe B.ByteString +getJsBS bs = B.stripPrefix jsHeader bs + +-- Header added to JS sources to discriminate them from other object files. +-- They all have .o extension but JS sources have this header. +jsHeader :: B.ByteString +jsHeader = "//JavaScript" + +jsHeaderLength :: Int +jsHeaderLength = B.length jsHeader + + + +prepareLoadedDeps :: [(Deps, DepsLocation)] + -> ( Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) +prepareLoadedDeps deps = + let req = concatMap (requiredUnits . fst) deps + depsMap = M.fromList $ map (\d -> (depsModule (fst d), d)) deps + in (depsMap, req) + +requiredUnits :: Deps -> [LinkableUnit] +requiredUnits d = map (depsModule d,) (IS.toList $ depsRequired d) + +-- | read dependencies from an object that might have already been into memory +-- pulls in all Deps from an archive +readDepsFromObj :: LinkedObj -> IO (Maybe (Deps, DepsLocation)) +readDepsFromObj = \case + ObjLoaded name obj -> do + let !deps = objDeps obj + pure $ Just (deps,InMemory name obj) + ObjFile file -> do + readObjectDeps file >>= \case + Nothing -> pure Nothing + Just deps -> pure $ Just (deps,ObjectFile file) + + +-- | Embed a JS file into a .o file +-- +-- The JS file is merely copied into a .o file with an additional header +-- ("//Javascript") in order to be recognized later on. +-- +-- JS files may contain option pragmas of the form: //#OPTIONS: +-- For now, only the CPP option is supported. If the CPP option is set, we +-- append some common CPP definitions to the file and call cpp on it. +embedJsFile :: Logger -> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO () +embedJsFile logger dflags tmpfs unit_env input_fn output_fn = do + let profiling = False -- FIXME: add support for profiling way + + createDirectoryIfMissing True (takeDirectory output_fn) + + -- the header lets the linker recognize processed JavaScript files + -- But don't add JavaScript header to object files! + + is_js_obj <- if True + then pure False + else isJsObjectFile input_fn + -- FIXME (Sylvain 2022-09): this call makes the + -- testsuite go into a loop, I don't know why yet! + -- Disabling it for now. + + if is_js_obj + then copyWithHeader "" input_fn output_fn + else do + -- header appended to JS files stored as .o to recognize them. + let header = "//JavaScript\n" + jsFileNeedsCpp input_fn >>= \case + False -> copyWithHeader header input_fn output_fn + True -> do + + -- append common CPP definitions to the .js file. + -- They define macros that avoid directly wiring zencoded names + -- in RTS JS files + pp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + payload <- B.readFile input_fn + B.writeFile pp_fn (commonCppDefs profiling <> payload) + + -- run CPP on the input JS file + js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + let + cpp_opts = CppOpts + { cppUseCc = True + , cppLinePragmas = False -- LINE pragmas aren't JS compatible + } + doCpp logger + tmpfs + dflags + unit_env + cpp_opts + pp_fn + js_fn + -- add header to recognize the object as a JS file + copyWithHeader header js_fn output_fn + +jsFileNeedsCpp :: FilePath -> IO Bool +jsFileNeedsCpp fn = do + opts <- getOptionsFromJsFile fn + pure (CPP `elem` opts) + +-- | Link module codes. +-- +-- Performs link time optimizations and produces one JStat per module plus some +-- commoned up initialization code. +linkModules :: [ModuleCode] -> ([CompactedModuleCode], JStat) +linkModules mods = (compact_mods, meta) + where + compact_mods = map compact mods + + -- here GHCJS used to: + -- - deduplicate declarations + -- - rename local variables into shorter ones + -- - compress initialization data + -- but we haven't ported it (yet). + compact m = CompactedModuleCode + { cmc_js_code = mc_js_code m + , cmc_module = mc_module m + , cmc_exports = mc_exports m + } + + -- common up statics: different bindings may reference the same statics, we + -- filter them here to initialize them once + statics = nubStaticInfo (concatMap mc_statics mods) + + infos = concatMap mc_closures mods + meta = mconcat + -- render metadata as individual statements + [ mconcat (map staticDeclStat statics) + , mconcat (map staticInitStat statics) + , mconcat (map (closureInfoStat True) infos) + ] + +-- | Only keep a single StaticInfo with a given name +nubStaticInfo :: [StaticInfo] -> [StaticInfo] +nubStaticInfo = go emptyUniqSet + where + go us = \case + [] -> [] + (x:xs) -> + -- only match on siVar. There is no reason for the initializing value to + -- be different for the same global name. + let name = siVar x + in if elementOfUniqSet name us + then go us xs + else x : go (addOneToUniqSet us name) xs + +-- | Initialize a global object. +-- +-- All global objects have to be declared (staticInfoDecl) first. +staticInitStat :: StaticInfo -> JStat +staticInitStat (StaticInfo i sv mcc) = + case sv of + StaticData con args -> appS "h$sti" $ add_cc_arg + [ var i + , var con + , jsStaticArgs args + ] + StaticFun f args -> appS "h$sti" $ add_cc_arg + [ var i + , var f + , jsStaticArgs args + ] + StaticList args mt -> appS "h$stl" $ add_cc_arg + [ var i + , jsStaticArgs args + , toJExpr $ maybe null_ (toJExpr . TxtI) mt + ] + StaticThunk (Just (f,args)) -> appS "h$stc" $ add_cc_arg + [ var i + , var f + , jsStaticArgs args + ] + _ -> mempty + where + -- add optional cost-center argument + add_cc_arg as = case mcc of + Nothing -> as + Just cc -> as ++ [toJExpr cc] + +-- | declare and do first-pass init of a global object (create JS object for heap objects) +staticDeclStat :: StaticInfo -> JStat +staticDeclStat (StaticInfo global_name static_value _) = decl + where + global_ident = TxtI global_name + decl_init v = global_ident ||= v + decl_no_init = appS "h$di" [toJExpr global_ident] + + decl = case static_value of + StaticUnboxed u -> decl_init (unboxed_expr u) + StaticThunk Nothing -> decl_no_init -- CAF initialized in an alternative way + _ -> decl_init (app "h$d" []) + + unboxed_expr = \case + StaticUnboxedBool b -> app "h$p" [toJExpr b] + StaticUnboxedInt i -> app "h$p" [toJExpr i] + StaticUnboxedDouble d -> app "h$p" [toJExpr (unSaneDouble d)] + StaticUnboxedString str -> app "h$rawStringData" [ValExpr (to_byte_list str)] + StaticUnboxedStringOffset {} -> 0 + + to_byte_list = JList . map (Int . fromIntegral) . BS.unpack diff --git a/compiler/GHC/StgToJS/Linker/Types.hs b/compiler/GHC/StgToJS/Linker/Types.hs new file mode 100644 index 0000000000..9e1714fc00 --- /dev/null +++ b/compiler/GHC/StgToJS/Linker/Types.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- for Ident's Binary instance + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Types +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Types + ( GhcjsEnv (..) + , newGhcjsEnv + , JSLinkConfig (..) + , defaultJSLinkConfig + , generateAllJs + , LinkedObj (..) + , LinkableUnit + ) +where + +import GHC.StgToJS.Object + +import GHC.Unit.Types +import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr) + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Set (Set) + +import Control.Concurrent.MVar + +import System.IO + +import Prelude + +-------------------------------------------------------------------------------- +-- Linker Config +-------------------------------------------------------------------------------- + +data JSLinkConfig = JSLinkConfig + { lcNoJSExecutables :: Bool + , lcNoHsMain :: Bool + , lcOnlyOut :: Bool + , lcNoRts :: Bool + , lcNoStats :: Bool + } + +-- | we generate a runnable all.js only if we link a complete application, +-- no incremental linking and no skipped parts +generateAllJs :: JSLinkConfig -> Bool +generateAllJs s = not (lcOnlyOut s) && not (lcNoRts s) + +defaultJSLinkConfig :: JSLinkConfig +defaultJSLinkConfig = JSLinkConfig + { lcNoJSExecutables = False + , lcNoHsMain = False + , lcOnlyOut = False + , lcNoRts = False + , lcNoStats = False + } + +-------------------------------------------------------------------------------- +-- Linker Environment +-------------------------------------------------------------------------------- + +-- | A @LinkableUnit@ is a pair of a module and the index of the block in the +-- object file +type LinkableUnit = (Module, Int) + +-- | An object file that's either already in memory (with name) or on disk +data LinkedObj + = ObjFile FilePath -- ^ load from this file + | ObjLoaded String Object -- ^ already loaded: description and payload + +instance Outputable LinkedObj where + ppr = \case + ObjFile fp -> hsep [text "ObjFile", text fp] + ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)] + +data GhcjsEnv = GhcjsEnv + { linkerArchiveDeps :: MVar (Map (Set FilePath) + (Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) + ) + } + +-- | return a fresh @GhcjsEnv@ +newGhcjsEnv :: IO GhcjsEnv +newGhcjsEnv = GhcjsEnv <$> newMVar M.empty diff --git a/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs new file mode 100644 index 0000000000..0733b73ff6 --- /dev/null +++ b/compiler/GHC/StgToJS/Linker/Utils.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Utils +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Various utilies used in the JS Linker +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Utils + ( getOptionsFromJsFile + , JSOption(..) + , jsExeFileName + , getInstalledPackageLibDirs + , getInstalledPackageHsLibs + , commonCppDefs + ) +where + +import System.FilePath +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import Data.ByteString (ByteString) + +import GHC.Driver.Session + +import GHC.Data.ShortText +import GHC.Unit.State +import GHC.Unit.Types + +import GHC.StgToJS.Types + +import Prelude +import GHC.Platform +import Data.List (isPrefixOf) +import System.IO +import Data.Char (isSpace) +import qualified Control.Exception as Exception + +-- | Retrieve library directories provided by the @UnitId@ in @UnitState@ +getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText] +getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us + +-- | Retrieve the names of the libraries provided by @UnitId@ +getInstalledPackageHsLibs :: UnitState -> UnitId -> [ShortText] +getInstalledPackageHsLibs us = maybe mempty unitLibraries . lookupUnitId us + +-- | A constant holding the JavaScript executable Filename extension +jsexeExtension :: String +jsexeExtension = "jsexe" + +-- | CPP definitions that are inserted into every .pp file +commonCppDefs :: Bool -> ByteString +commonCppDefs profiling = case profiling of + True -> commonCppDefs_profiled + False -> commonCppDefs_vanilla + +-- | CPP definitions for normal operation and profiling. Use CAFs for +-- commonCppDefs_* so that they are shared for every CPP file +commonCppDefs_vanilla, commonCppDefs_profiled :: ByteString +commonCppDefs_vanilla = genCommonCppDefs False +commonCppDefs_profiled = genCommonCppDefs True + +-- | Generate CPP Definitions depending on a profiled or normal build. This +-- occurs at link time. +genCommonCppDefs :: Bool -> ByteString +genCommonCppDefs profiling = mconcat + [ + -- constants + let mk_int_def n v = "#define " <> Char8.pack n <> " (" <> Char8.pack (show v) <> ")\n" + -- generate "#define CLOSURE_TYPE_xyz (num)" defines + mk_closure_def t = mk_int_def (ctJsName t) (ctNum t) + closure_defs = map mk_closure_def [minBound..maxBound] + -- generate "#define THREAD_xyz_xyz (num)" defines + mk_thread_def t = mk_int_def (threadStatusJsName t) (threadStatusNum t) + thread_defs = map mk_thread_def [minBound..maxBound] + in mconcat (closure_defs ++ thread_defs) + + -- low-level heap object manipulation macros + , if profiling + then mconcat + [ "#define MK_TUP2(x1,x2) (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP3(x1,x2,x3) (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP4(x1,x2,x3,x4) (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP5(x1,x2,x3,x4,x5) (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP6(x1,x2,x3,x4,x5,x6) (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7) (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" + ] + else mconcat + [ "#define MK_TUP2(x1,x2) (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2)))\n" + , "#define MK_TUP3(x1,x2,x3) (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3)))\n" + , "#define MK_TUP4(x1,x2,x3,x4) (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4)))\n" + , "#define MK_TUP5(x1,x2,x3,x4,x5) (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5)))\n" + , "#define MK_TUP6(x1,x2,x3,x4,x5,x6) (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6)))\n" + , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7) (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7)))\n" + , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8)))\n" + , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9)))\n" + , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10)))\n" + ] + + , "#define TUP2_1(x) ((x).d1)\n" + , "#define TUP2_2(x) ((x).d2)\n" + + -- GHCJS.Prim.JSVal + , if profiling + then "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n" + else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x))\n" + , "#define JSVAL_VAL(x) ((x).d1)\n" + + -- GHCJS.Prim.JSException + , if profiling + then "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg),h$CCS_SYSTEM))\n" + else "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg)))\n" + + -- Exception dictionary for JSException + , "#define HS_JSEXCEPTION_EXCEPTION h$baseZCGHCziJSziPrimzizdfExceptionJSException\n" + + -- SomeException + , if profiling + then "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except),h$CCS_SYSTEM))\n" + else "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except)))\n" + + -- GHC.Ptr.Ptr + , if profiling + then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" + else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + + -- Data.Maybe.Maybe + , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" + , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" + , "#define IS_JUST(cl) ((cl).f === h$baseZCGHCziMaybeziJust_con_e)\n" + , "#define JUST_VAL(jj) ((jj).d1)\n" + -- "#define HS_NOTHING h$nothing\n" + , if profiling + then "#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val), h$CCS_SYSTEM))\n" + else "#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val)))\n" + + -- Data.List + , "#define HS_NIL h$ghczmprimZCGHCziTypesziZMZN\n" + , "#define HS_NIL_CON h$ghczmprimZCGHCziTypesziZMZN_con_e\n" + , "#define IS_CONS(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZC_con_e)\n" + , "#define IS_NIL(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZMZN_con_e)\n" + , "#define CONS_HEAD(cl) ((cl).d1)\n" + , "#define CONS_TAIL(cl) ((cl).d2)\n" + , if profiling + then mconcat + [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n" + , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), (cc)))\n" + ] + else mconcat + [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n" + , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n" + ] + + -- Data.Text + , "#define DATA_TEXT_ARRAY(x) ((x).d1)\n" + , "#define DATA_TEXT_OFFSET(x) ((x).d2.d1)\n" + , "#define DATA_TEXT_LENGTH(x) ((x).d2.d2)\n" + + -- Data.Text.Lazy + , "#define LAZY_TEXT_IS_CHUNK(x) ((x).f.a === 2)\n" + , "#define LAZY_TEXT_IS_NIL(x) ((x).f.a === 1)\n" + , "#define LAZY_TEXT_CHUNK_HEAD(x) ((x))\n" + , "#define LAZY_TEXT_CHUNK_TAIL(x) ((x).d2.d3)\n" + + -- black holes + -- can we skip the indirection for black holes? + , "#define IS_BLACKHOLE(x) (typeof (x) === 'object' && (x) && (x).f && (x).f.t === CLOSURE_TYPE_BLACKHOLE)\n" + , "#define BLACKHOLE_TID(bh) ((bh).d1)\n" + , "#define SET_BLACKHOLE_TID(bh,tid) ((bh).d1 = (tid))\n" + , "#define BLACKHOLE_QUEUE(bh) ((bh).d2)\n" + , "#define SET_BLACKHOLE_QUEUE(bh,val) ((bh).d2 = (val))\n" + + -- resumable thunks + , "#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n" + + -- general deconstruction + , "#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n" + , "#define CONSTR_TAG(x) ((x).f.a)\n" + + -- retrieve a numeric value that's possibly stored as an indirection + , "#define IS_WRAPPED_NUMBER(val) ((typeof(val)==='object')&&(val).f === h$unbox_e)\n" + , "#define UNWRAP_NUMBER(val) ((typeof(val) === 'number')?(val):(val).d1)\n" + + -- generic lazy values + , if profiling + then mconcat + [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun), h$CCS_SYSTEM))\n" + , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun), (cc)))\n" + ] + else mconcat + [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun)))\n" + , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun)))\n" + ] + + -- generic data constructors and selectors + , if profiling + then mconcat + [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_DATA2_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_AP1(fun,val) (h$c2(h$ap1_e, (fun), (val), h$CCS_SYSTEM))\n" + , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e, (fun), (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3), h$CCS_SYSTEM))\n" + ] + else mconcat + [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val)))\n" + , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2)))\n" + , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val)))\n" + , "#define MK_DATA2_2(val1,val2) (h$c2(h$data2_e, (val1), (val2)))\n" + , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val)))\n" + , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val)))\n" + , "#define MK_AP1(fun,val) (h$c2(h$ap1_e,(fun),(val)))\n" + , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e,(fun),(val1),(val2)))\n" + , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3)))\n" + ] + + -- unboxed tuple returns + -- , "#define RETURN_UBX_TUP1(x) return x;\n" + , "#define RETURN_UBX_TUP2(x1,x2) { h$ret1 = (x2); return (x1); }\n" + , "#define RETURN_UBX_TUP3(x1,x2,x3) { h$ret1 = (x2); h$ret2 = (x3); return (x1); }\n" + , "#define RETURN_UBX_TUP4(x1,x2,x3,x4) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); return (x1); }\n" + , "#define RETURN_UBX_TUP5(x1,x2,x3,x4,x5) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); return (x1); }\n" + , "#define RETURN_UBX_TUP6(x1,x2,x3,x4,x5,x6) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); return (x1); }\n" + , "#define RETURN_UBX_TUP7(x1,x2,x3,x4,x5,x6,x7) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); return (x1); }\n" + , "#define RETURN_UBX_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); return (x1); }\n" + , "#define RETURN_UBX_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); return (x1); }\n" + , "#define RETURN_UBX_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); h$ret9 = (x10); return (x1); }\n" + + , "#define CALL_UBX_TUP2(r1,r2,c) { (r1) = (c); (r2) = h$ret1; }\n" + , "#define CALL_UBX_TUP3(r1,r2,r3,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; }\n" + , "#define CALL_UBX_TUP4(r1,r2,r3,r4,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; }\n" + , "#define CALL_UBX_TUP5(r1,r2,r3,r4,r5,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; }\n" + , "#define CALL_UBX_TUP6(r1,r2,r3,r4,r5,r6,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; }\n" + , "#define CALL_UBX_TUP7(r1,r2,r3,r4,r5,r6,r7,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; }\n" + , "#define CALL_UBX_TUP8(r1,r2,r3,r4,r5,r6,r7,r8,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; }\n" + , "#define CALL_UBX_TUP9(r1,r2,r3,r4,r5,r6,r7,r8,r9,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; }\n" + , "#define CALL_UBX_TUP10(r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; (r10) = h$ret9; }\n" + ] + +-- | Construct the Filename for the "binary" of Haskell code compiled to +-- JavaScript. +jsExeFileName :: DynFlags -> FilePath +jsExeFileName dflags + | Just s <- outputFile_ dflags = + -- unmunge the extension + let s' = dropPrefix "js_" (drop 1 $ takeExtension s) + in if Prelude.null s' + then dropExtension s <.> jsexeExtension + else dropExtension s <.> s' + | otherwise = + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.jsexe" + else "a.jsexe" + where + dropPrefix prefix xs + | prefix `isPrefixOf` xs = drop (length prefix) xs + | otherwise = xs + + +-- | Parse option pragma in JS file +getOptionsFromJsFile :: FilePath -- ^ Input file + -> IO [JSOption] -- ^ Parsed options, if any. +getOptionsFromJsFile filename + = Exception.bracket + (openBinaryFile filename ReadMode) + hClose + getJsOptions + +data JSOption = CPP deriving (Eq, Ord) + +getJsOptions :: Handle -> IO [JSOption] +getJsOptions handle = do + hSetEncoding handle utf8 + prefix' <- B.hGet handle prefixLen + if prefix == prefix' + then parseJsOptions <$> hGetLine handle + else pure [] + where + prefix :: B.ByteString + prefix = "//#OPTIONS:" + prefixLen = B.length prefix + +parseJsOptions :: String -> [JSOption] +parseJsOptions xs = go xs + where + trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + go [] = [] + go xs = let (tok, rest) = break (== ',') xs + tok' = trim tok + rest' = drop 1 rest + in if | tok' == "CPP" -> CPP : go rest' + | otherwise -> go rest' diff --git a/compiler/GHC/StgToJS/Literal.hs b/compiler/GHC/StgToJS/Literal.hs new file mode 100644 index 0000000000..13549cd324 --- /dev/null +++ b/compiler/GHC/StgToJS/Literal.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Literal + ( genLit + , genStaticLit + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Ids +import GHC.StgToJS.Symbols + +import GHC.Data.FastString +import GHC.Types.Literal +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Float + +import Data.Bits as Bits +import Data.Char (ord) + +-- | Generate JS expressions for a Literal +-- +-- Literals represented with 2 values: +-- * Addr# (Null and Strings): array and offset +-- * 64-bit values: high 32-bit, low 32-bit +-- * labels: call to h$mkFunctionPtr and 0, or function name and 0 +genLit :: HasDebugCallStack => Literal -> G [JExpr] +genLit = \case + LitChar c -> return [ toJExpr (ord c) ] + LitString str -> + freshIdent >>= \strLit@(TxtI strLitT) -> + freshIdent >>= \strOff@(TxtI strOffT) -> do + emitStatic strLitT (StaticUnboxed (StaticUnboxedString str)) Nothing + emitStatic strOffT (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing + return [ ValExpr (JVar strLit), ValExpr (JVar strOff) ] + LitNullAddr -> return [ null_, ValExpr (JInt 0) ] + LitNumber nt v -> case nt of + LitNumInt -> return [ toJExpr v ] + LitNumInt8 -> return [ toJExpr v ] + LitNumInt16 -> return [ toJExpr v ] + LitNumInt32 -> return [ toJExpr v ] + LitNumInt64 -> return [ toJExpr (Bits.shiftR v 32), toU32Expr v ] + LitNumWord -> return [ toU32Expr v ] + LitNumWord8 -> return [ toU32Expr v ] + LitNumWord16 -> return [ toU32Expr v ] + LitNumWord32 -> return [ toU32Expr v ] + LitNumWord64 -> return [ toU32Expr (Bits.shiftR v 32), toU32Expr v ] + LitNumBigNat -> panic "genLit: unexpected BigNat that should have been removed in CorePrep" + LitFloat r -> return [ toJExpr (r2f r) ] + LitDouble r -> return [ toJExpr (r2d r) ] + LitLabel name _size fod + | fod == IsFunction -> return [ ApplExpr (var "h$mkFunctionPtr") + [var (mkRawSymbol True name)] + , ValExpr (JInt 0) + ] + | otherwise -> return [ toJExpr (TxtI (mkRawSymbol True name)) + , ValExpr (JInt 0) + ] + LitRubbish {} -> return [ null_ ] + +-- | generate a literal for the static init tables +genStaticLit :: Literal -> G [StaticLit] +genStaticLit = \case + LitChar c -> return [ IntLit (fromIntegral $ ord c) ] + LitString str + | True -> return [ StringLit (mkFastStringByteString str), IntLit 0] + -- \| invalid UTF8 -> return [ BinLit str, IntLit 0] + LitNullAddr -> return [ NullLit, IntLit 0 ] + LitNumber nt v -> case nt of + LitNumInt -> return [ IntLit v ] + LitNumInt8 -> return [ IntLit v ] + LitNumInt16 -> return [ IntLit v ] + LitNumInt32 -> return [ IntLit v ] + LitNumInt64 -> return [ IntLit (v `Bits.shiftR` 32), toU32Lit v ] + LitNumWord -> return [ toU32Lit v ] + LitNumWord8 -> return [ toU32Lit v ] + LitNumWord16 -> return [ toU32Lit v ] + LitNumWord32 -> return [ toU32Lit v ] + LitNumWord64 -> return [ toU32Lit (v `Bits.shiftR` 32), toU32Lit v ] + LitNumBigNat -> panic "genStaticLit: unexpected BigNat that should have been removed in CorePrep" + LitFloat r -> return [ DoubleLit . SaneDouble . r2f $ r ] + LitDouble r -> return [ DoubleLit . SaneDouble . r2d $ r ] + LitLabel name _size fod -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name) + , IntLit 0 ] + l -> pprPanic "genStaticLit" (ppr l) + +-- make an unsigned 32 bit number from this unsigned one, lower 32 bits +toU32Expr :: Integer -> JExpr +toU32Expr i = Int (i Bits..&. 0xFFFFFFFF) .>>>. 0 + +-- make an unsigned 32 bit number from this unsigned one, lower 32 bits +toU32Lit :: Integer -> StaticLit +toU32Lit i = IntLit (i Bits..&. 0xFFFFFFFF) + +r2d :: Rational -> Double +r2d = realToFrac + +r2f :: Rational -> Double +r2f = float2Double . realToFrac diff --git a/compiler/GHC/StgToJS/Monad.hs b/compiler/GHC/StgToJS/Monad.hs new file mode 100644 index 0000000000..b8deb36a63 --- /dev/null +++ b/compiler/GHC/StgToJS/Monad.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | JS codegen state monad +module GHC.StgToJS.Monad + ( runG + , emitGlobal + , addDependency + , emitToplevel + , emitStatic + , emitClosureInfo + , emitForeign + , assertRtsStat + , getSettings + , globalOccs + , setGlobalIdCache + , getGlobalIdCache + , GlobalOcc(..) + -- * Group + , modifyGroup + , resetGroup + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Transform + +import GHC.StgToJS.Types + +import GHC.Unit.Module +import GHC.Stg.Syntax + +import GHC.Types.SrcLoc +import GHC.Types.Id +import GHC.Types.Unique.FM +import GHC.Types.ForeignCall + +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.List as L + +runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a +runG config m unfloat action = State.evalStateT action =<< initState config m unfloat + +initState :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> IO GenState +initState config m unfloat = do + id_gen <- newFastMutInt 1 + pure $ GenState + { gsSettings = config + , gsModule = m + , gsId = id_gen + , gsIdents = emptyIdCache + , gsUnfloated = unfloat + , gsGroup = defaultGenGroupState + , gsGlobal = [] + } + + +modifyGroup :: (GenGroupState -> GenGroupState) -> G () +modifyGroup f = State.modify mod_state + where + mod_state s = s { gsGroup = f (gsGroup s) } + +-- | emit a global (for the current module) toplevel statement +emitGlobal :: JStat -> G () +emitGlobal stat = State.modify (\s -> s { gsGlobal = stat : gsGlobal s }) + +-- | add a dependency on a particular symbol to the current group +addDependency :: OtherSymb -> G () +addDependency symbol = modifyGroup mod_group + where + mod_group g = g { ggsExtraDeps = S.insert symbol (ggsExtraDeps g) } + +-- | emit a top-level statement for the current binding group +emitToplevel :: JStat -> G () +emitToplevel s = modifyGroup mod_group + where + mod_group g = g { ggsToplevelStats = s : ggsToplevelStats g} + +-- | emit static data for the binding group +emitStatic :: FastString -> StaticVal -> Maybe Ident -> G () +emitStatic ident val cc = modifyGroup mod_group + where + mod_group g = g { ggsStatic = mod_static (ggsStatic g) } + mod_static s = StaticInfo ident val cc : s + +-- | add closure info in our binding group. all heap objects must have closure info +emitClosureInfo :: ClosureInfo -> G () +emitClosureInfo ci = modifyGroup mod_group + where + mod_group g = g { ggsClosureInfo = ci : ggsClosureInfo g} + +emitForeign :: Maybe RealSrcSpan + -> FastString + -> Safety + -> CCallConv + -> [FastString] + -> FastString + -> G () +emitForeign mbSpan pat safety cconv arg_tys res_ty = modifyGroup mod_group + where + mod_group g = g { ggsForeignRefs = new_ref : ggsForeignRefs g } + new_ref = ForeignJSRef spanTxt pat safety cconv arg_tys res_ty + spanTxt = case mbSpan of + -- TODO: Is there a better way to concatenate FastStrings? + Just sp -> mkFastString $ + unpackFS (srcSpanFile sp) ++ + " " ++ + show (srcSpanStartLine sp, srcSpanStartCol sp) ++ + "-" ++ + show (srcSpanEndLine sp, srcSpanEndCol sp) + Nothing -> "<unknown>" + + + + + + +-- | start with a new binding group +resetGroup :: G () +resetGroup = State.modify (\s -> s { gsGroup = defaultGenGroupState }) + +defaultGenGroupState :: GenGroupState +defaultGenGroupState = GenGroupState [] [] [] [] 0 S.empty emptyGlobalIdCache [] + +emptyGlobalIdCache :: GlobalIdCache +emptyGlobalIdCache = GlobalIdCache emptyUFM + +emptyIdCache :: IdCache +emptyIdCache = IdCache M.empty + + + +assertRtsStat :: G JStat -> G JStat +assertRtsStat stat = do + s <- State.gets gsSettings + if csAssertRts s then stat else pure mempty + +getSettings :: G StgToJSConfig +getSettings = State.gets gsSettings + +getGlobalIdCache :: G GlobalIdCache +getGlobalIdCache = State.gets (ggsGlobalIdCache . gsGroup) + +setGlobalIdCache :: GlobalIdCache -> G () +setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}}) + + +data GlobalOcc = GlobalOcc + { global_ident :: !Ident + , global_id :: !Id + , global_count :: !Word + } + +-- | Return number of occurrences of every global id used in the given JStat. +-- Sort by increasing occurrence count. +globalOccs :: JStat -> G [GlobalOcc] +globalOccs jst = do + GlobalIdCache gidc <- getGlobalIdCache + -- build a map form Ident Unique to (Ident, Id, Count) + let + cmp_cnt g1 g2 = compare (global_count g1) (global_count g2) + inc g1 g2 = g1 { global_count = global_count g1 + global_count g2 } + go gids = \case + [] -> -- return global Ids used locally sorted by increased use + L.sortBy cmp_cnt $ nonDetEltsUFM gids + (i:is) -> + -- check if the Id is global + case lookupUFM gidc i of + Nothing -> go gids is + Just (_k,gid) -> + -- add it to the list of already found global ids. Increasing + -- count by 1 + let g = GlobalOcc i gid 1 + in go (addToUFM_C inc gids i g) is + + pure $ go emptyUFM (identsS jst) diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs new file mode 100644 index 0000000000..f75d27e20b --- /dev/null +++ b/compiler/GHC/StgToJS/Object.hs @@ -0,0 +1,622 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- only for DB.Binary instances on Module +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Object +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Sylvain Henry <sylvain.henry@iohk.io> +-- Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Serialization/deserialization of binary .o files for the JavaScript backend +-- The .o files contain dependency information and generated code. +-- All strings are mapped to a central string table, which helps reduce +-- file size and gives us efficient hash consing on read +-- +-- Binary intermediate JavaScript object files: +-- serialized [Text] -> ([ClosureInfo], JStat) blocks +-- +-- file layout: +-- - magic "GHCJSOBJ" +-- - compiler version tag +-- - module name +-- - offsets of string table +-- - dependencies +-- - offset of the index +-- - unit infos +-- - index +-- - string table +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Object + ( putObject + , getObjectHeader + , getObjectBody + , getObject + , readObject + , getObjectUnits + , readObjectUnits + , readObjectDeps + , isGlobalUnit + , isJsObjectFile + , Object(..) + , IndexEntry(..) + , Deps (..), BlockDeps (..), DepsLocation (..) + , ExportedFun (..) + ) +where + +import GHC.Prelude + +import Control.Monad + +import Data.Array +import Data.Int +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.List (sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Word +import Data.Char +import Foreign.Storable +import Foreign.Marshal.Array +import System.IO + +import GHC.Settings.Constants (hiVersion) + +import GHC.JS.Syntax +import GHC.StgToJS.Types + +import GHC.Unit.Module + +import GHC.Data.FastString + +import GHC.Types.Unique.Map +import GHC.Float (castDoubleToWord64, castWord64ToDouble) + +import GHC.Utils.Binary hiding (SymbolTable) +import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep) +import GHC.Utils.Monad (mapMaybeM) + +-- | An object file +data Object = Object + { objModuleName :: !ModuleName + -- ^ name of the module + , objHandle :: !BinHandle + -- ^ BinHandle that can be used to read the ObjUnits + , objPayloadOffset :: !(Bin ObjUnit) + -- ^ Offset of the payload (units) + , objDeps :: !Deps + -- ^ Dependencies + , objIndex :: !Index + -- ^ The Index, serialed unit indices and their linkable units + } + +type BlockId = Int +type BlockIds = IntSet + +-- | dependencies for a single module +data Deps = Deps + { depsModule :: !Module + -- ^ module + , depsRequired :: !BlockIds + -- ^ blocks that always need to be linked when this object is loaded (e.g. + -- everything that contains initializer code or foreign exports) + , depsHaskellExported :: !(Map ExportedFun BlockId) + -- ^ exported Haskell functions -> block + , depsBlocks :: !(Array BlockId BlockDeps) + -- ^ info about each block + } + +instance Outputable Deps where + ppr d = vcat + [ hcat [ text "module: ", pprModule (depsModule d) ] + , hcat [ text "exports: ", ppr (M.keys (depsHaskellExported d)) ] + ] + +-- | Where are the dependencies +data DepsLocation + = ObjectFile FilePath -- ^ In an object file at path + | ArchiveFile FilePath -- ^ In a Ar file at path + | InMemory String Object -- ^ In memory + +instance Outputable DepsLocation where + ppr = \case + ObjectFile fp -> hsep [text "ObjectFile", text fp] + ArchiveFile fp -> hsep [text "ArchiveFile", text fp] + InMemory s o -> hsep [text "InMemory", text s, ppr (objModuleName o)] + +data BlockDeps = BlockDeps + { blockBlockDeps :: [Int] -- ^ dependencies on blocks in this object + , blockFunDeps :: [ExportedFun] -- ^ dependencies on exported symbols in other objects + -- , blockForeignExported :: [ExpFun] + -- , blockForeignImported :: [ForeignRef] + } + +{- | we use the convention that the first unit (0) is a module-global + unit that's always included when something from the module + is loaded. everything in a module implicitly depends on the + global block. the global unit itself can't have dependencies + -} +isGlobalUnit :: Int -> Bool +isGlobalUnit n = n == 0 + +-- | Exported Functions +data ExportedFun = ExportedFun + { funModule :: !Module -- ^ The module containing the function + , funSymbol :: !LexicalFastString -- ^ The function + } deriving (Eq, Ord) + +instance Outputable ExportedFun where + ppr (ExportedFun m f) = vcat + [ hcat [ text "module: ", pprModule m ] + , hcat [ text "symbol: ", ppr f ] + ] + +-- | Write an ObjUnit, except for the top level symbols which are stored in the +-- index +putObjUnit :: BinHandle -> ObjUnit -> IO () +putObjUnit bh (ObjUnit _syms b c d e f g) = do + put_ bh b + put_ bh c + lazyPut bh d + put_ bh e + put_ bh f + put_ bh g + +-- | Read an ObjUnit and associate it to the given symbols (that must have been +-- read from the index) +getObjUnit :: [FastString] -> BinHandle -> IO ObjUnit +getObjUnit syms bh = do + b <- get bh + c <- get bh + d <- lazyGet bh + e <- get bh + f <- get bh + g <- get bh + pure $ ObjUnit + { oiSymbols = syms + , oiClInfo = b + , oiStatic = c + , oiStat = d + , oiRaw = e + , oiFExports = f + , oiFImports = g + } + + +-- | A tag that determines the kind of payload in the .o file. See +-- @StgToJS.Linker.Arhive.magic@ for another kind of magic +magic :: String +magic = "GHCJSOBJ" + +-- | Serialized unit indexes and their exported symbols +-- (the first unit is module-global) +type Index = [IndexEntry] +data IndexEntry = IndexEntry + { idxSymbols :: ![FastString] -- ^ Symbols exported by a unit + , idxOffset :: !(Bin ObjUnit) -- ^ Offset of the unit in the object file + } + + +-------------------------------------------------------------------------------- +-- Essential oeprations on Objects +-------------------------------------------------------------------------------- + +-- | Given a handle to a Binary payload, add the module, 'mod_name', its +-- dependencies, 'deps', and its linkable units to the payload. +putObject + :: BinHandle + -> ModuleName -- ^ module + -> Deps -- ^ dependencies + -> [ObjUnit] -- ^ linkable units and their symbols + -> IO () +putObject bh mod_name deps os = do + forM_ magic (putByte bh . fromIntegral . ord) + put_ bh (show hiVersion) + + -- we store the module name as a String because we don't want to have to + -- decode the FastString table just to decode it when we're looking for an + -- object in an archive. + put_ bh (moduleNameString mod_name) + + (bh_fs, _bin_dict, put_dict) <- initFSTable bh + + forwardPut_ bh (const put_dict) $ do + put_ bh_fs deps + + -- forward put the index + forwardPut_ bh_fs (put_ bh_fs) $ do + idx <- forM os $ \o -> do + p <- tellBin bh_fs + -- write units without their symbols + putObjUnit bh_fs o + -- return symbols and offset to store in the index + pure (oiSymbols o,p) + pure idx + +-- | Test if the object file is a JS object +isJsObjectFile :: FilePath -> IO Bool +isJsObjectFile fp = do + let !n = length magic + withBinaryFile fp ReadMode $ \hdl -> do + allocaArray n $ \ptr -> do + n' <- hGetBuf hdl ptr n + if (n' /= n) + then pure False + else checkMagic (peekElemOff ptr) + +-- | Check magic +checkMagic :: (Int -> IO Word8) -> IO Bool +checkMagic get_byte = do + let go_magic !i = \case + [] -> pure True + (e:es) -> get_byte i >>= \case + c | fromIntegral (ord e) == c -> go_magic (i+1) es + | otherwise -> pure False + go_magic 0 magic + +-- | Parse object magic +getCheckMagic :: BinHandle -> IO Bool +getCheckMagic bh = checkMagic (const (getByte bh)) + +-- | Parse object header +getObjectHeader :: BinHandle -> IO (Either String ModuleName) +getObjectHeader bh = do + is_magic <- getCheckMagic bh + case is_magic of + False -> pure (Left "invalid magic header") + True -> do + is_correct_version <- ((== hiVersion) . read) <$> get bh + case is_correct_version of + False -> pure (Left "invalid header version") + True -> do + mod_name <- get bh + pure (Right (mkModuleName (mod_name))) + + +-- | Parse object body. Must be called after a sucessful getObjectHeader +getObjectBody :: BinHandle -> ModuleName -> IO Object +getObjectBody bh0 mod_name = do + -- Read the string table + dict <- forwardGet bh0 (getDictionary bh0) + let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict } + + deps <- get bh + idx <- forwardGet bh (get bh) + payload_pos <- tellBin bh + + pure $ Object + { objModuleName = mod_name + , objHandle = bh + , objPayloadOffset = payload_pos + , objDeps = deps + , objIndex = idx + } + +-- | Parse object +getObject :: BinHandle -> IO (Maybe Object) +getObject bh = do + getObjectHeader bh >>= \case + Left _err -> pure Nothing + Right mod_name -> Just <$> getObjectBody bh mod_name + +-- | Read object from file +-- +-- The object is still in memory after this (see objHandle). +readObject :: FilePath -> IO (Maybe Object) +readObject file = do + bh <- readBinMem file + getObject bh + +-- | Reads only the part necessary to get the dependencies +readObjectDeps :: FilePath -> IO (Maybe Deps) +readObjectDeps file = do + bh <- readBinMem file + getObject bh >>= \case + Just obj -> pure $! Just $! objDeps obj + Nothing -> pure Nothing + +-- | Get units in the object file, using the given filtering function +getObjectUnits :: Object -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit] +getObjectUnits obj pred = mapMaybeM read_entry (zip (objIndex obj) [0..]) + where + bh = objHandle obj + read_entry (e@(IndexEntry syms offset),i) + | pred i e = do + seekBin bh offset + Just <$> getObjUnit syms bh + | otherwise = pure Nothing + +-- | Read units in the object file, using the given filtering function +readObjectUnits :: FilePath -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit] +readObjectUnits file pred = do + readObject file >>= \case + Nothing -> pure [] + Just obj -> getObjectUnits obj pred + + +-------------------------------------------------------------------------------- +-- Helper functions +-------------------------------------------------------------------------------- + +putEnum :: Enum a => BinHandle -> a -> IO () +putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n) + | otherwise = put_ bh n + where n = fromIntegral $ fromEnum x :: Word16 + +getEnum :: Enum a => BinHandle -> IO a +getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16) + +-- | Helper to convert Int to Int32 +toI32 :: Int -> Int32 +toI32 = fromIntegral + +-- | Helper to convert Int32 to Int +fromI32 :: Int32 -> Int +fromI32 = fromIntegral + + +-------------------------------------------------------------------------------- +-- Binary Instances +-------------------------------------------------------------------------------- + +instance Binary IndexEntry where + put_ bh (IndexEntry a b) = put_ bh a >> put_ bh b + get bh = IndexEntry <$> get bh <*> get bh + +instance Binary Deps where + put_ bh (Deps m r e b) = do + put_ bh m + put_ bh (map toI32 $ IS.toList r) + put_ bh (map (\(x,y) -> (x, toI32 y)) $ M.toList e) + put_ bh (elems b) + get bh = Deps <$> get bh + <*> (IS.fromList . map fromI32 <$> get bh) + <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get bh) + <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get bh) + +instance Binary BlockDeps where + put_ bh (BlockDeps bbd bfd) = put_ bh bbd >> put_ bh bfd + get bh = BlockDeps <$> get bh <*> get bh + +instance Binary ForeignJSRef where + put_ bh (ForeignJSRef span pat safety cconv arg_tys res_ty) = + put_ bh span >> put_ bh pat >> putEnum bh safety >> putEnum bh cconv >> put_ bh arg_tys >> put_ bh res_ty + get bh = ForeignJSRef <$> get bh <*> get bh <*> getEnum bh <*> getEnum bh <*> get bh <*> get bh + +instance Binary ExpFun where + put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res + get bh = ExpFun <$> get bh <*> get bh <*> get bh + +instance Binary JStat where + put_ bh (DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e + put_ bh (ReturnStat e) = putByte bh 2 >> put_ bh e + put_ bh (IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 + put_ bh (WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s + put_ bh (ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (BlockStat xs) = putByte bh 8 >> put_ bh xs + put_ bh (ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es + put_ bh (UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e + put_ bh (AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 + put_ _ (UnsatBlock {}) = error "put_ bh JStat: UnsatBlock" + put_ bh (LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s + put_ bh (BreakStat ml) = putByte bh 13 >> put_ bh ml + put_ bh (ContinueStat ml) = putByte bh 14 >> put_ bh ml + get bh = getByte bh >>= \case + 1 -> DeclStat <$> get bh <*> get bh + 2 -> ReturnStat <$> get bh + 3 -> IfStat <$> get bh <*> get bh <*> get bh + 4 -> WhileStat <$> get bh <*> get bh <*> get bh + 5 -> ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> SwitchStat <$> get bh <*> get bh <*> get bh + 7 -> TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 8 -> BlockStat <$> get bh + 9 -> ApplStat <$> get bh <*> get bh + 10 -> UOpStat <$> get bh <*> get bh + 11 -> AssignStat <$> get bh <*> get bh + 12 -> LabelStat <$> get bh <*> get bh + 13 -> BreakStat <$> get bh + 14 -> ContinueStat <$> get bh + n -> error ("Binary get bh JStat: invalid tag: " ++ show n) + +instance Binary JExpr where + put_ bh (ValExpr v) = putByte bh 1 >> put_ bh v + put_ bh (SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i + put_ bh (IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2 + put_ bh (InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 + put_ bh (UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e + put_ bh (IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 + put_ bh (ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es + put_ _ (UnsatExpr {}) = error "put_ bh JExpr: UnsatExpr" + get bh = getByte bh >>= \case + 1 -> ValExpr <$> get bh + 2 -> SelExpr <$> get bh <*> get bh + 3 -> IdxExpr <$> get bh <*> get bh + 4 -> InfixExpr <$> get bh <*> get bh <*> get bh + 5 -> UOpExpr <$> get bh <*> get bh + 6 -> IfExpr <$> get bh <*> get bh <*> get bh + 7 -> ApplExpr <$> get bh <*> get bh + n -> error ("Binary get bh JExpr: invalid tag: " ++ show n) + +instance Binary JVal where + put_ bh (JVar i) = putByte bh 1 >> put_ bh i + put_ bh (JList es) = putByte bh 2 >> put_ bh es + put_ bh (JDouble d) = putByte bh 3 >> put_ bh d + put_ bh (JInt i) = putByte bh 4 >> put_ bh i + put_ bh (JStr xs) = putByte bh 5 >> put_ bh xs + put_ bh (JRegEx xs) = putByte bh 6 >> put_ bh xs + put_ bh (JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m) + put_ bh (JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s + put_ _ (UnsatVal {}) = error "put_ bh JVal: UnsatVal" + get bh = getByte bh >>= \case + 1 -> JVar <$> get bh + 2 -> JList <$> get bh + 3 -> JDouble <$> get bh + 4 -> JInt <$> get bh + 5 -> JStr <$> get bh + 6 -> JRegEx <$> get bh + 7 -> JHash . listToUniqMap <$> get bh + 8 -> JFunc <$> get bh <*> get bh + n -> error ("Binary get bh JVal: invalid tag: " ++ show n) + +instance Binary Ident where + put_ bh (TxtI xs) = put_ bh xs + get bh = TxtI <$> get bh + +-- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this +instance Binary SaneDouble where + put_ bh (SaneDouble d) + | isNaN d = putByte bh 1 + | isInfinite d && d > 0 = putByte bh 2 + | isInfinite d && d < 0 = putByte bh 3 + | isNegativeZero d = putByte bh 4 + | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d) + get bh = getByte bh >>= \case + 1 -> pure $ SaneDouble (0 / 0) + 2 -> pure $ SaneDouble (1 / 0) + 3 -> pure $ SaneDouble ((-1) / 0) + 4 -> pure $ SaneDouble (-0) + 5 -> SaneDouble . castWord64ToDouble <$> get bh + n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n) + +instance Binary ClosureInfo where + put_ bh (ClosureInfo v regs name layo typ static) = do + put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static + get bh = ClosureInfo <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh + +instance Binary JSFFIType where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary VarType where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary CIRegs where + put_ bh CIRegsUnknown = putByte bh 1 + put_ bh (CIRegs skip types) = putByte bh 2 >> put_ bh skip >> put_ bh types + get bh = getByte bh >>= \case + 1 -> pure CIRegsUnknown + 2 -> CIRegs <$> get bh <*> get bh + n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n) + +instance Binary JOp where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary JUOp where + put_ bh = putEnum bh + get bh = getEnum bh + +-- 16 bit sizes should be enough... +instance Binary CILayout where + put_ bh CILayoutVariable = putByte bh 1 + put_ bh (CILayoutUnknown size) = putByte bh 2 >> put_ bh size + put_ bh (CILayoutFixed size types) = putByte bh 3 >> put_ bh size >> put_ bh types + get bh = getByte bh >>= \case + 1 -> pure CILayoutVariable + 2 -> CILayoutUnknown <$> get bh + 3 -> CILayoutFixed <$> get bh <*> get bh + n -> error ("Binary get bh CILayout: invalid tag: " ++ show n) + +instance Binary CIStatic where + put_ bh (CIStaticRefs refs) = putByte bh 1 >> put_ bh refs + get bh = getByte bh >>= \case + 1 -> CIStaticRefs <$> get bh + n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n) + +instance Binary CIType where + put_ bh (CIFun arity regs) = putByte bh 1 >> put_ bh arity >> put_ bh regs + put_ bh CIThunk = putByte bh 2 + put_ bh (CICon conTag) = putByte bh 3 >> put_ bh conTag + put_ bh CIPap = putByte bh 4 + put_ bh CIBlackhole = putByte bh 5 + put_ bh CIStackFrame = putByte bh 6 + get bh = getByte bh >>= \case + 1 -> CIFun <$> get bh <*> get bh + 2 -> pure CIThunk + 3 -> CICon <$> get bh + 4 -> pure CIPap + 5 -> pure CIBlackhole + 6 -> pure CIStackFrame + n -> error ("Binary get bh CIType: invalid tag: " ++ show n) + +instance Binary ExportedFun where + put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb + get bh = ExportedFun <$> get bh <*> get bh + +instance Binary StaticInfo where + put_ bh (StaticInfo ident val cc) = put_ bh ident >> put_ bh val >> put_ bh cc + get bh = StaticInfo <$> get bh <*> get bh <*> get bh + +instance Binary StaticVal where + put_ bh (StaticFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args + put_ bh (StaticThunk t) = putByte bh 2 >> put_ bh t + put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u + put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args + put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t + get bh = getByte bh >>= \case + 1 -> StaticFun <$> get bh <*> get bh + 2 -> StaticThunk <$> get bh + 3 -> StaticUnboxed <$> get bh + 4 -> StaticData <$> get bh <*> get bh + 5 -> StaticList <$> get bh <*> get bh + n -> error ("Binary get bh StaticVal: invalid tag " ++ show n) + +instance Binary StaticUnboxed where + put_ bh (StaticUnboxedBool b) = putByte bh 1 >> put_ bh b + put_ bh (StaticUnboxedInt i) = putByte bh 2 >> put_ bh i + put_ bh (StaticUnboxedDouble d) = putByte bh 3 >> put_ bh d + put_ bh (StaticUnboxedString str) = putByte bh 4 >> put_ bh str + put_ bh (StaticUnboxedStringOffset str) = putByte bh 5 >> put_ bh str + get bh = getByte bh >>= \case + 1 -> StaticUnboxedBool <$> get bh + 2 -> StaticUnboxedInt <$> get bh + 3 -> StaticUnboxedDouble <$> get bh + 4 -> StaticUnboxedString <$> get bh + 5 -> StaticUnboxedStringOffset <$> get bh + n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n) + +instance Binary StaticArg where + put_ bh (StaticObjArg i) = putByte bh 1 >> put_ bh i + put_ bh (StaticLitArg p) = putByte bh 2 >> put_ bh p + put_ bh (StaticConArg c args) = putByte bh 3 >> put_ bh c >> put_ bh args + get bh = getByte bh >>= \case + 1 -> StaticObjArg <$> get bh + 2 -> StaticLitArg <$> get bh + 3 -> StaticConArg <$> get bh <*> get bh + n -> error ("Binary get bh StaticArg: invalid tag " ++ show n) + +instance Binary StaticLit where + put_ bh (BoolLit b) = putByte bh 1 >> put_ bh b + put_ bh (IntLit i) = putByte bh 2 >> put_ bh i + put_ bh NullLit = putByte bh 3 + put_ bh (DoubleLit d) = putByte bh 4 >> put_ bh d + put_ bh (StringLit t) = putByte bh 5 >> put_ bh t + put_ bh (BinLit b) = putByte bh 6 >> put_ bh b + put_ bh (LabelLit b t) = putByte bh 7 >> put_ bh b >> put_ bh t + get bh = getByte bh >>= \case + 1 -> BoolLit <$> get bh + 2 -> IntLit <$> get bh + 3 -> pure NullLit + 4 -> DoubleLit <$> get bh + 5 -> StringLit <$> get bh + 6 -> BinLit <$> get bh + 7 -> LabelLit <$> get bh <*> get bh + n -> error ("Binary get bh StaticLit: invalid tag " ++ show n) diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs new file mode 100644 index 0000000000..6085b110cf --- /dev/null +++ b/compiler/GHC/StgToJS/Prim.hs @@ -0,0 +1,1509 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} + +-- disable this warning because of all the lambdas matching on primops' +-- arguments. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.StgToJS.Prim + ( genPrim + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax hiding (JUOp (..)) +import GHC.JS.Make + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs + +import GHC.Core.Type + +import GHC.Builtin.PrimOps +import GHC.Tc.Utils.TcType (isBoolTy) +import GHC.Utils.Encoding (zEncodeString) + +import GHC.Data.FastString +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) +import Data.Maybe + + +genPrim :: Bool -- ^ Profiling (cost-centres) enabled + -> Bool -- ^ Array bounds-checking enabled + -> Type + -> PrimOp -- ^ the primitive operation + -> [JExpr] -- ^ where to store the result + -> [JExpr] -- ^ arguments + -> PrimRes +genPrim prof bound ty op = case op of + CharGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + CharGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + CharEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + CharNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + CharLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + CharLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + OrdOp -> \[r] [x] -> PrimInline $ r |= x + + Int8ToWord8Op -> \[r] [x] -> PrimInline $ r |= mask8 x + Word8ToInt8Op -> \[r] [x] -> PrimInline $ r |= signExtend8 x + Int16ToWord16Op -> \[r] [x] -> PrimInline $ r |= mask16 x + Word16ToInt16Op -> \[r] [x] -> PrimInline $ r |= signExtend16 x + Int32ToWord32Op -> \[r] [x] -> PrimInline $ r |= x .>>>. zero_ + Word32ToInt32Op -> \[r] [x] -> PrimInline $ r |= toI32 x + +------------------------------ Int ---------------------------------------------- + + IntAddOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Add x y) + IntSubOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Sub x y) + IntMulOp -> \[r] [x,y] -> PrimInline $ r |= app "h$mulInt32" [x, y] + IntMul2Op -> \[c,hr,lr] [x,y] -> PrimInline $ appT [c,hr,lr] "h$hs_timesInt2" [x, y] + IntMulMayOfloOp -> \[r] [x,y] -> PrimInline $ jVar \tmp -> mconcat + [ tmp |= Mul x y + , r |= if01 (tmp .===. toI32 tmp) + ] + IntQuotOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Div x y) + IntRemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y + IntQuotRemOp -> \[q,r] [x,y] -> PrimInline $ mconcat + [ q |= toI32 (Div x y) + , r |= x `Sub` (Mul y q) + ] + IntAndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y + IntOrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y + IntXorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y + IntNotOp -> \[r] [x] -> PrimInline $ r |= BNot x + + IntNegOp -> \[r] [x] -> PrimInline $ r |= toI32 (Negate x) +-- add with carry: overflow == 0 iff no overflow + IntAddCOp -> \[r,overf] [x,y] -> + PrimInline $ jVar \rt -> mconcat + [ rt |= Add x y + , r |= toI32 rt + , overf |= if10 (r .!=. rt) + ] + IntSubCOp -> \[r,overf] [x,y] -> + PrimInline $ jVar \rt -> mconcat + [ rt |= Sub x y + , r |= toI32 rt + , overf |= if10 (r .!=. rt) + ] + IntGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + IntGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + IntEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + IntNeOp -> \[r] [x,y] -> PrimInline $ r |= if10(x .!==. y) + IntLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + IntLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + ChrOp -> \[r] [x] -> PrimInline $ r |= x + IntToWordOp -> \[r] [x] -> PrimInline $ r |= x .>>>. 0 + IntToFloatOp -> \[r] [x] -> PrimInline $ r |= x + IntToDoubleOp -> \[r] [x] -> PrimInline $ r |= x + IntSllOp -> \[r] [x,y] -> PrimInline $ r |= x .<<. y + IntSraOp -> \[r] [x,y] -> PrimInline $ r |= x .>>. y + IntSrlOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (x .>>>. y) + +------------------------------ Int8 --------------------------------------------- + + Int8ToIntOp -> \[r] [x] -> PrimInline $ r |= x + IntToInt8Op -> \[r] [x] -> PrimInline $ r |= signExtend8 x + Int8NegOp -> \[r] [x] -> PrimInline $ r |= signExtend8 (Negate x) + Int8AddOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Add x y) + Int8SubOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Sub x y) + Int8MulOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Mul x y) + Int8QuotOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (quotShortInt 8 x y) + Int8RemOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (remShortInt 8 x y) + Int8QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat + [ r1 |= signExtend8 (quotShortInt 8 x y) + , r2 |= signExtend8 (remShortInt 8 x y) + ] + Int8EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + Int8GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .>=. (y .<<. (Int 24))) + Int8GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .>. (y .<<. (Int 24))) + Int8LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .<=. (y .<<. (Int 24))) + Int8LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .<. (y .<<. (Int 24))) + Int8NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + + Int8SraOp -> \[r] [x,i] -> PrimInline $ r |= x .>>. i + Int8SrlOp -> \[r] [x,i] -> PrimInline $ r |= signExtend8 (mask8 x .>>>. i) + Int8SllOp -> \[r] [x,i] -> PrimInline $ r |= signExtend8 (mask8 (x .<<. i)) + +------------------------------ Word8 -------------------------------------------- + + Word8ToWordOp -> \[r] [x] -> PrimInline $ r |= mask8 x + WordToWord8Op -> \[r] [x] -> PrimInline $ r |= mask8 x + + Word8AddOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Add x y) + Word8SubOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Sub x y) + Word8MulOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Mul x y) + Word8QuotOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Div x y) + Word8RemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y + Word8QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat + [ r1 |= toI32 (Div x y) + , r2 |= Mod x y + ] + Word8EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + Word8GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + Word8GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + Word8LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + Word8LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + Word8NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + + Word8AndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y + Word8OrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y + Word8XorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y + Word8NotOp -> \[r] [x] -> PrimInline $ r |= BXor x (Int 0xff) + + Word8SllOp -> \[r] [x,i] -> PrimInline $ r |= mask8 (x .<<. i) + Word8SrlOp -> \[r] [x,i] -> PrimInline $ r |= x .>>>. i + +------------------------------ Int16 ------------------------------------------- + + Int16ToIntOp -> \[r] [x] -> PrimInline $ r |= x + IntToInt16Op -> \[r] [x] -> PrimInline $ r |= signExtend16 x + + Int16NegOp -> \[r] [x] -> PrimInline $ r |= signExtend16 (Negate x) + Int16AddOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Add x y) + Int16SubOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Sub x y) + Int16MulOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Mul x y) + Int16QuotOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (quotShortInt 16 x y) + Int16RemOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (remShortInt 16 x y) + Int16QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat + [ r1 |= signExtend16 (quotShortInt 16 x y) + , r2 |= signExtend16 (remShortInt 16 x y) + ] + Int16EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + Int16GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .>=. (y .<<. (Int 16))) + Int16GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .>. (y .<<. (Int 16))) + Int16LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .<=. (y .<<. (Int 16))) + Int16LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .<. (y .<<. (Int 16))) + Int16NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + + Int16SraOp -> \[r] [x,i] -> PrimInline $ r |= x .>>. i + Int16SrlOp -> \[r] [x,i] -> PrimInline $ r |= signExtend16 (mask16 x .>>>. i) + Int16SllOp -> \[r] [x,i] -> PrimInline $ r |= signExtend16 (x .<<. i) + +------------------------------ Word16 ------------------------------------------ + + Word16ToWordOp -> \[r] [x] -> PrimInline $ r |= x + WordToWord16Op -> \[r] [x] -> PrimInline $ r |= mask16 x + + Word16AddOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Add x y) + Word16SubOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Sub x y) + Word16MulOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Mul x y) + Word16QuotOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Div x y) + Word16RemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y + Word16QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat + [ r1 |= toI32 (Div x y) + , r2 |= Mod x y + ] + Word16EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + Word16GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + Word16GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + Word16LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + Word16LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + Word16NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + + Word16AndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y + Word16OrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y + Word16XorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y + Word16NotOp -> \[r] [x] -> PrimInline $ r |= BXor x (Int 0xffff) + + Word16SllOp -> \[r] [x,i] -> PrimInline $ r |= mask16 (x .<<. i) + Word16SrlOp -> \[r] [x,i] -> PrimInline $ r |= x .>>>. i + +------------------------------ Int32 -------------------------------------------- + + Int32ToIntOp -> \[r] [x] -> PrimInline $ r |= x + IntToInt32Op -> \[r] [x] -> PrimInline $ r |= x + + Int32NegOp -> \rs xs -> genPrim prof bound ty IntNegOp rs xs + Int32AddOp -> \rs xs -> genPrim prof bound ty IntAddOp rs xs + Int32SubOp -> \rs xs -> genPrim prof bound ty IntSubOp rs xs + Int32MulOp -> \rs xs -> genPrim prof bound ty IntMulOp rs xs + Int32QuotOp -> \rs xs -> genPrim prof bound ty IntQuotOp rs xs + Int32RemOp -> \rs xs -> genPrim prof bound ty IntRemOp rs xs + Int32QuotRemOp -> \rs xs -> genPrim prof bound ty IntQuotRemOp rs xs + + Int32EqOp -> \rs xs -> genPrim prof bound ty IntEqOp rs xs + Int32GeOp -> \rs xs -> genPrim prof bound ty IntGeOp rs xs + Int32GtOp -> \rs xs -> genPrim prof bound ty IntGtOp rs xs + Int32LeOp -> \rs xs -> genPrim prof bound ty IntLeOp rs xs + Int32LtOp -> \rs xs -> genPrim prof bound ty IntLtOp rs xs + Int32NeOp -> \rs xs -> genPrim prof bound ty IntNeOp rs xs + + Int32SraOp -> \rs xs -> genPrim prof bound ty IntSraOp rs xs + Int32SrlOp -> \rs xs -> genPrim prof bound ty IntSrlOp rs xs + Int32SllOp -> \rs xs -> genPrim prof bound ty IntSllOp rs xs + +------------------------------ Word32 ------------------------------------------- + + Word32ToWordOp -> \[r] [x] -> PrimInline $ r |= x + WordToWord32Op -> \[r] [x] -> PrimInline $ r |= x + + Word32AddOp -> \rs xs -> genPrim prof bound ty WordAddOp rs xs + Word32SubOp -> \rs xs -> genPrim prof bound ty WordSubOp rs xs + Word32MulOp -> \rs xs -> genPrim prof bound ty WordMulOp rs xs + Word32QuotOp -> \rs xs -> genPrim prof bound ty WordQuotOp rs xs + Word32RemOp -> \rs xs -> genPrim prof bound ty WordRemOp rs xs + Word32QuotRemOp -> \rs xs -> genPrim prof bound ty WordQuotRemOp rs xs + + Word32EqOp -> \rs xs -> genPrim prof bound ty WordEqOp rs xs + Word32GeOp -> \rs xs -> genPrim prof bound ty WordGeOp rs xs + Word32GtOp -> \rs xs -> genPrim prof bound ty WordGtOp rs xs + Word32LeOp -> \rs xs -> genPrim prof bound ty WordLeOp rs xs + Word32LtOp -> \rs xs -> genPrim prof bound ty WordLtOp rs xs + Word32NeOp -> \rs xs -> genPrim prof bound ty WordNeOp rs xs + + Word32AndOp -> \rs xs -> genPrim prof bound ty WordAndOp rs xs + Word32OrOp -> \rs xs -> genPrim prof bound ty WordOrOp rs xs + Word32XorOp -> \rs xs -> genPrim prof bound ty WordXorOp rs xs + Word32NotOp -> \rs xs -> genPrim prof bound ty WordNotOp rs xs + + Word32SllOp -> \rs xs -> genPrim prof bound ty WordSllOp rs xs + Word32SrlOp -> \rs xs -> genPrim prof bound ty WordSrlOp rs xs + +------------------------------ Int64 -------------------------------------------- + + Int64ToIntOp -> \[r] [_h,l] -> PrimInline $ r |= toI32 l + + Int64NegOp -> \[r_h,r_l] [h,l] -> + PrimInline $ mconcat + [ r_l |= toU32 (BNot l + 1) + , r_h |= toI32 (BNot h + Not r_l) + ] + + Int64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusInt64" [h0,l0,h1,l1] + Int64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusInt64" [h0,l0,h1,l1] + Int64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesInt64" [h0,l0,h1,l1] + Int64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotInt64" [h0,l0,h1,l1] + Int64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remInt64" [h0,l0,h1,l1] + + Int64SllOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLLInt64" [h,l,n] + Int64SraOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRAInt64" [h,l,n] + Int64SrlOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRLInt64" [h,l,n] + + Int64ToWord64Op -> \[r1,r2] [x1,x2] -> + PrimInline $ mconcat + [ r1 |= toU32 x1 + , r2 |= x2 + ] + IntToInt64Op -> \[r1,r2] [x] -> + PrimInline $ mconcat + [ r1 |= if_ (x .<. 0) (-1) 0 -- sign-extension + , r2 |= toU32 x + ] + + Int64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) + Int64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) + Int64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) + Int64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) + Int64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) + Int64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) + +------------------------------ Word64 ------------------------------------------- + + Word64ToWordOp -> \[r] [_x1,x2] -> PrimInline $ r |= x2 + + WordToWord64Op -> \[rh,rl] [x] -> + PrimInline $ mconcat + [ rh |= 0 + , rl |= x + ] + + Word64ToInt64Op -> \[r1,r2] [x1,x2] -> + PrimInline $ mconcat + [ r1 |= toI32 x1 + , r2 |= x2 + ] + + Word64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) + Word64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) + Word64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) + Word64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) + Word64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) + Word64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) + + Word64SllOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLWord64" [h,l,n] + Word64SrlOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRWord64" [h,l,n] + + Word64OrOp -> \[hr,hl] [h0, l0, h1, l1] -> + PrimInline $ mconcat + [ hr |= toU32 (BOr h0 h1) + , hl |= toU32 (BOr l0 l1) + ] + + Word64AndOp -> \[hr,hl] [h0, l0, h1, l1] -> + PrimInline $ mconcat + [ hr |= toU32 (BAnd h0 h1) + , hl |= toU32 (BAnd l0 l1) + ] + + Word64XorOp -> \[hr,hl] [h0, l0, h1, l1] -> + PrimInline $ mconcat + [ hr |= toU32 (BXor h0 h1) + , hl |= toU32 (BXor l0 l1) + ] + + Word64NotOp -> \[hr,hl] [h, l] -> + PrimInline $ mconcat + [ hr |= toU32 (BNot h) + , hl |= toU32 (BNot l) + ] + + Word64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusWord64" [h0,l0,h1,l1] + Word64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusWord64" [h0,l0,h1,l1] + Word64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesWord64" [h0,l0,h1,l1] + Word64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotWord64" [h0,l0,h1,l1] + Word64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remWord64" [h0,l0,h1,l1] + +------------------------------ Word --------------------------------------------- + + WordAddOp -> \[r] [x,y] -> PrimInline $ r |= (x `Add` y) .>>>. zero_ + WordAddCOp -> \[r,c] [x,y] -> PrimInline $ + jVar \t -> mconcat + [ t |= x `Add` y + , r |= toU32 t + , c |= if10 (t .!==. r) + ] + WordSubCOp -> \[r,c] [x,y] -> + PrimInline $ mconcat + [ r |= toU32 (Sub x y) + , c |= if10 (y .>. x) + ] + WordAdd2Op -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$wordAdd2" [x,y] + WordSubOp -> \ [r] [x,y] -> PrimInline $ r |= toU32 (Sub x y) + WordMulOp -> \ [r] [x,y] -> PrimInline $ r |= app "h$mulWord32" [x, y] + WordMul2Op -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$mul2Word32" [x,y] + WordQuotOp -> \ [q] [x,y] -> PrimInline $ q |= app "h$quotWord32" [x,y] + WordRemOp -> \ [r] [x,y] -> PrimInline $ r |= app "h$remWord32" [x,y] + WordQuotRemOp -> \[q,r] [x,y] -> PrimInline $ appT [q,r] "h$quotRemWord32" [x,y] + WordQuotRem2Op -> \[q,r] [xh,xl,y] -> PrimInline $ appT [q,r] "h$quotRem2Word32" [xh,xl,y] + WordAndOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BAnd x y) + WordOrOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BOr x y) + WordXorOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BXor x y) + WordNotOp -> \[r] [x] -> PrimInline $ r |= toU32 (BNot x) + WordSllOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (x .<<. y) + WordSrlOp -> \[r] [x,y] -> PrimInline $ r |= x .>>>. y + WordToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x + WordGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + WordGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + WordEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + WordNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + WordLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + WordLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + WordToDoubleOp -> \[r] [x] -> PrimInline $ r |= x + WordToFloatOp -> \[r] [x] -> PrimInline $ r |= math_fround [x] + PopCnt8Op -> \[r] [x] -> PrimInline $ r |= var "h$popCntTab" .! (mask8 x) + PopCnt16Op -> \[r] [x] -> PrimInline $ r |= Add (var "h$popCntTab" .! (mask8 x)) + (var "h$popCntTab" .! (mask8 (x .>>>. Int 8))) + + PopCnt32Op -> \[r] [x] -> PrimInline $ r |= app "h$popCnt32" [x] + PopCnt64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$popCnt64" [x1,x2] + PopCntOp -> \[r] [x] -> genPrim prof bound ty PopCnt32Op [r] [x] + Pdep8Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep8" [s,m] + Pdep16Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep16" [s,m] + Pdep32Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep32" [s,m] + Pdep64Op -> \[ra,rb] [sa,sb,ma,mb] -> PrimInline $ appT [ra,rb] "h$pdep64" [sa,sb,ma,mb] + PdepOp -> \rs xs -> genPrim prof bound ty Pdep32Op rs xs + Pext8Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext8" [s,m] + Pext16Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext16" [s,m] + Pext32Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext32" [s,m] + Pext64Op -> \[ra,rb] [sa,sb,ma,mb] -> PrimInline $ appT [ra,rb] "h$pext64" [sa,sb,ma,mb] + PextOp -> \rs xs -> genPrim prof bound ty Pext32Op rs xs + + ClzOp -> \[r] [x] -> PrimInline $ r |= app "h$clz32" [x] + Clz8Op -> \[r] [x] -> PrimInline $ r |= app "h$clz8" [x] + Clz16Op -> \[r] [x] -> PrimInline $ r |= app "h$clz16" [x] + Clz32Op -> \[r] [x] -> PrimInline $ r |= app "h$clz32" [x] + Clz64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$clz64" [x1,x2] + CtzOp -> \[r] [x] -> PrimInline $ r |= app "h$ctz32" [x] + Ctz8Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz8" [x] + Ctz16Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz16" [x] + Ctz32Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz32" [x] + Ctz64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$ctz64" [x1,x2] + + BSwap16Op -> \[r] [x] -> PrimInline $ + r |= BOr ((mask8 x) .<<. (Int 8)) + (mask8 (x .>>>. (Int 8))) + BSwap32Op -> \[r] [x] -> PrimInline $ + r |= toU32 ((x .<<. (Int 24)) + `BOr` ((BAnd x (Int 0xFF00)) .<<. (Int 8)) + `BOr` ((BAnd x (Int 0xFF0000)) .>>. (Int 8)) + `BOr` (x .>>>. (Int 24))) + BSwap64Op -> \[r1,r2] [x,y] -> PrimInline $ appT [r1,r2] "h$bswap64" [x,y] + BSwapOp -> \[r] [x] -> genPrim prof bound ty BSwap32Op [r] [x] + + BRevOp -> \[r] [w] -> genPrim prof bound ty BRev32Op [r] [w] + BRev8Op -> \[r] [w] -> PrimInline $ r |= (app "h$reverseWord" [w] .>>>. 24) + BRev16Op -> \[r] [w] -> PrimInline $ r |= (app "h$reverseWord" [w] .>>>. 16) + BRev32Op -> \[r] [w] -> PrimInline $ r |= app "h$reverseWord" [w] + BRev64Op -> \[rh,rl] [h,l] -> PrimInline $ mconcat [ rl |= app "h$reverseWord" [h] + , rh |= app "h$reverseWord" [l] + ] + +------------------------------ Narrow ------------------------------------------- + + Narrow8IntOp -> \[r] [x] -> PrimInline $ r |= signExtend8 x + Narrow16IntOp -> \[r] [x] -> PrimInline $ r |= signExtend16 x + Narrow32IntOp -> \[r] [x] -> PrimInline $ r |= toI32 x + Narrow8WordOp -> \[r] [x] -> PrimInline $ r |= mask8 x + Narrow16WordOp -> \[r] [x] -> PrimInline $ r |= mask16 x + Narrow32WordOp -> \[r] [x] -> PrimInline $ r |= toU32 x + +------------------------------ Double ------------------------------------------- + + DoubleGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + DoubleGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + DoubleEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + DoubleNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + DoubleLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + DoubleLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + DoubleAddOp -> \[r] [x,y] -> PrimInline $ r |= Add x y + DoubleSubOp -> \[r] [x,y] -> PrimInline $ r |= Sub x y + DoubleMulOp -> \[r] [x,y] -> PrimInline $ r |= Mul x y + DoubleDivOp -> \[r] [x,y] -> PrimInline $ r |= Div x y + DoubleNegOp -> \[r] [x] -> PrimInline $ r |= Negate x + DoubleFabsOp -> \[r] [x] -> PrimInline $ r |= math_abs [x] + DoubleToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x + DoubleToFloatOp -> \[r] [x] -> PrimInline $ r |= math_fround [x] + DoubleExpOp -> \[r] [x] -> PrimInline $ r |= math_exp [x] + DoubleExpM1Op -> \[r] [x] -> PrimInline $ r |= math_expm1 [x] + DoubleLogOp -> \[r] [x] -> PrimInline $ r |= math_log [x] + DoubleLog1POp -> \[r] [x] -> PrimInline $ r |= math_log1p [x] + DoubleSqrtOp -> \[r] [x] -> PrimInline $ r |= math_sqrt [x] + DoubleSinOp -> \[r] [x] -> PrimInline $ r |= math_sin [x] + DoubleCosOp -> \[r] [x] -> PrimInline $ r |= math_cos [x] + DoubleTanOp -> \[r] [x] -> PrimInline $ r |= math_tan [x] + DoubleAsinOp -> \[r] [x] -> PrimInline $ r |= math_asin [x] + DoubleAcosOp -> \[r] [x] -> PrimInline $ r |= math_acos [x] + DoubleAtanOp -> \[r] [x] -> PrimInline $ r |= math_atan [x] + DoubleSinhOp -> \[r] [x] -> PrimInline $ r |= math_sinh [x] + DoubleCoshOp -> \[r] [x] -> PrimInline $ r |= math_cosh [x] + DoubleTanhOp -> \[r] [x] -> PrimInline $ r |= math_tanh [x] + DoubleAsinhOp -> \[r] [x] -> PrimInline $ r |= math_asinh [x] + DoubleAcoshOp -> \[r] [x] -> PrimInline $ r |= math_acosh [x] + DoubleAtanhOp -> \[r] [x] -> PrimInline $ r |= math_atanh [x] + DoublePowerOp -> \[r] [x,y] -> PrimInline $ r |= math_pow [x,y] + DoubleDecode_2IntOp -> \[s,h,l,e] [x] -> PrimInline $ appT [s,h,l,e] "h$decodeDouble2Int" [x] + DoubleDecode_Int64Op -> \[s1,s2,e] [d] -> PrimInline $ appT [e,s1,s2] "h$decodeDoubleInt64" [d] + +------------------------------ Float -------------------------------------------- + + FloatGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) + FloatGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) + FloatEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) + FloatNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) + FloatLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) + FloatLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) + FloatAddOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Add x y] + FloatSubOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Sub x y] + FloatMulOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Mul x y] + FloatDivOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Div x y] + FloatNegOp -> \[r] [x] -> PrimInline $ r |= Negate x + FloatFabsOp -> \[r] [x] -> PrimInline $ r |= math_abs [x] + FloatToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x + FloatExpOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_exp [x]] + FloatExpM1Op -> \[r] [x] -> PrimInline $ r |= math_fround [math_expm1 [x]] + FloatLogOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_log [x]] + FloatLog1POp -> \[r] [x] -> PrimInline $ r |= math_fround [math_log1p [x]] + FloatSqrtOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sqrt [x]] + FloatSinOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sin [x]] + FloatCosOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_cos [x]] + FloatTanOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_tan [x]] + FloatAsinOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_asin [x]] + FloatAcosOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_acos [x]] + FloatAtanOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_atan [x]] + FloatSinhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sinh [x]] + FloatCoshOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_cosh [x]] + FloatTanhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_tanh [x]] + FloatAsinhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_asinh [x]] + FloatAcoshOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_acosh [x]] + FloatAtanhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_atanh [x]] + FloatPowerOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [math_pow [x,y]] + FloatToDoubleOp -> \[r] [x] -> PrimInline $ r |= x + FloatDecode_IntOp -> \[s,e] [x] -> PrimInline $ appT [s,e] "h$decodeFloatInt" [x] + +------------------------------ Arrays ------------------------------------------- + + NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) + ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a + UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a + CopyArrayOp -> \[] [a,o1,ma,o2,n] -> + PrimInline $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] + FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ + jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] + +------------------------------ Small Arrays ------------------------------------- + + NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a + UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a + CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ + loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ + loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] + +------------------------------- Byte Arrays ------------------------------------- + + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a i $ jVar \t -> mconcat + [ t |= a .^ "arr" + , ifBlockS (t .&&. t .! (i .<<. two_)) + [ r1 |= t .! (i .<<. two_) .! zero_ + , r2 |= t .! (i .<<. two_) .! one_ + ] + [ r1 |= null_ + , r2 |= zero_ + ] + ] + + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a (Add i 3) $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_i32 a i + ] + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_i32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_u32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a (Add i 3) $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_i32 a i + ] + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_i32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_u32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) + ] + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 + + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ write_i32 a (Add (i .<<. one_) one_) e1 + , write_u32 a (i .<<. one_) e2 + ] + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ write_u32 a (Add (i .<<. one_) one_) h + , write_u32 a (i .<<. one_) l + ] + CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> + PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) + . boundsChecked bound a2 (Add o2 (Sub n 1)) + $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] + + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) + . boundsChecked bound a2 (Add o2 (Sub n 1)) + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ write_u8 a2 (Add i o2) (read_u8 a1 (Add i o1)) + , postDecrS i + ] + CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + + SetByteArrayOp -> \[] [a,o,n,v] -> + PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + [ write_u8 a (Add o i) v + , postIncrS i + ] + + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + +------------------------------- Addr# ------------------------------------------ + + AddrAddOp -> \[a',o'] [a,o,i] -> PrimInline $ mconcat [a' |= a, o' |= Add o i] + AddrSubOp -> \[i] [_a1,o1,_a2,o2] -> PrimInline $ i |= Sub o1 o2 + AddrRemOp -> \[r] [_a,o,i] -> PrimInline $ r |= Mod o i + AddrToIntOp -> \[i] [_a,o] -> PrimInline $ i |= o -- only usable for comparisons within one range + IntToAddrOp -> \[a,o] [i] -> PrimInline $ mconcat [a |= null_, o |= i] + AddrGtOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>. zero_) + AddrGeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>=. zero_) + AddrEqOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .===. zero_) + AddrNeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .!==. zero_) + AddrLtOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<. zero_) + AddrLeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<=. zero_) + +------------------------------- Addr Indexing: Unboxed Arrays ------------------- + + IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> + PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) + $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) + [ ca |= a .^ "arr" .! (off32 o i) .! zero_ + , co |= a .^ "arr" .! (off32 o i) .! one_ + ] + [ ca |= null_ + , co |= zero_ + ] + IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat + [ c1 |= var "h$stablePtrBuf" + , c2 |= read_boff_i32 a (off32 o i) + ] + IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) + , l |= read_boff_u32 a (off64 o i) + ] + IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) + , l |= read_boff_u32 a (off64 o i) + ] + ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") (Add o x) $ + ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) + [ c1 |= a .^ "arr" .! (Add o x) .! zero_ + , c2 |= a .^ "arr" .! (Add o x) .! one_ + ] + [ c1 |= null_ + , c2 |= zero_ + ] + ] + ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat + [ c1 |= var "h$stablePtrBuf" + , c2 |= read_boff_u32 a (off32 o i) + ] + ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_i32 a (Add (off64 o i) (Int 4)) + , l |= read_u32 a (off64 o i) + ] + ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> + PrimInline $ mconcat + [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) + , c2 |= read_boff_u32 a (off64 o i) + ] + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , boundsChecked bound (a .^ "arr") (off32 o i) $ + AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) + ] + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat + [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 + , write_boff_u32 a (off64 o i) v2 + ] + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat + [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 + , write_boff_u32 a (off64 o i) v2 + ] +-- Mutable variables + NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) + ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" + WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x + AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f] + AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f] + + CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o) + (mconcat [status |= zero_, r |= n, mv .^ "val" |= n]) + (mconcat [status |= one_ , r |= mv .^ "val"]) + +------------------------------- Exceptions -------------------------------------- + + CatchOp -> \[_r] [a,handler] -> PRPrimCall $ returnS (app "h$catch" [a, handler]) + + -- fully ignore the result arity as it can use 1 or 2 + -- slots, depending on the return type. + RaiseOp -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_]) + RaiseIOOp -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_]) + RaiseUnderflowOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypeziunderflowException", false_]) + RaiseOverflowOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezioverflowException", false_]) + RaiseDivZeroOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezidivZZeroException", false_]) + MaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$maskAsync" [a]) + MaskUninterruptibleOp -> \_r [a] -> PRPrimCall $ returnS (app "h$maskUnintAsync" [a]) + UnmaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$unmaskAsync" [a]) + + MaskStatus -> \[r] [] -> PrimInline $ r |= app "h$maskStatus" [] + +------------------------------- STM-accessible Mutable Variables -------------- + + AtomicallyOp -> \[_r] [a] -> PRPrimCall $ returnS (app "h$atomically" [a]) + RetryOp -> \_r [] -> PRPrimCall $ returnS (app "h$stmRetry" []) + CatchRetryOp -> \[_r] [a,b] -> PRPrimCall $ returnS (app "h$stmCatchRetry" [a,b]) + CatchSTMOp -> \[_r] [a,h] -> PRPrimCall $ returnS (app "h$catchStm" [a,h]) + NewTVarOp -> \[tv] [v] -> PrimInline $ tv |= app "h$newTVar" [v] + ReadTVarOp -> \[r] [tv] -> PrimInline $ r |= app "h$readTVar" [tv] + ReadTVarIOOp -> \[r] [tv] -> PrimInline $ r |= app "h$readTVarIO" [tv] + WriteTVarOp -> \[] [tv,v] -> PrimInline $ appS "h$writeTVar" [tv,v] + +------------------------------- Synchronized Mutable Variables ------------------ + + NewMVarOp -> \[r] [] -> PrimInline $ r |= New (app "h$MVar" []) + TakeMVarOp -> \[_r] [m] -> PRPrimCall $ returnS (app "h$takeMVar" [m]) + TryTakeMVarOp -> \[r,v] [m] -> PrimInline $ appT [r,v] "h$tryTakeMVar" [m] + PutMVarOp -> \[] [m,v] -> PRPrimCall $ returnS (app "h$putMVar" [m,v]) + TryPutMVarOp -> \[r] [m,v] -> PrimInline $ r |= app "h$tryPutMVar" [m,v] + ReadMVarOp -> \[_r] [m] -> PRPrimCall $ returnS (app "h$readMVar" [m]) + TryReadMVarOp -> \[r,v] [m] -> PrimInline $ mconcat + [ v |= m .^ "val" + , r |= if01 (v .===. null_) + ] + IsEmptyMVarOp -> \[r] [m] -> PrimInline $ r |= if10 (m .^ "val" .===. null_) + +------------------------------- Delay/Wait Ops --------------------------------- + + DelayOp -> \[] [t] -> PRPrimCall $ returnS (app "h$delayThread" [t]) + WaitReadOp -> \[] [fd] -> PRPrimCall $ returnS (app "h$waidRead" [fd]) + WaitWriteOp -> \[] [fd] -> PRPrimCall $ returnS (app "h$waitWrite" [fd]) + +------------------------------- Concurrency Primitives ------------------------- + + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ r |= var "h$threads" + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + +------------------------------- Weak Pointers ----------------------------------- + + MkWeakOp -> \[r] [o,b,c] -> PrimInline $ r |= app "h$makeWeak" [o,b,c] + MkWeakNoFinalizerOp -> \[r] [o,b] -> PrimInline $ r |= app "h$makeWeakNoFinalizer" [o,b] + AddCFinalizerToWeakOp -> \[r] [_a1,_a1o,_a2,_a2o,_i,_a3,_a3o,_w] -> PrimInline $ r |= one_ + DeRefWeakOp -> \[f,v] [w] -> PrimInline $ mconcat + [ v |= w .^ "val" + , f |= if01 (v .===. null_) + ] + FinalizeWeakOp -> \[fl,fin] [w] -> PrimInline $ appT [fin, fl] "h$finalizeWeak" [w] + TouchOp -> \[] [_e] -> PrimInline mempty + KeepAliveOp -> \[_r] [x, f] -> PRPrimCall $ ReturnStat (app "h$keepAlive" [x, f]) + + +------------------------------ Stable pointers and names ------------------------ + + MakeStablePtrOp -> \[s1,s2] [a] -> PrimInline $ mconcat + [ s1 |= var "h$stablePtrBuf" + , s2 |= app "h$makeStablePtr" [a] + ] + DeRefStablePtrOp -> \[r] [_s1,s2] -> PrimInline $ r |= app "h$deRefStablePtr" [s2] + EqStablePtrOp -> \[r] [_sa1,sa2,_sb1,sb2] -> PrimInline $ r |= if10 (sa2 .===. sb2) + + MakeStableNameOp -> \[r] [a] -> PrimInline $ r |= app "h$makeStableName" [a] + StableNameToIntOp -> \[r] [s] -> PrimInline $ r |= app "h$stableNameInt" [s] + +------------------------------ Compact normal form ----------------------------- + + CompactNewOp -> \[c] [s] -> PrimInline $ c |= app "h$compactNew" [s] + CompactResizeOp -> \[] [c,s] -> PrimInline $ appS "h$compactResize" [c,s] + CompactContainsOp -> \[r] [c,v] -> PrimInline $ r |= app "h$compactContains" [c,v] + CompactContainsAnyOp -> \[r] [v] -> PrimInline $ r |= app "h$compactContainsAny" [v] + CompactGetFirstBlockOp -> \[ra,ro,s] [c] -> + PrimInline $ appT [ra,ro,s] "h$compactGetFirstBlock" [c] + CompactGetNextBlockOp -> \[ra,ro,s] [c,a,o] -> + PrimInline $ appT [ra,ro,s] "h$compactGetNextBlock" [c,a,o] + CompactAllocateBlockOp -> \[ra,ro] [size,sa,so] -> + PrimInline $ appT [ra,ro] "h$compactAllocateBlock" [size,sa,so] + CompactFixupPointersOp -> \[c,newroota, newrooto] [blocka,blocko,roota,rooto] -> + PrimInline $ appT [c,newroota,newrooto] "h$compactFixupPointers" [blocka,blocko,roota,rooto] + CompactAdd -> \[_r] [c,o] -> + PRPrimCall $ returnS (app "h$compactAdd" [c,o]) + CompactAddWithSharing -> \[_r] [c,o] -> + PRPrimCall $ returnS (app "h$compactAddWithSharing" [c,o]) + CompactSize -> \[s] [c] -> + PrimInline $ s |= app "h$compactSize" [c] + +------------------------------ Unsafe pointer equality -------------------------- + + ReallyUnsafePtrEqualityOp -> \[r] [p1,p2] -> PrimInline $ r |= if10 (p1 .===. p2) + +------------------------------ Parallelism -------------------------------------- + + ParOp -> \[r] [_a] -> PrimInline $ r |= zero_ + SparkOp -> \[r] [a] -> PrimInline $ r |= a + SeqOp -> \[_r] [e] -> PRPrimCall $ returnS (app "h$e" [e]) + NumSparks -> \[r] [] -> PrimInline $ r |= zero_ + +------------------------------ Tag to enum stuff -------------------------------- + + DataToTagOp -> \[_r] [d] -> PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] + TagToEnumOp -> \[r] [tag] -> if + | isBoolTy ty -> PrimInline $ r |= IfExpr tag true_ false_ + | otherwise -> PrimInline $ r |= app "h$tagToEnum" [tag] + +------------------------------ Bytecode operations ------------------------------ + + AddrToAnyOp -> \[r] [d,_o] -> PrimInline $ r |= d + +------------------------------ Profiling (CCS) ------------------------------ + + GetCCSOfOp -> \[a, o] [obj] -> if + | prof -> PrimInline $ mconcat + [ a |= if_ (isObject obj) + (app "h$buildCCSPtr" [obj .^ "cc"]) + null_ + , o |= zero_ + ] + | otherwise -> PrimInline $ mconcat + [ a |= null_ + , o |= zero_ + ] + + GetCurrentCCSOp -> \[a, o] [_dummy_arg] -> + let ptr = if prof then app "h$buildCCSPtr" [jCurrentCCS] + else null_ + in PrimInline $ mconcat + [ a |= ptr + , o |= zero_ + ] + + ClearCCSOp -> \[_r] [x] -> PRPrimCall $ ReturnStat (app "h$clearCCS" [x]) + +------------------------------ Eventlog ------------------- + + TraceEventOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceEvent" [ed,eo] + TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] + TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") x $ + ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> + PrimInline $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_boff_i32 a i + ] + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_boff_u32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") x $ + ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> + PrimInline $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_boff_i32 a i + ] + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_boff_u32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , boundsChecked bound (a .^ "arr") (i .<<. two_) $ + a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) + ] + + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> + -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i + -- then write the higher 4 bytes to i+4 + PrimInline . boundsChecked bound a i + $ mconcat [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> + PrimInline . boundsChecked bound a (Add i 7) + $ mconcat [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new + CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new + CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new + CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new + + CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ + jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) + , t_l |= read_u32 a (i .<<. one_) + , r_h |= t_h + , r_l |= t_l + , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast + (ifBlockS (t_h .===. old_h) + -- Pre-Condition is good, do the write + [ write_i32 a (Add (i .<<. one_) one_) new_h + , write_u32 a (i .<<. one_) new_l + ] + -- no good, don't write + mempty) + mempty + ] + + CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ + mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) + (appS "h$memcpy" [a3,o3,a1,o1,8]) + mempty + , r_a |= a1 + , r_o |= o1 + ] + CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new + CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new + CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new + CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new + CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ + mconcat [ r_h |= read_u32 a (Add o (Int 4)) + , r_l |= read_u32 a o + , ifS (r_l .===. old_l) + (ifBlockS (r_h .===. old_h) + [ write_u32 a (Add o (Int 4)) new_h + , write_u32 a o new_l + ] + mempty) + mempty + ] + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v + FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v + FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v + FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v + + InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ + -- this primop can't be implemented + -- correctly because we don't store + -- the array reference part of an Addr#, + -- only the offset part. + -- + -- So let's assume that all the array + -- references are the same... + -- + -- Note: we could generate an assert + -- that checks that a1 === a2. However + -- we can't check that the Addr# read + -- at Addr# a2[o2] also comes from this + -- a1/a2 array. + mconcat [ r_a |= a1 -- might be wrong (see above) + , r_o |= read_boff_u32 a1 o1 + -- TODO (see above) + -- assert that a1 === a2 + , write_boff_u32 a1 o1 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ + mconcat [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] + + ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] + GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" + + AtomicReadAddrOp_Word -> \[r] [a,o] -> PrimInline $ r |= read_boff_u32 a o + AtomicWriteAddrOp_Word -> \[] [a,o,w] -> PrimInline $ write_boff_u32 a o w + + +------------------------------ Unhandled primops ------------------- + + NewPromptTagOp -> unhandledPrimop op + PromptOp -> unhandledPrimop op + Control0Op -> unhandledPrimop op + + NewIOPortOp -> unhandledPrimop op + ReadIOPortOp -> unhandledPrimop op + WriteIOPortOp -> unhandledPrimop op + + GetSparkOp -> unhandledPrimop op + AnyToAddrOp -> unhandledPrimop op + MkApUpd0_Op -> unhandledPrimop op + NewBCOOp -> unhandledPrimop op + UnpackClosureOp -> unhandledPrimop op + ClosureSizeOp -> unhandledPrimop op + GetApStackValOp -> unhandledPrimop op + WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n + + SetThreadAllocationCounter -> unhandledPrimop op + +------------------------------- Vector ----------------------------------------- +-- For now, vectors are unsupported on the JS backend. Simply put, they do not +-- make much sense to support given support for arrays and lack of SIMD support +-- in JS. We could try to roll something special but we would not be able to +-- give any performance guarentees to the user and so we leave these has +-- unhandled for now. + VecBroadcastOp _ _ _ -> unhandledPrimop op + VecPackOp _ _ _ -> unhandledPrimop op + VecUnpackOp _ _ _ -> unhandledPrimop op + VecInsertOp _ _ _ -> unhandledPrimop op + VecAddOp _ _ _ -> unhandledPrimop op + VecSubOp _ _ _ -> unhandledPrimop op + VecMulOp _ _ _ -> unhandledPrimop op + VecDivOp _ _ _ -> unhandledPrimop op + VecQuotOp _ _ _ -> unhandledPrimop op + VecRemOp _ _ _ -> unhandledPrimop op + VecNegOp _ _ _ -> unhandledPrimop op + VecIndexByteArrayOp _ _ _ -> unhandledPrimop op + VecReadByteArrayOp _ _ _ -> unhandledPrimop op + VecWriteByteArrayOp _ _ _ -> unhandledPrimop op + VecIndexOffAddrOp _ _ _ -> unhandledPrimop op + VecReadOffAddrOp _ _ _ -> unhandledPrimop op + VecWriteOffAddrOp _ _ _ -> unhandledPrimop op + + VecIndexScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecReadScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecWriteScalarByteArrayOp _ _ _ -> unhandledPrimop op + VecIndexScalarOffAddrOp _ _ _ -> unhandledPrimop op + VecReadScalarOffAddrOp _ _ _ -> unhandledPrimop op + VecWriteScalarOffAddrOp _ _ _ -> unhandledPrimop op + + PrefetchByteArrayOp3 -> noOp + PrefetchMutableByteArrayOp3 -> noOp + PrefetchAddrOp3 -> noOp + PrefetchValueOp3 -> noOp + PrefetchByteArrayOp2 -> noOp + PrefetchMutableByteArrayOp2 -> noOp + PrefetchAddrOp2 -> noOp + PrefetchValueOp2 -> noOp + PrefetchByteArrayOp1 -> noOp + PrefetchMutableByteArrayOp1 -> noOp + PrefetchAddrOp1 -> noOp + PrefetchValueOp1 -> noOp + PrefetchByteArrayOp0 -> noOp + PrefetchMutableByteArrayOp0 -> noOp + PrefetchAddrOp0 -> noOp + PrefetchValueOp0 -> noOp + +unhandledPrimop :: PrimOp -> [JExpr] -> [JExpr] -> PrimRes +unhandledPrimop op rs as = PrimInline $ mconcat + [ appS "h$log" [toJExpr $ mconcat + [ "warning, unhandled primop: " + , renderWithContext defaultSDocContext (ppr op) + , " " + , show (length rs, length as) + ]] + , appS (mkFastString $ "h$primop_" ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as + -- copyRes + , mconcat $ zipWith (\r reg -> r |= toJExpr reg) rs (enumFrom Ret1) + ] + +-- | A No Op, used for primops the JS platform cannot or do not support. For +-- example, the prefetching primops do not make sense on the JS platform because +-- we do not have enough control over memory to provide any kind of prefetching +-- mechanism. Hence, these are NoOps. +noOp :: Foldable f => f a -> f a -> PrimRes +noOp = const . const $ PrimInline mempty + +-- tuple returns +appT :: [JExpr] -> FastString -> [JExpr] -> JStat +appT [] f xs = appS f xs +appT (r:rs) f xs = mconcat + [ r |= app f xs + , mconcat (zipWith (\r ret -> r |= toJExpr ret) rs (enumFrom Ret1)) + ] + +-------------------------------------------- +-- ByteArray indexing +-------------------------------------------- + +-- For every ByteArray, the RTS creates the following views: +-- i3: Int32 view +-- u8: Word8 view +-- u1: Word16 view +-- f3: Float32 view +-- f6: Float64 view +-- dv: generic DataView +-- It seems a bit weird to mix Int and Word views like this, but perhaps they +-- are the more common. +-- +-- See 'h$newByteArray' in 'ghc/rts/js/mem.js' for details. +-- +-- Note that *byte* indexing can only be done with the generic DataView. Use +-- read_boff_* and write_boff_* for this. +-- +-- Other read_* and write_* helpers directly use the more specific views. +-- Prefer using them over idx_* to make your intent clearer. + +idx_i32, idx_u8, idx_u16, idx_f64, idx_f32 :: JExpr -> JExpr -> JExpr +idx_i32 a i = IdxExpr (a .^ "i3") i +idx_u8 a i = IdxExpr (a .^ "u8") i +idx_u16 a i = IdxExpr (a .^ "u1") i +idx_f64 a i = IdxExpr (a .^ "f6") i +idx_f32 a i = IdxExpr (a .^ "f3") i + +read_u8 :: JExpr -> JExpr -> JExpr +read_u8 a i = idx_u8 a i + +read_u16 :: JExpr -> JExpr -> JExpr +read_u16 a i = idx_u16 a i + +read_u32 :: JExpr -> JExpr -> JExpr +read_u32 a i = toU32 (idx_i32 a i) + +read_i8 :: JExpr -> JExpr -> JExpr +read_i8 a i = signExtend8 (idx_u8 a i) + +read_i16 :: JExpr -> JExpr -> JExpr +read_i16 a i = signExtend16 (idx_u16 a i) + +read_i32 :: JExpr -> JExpr -> JExpr +read_i32 a i = idx_i32 a i + +read_f32 :: JExpr -> JExpr -> JExpr +read_f32 a i = idx_f32 a i + +read_f64 :: JExpr -> JExpr -> JExpr +read_f64 a i = idx_f64 a i + +write_u8 :: JExpr -> JExpr -> JExpr -> JStat +write_u8 a i v = idx_u8 a i |= v + +write_u16 :: JExpr -> JExpr -> JExpr -> JStat +write_u16 a i v = idx_u16 a i |= v + +write_u32 :: JExpr -> JExpr -> JExpr -> JStat +write_u32 a i v = idx_i32 a i |= v + +write_i8 :: JExpr -> JExpr -> JExpr -> JStat +write_i8 a i v = idx_u8 a i |= v + +write_i16 :: JExpr -> JExpr -> JExpr -> JStat +write_i16 a i v = idx_u16 a i |= v + +write_i32 :: JExpr -> JExpr -> JExpr -> JStat +write_i32 a i v = idx_i32 a i |= v + +write_f32 :: JExpr -> JExpr -> JExpr -> JStat +write_f32 a i v = idx_f32 a i |= v + +write_f64 :: JExpr -> JExpr -> JExpr -> JStat +write_f64 a i v = idx_f64 a i |= v + +-- Data View helper functions: byte indexed! +-- +-- The argument list consists of the array @a@, the index @i@, and the new value +-- to set (in the case of a setter) @v@. + +write_boff_i8, write_boff_u8, write_boff_i16, write_boff_u16, write_boff_i32, write_boff_u32, write_boff_f32, write_boff_f64 :: JExpr -> JExpr -> JExpr -> JStat +write_boff_i8 a i v = write_i8 a i v +write_boff_u8 a i v = write_u8 a i v +write_boff_i16 a i v = ApplStat (a .^ "dv" .^ "setInt16" ) [i, v, true_] +write_boff_u16 a i v = ApplStat (a .^ "dv" .^ "setUint16" ) [i, v, true_] +write_boff_i32 a i v = ApplStat (a .^ "dv" .^ "setInt32" ) [i, v, true_] +write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] +write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] +write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] + +read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr +read_boff_i8 a i = read_i8 a i +read_boff_u8 a i = read_u8 a i +read_boff_i16 a i = ApplExpr (a .^ "dv" .^ "getInt16" ) [i, true_] +read_boff_u16 a i = ApplExpr (a .^ "dv" .^ "getUint16" ) [i, true_] +read_boff_i32 a i = ApplExpr (a .^ "dv" .^ "getInt32" ) [i, true_] +read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] +read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] +read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] + +fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +fetchOpByteArray op tgt src i v = mconcat + [ tgt |= read_i32 src i + , write_i32 src i (op tgt v) + ] + +fetchOpAddr :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +fetchOpAddr op tgt src i v = mconcat + [ tgt |= read_boff_u32 src i + , write_boff_u32 src i (op tgt v) + ] + +casOp + :: (JExpr -> JExpr -> JExpr) -- read + -> (JExpr -> JExpr -> JExpr -> JStat) -- write + -> JExpr -- target register to store result + -> JExpr -- source arrays + -> JExpr -- index + -> JExpr -- old value to compare + -> JExpr -- new value to write + -> JStat +casOp read write tgt src i old new = mconcat + [ tgt |= read src i + , ifS (tgt .===. old) + (write src i new) + mempty + ] + +-------------------------------------------------------------------------------- +-- Lifted Arrays +-------------------------------------------------------------------------------- +-- | lifted arrays +cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat +cloneArray tgt src mb_offset len = mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, end] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] + where + start = fromMaybe zero_ mb_offset + end = maybe len (Add len) mb_offset + +newArray :: JExpr -> JExpr -> JExpr -> JStat +newArray tgt len elem = + tgt |= app "h$newArray" [len, elem] + +newByteArray :: JExpr -> JExpr -> JStat +newByteArray tgt len = + tgt |= app "h$newByteArray" [len] + +boundsChecked :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +boundsChecked False _ _ r = r +boundsChecked True xs i r = + ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) + r + (returnS $ app "h$exitProcess" [Int 134]) + +-- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 +-- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. +-- So (x|0) * (y|0) can still return values outside of the Int32 range. You have +-- been warned! +toI32 :: JExpr -> JExpr +toI32 e = BOr e zero_ + +-- e>>>0 (32 bit unsigned integer truncation) +-- required because of JS numbers. e>>>0 converts e to a Word32 +-- so (-2147483648) >>> 0 = 2147483648 +-- and ((-2147483648) >>>0) | 0 = -2147483648 +toU32 :: JExpr -> JExpr +toU32 e = e .>>>. zero_ + +quotShortInt :: Int -> JExpr -> JExpr -> JExpr +quotShortInt bits x y = BAnd (signed x `Div` signed y) mask + where + signed z = (z .<<. shift) .>>. shift + shift = toJExpr (32 - bits) + mask = toJExpr (((2::Integer) ^ bits) - 1) + +remShortInt :: Int -> JExpr -> JExpr -> JExpr +remShortInt bits x y = BAnd (signed x `Mod` signed y) mask + where + signed z = (z .<<. shift) .>>. shift + shift = toJExpr (32 - bits) + mask = toJExpr (((2::Integer) ^ bits) - 1) diff --git a/compiler/GHC/StgToJS/Printer.hs b/compiler/GHC/StgToJS/Printer.hs new file mode 100644 index 0000000000..086f30ba07 --- /dev/null +++ b/compiler/GHC/StgToJS/Printer.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Printer +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Stability : experimental +-- +-- Custom prettyprinter for JS AST uses the JS PPr module for most of +-- the work +-- +-- +----------------------------------------------------------------------------- +module GHC.StgToJS.Printer + ( pretty + , ghcjsRenderJs + , prettyBlock + ) +where + +import GHC.Prelude +import GHC.Int +import GHC.Exts + +import GHC.JS.Syntax +import GHC.JS.Ppr + +import GHC.Utils.Ppr as PP +import GHC.Data.FastString +import GHC.Types.Unique.Map + +import Data.List (sortOn) +import Data.Char (isAlpha,isDigit,ord) +import qualified Data.ByteString.Short as SBS + +pretty :: JStat -> Doc +pretty = jsToDocR ghcjsRenderJs + +ghcjsRenderJs :: RenderJs +ghcjsRenderJs = defaultRenderJs + { renderJsV = ghcjsRenderJsV + , renderJsS = ghcjsRenderJsS + , renderJsI = ghcjsRenderJsI + } + +hdd :: SBS.ShortByteString +hdd = SBS.pack (map (fromIntegral . ord) "h$$") + +ghcjsRenderJsI :: RenderJs -> Ident -> Doc +ghcjsRenderJsI _ (TxtI fs) + -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by + -- name in user code, only in compiled code. Hence we can rename them if we do + -- it consistently in all the linked code. + -- + -- These symbols are usually very large because their name includes the + -- unit-id, the module name, and some unique number. So we rename these + -- symbols with a much shorter globally unique number. + -- + -- Here we reuse their FastString unique for this purpose! Note that it only + -- works if we pretty-print all the JS code linked together at once, which we + -- currently do. GHCJS used to maintain a CompactorState to support + -- incremental linking: it contained the mapping between original symbols and + -- their renaming. + | hdd `SBS.isPrefixOf` fastStringToShortByteString fs + , u <- uniqueOfFS fs + = text "h$$" <> hexDoc (fromIntegral u) + | otherwise + = ftext fs + +-- | Render as an hexadecimal number in reversed order (because it's faster and we +-- don't care about the actual value). +hexDoc :: Word -> Doc +hexDoc 0 = char '0' +hexDoc v = text $ go v + where + sym (I# i) = C# (indexCharOffAddr# chars i) + chars = "0123456789abcdef"# + go = \case + 0 -> [] + n -> sym (fromIntegral (n .&. 0x0F)) + : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) + : go (n `shiftR` 8) + + + + +-- attempt to resugar some of the common constructs +ghcjsRenderJsS :: RenderJs -> JStat -> Doc +ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s + +-- don't quote keys in our object literals, so closure compiler works +ghcjsRenderJsV :: RenderJs -> JVal -> Doc +ghcjsRenderJsV r (JHash m) + | isNullUniqMap m = text "{}" + | otherwise = braceNest . PP.fsep . punctuate comma . + map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y) + -- nonDetEltsUniqMap doesn't introduce non-determinism here because + -- we sort the elements lexically + . sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m + where + quoteIfRequired :: FastString -> Doc + quoteIfRequired x + | isUnquotedKey x' = text x' + | otherwise = PP.squotes (text x') + where x' = unpackFS x + + isUnquotedKey :: String -> Bool + isUnquotedKey x | null x = False + | all isDigit x = True + | otherwise = validFirstIdent (head x) + && all validOtherIdent (tail x) + + + validFirstIdent c = c == '_' || c == '$' || isAlpha c + validOtherIdent c = isAlpha c || isDigit c +ghcjsRenderJsV r v = renderJsV defaultRenderJs r v + +prettyBlock :: RenderJs -> [JStat] -> Doc +prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs) + +-- recognize common patterns in a block and convert them to more idiomatic/concise javascript +prettyBlock' :: RenderJs -> [JStat] -> [Doc] +-- return/... +prettyBlock' r ( x@(ReturnStat _) + : xs + ) + | not (null xs) + = prettyBlock' r [x] +-- declare/assign +prettyBlock' r ( (DeclStat i Nothing) + : (AssignStat (ValExpr (JVar i')) v) + : xs + ) + | i == i' + = prettyBlock' r (DeclStat i (Just v) : xs) + +-- resugar for loops with/without var declaration +prettyBlock' r ( (DeclStat i (Just v0)) + : (WhileStat False p (BlockStat bs)) + : xs + ) + | not (null flat) && isForUpdStat (last flat) + = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs + where + flat = flattenBlocks bs +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0) + : (WhileStat False p (BlockStat bs)) + : xs + ) + | not (null flat) && isForUpdStat (last flat) + = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs + where + flat = flattenBlocks bs + +-- global function (does not preserve semantics but works for GHCJS) +prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b)))) + : xs + ) + = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) + (jsToDocR r b) + ) : prettyBlock' r xs +-- modify/assign operators +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) + : xs + ) + | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) + : xs + ) + | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e)) + : xs + ) + | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs +prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e)) + : xs + ) + | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs + + +prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs +prettyBlock' _ [] = [] + +-- build the for block +mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc +mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond) + (jsToDocR r $ BlockStat sb) + where + c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0 + | otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0 + forCond = parens $ hcat $ interSemi + [ c0 + , jsToDocR r p + , parens (jsToDocR r s1) + ] + +-- check if a statement is suitable to be converted to something in the for(;;x) position +isForUpdStat :: JStat -> Bool +isForUpdStat UOpStat {} = True +isForUpdStat AssignStat {} = True +isForUpdStat ApplStat {} = True +isForUpdStat _ = False + +interSemi :: [Doc] -> [Doc] +interSemi [] = [PP.empty] +interSemi [s] = [s] +interSemi (x:xs) = x <> text ";" : interSemi xs + +addSemi :: Doc -> Doc +addSemi x = x <> text ";" diff --git a/compiler/GHC/StgToJS/Profiling.hs b/compiler/GHC/StgToJS/Profiling.hs new file mode 100644 index 0000000000..cd27604082 --- /dev/null +++ b/compiler/GHC/StgToJS/Profiling.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Profiling + ( initCostCentres + , emitCostCentreDecl + , emitCostCentreStackDecl + , enterCostCentreFun + , enterCostCentreThunk + , setCC + , pushRestoreCCS + , jCurrentCCS + , jCafCCS + , jSystemCCS + , costCentreLbl + , costCentreStackLbl + , singletonCCSLbl + , ccsVarJ + -- * Predicates + , profiling + , ifProfiling + , ifProfilingM + -- * helpers + , profStat + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Regs +import GHC.StgToJS.Types +import GHC.StgToJS.Symbols +import GHC.StgToJS.Monad + +import GHC.Types.CostCentre + +import GHC.Data.FastString +import GHC.Unit.Module +import GHC.Utils.Encoding +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Control.Monad.Trans.State.Strict as State + +-------------------------------------------------------------------------------- +-- Initialization + +initCostCentres :: CollectedCCs -> G () +initCostCentres (local_CCs, singleton_CCSs) = do + mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs + +emitCostCentreDecl :: CostCentre -> G () +emitCostCentreDecl cc = do + ccsLbl <- costCentreLbl cc + let is_caf = isCafCC cc + label = costCentreUserName cc + modl = moduleNameString $ moduleName $ cc_mod cc + loc = renderWithContext defaultSDocContext (ppr (costCentreSrcSpan cc)) + js = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CC") + [ toJExpr label + , toJExpr modl + , toJExpr loc + , toJExpr is_caf + ]) + emitGlobal js + +emitCostCentreStackDecl :: CostCentreStack -> G () +emitCostCentreStackDecl ccs = + case maybeSingletonCCS ccs of + Just cc -> do + ccsLbl <- singletonCCSLbl cc + ccLbl <- costCentreLbl cc + let js = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CCS") [null_, toJExpr ccLbl]) + emitGlobal js + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +-------------------------------------------------------------------------------- +-- Entering to cost-centres + +enterCostCentreFun :: CostCentreStack -> JStat +enterCostCentreFun ccs + | isCurrentCCS ccs = ApplStat (var "h$enterFunCCS") [jCurrentCCS, r1 .^ "cc"] + | otherwise = mempty -- top-level function, nothing to do + +enterCostCentreThunk :: JStat +enterCostCentreThunk = ApplStat (var "h$enterThunkCCS") [r1 .^ "cc"] + +setCC :: CostCentre -> Bool -> Bool -> G JStat +setCC cc _tick True = do + ccI@(TxtI _ccLbl) <- costCentreLbl cc + addDependency $ OtherSymb (cc_mod cc) + (moduleGlobalSymbol $ cc_mod cc) + return $ jCurrentCCS |= ApplExpr (var "h$pushCostCentre") [jCurrentCCS, toJExpr ccI] +setCC _cc _tick _push = return mempty + +pushRestoreCCS :: JStat +pushRestoreCCS = ApplStat (var "h$pushRestoreCCS") [] + +-------------------------------------------------------------------------------- +-- Some cost-centre stacks to be used in generator + +jCurrentCCS :: JExpr +jCurrentCCS = var "h$currentThread" .^ "ccs" + +jCafCCS :: JExpr +jCafCCS = var "h$CAF" + +jSystemCCS :: JExpr +jSystemCCS = var "h$CCS_SYSTEM" +-------------------------------------------------------------------------------- +-- Helpers for generating profiling related things + +profiling :: G Bool +profiling = csProf <$> getSettings + +ifProfiling :: Monoid m => m -> G m +ifProfiling m = do + prof <- profiling + return $ if prof then m else mempty + +ifProfilingM :: Monoid m => G m -> G m +ifProfilingM m = do + prof <- profiling + if prof then m else return mempty + +-- | If profiling is enabled, then use input JStat, else ignore +profStat :: StgToJSConfig -> JStat -> JStat +profStat cfg e = if csProf cfg then e else mempty +-------------------------------------------------------------------------------- +-- Generating cost-centre and cost-centre stack variables + +costCentreLbl' :: CostCentre -> G String +costCentreLbl' cc = do + curModl <- State.gets gsModule + let lbl = renderWithContext defaultSDocContext + $ withPprStyle PprCode (ppr cc) + return . ("h$"++) . zEncodeString $ + moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl + +costCentreLbl :: CostCentre -> G Ident +costCentreLbl cc = TxtI . mkFastString <$> costCentreLbl' cc + +costCentreStackLbl' :: CostCentreStack -> G (Maybe String) +costCentreStackLbl' ccs = do + ifProfilingM f + where + f | isCurrentCCS ccs = return $ Just "h$currentThread.ccs" + | dontCareCCS == ccs = return $ Just "h$CCS_DONT_CARE" + | otherwise = + case maybeSingletonCCS ccs of + Just cc -> Just <$> singletonCCSLbl' cc + Nothing -> pure Nothing + +costCentreStackLbl :: CostCentreStack -> G (Maybe Ident) +costCentreStackLbl ccs = fmap (TxtI . mkFastString) <$> costCentreStackLbl' ccs + +singletonCCSLbl' :: CostCentre -> G String +singletonCCSLbl' cc = do + curModl <- State.gets gsModule + ccLbl <- costCentreLbl' cc + let ccsLbl = ccLbl ++ "_ccs" + return . zEncodeString $ mconcat + [ moduleNameColons (moduleName curModl) + , "_" + , ccsLbl + ] + +singletonCCSLbl :: CostCentre -> G Ident +singletonCCSLbl cc = TxtI . mkFastString <$> singletonCCSLbl' cc + +ccsVarJ :: CostCentreStack -> G (Maybe JExpr) +ccsVarJ ccs = do + prof <- profiling + if prof + then fmap (ValExpr . JVar) <$> costCentreStackLbl ccs + else pure Nothing diff --git a/compiler/GHC/StgToJS/Regs.hs b/compiler/GHC/StgToJS/Regs.hs new file mode 100644 index 0000000000..ea482d4036 --- /dev/null +++ b/compiler/GHC/StgToJS/Regs.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Regs + ( StgReg (..) + , Special(..) + , sp + , stack + , r1, r2, r3, r4 + , regsFromR1 + , regsFromR2 + , jsRegsFromR1 + , jsRegsFromR2 + , StgRet (..) + , jsRegToInt + , intToJSReg + , jsReg + , maxReg + , minReg + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Data.FastString + +import Data.Array +import Data.Char + +-- | General purpose "registers" +-- +-- The JS backend arbitrarily supports 128 registers +data StgReg + = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 + | R9 | R10 | R11 | R12 | R13 | R14 | R15 | R16 + | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 + | R25 | R26 | R27 | R28 | R29 | R30 | R31 | R32 + | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40 + | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 + | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56 + | R57 | R58 | R59 | R60 | R61 | R62 | R63 | R64 + | R65 | R66 | R67 | R68 | R69 | R70 | R71 | R72 + | R73 | R74 | R75 | R76 | R77 | R78 | R79 | R80 + | R81 | R82 | R83 | R84 | R85 | R86 | R87 | R88 + | R89 | R90 | R91 | R92 | R93 | R94 | R95 | R96 + | R97 | R98 | R99 | R100 | R101 | R102 | R103 | R104 + | R105 | R106 | R107 | R108 | R109 | R110 | R111 | R112 + | R113 | R114 | R115 | R116 | R117 | R118 | R119 | R120 + | R121 | R122 | R123 | R124 | R125 | R126 | R127 | R128 + deriving (Eq, Ord, Show, Enum, Bounded, Ix) + +-- | Stack registers +data Special + = Stack + | Sp + deriving (Show, Eq) + +-- | Return registers +-- +-- Extra results from foreign calls can be stored here (while first result is +-- directly returned) +data StgRet = Ret1 | Ret2 | Ret3 | Ret4 | Ret5 | Ret6 | Ret7 | Ret8 | Ret9 | Ret10 + deriving (Eq, Ord, Show, Enum, Bounded, Ix) + +instance ToJExpr Special where + toJExpr Stack = var "h$stack" + toJExpr Sp = var "h$sp" + +instance ToJExpr StgReg where + toJExpr r = registers ! r + +instance ToJExpr StgRet where + toJExpr r = rets ! r + +--------------------------------------------------- +-- helpers +--------------------------------------------------- + +sp :: JExpr +sp = toJExpr Sp + +stack :: JExpr +stack = toJExpr Stack + +r1, r2, r3, r4 :: JExpr +r1 = toJExpr R1 +r2 = toJExpr R2 +r3 = toJExpr R3 +r4 = toJExpr R4 + + +jsRegToInt :: StgReg -> Int +jsRegToInt = (+1) . fromEnum + +intToJSReg :: Int -> StgReg +intToJSReg r = toEnum (r - 1) + +jsReg :: Int -> JExpr +jsReg r = toJExpr (intToJSReg r) + +maxReg :: Int +maxReg = jsRegToInt maxBound + +minReg :: Int +minReg = jsRegToInt minBound + +-- | List of registers, starting from R1 +regsFromR1 :: [StgReg] +regsFromR1 = enumFrom R1 + +-- | List of registers, starting from R2 +regsFromR2 :: [StgReg] +regsFromR2 = tail regsFromR1 + +-- | List of registers, starting from R1 as JExpr +jsRegsFromR1 :: [JExpr] +jsRegsFromR1 = fmap toJExpr regsFromR1 + +-- | List of registers, starting from R2 as JExpr +jsRegsFromR2 :: [JExpr] +jsRegsFromR2 = tail jsRegsFromR1 + +--------------------------------------------------- +-- caches +--------------------------------------------------- + +-- cache JExpr representing StgReg +registers :: Array StgReg JExpr +registers = listArray (minBound, maxBound) (map regN regsFromR1) + where + regN r + | fromEnum r < 32 = var . mkFastString . ("h$"++) . map toLower . show $ r + | otherwise = IdxExpr (var "h$regs") + (toJExpr ((fromEnum r) - 32)) + +-- cache JExpr representing StgRet +rets :: Array StgRet JExpr +rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1)) + where + retN = var . mkFastString . ("h$"++) . map toLower . show diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs new file mode 100644 index 0000000000..55e1a3f312 --- /dev/null +++ b/compiler/GHC/StgToJS/Rts/Rts.hs @@ -0,0 +1,661 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -O0 #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Rts.Rts +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Top level driver of the JavaScript Backend RTS. This file is an +-- implementation of the JS RTS for the JS backend written as an EDSL in +-- Haskell. It assumes the existence of pre-generated JS functions, included as +-- js-sources in base. These functions are similarly assumed for non-inline +-- Primops, See 'GHC.StgToJS.Prim'. Most of the elements in this module are +-- constants in Haskell Land which define pieces of the JS RTS. +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Rts.Rts where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Apply +import GHC.StgToJS.Closure +import GHC.StgToJS.Heap +import GHC.StgToJS.Printer +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Types +import GHC.StgToJS.Stack + +import GHC.Data.FastString +import GHC.Types.Unique.Map + +import Data.Array +import Data.Monoid +import Data.Char (toLower, toUpper) +import qualified Data.Bits as Bits + +-- | The garbageCollector resets registers and result variables. +garbageCollector :: JStat +garbageCollector = + mconcat [ TxtI "h$resetRegisters" ||= jLam (mconcat $ map resetRegister [minBound..maxBound]) + , TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound]) + ] + +-- | Reset the register 'r' in JS Land. Note that this "resets" by setting the +-- register to a dummy variable called "null", /not/ by setting to JS's nil +-- value. +resetRegister :: StgReg -> JStat +resetRegister r = toJExpr r |= null_ + +-- | Reset the return variable 'r' in JS Land. Note that this "resets" by +-- setting the register to a dummy variable called "null", /not/ by setting to +-- JS's nil value. +resetResultVar :: StgRet -> JStat +resetResultVar r = toJExpr r |= null_ + +-- | Define closures based on size, these functions are syntactic sugar, e.g., a +-- Haskell function which generates some useful JS. Each Closure constructor +-- follows the naming convention h$cN, where N is a natural number. For example, +-- h$c (with the nat omitted) is a JS Land Constructor for a closure in JS land +-- which has a single entry function 'f', and no fields; identical to h$c0. h$c1 +-- is a JS Land Constructor for a closure with an entry function 'f', and a +-- /single/ field 'x1', 'Just foo' is an example of this kind of closure. h$c2 +-- is a JS Land Constructor for a closure with an entry function and two data +-- fields: 'x1' and 'x2'. And so on. Note that this has JIT performance +-- implications; you should use h$c1, h$c2, h$c3, ... h$c24 instead of making +-- objects manually so layouts and fields can be changed more easily and so the +-- JIT can optimize better. +closureConstructors :: StgToJSConfig -> JStat +closureConstructors s = BlockStat + [ declClsConstr "h$c" ["f"] $ Closure + { clEntry = var "f" + , clField1 = null_ + , clField2 = null_ + , clMeta = 0 + , clCC = ccVal + } + , declClsConstr "h$c0" ["f"] $ Closure + { clEntry = var "f" + , clField1 = null_ + , clField2 = null_ + , clMeta = 0 + , clCC = ccVal + } + , declClsConstr "h$c1" ["f", "x1"] $ Closure + { clEntry = var "f" + , clField1 = var "x1" + , clField2 = null_ + , clMeta = 0 + , clCC = ccVal + } + , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure + { clEntry = var "f" + , clField1 = var "x1" + , clField2 = var "x2" + , clMeta = 0 + , clCC = ccVal + } + , mconcat (map mkClosureCon [3..24]) + , mconcat (map mkDataFill [1..24]) + ] + where + prof = csProf s + (ccArg,ccVal) + -- the cc argument happens to be named just like the cc field... + | prof = ([TxtI closureCC_], Just (var closureCC_)) + | otherwise = ([], Nothing) + addCCArg as = map TxtI as ++ ccArg + addCCArg' as = as ++ ccArg + + declClsConstr i as cl = TxtI i ||= ValExpr (JFunc (addCCArg as) + ( jVar $ \x -> + [ checkC + , x |= newClosure cl + , notifyAlloc x + , traceAlloc x + , returnS x + ] + )) + + traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x] + | otherwise = mempty + + notifyAlloc x | csDebugAlloc s = appS "h$debugAlloc_notifyAlloc" [x] + | otherwise = mempty + + -- only JSVal can typically contain undefined or null + -- although it's possible (and legal) to make other Haskell types + -- to contain JS refs directly + -- this can cause false positives here + checkC :: JStat + checkC | csAssertRts s = + jVar $ \msg -> + jwhenS (var "arguments" .! 0 .!==. jString "h$baseZCGHCziJSziPrimziJSVal_con_e") + (loop 1 (.<. var "arguments" .^ "length") + (\i -> + mconcat [msg |= jString "warning: undefined or null in argument: " + + i + + jString " allocating closure: " + (var "arguments" .! 0 .^ "n") + , appS "h$log" [msg] + , jwhenS (var "console" .&&. (var "console" .^ "trace")) ((var "console" .^ "trace") `ApplStat` [msg]) + , postIncrS i + ]) + + ) + | otherwise = mempty + + -- h$d is never used for JSVal (since it's only for constructors with + -- at least three fields, so we always warn here + checkD | csAssertRts s = + loop 0 (.<. var "arguments" .^ "length") + (\i -> jwhenS ((var "arguments" .! i .===. null_) + .||. (var "arguments" .! i .===. undefined_)) + (jVar $ \msg -> + mconcat [ msg |= jString "warning: undefined or null in argument: " + i + jString " allocating fields" + , jwhenS (var "console" .&&. (var "console" .^ "trace")) + ((var "console" .^ "trace") `ApplStat` [msg]) + ])) + + | otherwise = mempty + + mkClosureCon :: Int -> JStat + mkClosureCon n = funName ||= toJExpr fun + where + funName = TxtI $ mkFastString ("h$c" ++ show n) + -- args are: f x1 x2 .. xn [cc] + args = TxtI "f" : addCCArg' (map (TxtI . mkFastString . ('x':) . show) [(1::Int)..n]) + fun = JFunc args funBod + -- x1 goes into closureField1. All the other args are bundled into an + -- object in closureField2: { d1 = x2, d2 = x3, ... } + -- + extra_args = ValExpr . JHash . listToUniqMap $ zip + (map (mkFastString . ('d':) . show) [(1::Int)..]) + (map (toJExpr . TxtI . mkFastString . ('x':) . show) [2..n]) + + funBod = jVar $ \x -> + [ checkC + , x |= newClosure Closure + { clEntry = var "f" + , clField1 = var "x1" + , clField2 = extra_args + , clMeta = 0 + , clCC = ccVal + } + , notifyAlloc x + , traceAlloc x + , returnS x + ] + + mkDataFill :: Int -> JStat + mkDataFill n = funName ||= toJExpr fun + where + funName = TxtI $ mkFastString ("h$d" ++ show n) + ds = map (mkFastString . ('d':) . show) [(1::Int)..n] + extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds + fun = JFunc (map TxtI ds) (checkD <> returnS extra_args) + +-- | JS Payload to perform stack manipulation in the RTS +stackManip :: JStat +stackManip = mconcat (map mkPush [1..32]) <> + mconcat (map mkPpush [1..255]) + where + mkPush :: Int -> JStat + mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) + as = map (TxtI . mkFastString . ('x':) . show) [1..n] + fun = JFunc as ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + [1..] as)) + in funName ||= toJExpr fun + + -- partial pushes, based on bitmap, increases Sp by highest bit + mkPpush :: Integer -> JStat + mkPpush sig | sig Bits..&. (sig+1) == 0 = mempty -- already handled by h$p + mkPpush sig = let funName = TxtI $ mkFastString ("h$pp" ++ show sig) + bits = bitsIdx sig + n = length bits + h = last bits + args = map (TxtI . mkFastString . ('x':) . show) [1..n] + fun = JFunc args $ + mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) + ] + in funName ||= toJExpr fun + +bitsIdx :: Integer -> [Int] +bitsIdx n | n < 0 = error "bitsIdx: negative" + | otherwise = go n 0 + where + go 0 _ = [] + go m b | Bits.testBit m b = b : go (Bits.clearBit m b) (b+1) + | otherwise = go (Bits.clearBit m b) (b+1) + +bhLneStats :: StgToJSConfig -> JExpr -> JExpr -> JStat +bhLneStats _s p frameSize = + jVar $ \v -> + mconcat [ v |= stack .! p + , ifS v + ((sp |= sp - frameSize) + <> ifS (v .===. var "h$blackhole") + (returnS $ app "h$throw" [var "h$baseZCControlziExceptionziBasezinonTermination", false_]) + (mconcat [r1 |= v + , sp |= sp - frameSize + , returnStack + ])) + ((stack .! p |= var "h$blackhole") <> returnS null_) + ] + + +-- | JS payload to declare the registers +declRegs :: JStat +declRegs = + mconcat [ TxtI "h$regs" ||= toJExpr (JList []) + , mconcat (map declReg (enumFromTo R1 R32)) + , regGettersSetters + , loadRegs + ] + where + declReg r = (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) r + <> BlockStat [AssignStat (toJExpr r) (ValExpr (JInt 0))] -- [j| `r` = 0; |] + +-- | JS payload to define getters and setters on the registers. +regGettersSetters :: JStat +regGettersSetters = + mconcat [ TxtI "h$getReg" ||= jLam (\n -> SwitchStat n getRegCases mempty) + , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty) + ] + where + getRegCases = + map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) regsFromR1 + setRegCases v = + map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) regsFromR1 + +-- | JS payload that defines the functions to load each register +loadRegs :: JStat +loadRegs = mconcat $ map mkLoad [1..32] + where + mkLoad :: Int -> JStat + mkLoad n = let args = map (TxtI . mkFastString . ("x"++) . show) [1..n] + assign = zipWith (\a r -> toJExpr r |= toJExpr a) + args (reverse $ take n regsFromR1) + fname = TxtI $ mkFastString ("h$l" ++ show n) + fun = JFunc args (mconcat assign) + in fname ||= toJExpr fun + +-- | Assign registers R1 ... Rn in descending order, that is assign Rn first. +-- This function uses the 'assignRegs'' array to construct functions which set +-- the registers. +assignRegs :: StgToJSConfig -> [JExpr] -> JStat +assignRegs _ [] = mempty +assignRegs s xs + | l <= 32 && not (csInlineLoadRegs s) + = ApplStat (ValExpr (JVar $ assignRegs'!l)) (reverse xs) + | otherwise = mconcat . reverse $ + zipWith (\r ex -> toJExpr r |= ex) (take l regsFromR1) xs + where + l = length xs + +-- | JS payload which defines an array of function symbols that set N registers +-- from M parameters. For example, h$l2 compiles to: +-- @ +-- function h$l4(x1, x2, x3, x4) { +-- h$r4 = x1; +-- h$r3 = x2; +-- h$r2 = x3; +-- h$r1 = x4; +-- }; +-- @ +assignRegs' :: Array Int Ident +assignRegs' = listArray (1,32) (map (TxtI . mkFastString . ("h$l"++) . show) [(1::Int)..32]) + +-- | JS payload to declare return variables. +declRets :: JStat +declRets = mconcat $ map (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) (enumFrom Ret1) + +-- | JS payload defining the types closures. +closureTypes :: JStat +closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> closureTypeName + where + mkClosureType :: ClosureType -> JStat + mkClosureType c = let s = TxtI . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE" + in s ||= toJExpr c + closureTypeName :: JStat + closureTypeName = + TxtI "h$closureTypeName" ||= jLam (\c -> + mconcat (map (ifCT c) [minBound..maxBound]) + <> returnS (jString "InvalidClosureType")) + + ifCT :: JExpr -> ClosureType -> JStat + ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) + +-- | JS payload declaring the RTS functions. +rtsDecls :: JStat +rtsDecls = jsSaturate (Just "h$RTSD") $ + mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread + , TxtI "h$stack" ||= null_ -- stack for the current thread + , TxtI "h$sp" ||= 0 -- stack pointer for the current thread + , TxtI "h$initStatic" ||= toJExpr (JList []) -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs + , TxtI "h$staticThunks" ||= toJExpr (jhFromList []) -- funcName -> heapidx map for srefs + , TxtI "h$staticThunksArr" ||= toJExpr (JList []) -- indices of updatable thunks in static heap + , TxtI "h$CAFs" ||= toJExpr (JList []) + , TxtI "h$CAFsReset" ||= toJExpr (JList []) + -- stg registers + , declRegs + , declRets] + +-- | print the embedded RTS to a String +rtsText :: StgToJSConfig -> String +rtsText = show . pretty . rts + +-- | print the RTS declarations to a String. +rtsDeclsText :: String +rtsDeclsText = show . pretty $ rtsDecls + +-- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' +rts :: StgToJSConfig -> JStat +rts = jsSaturate (Just "h$RTS") . rts' + +-- | JS Payload which defines the embedded RTS. +rts' :: StgToJSConfig -> JStat +rts' s = + mconcat [ closureConstructors s + , garbageCollector + , stackManip + , TxtI "h$rts_traceForeign" ||= toJExpr (csTraceForeign s) + , TxtI "h$rts_profiling" ||= toJExpr (csProf s) + , TxtI "h$ct_fun" ||= toJExpr Fun + , TxtI "h$ct_con" ||= toJExpr Con + , TxtI "h$ct_thunk" ||= toJExpr Thunk + , TxtI "h$ct_pap" ||= toJExpr Pap + , TxtI "h$ct_blackhole" ||= toJExpr Blackhole + , TxtI "h$ct_stackframe" ||= toJExpr StackFrame + , TxtI "h$vt_ptr" ||= toJExpr PtrV + , TxtI "h$vt_void" ||= toJExpr VoidV + , TxtI "h$vt_double" ||= toJExpr IntV + , TxtI "h$vt_long" ||= toJExpr LongV + , TxtI "h$vt_addr" ||= toJExpr AddrV + , TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV + , TxtI "h$vt_obj" ||= toJExpr ObjV + , TxtI "h$vt_arr" ||= toJExpr ArrV + , TxtI "h$bh" ||= jLam (bhStats s True) + , TxtI "h$bh_lne" ||= jLam (\x frameSize -> bhLneStats s x frameSize) + , closure (ClosureInfo (TxtI "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty) + (appS "throw" [jString "oops: entered black hole"]) + , closure (ClosureInfo (TxtI "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty) + (appS "throw" [jString "oops: entered multiple times"]) + , closure (ClosureInfo (TxtI "h$done") (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty) + (appS "h$finishThread" [var "h$currentThread"] <> returnS (var "h$reschedule")) + , closure (ClosureInfo (TxtI "h$doneMain_e") (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty) + (returnS (var "h$doneMain")) + , conClosure (TxtI "h$false_e") "GHC.Types.False" (CILayoutFixed 0 []) 1 + , conClosure (TxtI "h$true_e" ) "GHC.Types.True" (CILayoutFixed 0 []) 2 + -- generic data constructor with 1 non-heapobj field + , conClosure (TxtI "h$data1_e") "data1" (CILayoutFixed 1 [ObjV]) 1 + -- generic data constructor with 2 non-heapobj fields + , conClosure (TxtI "h$data2_e") "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1 + , closure (ClosureInfo (TxtI "h$noop_e") (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty) + (returnS (stack .! sp)) + <> (TxtI "h$noop" ||= ApplExpr (var "h$c0") (var "h$noop_e" : [jSystemCCS | csProf s])) + , closure (ClosureInfo (TxtI "h$catch_e") (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty) + (adjSpN' 3 <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$dataToTag_e") (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeof r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0) + , adjSpN' 1 + , returnS (stack .! sp) + ] + -- function application to one argument + , closure (ClosureInfo (TxtI "h$ap1_e") (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 -> + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , returnS (app "h$ap_1_1_fast" []) + ]) + -- function application to two arguments + , closure (ClosureInfo (TxtI "h$ap2_e") (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 d3 -> + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 .^ "d1" + , d3 |= closureField2 r1 .^ "d2" + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , returnS (app "h$ap_2_2_fast" []) + ]) + -- function application to three arguments + , closure (ClosureInfo (TxtI "h$ap3_e") (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty) + (jVar $ \d1 d2 d3 d4 -> + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 .^ "d1" + , d3 |= closureField2 r1 .^ "d2" + , d4 |= closureField2 r1 .^ "d3" + , appS "h$bh" [] + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , r4 |= d4 + , returnS (app "h$ap_3_3_fast" []) + ]) + -- select first field + , closure (ClosureInfo (TxtI "h$select1_e") (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar $ \t -> + mconcat [ t |= closureField1 r1 + , adjSp' 3 + , stack .! (sp - 2) |= r1 + , stack .! (sp - 1) |= var "h$upd_frame" + , stack .! sp |= var "h$select1_ret" + , closureEntry r1 |= var "h$blackhole" + , closureField1 r1 |= var "h$currentThread" + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app "h$ap_0_0_fast" []) + ]) + , closure (ClosureInfo (TxtI "h$select1_ret") (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty) + ((r1 |= closureField1 r1) + <> adjSpN' 1 + <> returnS (app "h$ap_0_0_fast" []) + ) + -- select second field of a two-field constructor + , closure (ClosureInfo (TxtI "h$select2_e") (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + (jVar $ \t -> + mconcat [t |= closureField1 r1 + , adjSp' 3 + , stack .! (sp - 2) |= r1 + , stack .! (sp - 1) |= var "h$upd_frame" + , stack .! sp |= var "h$select2_ret" + , closureEntry r1 |= var "h$blackhole" + , closureField1 r1 |= var "h$currentThread" + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app "h$ap_0_0_fast" []) + ] + ) + , closure (ClosureInfo (TxtI "h$select2_ret") (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty) + $ mconcat [ r1 |= closureField2 r1 + , adjSpN' 1 + , returnS (app "h$ap_0_0_fast" []) + ] + , closure (ClosureInfo (TxtI "h$keepAlive_e") (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (mconcat [ adjSpN' 2 + , returnS (stack .! sp) + ] + ) + -- a thunk that just raises a synchronous exception + , closure (ClosureInfo (TxtI "h$raise_e") (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty) + (returnS (app "h$throw" [closureField1 r1, false_])) + , closure (ClosureInfo (TxtI "h$raiseAsync_e") (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty) + (returnS (app "h$throw" [closureField1 r1, true_])) + , closure (ClosureInfo (TxtI "h$raiseAsync_frame") (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty) + (jVar $ \ex -> + mconcat [ ex |= stack .! (sp - 1) + , adjSpN' 2 + , returnS (app "h$throw" [ex, true_]) + ]) + {- reduce result if it's a thunk, follow if it's an ind + add this to the stack if you want the outermost result + to always be reduced to whnf, and not an ind + -} + , closure (ClosureInfo (TxtI "h$reduce") (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty) + (ifS (isThunk r1) + (returnS (r1 .^ "f")) + (adjSpN' 1 <> returnS (stack .! sp)) + ) + , rtsApply s + , closureTypes + , closure (ClosureInfo (TxtI "h$runio_e") (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + $ mconcat [ r1 |= closureField1 r1 + , stack .! PreInc sp |= var "h$ap_1_0" + , returnS (var "h$ap_1_0") + ] + , closure (ClosureInfo (TxtI "h$flushStdout_e") (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty) + $ mconcat [ r1 |= var "h$baseZCGHCziIOziHandlezihFlush" + , r2 |= var "h$baseZCGHCziIOziHandleziFDzistdout" + , returnS (app "h$ap_1_1_fast" []) + ] + , TxtI "h$flushStdout" ||= app "h$static_thunk" [var "h$flushStdout_e"] + -- the scheduler pushes this frame when suspending a thread that + -- has not called h$reschedule explicitly + , closure (ClosureInfo (TxtI "h$restoreThread") (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty) + (jVar $ \f frameSize nregs -> + mconcat [f |= stack .! (sp - 2) + , frameSize |= stack .! (sp - 1) + , nregs |= frameSize - 3 + , loop 1 (.<=. nregs) + (\i -> appS "h$setReg" [i, stack .! (sp - 2 - i)] <> postIncrS i) + , sp |= sp - frameSize + , returnS f + ]) + -- return a closure in the stack frame to the next thing on the stack + , closure (ClosureInfo (TxtI "h$return") (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + ((r1 |= stack .! (sp - 1)) + <> adjSpN' 2 + <> returnS (stack .! sp)) + -- return a function in the stack frame for the next call + , closure (ClosureInfo (TxtI "h$returnf") (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar $ \r -> + mconcat [ r |= stack .! (sp - 1) + , adjSpN' 2 + , returnS r + ]) + -- return this function when the scheduler needs to come into action + -- (yield, delay etc), returning thread needs to push all relevant + -- registers to stack frame, thread will be resumed by calling the stack top + , closure (ClosureInfo (TxtI "h$reschedule") (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty) + (returnS $ var "h$reschedule") + -- debug thing, insert on stack to dump current result, should be boxed + , closure (ClosureInfo (TxtI "h$dumpRes") (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty) + (jVar $ \re -> + mconcat [ appS "h$log" [jString "h$dumpRes result: " + stack .! (sp-1)] + , appS "h$log" [r1] + , appS "h$log" [app "h$collectProps" [r1]] + , jwhenS ((r1 .^ "f") .&&. (r1 .^ "f" .^ "n")) + (appS "h$log" [jString "name: " + r1 .^ "f" .^ "n"]) + , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureField1_]) + (appS "h$log" [jString "d1: " + closureField1 r1]) + , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureField2_]) + (appS "h$log" [jString "d2: " + closureField2 r1]) + , jwhenS (r1 .^ "f") $ mconcat + [ re |= New (app "RegExp" [jString "([^\\n]+)\\n(.|\\n)*"]) + , appS "h$log" [jString "function" + + ApplExpr (ApplExpr ((jString "" + r1 .^ "f") .^ "substring") [0, 50] .^ "replace") [r1, jString "$1"]] + ] + , adjSpN' 2 + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo (TxtI "h$resume_e") (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty) + (jVar $ \ss -> + mconcat [ss |= closureField1 r1 + , updateThunk' s + , loop 0 (.<. ss .^ "length") (\i -> (stack .! (sp+1+i) |= ss .! i) + <> postIncrS i) + , sp |= sp + ss .^ "length" + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo (TxtI "h$unmaskFrame") (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 0) + <> adjSpN' 1 + -- back to scheduler to give us async exception if pending + <> ifS (var "h$currentThread" .^ "excep" .^ "length" .>. 0) + (push' s [r1, var "h$return"] <> returnS (var "h$reschedule")) + (returnS (stack .! sp))) + , closure (ClosureInfo (TxtI "h$maskFrame") (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 2) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$maskUnintFrame") (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty) + ((var "h$currentThread" .^ "mask" |= 1) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$unboxFFIResult") (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar $ \d -> + mconcat [d |= closureField1 r1 + , loop 0 (.<. d .^ "length") (\i -> appS "h$setReg" [i + 1, d .! i] <> postIncrS i) + , adjSpN' 1 + , returnS (stack .! sp) + ]) + , closure (ClosureInfo (TxtI "h$unbox_e") (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty) + ((r1 |= closureField1 r1) <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$retryInterrupted") (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar $ \a -> + mconcat [ a |= stack .! (sp - 1) + , adjSpN' 2 + , returnS (ApplExpr (a .! 0 .^ "apply") [var "this", ApplExpr (a .^ "slice") [1]]) + ]) + , closure (ClosureInfo (TxtI "h$atomically_e") (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (ifS (app "h$stmValidateTransaction" []) + (appS "h$stmCommitTransaction" [] + <> adjSpN' 2 + <> returnS (stack .! sp)) + (returnS (app "h$stmStartTransaction" [stack .! (sp - 1)]))) + + , closure (ClosureInfo (TxtI "h$stmCatchRetry_e") (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (adjSpN' 2 + <> appS "h$stmCommitTransaction" [] + <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$catchStm_e") (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty) + (adjSpN' 4 + <> appS "h$stmCommitTransaction" [] + <> returnS (stack .! sp)) + , closure (ClosureInfo (TxtI "h$stmResumeRetry_e") (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar $ \blocked -> + mconcat [ jwhenS (stack .! (sp - 2) .!==. var "h$atomically_e") + (appS "throw" [jString "h$stmResumeRetry_e: unexpected value on stack"]) + , blocked |= stack .! (sp - 1) + , adjSpN' 2 + , appS "h$stmRemoveBlockedThread" [blocked, var "h$currentThread"] + , returnS (app "h$stmStartTransaction" [stack .! (sp - 1)]) + ]) + , closure (ClosureInfo (TxtI "h$lazy_e") (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty) + (jVar $ \x -> + mconcat [x |= ApplExpr (closureField1 r1) [] + , appS "h$bh" [] + , profStat s enterCostCentreThunk + , r1 |= x + , returnS (stack .! sp) + ]) + -- Top-level statements to generate only in profiling mode + , profStat s (closure (ClosureInfo (TxtI "h$setCcs_e") (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (appS "h$restoreCCS" [ stack .! (sp - 1)] + <> adjSpN' 2 + <> returnS (stack .! sp))) + ] diff --git a/compiler/GHC/StgToJS/Rts/Types.hs b/compiler/GHC/StgToJS/Rts/Types.hs new file mode 100644 index 0000000000..f1a0276d5d --- /dev/null +++ b/compiler/GHC/StgToJS/Rts/Types.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP, + FlexibleInstances, + OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Rts.Apply +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Types and utility functions used in the JS RTS. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Rts.Types where + +import GHC.Prelude + +import GHC.JS.Make +import GHC.JS.Syntax +import GHC.StgToJS.Regs +import GHC.StgToJS.Types + +-------------------------------------------------------------------------------- +-- Syntactic Sugar for some Utilities we want in JS land +-------------------------------------------------------------------------------- + +-- | Syntactic sugar, i.e., a Haskell function which generates useful JS code. +-- Given a @JExpr@, 'ex', inject a trace statement on 'ex' in the compiled JS +-- program +traceRts :: StgToJSConfig -> JExpr -> JStat +traceRts s ex | (csTraceRts s) = appS "h$log" [ex] + | otherwise = mempty + +-- | Syntactic sugar. Given a @JExpr@, 'ex' which is assumed to be a predicate, +-- and a message 'm', assert that 'not ex' is True, if not throw an exception in +-- JS land with message 'm'. +assertRts :: ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat +assertRts s ex m | csAssertRts s = jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m]) + | otherwise = mempty + +-- | name of the closure 'c' +clName :: JExpr -> JExpr +clName c = c .^ "n" + +-- | Type name of the closure 'c' +clTypeName :: JExpr -> JExpr +clTypeName c = app "h$closureTypeName" [c .^ "t"] + +-- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +stackFrameSize :: JExpr -- ^ assign frame size to this + -> JExpr -- ^ stack frame header function + -> JStat -- ^ size of the frame, including header +stackFrameSize tgt f = + ifS (f .===. var "h$ap_gen") -- h$ap_gen is special + (tgt |= (stack .! (sp - 1) .>>. 8) + 2) + (jVar (\tag -> + mconcat + [tag |= f .^ "size" + , ifS (tag .<. 0) -- if tag is less than 0 + (tgt |= stack .! (sp - 1)) -- set target to stack pointer - 1 + (tgt |= mask8 tag + 1) -- else set to mask'd tag + 1 + ] + )) + +-------------------------------------------------------------------------------- +-- Register utilities +-------------------------------------------------------------------------------- + +-- | Perform the computation 'f', on the range of registers bounded by 'start' +-- and 'end'. +withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat +withRegs start end f = mconcat $ fmap f [start..end] diff --git a/compiler/GHC/StgToJS/Sinker.hs b/compiler/GHC/StgToJS/Sinker.hs new file mode 100644 index 0000000000..6df58d4fcf --- /dev/null +++ b/compiler/GHC/StgToJS/Sinker.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Sinker (sinkPgm) where + +import GHC.Prelude +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Types.Literal +import GHC.Data.Graph.Directed + +import GHC.StgToJS.CoreUtils + +import Data.Char +import Data.Either +import Data.List (partition) +import Data.Maybe + + +-- | Unfloat some top-level unexported things +-- +-- GHC floats constants to the top level. This is fine in native code, but with JS +-- they occupy some global variable name. We can unfloat some unexported things: +-- +-- - global constructors, as long as they're referenced only once by another global +-- constructor and are not in a recursive binding group +-- - literals (small literals may also be sunk if they are used more than once) +sinkPgm :: Module + -> [CgStgTopBinding] + -> (UniqFM Id CgStgExpr, [CgStgTopBinding]) +sinkPgm m pgm = (sunk, map StgTopLifted pgm'' ++ stringLits) + where + selectLifted (StgTopLifted b) = Left b + selectLifted x = Right x + (pgm', stringLits) = partitionEithers (map selectLifted pgm) + (sunk, pgm'') = sinkPgm' m pgm' + +sinkPgm' + :: Module + -- ^ the module, since we treat definitions from the current module + -- differently + -> [CgStgBinding] + -- ^ the bindings + -> (UniqFM Id CgStgExpr, [CgStgBinding]) + -- ^ a map with sunken replacements for nodes, for where the replacement + -- does not fit in the 'StgBinding' AST and the new bindings +sinkPgm' m pgm = + let usedOnce = collectUsedOnce pgm + sinkables = listToUFM $ + concatMap alwaysSinkable pgm ++ + filter ((`elementOfUniqSet` usedOnce) . fst) (concatMap (onceSinkable m) pgm) + isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True + isSunkBind _ = False + in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm) + +-- | always sinkable, values that may be duplicated in the generated code (e.g. +-- small literals) +alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)] +alwaysSinkable (StgRec {}) = [] +alwaysSinkable (StgNonRec b rhs) = case rhs of + StgRhsClosure _ _ _ _ e@(StgLit l) + | isSmallSinkableLit l + , isLocal b + -> [(b,e)] + StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] + | isSmallSinkableLit l + , isLocal b + , isUnboxableCon dc + -> [(b,StgConApp dc cnum as [])] + _ -> [] + +isSmallSinkableLit :: Literal -> Bool +isSmallSinkableLit (LitChar c) = ord c < 100000 +isSmallSinkableLit (LitNumber _ i) = abs i < 100000 +isSmallSinkableLit _ = False + + +-- | once sinkable: may be sunk, but duplication is not ok +onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)] +onceSinkable _m (StgNonRec b rhs) + | Just e <- getSinkable rhs + , isLocal b = [(b,e)] + where + getSinkable = \case + StgRhsCon _ccs dc cnum _ticks args -> Just (StgConApp dc cnum args []) + StgRhsClosure _ _ _ _ e@(StgLit{}) -> Just e + _ -> Nothing +onceSinkable _ _ = [] + +-- | collect all idents used only once in an argument at the top level +-- and never anywhere else +collectUsedOnce :: [CgStgBinding] -> IdSet +collectUsedOnce binds = intersectUniqSets (usedOnce args) (usedOnce top_args) + where + top_args = concatMap collectArgsTop binds + args = concatMap collectArgs binds + usedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet) + g i t@(once, mult) + | i `elementOfUniqSet` mult = t + | i `elementOfUniqSet` once + = (delOneFromUniqSet once i, addOneToUniqSet mult i) + | otherwise = (addOneToUniqSet once i, mult) + +-- | fold over all id in StgArg used at the top level in an StgRhsCon +collectArgsTop :: CgStgBinding -> [Id] +collectArgsTop = \case + StgNonRec _b r -> collectArgsTopRhs r + StgRec bs -> concatMap (collectArgsTopRhs . snd) bs + +collectArgsTopRhs :: CgStgRhs -> [Id] +collectArgsTopRhs = \case + StgRhsCon _ccs _dc _mu _ticks args -> concatMap collectArgsA args + StgRhsClosure {} -> [] + +-- | fold over all Id in StgArg in the AST +collectArgs :: CgStgBinding -> [Id] +collectArgs = \case + StgNonRec _b r -> collectArgsR r + StgRec bs -> concatMap (collectArgsR . snd) bs + +collectArgsR :: CgStgRhs -> [Id] +collectArgsR = \case + StgRhsClosure _x0 _x1 _x2 _x3 e -> collectArgsE e + StgRhsCon _ccs _con _mu _ticks args -> concatMap collectArgsA args + +collectArgsAlt :: CgStgAlt -> [Id] +collectArgsAlt alt = collectArgsE (alt_rhs alt) + +collectArgsE :: CgStgExpr -> [Id] +collectArgsE = \case + StgApp x args + -> x : concatMap collectArgsA args + StgConApp _con _mn args _ts + -> concatMap collectArgsA args + StgOpApp _x args _t + -> concatMap collectArgsA args + StgCase e _b _a alts + -> collectArgsE e ++ concatMap collectArgsAlt alts + StgLet _x b e + -> collectArgs b ++ collectArgsE e + StgLetNoEscape _x b e + -> collectArgs b ++ collectArgsE e + StgTick _i e + -> collectArgsE e + StgLit _ + -> [] + +collectArgsA :: StgArg -> [Id] +collectArgsA = \case + StgVarArg i -> [i] + StgLitArg _ -> [] + +isLocal :: Id -> Bool +isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i) + +-- | since we have sequential initialization, topsort the non-recursive +-- constructor bindings +topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding] +topSortDecls _m binds = rest ++ nr' + where + (nr, rest) = partition isNonRec binds + isNonRec StgNonRec{} = True + isNonRec _ = False + vs = map getV nr + keys = mkUniqSet (map node_key vs) + getV e@(StgNonRec b _) = DigraphNode e b [] + getV _ = error "topSortDecls: getV, unexpected binding" + collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args)) = + [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ] + collectDeps _ = [] + g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr) + nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g] + = error "topSortDecls: unexpected cycle" + | otherwise = map node_payload (topologicalSortG g) diff --git a/compiler/GHC/StgToJS/Stack.hs b/compiler/GHC/StgToJS/Stack.hs new file mode 100644 index 0000000000..0250837f32 --- /dev/null +++ b/compiler/GHC/StgToJS/Stack.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Stack +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- Utilities and wrappers for Stack manipulation in JS Land. +-- +-- In general, functions suffixed with a tick do the actual work, functions +-- suffixed with an "I" are identical to the non-I versions but work on 'Ident's +-- +-- The stack in JS land is held in the special JS array 'h$stack' and the stack +-- pointer is held in 'h$sp'. The top of the stack thus exists at +-- 'h$stack[h$sp]'. h$stack[h$sp + i] where i > 0, moves deeper into the stack +-- into older entries, whereas h$stack[h$sp - i] moves towards the top of the +-- stack. +-- +-- The stack layout algorithm is slightly peculiar. It makes an effort to +-- remember recently popped things so that if these values need to be pushed +-- then they can be quickly. The implementation for this is storing these values +-- above the stack pointer, and the pushing will skip slots that we know we will +-- use and fill in slots marked as unknown. Thus, you may find that our push and +-- pop functions do some non-traditional stack manipulation such as adding slots +-- in pop or removing slots in push. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Stack + ( resetSlots + , isolateSlots + , setSlots + , getSlots + , addSlots + , dropSlots + , addUnknownSlots + , push + , push' + , adjSpN + , adjSpN' + , adjSp' + , adjSp + , pushNN + , pushNN' + , pushN' + , pushN + , pushOptimized' + , pushOptimized + , pushLneFrame + , popN + , popSkip + , popSkipI + , loadSkip + -- * Thunk update + , updateThunk + , updateThunk' + , bhStats + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Ids +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Regs + +import GHC.Types.Id +import GHC.Utils.Misc +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import qualified Data.List as L +import qualified Control.Monad.Trans.State.Strict as State +import Data.Array +import Data.Monoid +import Control.Monad + +-- | Run the action, 'm', with no stack info +resetSlots :: G a -> G a +resetSlots m = do + s <- getSlots + d <- getStackDepth + setSlots [] + a <- m + setSlots s + setStackDepth d + return a + +-- | run the action, 'm', with current stack info, but don't let modifications +-- propagate +isolateSlots :: G a -> G a +isolateSlots m = do + s <- getSlots + d <- getStackDepth + a <- m + setSlots s + setStackDepth d + pure a + +-- | Set stack depth +setStackDepth :: Int -> G () +setStackDepth d = modifyGroup (\s -> s { ggsStackDepth = d}) + +-- | Get stack depth +getStackDepth :: G Int +getStackDepth = State.gets (ggsStackDepth . gsGroup) + +-- | Modify stack depth +modifyStackDepth :: (Int -> Int) -> G () +modifyStackDepth f = modifyGroup (\s -> s { ggsStackDepth = f (ggsStackDepth s) }) + +-- | overwrite our stack knowledge +setSlots :: [StackSlot] -> G () +setSlots xs = modifyGroup (\g -> g { ggsStack = xs}) + +-- | retrieve our current stack knowledge +getSlots :: G [StackSlot] +getSlots = State.gets (ggsStack . gsGroup) + +-- | Modify stack slots +modifySlots :: ([StackSlot] -> [StackSlot]) -> G () +modifySlots f = modifyGroup (\g -> g { ggsStack = f (ggsStack g)}) + +-- | add `n` unknown slots to our stack knowledge +addUnknownSlots :: Int -> G () +addUnknownSlots n = addSlots (replicate n SlotUnknown) + +-- | add knowledge about the stack slots +addSlots :: [StackSlot] -> G () +addSlots xs = do + s <- getSlots + setSlots (xs ++ s) + +-- | drop 'n' slots from our stack knowledge +dropSlots :: Int -> G () +dropSlots n = modifySlots (drop n) + +push :: [JExpr] -> G JStat +push xs = do + dropSlots (length xs) + modifyStackDepth (+ (length xs)) + flip push' xs <$> getSettings + +push' :: StgToJSConfig -> [JExpr] -> JStat +push' _ [] = mempty +push' cs xs + | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items + | otherwise = ApplStat (toJExpr $ pushN ! l) xs + where + items = zipWith f [(1::Int)..] xs + offset i | i == l = sp + | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) + l = length xs + f i e = AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e) + + +-- | Grow the stack pointer by 'n' without modifying the stack depth. The stack +-- is just a JS array so we add to grow (instead of the traditional subtract) +adjSp' :: Int -> JStat +adjSp' 0 = mempty +adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n) + +-- | Shrink the stack pointer by 'n'. The stack grows downward so substract +adjSpN' :: Int -> JStat +adjSpN' 0 = mempty +adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n) + +-- | Wrapper which adjusts the stack pointer /and/ modifies the stack depth +-- tracked in 'G'. See also 'adjSp'' which actually does the stack pointer +-- manipulation. +adjSp :: Int -> G JStat +adjSp 0 = return mempty +adjSp n = do + -- grow depth by n + modifyStackDepth (+n) + return (adjSp' n) + +-- | Shrink the stack and stack pointer. NB: This function is unsafe when the +-- input 'n', is negative. This function wraps around 'adjSpN' which actually +-- performs the work. +adjSpN :: Int -> G JStat +adjSpN 0 = return mempty +adjSpN n = do + modifyStackDepth (\x -> x - n) + return (adjSpN' n) + +-- | A constant array that holds global function symbols which do N pushes onto +-- the stack. For example: +-- @ +-- function h$p1(x1) { +-- ++h$sp; +-- h$stack[(h$sp - 0)] = x1; +-- }; +-- function h$p2(x1, x2) { +-- h$sp += 2; +-- h$stack[(h$sp - 1)] = x1; +-- h$stack[(h$sp - 0)] = x2; +-- }; +-- @ +-- +-- and so on up to 32. +pushN :: Array Int Ident +pushN = listArray (1,32) $ map (TxtI . mkFastString . ("h$p"++) . show) [(1::Int)..32] + +-- | Convert all function symbols in 'pushN' to global top-level functions. This +-- is a hack which converts the function symbols to variables. This hack is +-- caught in 'GHC.StgToJS.Printer.prettyBlock'' to turn these into global +-- functions. +pushN' :: Array Int JExpr +pushN' = fmap (ValExpr . JVar) pushN + +-- | Partial Push functions. Like 'pushN' except these push functions skip +-- slots. For example, +-- @ +-- function h$pp33(x1, x2) { +-- h$sp += 6; +-- h$stack[(h$sp - 5)] = x1; +-- h$stack[(h$sp - 0)] = x2; +-- }; +-- @ +-- +-- The 33rd entry skips slots 1-4 to bind the top of the stack and the 6th +-- slot. See 'pushOptimized' and 'pushOptimized'' for use cases. +pushNN :: Array Integer Ident +pushNN = listArray (1,255) $ map (TxtI . mkFastString . ("h$pp"++) . show) [(1::Int)..255] + +-- | Like 'pushN'' but for the partial push functions +pushNN' :: Array Integer JExpr +pushNN' = fmap (ValExpr . JVar) pushNN + +pushOptimized' :: [(Id,Int)] -> G JStat +pushOptimized' xs = do + slots <- getSlots + pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown)) + where + f (i1,n1) xs2 = do + xs <- varsForId i1 + let !id_n1 = xs !! (n1-1) + + case xs2 of + SlotId i2 n2 -> pure (id_n1,i1==i2&&n1==n2) + _ -> pure (id_n1,False) + +-- | optimized push that reuses existing values on stack automatically chooses +-- an optimized partial push (h$ppN) function when possible. +pushOptimized :: [(JExpr,Bool)] -- ^ contents of the slots, True if same value is already there + -> G JStat +pushOptimized [] = return mempty +pushOptimized xs = do + dropSlots l + modifyStackDepth (+ length xs) + go . csInlinePush <$> getSettings + where + go True = inlinePush + go _ + | all snd xs = adjSp' l + | all (not.snd) xs && l <= 32 = + ApplStat (pushN' ! l) (map fst xs) + | l <= 8 && not (snd $ last xs) = + ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ] + | otherwise = inlinePush + l = length xs + sig :: Integer + sig = L.foldl1' (Bits..|.) $ zipWith (\(_e,b) i -> if not b then Bits.bit i else 0) xs [0..] + inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs) + pushSlot i (ex, False) = IdxExpr stack (offset i) |= ex + pushSlot _ _ = mempty + offset i | i == l = sp + | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) + +-- | push a let-no-escape frame onto the stack +pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat +pushLneFrame size ctx = + let ctx' = ctxLneShrinkStack ctx size + in pushOptimized' (ctxLneFrameVars ctx') + +-- | Pop things, don't update the stack knowledge in 'G' +popSkip :: Int -- ^ number of slots to skip + -> [JExpr] -- ^ assign stack slot values to these + -> JStat +popSkip 0 [] = mempty +popSkip n [] = adjSpN' n +popSkip n tgt = loadSkip n tgt <> adjSpN' (length tgt + n) + +-- | Load 'length (xs :: [JExpr])' things from the stack at offset 'n :: Int'. +-- This function does no stack pointer manipulation, it merely indexes into the +-- stack and loads payloads into 'xs'. +loadSkip :: Int -> [JExpr] -> JStat +loadSkip = loadSkipFrom sp + where + loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat + loadSkipFrom fr n xs = mconcat items + where + items = reverse $ zipWith f [(0::Int)..] (reverse xs) + -- helper to generate sp - n offset to index with + offset 0 = fr + offset n = InfixExpr SubOp fr (toJExpr n) + -- helper to load stack .! i into ex, e.g., ex = stack[i] + f i ex = ex |= IdxExpr stack (toJExpr (offset (i+n))) + + +-- | Pop but preserve the first N slots +popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat +popSkipI 0 [] = pure mempty +popSkipI n [] = popN n +popSkipI n xs = do + -- add N unknown slots + addUnknownSlots n + -- now add the slots from xs, after this line the stack should look like + -- [xs] ++ [Unknown...] ++ old_stack + addSlots (map snd xs) + -- move stack pointer into the stack by (length xs + n), basically resetting + -- the stack pointer + a <- adjSpN (length xs + n) + -- now load skipping first N slots + return (loadSkipI n (map fst xs) <> a) + +-- | Just like 'loadSkip' but operate on 'Ident's rather than 'JExpr' +loadSkipI :: Int -> [Ident] -> JStat +loadSkipI = loadSkipIFrom sp + where loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat + loadSkipIFrom fr n xs = mconcat items + where + items = reverse $ zipWith f [(0::Int)..] (reverse xs) + offset 0 = fr + offset n = InfixExpr SubOp fr (toJExpr n) + f i ex = ex ||= IdxExpr stack (toJExpr (offset (i+n))) + +-- | Blindly pop N slots +popN :: Int -> G JStat +popN n = addUnknownSlots n >> adjSpN n + +-- | Generate statements to update the current node with a blackhole +bhStats :: StgToJSConfig -> Bool -> JStat +bhStats s pushUpd = mconcat + [ if pushUpd then push' s [r1, var "h$upd_frame"] else mempty + , toJExpr R1 .^ closureEntry_ |= var "h$blackhole" + , toJExpr R1 .^ closureField1_ |= var "h$currentThread" + , toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array + ] + +-- | Wrapper around 'updateThunk'', performs the stack manipulation before +-- updating the Thunk. +updateThunk :: G JStat +updateThunk = do + settings <- getSettings + -- update frame size + let adjPushStack :: Int -> G () + adjPushStack n = do modifyStackDepth (+n) + dropSlots n + adjPushStack 2 + return $ (updateThunk' settings) + +-- | Update a thunk by checking 'StgToJSConfig'. If the config inlines black +-- holes then update inline, else make an explicit call to the black hole +-- handler. +updateThunk' :: StgToJSConfig -> JStat +updateThunk' settings = + if csInlineBlackhole settings + then bhStats settings True + else ApplStat (var "h$bh") [] diff --git a/compiler/GHC/StgToJS/StaticPtr.hs b/compiler/GHC/StgToJS/StaticPtr.hs new file mode 100644 index 0000000000..bddae1e674 --- /dev/null +++ b/compiler/GHC/StgToJS/StaticPtr.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.StaticPtr + ( initStaticPtrs + ) +where + +import GHC.Prelude +import GHC.Linker.Types (SptEntry(..)) +import GHC.Fingerprint.Type +import GHC.Types.Literal + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Ids + +initStaticPtrs :: [SptEntry] -> G JStat +initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs + where + initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do + i <- varForId sp_id + fpa <- concat <$> mapM (genLit . mkLitWord64 . fromIntegral) [w1,w2] + let sptInsert = ApplExpr (var "h$hs_spt_insert") (fpa ++ [i]) + return $ (var "h$initStatic" .^ "push") `ApplStat` [jLam sptInsert] + diff --git a/compiler/GHC/StgToJS/StgUtils.hs b/compiler/GHC/StgToJS/StgUtils.hs new file mode 100644 index 0000000000..62c494c3a7 --- /dev/null +++ b/compiler/GHC/StgToJS/StgUtils.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.StgUtils + ( bindingRefs + , hasExport + , collectTopIds + , collectIds + , removeTick + , isUpdatableRhs + , isInlineExpr + , exprRefs + -- * Live vars + , LiveVars + , liveVars + , liveStatic + , stgRhsLive + , stgExprLive + , stgTopBindLive + , stgLetNoEscapeLive + , stgLneLiveExpr + , stgLneLive + , stgLneLive' + ) +where + +import GHC.Prelude + +import GHC.Stg.Syntax +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.TyCon + +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Unique +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.ForeignCall +import GHC.Types.TyThing +import GHC.Types.Name +import GHC.Types.Var.Set + +import GHC.Builtin.Names +import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Utils.Misc (seqList) +import GHC.Utils.Panic + +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.List as L +import Data.Set (Set) +import Data.Monoid + +s :: a -> Set a +s = S.singleton + +l :: (a -> Set Id) -> [a] -> Set Id +l = F.foldMap + +-- | collect Ids that this binding refers to +-- (does not include the bindees themselves) +-- first argument is Id -> StgExpr map for unfloated arguments +bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id +bindingRefs u = \case + StgNonRec _ rhs -> rhsRefs u rhs + StgRec bs -> l (rhsRefs u . snd) bs + +rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id +rhsRefs u = \case + StgRhsClosure _ _ _ _ body -> exprRefs u body + StgRhsCon _ccs d _mu _ticks args -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + +exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id +exprRefs u = \case + StgApp f args -> s f <> l (argRefs u) args + StgConApp d _n args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + StgOpApp _ args _ -> l (argRefs u) args + StgLit {} -> mempty + StgCase expr _ _ alts -> exprRefs u expr <> mconcat (fmap (altRefs u) alts) + StgLet _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgLetNoEscape _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgTick _ expr -> exprRefs u expr + +altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id +altRefs u alt = exprRefs u (alt_rhs alt) + +argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id +argRefs u = \case + StgVarArg id + | Just e <- lookupUFM u id -> exprRefs u e + | otherwise -> s id + _ -> mempty + +hasExport :: CgStgBinding -> Bool +hasExport bnd = + case bnd of + StgNonRec b e -> isExportedBind b e + StgRec bs -> any (uncurry isExportedBind) bs + where + isExportedBind _i (StgRhsCon _cc con _ _ _) = + getUnique con == staticPtrDataConKey + isExportedBind _ _ = False + +collectTopIds :: CgStgBinding -> [Id] +collectTopIds (StgNonRec b _) = [b] +collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs + in seqList xs `seq` xs + +collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id] +collectIds unfloated b = + let xs = map zapFragileIdInfo . + filter acceptId $ S.toList (bindingRefs unfloated b) + in seqList xs `seq` xs + where + acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden] + -- the GHC.Prim module has no js source file + isForbidden i + | Just m <- nameModule_maybe (getName i) = m == gHC_PRIM + | otherwise = False + +removeTick :: CgStgExpr -> CgStgExpr +removeTick (StgTick _ e) = e +removeTick e = e + +----------------------------------------------------- +-- Live vars +-- +-- TODO: should probably be moved into GHC.Stg.LiveVars + +type LiveVars = DVarSet + +liveStatic :: LiveVars -> LiveVars +liveStatic = filterDVarSet isGlobalId + +liveVars :: LiveVars -> LiveVars +liveVars = filterDVarSet (not . isGlobalId) + +stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)] +stgTopBindLive = \case + StgTopLifted b -> stgBindLive b + StgTopStringLit {} -> [] + +stgBindLive :: CgStgBinding -> [(Id, LiveVars)] +stgBindLive = \case + StgNonRec b rhs -> [(b, stgRhsLive rhs)] + StgRec bs -> map (\(b,rhs) -> (b, stgRhsLive rhs)) bs + +stgBindRhsLive :: CgStgBinding -> LiveVars +stgBindRhsLive b = + let (bs, ls) = unzip (stgBindLive b) + in delDVarSetList (unionDVarSets ls) bs + +stgRhsLive :: CgStgRhs -> LiveVars +stgRhsLive = \case + StgRhsClosure _ _ _ args e -> delDVarSetList (stgExprLive True e) args + StgRhsCon _ _ _ _ args -> unionDVarSets (map stgArgLive args) + +stgArgLive :: StgArg -> LiveVars +stgArgLive = \case + StgVarArg occ -> unitDVarSet occ + StgLitArg {} -> emptyDVarSet + +stgExprLive :: Bool -> CgStgExpr -> LiveVars +stgExprLive includeLHS = \case + StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args) + StgLit {} -> emptyDVarSet + StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args) + StgOpApp _op args _ty -> unionDVarSets (map stgArgLive args) + StgCase e b _at alts + | includeLHS -> el `unionDVarSet` delDVarSet al b + | otherwise -> delDVarSet al b + where + al = unionDVarSets (map stgAltLive alts) + el = stgExprLive True e + StgLet _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgLetNoEscape _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgTick _ti e -> stgExprLive True e + +stgAltLive :: CgStgAlt -> LiveVars +stgAltLive alt = + delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt) + +stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars +stgLetNoEscapeLive _someBool _b _e = panic "stgLetNoEscapeLive" + +bindees :: CgStgBinding -> [Id] +bindees = \case + StgNonRec b _e -> [b] + StgRec bs -> map fst bs + +isUpdatableRhs :: CgStgRhs -> Bool +isUpdatableRhs (StgRhsClosure _ _ u _ _) = isUpdatable u +isUpdatableRhs _ = False + +stgLneLive' :: CgStgBinding -> [Id] +stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b) + +stgLneLive :: CgStgBinding -> [Id] +stgLneLive (StgNonRec _b e) = stgLneLiveExpr e +stgLneLive (StgRec bs) = L.nub $ concatMap (stgLneLiveExpr . snd) bs + +stgLneLiveExpr :: CgStgRhs -> [Id] +stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs) +-- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e)) +-- stgLneLiveExpr StgRhsCon {} = [] + +-- | returns True if the expression is definitely inline +isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool) +isInlineExpr v = \case + StgApp i args + -> (emptyUniqSet, isInlineApp v i args) + StgLit{} + -> (emptyUniqSet, True) + StgConApp{} + -> (emptyUniqSet, True) + StgOpApp (StgFCallOp f _) _ _ + -> (emptyUniqSet, isInlineForeignCall f) + StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t + -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) + StgOpApp (StgPrimOp op) _ _ + -> (emptyUniqSet, primOpIsReallyInline op) + StgOpApp (StgPrimCallOp _c) _ _ + -> (emptyUniqSet, True) + StgCase e b _ alts + ->let (_ve, ie) = isInlineExpr v e + v' = addOneToUniqSet v b + (vas, ias) = unzip $ map (isInlineExpr v') (fmap alt_rhs alts) + vr = L.foldl1' intersectUniqSets vas + in (vr, (ie || b `elementOfUniqSet` v) && and ias) + StgLet _ b e + -> isInlineExpr (inspectInlineBinding v b) e + StgLetNoEscape _ _b e + -> isInlineExpr v e + StgTick _ e + -> isInlineExpr v e + +inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id +inspectInlineBinding v = \case + StgNonRec i r -> inspectInlineRhs v i r + StgRec bs -> foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs + +inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id +inspectInlineRhs v i = \case + StgRhsCon{} -> addOneToUniqSet v i + StgRhsClosure _ _ ReEntrant _ _ -> addOneToUniqSet v i + _ -> v + +isInlineForeignCall :: ForeignCall -> Bool +isInlineForeignCall (CCall (CCallSpec _ cconv safety)) = + not (playInterruptible safety) && + not (cconv /= JavaScriptCallConv && playSafe safety) + +isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool +isInlineApp v i = \case + _ | isJoinId i -> False + [] -> isUnboxedTupleType (idType i) || + isStrictType (idType i) || + i `elementOfUniqSet` v + + [StgVarArg a] + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a + -> True + _ -> False + diff --git a/compiler/GHC/StgToJS/Symbols.hs b/compiler/GHC/StgToJS/Symbols.hs new file mode 100644 index 0000000000..999c654fa8 --- /dev/null +++ b/compiler/GHC/StgToJS/Symbols.hs @@ -0,0 +1,89 @@ + +-- | JS symbol generation +module GHC.StgToJS.Symbols + ( moduleGlobalSymbol + , moduleExportsSymbol + , mkJsSymbol + , mkJsSymbolBS + , mkFreshJsSymbol + , mkRawSymbol + , intBS + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Unit.Module +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL + +-- | Hexadecimal representation of an int +-- +-- Used for uniques. We could use base-62 as GHC usually does but this is likely +-- faster. +intBS :: Int -> ByteString +intBS = BSL.toStrict . BSB.toLazyByteString . BSB.wordHex . fromIntegral + +-- | Return z-encoded unit:module +unitModuleStringZ :: Module -> ByteString +unitModuleStringZ mod = mconcat + [ fastZStringToByteString (zEncodeFS (unitIdFS (moduleUnitId mod))) + , BSC.pack "ZC" -- z-encoding for ":" + , fastZStringToByteString (zEncodeFS (moduleNameFS (moduleName mod))) + ] + +-- | the global linkable unit of a module exports this symbol, depend on it to +-- include that unit (used for cost centres) +moduleGlobalSymbol :: Module -> FastString +moduleGlobalSymbol m = mkFastStringByteString $ mconcat + [ hd + , unitModuleStringZ m + , BSC.pack "_<global>" + ] + +moduleExportsSymbol :: Module -> FastString +moduleExportsSymbol m = mkFastStringByteString $ mconcat + [ hd + , unitModuleStringZ m + , BSC.pack "_<exports>" + ] + +-- | Make JS symbol corresponding to the given Haskell symbol in the given +-- module +mkJsSymbolBS :: Bool -> Module -> FastString -> ByteString +mkJsSymbolBS exported mod s = mconcat + [ if exported then hd else hdd + , unitModuleStringZ mod + , BSC.pack "zi" -- z-encoding of "." + , fastZStringToByteString (zEncodeFS s) + ] + +-- | Make JS symbol corresponding to the given Haskell symbol in the given +-- module +mkJsSymbol :: Bool -> Module -> FastString -> FastString +mkJsSymbol exported mod s = mkFastStringByteString (mkJsSymbolBS exported mod s) + +-- | Make JS symbol for given module and unique. +mkFreshJsSymbol :: Module -> Int -> FastString +mkFreshJsSymbol mod i = mkFastStringByteString $ mconcat + [ hdd + , unitModuleStringZ mod + , BSC.pack "_" + , intBS i + ] + +-- | Make symbol "h$XYZ" or "h$$XYZ" +mkRawSymbol :: Bool -> FastString -> FastString +mkRawSymbol exported fs + | exported = mkFastStringByteString $ mconcat [ hd, bytesFS fs ] + | otherwise = mkFastStringByteString $ mconcat [ hdd, bytesFS fs ] + +-- | "h$$" constant string +hdd :: ByteString +hdd = BSC.pack "h$$" + +-- | "h$" constant string +hd :: ByteString +hd = BSC.take 2 hdd diff --git a/compiler/GHC/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs new file mode 100644 index 0000000000..2c01a30bf2 --- /dev/null +++ b/compiler/GHC/StgToJS/Types.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Types +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- Module that holds the Types required for the StgToJS pass +----------------------------------------------------------------------------- + +module GHC.StgToJS.Types where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Ppr () + +import GHC.Stg.Syntax +import GHC.Core.TyCon + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Var +import GHC.Types.ForeignCall + +import Control.Monad.Trans.State.Strict +import GHC.Utils.Outputable (Outputable (..), text, SDocContext, (<+>), ($$)) + +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import GHC.Unit.Module + +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.ByteString as BS +import Data.Monoid +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Control.DeepSeq + +-- | A State monad over IO holding the generator state. +type G = StateT GenState IO + +-- | The JS code generator state +data GenState = GenState + { gsSettings :: !StgToJSConfig -- ^ codegen settings, read-only + , gsModule :: !Module -- ^ current module + , gsId :: {-# UNPACK #-} !FastMutInt -- ^ unique number for the id generator + , gsIdents :: !IdCache -- ^ hash consing for identifiers from a Unique + , gsUnfloated :: !(UniqFM Id CgStgExpr) -- ^ unfloated arguments + , gsGroup :: GenGroupState -- ^ state for the current binding group + , gsGlobal :: [JStat] -- ^ global (per module) statements (gets included when anything else from the module is used) + } + +-- | The JS code generator state relevant for the current binding group +data GenGroupState = GenGroupState + { ggsToplevelStats :: [JStat] -- ^ extra toplevel statements for the binding group + , ggsClosureInfo :: [ClosureInfo] -- ^ closure metadata (info tables) for the binding group + , ggsStatic :: [StaticInfo] -- ^ static (CAF) data in our binding group + , ggsStack :: [StackSlot] -- ^ stack info for the current expression + , ggsStackDepth :: Int -- ^ current stack depth + , ggsExtraDeps :: Set OtherSymb -- ^ extra dependencies for the linkable unit that contains this group + , ggsGlobalIdCache :: GlobalIdCache + , ggsForeignRefs :: [ForeignJSRef] + } + +-- | The Configuration record for the StgToJS pass +data StgToJSConfig = StgToJSConfig + -- flags + { csInlinePush :: !Bool + , csInlineBlackhole :: !Bool + , csInlineLoadRegs :: !Bool + , csInlineEnter :: !Bool + , csInlineAlloc :: !Bool + , csTraceRts :: !Bool + , csAssertRts :: !Bool + , csBoundsCheck :: !Bool + , csDebugAlloc :: !Bool + , csTraceForeign :: !Bool + , csProf :: !Bool -- ^ Profiling enabled + , csRuntimeAssert :: !Bool -- ^ Enable runtime assertions + -- settings + , csContext :: !SDocContext + } + +-- | Information relevenat to code generation for closures. +data ClosureInfo = ClosureInfo + { ciVar :: Ident -- ^ object being infod + , ciRegs :: CIRegs -- ^ size of the payload (in number of JS values) + , ciName :: FastString -- ^ friendly name for printing + , ciLayout :: CILayout -- ^ heap/stack layout of the object + , ciType :: CIType -- ^ type of the object, with extra info where required + , ciStatic :: CIStatic -- ^ static references of this object + } + deriving stock (Eq, Show, Generic) + +-- | Closure information, 'ClosureInfo', registers +data CIRegs + = CIRegsUnknown -- ^ A value witnessing a state of unknown registers + | CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start + , ciRegsTypes :: [VarType] -- ^ args + } + deriving stock (Eq, Ord, Show, Generic) + +instance NFData CIRegs + +-- | Closure Information, 'ClosureInfo', layout +data CILayout + = CILayoutVariable -- ^ layout stored in object itself, first position from the start + | CILayoutUnknown -- ^ fixed size, but content unknown (for example stack apply frame) + { layoutSize :: !Int + } + | CILayoutFixed -- ^ whole layout known + { layoutSize :: !Int -- ^ closure size in array positions, including entry + , layout :: [VarType] -- ^ The set of sized Types to layout + } + deriving stock (Eq, Ord, Show, Generic) + +instance NFData CILayout + +-- | The type of 'ClosureInfo' +data CIType + = CIFun { citArity :: !Int -- ^ function arity + , citRegs :: !Int -- ^ number of registers for the args + } + | CIThunk -- ^ The closure is a THUNK + | CICon { citConstructor :: !Int } -- ^ The closure is a Constructor + | CIPap -- ^ The closure is a Partial Application + | CIBlackhole -- ^ The closure is a black hole + | CIStackFrame -- ^ The closure is a stack frame + deriving stock (Eq, Ord, Show, Generic) + +instance NFData CIType + +-- | Static references that must be kept alive +newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] } + deriving stock (Eq, Generic) + deriving newtype (Semigroup, Monoid, Show) + +-- | static refs: array = references, null = nothing to report +-- note: only works after all top-level objects have been created +instance ToJExpr CIStatic where + toJExpr (CIStaticRefs []) = null_ -- [je| null |] + toJExpr (CIStaticRefs rs) = toJExpr (map TxtI rs) + +-- | Free variable types +data VarType + = PtrV -- ^ pointer = reference to heap object (closure object) + | VoidV -- ^ no fields + | DoubleV -- ^ A Double: one field + | IntV -- ^ An Int (32bit because JS): one field + | LongV -- ^ A Long: two fields one for the upper 32bits, one for the lower (NB: JS is little endian) + | AddrV -- ^ a pointer not to the heap: two fields, array + index + | RtsObjV -- ^ some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#) + | ObjV -- ^ some JS object, user supplied, be careful around these, can be anything + | ArrV -- ^ boxed array + deriving stock (Eq, Ord, Enum, Bounded, Show, Generic) + +instance NFData VarType + +instance ToJExpr VarType where + toJExpr = toJExpr . fromEnum + +-- | The type of identifiers. These determine the suffix of generated functions +-- in JS Land. For example, the entry function for the 'Just' constructor is a +-- 'IdConEntry' which compiles to: +-- @ +-- function h$baseZCGHCziMaybeziJust_con_e() { return h$rs() }; +-- @ +-- which just returns whatever the stack point is pointing to. Whereas the entry +-- function to 'Just' is an 'IdEntry' and does the work. It compiles to: +-- @ +-- function h$baseZCGHCziMaybeziJust_e() { +-- var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2; +-- h$r1 = h$c1(h$baseZCGHCziMaybeziJust_con_e, h$$baseZCGHCziMaybezieta_8KXnScrCjF5); +-- return h$rs(); +-- }; +-- @ +-- Which loads some payload from register 2, and applies the Constructor Entry +-- function for the Just to the payload, returns the result in register 1 and +-- returns whatever is on top of the stack +data IdType + = IdPlain -- ^ A plain identifier for values, no suffix added + | IdEntry -- ^ An entry function, suffix = "_e" in 'GHC.StgToJS.Ids.makeIdentForId' + | IdConEntry -- ^ A Constructor entry function, suffix = "_con_e" in 'GHC.StgToJS.Ids.makeIdentForId' + deriving (Enum, Eq, Ord) + +-- | Keys to differentiate Ident's in the ID Cache +data IdKey + = IdKey !Int !Int !IdType + deriving (Eq, Ord) + +-- | Some other symbol +data OtherSymb + = OtherSymb !Module !FastString + deriving Eq + +instance Ord OtherSymb where + compare (OtherSymb m1 t1) (OtherSymb m2 t2) + = stableModuleCmp m1 m2 <> lexicalCompareFS t1 t2 + +-- | The identifier cache indexed on 'IdKey' local to a module +newtype IdCache = IdCache (M.Map IdKey Ident) + +-- | The global Identifier Cache +newtype GlobalIdCache = GlobalIdCache (UniqFM Ident (IdKey, Id)) + +-- | A Stack Slot is either known or unknown. We avoid maybe here for more +-- strictness. +data StackSlot + = SlotId !Id !Int + | SlotUnknown + deriving (Eq, Ord) + +data StaticInfo = StaticInfo + { siVar :: !FastString -- ^ global object + , siVal :: !StaticVal -- ^ static initialization + , siCC :: !(Maybe Ident) -- ^ optional CCS name + } deriving stock (Eq, Show, Typeable, Generic) + +data StaticVal + = StaticFun !FastString [StaticArg] + -- ^ heap object for function + | StaticThunk !(Maybe (FastString,[StaticArg])) + -- ^ heap object for CAF (field is Nothing when thunk is initialized in an + -- alternative way, like string thunks through h$str) + | StaticUnboxed !StaticUnboxed + -- ^ unboxed constructor (Bool, Int, Double etc) + | StaticData !FastString [StaticArg] + -- ^ regular datacon app + | StaticList [StaticArg] (Maybe FastString) + -- ^ list initializer (with optional tail) + deriving stock (Eq, Show, Generic) + +data StaticUnboxed + = StaticUnboxedBool !Bool + | StaticUnboxedInt !Integer + | StaticUnboxedDouble !SaneDouble + | StaticUnboxedString !BS.ByteString + | StaticUnboxedStringOffset !BS.ByteString + deriving stock (Eq, Ord, Show, Generic) + +instance NFData StaticUnboxed + +-- | Static Arguments. Static Arguments are things that are statically +-- allocated, i.e., they exist at program startup. These are static heap objects +-- or literals or things that have been floated to the top level binding by ghc. +data StaticArg + = StaticObjArg !FastString -- ^ reference to a heap object + | StaticLitArg !StaticLit -- ^ literal + | StaticConArg !FastString [StaticArg] -- ^ unfloated constructor + deriving stock (Eq, Show, Generic) + +instance Outputable StaticArg where + ppr x = text (show x) + +-- | A Static literal value +data StaticLit + = BoolLit !Bool + | IntLit !Integer + | NullLit + | DoubleLit !SaneDouble -- should we actually use double here? + | StringLit !FastString + | BinLit !BS.ByteString + | LabelLit !Bool !FastString -- ^ is function pointer, label (also used for string / binary init) + deriving (Eq, Show, Generic) + +instance Outputable StaticLit where + ppr x = text (show x) + + +instance ToJExpr StaticLit where + toJExpr (BoolLit b) = toJExpr b + toJExpr (IntLit i) = toJExpr i + toJExpr NullLit = null_ + toJExpr (DoubleLit d) = toJExpr (unSaneDouble d) + toJExpr (StringLit t) = app (mkFastString "h$str") [toJExpr t] + toJExpr (BinLit b) = app (mkFastString "h$rstr") [toJExpr (map toInteger (BS.unpack b))] + toJExpr (LabelLit _isFun lbl) = var lbl + +-- | A foreign reference to some JS code +data ForeignJSRef = ForeignJSRef + { foreignRefSrcSpan :: !FastString + , foreignRefPattern :: !FastString + , foreignRefSafety :: !Safety + , foreignRefCConv :: !CCallConv + , foreignRefArgs :: ![FastString] + , foreignRefResult :: !FastString + } deriving stock (Generic) + +-- | data used to generate one ObjUnit in our object file +data LinkableUnit = LinkableUnit + { luObjUnit :: ObjUnit -- ^ serializable unit info + , luIdExports :: [Id] -- ^ exported names from haskell identifiers + , luOtherExports :: [FastString] -- ^ other exports + , luIdDeps :: [Id] -- ^ identifiers this unit depends on + , luPseudoIdDeps :: [Unique] -- ^ pseudo-id identifiers this unit depends on (fixme) + , luOtherDeps :: [OtherSymb] -- ^ symbols not from a haskell id that this unit depends on + , luRequired :: Bool -- ^ always link this unit + , luForeignRefs :: [ForeignJSRef] + } + +-- | one toplevel block in the object file +data ObjUnit = ObjUnit + { oiSymbols :: ![FastString] -- ^ toplevel symbols (stored in index) + , oiClInfo :: ![ClosureInfo] -- ^ closure information of all closures in block + , oiStatic :: ![StaticInfo] -- ^ static closure data + , oiStat :: JStat -- ^ the code + , oiRaw :: !BS.ByteString -- ^ raw JS code + , oiFExports :: ![ExpFun] + , oiFImports :: ![ForeignJSRef] + } + +data ExpFun = ExpFun + { isIO :: !Bool + , args :: [JSFFIType] + , result :: !JSFFIType + } deriving (Eq, Ord, Show) + +-- | Types of FFI values +data JSFFIType + = Int8Type + | Int16Type + | Int32Type + | Int64Type + | Word8Type + | Word16Type + | Word32Type + | Word64Type + | DoubleType + | ByteArrayType + | PtrType + | RefType + deriving (Show, Ord, Eq, Enum) + + +-- | Typed expression +data TypedExpr = TypedExpr + { typex_typ :: !PrimRep + , typex_expr :: [JExpr] + } + +instance Outputable TypedExpr where + ppr x = text "TypedExpr: " <+> ppr (typex_expr x) + $$ text "PrimReps: " <+> ppr (typex_typ x) + +-- | A Primop result is either an inlining of some JS payload, or a primitive +-- call to a JS function defined in Shim files in base. +data PrimRes + = PrimInline JStat -- ^ primop is inline, result is assigned directly + | PRPrimCall JStat -- ^ primop is async call, primop returns the next + -- function to run. result returned to stack top in registers + +data ExprResult + = ExprCont + | ExprInline (Maybe [JExpr]) + deriving (Eq) + +newtype ExprValData = ExprValData [JExpr] + deriving newtype (Eq) + +-- | A Closure is one of six types +data ClosureType + = Thunk -- ^ The closure is a THUNK + | Fun -- ^ The closure is a Function + | Pap -- ^ The closure is a Partial Application + | Con -- ^ The closure is a Constructor + | Blackhole -- ^ The closure is a Blackhole + | StackFrame -- ^ The closure is a stack frame + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Convert 'ClosureType' to an Int +ctNum :: ClosureType -> Int +ctNum Fun = 1 +ctNum Con = 2 +ctNum Thunk = 0 +ctNum Pap = 3 +ctNum Blackhole = 5 +ctNum StackFrame = -1 + +-- | Convert 'ClosureType' to a String +ctJsName :: ClosureType -> String +ctJsName = \case + Thunk -> "CLOSURE_TYPE_THUNK" + Fun -> "CLOSURE_TYPE_FUN" + Pap -> "CLOSURE_TYPE_PAP" + Con -> "CLOSURE_TYPE_CON" + Blackhole -> "CLOSURE_TYPE_BLACKHOLE" + StackFrame -> "CLOSURE_TYPE_STACKFRAME" + +instance ToJExpr ClosureType where + toJExpr e = toJExpr (ctNum e) + + +-- | A thread is in one of 4 states +data ThreadStatus + = Running -- ^ The thread is running + | Blocked -- ^ The thread is blocked + | Finished -- ^ The thread is done + | Died -- ^ The thread has died + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Convert the status of a thread in JS land to an Int +threadStatusNum :: ThreadStatus -> Int +threadStatusNum = \case + Running -> 0 + Blocked -> 1 + Finished -> 16 + Died -> 17 + +-- | convert the status of a thread in JS land to a string +threadStatusJsName :: ThreadStatus -> String +threadStatusJsName = \case + Running -> "THREAD_RUNNING" + Blocked -> "THREAD_BLOCKED" + Finished -> "THREAD_FINISHED" + Died -> "THREAD_DIED" diff --git a/compiler/GHC/StgToJS/Utils.hs b/compiler/GHC/StgToJS/Utils.hs new file mode 100644 index 0000000000..8d16f39a64 --- /dev/null +++ b/compiler/GHC/StgToJS/Utils.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Utils + ( assignToTypedExprs + , assignCoerce1 + , assignToExprCtx + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types +import GHC.StgToJS.ExprCtx + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Core.TyCon + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable + +assignToTypedExprs :: HasDebugCallStack => [TypedExpr] -> [JExpr] -> JStat +assignToTypedExprs tes es = + assignAllEqual (concatMap typex_expr tes) es + +assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStat +assignTypedExprs tes es = + -- TODO: check primRep (typex_typ) here? + assignToTypedExprs tes (concatMap typex_expr es) + +assignToExprCtx :: HasDebugCallStack => ExprCtx -> [JExpr] -> JStat +assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es + +-- | Assign first expr only (if it exists), performing coercions between some +-- PrimReps (e.g. StablePtr# and Addr#). +assignCoerce1 :: HasDebugCallStack => [TypedExpr] -> [TypedExpr] -> JStat +assignCoerce1 [x] [y] = assignCoerce x y +assignCoerce1 [] [] = mempty +assignCoerce1 x y = pprPanic "assignCoerce1" + (vcat [ text "lengths do not match" + , ppr x + , ppr y + ]) + +-- | Assign p2 to p1 with optional coercion +assignCoerce :: TypedExpr -> TypedExpr -> JStat +-- Coercion between StablePtr# and Addr# +assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr UnliftedRep [sptr]) = mconcat + [ a_val |= var "h$stablePtrBuf" + , a_off |= sptr + ] +assignCoerce (TypedExpr UnliftedRep [sptr]) (TypedExpr AddrRep [_a_val, a_off]) = + sptr |= a_off +assignCoerce p1 p2 = assignTypedExprs [p1] [p2] + diff --git a/compiler/GHC/SysTools/Cpp.hs b/compiler/GHC/SysTools/Cpp.hs index 1754def83d..61f70342a6 100644 --- a/compiler/GHC/SysTools/Cpp.hs +++ b/compiler/GHC/SysTools/Cpp.hs @@ -231,4 +231,3 @@ offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs offsetIncludePaths dflags (IncludeSpecs incs quotes impl) = let go = map (augmentByWorkingDirectory dflags) in IncludeSpecs (go incs) (go quotes) (go impl) - diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index a1846980a1..465b86a181 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -159,6 +159,10 @@ runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do ,pgm_c dflags, "Asm Compiler") RawObject -> ("c", [] ,pgm_c dflags, "C Compiler") -- claim C for lack of a better idea + --JS backend shouldn't reach here, so we just pass + -- strings to satisfy the totality checker + LangJs -> ("js", [] + ,pgm_c dflags, "JS Backend Compiler") userOpts_c = getOpts dflags opt_c userOpts_cxx = getOpts dflags opt_cxx @@ -221,6 +225,12 @@ runClang logger dflags args = traceSystoolCommand logger "clang" $ do throwIO err ) +runEmscripten :: Logger -> DynFlags -> [Option] -> IO () +runEmscripten logger dflags args = traceSystoolCommand logger "emcc" $ do + let (p,args0) = pgm_a dflags + args1 = args0 ++ args + runSomething logger "Emscripten" p args1 + -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index e4b741f13a..caa7feeca7 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -340,6 +340,10 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty return (CImport src (L lc cconv) (L ls safety) mh (CFunction target)) + | cconv == JavaScriptCallConv = do + checkCg (Right idecl) backendValidityOfCImport + -- leave the rest to the JS backend (at least for now) + return (CImport src (L lc cconv) (L ls safety) mh (CFunction target)) | otherwise = do -- Normal foreign import checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 5c58a73701..e6d03af276 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -977,7 +977,7 @@ removeBindingShadowing bindings = reverse $ fst $ foldl -- | Get target platform -getPlatform :: TcM Platform +getPlatform :: TcRnIf a b Platform getPlatform = targetPlatform <$> getDynFlags --------------------------- diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs index aef23be566..b889ba2bbd 100644 --- a/compiler/GHC/Types/Unique/Map.hs +++ b/compiler/GHC/Types/Unique/Map.hs @@ -61,7 +61,7 @@ import Data.Maybe import Data.Data -- | Maps indexed by 'Uniquable' keys -newtype UniqMap k a = UniqMap (UniqFM k (k, a)) +newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) } deriving (Data, Eq, Functor) type role UniqMap nominal representational diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index c2d36c5c0e..4ae489d631 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -42,6 +42,7 @@ module GHC.Unit.Module.Graph where import GHC.Prelude +import GHC.Platform import qualified GHC.LanguageExtensions as LangExt @@ -262,7 +263,8 @@ showModMsg dflags _ (LinkNode {}) = _ -> False platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile_ dflags) + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) in text exe_file showModMsg _ _ (InstantiationNode _uid indef_unit) = ppr $ instUnitInstanceOf indef_unit diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 26328d8d05..99d5a01665 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -34,6 +34,7 @@ module GHC.Utils.Binary SymbolTable, Dictionary, BinData(..), dataHandle, handleData, + unsafeUnpackBinBuffer, openBinMem, -- closeBin, @@ -47,8 +48,10 @@ module GHC.Utils.Binary writeBinMem, readBinMem, + readBinMemN, putAt, getAt, + forwardPut, forwardPut_, forwardGet, -- * For writing instances putByte, @@ -71,8 +74,11 @@ module GHC.Utils.Binary -- * User data UserData(..), getUserData, setUserData, - newReadState, newWriteState, + newReadState, newWriteState, noUserData, + + -- * String table ("dictionary") putDictionary, getDictionary, putFS, + FSTable, initFSTable, getDictFastString, putDictFastString, -- * Newtype wrappers BinSpan(..), BinSrcSpan(..), BinLocated(..) @@ -89,10 +95,11 @@ import GHC.Types.Unique.FM import GHC.Data.FastMutInt import GHC.Utils.Fingerprint import GHC.Types.SrcLoc +import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import Control.DeepSeq -import Foreign hiding (shiftL, shiftR) +import Foreign hiding (shiftL, shiftR, void) import Data.Array import Data.Array.IO import Data.Array.Unsafe @@ -107,7 +114,7 @@ import Data.Set ( Set ) import qualified Data.Set as Set import Data.Time import Data.List (unfoldr) -import Control.Monad ( when, (<$!>), unless, forM_ ) +import Control.Monad ( when, (<$!>), unless, forM_, void ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -186,6 +193,12 @@ withBinBuffer (BinMem _ ix_r _ arr_r) action = do ix <- readFastMutInt ix_r action $ BS.fromForeignPtr arr 0 ix +unsafeUnpackBinBuffer :: ByteString -> IO BinHandle +unsafeUnpackBinBuffer (BS.BS arr len) = do + arr_r <- newIORef arr + ix_r <- newFastMutInt 0 + sz_r <- newFastMutInt len + return (BinMem noUserData ix_r sz_r arr_r) --------------------------------------------------------------- -- Bin @@ -222,7 +235,7 @@ getAt bh p = do seekBin bh p; get bh openBinMem :: Int -> IO BinHandle openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" + | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- mallocForeignPtrBytes size arr_r <- newIORef arr @@ -240,6 +253,14 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p +-- | SeekBin but without calling expandBin +seekBinNoExpand :: BinHandle -> Bin a -> IO () +seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then panic "seekBinNoExpand: seek out of range" + else writeFastMutInt ix_r p + writeBinMem :: BinHandle -> FilePath -> IO () writeBinMem (BinMem _ ix_r _ arr_r) fn = do h <- openBinaryFile fn WriteMode @@ -249,16 +270,27 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do hClose h readBinMem :: FilePath -> IO BinHandle --- Return a BinHandle with a totally undefined State readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + readBinMem_ filesize h + +readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle) +readBinMemN size filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + if filesize < size + then pure Nothing + else Just <$> readBinMem_ size h + +readBinMem_ :: Int -> Handle -> IO BinHandle +readBinMem_ filesize h = do arr <- mallocForeignPtrBytes filesize count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize when (count /= filesize) $ error ("Binary.readBinMem: only read " ++ show count ++ " bytes") - hClose h arr_r <- newIORef arr ix_r <- newFastMutInt 0 sz_r <- newFastMutInt filesize @@ -557,7 +589,9 @@ getSLEB128 bh = do -- | Encode the argument in it's full length. This is different from many default -- binary instances which make no guarantee about the actual encoding and -- might do things use variable length encoding. -newtype FixedLengthEncoding a = FixedLengthEncoding { unFixedLength :: a } +newtype FixedLengthEncoding a + = FixedLengthEncoding { unFixedLength :: a } + deriving (Eq,Ord,Show) instance Binary (FixedLengthEncoding Word8) where put_ h (FixedLengthEncoding x) = putByte h x @@ -920,6 +954,45 @@ instance Binary (Bin a) where -- ----------------------------------------------------------------------------- +-- Forward reading/writing + +-- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B +-- by using a forward reference +forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPut bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBin bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBin bh + putAt bh pre_a a + seekBinNoExpand bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO () +forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B + +-- | Read a value stored using a forward reference +forwardGet :: BinHandle -> IO a -> IO a +forwardGet bh get_A = do + -- read forward reference + p <- get bh -- a BinPtr + -- store current position + p_a <- tellBin bh + -- go read the forward value, then seek back + seekBinNoExpand bh p + r <- get_A + seekBinNoExpand bh p_a + pure r + +-- ----------------------------------------------------------------------------- -- Lazy reading/writing lazyPut :: Binary a => BinHandle -> a -> IO () @@ -1026,8 +1099,14 @@ newWriteState put_nonbinding_name put_binding_name put_fs ud_put_fs = put_fs } -noUserData :: a -noUserData = undef "UserData" +noUserData :: UserData +noUserData = UserData + { ud_get_name = undef "get_name" + , ud_get_fs = undef "get_fs" + , ud_put_nonbinding_name = undef "put_nonbinding_name" + , ud_put_binding_name = undef "put_binding_name" + , ud_put_fs = undef "put_fs" + } undef :: String -> a undef s = panic ("Binary.UserData: no " ++ s) @@ -1055,6 +1134,58 @@ getDictionary bh = do writeArray mut_arr i fs unsafeFreeze mut_arr +getDictFastString :: Dictionary -> BinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + + +initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int) +initFSTable bh = do + dict_next_ref <- newFastMutInt 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = FSTable + { fs_tab_next = dict_next_ref + , fs_tab_map = dict_map_ref + } + let put_dict = do + fs_count <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh fs_count dict_map + pure fs_count + + -- BinHandle with FastString writing support + let ud = getUserData bh + let ud_fs = ud { ud_put_fs = putDictFastString bin_dict } + let bh_fs = setUserData bh ud_fs + + return (bh_fs,bin_dict,put_dict) + +putDictFastString :: FSTable -> BinHandle -> FastString -> IO () +putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: FSTable -> FastString -> IO Word32 +allocateFastString FSTable { fs_tab_next = j_r + , fs_tab_map = out_r + } f = do + out <- readIORef out_r + let !uniq = getUnique f + case lookupUFM_Directly out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM_Directly out uniq (j, f) + return (fromIntegral j :: Word32) + +-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to +-- avoid a collision and copy to avoid a dependency. +data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use + , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString))) + -- indexed by FastString + } + + --------------------------------------------------------- -- The Symbol Table --------------------------------------------------------- diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index 4603b42d7b..618ded2669 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -202,6 +202,7 @@ data DumpFormat | FormatASM -- ^ Assembly code | FormatC -- ^ C code/header | FormatLLVM -- ^ LLVM bytecode + | FormatJS -- ^ JavaScript code | FormatText -- ^ Unstructured dump deriving (Show,Eq) diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 0d5eabeb0b..a115c61336 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -228,10 +228,10 @@ are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not? -} -zipEqual :: String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipEqual :: HasDebugCallStack => String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #if !defined(DEBUG) zipEqual _ = zip diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs index c5e24794a4..d91570223c 100644 --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -19,6 +19,8 @@ module GHC.Utils.Monad , anyM, allM, orM , foldlM, foldlM_, foldrM , whenM, unlessM + , filterOutM + , partitionM ) where ------------------------------------------------------------------------------- @@ -226,6 +228,19 @@ unlessM :: Monad m => m Bool -> m () -> m () unlessM condM acc = do { cond <- condM ; unless cond acc } +-- | Like 'filterM', only it reverses the sense of the test. +filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] +filterOutM p = + foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) + +-- | Monadic version of @partition@ +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + pure ([x | res]++as, [x | not res]++bs) + {- Note [The one-shot state monad trick] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Summary: many places in GHC use a state monad, and we really want those diff --git a/compiler/GHC/Utils/Panic/Plain.hs b/compiler/GHC/Utils/Panic/Plain.hs index 656b7f2fa8..10b963bf5d 100644 --- a/compiler/GHC/Utils/Panic/Plain.hs +++ b/compiler/GHC/Utils/Panic/Plain.hs @@ -101,11 +101,12 @@ throwPlainGhcException :: PlainGhcException -> a throwPlainGhcException = Exception.throw -- | Panics and asserts. -panic, sorry, pgmError :: String -> a +panic, sorry, pgmError :: HasCallStack => String -> a panic x = unsafeDupablePerformIO $ do stack <- ccsToStrings =<< getCurrentCCS x + let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack) if null stack - then throwPlainGhcException (PlainPanic x) + then throwPlainGhcException (PlainPanic (x ++ '\n' : doc)) else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) sorry x = throwPlainGhcException (PlainSorry x) diff --git a/compiler/GHC/Utils/Ppr.hs b/compiler/GHC/Utils/Ppr.hs index 4c28f083af..51af55b06b 100644 --- a/compiler/GHC/Utils/Ppr.hs +++ b/compiler/GHC/Utils/Ppr.hs @@ -79,7 +79,7 @@ module GHC.Utils.Ppr ( lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- ** Wrapping documents in delimiters - parens, brackets, braces, quotes, quote, doubleQuotes, + parens, brackets, braces, quotes, squotes, quote, doubleQuotes, maybeParens, -- ** Combining documents @@ -108,7 +108,7 @@ module GHC.Utils.Ppr ( -- ** GHC-specific rendering printDoc, printDoc_, - bufLeftRender -- performance hack + bufLeftRender, printLeftRender -- performance hack ) where @@ -462,10 +462,12 @@ hex n = text ('0' : 'x' : padded) parens :: Doc -> Doc -- ^ Wrap document in @(...)@ brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ braces :: Doc -> Doc -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ +quotes :: Doc -> Doc -- ^ Wrap document in @\`...\'@ +squotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ quote :: Doc -> Doc doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ quotes p = char '`' <> p <> char '\'' +squotes p = char '\'' <> p <> char '\'' quote p = char '\'' <> p doubleQuotes p = char '"' <> p <> char '"' parens p = char '(' <> p <> char ')' @@ -1170,16 +1172,14 @@ bufLeftRender :: BufHandle -> Doc -> IO () bufLeftRender b doc = layLeft b (reduceDoc doc) layLeft :: BufHandle -> Doc -> IO () -layLeft b _ | b `seq` False = undefined -- make it strict in b -layLeft _ NoDoc = error "layLeft: NoDoc" +layLeft !_ NoDoc = error "layLeft: NoDoc" layLeft b (Union p q) = layLeft b $! first p q layLeft b (Nest _ p) = layLeft b $! p layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) -layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) +layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p +layLeft b (TextBeside s _ p) = put b s >> layLeft b p where - put b _ | b `seq` False = undefined - put b (Chr c) = bPutChar b c + put !b (Chr c) = bPutChar b c put b (Str s) = bPutStr b s put b (PStr s) = bPutFS b s put b (ZStr s) = bPutFZS b s diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a867801951..b029a9fba6 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -428,6 +428,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 @@ -478,6 +479,7 @@ Library GHC.HsToCore.Foreign.C GHC.HsToCore.Foreign.Call GHC.HsToCore.Foreign.Decl + GHC.HsToCore.Foreign.JavaScript GHC.HsToCore.Foreign.Prim GHC.HsToCore.Foreign.Utils GHC.HsToCore.GuardedRHSs @@ -521,6 +523,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 @@ -636,6 +642,38 @@ Library GHC.StgToCmm.Ticky GHC.StgToCmm.Types GHC.StgToCmm.Utils + GHC.StgToJS + GHC.StgToJS.Apply + GHC.StgToJS.Arg + GHC.StgToJS.Closure + GHC.StgToJS.CodeGen + GHC.StgToJS.CoreUtils + GHC.StgToJS.DataCon + GHC.StgToJS.Deps + GHC.StgToJS.Expr + GHC.StgToJS.ExprCtx + GHC.StgToJS.FFI + GHC.StgToJS.Heap + GHC.StgToJS.Ids + GHC.StgToJS.Literal + GHC.StgToJS.Monad + GHC.StgToJS.Object + GHC.StgToJS.Prim + GHC.StgToJS.Profiling + GHC.StgToJS.Printer + GHC.StgToJS.Regs + GHC.StgToJS.Rts.Types + GHC.StgToJS.Rts.Rts + GHC.StgToJS.Sinker + GHC.StgToJS.Stack + GHC.StgToJS.StaticPtr + GHC.StgToJS.StgUtils + GHC.StgToJS.Symbols + GHC.StgToJS.Types + GHC.StgToJS.Utils + GHC.StgToJS.Linker.Linker + GHC.StgToJS.Linker.Types + GHC.StgToJS.Linker.Utils GHC.Stg.Unarise GHC.SysTools GHC.SysTools.Ar diff --git a/config.sub b/config.sub index dba16e84c7..9977d334bd 100755 --- a/config.sub +++ b/config.sub @@ -1190,7 +1190,7 @@ case $cpu-$vendor in | arc | arceb | arc32 | arc64 \ | arm | arm[lb]e | arme[lb] | armv* \ | avr | avr32 \ - | asmjs \ + | asmjs | js \ | ba \ | be32 | be64 \ | bfin | bpf | bs2000 \ @@ -1711,7 +1711,11 @@ fi # Now, validate our (potentially fixed-up) OS. case $os in - # Sometimes we do "kernel-libc", so those need to count as OSes. + # GHC specific: added for JS backend support + js | ghcjs) + ;; + + # Sometimes we do "kernel-abi", so those need to count as OSes. musl* | newlib* | relibc* | uclibc*) ;; # Likewise for "kernel-abi" diff --git a/configure.ac b/configure.ac index b5855f4ef0..2e683cdef3 100644 --- a/configure.ac +++ b/configure.ac @@ -333,7 +333,7 @@ AC_SUBST(TablesNextToCode) dnl ** Does target have runtime linker support? dnl -------------------------------------------------------------- case "$target" in - powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*) + powerpc64-*|powerpc64le-*|powerpc-ibm-aix*|s390x-ibm-linux|riscv64-*|wasm*|js-*) TargetHasRTSLinker=NO ;; *) @@ -691,8 +691,12 @@ AC_SUBST(CONF_HC_OPTS_STAGE0) AC_SUBST(CONF_HC_OPTS_STAGE1) AC_SUBST(CONF_HC_OPTS_STAGE2) -dnl Identify C++ standard library flavour and location -FP_FIND_CXX_STD_LIB +dnl Identify C++ standard library flavour and location only when _not_ compiling +dnl the JS backend. The JS backend uses emscripten to wrap c++ utilities which +dnl fails this check, so we avoid it when compiling to JS. +if test "$TargetOS" != "ghcjs"; then + FP_FIND_CXX_STD_LIB +fi AC_CONFIG_FILES([mk/system-cxx-std-lib-1.0.conf]) dnl ** Set up the variables for the platform in the settings file. diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst index 83d093cd06..e7b4f12bd9 100644 --- a/docs/users_guide/debugging.rst +++ b/docs/users_guide/debugging.rst @@ -709,6 +709,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/hadrian/bindist/config.mk.in b/hadrian/bindist/config.mk.in index c76c1c9414..ee8366a26f 100644 --- a/hadrian/bindist/config.mk.in +++ b/hadrian/bindist/config.mk.in @@ -128,6 +128,8 @@ GhcUnregisterised = @Unregisterised@ ifeq "$(TargetArch_CPP)" "arm" # We don't support load/store barriers pre-ARMv7. See #10433. ArchSupportsSMP=$(if $(filter $(ARM_ISA),ARMv5 ARMv6),NO,YES) +else ifeq "$(TargetArch_CPP)" "js" +ArchSupportsSMP=NO else ArchSupportsSMP=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 sparc powerpc powerpc64 powerpc64le s390x aarch64 riscv64))) endif diff --git a/hadrian/doc/flavours.md b/hadrian/doc/flavours.md index 8c24f4993c..9aeabcc49d 100644 --- a/hadrian/doc/flavours.md +++ b/hadrian/doc/flavours.md @@ -240,6 +240,11 @@ The supported transformers are listed below: e.g., loading libraries during TemplateHaskell evaluations.</td> </tr> <tr> + <td><code>no_dynamic_libs</code></td> + <td>Just like `no_dynamic_ghc`, this transformer ensures statically-linked libraries + </td> + </tr> + <tr> <td><code>no_profiled_libs</code></td> <td>Disables building of libraries in profiled build ways.</td> </tr> diff --git a/hadrian/src/Context.hs b/hadrian/src/Context.hs index b3608657ca..b8fb5fca26 100644 --- a/hadrian/src/Context.hs +++ b/hadrian/src/Context.hs @@ -9,7 +9,7 @@ module Context ( contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile, pkgSetupConfigDir, pkgHaddockFile, pkgRegisteredLibraryFile, pkgRegisteredLibraryFileName, pkgLibraryFile, pkgGhciLibraryFile, - pkgConfFile, pkgStampFile, objectPath, contextPath, getContextPath, libPath, distDir, + pkgConfFile, pkgStampFile, resourcePath, objectPath, contextPath, getContextPath, libPath, distDir, haddockStatsFilesDir ) where @@ -163,3 +163,10 @@ objectPath context@Context {..} src = do | "*hs*" ?== extension = path -/- obj | otherwise = path -/- extension -/- obj return result + + +resourcePath :: Context -> FilePath -> Action FilePath +resourcePath context src = do + path <- buildPath context + let extension = drop 1 $ takeExtension src + return (path -/- extension -/- src) diff --git a/hadrian/src/Expression.hs b/hadrian/src/Expression.hs index 14b08cb0e9..db437013b4 100644 --- a/hadrian/src/Expression.hs +++ b/hadrian/src/Expression.hs @@ -9,7 +9,7 @@ module Expression ( -- ** Predicates (?), stage, stage0, stage1, stage2, notStage0, threadedBootstrapper, - package, notPackage, packageOneOf, + package, notPackage, packageOneOf, cross, notCross, libraryPackage, builder, way, input, inputs, output, outputs, -- ** Evaluation @@ -151,3 +151,9 @@ cabalFlag pred flagName = do ifM (toPredicate pred) (arg flagName) (arg $ "-"<>flagName) infixr 3 `cabalFlag` + +cross :: Predicate +cross = expr (flag CrossCompiling) + +notCross :: Predicate +notCross = notM cross diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs index b13cb2f365..58baa7c3a9 100644 --- a/hadrian/src/Flavour.hs +++ b/hadrian/src/Flavour.hs @@ -11,9 +11,12 @@ module Flavour , viaLlvmBackend , enableProfiledGhc , disableDynamicGhcPrograms + , disableDynamicLibs , disableProfiledLibs , enableLinting , enableHaddock + , useNativeBignum + , omitPragmas , completeSetting , applySettings @@ -39,25 +42,27 @@ import Oracles.Setting flavourTransformers :: Map String (Flavour -> Flavour) flavourTransformers = M.fromList - [ "werror" =: werror - , "debug_info" =: enableDebugInfo - , "ticky_ghc" =: enableTickyGhc - , "split_sections" =: splitSections + [ "werror" =: werror + , "debug_info" =: enableDebugInfo + , "ticky_ghc" =: enableTickyGhc + , "split_sections" =: splitSections , "thread_sanitizer" =: enableThreadSanitizer - , "llvm" =: viaLlvmBackend - , "profiled_ghc" =: enableProfiledGhc - , "no_dynamic_ghc" =: disableDynamicGhcPrograms + , "llvm" =: viaLlvmBackend + , "profiled_ghc" =: enableProfiledGhc + , "no_dynamic_ghc" =: disableDynamicGhcPrograms + , "no_dynamic_libs" =: disableDynamicLibs + , "native_bignum" =: useNativeBignum , "no_profiled_libs" =: disableProfiledLibs - , "omit_pragmas" =: omitPragmas - , "ipe" =: enableIPE - , "fully_static" =: fullyStatic - , "collect_timings" =: collectTimings - , "assertions" =: enableAssertions - , "debug_ghc" =: debugGhc Stage1 + , "omit_pragmas" =: omitPragmas + , "ipe" =: enableIPE + , "fully_static" =: fullyStatic + , "collect_timings" =: collectTimings + , "assertions" =: enableAssertions + , "debug_ghc" =: debugGhc Stage1 , "debug_stage1_ghc" =: debugGhc stage0InTree - , "lint" =: enableLinting - , "haddock" =: enableHaddock - , "late_ccs" =: enableLateCCS + , "lint" =: enableLinting + , "haddock" =: enableHaddock + , "late_ccs" =: enableLateCCS ] where (=:) = (,) @@ -70,7 +75,7 @@ parseFlavour :: [Flavour] -- ^ base flavours parseFlavour baseFlavours transformers str = case P.runParser parser () "" str of Left perr -> Left $ unlines $ - [ "error parsing flavour specifier: " ++ show perr + [ "error parsing flavour specifier: " ++ show perr , "" , "known flavours:" ] ++ @@ -92,13 +97,14 @@ parseFlavour baseFlavours transformers str = baseFlavour = P.choice [ f <$ P.try (P.string (name f)) | f <- reverse (sortOn name baseFlavours) - ] -- needed to parse e.g. "quick-debug" before "quick" + ] -- reverse&sort needed to parse e.g. "quick-debug" before "quick" flavourTrans :: Parser (Flavour -> Flavour) flavourTrans = do void $ P.char '+' P.choice [ trans <$ P.try (P.string nm) - | (nm, trans) <- M.toList transformers + | (nm, trans) <- reverse $ sortOn fst $ M.toList transformers + -- reverse&sort needed to parse e.g. "ticky_ghc0" before "ticky_ghc" ] -- | Add arguments to the 'args' of a 'Flavour'. @@ -137,20 +143,21 @@ enableDebugInfo = addArgs $ notStage0 ? mconcat -- | Enable the ticky-ticky profiler in stage2 GHC enableTickyGhc :: Flavour -> Flavour enableTickyGhc = - addArgs $ stage1 ? mconcat - [ builder (Ghc CompileHs) ? ticky - , builder (Ghc LinkHs) ? ticky - ] - where - ticky = mconcat - [ arg "-ticky" - , arg "-ticky-allocd" - , arg "-ticky-dyn-thunk" - -- You generally need STG dumps to interpret ticky profiles - , arg "-ddump-to-file" - , arg "-ddump-stg-final" + addArgs $ orM [stage1, cross] ? mconcat + [ builder (Ghc CompileHs) ? tickyArgs + , builder (Ghc LinkHs) ? tickyArgs ] +tickyArgs :: Args +tickyArgs = mconcat + [ arg "-ticky" + , arg "-ticky-allocd" + , arg "-ticky-dyn-thunk" + -- You generally need STG dumps to interpret ticky profiles + , arg "-ddump-to-file" + , arg "-ddump-stg-final" + ] + -- | Enable Core, STG, and (not C--) linting in all compilations with the stage1 compiler. enableLinting :: Flavour -> Flavour enableLinting = @@ -228,6 +235,16 @@ disableDynamicGhcPrograms :: Flavour -> Flavour disableDynamicGhcPrograms flavour = flavour { dynamicGhcPrograms = pure False } -- | Don't build libraries in profiled 'Way's. +disableDynamicLibs :: Flavour -> Flavour +disableDynamicLibs flavour = + flavour { libraryWays = prune $ libraryWays flavour + } + where + prune :: Ways -> Ways + prune = fmap $ Set.filter (not . wayUnit Dynamic) + + +-- | Don't build libraries in profiled 'Way's. disableProfiledLibs :: Flavour -> Flavour disableProfiledLibs flavour = flavour { libraryWays = prune $ libraryWays flavour @@ -237,6 +254,11 @@ disableProfiledLibs flavour = prune :: Ways -> Ways prune = fmap $ Set.filter (not . wayUnit Profiling) +useNativeBignum :: Flavour -> Flavour +useNativeBignum flavour = + flavour { bignumBackend = "native" + } + -- | Build stage2 compiler with -fomit-interface-pragmas to reduce -- recompilation. omitPragmas :: Flavour -> Flavour diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs index eea23de1c7..dfb4924889 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs +++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs @@ -281,6 +281,7 @@ resolveContextData context@Context {..} = do , cSrcs = C.cSources buildInfo ++ [ ms | Just (_,ms) <- pure main_src, CMain <- pure (classifyMain ms)] , cxxSrcs = C.cxxSources buildInfo ++ [ ms | Just (_,ms) <- pure main_src, CppMain <- pure (classifyMain ms)] , cmmSrcs = C.cmmSources buildInfo + , jsSrcs = C.jsSources buildInfo , hcOpts = C.programDefaultArgs ghcProg ++ C.hcOptions C.GHC buildInfo ++ C.languageToFlags (C.compiler lbi') (C.defaultLanguage buildInfo) diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs index 756f5082bf..a35ca7df0e 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs +++ b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs @@ -56,6 +56,7 @@ data ContextData = ContextData , cSrcs :: [String] , cxxSrcs :: [String] , cmmSrcs :: [String] + , jsSrcs :: [String] , hcOpts :: [String] , asmOpts :: [String] , ccOpts :: [String] diff --git a/hadrian/src/Oracles/Flag.hs b/hadrian/src/Oracles/Flag.hs index a929b77e68..41fc723b44 100644 --- a/hadrian/src/Oracles/Flag.hs +++ b/hadrian/src/Oracles/Flag.hs @@ -95,14 +95,15 @@ platformSupportsSharedLibs = do wasm <- anyTargetArch [ "wasm32" ] ppc_linux <- anyTargetPlatform [ "powerpc-unknown-linux" ] solaris <- anyTargetPlatform [ "i386-unknown-solaris2" ] + javascript <- anyTargetArch [ "js" ] solarisBroken <- flag SolarisBrokenShld - return $ not (windows || wasm || ppc_linux || solaris && solarisBroken) + return $ not (windows || wasm || javascript || ppc_linux || solaris && solarisBroken) -- | Does the target support threaded RTS? targetSupportsThreadedRts :: Action Bool targetSupportsThreadedRts = do - wasm <- anyTargetArch [ "wasm32" ] - return $ not wasm + bad_arch <- anyTargetArch [ "wasm32", "js" ] + return $ not bad_arch -- | Does the target support the -N RTS flag? targetSupportsSMP :: Action Bool diff --git a/hadrian/src/Oracles/Setting.hs b/hadrian/src/Oracles/Setting.hs index 28926c7763..e064d7a5c1 100644 --- a/hadrian/src/Oracles/Setting.hs +++ b/hadrian/src/Oracles/Setting.hs @@ -11,7 +11,7 @@ module Oracles.Setting ( -- ** Target platform things anyTargetPlatform, anyTargetOs, anyTargetArch, anyHostOs, - isElfTarget, isOsxTarget, isWinTarget, + isElfTarget, isOsxTarget, isWinTarget, isJsTarget, ArmVersion(..), targetArmVersion, ghcWithInterpreter @@ -257,6 +257,9 @@ anyTargetOs = matchSetting TargetOs isWinTarget :: Action Bool isWinTarget = anyTargetOs ["mingw32"] +isJsTarget :: Action Bool +isJsTarget = anyTargetArch ["js"] + isOsxTarget :: Action Bool isOsxTarget = anyTargetOs ["darwin"] diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs index ff1f9f214b..93d24314ea 100644 --- a/hadrian/src/Rules/Compile.hs +++ b/hadrian/src/Rules/Compile.hs @@ -48,6 +48,9 @@ compilePackage rs = do [ root -/- "**/build/S/**/*." ++ wayPat ++ "o" | wayPat <- wayPats] |%> compileNonHsObject rs Asm + [ root -/- "**/build/js/**/*." ++ wayPat ++ "o" + | wayPat <- wayPats] |%> compileNonHsObject rs JS + -- All else is haskell. -- These come last as they overlap with the above rules' file patterns. @@ -115,11 +118,12 @@ compilePackage rs = do -} -- | Non Haskell source languages that we compile to get object files. -data SourceLang = Asm | C | Cmm | Cxx deriving (Eq, Show) +data SourceLang = Asm | C | Cmm | Cxx | JS deriving (Eq, Show) parseSourceLang :: Parsec.Parsec String () SourceLang parseSourceLang = Parsec.choice - [ Parsec.char 'c' *> Parsec.choice + [ Parsec.string "js" *> pure JS + , Parsec.char 'c' *> Parsec.choice [ Parsec.string "mm" *> pure Cmm , Parsec.string "pp" *> pure Cxx , pure C @@ -238,6 +242,7 @@ compileNonHsObject rs lang path = do C -> obj2src "c" (const False) ctx path Cmm -> obj2src "cmm" isGeneratedCmmFile ctx path Cxx -> obj2src "cpp" (const False) ctx path + JS -> obj2src "js" (const False) ctx path need [src] needDependencies lang ctx src (path <.> "d") buildWithResources rs $ target ctx (builder stage) [src] [path] diff --git a/hadrian/src/Rules/Generate.hs b/hadrian/src/Rules/Generate.hs index a44ca510d2..2c02407d31 100644 --- a/hadrian/src/Rules/Generate.hs +++ b/hadrian/src/Rules/Generate.hs @@ -42,15 +42,23 @@ rtsDependencies :: Expr [FilePath] rtsDependencies = do stage <- getStage rtsPath <- expr (rtsBuildPath stage) + jsTarget <- expr isJsTarget useSystemFfi <- expr (flag UseSystemFfi) - let headers = + let -- headers common to native and JS RTS + common_headers = [ "ghcautoconf.h", "ghcplatform.h" , "DerivedConstants.h" - , "rts" -/- "EventTypes.h" + ] + -- headers specific to the native RTS + native_headers = + [ "rts" -/- "EventTypes.h" , "rts" -/- "EventLogConstants.h" ] ++ (if useSystemFfi then [] else libffiHeaderFiles) + headers + | jsTarget = common_headers + | otherwise = common_headers ++ native_headers pure $ ((rtsPath -/- "include") -/-) <$> headers genapplyDependencies :: Expr [FilePath] diff --git a/hadrian/src/Rules/Libffi.hs b/hadrian/src/Rules/Libffi.hs index c0a27128ca..61aa133038 100644 --- a/hadrian/src/Rules/Libffi.hs +++ b/hadrian/src/Rules/Libffi.hs @@ -68,8 +68,10 @@ dynLibManifest = dynLibManifest' buildRoot -- | Need the (locally built) libffi library. needLibffi :: Stage -> Action () needLibffi stage = do - manifest <- dynLibManifest stage - need [manifest] + jsTarget <- isJsTarget + unless jsTarget $ do + manifest <- dynLibManifest stage + need [manifest] -- | Context for @libffi@. libffiContext :: Stage -> Action Context @@ -155,7 +157,11 @@ needLibfffiArchive buildPath = do libffiRules :: Rules () libffiRules = do _ <- addOracleCache $ \ (LibffiDynLibs stage) - -> readFileLines =<< dynLibManifest stage + -> do + jsTarget <- isJsTarget + if jsTarget + then return [] + else readFileLines =<< dynLibManifest stage forM_ [Stage1, Stage2, Stage3] $ \stage -> do root <- buildRootRules let path = root -/- stageString stage diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs index d50f283cfe..2e63f1768f 100644 --- a/hadrian/src/Rules/Library.hs +++ b/hadrian/src/Rules/Library.hs @@ -172,10 +172,11 @@ nonHsObjects context = do asmObjs <- mapM (objectPath context) asmSrcs cObjs <- cObjects context cxxObjs <- cxxObjects context + jsObjs <- jsObjects context cmmSrcs <- interpretInContext context (getContextData cmmSrcs) cmmObjs <- mapM (objectPath context) cmmSrcs eObjs <- extraObjects context - return $ asmObjs ++ cObjs ++ cxxObjs ++ cmmObjs ++ eObjs + return $ asmObjs ++ cObjs ++ cxxObjs ++ cmmObjs ++ jsObjs ++ eObjs -- | Return all the Cxx object files needed to build the given library context. cxxObjects :: Context -> Action [FilePath] @@ -192,6 +193,12 @@ cObjects context = do then objs else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs +-- | Return all the JS object files to be included in the library. +jsObjects :: Context -> Action [FilePath] +jsObjects context = do + srcs <- interpretInContext context (getContextData jsSrcs) + mapM (objectPath context) srcs + -- | Return extra object files needed to build the given library context. The -- resulting list is currently non-empty only when the package from the -- 'Context' is @ghc-bignum@ built with in-tree GMP backend. diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs index 71cccd628f..09965ee64c 100644 --- a/hadrian/src/Rules/Program.hs +++ b/hadrian/src/Rules/Program.hs @@ -120,10 +120,12 @@ buildBinary rs bin context@Context {..} = do asmObjs <- mapM (objectPath context) asmSrcs cSrcs <- interpretInContext context (getContextData cSrcs) cxxSrcs <- interpretInContext context (getContextData cxxSrcs) + jsSrcs <- interpretInContext context (getContextData jsSrcs) cObjs <- mapM (objectPath context) cSrcs cxxObjs <- mapM (objectPath context) cxxSrcs + jsObjs <- mapM (objectPath context) jsSrcs hsObjs <- hsObjects context - let binDeps = asmObjs ++ cObjs ++ cxxObjs ++ hsObjs + let binDeps = asmObjs ++ cObjs ++ cxxObjs ++ jsObjs ++ hsObjs need binDeps buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin] synopsis <- pkgSynopsis package diff --git a/hadrian/src/Rules/Register.hs b/hadrian/src/Rules/Register.hs index 2574130c9c..e716204614 100644 --- a/hadrian/src/Rules/Register.hs +++ b/hadrian/src/Rules/Register.hs @@ -6,6 +6,7 @@ module Rules.Register ( import Base import Context import Expression ( getContextData ) +import Oracles.Setting import Hadrian.BuildPath import Hadrian.Expression import Hadrian.Haskell.Cabal @@ -136,15 +137,26 @@ buildConfFinal rs context@Context {..} _conf = do path <- buildPath context -- Special package cases (these should ideally be rolled into Cabal). - when (package == rts) $ + when (package == rts) $ do + jsTarget <- isJsTarget + -- If Cabal knew about "generated-headers", we could read them from the -- 'configuredCabal' information, and just "need" them here. - need [ path -/- "include/DerivedConstants.h" - , path -/- "include/ghcautoconf.h" - , path -/- "include/ghcplatform.h" - , path -/- "include/rts/EventLogConstants.h" + let common_headers = + [ path -/- "include/DerivedConstants.h" + , path -/- "include/ghcautoconf.h" + , path -/- "include/ghcplatform.h" + ] + -- headers only required for the native RTS + native_headers = + [ path -/- "include/rts/EventLogConstants.h" , path -/- "include/rts/EventTypes.h" ] + headers + | jsTarget = common_headers + | otherwise = common_headers ++ native_headers + + need headers -- we need to generate this file for GMP when (package == ghcBignum) $ do diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs index e08c2a856f..adcc7f51cc 100644 --- a/hadrian/src/Rules/Rts.hs +++ b/hadrian/src/Rules/Rts.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} + module Rules.Rts (rtsRules, needRtsLibffiTargets, needRtsSymLinks) where import qualified Data.Set as Set @@ -121,13 +123,14 @@ needRtsLibffiTargets :: Stage -> Action [FilePath] needRtsLibffiTargets stage = do rtsPath <- rtsBuildPath stage useSystemFfi <- flag UseSystemFfi + jsTarget <- isJsTarget -- Header files (in the rts build dir). let headers = fmap ((rtsPath -/- "include") -/-) libffiHeaderFiles - if useSystemFfi - then return [] - else do + if | jsTarget -> return [] + | useSystemFfi -> return [] + | otherwise -> do -- Need Libffi -- This returns the dynamic library files (in the Libffi build dir). needLibffi stage diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs index f1fb204c88..0c8bd0059d 100644 --- a/hadrian/src/Rules/Test.hs +++ b/hadrian/src/Rules/Test.hs @@ -9,6 +9,7 @@ import Expression import Flavour import Hadrian.Haskell.Cabal.Type (packageDependencies) import Hadrian.Oracles.Cabal (readPackageData) +import Hadrian.Oracles.Path (fixAbsolutePathOnWindows) import Oracles.Setting import Oracles.TestSettings import Oracles.Flag @@ -191,9 +192,32 @@ testRules = do -- Prepare Ghc configuration file for input compiler. need [root -/- timeoutPath] + cross <- flag CrossCompiling - ghcPath <- getCompilerPath testCompilerArg + -- get relative path for the given program in the given stage + let relative_path_stage s p = programPath =<< programContext s p + let make_absolute rel_path = do + abs_path <- liftIO (IO.makeAbsolute rel_path) + fixAbsolutePathOnWindows abs_path + + rel_ghc_pkg <- relative_path_stage Stage1 ghcPkg + rel_hsc2hs <- relative_path_stage Stage1 hsc2hs + rel_hp2ps <- relative_path_stage Stage1 hp2ps + rel_haddock <- relative_path_stage (Stage0 InTreeLibs) haddock + rel_hpc <- relative_path_stage (Stage0 InTreeLibs) hpc + rel_runghc <- relative_path_stage (Stage0 InTreeLibs) runGhc + -- force stage0 program building for cross + when cross $ need [rel_hpc, rel_haddock, rel_runghc] + + prog_ghc_pkg <- make_absolute rel_ghc_pkg + prog_hsc2hs <- make_absolute rel_hsc2hs + prog_hp2ps <- make_absolute rel_hp2ps + prog_haddock <- make_absolute rel_haddock + prog_hpc <- make_absolute rel_hpc + prog_runghc <- make_absolute rel_runghc + + ghcPath <- getCompilerPath testCompilerArg makePath <- builderPath $ Make "" top <- topDirectory @@ -222,6 +246,15 @@ testRules = do setEnv "TEST_HC_OPTS_INTERACTIVE" ghciFlags setEnv "TEST_CC" ccPath setEnv "TEST_CC_OPTS" ccFlags + + when cross $ do + setEnv "GHC_PKG" prog_ghc_pkg + setEnv "HSC2HS" prog_hsc2hs + setEnv "HP2PS_ABS" prog_hp2ps + setEnv "HPC" prog_hpc + setEnv "HADDOCK" prog_haddock + setEnv "RUNGHC" prog_runghc + setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath) setEnv "CHECK_EXACT" (top -/- root -/- checkExactProgPath) setEnv "COUNT_DEPS" (top -/- root -/- countDepsProgPath) diff --git a/hadrian/src/Settings/Flavours/Performance.hs b/hadrian/src/Settings/Flavours/Performance.hs index fc46920703..21de3c72fe 100644 --- a/hadrian/src/Settings/Flavours/Performance.hs +++ b/hadrian/src/Settings/Flavours/Performance.hs @@ -13,6 +13,10 @@ performanceFlavour = defaultFlavour performanceArgs :: Args performanceArgs = sourceArgs SourceArgs { hsDefault = pure ["-O", "-H64m"] - , hsLibrary = notStage0 ? arg "-O2" + , hsLibrary = orM [notStage0, cross] ? arg "-O2" , hsCompiler = pure ["-O2"] - , hsGhc = mconcat [stage0 ? arg "-O", notStage0 ? arg "-O2"] } + , hsGhc = mconcat + [ andM [stage0, notCross] ? arg "-O" + , orM [notStage0, cross] ? arg "-O2" + ] + } diff --git a/libraries/array b/libraries/array -Subproject 77990b2132ba688f6282822891da2b9455e33c2 +Subproject acd92ba77c205a039d9c6eaabb3e35d09e33016 diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index 1bf020b8a9..87ddc9584a 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -105,17 +105,25 @@ module Control.Concurrent ( ) where +-- JavaScript platform doesn't support bound threads +#if !defined(js_HOST_ARCH) +#define SUPPORT_BOUND_THREADS +#endif + import Control.Exception.Base as Exception import GHC.Conc hiding (threadWaitRead, threadWaitWrite, threadWaitReadSTM, threadWaitWriteSTM) + +#if defined(SUPPORT_BOUND_THREADS) import GHC.IO ( unsafeUnmask, catchException ) import GHC.IORef ( newIORef, readIORef, writeIORef ) import GHC.Base - -import System.Posix.Types ( Fd ) import Foreign.StablePtr import Foreign.C.Types +#endif + +import System.Posix.Types ( Fd ) #if defined(mingw32_HOST_OS) import Foreign.C @@ -250,6 +258,27 @@ waiting for the results in the main thread. -} +#if !defined(SUPPORT_BOUND_THREADS) +forkOS :: IO () -> IO ThreadId +forkOS _ = error "forkOS not supported on this architecture" + +forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkOSWithUnmask _ = error "forkOS not supported on this architecture" + +isCurrentThreadBound :: IO Bool +isCurrentThreadBound = pure False + +runInBoundThread :: IO a -> IO a +runInBoundThread action = action + +runInUnboundThread :: IO a -> IO a +runInUnboundThread action = action + +rtsSupportsBoundThreads :: Bool +rtsSupportsBoundThreads = False +#else + + -- | 'True' if bound threads are supported. -- If @rtsSupportsBoundThreads@ is 'False', 'isCurrentThreadBound' -- will always return 'False' and both 'forkOS' and 'runInBoundThread' will @@ -390,6 +419,8 @@ runInUnboundThread action = do unsafeResult :: Either SomeException a -> IO a unsafeResult = either Exception.throwIO return +#endif + -- --------------------------------------------------------------------------- -- threadWaitRead/threadWaitWrite diff --git a/libraries/base/GHC/Conc/IO.hs b/libraries/base/GHC/Conc/IO.hs index 344a688d28..869847e77a 100644 --- a/libraries/base/GHC/Conc/IO.hs +++ b/libraries/base/GHC/Conc/IO.hs @@ -65,12 +65,14 @@ import GHC.IO.SubSystem import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA, asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler, toWin32ConsoleEvent) -#else +#elif !defined(js_HOST_ARCH) import qualified GHC.Event.Thread as Event #endif ensureIOManagerIsRunning :: IO () -#if !defined(mingw32_HOST_OS) +#if defined(js_HOST_ARCH) +ensureIOManagerIsRunning = pure () +#elif !defined(mingw32_HOST_OS) ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning #else ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning @@ -89,7 +91,7 @@ interruptIOManager = Windows.interruptIOManager #endif ioManagerCapabilitiesChanged :: IO () -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) ioManagerCapabilitiesChanged = Event.ioManagerCapabilitiesChanged #else ioManagerCapabilitiesChanged = return () @@ -103,7 +105,7 @@ ioManagerCapabilitiesChanged = return () -- that has been used with 'threadWaitRead', use 'closeFdWith'. threadWaitRead :: Fd -> IO () threadWaitRead fd -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) | threaded = Event.threadWaitRead fd #endif | otherwise = IO $ \s -> @@ -119,7 +121,7 @@ threadWaitRead fd -- that has been used with 'threadWaitWrite', use 'closeFdWith'. threadWaitWrite :: Fd -> IO () threadWaitWrite fd -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) | threaded = Event.threadWaitWrite fd #endif | otherwise = IO $ \s -> @@ -133,7 +135,7 @@ threadWaitWrite fd -- in the file descriptor. threadWaitReadSTM :: Fd -> IO (Sync.STM (), IO ()) threadWaitReadSTM fd -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) | threaded = Event.threadWaitReadSTM fd #endif | otherwise = do @@ -152,7 +154,7 @@ threadWaitReadSTM fd -- in the file descriptor. threadWaitWriteSTM :: Fd -> IO (Sync.STM (), IO ()) threadWaitWriteSTM fd -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) | threaded = Event.threadWaitWriteSTM fd #endif | otherwise = do @@ -177,7 +179,7 @@ closeFdWith :: (Fd -> IO ()) -- ^ Low-level action that performs the real close. -> Fd -- ^ File descriptor to close. -> IO () closeFdWith close fd -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) | threaded = Event.closeFdWith close fd #endif | otherwise = close fd @@ -197,8 +199,8 @@ threadDelay time #if defined(mingw32_HOST_OS) | isWindowsNativeIO = Windows.threadDelay time | threaded = Windows.threadDelay time -#else - | threaded = Event.threadDelay time +#elif !defined(js_HOST_ARCH) + | threaded = Event.threadDelay time #endif | otherwise = IO $ \s -> case time of { I# time# -> @@ -213,13 +215,15 @@ threadDelay time -- 2147483647 μs, less than 36 minutes. -- registerDelay :: Int -> IO (TVar Bool) -registerDelay usecs +registerDelay _usecs #if defined(mingw32_HOST_OS) - | isWindowsNativeIO = Windows.registerDelay usecs - | threaded = Windows.registerDelay usecs -#else - | threaded = Event.registerDelay usecs + | isWindowsNativeIO = Windows.registerDelay _usecs + | threaded = Windows.registerDelay _usecs +#elif !defined(js_HOST_ARCH) + | threaded = Event.registerDelay _usecs #endif | otherwise = errorWithoutStackTrace "registerDelay: requires -threaded" +#if !defined(js_HOST_ARCH) foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool +#endif diff --git a/libraries/base/GHC/Conc/Windows.hs b/libraries/base/GHC/Conc/Windows.hs index 50b91aaa45..e9733806e7 100644 --- a/libraries/base/GHC/Conc/Windows.hs +++ b/libraries/base/GHC/Conc/Windows.hs @@ -19,6 +19,9 @@ -- #not-home module GHC.Conc.Windows +#if defined(js_HOST_ARCH) + () where +#else ( ensureIOManagerIsRunning , interruptIOManager @@ -117,4 +120,4 @@ ensureIOManagerIsRunning = POSIX.ensureIOManagerIsRunning interruptIOManager :: IO () interruptIOManager = POSIX.interruptIOManager <!> WINIO.interruptIOManager - +#endif diff --git a/libraries/base/GHC/Event.hs b/libraries/base/GHC/Event.hs index 9f1d3dfd73..a9acda5516 100644 --- a/libraries/base/GHC/Event.hs +++ b/libraries/base/GHC/Event.hs @@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} -- ---------------------------------------------------------------------------- -- | This module provides scalable event notification for file @@ -10,6 +11,9 @@ -- ---------------------------------------------------------------------------- module GHC.Event +#if defined(js_HOST_ARCH) + ( ) where +#else ( -- * Types EventManager , TimerManager @@ -44,3 +48,4 @@ import GHC.Event.TimerManager (TimeoutCallback, TimeoutKey, registerTimeout, updateTimeout, unregisterTimeout, TimerManager) import GHC.Event.Thread (getSystemEventManager, getSystemTimerManager) +#endif diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index 7e7b215f24..f76e9147da 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -2,7 +2,12 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns, NoImplicitPrelude #-} +#include <ghcplatform.h> + module GHC.Event.Thread +#if defined(js_HOST_ARCH) + ( ) where +#else ( getSystemEventManager , getSystemTimerManager , ensureIOManagerIsRunning @@ -17,7 +22,6 @@ module GHC.Event.Thread , blockedOnBadFD -- used by RTS ) where -#include <ghcplatform.h> -- TODO: Use new Windows I/O manager import Control.Exception (finally, SomeException, toException) @@ -439,3 +443,5 @@ foreign import ccall unsafe "setIOManagerControlFd" foreign import ccall unsafe "setTimerManagerControlFd" c_setTimerManagerControlFd :: CInt -> IO () #endif + +#endif diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index 508b9e0a0a..bb26741d58 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -7,6 +7,9 @@ -- TODO: use the new Windows IO manager module GHC.Event.TimerManager +#if defined(js_HOST_ARCH) + () where +#else ( -- * Types TimerManager @@ -261,3 +264,5 @@ editTimeouts mgr g = do -- minimum element didn't change. t0 /= t1 _ -> True + +#endif diff --git a/libraries/base/GHC/IO/Encoding.hs b/libraries/base/GHC/IO/Encoding.hs index a7162f565b..ea738c56a4 100644 --- a/libraries/base/GHC/IO/Encoding.hs +++ b/libraries/base/GHC/IO/Encoding.hs @@ -180,7 +180,11 @@ initLocaleEncoding, initFileSystemEncoding, initForeignEncoding :: TextEncoding -- N.B. initLocaleEncoding is exported for use in System.IO.localeEncoding. -- NOINLINE ensures that this result is shared. -#if !defined(mingw32_HOST_OS) +#if defined(js_HOST_ARCH) +initLocaleEncoding = utf8 +initFileSystemEncoding = utf8 +initForeignEncoding = utf8 +#elif !defined(mingw32_HOST_OS) -- It is rather important that we don't just call Iconv.mkIconvEncoding here -- because some iconvs (in particular GNU iconv) will brokenly UTF-8 encode -- lone surrogates without complaint. diff --git a/libraries/base/GHC/IO/Encoding/CodePage/API.hs b/libraries/base/GHC/IO/Encoding/CodePage/API.hs index 41bc8d0f07..ef6bebd002 100644 --- a/libraries/base/GHC/IO/Encoding/CodePage/API.hs +++ b/libraries/base/GHC/IO/Encoding/CodePage/API.hs @@ -32,6 +32,10 @@ import GHC.ForeignPtr (castForeignPtr) import System.Posix.Internals +#if defined(js_HOST_ARCH) +mkCodePageEncoding :: String +mkCodePageEncoding = "" +#else c_DEBUG_DUMP :: Bool c_DEBUG_DUMP = False @@ -422,3 +426,5 @@ cpRecode try' is_valid_prefix max_i_size min_o_size iscale oscale = go -- Must have interpreted all given bytes successfully -- We need to iterate until we have consumed the complete contents of the buffer Right wrote_elts -> go (bufferRemove n ibuf) (obuf { bufR = bufR obuf + wrote_elts }) + +#endif diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs index 951a3ebecc..2886658a5c 100644 --- a/libraries/base/GHC/IO/FD.hs +++ b/libraries/base/GHC/IO/FD.hs @@ -570,6 +570,10 @@ indicates that there's no data, we call threadWaitRead. readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int readRawBufferPtr loc !fd !buf !off !len +#if defined(js_HOST_ARCH) + = fmap fromIntegral . uninterruptibleMask_ $ + throwErrnoIfMinus1 loc (c_read (fdFD fd) (buf `plusPtr` off) len) +#else | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block | otherwise = do r <- throwErrnoIfMinus1 loc (unsafe_fdReady (fdFD fd) 0 0 0) @@ -583,10 +587,19 @@ readRawBufferPtr loc !fd !buf !off !len read = if threaded then safe_read else unsafe_read unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len) safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len) +#endif -- return: -1 indicates EOF, >=0 is bytes read readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int readRawBufferPtrNoBlock loc !fd !buf !off !len +#if defined(js_HOST_ARCH) + = uninterruptibleMask_ $ do + r <- throwErrnoIfMinus1 loc (c_read (fdFD fd) (buf `plusPtr` off) len) + case r of + (-1) -> return 0 + 0 -> return (-1) + n -> return (fromIntegral n) +#else | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0 if r /= 0 then safe_read @@ -600,9 +613,14 @@ readRawBufferPtrNoBlock loc !fd !buf !off !len n -> return (fromIntegral n) unsafe_read = do_read (c_read (fdFD fd) (buf `plusPtr` off) len) safe_read = do_read (c_safe_read (fdFD fd) (buf `plusPtr` off) len) +#endif writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtr loc !fd !buf !off !len +#if defined(js_HOST_ARCH) + = fmap fromIntegral . uninterruptibleMask_ $ + throwErrnoIfMinus1 loc (c_write (fdFD fd) (buf `plusPtr` off) len) +#else | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 if r /= 0 @@ -615,9 +633,17 @@ writeRawBufferPtr loc !fd !buf !off !len write = if threaded then safe_write else unsafe_write unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len) safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len) +#endif writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt writeRawBufferPtrNoBlock loc !fd !buf !off !len +#if defined(js_HOST_ARCH) + = uninterruptibleMask_ $ do + r <- throwErrnoIfMinus1 loc (c_write (fdFD fd) (buf `plusPtr` off) len) + case r of + (-1) -> return 0 + n -> return (fromIntegral n) +#else | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 if r /= 0 then write @@ -630,12 +656,15 @@ writeRawBufferPtrNoBlock loc !fd !buf !off !len write = if threaded then safe_write else unsafe_write unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len) safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len) +#endif +#if !defined(js_HOST_ARCH) isNonBlocking :: FD -> Bool isNonBlocking fd = fdIsNonBlocking fd /= 0 foreign import ccall unsafe "fdReady" unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt +#endif #else /* mingw32_HOST_OS.... */ @@ -725,12 +754,14 @@ foreign import WINDOWS_CCONV safe "send" #endif +#if !defined(js_HOST_ARCH) foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool +#endif -- ----------------------------------------------------------------------------- -- utils -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) throwErrnoIfMinus1RetryOnBlock :: String -> IO CSsize -> IO CSsize -> IO CSsize throwErrnoIfMinus1RetryOnBlock loc f on_block = do diff --git a/libraries/base/GHC/JS/Prim.hs b/libraries/base/GHC/JS/Prim.hs new file mode 100644 index 0000000000..4a9505cbdf --- /dev/null +++ b/libraries/base/GHC/JS/Prim.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE GHCForeignImportPrim #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE UnboxedTuples #-} + +module GHC.JS.Prim ( JSVal(..), JSVal# + , JSException(..) + , WouldBlockException(..) +#if defined(js_HOST_ARCH) + , toIO + , resolve + , resolveIO + , mkJSException + , fromJSString + , toJSString + , toJSArray + , fromJSArray + , fromJSInt + , toJSInt + , isNull + , isUndefined + , jsNull + , getProp + , getProp' + , getProp# + , unsafeGetProp + , unsafeGetProp' + , unsafeGetProp# + , unpackJSString# + , unpackJSStringUtf8# + , unsafeUnpackJSString# + , unsafeUnpackJSStringUtf8# + , unpackJSStringUtf8## + , unsafeUnpackJSStringUtf8## + +#endif + ) where + +import Data.Typeable (Typeable) +import Unsafe.Coerce (unsafeCoerce) + +import GHC.Prim +import qualified GHC.Exception as Ex +import qualified GHC.Exts as Exts +import qualified GHC.CString as GHC +import GHC.IO + +{- + JSVal is a boxed type that can be used as FFI + argument or result. +-} + +#if defined(js_HOST_ARCH) +data JSVal = JSVal ByteArray# +type JSVal# = ByteArray# +#else +data JSVal = JSVal Addr# +type JSVal# = Addr# +#endif + +{- + When a JavaScript exception is raised inside + a safe or interruptible foreign call, it is converted + to a JSException + -} +data JSException = JSException JSVal String + deriving (Typeable) + +instance Ex.Exception JSException + +instance Show JSException where + show (JSException _ xs) = "JavaScript exception: " ++ xs + +#if defined(js_HOST_ARCH) + +{-# NOINLINE toIO #-} +toIO :: Exts.Any -> IO Exts.Any +toIO x = pure x + +{-# NOINLINE resolve #-} +resolve :: JSVal# -> JSVal# -> Exts.Any -> IO () +resolve accept reject x = resolveIO accept reject (pure x) + +{-# NOINLINE resolveIO #-} +resolveIO :: JSVal# -> JSVal# -> IO Exts.Any -> IO () +resolveIO accept reject x = + (x >>= evaluate >>= js_callback_any accept) `catch` + (\(e::Ex.SomeException) -> do + exceptionText <- evaluate (toJSString $ Ex.displayException e) `catch` + (\(_::Ex.SomeException) -> evaluate (toJSString "unknown exception")) + js_callback_jsval reject exceptionText) + +mkJSException :: JSVal -> IO JSException +mkJSException ref = + return (JSException (unsafeCoerce ref) (fromJSString ref)) + +{- | Low-level conversion utilities for packages that cannot + depend on ghcjs-base + -} + +{- | returns an empty string if the JSVal does not contain + a string + -} +fromJSString :: JSVal -> String +fromJSString = unsafeCoerce . js_fromJSString +{-# INLINE fromJSString #-} + +toJSString :: String -> JSVal +toJSString = js_toJSString . unsafeCoerce . seqList +{-# INLINE [0] toJSString #-} +{-# RULES +"GHC.JS.PRIM toJSString/literal" forall a. + toJSString (GHC.unpackCString# a) = JSVal (unsafeUnpackJSStringUtf8## a) +"GHC.JS.PRIM toJSString/literalUtf8" forall a. + toJSString (GHC.unpackCStringUtf8# a) = JSVal (unsafeUnpackJSStringUtf8## a) + #-} + +fromJSArray :: JSVal -> IO [JSVal] +fromJSArray = unsafeCoerce . js_fromJSArray +{-# INLINE fromJSArray #-} + +toJSArray :: [JSVal] -> IO JSVal +toJSArray = js_toJSArray . unsafeCoerce . seqList +{-# INLINE toJSArray #-} + +{- | returns zero if the JSVal does not contain a number + -} +fromJSInt :: JSVal -> Int +fromJSInt = js_fromJSInt +{-# INLINE fromJSInt #-} + +toJSInt :: Int -> JSVal +toJSInt = js_toJSInt +{-# INLINE toJSInt #-} + +isNull :: JSVal -> Bool +isNull = js_isNull +{-# INLINE isNull #-} + +isUndefined :: JSVal -> Bool +isUndefined = js_isUndefined +{-# INLINE isUndefined #-} + +jsNull :: JSVal +jsNull = js_null +{-# INLINE CONLIKE jsNull #-} + +getProp :: JSVal -> String -> IO JSVal +getProp o p = js_getProp o (unsafeCoerce $ seqList p) +{-# INLINE [0] getProp #-} +{-# RULES +"GHC.JS.PRIM getProp/literal" forall o a. + getProp o (GHC.unpackCString# a) = getProp# o a +"GHC.JS.PRIM getProp/literalUtf8" forall o a. + getProp o (GHC.unpackCStringUtf8# a) = getPropUtf8# o a + #-} + +-- | only safe on immutable object +unsafeGetProp :: JSVal -> String -> JSVal +unsafeGetProp o p = js_unsafeGetProp o (unsafeCoerce $ seqList p) +{-# INLINE [0] unsafeGetProp #-} +{-# RULES +"GHC.JS.PRIM unsafeGetProp/literal" forall o a. + unsafeGetProp o (GHC.unpackCString# a) = unsafeGetProp# o a +"GHC.JS.PRIM unsafeGetProp/literalUtf8" forall o a. + unsafeGetProp o (GHC.unpackCStringUtf8# a) = unsafeGetPropUtf8# o a + #-} + +getProp' :: JSVal -> JSVal -> IO JSVal +getProp' o p = js_getProp' o p +{-# INLINE [0] getProp' #-} +{-# RULES +"GHC.JS.PRIM getProp'/literal" forall o a. + getProp' o (unsafeUnpackJSString# a) = getProp# o a +"GHC.JS.PRIM getProp'/literalUtf8" forall o a. + getProp' o (unsafeUnpackJSStringUtf8# a) = getPropUtf8# o a + #-} + +-- | only safe on immutable object +unsafeGetProp' :: JSVal -> JSVal -> JSVal +unsafeGetProp' o p = js_unsafeGetProp' o p +{-# INLINE [0] unsafeGetProp' #-} +{-# RULES +"GHC.JS.PRIM unsafeGetProp'/literal" forall o a. + unsafeGetProp' o (unsafeUnpackJSString# a) = unsafeGetPropUtf8# o a +"GHC.JS.PRIM unsafeGetProp'/literalUtf8" forall o a. + unsafeGetProp' o (unsafeUnpackJSStringUtf8# a) = unsafeGetPropUtf8# o a + #-} + + +-- | only safe on immutable Addr# +getProp# :: JSVal -> Addr# -> IO JSVal +getProp# (JSVal o) p = IO $ + \s -> case getPropUtf8## o p s of (# s', v #) -> (# s', JSVal v #) +{-# INLINE [0] getProp# #-} +-- js_getProp# o p + +-- | only safe on immutable Addr# +getPropUtf8# :: JSVal -> Addr# -> IO JSVal +getPropUtf8# (JSVal o) p = IO $ + \s -> case getPropUtf8## o p s of (# s', v #) -> (# s', JSVal v #) +{-# INLINE [0] getPropUtf8# #-} + +getPropUtf8## :: JSVal# -> Addr# -> State# s -> (# State# s, JSVal# #) +getPropUtf8## o p = js_getPropUtf8## o p +{-# NOINLINE getPropUtf8## #-} + +-- | only safe on immutable Addr# and JSVal +unsafeGetProp# :: JSVal -> Addr# -> JSVal +unsafeGetProp# (JSVal o) p = JSVal (unsafeGetPropUtf8## o p) +{-# INLINE [0] unsafeGetProp# #-} + +-- | only safe on immutable Addr# and JSVal +unsafeGetPropUtf8# :: JSVal -> Addr# -> JSVal +unsafeGetPropUtf8# (JSVal o) p = JSVal (unsafeGetPropUtf8## o p) +{-# INLINE [0] unsafeGetPropUtf8# #-} + +unsafeGetPropUtf8## :: JSVal# -> Addr# -> JSVal# +unsafeGetPropUtf8## o p = js_unsafeGetPropUtf8## o p +{-# NOINLINE unsafeGetPropUtf8## #-} + +unpackJSString# :: Addr# -> IO JSVal +unpackJSString# a = IO $ + \s -> case unpackJSStringUtf8## a s of (# s', v #) -> (# s', JSVal v #) +{-# INLINE [0] unpackJSString# #-} + +unpackJSStringUtf8# :: Addr# -> IO JSVal +unpackJSStringUtf8# a = IO $ + \s -> case unpackJSStringUtf8## a s of (# s', v #) -> (# s', JSVal v #) +{-# INLINE [0] unpackJSStringUtf8# #-} + +unpackJSStringUtf8## :: Addr# -> State# s -> (# State# s, JSVal# #) +unpackJSStringUtf8## a s = js_unpackJSStringUtf8## a s +{-# NOINLINE unpackJSStringUtf8## #-} + +-- | only safe on immutable Addr# +unsafeUnpackJSString# :: Addr# -> JSVal +unsafeUnpackJSString# a = JSVal (unsafeUnpackJSStringUtf8## a) + -- js_unsafeUnpackJSString# a +{-# INLINE [0] unsafeUnpackJSString# #-} + +-- | only safe on immutable Addr# +unsafeUnpackJSStringUtf8# :: Addr# -> JSVal +unsafeUnpackJSStringUtf8# a = JSVal (unsafeUnpackJSStringUtf8## a) +{-# INLINE [0] unsafeUnpackJSStringUtf8# #-} + +unsafeUnpackJSStringUtf8## :: Addr# -> JSVal# +unsafeUnpackJSStringUtf8## a = js_unsafeUnpackJSStringUtf8## a +{-# NOINLINE unsafeUnpackJSStringUtf8## #-} + + +-- reduce the spine and all list elements to whnf +seqList :: [a] -> [a] +seqList xs = go xs `seq` xs + where go (y:ys) = y `seq` go ys + go [] = () + +foreign import javascript unsafe "(($1) => { return h$toHsString($1); })" + js_fromJSString :: JSVal -> Exts.Any + +foreign import javascript unsafe "(($1) => { return h$fromHsString($1); })" + js_toJSString :: Exts.Any -> JSVal + +foreign import javascript unsafe "(($1) => { return h$toHsListJSVal($1); })" + js_fromJSArray :: JSVal -> IO Exts.Any + +foreign import javascript unsafe "(($1) => { return h$fromHsListJSVal($1); })" + js_toJSArray :: Exts.Any -> IO JSVal + +foreign import javascript unsafe "(($1) => { return ($1 === null); })" + js_isNull :: JSVal -> Bool + +foreign import javascript unsafe "(($1) => { return ($1 === undefined); })" + js_isUndefined :: JSVal -> Bool + +foreign import javascript unsafe "(($1) => { return ($r = typeof($1) === 'number' ? ($1|0) : 0;); })" + js_fromJSInt :: JSVal -> Int + +foreign import javascript unsafe "(($1) => { return ($r = $1;); })" + js_toJSInt :: Int -> JSVal + +foreign import javascript unsafe "$r = null;" + js_null :: JSVal + +foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })" + js_getProp :: JSVal -> Exts.Any -> IO JSVal + +foreign import javascript unsafe "(($1,$2) => { return $1[h$fromHsString($2)]; })" + js_unsafeGetProp :: JSVal -> Exts.Any -> JSVal + +foreign import javascript unsafe "(($1,$2) => { return $1[$2]; })" + js_getProp' :: JSVal -> JSVal -> IO JSVal + +foreign import javascript unsafe "(($1,$2) => { return $1[$2]; })" + js_unsafeGetProp' :: JSVal -> JSVal -> JSVal + +foreign import javascript unsafe "(($1,$2_1,$2_2) => { return $1[h$decodeUtf8z($2_1, $2_2)]; })" + js_getPropUtf8## :: JSVal# -> Addr# -> State# s -> (# State# s, JSVal# #) + +foreign import javascript unsafe "(($1,$2_1,$2_2) => { return $1[h$decodeUtf8z($2_1, $2_2)]; })" + js_unsafeGetPropUtf8## :: JSVal# -> Addr# -> JSVal# + +foreign import javascript unsafe "(($1_1,$1_2) => { return h$decodeUtf8z($1_1, $1_2); })" + js_unpackJSStringUtf8## :: Addr# -> State# s -> (# State# s, JSVal# #) + + +foreign import javascript unsafe "(($1_1, $1_2) => { return h$decodeUtf8z($1_1,$1_2); })" + js_unsafeUnpackJSStringUtf8## :: Addr# -> JSVal# + +foreign import javascript unsafe "(($1, $2) => { return $1($2); })" + js_callback_any :: JSVal# -> Exts.Any -> IO () + +foreign import javascript unsafe "(($1, $2) => { return $1($2); })" + js_callback_jsval :: JSVal# -> JSVal -> IO () + +#endif + +{- | If a synchronous thread tries to do something that can only + be done asynchronously, and the thread is set up to not + continue asynchronously, it receives this exception. + -} +data WouldBlockException = WouldBlockException + deriving (Typeable) + +instance Show WouldBlockException where + show _ = "thread would block" + +instance Ex.Exception WouldBlockException diff --git a/libraries/base/GHC/JS/Prim/Internal.hs b/libraries/base/GHC/JS/Prim/Internal.hs new file mode 100644 index 0000000000..be8dd63040 --- /dev/null +++ b/libraries/base/GHC/JS/Prim/Internal.hs @@ -0,0 +1,56 @@ +{- | Code used by the RTS + + -} + +module GHC.JS.Prim.Internal ( blockedIndefinitelyOnMVar + , blockedIndefinitelyOnSTM + , wouldBlock + , ignoreException + , setCurrentThreadResultException + , setCurrentThreadResultValue + ) where + +import Control.Exception + +import GHC.JS.Prim + +wouldBlock :: SomeException +wouldBlock = toException WouldBlockException + +blockedIndefinitelyOnMVar :: SomeException +blockedIndefinitelyOnMVar = toException BlockedIndefinitelyOnMVar + +blockedIndefinitelyOnSTM :: SomeException +blockedIndefinitelyOnSTM = toException BlockedIndefinitelyOnSTM + +ignoreException :: SomeException -> IO () +ignoreException _ = return () + +setCurrentThreadResultException :: SomeException -> IO () +setCurrentThreadResultException e + | Just WouldBlockException <- fromException e = + js_setCurrentThreadResultWouldBlock + | Just (JSException v _) <- fromException e = + js_setCurrentThreadResultJSException v + | otherwise = + js_setCurrentThreadResultHaskellException (toJSString (show e)) + +setCurrentThreadResultValue :: IO JSVal -> IO () +setCurrentThreadResultValue x = js_setCurrentThreadResultValue =<< x + +foreign import javascript unsafe + "(() => { return h$setCurrentThreadResultWouldBlock; })" + js_setCurrentThreadResultWouldBlock :: IO () + +foreign import javascript unsafe + "(($1) => { return h$setCurrentThreadResultJSException($1); })" + js_setCurrentThreadResultJSException :: JSVal -> IO () + +foreign import javascript unsafe + "(($1) => { return h$setCurrentThreadResultHaskellException($1); })" + js_setCurrentThreadResultHaskellException :: JSVal -> IO () + +foreign import javascript unsafe + "(($1) => { return h$setCurrentThreadResultValue($1); })" + js_setCurrentThreadResultValue :: JSVal -> IO () + diff --git a/libraries/base/GHC/JS/Prim/Internal/Build.hs b/libraries/base/GHC/JS/Prim/Internal/Build.hs new file mode 100644 index 0000000000..78203cd787 --- /dev/null +++ b/libraries/base/GHC/JS/Prim/Internal/Build.hs @@ -0,0 +1,1470 @@ +-- helpers for constructing JS objects that can be efficiently inlined as literals +-- no Template Haskell available yet, generated by utils/genBuildObject.hs +{-# LANGUAGE CPP #-} +#if !defined(js_HOST_ARCH) +module GHC.JS.Prim.Internal.Build () where +#else +{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, GHCForeignImportPrim #-} +module GHC.JS.Prim.Internal.Build + ( buildArrayI + , buildArrayM + , buildObjectI + , buildObjectM + , buildArrayI1 + , buildArrayI2 + , buildArrayI3 + , buildArrayI4 + , buildArrayI5 + , buildArrayI6 + , buildArrayI7 + , buildArrayI8 + , buildArrayI9 + , buildArrayI10 + , buildArrayI11 + , buildArrayI12 + , buildArrayI13 + , buildArrayI14 + , buildArrayI15 + , buildArrayI16 + , buildArrayI17 + , buildArrayI18 + , buildArrayI19 + , buildArrayI20 + , buildArrayI21 + , buildArrayI22 + , buildArrayI23 + , buildArrayI24 + , buildArrayI25 + , buildArrayI26 + , buildArrayI27 + , buildArrayI28 + , buildArrayI29 + , buildArrayI30 + , buildArrayI31 + , buildArrayI32 + , buildArrayM1 + , buildArrayM2 + , buildArrayM3 + , buildArrayM4 + , buildArrayM5 + , buildArrayM6 + , buildArrayM7 + , buildArrayM8 + , buildArrayM9 + , buildArrayM10 + , buildArrayM11 + , buildArrayM12 + , buildArrayM13 + , buildArrayM14 + , buildArrayM15 + , buildArrayM16 + , buildArrayM17 + , buildArrayM18 + , buildArrayM19 + , buildArrayM20 + , buildArrayM21 + , buildArrayM22 + , buildArrayM23 + , buildArrayM24 + , buildArrayM25 + , buildArrayM26 + , buildArrayM27 + , buildArrayM28 + , buildArrayM29 + , buildArrayM30 + , buildArrayM31 + , buildArrayM32 + , buildObjectI1 + , buildObjectI2 + , buildObjectI3 + , buildObjectI4 + , buildObjectI5 + , buildObjectI6 + , buildObjectI7 + , buildObjectI8 + , buildObjectI9 + , buildObjectI10 + , buildObjectI11 + , buildObjectI12 + , buildObjectI13 + , buildObjectI14 + , buildObjectI15 + , buildObjectI16 + , buildObjectI17 + , buildObjectI18 + , buildObjectI19 + , buildObjectI20 + , buildObjectI21 + , buildObjectI22 + , buildObjectI23 + , buildObjectI24 + , buildObjectI25 + , buildObjectI26 + , buildObjectI27 + , buildObjectI28 + , buildObjectI29 + , buildObjectI30 + , buildObjectI31 + , buildObjectI32 + , buildObjectM1 + , buildObjectM2 + , buildObjectM3 + , buildObjectM4 + , buildObjectM5 + , buildObjectM6 + , buildObjectM7 + , buildObjectM8 + , buildObjectM9 + , buildObjectM10 + , buildObjectM11 + , buildObjectM12 + , buildObjectM13 + , buildObjectM14 + , buildObjectM15 + , buildObjectM16 + , buildObjectM17 + , buildObjectM18 + , buildObjectM19 + , buildObjectM20 + , buildObjectM21 + , buildObjectM22 + , buildObjectM23 + , buildObjectM24 + , buildObjectM25 + , buildObjectM26 + , buildObjectM27 + , buildObjectM28 + , buildObjectM29 + , buildObjectM30 + , buildObjectM31 + , buildObjectM32 + ) where + +import GHC.JS.Prim +import GHC.Exts +import Unsafe.Coerce +import System.IO.Unsafe + +type O = JSVal -- object +type K = JSVal -- key +type V = JSVal -- value +type J = JSVal -- some JS value +type A = JSVal -- array + +seqTupList :: [(a,b)] -> [(a,b)] +seqTupList xs = go xs `seq` xs + where go ((y1,y2):ys) = y1 `seq` y2 `seq` go ys + go [] = () + +foreign import javascript unsafe "$r = [];" js_emptyArrayI :: A + +buildArrayI :: [J] -> A +buildArrayI xs = unsafePerformIO (toJSArray xs) +{-# INLINE [1] buildArrayI #-} +{-# RULES "buildArrayI/empty" buildArrayI [] = js_emptyArrayI #-} +{-# RULES "buildArrayI/buildArrayI1" forall x1. buildArrayI [x1] = buildArrayI1 x1 #-} +{-# RULES "buildArrayI/buildArrayI2" forall x1 x2. buildArrayI [x1,x2] = buildArrayI2 x1 x2 #-} +{-# RULES "buildArrayI/buildArrayI3" forall x1 x2 x3. buildArrayI [x1,x2,x3] = buildArrayI3 x1 x2 x3 #-} +{-# RULES "buildArrayI/buildArrayI4" forall x1 x2 x3 x4. buildArrayI [x1,x2,x3,x4] = buildArrayI4 x1 x2 x3 x4 #-} +{-# RULES "buildArrayI/buildArrayI5" forall x1 x2 x3 x4 x5. buildArrayI [x1,x2,x3,x4,x5] = buildArrayI5 x1 x2 x3 x4 x5 #-} +{-# RULES "buildArrayI/buildArrayI6" forall x1 x2 x3 x4 x5 x6. buildArrayI [x1,x2,x3,x4,x5,x6] = buildArrayI6 x1 x2 x3 x4 x5 x6 #-} +{-# RULES "buildArrayI/buildArrayI7" forall x1 x2 x3 x4 x5 x6 x7. buildArrayI [x1,x2,x3,x4,x5,x6,x7] = buildArrayI7 x1 x2 x3 x4 x5 x6 x7 #-} +{-# RULES "buildArrayI/buildArrayI8" forall x1 x2 x3 x4 x5 x6 x7 x8. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8] = buildArrayI8 x1 x2 x3 x4 x5 x6 x7 x8 #-} +{-# RULES "buildArrayI/buildArrayI9" forall x1 x2 x3 x4 x5 x6 x7 x8 x9. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9] = buildArrayI9 x1 x2 x3 x4 x5 x6 x7 x8 x9 #-} +{-# RULES "buildArrayI/buildArrayI10" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10] = buildArrayI10 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 #-} +{-# RULES "buildArrayI/buildArrayI11" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11] = buildArrayI11 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 #-} +{-# RULES "buildArrayI/buildArrayI12" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12] = buildArrayI12 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 #-} +{-# RULES "buildArrayI/buildArrayI13" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13] = buildArrayI13 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 #-} +{-# RULES "buildArrayI/buildArrayI14" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14] = buildArrayI14 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 #-} +{-# RULES "buildArrayI/buildArrayI15" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15] = buildArrayI15 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 #-} +{-# RULES "buildArrayI/buildArrayI16" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16] = buildArrayI16 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 #-} +{-# RULES "buildArrayI/buildArrayI17" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17] = buildArrayI17 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 #-} +{-# RULES "buildArrayI/buildArrayI18" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18] = buildArrayI18 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 #-} +{-# RULES "buildArrayI/buildArrayI19" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19] = buildArrayI19 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 #-} +{-# RULES "buildArrayI/buildArrayI20" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20] = buildArrayI20 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 #-} +{-# RULES "buildArrayI/buildArrayI21" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21] = buildArrayI21 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 #-} +{-# RULES "buildArrayI/buildArrayI22" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22] = buildArrayI22 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 #-} +{-# RULES "buildArrayI/buildArrayI23" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23] = buildArrayI23 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 #-} +{-# RULES "buildArrayI/buildArrayI24" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24] = buildArrayI24 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 #-} +{-# RULES "buildArrayI/buildArrayI25" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25] = buildArrayI25 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 #-} +{-# RULES "buildArrayI/buildArrayI26" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26] = buildArrayI26 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 #-} +{-# RULES "buildArrayI/buildArrayI27" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27] = buildArrayI27 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 #-} +{-# RULES "buildArrayI/buildArrayI28" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28] = buildArrayI28 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 #-} +{-# RULES "buildArrayI/buildArrayI29" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29] = buildArrayI29 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 #-} +{-# RULES "buildArrayI/buildArrayI30" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30] = buildArrayI30 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 #-} +{-# RULES "buildArrayI/buildArrayI31" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31] = buildArrayI31 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 #-} +{-# RULES "buildArrayI/buildArrayI32" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32. buildArrayI [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31,x32] = buildArrayI32 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 #-} + +buildArrayI1 :: J -> A +buildArrayI1 x1 = + js_buildArrayI1 x1 +{-# INLINE buildArrayI1 #-} + +foreign import javascript unsafe "[$1]" + js_buildArrayI1 :: J -> A + + +buildArrayI2 :: J -> J -> A +buildArrayI2 x1 x2 = + js_buildArrayI2 x1 x2 +{-# INLINE buildArrayI2 #-} + +foreign import javascript unsafe "[$1,$2]" + js_buildArrayI2 :: J -> J -> A + + +buildArrayI3 :: J -> J -> J -> A +buildArrayI3 x1 x2 x3 = + js_buildArrayI3 x1 x2 x3 +{-# INLINE buildArrayI3 #-} + +foreign import javascript unsafe "[$1,$2,$3]" + js_buildArrayI3 :: J -> J -> J -> A + + +buildArrayI4 :: J -> J -> J -> J -> A +buildArrayI4 x1 x2 x3 x4 = + js_buildArrayI4 x1 x2 x3 x4 +{-# INLINE buildArrayI4 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4]" + js_buildArrayI4 :: J -> J -> J -> J -> A + + +buildArrayI5 :: J -> J -> J -> J -> J -> A +buildArrayI5 x1 x2 x3 x4 x5 = + js_buildArrayI5 x1 x2 x3 x4 x5 +{-# INLINE buildArrayI5 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5]" + js_buildArrayI5 :: J -> J -> J -> J -> J -> A + + +buildArrayI6 :: J -> J -> J -> J -> J -> J -> A +buildArrayI6 x1 x2 x3 x4 x5 x6 = + js_buildArrayI6 x1 x2 x3 x4 x5 x6 +{-# INLINE buildArrayI6 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6]" + js_buildArrayI6 :: J -> J -> J -> J -> J -> J -> A + + +buildArrayI7 :: J -> J -> J -> J -> J -> J -> J -> A +buildArrayI7 x1 x2 x3 x4 x5 x6 x7 = + js_buildArrayI7 x1 x2 x3 x4 x5 x6 x7 +{-# INLINE buildArrayI7 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7]" + js_buildArrayI7 :: J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI8 :: J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI8 x1 x2 x3 x4 x5 x6 x7 x8 = + js_buildArrayI8 x1 x2 x3 x4 x5 x6 x7 x8 +{-# INLINE buildArrayI8 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8]" + js_buildArrayI8 :: J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI9 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI9 x1 x2 x3 x4 x5 x6 x7 x8 x9 = + js_buildArrayI9 x1 x2 x3 x4 x5 x6 x7 x8 x9 +{-# INLINE buildArrayI9 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9]" + js_buildArrayI9 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI10 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI10 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 = + js_buildArrayI10 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 +{-# INLINE buildArrayI10 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10]" + js_buildArrayI10 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI11 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI11 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 = + js_buildArrayI11 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 +{-# INLINE buildArrayI11 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11]" + js_buildArrayI11 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI12 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI12 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 = + js_buildArrayI12 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 +{-# INLINE buildArrayI12 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12]" + js_buildArrayI12 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI13 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI13 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 = + js_buildArrayI13 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 +{-# INLINE buildArrayI13 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13]" + js_buildArrayI13 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI14 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI14 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 = + js_buildArrayI14 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 +{-# INLINE buildArrayI14 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14]" + js_buildArrayI14 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI15 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI15 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 = + js_buildArrayI15 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 +{-# INLINE buildArrayI15 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15]" + js_buildArrayI15 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI16 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI16 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 = + js_buildArrayI16 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 +{-# INLINE buildArrayI16 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16]" + js_buildArrayI16 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI17 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI17 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 = + js_buildArrayI17 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 +{-# INLINE buildArrayI17 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17]" + js_buildArrayI17 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI18 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI18 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 = + js_buildArrayI18 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 +{-# INLINE buildArrayI18 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18]" + js_buildArrayI18 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI19 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI19 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 = + js_buildArrayI19 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 +{-# INLINE buildArrayI19 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19]" + js_buildArrayI19 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI20 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI20 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 = + js_buildArrayI20 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 +{-# INLINE buildArrayI20 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20]" + js_buildArrayI20 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI21 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI21 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 = + js_buildArrayI21 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 +{-# INLINE buildArrayI21 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21]" + js_buildArrayI21 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI22 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI22 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 = + js_buildArrayI22 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 +{-# INLINE buildArrayI22 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22]" + js_buildArrayI22 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI23 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI23 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 = + js_buildArrayI23 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 +{-# INLINE buildArrayI23 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23]" + js_buildArrayI23 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI24 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI24 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 = + js_buildArrayI24 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 +{-# INLINE buildArrayI24 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24]" + js_buildArrayI24 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI25 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI25 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 = + js_buildArrayI25 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 +{-# INLINE buildArrayI25 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25]" + js_buildArrayI25 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI26 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI26 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 = + js_buildArrayI26 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 +{-# INLINE buildArrayI26 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26]" + js_buildArrayI26 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI27 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI27 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 = + js_buildArrayI27 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 +{-# INLINE buildArrayI27 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27]" + js_buildArrayI27 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI28 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI28 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 = + js_buildArrayI28 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 +{-# INLINE buildArrayI28 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28]" + js_buildArrayI28 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI29 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI29 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 = + js_buildArrayI29 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 +{-# INLINE buildArrayI29 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29]" + js_buildArrayI29 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI30 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI30 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 = + js_buildArrayI30 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 +{-# INLINE buildArrayI30 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30]" + js_buildArrayI30 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI31 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI31 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 = + js_buildArrayI31 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 +{-# INLINE buildArrayI31 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31]" + js_buildArrayI31 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +buildArrayI32 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A +buildArrayI32 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 = + js_buildArrayI32 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 +{-# INLINE buildArrayI32 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32]" + js_buildArrayI32 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> A + + +foreign import javascript unsafe "$r = [];" js_emptyArrayM :: IO A + +buildArrayM :: [J] -> IO A +buildArrayM xs = toJSArray xs +{-# INLINE [1] buildArrayM #-} +{-# RULES "buildArrayM/empty" buildArrayM [] = js_emptyArrayM #-} +{-# RULES "buildArrayM/buildArrayM1" forall x1. buildArrayM [x1] = buildArrayM1 x1 #-} +{-# RULES "buildArrayM/buildArrayM2" forall x1 x2. buildArrayM [x1,x2] = buildArrayM2 x1 x2 #-} +{-# RULES "buildArrayM/buildArrayM3" forall x1 x2 x3. buildArrayM [x1,x2,x3] = buildArrayM3 x1 x2 x3 #-} +{-# RULES "buildArrayM/buildArrayM4" forall x1 x2 x3 x4. buildArrayM [x1,x2,x3,x4] = buildArrayM4 x1 x2 x3 x4 #-} +{-# RULES "buildArrayM/buildArrayM5" forall x1 x2 x3 x4 x5. buildArrayM [x1,x2,x3,x4,x5] = buildArrayM5 x1 x2 x3 x4 x5 #-} +{-# RULES "buildArrayM/buildArrayM6" forall x1 x2 x3 x4 x5 x6. buildArrayM [x1,x2,x3,x4,x5,x6] = buildArrayM6 x1 x2 x3 x4 x5 x6 #-} +{-# RULES "buildArrayM/buildArrayM7" forall x1 x2 x3 x4 x5 x6 x7. buildArrayM [x1,x2,x3,x4,x5,x6,x7] = buildArrayM7 x1 x2 x3 x4 x5 x6 x7 #-} +{-# RULES "buildArrayM/buildArrayM8" forall x1 x2 x3 x4 x5 x6 x7 x8. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8] = buildArrayM8 x1 x2 x3 x4 x5 x6 x7 x8 #-} +{-# RULES "buildArrayM/buildArrayM9" forall x1 x2 x3 x4 x5 x6 x7 x8 x9. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9] = buildArrayM9 x1 x2 x3 x4 x5 x6 x7 x8 x9 #-} +{-# RULES "buildArrayM/buildArrayM10" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10] = buildArrayM10 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 #-} +{-# RULES "buildArrayM/buildArrayM11" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11] = buildArrayM11 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 #-} +{-# RULES "buildArrayM/buildArrayM12" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12] = buildArrayM12 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 #-} +{-# RULES "buildArrayM/buildArrayM13" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13] = buildArrayM13 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 #-} +{-# RULES "buildArrayM/buildArrayM14" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14] = buildArrayM14 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 #-} +{-# RULES "buildArrayM/buildArrayM15" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15] = buildArrayM15 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 #-} +{-# RULES "buildArrayM/buildArrayM16" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16] = buildArrayM16 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 #-} +{-# RULES "buildArrayM/buildArrayM17" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17] = buildArrayM17 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 #-} +{-# RULES "buildArrayM/buildArrayM18" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18] = buildArrayM18 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 #-} +{-# RULES "buildArrayM/buildArrayM19" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19] = buildArrayM19 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 #-} +{-# RULES "buildArrayM/buildArrayM20" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20] = buildArrayM20 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 #-} +{-# RULES "buildArrayM/buildArrayM21" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21] = buildArrayM21 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 #-} +{-# RULES "buildArrayM/buildArrayM22" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22] = buildArrayM22 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 #-} +{-# RULES "buildArrayM/buildArrayM23" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23] = buildArrayM23 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 #-} +{-# RULES "buildArrayM/buildArrayM24" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24] = buildArrayM24 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 #-} +{-# RULES "buildArrayM/buildArrayM25" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25] = buildArrayM25 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 #-} +{-# RULES "buildArrayM/buildArrayM26" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26] = buildArrayM26 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 #-} +{-# RULES "buildArrayM/buildArrayM27" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27] = buildArrayM27 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 #-} +{-# RULES "buildArrayM/buildArrayM28" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28] = buildArrayM28 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 #-} +{-# RULES "buildArrayM/buildArrayM29" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29] = buildArrayM29 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 #-} +{-# RULES "buildArrayM/buildArrayM30" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30] = buildArrayM30 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 #-} +{-# RULES "buildArrayM/buildArrayM31" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31] = buildArrayM31 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 #-} +{-# RULES "buildArrayM/buildArrayM32" forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32. buildArrayM [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16,x17,x18,x19,x20,x21,x22,x23,x24,x25,x26,x27,x28,x29,x30,x31,x32] = buildArrayM32 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 #-} + +buildArrayM1 :: J -> IO A +buildArrayM1 x1 = + js_buildArrayM1 x1 +{-# INLINE buildArrayM1 #-} + +foreign import javascript unsafe "[$1]" + js_buildArrayM1 :: J -> IO A + + +buildArrayM2 :: J -> J -> IO A +buildArrayM2 x1 x2 = + js_buildArrayM2 x1 x2 +{-# INLINE buildArrayM2 #-} + +foreign import javascript unsafe "[$1,$2]" + js_buildArrayM2 :: J -> J -> IO A + + +buildArrayM3 :: J -> J -> J -> IO A +buildArrayM3 x1 x2 x3 = + js_buildArrayM3 x1 x2 x3 +{-# INLINE buildArrayM3 #-} + +foreign import javascript unsafe "[$1,$2,$3]" + js_buildArrayM3 :: J -> J -> J -> IO A + + +buildArrayM4 :: J -> J -> J -> J -> IO A +buildArrayM4 x1 x2 x3 x4 = + js_buildArrayM4 x1 x2 x3 x4 +{-# INLINE buildArrayM4 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4]" + js_buildArrayM4 :: J -> J -> J -> J -> IO A + + +buildArrayM5 :: J -> J -> J -> J -> J -> IO A +buildArrayM5 x1 x2 x3 x4 x5 = + js_buildArrayM5 x1 x2 x3 x4 x5 +{-# INLINE buildArrayM5 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5]" + js_buildArrayM5 :: J -> J -> J -> J -> J -> IO A + + +buildArrayM6 :: J -> J -> J -> J -> J -> J -> IO A +buildArrayM6 x1 x2 x3 x4 x5 x6 = + js_buildArrayM6 x1 x2 x3 x4 x5 x6 +{-# INLINE buildArrayM6 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6]" + js_buildArrayM6 :: J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM7 :: J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM7 x1 x2 x3 x4 x5 x6 x7 = + js_buildArrayM7 x1 x2 x3 x4 x5 x6 x7 +{-# INLINE buildArrayM7 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7]" + js_buildArrayM7 :: J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM8 :: J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM8 x1 x2 x3 x4 x5 x6 x7 x8 = + js_buildArrayM8 x1 x2 x3 x4 x5 x6 x7 x8 +{-# INLINE buildArrayM8 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8]" + js_buildArrayM8 :: J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM9 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM9 x1 x2 x3 x4 x5 x6 x7 x8 x9 = + js_buildArrayM9 x1 x2 x3 x4 x5 x6 x7 x8 x9 +{-# INLINE buildArrayM9 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9]" + js_buildArrayM9 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM10 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM10 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 = + js_buildArrayM10 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 +{-# INLINE buildArrayM10 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10]" + js_buildArrayM10 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM11 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM11 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 = + js_buildArrayM11 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 +{-# INLINE buildArrayM11 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11]" + js_buildArrayM11 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM12 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM12 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 = + js_buildArrayM12 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 +{-# INLINE buildArrayM12 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12]" + js_buildArrayM12 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM13 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM13 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 = + js_buildArrayM13 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 +{-# INLINE buildArrayM13 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13]" + js_buildArrayM13 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM14 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM14 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 = + js_buildArrayM14 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 +{-# INLINE buildArrayM14 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14]" + js_buildArrayM14 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM15 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM15 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 = + js_buildArrayM15 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 +{-# INLINE buildArrayM15 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15]" + js_buildArrayM15 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM16 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM16 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 = + js_buildArrayM16 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 +{-# INLINE buildArrayM16 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16]" + js_buildArrayM16 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM17 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM17 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 = + js_buildArrayM17 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 +{-# INLINE buildArrayM17 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17]" + js_buildArrayM17 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM18 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM18 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 = + js_buildArrayM18 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 +{-# INLINE buildArrayM18 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18]" + js_buildArrayM18 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM19 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM19 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 = + js_buildArrayM19 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 +{-# INLINE buildArrayM19 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19]" + js_buildArrayM19 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM20 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM20 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 = + js_buildArrayM20 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 +{-# INLINE buildArrayM20 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20]" + js_buildArrayM20 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM21 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM21 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 = + js_buildArrayM21 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 +{-# INLINE buildArrayM21 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21]" + js_buildArrayM21 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM22 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM22 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 = + js_buildArrayM22 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 +{-# INLINE buildArrayM22 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22]" + js_buildArrayM22 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM23 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM23 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 = + js_buildArrayM23 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 +{-# INLINE buildArrayM23 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23]" + js_buildArrayM23 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM24 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM24 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 = + js_buildArrayM24 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 +{-# INLINE buildArrayM24 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24]" + js_buildArrayM24 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM25 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM25 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 = + js_buildArrayM25 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 +{-# INLINE buildArrayM25 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25]" + js_buildArrayM25 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM26 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM26 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 = + js_buildArrayM26 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 +{-# INLINE buildArrayM26 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26]" + js_buildArrayM26 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM27 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM27 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 = + js_buildArrayM27 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 +{-# INLINE buildArrayM27 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27]" + js_buildArrayM27 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM28 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM28 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 = + js_buildArrayM28 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 +{-# INLINE buildArrayM28 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28]" + js_buildArrayM28 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM29 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM29 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 = + js_buildArrayM29 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 +{-# INLINE buildArrayM29 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29]" + js_buildArrayM29 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM30 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM30 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 = + js_buildArrayM30 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 +{-# INLINE buildArrayM30 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30]" + js_buildArrayM30 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM31 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM31 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 = + js_buildArrayM31 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 +{-# INLINE buildArrayM31 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31]" + js_buildArrayM31 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +buildArrayM32 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A +buildArrayM32 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 = + js_buildArrayM32 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 +{-# INLINE buildArrayM32 #-} + +foreign import javascript unsafe "[$1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32]" + js_buildArrayM32 :: J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> J -> IO A + + +foreign import javascript unsafe "h$buildObjectFromTupList($1)" + js_buildObjectFromTupListI :: Any -> O +foreign import javascript unsafe "$r = {};" js_emptyObjectI :: O +buildObjectI :: [(K,V)] -> O +buildObjectI xs = js_buildObjectFromTupListI . unsafeCoerce . seqTupList $ xs +{-# INLINE [1] buildObjectI #-} +{-# RULES "buildObjectI/empty" buildObjectI [] = js_emptyObjectI #-} +{-# RULES "buildObjectI/buildObjectI1" forall k1 v1. buildObjectI [(k1,v1)] = buildObjectI1 k1 v1 #-} +{-# RULES "buildObjectI/buildObjectI2" forall k1 v1 k2 v2. buildObjectI [(k1,v1),(k2,v2)] = buildObjectI2 k1 v1 k2 v2 #-} +{-# RULES "buildObjectI/buildObjectI3" forall k1 v1 k2 v2 k3 v3. buildObjectI [(k1,v1),(k2,v2),(k3,v3)] = buildObjectI3 k1 v1 k2 v2 k3 v3 #-} +{-# RULES "buildObjectI/buildObjectI4" forall k1 v1 k2 v2 k3 v3 k4 v4. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4)] = buildObjectI4 k1 v1 k2 v2 k3 v3 k4 v4 #-} +{-# RULES "buildObjectI/buildObjectI5" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5)] = buildObjectI5 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 #-} +{-# RULES "buildObjectI/buildObjectI6" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6)] = buildObjectI6 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 #-} +{-# RULES "buildObjectI/buildObjectI7" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7)] = buildObjectI7 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 #-} +{-# RULES "buildObjectI/buildObjectI8" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8)] = buildObjectI8 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 #-} +{-# RULES "buildObjectI/buildObjectI9" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9)] = buildObjectI9 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 #-} +{-# RULES "buildObjectI/buildObjectI10" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10)] = buildObjectI10 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 #-} +{-# RULES "buildObjectI/buildObjectI11" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11)] = buildObjectI11 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 #-} +{-# RULES "buildObjectI/buildObjectI12" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12)] = buildObjectI12 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 #-} +{-# RULES "buildObjectI/buildObjectI13" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13)] = buildObjectI13 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 #-} +{-# RULES "buildObjectI/buildObjectI14" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14)] = buildObjectI14 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 #-} +{-# RULES "buildObjectI/buildObjectI15" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15)] = buildObjectI15 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 #-} +{-# RULES "buildObjectI/buildObjectI16" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16)] = buildObjectI16 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 #-} +{-# RULES "buildObjectI/buildObjectI17" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17)] = buildObjectI17 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 #-} +{-# RULES "buildObjectI/buildObjectI18" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18)] = buildObjectI18 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 #-} +{-# RULES "buildObjectI/buildObjectI19" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19)] = buildObjectI19 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 #-} +{-# RULES "buildObjectI/buildObjectI20" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20)] = buildObjectI20 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 #-} +{-# RULES "buildObjectI/buildObjectI21" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21)] = buildObjectI21 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 #-} +{-# RULES "buildObjectI/buildObjectI22" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22)] = buildObjectI22 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 #-} +{-# RULES "buildObjectI/buildObjectI23" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23)] = buildObjectI23 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 #-} +{-# RULES "buildObjectI/buildObjectI24" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24)] = buildObjectI24 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 #-} +{-# RULES "buildObjectI/buildObjectI25" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25)] = buildObjectI25 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 #-} +{-# RULES "buildObjectI/buildObjectI26" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26)] = buildObjectI26 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 #-} +{-# RULES "buildObjectI/buildObjectI27" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27)] = buildObjectI27 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 #-} +{-# RULES "buildObjectI/buildObjectI28" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28)] = buildObjectI28 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 #-} +{-# RULES "buildObjectI/buildObjectI29" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28),(k29,v29)] = buildObjectI29 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 #-} +{-# RULES "buildObjectI/buildObjectI30" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28),(k29,v29),(k30,v30)] = buildObjectI30 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 #-} +{-# RULES "buildObjectI/buildObjectI31" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28),(k29,v29),(k30,v30),(k31,v31)] = buildObjectI31 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 #-} +{-# RULES "buildObjectI/buildObjectI32" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 k32 v32. buildObjectI [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28),(k29,v29),(k30,v30),(k31,v31),(k32,v32)] = buildObjectI32 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 k32 v32 #-} + +buildObjectI1 :: K -> V -> O +buildObjectI1 k1 v1 = + js_buildObjectI1 k1 v1 +{-# INLINE buildObjectI1 #-} + +foreign import javascript unsafe "h$buildObject($1,$2)" + js_buildObjectI1 :: K -> V -> O + + +buildObjectI2 :: K -> V -> K -> V -> O +buildObjectI2 k1 v1 k2 v2 = + js_buildObjectI2 k1 v1 k2 v2 +{-# INLINE buildObjectI2 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4)" + js_buildObjectI2 :: K -> V -> K -> V -> O + + +buildObjectI3 :: K -> V -> K -> V -> K -> V -> O +buildObjectI3 k1 v1 k2 v2 k3 v3 = + js_buildObjectI3 k1 v1 k2 v2 k3 v3 +{-# INLINE buildObjectI3 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6)" + js_buildObjectI3 :: K -> V -> K -> V -> K -> V -> O + + +buildObjectI4 :: K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI4 k1 v1 k2 v2 k3 v3 k4 v4 = + js_buildObjectI4 k1 v1 k2 v2 k3 v3 k4 v4 +{-# INLINE buildObjectI4 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8)" + js_buildObjectI4 :: K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI5 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI5 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 = + js_buildObjectI5 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 +{-# INLINE buildObjectI5 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10)" + js_buildObjectI5 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI6 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI6 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 = + js_buildObjectI6 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 +{-# INLINE buildObjectI6 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12)" + js_buildObjectI6 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI7 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI7 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 = + js_buildObjectI7 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 +{-# INLINE buildObjectI7 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14)" + js_buildObjectI7 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI8 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI8 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 = + js_buildObjectI8 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 +{-# INLINE buildObjectI8 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16)" + js_buildObjectI8 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI9 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI9 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 = + js_buildObjectI9 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 +{-# INLINE buildObjectI9 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18)" + js_buildObjectI9 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI10 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI10 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 = + js_buildObjectI10 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 +{-# INLINE buildObjectI10 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20)" + js_buildObjectI10 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI11 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI11 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 = + js_buildObjectI11 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 +{-# INLINE buildObjectI11 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22)" + js_buildObjectI11 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI12 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI12 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 = + js_buildObjectI12 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 +{-# INLINE buildObjectI12 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24)" + js_buildObjectI12 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI13 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI13 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 = + js_buildObjectI13 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 +{-# INLINE buildObjectI13 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26)" + js_buildObjectI13 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI14 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI14 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 = + js_buildObjectI14 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 +{-# INLINE buildObjectI14 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28)" + js_buildObjectI14 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI15 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI15 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 = + js_buildObjectI15 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 +{-# INLINE buildObjectI15 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30)" + js_buildObjectI15 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI16 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI16 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 = + js_buildObjectI16 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 +{-# INLINE buildObjectI16 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32)" + js_buildObjectI16 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI17 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI17 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 = + js_buildObjectI17 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 +{-# INLINE buildObjectI17 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34)" + js_buildObjectI17 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI18 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI18 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 = + js_buildObjectI18 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 +{-# INLINE buildObjectI18 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36)" + js_buildObjectI18 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI19 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI19 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 = + js_buildObjectI19 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 +{-# INLINE buildObjectI19 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38)" + js_buildObjectI19 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI20 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI20 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 = + js_buildObjectI20 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 +{-# INLINE buildObjectI20 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40)" + js_buildObjectI20 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI21 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI21 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 = + js_buildObjectI21 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 +{-# INLINE buildObjectI21 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42)" + js_buildObjectI21 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI22 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI22 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 = + js_buildObjectI22 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 +{-# INLINE buildObjectI22 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44)" + js_buildObjectI22 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI23 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI23 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 = + js_buildObjectI23 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 +{-# INLINE buildObjectI23 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46)" + js_buildObjectI23 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI24 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI24 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 = + js_buildObjectI24 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 +{-# INLINE buildObjectI24 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48)" + js_buildObjectI24 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI25 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI25 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 = + js_buildObjectI25 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 +{-# INLINE buildObjectI25 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50)" + js_buildObjectI25 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI26 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI26 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 = + js_buildObjectI26 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 +{-# INLINE buildObjectI26 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52)" + js_buildObjectI26 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI27 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI27 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 = + js_buildObjectI27 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 +{-# INLINE buildObjectI27 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54)" + js_buildObjectI27 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI28 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI28 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 = + js_buildObjectI28 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 +{-# INLINE buildObjectI28 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56)" + js_buildObjectI28 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI29 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI29 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 = + js_buildObjectI29 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 +{-# INLINE buildObjectI29 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56,$57,$58)" + js_buildObjectI29 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI30 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI30 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 = + js_buildObjectI30 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 +{-# INLINE buildObjectI30 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$60)" + js_buildObjectI30 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI31 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI31 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 = + js_buildObjectI31 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 +{-# INLINE buildObjectI31 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$60,$61,$62)" + js_buildObjectI31 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +buildObjectI32 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O +buildObjectI32 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 k32 v32 = + js_buildObjectI32 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 k32 v32 +{-# INLINE buildObjectI32 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$60,$61,$62,$63,$64)" + js_buildObjectI32 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> O + + +foreign import javascript unsafe "h$buildObjectFromTupList($1)" + js_buildObjectFromTupListM :: Any -> IO O +foreign import javascript unsafe "$r = {};" js_emptyObjectM :: IO O +buildObjectM :: [(K,V)] -> IO O +buildObjectM xs = js_buildObjectFromTupListM . unsafeCoerce . seqTupList $ xs +{-# INLINE [1] buildObjectM #-} +{-# RULES "buildObjectM/empty" buildObjectM [] = js_emptyObjectM #-} +{-# RULES "buildObjectM/buildObjectM1" forall k1 v1. buildObjectM [(k1,v1)] = buildObjectM1 k1 v1 #-} +{-# RULES "buildObjectM/buildObjectM2" forall k1 v1 k2 v2. buildObjectM [(k1,v1),(k2,v2)] = buildObjectM2 k1 v1 k2 v2 #-} +{-# RULES "buildObjectM/buildObjectM3" forall k1 v1 k2 v2 k3 v3. buildObjectM [(k1,v1),(k2,v2),(k3,v3)] = buildObjectM3 k1 v1 k2 v2 k3 v3 #-} +{-# RULES "buildObjectM/buildObjectM4" forall k1 v1 k2 v2 k3 v3 k4 v4. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4)] = buildObjectM4 k1 v1 k2 v2 k3 v3 k4 v4 #-} +{-# RULES "buildObjectM/buildObjectM5" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5)] = buildObjectM5 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 #-} +{-# RULES "buildObjectM/buildObjectM6" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6)] = buildObjectM6 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 #-} +{-# RULES "buildObjectM/buildObjectM7" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7)] = buildObjectM7 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 #-} +{-# RULES "buildObjectM/buildObjectM8" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8)] = buildObjectM8 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 #-} +{-# RULES "buildObjectM/buildObjectM9" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9)] = buildObjectM9 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 #-} +{-# RULES "buildObjectM/buildObjectM10" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10)] = buildObjectM10 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 #-} +{-# RULES "buildObjectM/buildObjectM11" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11)] = buildObjectM11 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 #-} +{-# RULES "buildObjectM/buildObjectM12" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12)] = buildObjectM12 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 #-} +{-# RULES "buildObjectM/buildObjectM13" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13)] = buildObjectM13 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 #-} +{-# RULES "buildObjectM/buildObjectM14" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14)] = buildObjectM14 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 #-} +{-# RULES "buildObjectM/buildObjectM15" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15)] = buildObjectM15 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 #-} +{-# RULES "buildObjectM/buildObjectM16" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16)] = buildObjectM16 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 #-} +{-# RULES "buildObjectM/buildObjectM17" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17)] = buildObjectM17 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 #-} +{-# RULES "buildObjectM/buildObjectM18" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18)] = buildObjectM18 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 #-} +{-# RULES "buildObjectM/buildObjectM19" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19)] = buildObjectM19 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 #-} +{-# RULES "buildObjectM/buildObjectM20" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20)] = buildObjectM20 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 #-} +{-# RULES "buildObjectM/buildObjectM21" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21)] = buildObjectM21 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 #-} +{-# RULES "buildObjectM/buildObjectM22" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22)] = buildObjectM22 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 #-} +{-# RULES "buildObjectM/buildObjectM23" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23)] = buildObjectM23 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 #-} +{-# RULES "buildObjectM/buildObjectM24" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24)] = buildObjectM24 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 #-} +{-# RULES "buildObjectM/buildObjectM25" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25)] = buildObjectM25 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 #-} +{-# RULES "buildObjectM/buildObjectM26" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26)] = buildObjectM26 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 #-} +{-# RULES "buildObjectM/buildObjectM27" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27)] = buildObjectM27 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 #-} +{-# RULES "buildObjectM/buildObjectM28" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28)] = buildObjectM28 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 #-} +{-# RULES "buildObjectM/buildObjectM29" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28),(k29,v29)] = buildObjectM29 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 #-} +{-# RULES "buildObjectM/buildObjectM30" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28),(k29,v29),(k30,v30)] = buildObjectM30 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 #-} +{-# RULES "buildObjectM/buildObjectM31" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28),(k29,v29),(k30,v30),(k31,v31)] = buildObjectM31 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 #-} +{-# RULES "buildObjectM/buildObjectM32" forall k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 k32 v32. buildObjectM [(k1,v1),(k2,v2),(k3,v3),(k4,v4),(k5,v5),(k6,v6),(k7,v7),(k8,v8),(k9,v9),(k10,v10),(k11,v11),(k12,v12),(k13,v13),(k14,v14),(k15,v15),(k16,v16),(k17,v17),(k18,v18),(k19,v19),(k20,v20),(k21,v21),(k22,v22),(k23,v23),(k24,v24),(k25,v25),(k26,v26),(k27,v27),(k28,v28),(k29,v29),(k30,v30),(k31,v31),(k32,v32)] = buildObjectM32 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 k32 v32 #-} + +buildObjectM1 :: K -> V -> IO O +buildObjectM1 k1 v1 = + js_buildObjectM1 k1 v1 +{-# INLINE buildObjectM1 #-} + +foreign import javascript unsafe "h$buildObject($1,$2)" + js_buildObjectM1 :: K -> V -> IO O + + +buildObjectM2 :: K -> V -> K -> V -> IO O +buildObjectM2 k1 v1 k2 v2 = + js_buildObjectM2 k1 v1 k2 v2 +{-# INLINE buildObjectM2 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4)" + js_buildObjectM2 :: K -> V -> K -> V -> IO O + + +buildObjectM3 :: K -> V -> K -> V -> K -> V -> IO O +buildObjectM3 k1 v1 k2 v2 k3 v3 = + js_buildObjectM3 k1 v1 k2 v2 k3 v3 +{-# INLINE buildObjectM3 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6)" + js_buildObjectM3 :: K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM4 :: K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM4 k1 v1 k2 v2 k3 v3 k4 v4 = + js_buildObjectM4 k1 v1 k2 v2 k3 v3 k4 v4 +{-# INLINE buildObjectM4 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8)" + js_buildObjectM4 :: K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM5 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM5 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 = + js_buildObjectM5 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 +{-# INLINE buildObjectM5 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10)" + js_buildObjectM5 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM6 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM6 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 = + js_buildObjectM6 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 +{-# INLINE buildObjectM6 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12)" + js_buildObjectM6 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM7 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM7 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 = + js_buildObjectM7 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 +{-# INLINE buildObjectM7 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14)" + js_buildObjectM7 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM8 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM8 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 = + js_buildObjectM8 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 +{-# INLINE buildObjectM8 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16)" + js_buildObjectM8 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM9 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM9 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 = + js_buildObjectM9 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 +{-# INLINE buildObjectM9 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18)" + js_buildObjectM9 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM10 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM10 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 = + js_buildObjectM10 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 +{-# INLINE buildObjectM10 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20)" + js_buildObjectM10 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM11 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM11 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 = + js_buildObjectM11 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 +{-# INLINE buildObjectM11 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22)" + js_buildObjectM11 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM12 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM12 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 = + js_buildObjectM12 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 +{-# INLINE buildObjectM12 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24)" + js_buildObjectM12 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM13 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM13 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 = + js_buildObjectM13 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 +{-# INLINE buildObjectM13 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26)" + js_buildObjectM13 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM14 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM14 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 = + js_buildObjectM14 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 +{-# INLINE buildObjectM14 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28)" + js_buildObjectM14 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM15 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM15 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 = + js_buildObjectM15 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 +{-# INLINE buildObjectM15 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30)" + js_buildObjectM15 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM16 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM16 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 = + js_buildObjectM16 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 +{-# INLINE buildObjectM16 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32)" + js_buildObjectM16 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM17 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM17 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 = + js_buildObjectM17 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 +{-# INLINE buildObjectM17 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34)" + js_buildObjectM17 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM18 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM18 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 = + js_buildObjectM18 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 +{-# INLINE buildObjectM18 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36)" + js_buildObjectM18 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM19 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM19 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 = + js_buildObjectM19 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 +{-# INLINE buildObjectM19 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38)" + js_buildObjectM19 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM20 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM20 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 = + js_buildObjectM20 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 +{-# INLINE buildObjectM20 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40)" + js_buildObjectM20 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM21 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM21 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 = + js_buildObjectM21 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 +{-# INLINE buildObjectM21 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42)" + js_buildObjectM21 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM22 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM22 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 = + js_buildObjectM22 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 +{-# INLINE buildObjectM22 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44)" + js_buildObjectM22 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM23 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM23 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 = + js_buildObjectM23 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 +{-# INLINE buildObjectM23 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46)" + js_buildObjectM23 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM24 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM24 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 = + js_buildObjectM24 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 +{-# INLINE buildObjectM24 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48)" + js_buildObjectM24 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM25 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM25 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 = + js_buildObjectM25 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 +{-# INLINE buildObjectM25 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50)" + js_buildObjectM25 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM26 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM26 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 = + js_buildObjectM26 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 +{-# INLINE buildObjectM26 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52)" + js_buildObjectM26 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM27 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM27 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 = + js_buildObjectM27 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 +{-# INLINE buildObjectM27 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54)" + js_buildObjectM27 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM28 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM28 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 = + js_buildObjectM28 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 +{-# INLINE buildObjectM28 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56)" + js_buildObjectM28 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM29 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM29 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 = + js_buildObjectM29 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 +{-# INLINE buildObjectM29 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56,$57,$58)" + js_buildObjectM29 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM30 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM30 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 = + js_buildObjectM30 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 +{-# INLINE buildObjectM30 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$60)" + js_buildObjectM30 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM31 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM31 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 = + js_buildObjectM31 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 +{-# INLINE buildObjectM31 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$60,$61,$62)" + js_buildObjectM31 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + +buildObjectM32 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O +buildObjectM32 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 k32 v32 = + js_buildObjectM32 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 k7 v7 k8 v8 k9 v9 k10 v10 k11 v11 k12 v12 k13 v13 k14 v14 k15 v15 k16 v16 k17 v17 k18 v18 k19 v19 k20 v20 k21 v21 k22 v22 k23 v23 k24 v24 k25 v25 k26 v26 k27 v27 k28 v28 k29 v29 k30 v30 k31 v31 k32 v32 +{-# INLINE buildObjectM32 #-} + +foreign import javascript unsafe "h$buildObject($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11,$12,$13,$14,$15,$16,$17,$18,$19,$20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$60,$61,$62,$63,$64)" + js_buildObjectM32 :: K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> K -> V -> IO O + + + +#endif diff --git a/libraries/base/GHC/Stack/CCS.hsc b/libraries/base/GHC/Stack/CCS.hsc index fa85270012..b6d3f83b94 100644 --- a/libraries/base/GHC/Stack/CCS.hsc +++ b/libraries/base/GHC/Stack/CCS.hsc @@ -76,6 +76,22 @@ clearCCS :: IO a -> IO a clearCCS (IO m) = IO $ \s -> clearCCS## m s -- | Get the 'CostCentre' at the head of a 'CostCentreStack'. +#if defined(js_HOST_ARCH) +ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) +ccsCC p = peekByteOff p 4 + +ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack) +ccsParent p = peekByteOff p 8 + +ccLabel :: Ptr CostCentre -> IO CString +ccLabel p = peekByteOff p 4 + +ccModule :: Ptr CostCentre -> IO CString +ccModule p = peekByteOff p 8 + +ccSrcSpan :: Ptr CostCentre -> IO CString +ccSrcSpan p = peekByteOff p 12 +#else ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre) ccsCC p = (# peek CostCentreStack, cc) p @@ -94,6 +110,7 @@ ccModule p = (# peek CostCentre, module) p -- | Get the source span of a 'CostCentre'. ccSrcSpan :: Ptr CostCentre -> IO CString ccSrcSpan p = (# peek CostCentre, srcloc) p +#endif -- | Returns a @[String]@ representing the current call stack. This -- can be useful for debugging. diff --git a/libraries/base/GHC/TopHandler.hs b/libraries/base/GHC/TopHandler.hs index b2b29cf5d7..153b5170d7 100644 --- a/libraries/base/GHC/TopHandler.hs +++ b/libraries/base/GHC/TopHandler.hs @@ -47,6 +47,7 @@ import GHC.Weak #if defined(mingw32_HOST_OS) import GHC.ConsoleHandler +#elif defined(js_HOST_ARCH) #else import Data.Dynamic (toDyn) #endif @@ -94,7 +95,9 @@ runMainIO main = topHandler install_interrupt_handler :: IO () -> IO () -#if defined(mingw32_HOST_OS) +#if defined(js_HOST_ARCH) +install_interrupt_handler _ = return () +#elif defined(mingw32_HOST_OS) install_interrupt_handler handler = do _ <- GHC.ConsoleHandler.installHandler $ Catch $ \event -> @@ -266,7 +269,7 @@ unreachable :: IO a unreachable = failIO "If you can read this, shutdownHaskellAndExit did not exit." exitHelper :: CInt -> Int -> IO a -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) || defined(js_HOST_ARCH) exitHelper exitKind r = shutdownHaskellAndExit (fromIntegral r) exitKind >> unreachable #else @@ -294,7 +297,7 @@ foreign import ccall "shutdownHaskellAndSignal" exitInterrupted :: IO a exitInterrupted = -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) || defined(js_HOST_ARCH) safeExit 252 #elif !defined(HAVE_SIGNAL_H) safeExit 1 diff --git a/libraries/base/GHC/Windows.hs b/libraries/base/GHC/Windows.hs index be0c3837a9..85faa25e43 100644 --- a/libraries/base/GHC/Windows.hs +++ b/libraries/base/GHC/Windows.hs @@ -21,6 +21,10 @@ ----------------------------------------------------------------------------- module GHC.Windows ( +#if defined(js_HOST_ARCH) + ) where + +#else -- * Types BOOL, LPBOOL, @@ -236,3 +240,5 @@ ddwordToDwords n = dwordsToDdword:: (DWORD,DWORD) -> DDWORD dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL` finiteBitSize hi) + +#endif diff --git a/libraries/base/System/CPUTime.hsc b/libraries/base/System/CPUTime.hsc index 5b0fdbf4da..19d21e2135 100644 --- a/libraries/base/System/CPUTime.hsc +++ b/libraries/base/System/CPUTime.hsc @@ -34,6 +34,9 @@ import System.IO.Unsafe (unsafePerformIO) #if defined(mingw32_HOST_OS) import qualified System.CPUTime.Windows as I +#elif defined(js_HOST_ARCH) +import qualified System.CPUTime.Javascript as I + #elif _POSIX_TIMERS > 0 && defined(_POSIX_CPUTIME) && _POSIX_CPUTIME >= 0 import qualified System.CPUTime.Posix.ClockGetTime as I diff --git a/libraries/base/System/CPUTime/Javascript.hs b/libraries/base/System/CPUTime/Javascript.hs new file mode 100644 index 0000000000..612d428f0e --- /dev/null +++ b/libraries/base/System/CPUTime/Javascript.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE JavaScriptFFI #-} + +module System.CPUTime.Javascript + ( getCPUTime + , getCpuTimePrecision + ) +where + +import qualified System.CPUTime.Unsupported as I + +getCpuTimePrecision :: IO Integer +getCpuTimePrecision = toInteger <$> js_cpuTimePrecision + +getCPUTime :: IO Integer +getCPUTime = do + t <- js_getCPUTime + if t == -1 then I.getCPUTime + else pure (1000 * round t) + +foreign import javascript unsafe + "(() => { return h$cpuTimePrecision(); })" + js_cpuTimePrecision :: IO Int + +foreign import javascript unsafe + "(() => { return h$getCPUTime(); })" + js_getCPUTime :: IO Double diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs index 44382acf45..c5e5d6d039 100644 --- a/libraries/base/System/Environment.hs +++ b/libraries/base/System/Environment.hs @@ -19,7 +19,9 @@ module System.Environment ( getArgs, getProgName, +#if !defined(js_HOST_ARCH) executablePath, +#endif getExecutablePath, getEnv, lookupEnv, diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc index 1bee1122e8..ede63d5e6d 100644 --- a/libraries/base/System/Environment/ExecutablePath.hsc +++ b/libraries/base/System/Environment/ExecutablePath.hsc @@ -18,9 +18,18 @@ module System.Environment.ExecutablePath ( getExecutablePath +##if !defined(js_HOST_ARCH) , executablePath +##endif ) where +##if defined(js_HOST_ARCH) + +getExecutablePath :: IO FilePath +getExecutablePath = return "a.jsexe" + +##else + -- The imports are purposely kept completely disjoint to prevent edits -- to one OS implementation from breaking another. @@ -372,3 +381,5 @@ executablePath = Nothing -------------------------------------------------------------------------------- #endif + +##endif diff --git a/libraries/base/System/Posix/Internals.hs b/libraries/base/System/Posix/Internals.hs index f2207d32a6..6918aa29a9 100644 --- a/libraries/base/System/Posix/Internals.hs +++ b/libraries/base/System/Posix/Internals.hs @@ -368,9 +368,6 @@ type CFilePath = CString type CFilePath = CWString #endif -foreign import ccall unsafe "HsBase.h __hscore_open" - c_open :: CFilePath -> CInt -> CMode -> IO CInt - -- | The same as 'c_safe_open', but an /interruptible operation/ -- as described in "Control.Exception"—it respects `uninterruptibleMask` -- but not `mask`. @@ -415,11 +412,16 @@ c_interruptible_open filepath oflags mode = interruptible (IO $ \s -> (# yield# s, () #)) pure open_res --- | --- --- @since 4.16.0.0 -foreign import ccall interruptible "HsBase.h __hscore_open" - c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt +c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt +c_safe_open filepath oflags mode = + getMaskingState >>= \case + -- When exceptions are unmasked, we use an interruptible + -- open call. If the system call is successfully + -- interrupted, the situation will be the same as if + -- the exception had arrived before this function was + -- called. + Unmasked -> c_interruptible_open_ filepath oflags mode + _ -> c_safe_open_ filepath oflags mode -- | Consult the RTS to find whether it is threaded. -- @@ -427,21 +429,20 @@ foreign import ccall interruptible "HsBase.h __hscore_open" hostIsThreaded :: Bool hostIsThreaded = rtsIsThreaded_ /= 0 +#if !defined(js_HOST_ARCH) +foreign import ccall unsafe "HsBase.h __hscore_open" + c_open :: CFilePath -> CInt -> CMode -> IO CInt + -- | -- -- @since 4.16.0.0 -foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int +foreign import ccall interruptible "HsBase.h __hscore_open" + c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt -c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt -c_safe_open filepath oflags mode = - getMaskingState >>= \case - -- When exceptions are unmasked, we use an interruptible - -- open call. If the system call is successfully - -- interrupted, the situation will be the same as if - -- the exception had arrived before this function was - -- called. - Unmasked -> c_interruptible_open_ filepath oflags mode - _ -> c_safe_open_ filepath oflags mode +-- | +-- +-- @since 4.16.0.0 +foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int foreign import ccall safe "HsBase.h __hscore_open" c_safe_open_ :: CFilePath -> CInt -> CMode -> IO CInt @@ -452,6 +453,145 @@ foreign import ccall unsafe "HsBase.h __hscore_fstat" foreign import ccall unsafe "HsBase.h __hscore_lstat" lstat :: CFilePath -> Ptr CStat -> IO CInt +#endif + +#if defined(js_HOST_ARCH) + +foreign import javascript unsafe "(() => { return rts_isThreaded; })" rtsIsThreaded_ :: Int +foreign import javascript interruptible "(($1_1, $2_2, $2, $c) => { return h$base_access($1_1,$2_2,$2,$c); })" + c_access :: CString -> CInt -> IO CInt +foreign import javascript interruptible "(($1_1, $2_2, $2, $c) => { return h$base_chmod($1_1,$2_2,$2,$c); })" + c_chmod :: CString -> CMode -> IO CInt +foreign import javascript interruptible "(($1,$c) => { return h$base_close($1,$c); })" + c_close :: CInt -> IO CInt +foreign import javascript interruptible "(($1, $c) => { return h$base_creat($1,$c); })" + c_creat :: CString -> CMode -> IO CInt +foreign import javascript interruptible "(($1, $c) => { return h$base_dup($1, $c); })" + c_dup :: CInt -> IO CInt +foreign import javascript interruptible "(($1, $2, $c) => { return h$base_dup2($1,$2,$c); })" + c_dup2 :: CInt -> CInt -> IO CInt +foreign import javascript interruptible "(($1,$2_1,$2_2,$c) => { return h$base_fstat($1,$2_1,$2_2,$c); })" -- fixme wrong type + c_fstat :: CInt -> Ptr CStat -> IO CInt +foreign import javascript unsafe "(($1) => { return h$base_isatty($1); })" + c_isatty :: CInt -> IO CInt +foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_lseek($1,$2_1,$2_2,$3,$c); })" + c_lseek :: CInt -> COff -> CInt -> IO COff +foreign import javascript interruptible "(($1_1,$1_2,$2_1,$2_2,$c) => { return h$base_lstat($1_1,$1_2,$2_1,$2_2,$c); })" -- fixme wrong type + lstat :: CFilePath -> Ptr CStat -> IO CInt +foreign import javascript interruptible "(($1_1,$1_2,$2,$3,$c) => { return h$base_open($1_1,$1_2,$2,$3,$c); })" + c_open :: CFilePath -> CInt -> CMode -> IO CInt +foreign import javascript interruptible "(($1_1,$1_2,$2,$3,$c) => { return h$base_open($1_1,$1_2,$2,$3,$c); })" + c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt +foreign import javascript interruptible "(($1_1,$1_2,$2,$3,$c) => { return h$base_open($1_1,$1_2,$2,$3,$c); })" + c_safe_open_ :: CFilePath -> CInt -> CMode -> IO CInt +foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_read($1,$2_1,$2_2,$3,$c); })" + c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize +foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_read($1,$2_1,$2_2,$3,$c); })" + c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize +foreign import javascript interruptible "(($1_1,$1_2,$2_1,$2_2,$c) => { return h$base_stat($1_1,$1_2,$2_1,$2_2,$c); })" -- fixme wrong type + c_stat :: CFilePath -> Ptr CStat -> IO CInt +foreign import javascript unsafe "(($1) => { return h$base_umask($1); })" + c_umask :: CMode -> IO CMode +foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_write($1,$2_1,$2_2,$3,$c); })" + c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize +foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_write($1,$2_1,$2_2,$3,$c); })" + c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize +foreign import javascript interruptible "(($1,$2_1,$2_2,$c) => { return h$base_ftruncate($1,$2_1,$2_2,$c); })" -- fixme COff + c_ftruncate :: CInt -> FileOffset -> IO CInt +foreign import javascript interruptible "(($1_1,$1_2,$c) => { return h$base_unlink($1_1,$1_2,$c); })" + c_unlink :: CString -> IO CInt +foreign import javascript unsafe "(() => { return h$base_getpid; })" + c_getpid :: IO CPid +-- foreign import ccall unsafe "HsBase.h fork" +-- c_fork :: IO CPid +foreign import javascript interruptible "($1_1,$1_2,$2_1,$2_2,$c) => { return h$base_link($1_1,$1_2,$2_1,$2_2,$c); })" + c_link :: CString -> CString -> IO CInt +foreign import javascript interruptible "(($1_1,$1_2,$2,$c) => { return h$base_mkfifo($1_1,$1_2,$2,$c); })" + c_mkfifo :: CString -> CMode -> IO CInt +foreign import javascript interruptible "(($1_1,$1_2,$c) => { return h$base_pipe($1_1,$1_2,$c); })" + c_pipe :: Ptr CInt -> IO CInt +foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_sigemptyset($1_1,$1_2); })" + c_sigemptyset :: Ptr CSigset -> IO CInt +foreign import javascript unsafe "(($1_1,$1_2,$2) => { return h$base_sigaddset($1_1,$1_2,$2); })" + c_sigaddset :: Ptr CSigset -> CInt -> IO CInt +foreign import javascript unsafe "(($1,$2_1,$2_2,$3_1,$3_2) => { return h$base_sigprocmask($1,$2_1,$2_2,$3_1,$3_2); })" + c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt +foreign import javascript unsafe "(($1,$2_1,$2_2) => { return h$base_tcgetattr($1,$2_1,$2_2); })" + c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt +foreign import javascript unsafe "(($1,$2,$3_1,$3_2) => { return h$base_tcsetattr($1,$2,$3_1,$3_2); })" + c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt +foreign import javascript unsafe "(($1_1,$1_2,$2_1,$2_2) => { return h$base_utime($1_1,$1_2,$2_1,$2_2); })" -- should this be async? + c_utime :: CString -> Ptr CUtimbuf -> IO CInt +foreign import javascript interruptible "(($1,$2_1,$2_2,$3,$c) => { return h$base_waitpid($1,$2_1,$2_2,$3,$c); })" + c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid + +foreign import javascript unsafe "(() => { return h$base_o_rdonly; })" o_RDONLY :: CInt +foreign import javascript unsafe "(() => { return h$base_o_wronly; })" o_WRONLY :: CInt +foreign import javascript unsafe "(() => { return h$base_o_rdwr; })" o_RDWR :: CInt +foreign import javascript unsafe "(() => { return h$base_o_append; })" o_APPEND :: CInt +foreign import javascript unsafe "(() => { return h$base_o_creat; })" o_CREAT :: CInt +foreign import javascript unsafe "(() => { return h$base_o_excl; })" o_EXCL :: CInt +foreign import javascript unsafe "(() => { return h$base_o_trunc; })" o_TRUNC :: CInt +foreign import javascript unsafe "(() => { return h$base_o_noctty; })" o_NOCTTY :: CInt +foreign import javascript unsafe "(() => { return h$base_o_nonblock; })" o_NONBLOCK :: CInt +foreign import javascript unsafe "(() => { return h$base_o_binary; })" o_BINARY :: CInt + +foreign import javascript unsafe "(($1) => { return h$base_c_s_isreg($1); })" c_s_isreg :: CMode -> CInt +foreign import javascript unsafe "(($1) => { return h$base_c_s_ischr($1); })" c_s_ischr :: CMode -> CInt +foreign import javascript unsafe "(($1) => { return h$base_c_s_isblk($1); })" c_s_isblk :: CMode -> CInt +foreign import javascript unsafe "(($1) => { return h$base_c_s_isdir($1); })" c_s_isdir :: CMode -> CInt +foreign import javascript unsafe "(($1) => { return h$base_c_s_isfifo($1); })" c_s_isfifo :: CMode -> CInt + +s_isreg :: CMode -> Bool +s_isreg cm = c_s_isreg cm /= 0 +s_ischr :: CMode -> Bool +s_ischr cm = c_s_ischr cm /= 0 +s_isblk :: CMode -> Bool +s_isblk cm = c_s_isblk cm /= 0 +s_isdir :: CMode -> Bool +s_isdir cm = c_s_isdir cm /= 0 +s_isfifo :: CMode -> Bool +s_isfifo cm = c_s_isfifo cm /= 0 + +foreign import javascript unsafe "(() => { return h$base_sizeof_stat; })" sizeof_stat :: Int +foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_mtime($1_1,$1_2); })" st_mtime :: Ptr CStat -> IO CTime +foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_size($1_1,$1_2); })" st_size :: Ptr CStat -> IO Int64 +foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_mode($1_1,$1_2); })" st_mode :: Ptr CStat -> IO CMode +foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_dev($1_1,$1_2); })" st_dev :: Ptr CStat -> IO CDev +foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_st_ino($1_1,$1_2); })" st_ino :: Ptr CStat -> IO CIno + +foreign import javascript unsafe "(() => { return h$base_echo; })" const_echo :: CInt +foreign import javascript unsafe "(() => { return h$base_tcsanow; })" const_tcsanow :: CInt +foreign import javascript unsafe "(() => { return h$base_icanon; })" const_icanon :: CInt +foreign import javascript unsafe "(() => { return h$base_vmin; })" const_vmin :: CInt +foreign import javascript unsafe "(() => { return h$base_vtime; })" const_vtime :: CInt +foreign import javascript unsafe "(() => { return h$base_sigttou; })" const_sigttou :: CInt +foreign import javascript unsafe "(() => { return h$base_sig_block; })" const_sig_block :: CInt +foreign import javascript unsafe "(() => { return h$base_sig_setmask; })" const_sig_setmask :: CInt +foreign import javascript unsafe "(() => { return h$base_f_getfl; })" const_f_getfl :: CInt +foreign import javascript unsafe "(() => { return h$base_f_setfl; })" const_f_setfl :: CInt +foreign import javascript unsafe "(() => { return h$base_f_setfd; })" const_f_setfd :: CInt +foreign import javascript unsafe "(() => { return h$base_fd_cloexec; })" const_fd_cloexec :: CLong +foreign import javascript unsafe "(() => { return h$base_sizeof_termios; })" sizeof_termios :: Int +foreign import javascript unsafe "(() => { return h$base_sizeof_sigset_t; })" sizeof_sigset_t :: Int +foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_lflag($1_1,$1_2); })" c_lflag :: Ptr CTermios -> IO CTcflag +foreign import javascript unsafe "(($1_1,$1_2,$2) => { return h$base_poke_lflag($1_1,$1_2,$2); })" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO () +foreign import javascript unsafe "(($1_1,$1_2) => { return h$base_ptr_c_cc($1_1,$1_2); })" ptr_c_cc :: Ptr CTermios -> IO (Ptr Word8) +s_issock :: CMode -> Bool +s_issock cmode = c_s_issock cmode /= 0 +foreign import javascript unsafe "(($1) => { return h$base_c_s_issock($1); })" c_s_issock :: CMode -> CInt +foreign import javascript unsafe "(() => { return h$base_default_buffer_size; })" dEFAULT_BUFFER_SIZE :: Int +foreign import javascript unsafe "(() => { return h$base_SEEK_CUR; })" sEEK_CUR :: CInt +foreign import javascript unsafe "(() => { return h$base_SEEK_SET; })" sEEK_SET :: CInt +foreign import javascript unsafe "(() => { return h$base_SEEK_END; })" sEEK_END :: CInt + +-- fixme, unclear if these can be supported, remove? +foreign import javascript unsafe "(($1, $2) => { return h$base_c_fcntl_read($1,$2); })" c_fcntl_read :: CInt -> CInt -> IO CInt +foreign import javascript unsafe "(($1, $2, $3) => { return h$base_c_fcntl_write($1,$2,$3); })" c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt +foreign import javascript unsafe "(($1,$2,$3_1,$3_2) => { return h$base_c_fcntl_lock($1,$2,$3_1,$3_2); })" c_fcntl_lock :: CInt -> CInt -> Ptr CFLock -> IO CInt + +#else + {- Note: Win32 POSIX functions Functions that are not part of the POSIX standards were at some point deprecated by Microsoft. This deprecation @@ -576,13 +716,15 @@ foreign import ccall unsafe "HsBase.h getpid" c_getpid :: IO CPid #endif +#if !defined(js_HOST_ARCH) foreign import ccall unsafe "HsBase.h __hscore_stat" c_stat :: CFilePath -> Ptr CStat -> IO CInt foreign import ccall unsafe "HsBase.h __hscore_ftruncate" c_ftruncate :: CInt -> COff -> IO CInt +#endif -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) foreign import capi unsafe "HsBase.h fcntl" c_fcntl_read :: CInt -> CInt -> IO CInt @@ -647,6 +789,7 @@ foreign import ccall unsafe "HsBase.h waitpid" c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid #endif +#if !defined(js_HOST_ARCH) -- POSIX flags only: foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt @@ -723,6 +866,8 @@ foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int foreign import capi unsafe "stdio.h value SEEK_CUR" sEEK_CUR :: CInt foreign import capi unsafe "stdio.h value SEEK_SET" sEEK_SET :: CInt foreign import capi unsafe "stdio.h value SEEK_END" sEEK_END :: CInt +#endif +#endif {- Note: Windows types diff --git a/libraries/base/System/Timeout.hs b/libraries/base/System/Timeout.hs index 3cca893c4d..bf215c747a 100644 --- a/libraries/base/System/Timeout.hs +++ b/libraries/base/System/Timeout.hs @@ -17,7 +17,7 @@ -- TODO: Inspect is still suitable. module System.Timeout ( Timeout, timeout ) where -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) import Control.Monad import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) @@ -99,7 +99,7 @@ timeout :: Int -> IO a -> IO (Maybe a) timeout n f | n < 0 = fmap Just f | n == 0 = return Nothing -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) && !defined(js_HOST_ARCH) | rtsSupportsBoundThreads = do -- In the threaded RTS, we use the Timer Manager to delay the -- (fairly expensive) 'forkIO' call until the timeout has expired. diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index a8875f9d59..1af0d4b73b 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -361,20 +361,29 @@ Library System.Environment.ExecutablePath System.CPUTime.Utils - c-sources: - cbits/DarwinUtils.c - cbits/PrelIOUtils.c - cbits/SetEnv.c - cbits/iconv.c - cbits/inputReady.c - cbits/md5.c - cbits/primFloat.c - cbits/sysconf.c - cbits/fs.c + if !arch(js) + c-sources: + cbits/DarwinUtils.c + cbits/PrelIOUtils.c + cbits/SetEnv.c + cbits/iconv.c + cbits/inputReady.c + cbits/md5.c + cbits/primFloat.c + cbits/sysconf.c + cbits/fs.c - cmm-sources: - cbits/CastFloatWord.cmm - cbits/StackCloningDecoding.cmm + cmm-sources: + cbits/CastFloatWord.cmm + cbits/StackCloningDecoding.cmm + + if arch(js) + js-sources: + -- "platform" must be linked first because it defines global constants + -- (e.g. h$isNode) + jsbits/platform.js + jsbits/base.js + jsbits/errno.js include-dirs: include includes: @@ -451,12 +460,22 @@ Library System.CPUTime.Posix.RUsage System.CPUTime.Unsupported + if arch(js) + other-modules: + System.CPUTime.Javascript + -- The Ports framework always passes this flag when building software that -- uses iconv to make iconv from Ports compatible with iconv from the base system -- See /usr/ports/Mk/Uses/iconv.mk if os(freebsd) cc-options: -DLIBICONV_PLUG + if arch(js) + exposed-modules: + GHC.JS.Prim + GHC.JS.Prim.Internal + GHC.JS.Prim.Internal.Build + -- We need to set the unit id to base (without a version number) -- as it's magic. ghc-options: -this-unit-id base diff --git a/libraries/base/jsbits/base.js b/libraries/base/jsbits/base.js new file mode 100644 index 0000000000..dd491bac00 --- /dev/null +++ b/libraries/base/jsbits/base.js @@ -0,0 +1,839 @@ +//#OPTIONS: CPP +#include "HsBaseConfig.h" + +// #define GHCJS_TRACE_IO 1 + +#ifdef GHCJS_TRACE_IO +function h$logIO() { h$log.apply(h$log, arguments); } +#define TRACE_IO(args...) h$logIO(args) +#else +#define TRACE_IO(args...) +#endif + +function h$base_access(file, file_off, mode, c) { + TRACE_IO("base_access") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.stat(fd, function(err, fs) { + if(err) { + h$handleErrnoC(err, -1, 0, c); + } else { + c(mode & fs.mode); // fixme is this ok? + } + }); + } else +#endif + h$unsupported(-1, c); +} + +function h$base_chmod(file, file_off, mode, c) { + TRACE_IO("base_chmod") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.chmod(h$decodeUtf8z(file, file_off), mode, function(err) { + h$handleErrnoC(err, -1, 0, c); + }); + } else +#endif + h$unsupported(-1, c); +} + +function h$base_close(fd, c) { + TRACE_IO("base_close fd: " + fd) + var fdo = h$base_fds[fd]; + if(fdo) { + delete h$base_fds[fd]; + if(--fdo.refs < 1) { + TRACE_IO("base_close: closing underlying fd") + if(fdo.close) { + fdo.close(fd, fdo, c); + } else { + c(0); + } + } else { + TRACE_IO("base_close: remaining references, not closing underlying fd") + c(0); + } + } else { + TRACE_IO("base_close: file descriptor not found, already closed?") + h$errno = CONST_EINVAL; + c(-1); + } +} + +function h$base_dup(fd, c) { + // h$log("h$base_dup al: " + arguments.length); + h$base_dup2(fd, h$base_fdN--, c); +} + +function h$base_dup2(fd, new_fd, c) { + TRACE_IO("base_dup2 " + fd + " " + new_fd) + // if(new_fd >= 0 && new_fd <= 2) { + + // } + // h$log("h$base_dup2 al: " + arguments.length); + // if(fd >= 0 && fd < 2) { + // h$errno = CONST_EINVAL; + // c(-1); + // fixme make sure it can't be called again! + // return; + // } // && new_fd ) + + /* Fixme: + The two descriptors do not share file descriptor flags + (the close-on-exec flag). The close-on-exec flag + (FD_CLOEXEC; see fcntl(2)) for the duplicate descriptor is off. + */ + var fdo = h$base_fds[fd]; + if(!fdo) { + TRACE_IO("file descriptor not found") + h$errno = CONST_EINVAL; + c(-1); + } else { + var new_fdo = h$base_fds[new_fd]; + function f() { + h$base_fds[new_fd] = fdo; + fdo.refs++; + c(new_fd); + } + if(new_fdo) { + TRACE_IO("closing existing fd") + h$base_close(new_fd, f); + } else { + f(); + } // h$new_fdo.close(); + } +} + +function h$base_fstat(fd, stat, stat_off, c) { + TRACE_IO("base_stat") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.fstat(fd, function(err, fs) { + if(err) { + h$handleErrnoC(err, -1, 0, c); + } else { + h$base_fillStat(fs, stat, stat_off); + c(0); + } + }); + } else +#endif + h$unsupported(-1, c); +} + +function h$base_isatty(fd) { + TRACE_IO("base_isatty " + fd) + // return 1; // fixme debug + var fdo = h$base_fds[fd]; + if(fdo && typeof fdo.isatty !== 'undefined') { + if(typeof fdo.isatty === 'function') return fdo.isatty() ? 1 : 0; + return fdo.isatty ? 1 : 0; + } + return 0; +} + + +#define TWO_PWR_32_DBL_ 0x100000000 +#define TWO_PWR_63_DBL_ 0x8000000000000000 +#define CLOSEST_FLOAT_NUMBER(h,l) (((h)*TWO_PWR_32_DBL_) + ((l)>>>0)) + +/** + * Returns a 64-bit represention of the given number. + * NaN will be returned as zero. + * Infinity is converted to max value and + * -Infinity to min value. + * @param {f} The number in question. + * @param {c} the continuation taking high and low bits + */ +function h$long_from_number(f,c) { + if (f > 0) { + if (f >= TWO_PWR_63_DBL_) { + // return max value + return c(0x7FFFFFFF,0xFFFFFFFF); + } + return c(f / TWO_PWR_32_DBL_, f); + } else if (f < 0) { + if (f <= -TWO_PWR_63_DBL_) { + // return min value + return c(0x80000000,0); + } + var h = -f / TWO_PWR_32_DBL_; + var l = -f; + // negate h l + var nl = (~l + 1) | 0; + var nh = (~h + !nl) | 0; + return c(nh,nl); + } else { + // NaN or 0. + return c(0,0); + } +} + +function h$base_lseek(fd, pos_h, pos_l, whence, c) { + TRACE_IO("base_lseek") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + var p = CLOSEST_FLOAT_NUMBER(pos_h,pos_l); + var o = h$base_fds[fd]; + if(!o) { + h$errno = CONST_BADF; + c(-1,-1); + } else { + switch(whence) { + case 0: /* SET */ + o.pos = p; + c(pos_h, pos_l); + break; + case 1: /* CUR */ + o.pos += p; + h$long_from_number(o.pos,c); + break; + case 2: /* END */ + h$fs.fstat(fd, function(err, fs) { + if(err) { + h$setErrno(err); + c(-1,-1); + } else { + o.pos = fs.size + p; + h$long_from_number(o.pos,c); + } + }); + break; + default: + h$errno = CONST_EINVAL; + c(-1,-1); + } + } + } else { +#endif + h$unsupported(); + c(-1, -1); +#ifndef GHCJS_BROWSER + } +#endif +} + +function h$base_lstat(file, file_off, stat, stat_off, c) { + TRACE_IO("base_lstat") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.lstat(h$decodeUtf8z(file, file_off), function(err, fs) { + if(err) { + h$handleErrnoC(err, -1, 0, c); + } else { + h$base_fillStat(fs, stat, stat_off); + c(0); + } + }); + } else +#endif + h$unsupported(-1, c); +} +function h$base_open(file, file_off, how, mode, c) { +#ifndef GHCJS_BROWSER + if(h$isNode()) { + var flags, off; + var fp = h$decodeUtf8z(file, file_off); + TRACE_IO("base_open: " + fp) + var acc = how & h$base_o_accmode; + // passing a number lets node.js use it directly as the flags (undocumented) + if(acc === h$base_o_rdonly) { + flags = h$processConstants['fs']['O_RDONLY']; + } else if(acc === h$base_o_wronly) { + flags = h$processConstants['fs']['O_WRONLY']; + } else { // r+w + flags = h$processConstants['fs']['O_RDWR']; + } + off = (how & h$base_o_append) ? -1 : 0; + flags = flags | ((how & h$base_o_trunc) ? h$processConstants['fs']['O_TRUNC'] : 0) + | ((how & h$base_o_creat) ? h$processConstants['fs']['O_CREAT'] : 0) + | ((how & h$base_o_excl) ? h$processConstants['fs']['O_EXCL'] : 0) + | ((how & h$base_o_append) ? h$processConstants['fs']['O_APPEND'] : 0); + h$fs.open(fp, flags, mode, function(err, fd) { + if(err) { + h$handleErrnoC(err, -1, 0, c); + } else { + var f = function(p) { + h$base_fds[fd] = { read: h$base_readFile + , write: h$base_writeFile + , close: h$base_closeFile + , fd: fd + , pos: p + , refs: 1 + }; + TRACE_IO("base_open: " + fp + " -> " + fd) + c(fd); + } + if(off === -1) { + h$fs.stat(fp, function(err, fs) { + if(err) h$handleErrnoC(err, -1, 0, c); else f(fs.size); + }); + } else { + f(0); + } + } + }); + } else +#endif + h$unsupported(-1, c); +} +function h$base_read(fd, buf, buf_off, n, c) { + TRACE_IO("base_read: " + fd) + var fdo = h$base_fds[fd]; + if(fdo && fdo.read) { + fdo.read(fd, fdo, buf, buf_off, n, c); + } else { + h$fs.read(fd, buf.u8, buf_off, n, null, function(err, bytesRead, buf0) { + h$handleErrnoC(err, -1, bytesRead, c); + }); + } +} +function h$base_stat(file, file_off, stat, stat_off, c) { + TRACE_IO("base_stat") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.stat(h$decodeUtf8z(file, file_off), function(err, fs) { + if(err) { + h$handleErrnoC(err, -1, 0, c); + } else { + h$base_fillStat(fs, stat, stat_off); + c(0); + } + }); + } else +#endif + h$unsupported(-1, c); +} +function h$base_umask(mode) { + TRACE_IO("base_umask: " + mode) +#ifndef GHCJS_BROWSER + if(h$isNode()) return process.umask(mode); +#endif + return 0; +} + +function h$base_write(fd, buf, buf_off, n, c) { +// fd: file descriptor number +// buf: buffer to write +// buf_off: offset in the buffer +// n: number of bytes to write +// c: continuation + TRACE_IO("base_write: " + fd) + + var fdo = h$base_fds[fd]; + + if(fdo && fdo.write) { + fdo.write(fd, fdo, buf, buf_off, n, c); + } else { + h$fs.write(fd, buf.u8, buf_off, n, function(err, bytesWritten, buf0) { + h$handleErrnoC(err, -1, bytesWritten, c); + }); + } +} + +function h$base_ftruncate(fd, pos_h, pos_l, c) { + TRACE_IO("base_ftruncate") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.ftruncate(fd, CLOSEST_FLOAT_NUMBER(pos_h,pos_l), function(err) { + h$handleErrnoC(err, -1, 0, c); + }); + } else +#endif + h$unsupported(-1, c); +} +function h$base_unlink(file, file_off, c) { + TRACE_IO("base_unlink") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.unlink(h$decodeUtf8z(file, file_off), function(err) { + h$handleErrnoC(err, -1, 0, c); + }); + } else +#endif + h$unsupported(-1, c); +} +function h$base_getpid() { + TRACE_IO("base_getpid") +#ifndef GHCJS_BROWSER + if(h$isNode()) return process.pid; +#endif + return 0; +} +function h$base_link(file1, file1_off, file2, file2_off, c) { + TRACE_IO("base_link") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.link(h$decodeUtf8z(file1, file1_off), h$decodeUtf8z(file2, file2_off), function(err) { + h$handleErrnoC(err, -1, 0, c); + }); + } else +#endif + h$unsupported(-1, c); +} +function h$base_mkfifo(file, file_off, mode, c) { + throw "h$base_mkfifo"; +} +function h$base_sigemptyset(sigset, sigset_off) { + return 0; + // throw "h$base_sigemptyset"; +} +function h$base_sigaddset(sigset, sigset_off, sig) { + return 0; + // throw "h$base_sigaddset"; +} +function h$base_sigprocmask(sig, sigset1, sigset1_off, sigset2, sigset2_off) { + return 0; + // throw "h$base_sigprocmask"; +} +function h$base_tcgetattr(attr, termios, termios_off) { + return 0; +} +function h$base_tcsetattr(attr, val, termios, termios_off) { + return 0; +} +function h$base_utime(file, file_off, timbuf, timbuf_off, c) { + TRACE_IO("base_utime") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + h$fs.fstat(h$decodeUtf8z(file, file_off), function(err, fs) { + if(err) { + h$handleErrnoC(err, 0, -1, c); // fixme + } else { + h$long_from_number(fs.atime.getTime(), (h,l) => { + timbuf.i3[0] = h; + timbuf.i3[1] = l; + }); + h$long_from_number(fs.mtime.getTime(), (h,l) => { + timbuf.i3[2] = h; + timbuf.i3[3] = l; + }); + h$long_from_number(fs.ctime.getTime(), (h,l) => { + timbuf.i3[4] = h; + timbuf.i3[5] = l; + }); + c(0); + } + }); + } else +#endif + h$unsupported(-1, c); +} +function h$base_waitpid(pid, stat, stat_off, options, c) { + throw "h$base_waitpid"; +} +/** @const */ var h$base_o_rdonly = 0x00000; +/** @const */ var h$base_o_wronly = 0x00001; +/** @const */ var h$base_o_rdwr = 0x00002; +/** @const */ var h$base_o_accmode = 0x00003; +/** @const */ var h$base_o_append = 0x00008; +/** @const */ var h$base_o_creat = 0x00200; +/** @const */ var h$base_o_trunc = 0x00400; +/** @const */ var h$base_o_excl = 0x00800; +/** @const */ var h$base_o_noctty = 0x20000; +/** @const */ var h$base_o_nonblock = 0x00004; +/** @const */ var h$base_o_binary = 0x00000; + +function h$base_c_s_isreg(mode) { + return 1; +} +function h$base_c_s_ischr(mode) { + return 0; +} +function h$base_c_s_isblk(mode) { + return 0; +} +function h$base_c_s_isdir(mode) { + return 0; // fixme +} +function h$base_c_s_isfifo(mode) { + return 0; +} + +#ifndef GHCJS_BROWSER +function h$base_fillStat(fs, b, off) { + if(off%4) throw "h$base_fillStat: not aligned"; + var o = off>>2; + b.i3[o+0] = fs.mode; + h$long_from_number(fs.size, (h,l) => { + b.i3[o+1] = h; + b.i3[o+2] = l; + }); + + b.i3[o+3] = 0; // fixme + b.i3[o+4] = 0; // fixme + b.i3[o+5] = fs.dev; + h$long_from_number(fs.ino, (h,l) => { + b.i3[o+6] = h; + b.i3[o+7] = l; + }); + b.i3[o+8] = fs.uid; + b.i3[o+9] = fs.gid; +} +#endif + +// [mode,size1,size2,mtime1,mtime2,dev,ino1,ino2,uid,gid] all 32 bit +/** @const */ var h$base_sizeof_stat = 40; + +function h$base_st_mtime(stat, stat_off) { + RETURN_UBX_TUP2(stat.i3[(stat_off>>2)+3], stat.i3[(stat_off>>2)+4]); +} + +function h$base_st_size(stat, stat_off) { + RETURN_UBX_TUP2(stat.i3[(stat_off>>2)+1], stat.i3[(stat_off>>2)+2]); +} + +function h$base_st_mode(stat, stat_off) { + return stat.i3[stat_off>>2]; +} + +function h$base_st_dev(stat, stat_off) { + return stat.i3[(stat_off>>2)+5]; +} + +function h$base_st_ino(stat, stat_off) { + RETURN_UBX_TUP2(stat.i3[(stat_off>>2)+6], stat.i3[(stat_off>>2)+7]); +} + +/** @const */ var h$base_echo = 1; +/** @const */ var h$base_tcsanow = 2; +/** @const */ var h$base_icanon = 4; +/** @const */ var h$base_vmin = 8; +/** @const */ var h$base_vtime = 16; +/** @const */ var h$base_sigttou = 0; +/** @const */ var h$base_sig_block = 0; +/** @const */ var h$base_sig_setmask = 0; +/** @const */ var h$base_f_getfl = 0; +/** @const */ var h$base_f_setfl = 0; +/** @const */ var h$base_f_setfd = 0; +/** @const */ var h$base_fd_cloexec = 0; +/** @const */ var h$base_sizeof_termios = 4; +/** @const */ var h$base_sizeof_sigset_t = 4; + +function h$base_lflag(termios, termios_off) { + return 0; +} + +function h$base_poke_lflag(termios, termios_off, flag) { + return 0; +} + +function h$base_ptr_c_cc(termios, termios_off) { + RETURN_UBX_TUP2(h$newByteArray(8), 0); +} + +/** @const */ var h$base_default_buffer_size = 32768; + +function h$base_c_s_issock(mode) { + return 0; // fixme +} + +/** @const */ var h$base_SEEK_SET = 0; +/** @const */ var h$base_SEEK_CUR = 1; +/** @const */ var h$base_SEEK_END = 2; + +function h$base_set_saved_termios(a, b, c) { + RETURN_UBX_TUP2(null, 0); +} + +function h$base_get_saved_termios(r) { + RETURN_UBX_TUP2(null, 0); +} + +// fixme +function h$lockFile(fd, dev, ino, for_writing) { + TRACE_IO("lockFile:" + fd) + return 0; +} +function h$unlockFile(fd) { + TRACE_IO("unlockFile:" + fd) + return 0; +} + + + +// engine-dependent setup +var h$base_readStdin , h$base_writeStderr, h$base_writeStdout; +var h$base_isattyStdin = false, h$base_isattyStdout = false, h$base_isattyStderr = false; +var h$base_closeStdin = null, h$base_closeStderr = null, h$base_closeStdout = null; +var h$base_readFile, h$base_writeFile, h$base_closeFile; +#ifndef GHCJS_BROWSER +var h$base_stdin_waiting = new h$Queue(); +var h$base_stdin_chunk = { buf: null + , pos: 0 + , processing: false + }; +var h$base_stdin_eof = false; +var h$base_process_stdin = function() { + var c = h$base_stdin_chunk; + var q = h$base_stdin_waiting; + if(!q.length() || c.processing) return; + c.processing = true; + if(!c.buf) { c.pos = 0; c.buf = process.stdin.read(); } + while(c.buf && q.length()) { + var x = q.dequeue(); + var n = Math.min(c.buf.length - c.pos, x.n); + for(var i=0;i<n;i++) { + x.buf.u8[i+x.off] = c.buf[c.pos+i]; + } + c.pos += n; + x.c(n); + if(c.pos >= c.buf.length) c.buf = null; + if(!c.buf && q.length()) { c.pos = 0; c.buf = process.stdin.read(); } + } + while(h$base_stdin_eof && q.length()) q.dequeue().c(0); + c.processing = false; +} + +if(h$isNode()) { + h$base_closeFile = function(fd, fdo, c) { + TRACE_IO("base_closeFile: " + fd + " (" + fdo.fd + ")") + var real_fd = typeof fdo.fd === 'number' ? fdo.fd : fd; + h$fs.close(real_fd, function(err) { + delete h$base_fds[fd]; + h$handleErrnoC(err, -1, 0, c); + }); + } + + h$base_readFile = function(fd, fdo, buf, buf_offset, n, c) { + var pos = typeof fdo.pos === 'number' ? fdo.pos : null; + TRACE_IO("base_readFile: " + fd + " (" + fdo.fd + ") " + pos + " " + buf_offset + " " + n) + var real_fd = typeof fdo.fd === 'number' ? fdo.fd : fd; + h$fs.read(real_fd, Buffer.alloc(n), 0, n, pos, function(err, bytesRead, nbuf) { + if(err) { + h$setErrno(err); + c(-1); + } else { + for(var i=bytesRead-1;i>=0;i--) buf.u8[buf_offset+i] = nbuf[i]; + if(typeof fdo.pos === 'number') fdo.pos += bytesRead; + c(bytesRead); + } + }); + } + + h$base_readStdin = function(fd, fdo, buf, buf_offset, n, c) { + TRACE_IO("read stdin") + h$base_stdin_waiting.enqueue({buf: buf, off: buf_offset, n: n, c: c}); + h$base_process_stdin(); + } + + h$base_closeStdin = function(fd, fdo, c) { + TRACE_IO("close stdin") + // process.stdin.close(); fixme + c(0); + } + + h$base_writeFile = function(fd, fdo, buf, buf_offset, n, c) { + var pos = typeof fdo.pos === 'number' ? fdo.pos : null; + TRACE_IO("base_writeFile: " + fd + " (" + fdo.fd + ") " + pos + " " + buf_offset + " " + n) + var nbuf = Buffer.alloc(n); + for(var i=0;i<n;i++) nbuf[i] = buf.u8[i+buf_offset]; + var real_fd = typeof fdo.fd === 'number' ? fdo.fd : fd; + if(typeof fdo.pos === 'number') fdo.pos += n; + h$fs.write(real_fd, nbuf, 0, n, pos, function(err, bytesWritten) { + TRACE_IO("written file: " + fd + " (" + fdo.fd + ")") + if(err) { + h$setErrno(err); + if(typeof fdo.pos === 'number') fdo.pos -= n; + if(h$errno === CONST_EAGAIN) + setTimeout(function() { h$base_writeFile(fd, fdo, buf, buf_offset, n, c); }, 20); + else c(-1); + } else { + if(typeof fdo.pos === 'number') fdo.pos += bytesWritten - n; + c(bytesWritten); + } + }); + } + + h$base_writeStdout = function(fd, fdo, buf, buf_offset, n, c) { + TRACE_IO("write stdout") + h$base_writeFile(1, fdo, buf, buf_offset, n, c); + } + + h$base_closeStdout = function(fd, fdo, c) { + TRACE_IO("close stdout") + // not actually closed, fixme? + c(0); + } + + h$base_writeStderr = function(fd, fdo, buf, buf_offset, n, c) { + TRACE_IO("write stderr") + h$base_writeFile(2, fdo, buf, buf_offset, n, c); + } + + h$base_closeStderr = function(fd, fdo, c) { + TRACE_IO("close stderr") + // not actually closed, fixme? + c(0); + } + + process.stdin.on('readable', h$base_process_stdin); + process.stdin.on('end', function() { h$base_stdin_eof = true; h$base_process_stdin(); }); + + h$base_isattyStdin = function() { return process.stdin.isTTY; }; + h$base_isattyStdout = function() { return process.stdout.isTTY; }; + h$base_isattyStderr = function() { return process.stderr.isTTY; }; + +} else if (h$isJsShell()) { + h$base_readStdin = function(fd, fdo, buf, buf_offset, n, c) { + c(0); + } + h$base_writeStdout = function(fd, fdo, buf, buf_offset, n, c) { + putstr(h$decodeUtf8(buf, n, buf_offset)); + c(n); + } + h$base_writeStderr = function(fd, fdo, buf, buf_offset, n, c) { + printErr(h$decodeUtf8(buf, n, buf_offset)); + c(n); + } +} else if(h$isJsCore()) { + h$base_readStdin = function(fd, fdo, buf, buf_offset, n, c) { + c(0); + } + var h$base_stdoutLeftover = { f: print, val: null }; + var h$base_stderrLeftover = { f: debug, val: null }; + var h$base_writeWithLeftover = function(buf, n, buf_offset, c, lo) { + var lines = h$decodeUtf8(buf, n, buf_offset).split(/\r?\n/); + if(lines.length === 1) { + if(lines[0].length) { + if(lo.val !== null) lo.val += lines[0]; + else lo.val = lines[0]; + } + } else { + lo.f(((lo.val !== null) ? lo.val : '') + lines[0]); + for(var i=1;i<lines.length-1;i++) lo.f(lines[i]); + if(lines[lines.length-1].length) lo.val = lines[lines.length-1]; + else lo.val = null; + } + c(n); + } + h$base_writeStdout = function(fd, fdo, buf, buf_offset, n, c) { + h$base_writeWithLeftover(buf, n, buf_offset, c, h$base_stdoutLeftover); + } + h$base_writeStderr = function(fd, fdo, buf, buf_offset, n, c) { + // writing to stderr not supported, write to stdout + h$base_writeWithLeftover(buf, n, buf_offset, c, h$base_stderrLeftover); + } +} else { // browser / fallback +#endif + h$base_readStdin = function(fd, fdo, buf, buf_offset, n, c) { + c(0); + } + h$base_writeStdout = function(fd, fdo, buf, buf_offset, n, c) { + console.log(h$decodeUtf8(buf, n, buf_offset)); + c(n); + } + h$base_writeStderr = function(fd, fdo, buf, buf_offset, n, c) { + console.log(h$decodeUtf8(buf, n, buf_offset)); + c(n); + } +#ifndef GHCJS_BROWSER +} +#endif + +var h$base_stdin_fd = + { read: h$base_readStdin + , close: h$base_closeStdin + , isatty: h$base_isattyStdin + , refs: 1 + }; +var h$base_stdout_fd = + { write: h$base_writeStdout + , close: h$base_closeStdout + , isatty: h$base_isattyStdout + , refs: 1 + }; +var h$base_stderr_fd = + { write: h$base_writeStderr + , close: h$base_closeStderr + , isatty: h$base_isattyStderr + , refs: 1 + }; + +var h$base_fdN = -2; // negative file descriptors are 'virtual', -1 is already used to indicated error +var h$base_fds = [h$base_stdin_fd, h$base_stdout_fd, h$base_stderr_fd]; + +function h$shutdownHaskellAndExit(code, fast) { +#ifndef GHCJS_BROWSER +#ifdef GHCJS_LOG_BUFFER + if(h$isNode()) console.log(h$logBuffer); + if(h$isJsShell() || h$isJsCore()) print(h$logBuffer); +#endif +#endif + h$exitProcess(code); +} + +// RAND_MAX = 32767 +function h$rand() { + return (32768 * Math.random()) & 32767; +} + +// SIGUSR1, SIGTERM, SIGINT, SIGPIPE, SIGHUP, SIGTERM, SIGINT +// SIGBREAK, SIGWINCH, SIGKILL, SIGSTOP, SIGBUS, SIGFPE +// SIGSEGV, SIGILL + +// returns old action code +function h$stg_sig_install(sigNo, actionCode, sigSet_d, sigSet_o) { + // XXX dummy implementation + return 0; +} + +const h$putchar_buf = h$newByteArray(1); + +function h$putchar(c) { + h$putchar_buf.u8[0] = c; + h$base_write(1, h$putchar_buf, 0, 1, null); + return h$errno; +} + +function h$__hscore_set_errno(n) { + h$errno = n; +} + +/******************************************* + * Directory API + *******************************************/ + +function h$opendir(path) { + if(!h$isNode()) { + throw "h$opendir unsupported"; + } + + const d = fs.opendirSync(h$decodeUtf8z(path,0)); + RETURN_UBX_TUP2(d,0); +} + +function h$closedir(d,o) { + if(!h$isNode()) { + throw "h$closedir unsupported"; + } + d.closeSync(); + return 0; +} + +function h$readdir(d,o) { + if(!h$isNode()) { + throw "h$readdir unsupported"; + } + const c = d.readSync(); + RETURN_UBX_TUP2(c,0); +} + +function h$__hscore_readdir(d,o,dst_a,dst_o) { + if(!h$isNode()) { + throw "h$readdir unsupported"; + } + const e = d.readSync(); + + if (!dst_a.arr) dst_a.arr = []; + dst_a.arr[dst_o*2] = [e,0]; + return 0; +} + +function h$__hscore_free_dirent(a,o) { +} + +function h$__hscore_d_name(a,o) { + RETURN_UBX_TUP2(h$encodeModifiedUtf8(a.name),0); +} diff --git a/libraries/base/jsbits/errno.js b/libraries/base/jsbits/errno.js new file mode 100644 index 0000000000..185f799186 --- /dev/null +++ b/libraries/base/jsbits/errno.js @@ -0,0 +1,102 @@ +//#OPTIONS: CPP + +#include "HsBaseConfig.h" + +#ifdef GHCJS_TRACE_ERRNO +function h$logErrno() { h$log.apply(h$log,arguments); } +#define TRACE_ERRNO(args...) h$logErrno(args) +#else +#define TRACE_ERRNO(args...) +#endif + +var h$errno = 0; + +function h$__hscore_get_errno() { + TRACE_ERRNO("hscore_get_errno: " + h$errno); + return h$errno; +} + +function h$unsupported(status, c) { + h$errno = 12456; + if(c) c(status); + return status; +} + +function h$strerror(err) { + if(err === 12456) { + RETURN_UBX_TUP2(h$encodeUtf8("operation unsupported on this platform"), 0); + } +#ifdef GHCJS_BROWSER + RETURN_UBX_TUP2(h$encodeUtf8("unknown error"), 0); +#else + RETURN_UBX_TUP2(h$encodeUtf8(h$errorStrs[err] || "unknown error"), 0); +#endif +} + +#ifndef GHCJS_BROWSER +function h$setErrno(e) { + TRACE_ERRNO("setErrno: " + e); + var es = e.toString(); + var getErr = function() { + if(es.indexOf('ENOTDIR') !== -1) return CONST_ENOTDIR; + if(es.indexOf('EISDIR') !== -1) return CONST_EISDIR; + if(es.indexOf('ENOENT') !== -1) return CONST_ENOENT; + if(es.indexOf('EEXIST') !== -1) return CONST_EEXIST; + if(es.indexOf('ENETUNREACH') !== -1) return CONST_EINVAL; // fixme + if(es.indexOf('EPERM') !== -1) return CONST_EPERM; + if(es.indexOf('EMFILE') !== -1) return CONST_EMFILE; + if(es.indexOf('EPIPE') !== -1) return CONST_EPIPE; + if(es.indexOf('EAGAIN') !== -1) return CONST_EAGAIN; + if(es.indexOf('EINVAL') !== -1) return CONST_EINVAL; + if(es.indexOf('ESPIPE') !== -1) return CONST_ESPIPE; + if(es.indexOf('EBADF') !== -1) return CONST_EBADF; + if(es.indexOf('Bad argument') !== -1) return CONST_ENOENT; // fixme? + throw ("setErrno not yet implemented: " + e); + + } + h$errno = getErr(); +} + +var h$errorStrs = { CONST_E2BIG: "Argument list too long" + , CONST_EACCESS: "Permission denied" + , CONST_EINVAL: "Invalid argument" + , CONST_EBADF: "Bad file descriptor" + , CONST_ENOTDIR: "Not a directory" + , CONST_EISDIR: "Illegal operation on a directory" + , CONST_ENOENT: "No such file or directory" + , CONST_EPERM: "Operation not permitted" + , CONST_EEXIST: "File exists" + , CONST_EMFILE: "Too many open files" + , CONST_EPIPE: "Broken pipe" + , CONST_EAGAIN: "Resource temporarily unavailable" + , CONST_ESPIPE: "Illegal seek" + } + +function h$handleErrno(r_err, f) { + try { + return f(); + } catch(e) { + h$setErrno(e); + return r_err; + } +} + +function h$handleErrnoS(r_err, r_success, f) { + try { + f(); + return r_success; + } catch(e) { + h$setErrno(e); + return r_err; + } +} + +function h$handleErrnoC(err, r_err, r_success, c) { + if(err) { + h$setErrno(err); + c(r_err); + } else { + c(r_success); + } +} +#endif diff --git a/libraries/base/jsbits/platform.js b/libraries/base/jsbits/platform.js new file mode 100644 index 0000000000..2ecdee2189 --- /dev/null +++ b/libraries/base/jsbits/platform.js @@ -0,0 +1,111 @@ +//#OPTIONS: CPP + +/* platform-specific setup */ + +/* + if browser mode is active (GHCJS_BROWSER is defined), all the runtime platform + detection code should be removed by the preprocessor. The h$isPlatform variables + are undeclared. + + in non-browser mode, use h$isNode, h$isJsShell, h$isBrowser to find the current + platform. + + more platforms should be added here in the future +*/ +#ifndef GHCJS_BROWSER +var h$isNode_ = false; // runtime is node.js +var h$isJvm_ = false; // runtime is JVM +var h$isJsShell_ = false; // runtime is SpiderMonkey jsshell +var h$isJsCore_ = false; // runtime is JavaScriptCore jsc +var h$isBrowser_ = false; // running in browser or everything else + +var h$isGHCJSi_ = false; // Code is GHCJSi (browser or node) + +function h$isNode() { + return h$isNode_; +} + +function h$isJvm() { + return h$isJvm_; +} + +function h$isJsShell() { + return h$isJsShell_; +} + +function h$isJsCore() { + return h$isJsCore_; +} + +function h$isBrowser() { + return h$isBrowser_; +} + +function h$isGHCJSi() { + return h$isGHCJSi_; +} + +// load all required node.js modules +if(typeof process !== 'undefined' && (typeof h$TH !== 'undefined' || (typeof require !== 'undefined' && typeof module !== 'undefined' && module.exports))) { + h$isNode_ = true; + // we have to use these names for the closure compiler externs to work + var fs = require('fs'); + var path = require('path'); + var os = require('os'); + var child_process = require('child_process'); + var h$fs = fs; + var h$path = path; + var h$os = os; + var h$child = child_process; + var h$process = process; + function h$getProcessConstants() { + // this is a non-public API, but we need these values for things like file access modes + var cs = process['binding']('constants'); + if(typeof cs.os === 'object' && typeof cs.fs === 'object') { + return cs; + } else { + // earlier node.js versions (4.x and older) have all constants directly in the constants object + // construct something that resembles the hierarchy of the object in new versions: + return { 'fs': cs + , 'crypto': cs + , 'os': { 'UV_UDP_REUSEADDR': cs['UV_UDP_REUSEADDR'] + , 'errno': cs + , 'signals': cs + } + }; + } + } + var h$processConstants = h$getProcessConstants(); +} else if(typeof Java !== 'undefined') { + h$isJvm_ = true; + this.console = { + log: function(s) { + java.lang.System.out.print(s); + } + }; +} else if(typeof snarf !== 'undefined' && typeof print !== 'undefined' && typeof quit !== 'undefined') { + h$isJsShell_ = true; + this.console = { log: this.print }; +} else if(typeof numberOfDFGCompiles !== 'undefined' && typeof jscStack !== 'undefined') { + h$isJsCore_ = true; +} else { + h$isBrowser_ = true; +} +if(typeof global !== 'undefined' && global.h$GHCJSi) { + h$isGHCJSi_ = true; +} +#endif + +function h$getGlobal(that) { + if(typeof global !== 'undefined') return global; + return that; +} + +#ifdef GHCJS_BROWSER +// IE 8 doesn't support Date.now(), shim it +if (!Date.now) { + Date.now = function now() { + return +(new Date); + }; +} +#endif diff --git a/libraries/base/tests/Concurrent/all.T b/libraries/base/tests/Concurrent/all.T index f8826a08d3..05fdf1d303 100644 --- a/libraries/base/tests/Concurrent/all.T +++ b/libraries/base/tests/Concurrent/all.T @@ -1,3 +1,3 @@ test('Chan002', extra_run_opts('100'), compile_and_run, ['']) test('Chan003', extra_run_opts('200'), compile_and_run, ['']) -test('ThreadDelay001', normal, compile_and_run, ['']) +test('ThreadDelay001', js_broken(22374), compile_and_run, ['']) diff --git a/libraries/base/tests/IO/T21336/all.T b/libraries/base/tests/IO/T21336/all.T index 39ccb04d6a..e1fbd3b22d 100644 --- a/libraries/base/tests/IO/T21336/all.T +++ b/libraries/base/tests/IO/T21336/all.T @@ -1,11 +1,13 @@ # N.B. /dev/full exists on Darwin but cannot be opened, failing with -EPERM test('T21336a', - [unless(opsys('linux') or opsys('freebsd'), skip)], + [unless(opsys('linux') or opsys('freebsd'), skip), js_broken(22261)], compile_and_run, ['']) test('T21336b', - [unless(opsys('linux') or opsys('freebsd'), skip)], + [unless(opsys('linux') or opsys('freebsd'), skip), js_broken(22352)], makefile_test, []) test('T21336c', - [unless(opsys('linux') or opsys('freebsd'), skip)], + [ unless(opsys('linux') or opsys('freebsd'), skip) + , js_broken(22370) + ], makefile_test, []) diff --git a/libraries/base/tests/IO/all.T b/libraries/base/tests/IO/all.T index 7cb99c0f7f..92cb93add5 100644 --- a/libraries/base/tests/IO/all.T +++ b/libraries/base/tests/IO/all.T @@ -10,9 +10,9 @@ test('IOError001', [omit_ways(['ghci']), set_stdin('IOError001.hs')], test('IOError002', normal, compile_and_run, ['']) test('finalization001', normal, compile_and_run, ['']) test('hClose001', [], compile_and_run, ['']) -test('hClose002', [normalise_win32_io_errors], compile_and_run, ['']) +test('hClose002', [normalise_win32_io_errors, js_broken(22261)], compile_and_run, ['']) test('hFileSize001', normal, compile_and_run, ['']) -test('hFileSize002', [omit_ways(['ghci'])], compile_and_run, ['']) +test('hFileSize002', [omit_ways(['ghci']), js_broken(22261)], compile_and_run, ['']) test('hFlush001', [], compile_and_run, ['']) test('hGetBuffering001', @@ -28,14 +28,14 @@ test('hGetPosn001', [], compile_and_run, ['-cpp']) test('hIsEOF001', normal, compile_and_run, ['']) test('hIsEOF002', [], compile_and_run, ['-cpp']) -test('hReady001', normal, compile_and_run, ['-cpp']) +test('hReady001', js_broken(22374), compile_and_run, ['-cpp']) # hReady002 tests that hReady returns False for a pipe that has no # data to read. It relies on piping input from 'sleep 1', which doesn't # work for the 'ghci' way because in that case we already pipe input from # a script, so hence omit_ways(['ghci']) test('hReady002', [cmd_prefix('sleep 1 |'), omit_ways(['ghci']), - multi_cpu_race], + multi_cpu_race, js_broken(22374)], compile_and_run, ['']) test('hSeek001', normal, compile_and_run, ['']) @@ -46,7 +46,10 @@ test('hSeek004', [], compile_and_run, ['-cpp']) test('hSetBuffering002', set_stdin('hSetBuffering002.hs'), compile_and_run, ['']) test('hSetBuffering003', - [omit_ways(['ghci']), set_stdin('hSetBuffering003.hs')], + [ omit_ways(['ghci']) + , set_stdin('hSetBuffering003.hs') + , js_broken(22261) + ], compile_and_run, ['']) test('hSetBuffering004', set_stdin('hSetBuffering004.hs'), compile_and_run, ['']) @@ -61,34 +64,35 @@ test('misc001', [extra_run_opts('misc001.hs misc001.out')], compile_and_run, test('openFile001', normal, compile_and_run, ['']) test('openFile002', [exit_code(1), normalise_win32_io_errors], compile_and_run, ['']) -test('openFile003', [normalise_win32_io_errors], compile_and_run, ['']) +test('openFile003', [normalise_win32_io_errors, js_broken(22374)], compile_and_run, ['']) test('openFile004', [], compile_and_run, ['']) -test('openFile005', [], compile_and_run, ['']) +test('openFile005', js_broken(22261), compile_and_run, ['']) test('openFile006', [], compile_and_run, ['']) -test('openFile007', [], compile_and_run, ['']) -test('openFile008', cmd_prefix('ulimit -n 1024; '), compile_and_run, ['']) +test('openFile007', js_broken(22261), compile_and_run, ['']) +test('openFile008', [js_broken(22349), cmd_prefix('ulimit -n 1024; ')], compile_and_run, ['']) test('openFile009', [], compile_and_run, ['']) test('putStr001', normal, compile_and_run, ['']) -test('readFile001', [], compile_and_run, ['']) +test('readFile001', js_broken(22261), compile_and_run, ['']) test('readwrite001', [], compile_and_run, ['-cpp']) -test('readwrite002', [omit_ways(['ghci']), set_stdin('readwrite002.hs')], +test('readwrite002', [omit_ways(['ghci']), set_stdin('readwrite002.hs'), js_broken(22374)], compile_and_run, ['-cpp']) test('readwrite003', [], compile_and_run, ['']) test('hGetBuf001', - [ - when(fast(), skip), - expect_fail_if_windows], + [ when(fast(), skip) + , expect_fail_if_windows + , js_broken(22374) + ], compile_and_run, ['-package unix']) test('hDuplicateTo001', [fragile_for(16819, concurrent_ways), when(opsys('mingw32'), skip)], compile_and_run, ['']) -test('countReaders001', [], compile_and_run, ['']) +test('countReaders001', js_broken(22261), compile_and_run, ['']) test('concio001', [normal, multi_cpu_race], makefile_test, ['test.concio001']) @@ -115,7 +119,7 @@ test('encoding001', [], compile_and_run, ['']) test('encoding002', normal, compile_and_run, ['']) test('encoding003', normal, compile_and_run, ['']) -test('encoding004', extra_files(['encoded-data/']), compile_and_run, ['']) +test('encoding004', [extra_files(['encoded-data/']), js_broken(22374)], compile_and_run, ['']) test('encoding005', normal, compile_and_run, ['']) test('environment001', [], makefile_test, ['environment001-test']) diff --git a/libraries/base/tests/System/all.T b/libraries/base/tests/System/all.T index 50ebb596e6..ad3b046b25 100644 --- a/libraries/base/tests/System/all.T +++ b/libraries/base/tests/System/all.T @@ -4,7 +4,7 @@ test('getArgs001', normal, compile_and_run, ['']) test('getEnv001', normal, compile_and_run, ['']) test('T5930', normal, compile_and_run, ['']) -test('system001', when(opsys("mingw32"), skip), \ +test('system001', [js_broken(22349), when(opsys("mingw32"), skip)], \ compile_and_run, ['']) -test('Timeout001', normal, compile_and_run, ['']) +test('Timeout001', js_broken(22261), compile_and_run, ['']) test('T16466', normal, compile_and_run, ['']) diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index e50d28da12..c96a3d1f43 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -156,7 +156,7 @@ test('T2528', normal, compile_and_run, ['']) # May 2014: seems to work on msys2 # May 2018: The behavior of printf seems very implementation dependent. # so let's normalise the output. -test('T4006', normalise_fun(normalise_quotes), compile_and_run, ['']) +test('T4006', [js_broken(22349), normalise_fun(normalise_quotes)], compile_and_run, ['']) test('T5943', normal, compile_and_run, ['']) test('T5962', normal, compile_and_run, ['']) @@ -167,7 +167,7 @@ test('qsemn001', normal, compile_and_run, ['']) test('T7457', normal, compile_and_run, ['']) -test('T7773', when(opsys('mingw32'), skip), compile_and_run, ['']) +test('T7773', [when(opsys('mingw32'), skip), js_broken(22261)], compile_and_run, ['']) # Andreas says that T7773 will not (and should not) work on Windows # Tests for kind-polymorphic Category @@ -179,15 +179,17 @@ test('T7653', [when(opsys('mingw32'), skip), omit_ways(prof_ways+['ghci'])], compile_and_run, ['']) test('T7787', normal, compile_and_run, ['']) -test('topHandler01', when(opsys('mingw32'), skip), compile_and_run, ['']) +test('topHandler01', [when(opsys('mingw32'), skip), js_broken(22261)], compile_and_run, ['']) test('topHandler02', [when(opsys('mingw32'), skip), omit_ways(['ghci']), - signal_exit_code(2) + signal_exit_code(2), + js_broken(22261) ], compile_and_run, ['']) test('topHandler03', [when(opsys('mingw32'), skip), ignore_stderr, - signal_exit_code(15) + signal_exit_code(15), + js_broken(22261) ], compile_and_run, ['']) test('topHandler04', [when(opsys('mingw32'), skip), @@ -197,7 +199,9 @@ test('topHandler04', test('T8766', [ collect_stats('bytes allocated',5) - , only_ways(['normal'])], + , only_ways(['normal']) + , js_broken(22261) + ], compile_and_run, ['-O']) @@ -221,31 +225,36 @@ test('T8089', [exit_code(99), run_timeout_multiplier(0.01)], compile_and_run, ['']) test('T8684', expect_broken(8684), compile_and_run, ['']) -test('hWaitForInput-accurate-stdin', [expect_broken_for(16535, threaded_ways), omit_ways(['ghci'])], compile_and_run, ['']) +test('hWaitForInput-accurate-stdin', [js_broken(22349), expect_broken_for(16535, threaded_ways), omit_ways(['ghci'])], compile_and_run, ['']) test('T9826',normal, compile_and_run,['']) test('T9848', [ collect_stats('bytes allocated') - , only_ways(['normal'])], + , only_ways(['normal']) + , js_broken(22261) + ], compile_and_run, ['-O']) test('T10149', normal, compile_and_run, ['']) test('T11334a', normal, compile_and_run, ['']) test('T11555', normal, compile_and_run, ['']) test('T12494', normal, compile_and_run, ['']) -test('T12852', when(opsys('mingw32'), skip), compile_and_run, ['']) +test('T12852', [when(opsys('mingw32'), skip), js_broken(22374)], compile_and_run, ['']) test('lazySTexamples', normal, compile_and_run, ['']) test('T11760', req_smp, compile_and_run, ['-threaded -with-rtsopts=-N2']) test('T12874', normal, compile_and_run, ['']) test('T13191', [ collect_stats('bytes allocated', 5) - , only_ways(['normal'])], + , only_ways(['normal']) + , js_broken(22261) + ], compile_and_run, ['-O']) -test('T13525', when(opsys('mingw32'), skip), compile_and_run, ['']) +test('T13525', [when(opsys('mingw32'), skip), js_broken(22374)], compile_and_run, ['']) test('T13097', normal, compile_and_run, ['']) test('functorOperators', normal, compile_and_run, ['']) test('T3474', [collect_stats('max_bytes_used',5), + js_broken(22374), only_ways(['normal'])], compile_and_run, ['-O']) test('T14425', normal, compile_and_run, ['']) @@ -254,25 +263,29 @@ test('T13896', normal, compile_and_run, ['']) # On Windows this test is fragile using the old MIO IO manager due to an # apparent flushing bug. test('T13167', - [when(opsys('mingw32'), only_ways(['winio', 'winio_threaded'])), - fragile_for(16536, concurrent_ways)], + [ when(opsys('mingw32') + , only_ways(['winio', 'winio_threaded'])) + , fragile_for(16536, concurrent_ways) + , js_broken(22261) + ], compile_and_run, ['']) test('T15183', normal, compile_and_run, ['']) test('T15349', [exit_code(1), expect_broken_for(15349, ['ghci'])], compile_and_run, ['']) test('T16111', exit_code(1), compile_and_run, ['']) test('T16943a', normal, compile_and_run, ['']) test('T16943b', normal, compile_and_run, ['']) -test('T17499', [collect_stats('bytes allocated',5)], compile_and_run, ['-O -w']) +test('T17499', [collect_stats('bytes allocated',5), js_broken(22261)], compile_and_run, ['-O -w']) test('T16643', normal, compile_and_run, ['']) test('clamp', normal, compile_and_run, ['']) test('T18642', [extra_run_opts('+RTS -T -RTS'), # The nonmoving GC's residency behavior is very conservative - omit_ways(['nonmoving', 'nonmoving_thr', 'nonmoving_thr_sanity'])], + omit_ways(['nonmoving', 'nonmoving_thr', 'nonmoving_thr_sanity']), + js_broken(22374)], compile_and_run, ['-O2']) test('T19288', exit_code(1), compile_and_run, ['']) test('T19719', normal, compile_and_run, ['']) test('T20107', extra_run_opts('+RTS -M50M'), compile_and_run, ['-package bytestring']) test('trace', normal, compile_and_run, ['']) -test('listThreads', normal, compile_and_run, ['']) +test('listThreads', js_broken(22261), compile_and_run, ['']) test('inits1tails1', normal, compile_and_run, ['']) diff --git a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs index c40f6f91df..19b223f56d 100644 --- a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs +++ b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs @@ -13,5 +13,6 @@ data ForeignSrcLang | LangObjc -- ^ Objective C | LangObjcxx -- ^ Objective C++ | LangAsm -- ^ Assembly language (.s) + | LangJs -- ^ JavaScript | RawObject -- ^ Object (.o) deriving (Eq, Show, Generic) diff --git a/libraries/ghc-boot/GHC/Data/ShortText.hs b/libraries/ghc-boot/GHC/Data/ShortText.hs index 9ea261435f..aa5a50ce7f 100644 --- a/libraries/ghc-boot/GHC/Data/ShortText.hs +++ b/libraries/ghc-boot/GHC/Data/ShortText.hs @@ -29,6 +29,7 @@ module GHC.Data.ShortText ( -- * ShortText ShortText(..), -- ** Conversion to and from String + singleton, pack, unpack, -- ** Operations @@ -77,6 +78,10 @@ byteLength st = SBS.length $ contents st pack :: String -> ShortText pack s = ShortText $ utf8EncodeShortByteString s +-- | Create a singleton +singleton :: Char -> ShortText +singleton s = pack [s] + -- | /O(n)/ Convert a 'ShortText' into a 'String'. unpack :: ShortText -> String unpack st = utf8DecodeShortByteString $ contents st diff --git a/libraries/ghc-compact/tests/all.T b/libraries/ghc-compact/tests/all.T index 92864e37bb..a9e72b548f 100644 --- a/libraries/ghc-compact/tests/all.T +++ b/libraries/ghc-compact/tests/all.T @@ -1,4 +1,7 @@ -setTestOpts(extra_ways(['sanity', 'compacting_gc'])) +setTestOpts( + [extra_ways(['sanity', 'compacting_gc']), + js_skip # compact API not supported by the JS backend + ]) test('compact_simple', normal, compile_and_run, ['']) test('compact_loop', normal, compile_and_run, ['']) diff --git a/libraries/ghc-heap/ghc-heap.cabal.in b/libraries/ghc-heap/ghc-heap.cabal.in index d1db0e250c..1842995885 100644 --- a/libraries/ghc-heap/ghc-heap.cabal.in +++ b/libraries/ghc-heap/ghc-heap.cabal.in @@ -28,7 +28,8 @@ library , containers >= 0.6.2.1 && < 0.7 ghc-options: -Wall - cmm-sources: cbits/HeapPrim.cmm + if !os(ghcjs) + cmm-sources: cbits/HeapPrim.cmm default-extensions: NoImplicitPrelude diff --git a/libraries/ghc-heap/tests/all.T b/libraries/ghc-heap/tests/all.T index 504eb58857..bce11d6278 100644 --- a/libraries/ghc-heap/tests/all.T +++ b/libraries/ghc-heap/tests/all.T @@ -1,3 +1,5 @@ +setTestOpts(js_skip) # ghc-heap not supported by the JS backend + test('heap_all', [when(have_profiling(), extra_ways(['prof'])), # These ways produce slightly different heap representations. diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index 24b412e970..dbe1e32545 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -81,19 +81,20 @@ Library -- is just an empty shell. extra-libraries: c, m - c-sources: - cbits/atomic.c - cbits/bswap.c - cbits/bitrev.c - cbits/clz.c - cbits/ctz.c - cbits/debug.c - cbits/longlong.c - cbits/mulIntMayOflo.c - cbits/pdep.c - cbits/pext.c - cbits/popcnt.c - cbits/word2float.c + if !os(ghcjs) + c-sources: + cbits/atomic.c + cbits/bswap.c + cbits/bitrev.c + cbits/clz.c + cbits/ctz.c + cbits/debug.c + cbits/longlong.c + cbits/mulIntMayOflo.c + cbits/pdep.c + cbits/pext.c + cbits/popcnt.c + cbits/word2float.c -- We need to set the unit ID to ghc-prim (without a version number) -- as it's magic. diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs index 7d969efc8d..72364b6a7e 100644 --- a/libraries/ghci/GHCi/CreateBCO.hs +++ b/libraries/ghci/GHCi/CreateBCO.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} -- -- (c) The University of Glasgow 2002-2006 @@ -132,7 +133,12 @@ writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s -> -- without making a thunk turns out to be surprisingly tricky. {-# NOINLINE writeArrayAddr# #-} writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s +#if defined(js_HOST_ARCH) +-- Addr# isn't coercible with Any with the JS backend. +writeArrayAddr# = error "writeArrayAddr#: currently unsupported with the JS backend" +#else writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s +#endif writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO () writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s -> diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc index 74c9e175b1..ab6c4bb17f 100644 --- a/libraries/ghci/GHCi/FFI.hsc +++ b/libraries/ghci/GHCi/FFI.hsc @@ -6,7 +6,24 @@ -- ----------------------------------------------------------------------------- +{- Note [FFI for the JS-Backend] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + The JS-backend does not use GHC's native rts, as such you might think that it + doesn't require ghci. However, that is not true, because we need ghci in + order to interoperate with iserv even if we do not use any of the FFI stuff + in this file. So obviously we do not require libffi, but we still need to be + able to build ghci in order for the JS-Backend to supply its own iserv + interop solution. Thus we bite the bullet and wrap all the unneeded bits in a + CPP conditional compilation blocks that detect the JS-backend. A necessary + evil to be sure; notice that the only symbols remaining the JS_HOST_ARCH case + are those that are explicitly exported by this module and set to error if + they are every used. +-} + +#if !defined(js_HOST_ARCH) #include <ffi.h> +#endif {-# LANGUAGE CPP, DeriveGeneric, DeriveAnyClass #-} module GHCi.FFI @@ -18,11 +35,13 @@ module GHCi.FFI ) where import Prelude -- See note [Why do we import Prelude here?] +#if !defined(js_HOST_ARCH) import Control.Exception +import Foreign.C +#endif import Data.Binary import GHC.Generics import Foreign -import Foreign.C data FFIType = FFIVoid @@ -51,6 +70,7 @@ prepForeignCall -> FFIType -- result type -> IO (Ptr C_ffi_cif) -- token for making calls (must be freed by caller) +#if !defined(js_HOST_ARCH) prepForeignCall cconv arg_types result_type = do let n_args = length arg_types arg_arr <- mallocArray n_args @@ -66,11 +86,26 @@ prepForeignCall cconv arg_types result_type = do " res ty: ", show result_type, ")" ] else return (castPtr cif) +#else +prepForeignCall _ _ _ = + error "GHCi.FFI.prepForeignCall: Called with JS_HOST_ARCH! Perhaps you need to run configure?" +#endif + freeForeignCallInfo :: Ptr C_ffi_cif -> IO () +#if !defined(js_HOST_ARCH) freeForeignCallInfo p = do free ((#ptr ffi_cif, arg_types) p) free p +#else +freeForeignCallInfo _ = + error "GHCi.FFI.freeForeignCallInfo: Called with JS_HOST_ARCH! Perhaps you need to run configure?" +#endif + +data C_ffi_cif + +#if !defined(js_HOST_ARCH) +data C_ffi_type strError :: C_ffi_status -> String strError r @@ -103,9 +138,6 @@ ffiType FFIUInt16 = ffi_type_uint16 ffiType FFIUInt32 = ffi_type_uint32 ffiType FFIUInt64 = ffi_type_uint64 -data C_ffi_type -data C_ffi_cif - type C_ffi_status = (#type ffi_status) type C_ffi_abi = (#type ffi_abi) @@ -161,3 +193,4 @@ foreign import ccall "ffi_prep_cif" -- -> Ptr () -- put result here -- -> Ptr (Ptr ()) -- arg values -- -> IO () +#endif diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 37de9717b0..aae6ecdbb1 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -827,6 +827,7 @@ addForeignSource lang src = do LangObjc -> "m" LangObjcxx -> "mm" LangAsm -> "s" + LangJs -> "js" RawObject -> "a" path <- addTempFile suffix runIO $ writeFile path src diff --git a/m4/fptools_set_haskell_platform_vars.m4 b/m4/fptools_set_haskell_platform_vars.m4 index 23b7fb63f9..d0c091e57d 100644 --- a/m4/fptools_set_haskell_platform_vars.m4 +++ b/m4/fptools_set_haskell_platform_vars.m4 @@ -48,6 +48,9 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS_SHELL_FUNCTIONS], hppa|hppa1_1|ia64|m68k|nios2|riscv32|rs6000|s390|sh4|vax) test -z "[$]2" || eval "[$]2=ArchUnknown" ;; + js) + test -z "[$]2" || eval "[$]2=ArchJavaScript" + ;; *) echo "Unknown arch [$]1" exit 1 @@ -112,6 +115,9 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS_SHELL_FUNCTIONS], gnu) test -z "[$]2" || eval "[$]2=OSHurd" ;; + ghcjs|js) + test -z "[$]2" || eval "[$]2=OSUnknown" + ;; *) echo "Unknown OS '[$]1'" exit 1 diff --git a/m4/ghc_convert_cpu.m4 b/m4/ghc_convert_cpu.m4 index f70114142f..8c1f1925e7 100644 --- a/m4/ghc_convert_cpu.m4 +++ b/m4/ghc_convert_cpu.m4 @@ -77,6 +77,9 @@ case "$1" in wasm32) $2="wasm32" ;; + js) + $2="js" + ;; *) echo "Unknown CPU $1" exit 1 diff --git a/m4/ghc_convert_os.m4 b/m4/ghc_convert_os.m4 index b104549b77..885ca24848 100644 --- a/m4/ghc_convert_os.m4 +++ b/m4/ghc_convert_os.m4 @@ -49,6 +49,9 @@ AC_DEFUN([GHC_CONVERT_OS],[ wasi) $3="wasi" ;; + ghcjs*) + $3="ghcjs" + ;; *) echo "Unknown OS $1" exit 1 diff --git a/m4/ghc_unregisterised.m4 b/m4/ghc_unregisterised.m4 index b06cb41c90..aafb92e165 100644 --- a/m4/ghc_unregisterised.m4 +++ b/m4/ghc_unregisterised.m4 @@ -5,7 +5,7 @@ AC_DEFUN([GHC_UNREGISTERISED], [ AC_MSG_CHECKING(whether target supports a registerised ABI) case "$TargetArch" in - i386|x86_64|powerpc|powerpc64|powerpc64le|s390x|arm|aarch64|riscv64|wasm32) + i386|x86_64|powerpc|powerpc64|powerpc64le|s390x|arm|aarch64|riscv64|wasm32|js) UnregisterisedDefault=NO AC_MSG_RESULT([yes]) ;; diff --git a/rts/include/stg/MachRegsForHost.h b/rts/include/stg/MachRegsForHost.h index 0a6ab5736d..78f823d95c 100644 --- a/rts/include/stg/MachRegsForHost.h +++ b/rts/include/stg/MachRegsForHost.h @@ -14,7 +14,7 @@ #pragma once -#if defined(UnregisterisedCompiler) +#if defined(UnregisterisedCompiler) || defined(js_HOST_ARCH) #if !defined(NO_REGS) #define NO_REGS #endif @@ -25,6 +25,9 @@ * typically defined by GHC, via a command-line option passed to gcc, * when the -funregisterised flag is given. * + * It is also enabled for target architectures that really lack registers, such + * as JavaScript. + * * NB. When NO_REGS is on, calling & return conventions may be * different. For example, all function arguments will be passed on * the stack, and components of an unboxed tuple will be returned on diff --git a/rts/js/arith.js b/rts/js/arith.js new file mode 100644 index 0000000000..66649c31a9 --- /dev/null +++ b/rts/js/arith.js @@ -0,0 +1,628 @@ +//#OPTIONS: CPP +// #define GHCJS_TRACE_ARITH 1 + +#ifdef GHCJS_TRACE_ARITH +function h$logArith() { h$log.apply(h$log,arguments); } +#define TRACE_ARITH(args...) h$logArith(args) +#else +#define TRACE_ARITH(args...) +#endif + +#define UN(x) ((x)>>>0) +#define W32(x) (BigInt(x)) +#define I32(x) (BigInt(x)) +#define W64(h,l) ((BigInt(h) << BigInt(32)) | BigInt(l>>>0)) +#define W64h(x) (Number(x >> BigInt(32)) >>> 0) +#define W64l(x) (Number(BigInt.asUintN(32, x)) >>> 0) +#define I64(h,l) ((BigInt(h) << BigInt(32)) | BigInt(l>>>0)) +#define I64h(x) (Number(x >> BigInt(32))|0) +#define I64l(x) (Number(BigInt.asUintN(32,x)) >>> 0) +#define RETURN_I64(x) RETURN_UBX_TUP2(I64h(x), I64l(x)) +#define RETURN_W64(x) RETURN_UBX_TUP2(W64h(x), W64l(x)) +#define RETURN_W32(x) return Number(x) + +function h$hs_quotWord64(h1,l1,h2,l2) { + var a = W64(h1,l1); + var b = W64(h2,l2); + var r = BigInt.asUintN(64, a / b); + TRACE_ARITH("Word64: " + a + " / " + b + " ==> " + r) + RETURN_W64(r); +} + +function h$hs_remWord64(h1,l1,h2,l2) { + var a = W64(h1,l1); + var b = W64(h2,l2); + var r = BigInt.asUintN(64, a % b); + TRACE_ARITH("Word64: " + a + " % " + b + " ==> " + r) + RETURN_W64(r); +} + +function h$hs_timesWord64(h1,l1,h2,l2) { + var a = W64(h1,l1); + var b = W64(h2,l2); + var r = BigInt.asUintN(64, a * b); + TRACE_ARITH("Word64: " + a + " * " + b + " ==> " + r) + RETURN_W64(r); +} + +function h$hs_minusWord64(h1,l1,h2,l2) { + var a = (BigInt(h1) << BigInt(32)) | BigInt(l1>>>0); + var b = (BigInt(h2) << BigInt(32)) | BigInt(l2>>>0); + var r = BigInt.asUintN(64, a - b); + TRACE_ARITH("Word64: " + a + " - " + b + " ==> " + r) + RETURN_W64(r); +} + +function h$hs_plusWord64(h1,l1,h2,l2) { + var a = W64(h1,l1); + var b = W64(h2,l2); + var r = BigInt.asUintN(64, a + b); + TRACE_ARITH("Word64: " + a + " + " + b + " ==> " + r) + RETURN_W64(r); +} + +function h$hs_timesInt64(h1,l1,h2,l2) { + var a = I64(h1,l1); + var b = I64(h2,l2); + var r = BigInt.asIntN(64, a * b); + TRACE_ARITH("Int64: " + a + " * " + b + " ==> " + r) + RETURN_I64(r); +} + +function h$hs_quotInt64(h1,l1,h2,l2) { + var a = I64(h1,l1); + var b = I64(h2,l2); + var r = BigInt.asIntN(64, a / b); + TRACE_ARITH("Int64: " + a + " / " + b + " ==> " + r) + RETURN_I64(r); +} + +function h$hs_remInt64(h1,l1,h2,l2) { + var a = I64(h1,l1); + var b = I64(h2,l2); + var r = BigInt.asIntN(64, a % b); + TRACE_ARITH("Int64: " + a + " % " + b + " ==> " + r) + RETURN_I64(r); +} + +function h$hs_plusInt64(h1,l1,h2,l2) { + var a = I64(h1,l1); + var b = I64(h2,l2); + var r = BigInt.asIntN(64, a + b); + TRACE_ARITH("Int64: " + a + " + " + b + " ==> " + r) + RETURN_I64(r); +} + +function h$hs_minusInt64(h1,l1,h2,l2) { + var a = I64(h1,l1); + var b = I64(h2,l2); + var r = BigInt.asIntN(64, a - b); + TRACE_ARITH("Int64: " + a + " - " + b + " ==> " + r) + RETURN_I64(r); +} + +function h$hs_uncheckedShiftLWord64(h,l,n) { + var rh, rl; + + n &= 63; + if (n == 0) { + rh = h; + rl = l; + } else if (n === 32) { + rh = l; + rl = 0; + } else if (n < 32) { + rh = UN((h << n) | (l >>> (32 - n))); + rl = UN(l << n); + } else { + rh = UN(l << (n - 32)); + rl = 0; + } + TRACE_ARITH("Word64: " + W64(h,l) + " << " + n + " ==> " + W64(rh,rl)) + RETURN_UBX_TUP2(rh,rl); +} + +function h$hs_uncheckedShiftRWord64(h,l,n) { + var rh, rl; + + n &= 63; + if(n == 0) { + rh = h; + rl = l; + } else if(n === 32) { + rh = 0; + rl = h; + } else if(n < 32) { + rh = h >>> n; + rl = UN((l >>> n ) | (h << (32-n))); + } else { + rh = 0; + rl = h >>> (n-32); + } + TRACE_ARITH("Word64: " + W64(h,l) + " >>> " + n + " ==> " + W64(rh,rl)) + RETURN_UBX_TUP2(rh,rl); +} + +function h$hs_uncheckedShiftLLInt64(h,l,n) { + var rh,rl; + + n &= 63; + if (n == 0) { + rh = h; + rl = l; + } else if (n === 32) { + rh = l|0; + rl = 0; + } else if (n < 32) { + rh = (h << n) | (l >>> (32 - n)); + rl = UN(l << n); + } else { + rh = l << (n - 32); + rl = 0; + } + TRACE_ARITH("Int64: " + W64(h,l) + " << " + n + " ==> " + W64(rh,rl)) + RETURN_UBX_TUP2(rh,rl); +} + +function h$hs_uncheckedShiftRAInt64(h,l,n) { + var rh,rl; + + n &= 63; + if (n == 0) { + rh = h; + rl = l; + } else if (n < 32) { + rh = h >> n; + rl = UN((l >>> n) | UN(h << (32 - n))); + } else { + rh = h >= 0 ? 0 : -1; + rl = UN(h >> (n - 32)); + } + TRACE_ARITH("Int64: " + W64(h,l) + " >> " + n + " ==> " + W64(rh,rl)) + RETURN_UBX_TUP2(rh,rl); +} + +function h$hs_uncheckedShiftRLInt64(h,l,n) { + var rh,rl; + + n &= 63; + if(n == 0) { + rh = h; + rl = l; + } else if(n == 32) { + rh = 0; + rl = UN(h); + } else if(n < 32) { + rh = h >>> n; + rl = UN((l >>> n) | (h << (32-n))); + } else { + rh = 0; + rl = h >>> (n-32); + } + TRACE_ARITH("Int64: " + W64(h,l) + " >>> " + n + " ==> " + W64(rh,rl)) + RETURN_UBX_TUP2(rh,rl); +} + +var h$mulInt32 = Math.imul; + +// Compute product of two Ints. Returns (nh,ch,cl) +// where (ch,cl) are the two parts of the 64-bit result +// and nh is 0 if ch can be safely dropped (i.e. it's a sign-extension of cl). +function h$hs_timesInt2(l1,l2) { + var a = I32(l1); + var b = I32(l2); + var r = BigInt.asIntN(64, a * b); + TRACE_ARITH("Int32: " + a + " * " + b + " ==> " + r + " (Int64)") + + var rh = I64h(r); + var rl = I64l(r)|0; + var nh = ((rh === 0 && rl >= 0) || (rh === -1 && rl < 0)) ? 0 : 1; + RETURN_UBX_TUP3(nh, rh, rl); +} + + +function h$mulWord32(l1,l2) { + var a = W32(l1); + var b = W32(l2); + var r = BigInt.asUintN(32, a * b); + TRACE_ARITH("Word32: " + a + " * " + b + " ==> " + r) + RETURN_W32(r); +} + +function h$mul2Word32(l1,l2) { + var a = W32(l1); + var b = W32(l2); + var r = BigInt.asUintN(64, a * b); + TRACE_ARITH("Word32: " + a + " * " + b + " ==> " + r + " (Word64)") + RETURN_W64(r); +} + +function h$quotWord32(n,d) { + var a = W32(n); + var b = W32(d); + var r = BigInt.asUintN(32, a / b); + TRACE_ARITH("Word32: " + a + " / " + b + " ==> " + r) + RETURN_W32(r); +} + +function h$remWord32(n,d) { + var a = W32(n); + var b = W32(d); + var r = BigInt.asUintN(32, a % b); + TRACE_ARITH("Word32: " + a + " % " + b + " ==> " + r) + RETURN_W32(r); +} + +function h$quotRemWord32(n,d) { + var a = W32(n); + var b = W32(d); + var q = BigInt.asUintN(32, a / b); + var r = BigInt.asUintN(32, a % b); + TRACE_ARITH("Word32: " + a + " `quotRem` " + b + " ==> (" + q + ", " + r + ")") + RETURN_UBX_TUP2(Number(q),Number(r)); +} + +function h$quotRem2Word32(nh,nl,d) { + var a = W64(nh,nl); + var b = W32(d); + var q = BigInt.asUintN(32, a / b); + var r = BigInt.asUintN(32, a % b); + TRACE_ARITH("Word32: " + a + " `quotRem2` " + b + " ==> (" + q + ", " + r + ")") + RETURN_UBX_TUP2(Number(q),Number(r)); +} + +function h$wordAdd2(l1,l2) { + var a = W32(l1); + var b = W32(l2); + var r = BigInt.asUintN(64, a + b); + TRACE_ARITH("Word32: " + a + " + " + b + " ==> " + r + " (Word64)") + RETURN_W64(r); +} + +function h$isDoubleNegativeZero(d) { + TRACE_ARITH("isDoubleNegativeZero: " + d) + return (d===0 && (1/d) === -Infinity) ? 1 : 0; +} + +function h$isFloatNegativeZero(d) { + TRACE_ARITH("isFloatNegativeZero: " + d) + return (d===0 && (1/d) === -Infinity) ? 1 : 0; +} + +function h$isDoubleInfinite(d) { + return (d === Number.NEGATIVE_INFINITY || d === Number.POSITIVE_INFINITY) ? 1 : 0; +} + +function h$isFloatInfinite(d) { + return (d === Number.NEGATIVE_INFINITY || d === Number.POSITIVE_INFINITY) ? 1 : 0; +} + +function h$isFloatFinite(d) { + return (d !== Number.NEGATIVE_INFINITY && d !== Number.POSITIVE_INFINITY && !isNaN(d)) ? 1 : 0; +} + +function h$isDoubleFinite(d) { + return (d !== Number.NEGATIVE_INFINITY && d !== Number.POSITIVE_INFINITY && !isNaN(d)) ? 1 : 0; +} + +function h$isDoubleNaN(d) { + return (isNaN(d)) ? 1 : 0; +} + +function h$isFloatNaN(d) { + return (isNaN(d)) ? 1 : 0; +} + +function h$isDoubleDenormalized(d) { + return (d !== 0 && Math.abs(d) < 2.2250738585072014e-308) ? 1 : 0; +} + +function h$isFloatDenormalized(d) { + h$convertFloat[0] = d; + var i = h$convertInt[0]; + var exp = (i >> 23) & 0xff; + var s = i&8388607; + return ((s !== 0 && exp === 0) ? 1 : 0); +} + +var h$convertBuffer = new ArrayBuffer(8); +var h$convertDouble = new Float64Array(h$convertBuffer); +var h$convertFloat = new Float32Array(h$convertBuffer); +var h$convertInt = new Int32Array(h$convertBuffer); +var h$convertWord = new Uint32Array(h$convertBuffer); + +// use direct inspection through typed array for decoding floating point numbers if this test gives +// the expected answer. fixme: does this test catch all non-ieee or weird endianness situations? +h$convertFloat[0] = 0.75; + +function h$decodeFloatInt(d) { + TRACE_ARITH("decodeFloatInt: " + d) + if(isNaN(d)) { + RETURN_UBX_TUP2(-12582912, 105); + } + h$convertFloat[0] = d; + var i = h$convertInt[0]; + var exp = (i >> 23) & 0xff; + var sgn = 2 * (i >> 31) + 1; + var s = i&8388607; + if(exp === 0) { // zero or denormal + if(s === 0) { + TRACE_ARITH("decodeFloatInt s: 0 e: 0") + RETURN_UBX_TUP2(0, 0); + } else { + h$convertFloat[0] = d*8388608; // put d in the normal range (~ shift left 23 bits) + i = h$convertInt[0]; + s = (i&8388607) | 8388608; + e = ((i >> 23) & 0xff) - 173; // take into account normalization above (150+23) + TRACE_ARITH("decodeFloatInt s: " + (sgn * s) + " e: " + e) + RETURN_UBX_TUP2(sgn*s, e) + } + } else { + TRACE_ARITH("decodeFloatInt s: " + (sgn * (s|8388608)) + " e: " + (exp-150)) + RETURN_UBX_TUP2(sgn * (s|8388608), exp - 150); + } +} + +function h$decodeDouble2Int(d) { + TRACE_ARITH("decodeDouble2Int: " + d) + if(isNaN(d)) { + RETURN_UBX_TUP4(1, -1572864, 0, 972); + } + h$convertDouble[0] = d; + TRACE_ARITH("decodeDouble2Int binary: " + h$convertInt[0].toString(2) + " " + h$convertInt[1].toString(2)) + var i1 = h$convertInt[1]; + var ret1, ret2 = h$convertInt[0], ret3; + var exp = (i1&2146435072)>>>20; + if(exp === 0) { // denormal or zero + if((i1&2147483647) === 0 && ret2 === 0) { + ret1 = 0; + ret3 = 0; + } else { + h$convertDouble[0] = d*9007199254740992; + i1 = h$convertInt[1]; + ret1 = (i1&1048575)|1048576; + ret2 = h$convertInt[0]; + ret3 = ((i1&2146435072)>>>20)-1128; + } + } else { + ret3 = exp-1075; + ret1 = (i1&1048575)|1048576; + } + TRACE_ARITH("decodeDouble2Int: exp: " + ret3 + " significand: " + ret1 + " " + ret2) + RETURN_UBX_TUP4(i1<0?-1:1,ret1,ret2,ret3); +} + +// round .5 to nearest even number +function h$rintDouble(a) { + var rounda = Math.round(a); + if(a >= 0) { + if(a%1===0.5 && rounda%2===1) { // tie + return rounda-1; + } else { + return rounda; + } + } else { + if(a%1===-0.5 && rounda%2===-1) { // tie + return rounda-1; + } else { + return rounda; + } + } +} +var h$rintFloat = h$rintDouble; + +function h$acos(d) { return Math.acos(d); } +function h$acosf(f) { return Math.acos(f); } + +function h$asin(d) { return Math.asin(d); } +function h$asinf(f) { return Math.asin(f); } + +function h$atan(d) { return Math.atan(d); } +function h$atanf(f) { return Math.atan(f); } + +function h$atan2(x,y) { return Math.atan2(x,y); } +function h$atan2f(x,y) { return Math.atan2(x,y); } + +function h$cos(d) { return Math.cos(d); } +function h$cosf(f) { return Math.cos(f); } + +function h$sin(d) { return Math.sin(d); } +function h$sinf(f) { return Math.sin(f); } + +function h$tan(d) { return Math.tan(d); } +function h$tanf(f) { return Math.tan(f); } + +function h$cosh(d) { return (Math.exp(d)+Math.exp(-d))/2; } +function h$coshf(f) { return h$cosh(f); } + +function h$sinh(d) { return (Math.exp(d)-Math.exp(-d))/2; } +function h$sinhf(f) { return h$sinh(f); } + +function h$tanh(d) { return (Math.exp(2*d)-1)/(Math.exp(2*d)+1); } +function h$tanhf(f) { return h$tanh(f); } + +var h$popCntTab = + [0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4,1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5, + 1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6, + 1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6, + 2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7, + 1,2,2,3,2,3,3,4,2,3,3,4,3,4,4,5,2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6, + 2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7, + 2,3,3,4,3,4,4,5,3,4,4,5,4,5,5,6,3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7, + 3,4,4,5,4,5,5,6,4,5,5,6,5,6,6,7,4,5,5,6,5,6,6,7,5,6,6,7,6,7,7,8]; + +function h$popCnt32(x) { + return h$popCntTab[x&0xFF] + + h$popCntTab[(x>>>8)&0xFF] + + h$popCntTab[(x>>>16)&0xFF] + + h$popCntTab[(x>>>24)&0xFF]; +} + +function h$popCnt64(x1,x2) { + return h$popCntTab[x1&0xFF] + + h$popCntTab[(x1>>>8)&0xFF] + + h$popCntTab[(x1>>>16)&0xFF] + + h$popCntTab[(x1>>>24)&0xFF] + + h$popCntTab[x2&0xFF] + + h$popCntTab[(x2>>>8)&0xFF] + + h$popCntTab[(x2>>>16)&0xFF] + + h$popCntTab[(x2>>>24)&0xFF]; +} + +function h$reverseWord(w) { + /* Reverse the bits in a 32-bit word this trick comes from + * https://graphics.stanford.edu/~seander/bithacks.html#ReverseParallel This + * method should use a bit more memory than other methods, but we choose it + * because it does not rely on any 64bit multiplication or look up tables. + * Note that this could be expressed in the Haskell EDSL, but we choose to not + * do that for improved sharing in the JIT. Should be O(lg n) + */ + var r = w; + r = ((r >>> 1) & 0x55555555) | ((r & 0x55555555) << 1); // swap odd and even bits + r = ((r >>> 2) & 0x33333333) | ((r & 0x33333333) << 2); // swap consecutive pairs + r = ((r >>> 4) & 0x0F0F0F0F) | ((r & 0x0F0F0F0F) << 4); // swap nibbles + r = ((r >>> 8) & 0x00FF00FF) | ((r & 0x00FF00FF) << 8); // swap bytes + r = ( r >>> 16 ) | ( r << 16); // swap 2-byte long pairs + r = r >>> 0; // ensure w is unsigned + return r; +} + +function h$bswap64(x1,x2) { + RETURN_UBX_TUP2(UN((x2 >>> 24) | (x2 << 24) | ((x2 & 0xFF00) << 8) | ((x2 & 0xFF0000) >> 8)) + ,UN((x1 >>> 24) | (x1 << 24) | ((x1 & 0xFF00) << 8) | ((x1 & 0xFF0000) >> 8))); +} + +var h$clz32 = Math.clz32 || function(x) { + if (x < 0) return 0; + if (x === 0) return 32; + return 31 - ((Math.log(x) / Math.LN2) | 0); +} +function h$clz8(x) { + return h$clz32(x&255)-24; +} +function h$clz16(x) { + return h$clz32(x&65535)-16; +} + +function h$clz64(x1,x2) { + return (x1 === 0) ? 32 + h$clz32(x2) : h$clz32(x1); +} + +var h$ctz32tbl = [32,0,1,26,2,23,27,0,3,16,24,30,28,11,0,13,4,7,17,0,25,22,31,15,29,10,12,6,0,21,14,9,5,20,8,19,18,0,0,0,0,0,31]; +function h$ctz32(x) { + return h$ctz32tbl[((x&-x)%37)&63]; +} +function h$ctz16(x) { + return h$ctz32(x|65536); +} +function h$ctz8(x) { + return h$ctz32(x|256); +} +function h$ctz64(x1,x2) { + return (x2 === 0) ? 32 + h$ctz32(x1) : h$ctz32(x2); +} + +function h$decodeDoubleInt64(d) { + TRACE_ARITH("decodeDoubleInt64: " + d) + if(isNaN(d)) { + RETURN_UBX_TUP3(972, -1572864, 0); + } + h$convertDouble[0] = d; + var i0 = h$convertInt[0], i1 = h$convertInt[1]; + var exp = (i1&2146435072)>>>20; + var ret1, ret2 = i0, ret3; + if(exp === 0) { // denormal or zero + if((i1&2147483647) === 0 && ret2 === 0) { + ret1 = 0; + ret3 = 0; + } else { + h$convertDouble[0] = d*9007199254740992; + i1 = h$convertInt[1]; + ret1 = (i1&1048575)|1048576; + ret2 = h$convertInt[0]; + ret3 = ((i1&2146435072)>>>20)-1128; + } + } else { + ret3 = exp-1075; + ret1 = (i1&1048575)|1048576; + } + // negate mantissa for negative input + if(d < 0) { + if(ret2 === 0) { + ret1 = ((~ret1) + 1) | 0; + // ret2 = 0; + } else { + ret1 = ~ret1; + ret2 = ((~ret2) + 1) | 0; + } + } + // prim ubx tup returns don't return the first value! + RETURN_UBX_TUP3(ret3,ret1,ret2); +} + +function h$__int_encodeDouble(j,e) { + if (!j) return 0; + return (j|0) * (2 ** (e|0)); +} + +function h$__word_encodeDouble(j,e) { + if (!j) return 0; + return (j>>>0) * (2 ** (e|0)); +} + +function h$__int_encodeFloat(j,e) { + if (!j) return 0; + return Math.fround((j|0) * (2 ** (e|0))); +} + +function h$__word_encodeFloat(j,e) { + if (!j) return 0; + return Math.fround((j>>>0) * (2 ** (e|0))); +} + +function h$stg_word32ToFloatzh(v) { + h$convertWord[0] = v; + return h$convertFloat[0]; +} + +function h$stg_floatToWord32zh(v) { + h$convertFloat[0] = v; + return h$convertWord[0]; +} + +function h$stg_word64ToDoublezh(h,l) { + h$convertWord[0] = l; + h$convertWord[1] = h; + return h$convertDouble[0]; +} + +function h$stg_doubleToWord64zh(v) { + h$convertDouble[0] = v; + var l = h$convertWord[0]; + var h = h$convertWord[1]; + RETURN_UBX_TUP2(h,l); +} + +function h$sqrt(x) { + return Math.sqrt(x); +} + +function h$sqrtf(x) { + return Math.fround(Math.sqrt(x)); +} + +function h$log1p(x) { + return Math.log1p(x); +} + +function h$log1pf(x) { + return Math.fround(Math.log1p(x)); +} + +function h$expm1(x) { + return Math.expm1(x); +} + +function h$expm1f(x) { + return Math.fround(Math.expm1(x)); +} diff --git a/rts/js/compact.js b/rts/js/compact.js new file mode 100644 index 0000000000..4d2384219a --- /dev/null +++ b/rts/js/compact.js @@ -0,0 +1,69 @@ +//#OPTIONS: CPP + +#ifdef GHCJS_TRACE_COMPACT +function h$logCompact() { h$log.apply(h$log,arguments); } +#define TRACE_COMPACT(args...) h$logCompact(args) +#else +#define TRACE_COMPACT(args...) +#endif + +function h$compactNew(size) { + TRACE_COMPACT("compactNew" + size) + throw new Error("not implemented"); +} + +function h$compactResize(compact, size) { + TRACE_COMPACT("compactResize" + size) +} + +function h$compactContains(compact, obj) { + TRACE_COMPACT("compactContains") + return 0; +} + +function h$compactContainsAny(obj) { + TRACE_COMPACT("compactContainsAny") + return 0; +} + +function h$compactGetFirstBlock(compact) { + TRACE_COMPACT("compactGetFirstBlock") + RETURN_UBX_TUP2(null, 0); +} + +function h$compactGetNextBlock(compact, blocka, blokco) { + TRACE_COMPACT("compactGetNextBlock") + RETURN_UBX_TUP2(null, 0); +} + +function h$compactAllocateBlock(size, suggesta, suggesto) { + TRACE_COMPACT("compactAllocateBlock" + size) + throw new Error("not implemented"); + // returns new root address + RETURN_UBX_TUP2(null, 0); +} + +function h$compactFixupPointers(blocka, blocko, roota, rooto) { + TRACE_COMPACT("compactFixupPointers") + throw new Error("not implemented"); + // returns new root address and new Compact# + RETURN_UBX_TUP3(null, null, 0); +} + + +function h$compactAdd(compact, obj) { + TRACE_COMPACT("compactAdd") + throw new Error("not implemented"); +} + + +function h$compactAddWithSharing(compact, obj) { + TRACE_COMPACT("compactAddWithSharing") + throw new Error("not implemented"); +} + + +function h$compactCompactSize(compact) { + TRACE_COMPACT("compactSize") + return 0; +} diff --git a/rts/js/debug.js b/rts/js/debug.js new file mode 100644 index 0000000000..76cc4c33d7 --- /dev/null +++ b/rts/js/debug.js @@ -0,0 +1,260 @@ +//#OPTIONS: CPP + +/* + debugging tools that depend on node.js extensions + + compile with -DGHCJS_DEBUG_ALLOC to use + + compile additionally with -DGHCJS_DEBUG_ALLOC_ALWAYS_ENABLE to enable + allocation debugging even if the JavaScript runtime does not support + weak references with observable deadness. This causes allocation + debugging to run with reduced functionality (h$debugAlloc_shouldBeDead + is not available) and keeps strong references to everything allocaded + between h$gc calls. + */ + +// public API + +// called after (GHCJS) GC, all objects reachable from the Haskell +// runtime must have been marked with the given mark +function h$debugAlloc_verifyReachability(mark) { +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_init_internal(); + h$debugAlloc_verifyReachability_internal(mark); +#endif +} + +// called after creating a new Heap object or RTS primitive +function h$debugAlloc_notifyAlloc(obj) { +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_init_internal(); + h$debugAlloc_notifyAlloc_internal(obj); +#endif +} + +// called when an object is used +function h$debugAlloc_notifyUse(obj) { +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_init_internal(); + h$debugAlloc_notifyUse_internal(obj); +#endif +} + +// private API + +#ifdef GHCJS_DEBUG_ALLOC + +var h$debugAlloc; + +function h$debugAlloc_init_internal() { + if(!h$debugAlloc) { + h$debugAlloc = + { enabled: false + // Set of weak references to everything that's been allocated + , allocatedHeapObjects: null + // reference to the node.js weak module + , makeWeak: null + // exception while trying to load the node.js weak module + , makeWeakError: null + // each registered allocated heap object gets a unique sequence number + , allocCount: 0 + // these objects have been seen with the wrong mark at least once (Set of weak refs) + // each object has a __ghcjsShouldBeDeadSince timestamp indicating the first time + // the object was unreachable from the Haskell heap + , shouldBeDead: null + // these objects have been seen with the wrong mark at least once, and have been + // used after that (Map of sequence no -> heap object) + // + // this set should remain empty. + , shouldBeDead_reported: null + // these sequence ids of items that have been in the shouldBeDead_reported set + // this should also be empty + , shouldBeDead_reported_ids: null + }; + +#ifndef GHCJS_BROWSER + if(h$isNode()) { + try { + // the 'weak' package provides the same functionality, but segfaults + // try this first + h$debugAlloc.makeWeak = require('weak-napi'); + h$debugAlloc.enabled = true; + } catch(e) { + h$debugAlloc.makeWeakError = e; + } + /* + if(!h$debugAlloc.makeWeak) { + try { + // fall back to 'weak' + h$debugAlloc.makeWeak = require('weak'); + h$debugAlloc.enabled = true; + } catch(e) { + h$debugAlloc.makeWeakError = e; + } + }*/ + } +#endif +#ifdef GHCJS_DEBUG_ALLOC_ALWAYS_ENABLE + h$debugAlloc.enabled = true; +#endif + if(h$debugAlloc.enabled) { + h$debugAlloc.allocatedHeapObjects = new Set(); + if(h$debugAlloc.makeWeak) { + h$debugAlloc.shouldBeDead = new Set(); + } + h$debugAlloc.shouldBeDead_reported = new Map(); + h$debugAlloc.shouldBeDead_reported_ids = new Set(); + } + } +} + +function h$debugAlloc_notifyAlloc_internal(obj) { + if(!h$debugAlloc.enabled) return; + // test if already notified + if(typeof obj.__ghcjsDebugAllocSequenceNo == 'number') return; + obj.__ghcjsDebugAllocSequenceNo = h$debugAlloc.allocCount++; + obj.__ghcjsDebugAllocStack = new Error(); + + // wrap all own properties in a getter and setter + // use these to notify the allocation debugger of each use + for(var p in obj) { + if(!p.startsWith('__') && obj.hasOwnProperty(p)) { + (function(pobj, pp) { + var pw = '__alloc_wrapped_' + pp; + pobj[pw] = pobj[pp]; + Object.defineProperty(pobj, pp, + { get: function() { + h$debugAlloc_notifyUse_internal(this); + return this[pw]; + } + , set: function(v) { + h$debugAlloc_notifyUse_internal(this); + this[pw] = v; + } + }); + })(obj, p); + } + } + + // insert into our set of allocated heap objects, use a weak ref if supported + if(h$debugAlloc.makeWeak) { + h$debugAlloc.allocatedHeapObjects.add(h$debugAlloc.makeWeak(obj)); + } else { + h$debugAlloc.allocatedHeapObjects.add(obj); + } +} + +function h$debugAlloc_filterReport(obj) { + var stk = obj.__ghcjsDebugAllocStack ? obj.__ghcjsDebugAllocStack.stack : ''; + if(!(stk.indexOf('h$runThreadSlice') >= 0)) return true; + + // if(obj.hasOwnProperty('f') && obj.hasOwnProperty('d1') && obj.hasOwnProperty('d2')) { + // } + // if(stk.indexOf(' at h$d ') >= 0) return true; + // if(stk.indexOf(' at h$makeEnum ') >= 0) return true; + return false; +} + +var h$debugAlloc_notify_recursive = false; +function h$debugAlloc_notifyUse_internal(obj) { + if(!h$debugAlloc.enabled) return; + if(h$debugAlloc_notify_recursive) return; + try { + h$debugAlloc_notify_recursive = true; + if(typeof obj === 'object' && obj && typeof obj.__ghcjsShouldBeDeadSince === 'number' && !h$debugAlloc_filterReport(obj)) { + var seqNo = obj.__ghcjsDebugAllocSequenceNo; + if(!h$debugAlloc.shouldBeDead_reported_ids.has(seqNo)) { + if(h$debugAlloc.makeWeak) { + h$debugAlloc.shouldBeDead_reported.set(seqNo, obj); // h$debugAlloc.makeWeak(obj)); + } + h$debugAlloc.shouldBeDead_reported_ids.add(seqNo); + // should we do more reporting, output the CCS or JS stack of the allocation point perhaps? + } + } + } finally { + h$debugAlloc_notify_recursive = false; + } +} + +// call this immediately after h$gc +function h$debugAlloc_verifyReachability_internal(mark) { + if(!h$debugAlloc.enabled) return; + if(typeof global == 'object' && global && global.gc) { + global.gc(); + } + var timestamp = Date.now(); + var weak, elem, key; + function getMark(obj) { + if(typeof obj.m === 'number') { + return obj.m; + } else if(typeof elem.m === 'object' && elem.m) { + return obj.m.m; + } else { + return -1; + } + } + if(h$debugAlloc.makeWeak) { + // keep track of things with assistance from weaks in the JS runtime, yay! + for(weak of h$debugAlloc.allocatedHeapObjects) { + elem = h$debugAlloc.makeWeak.get(weak); + if(elem === undefined) { + h$debugAlloc.allocatedHeapObjects.delete(weak); + } else { + if(getMark(elem) !== mark) { + elem.__ghcjsShouldBeDeadSince = timestamp; + h$debugAlloc.shouldBeDead.add(h$debugAlloc.makeWeak(elem)); + } + } + } + // clean up dead refs + for(weak of h$debugAlloc.shouldBeDead) { + if(h$debugAlloc.makeWeak.isDead(weak)) { + h$debugAlloc.shouldBeDead.delete(weak); + } + } + /* we store the original objects now + for([key, weak] of h$debugAlloc.shouldBeDead_reported) { + if(h$debugAlloc.makeWeak.isDead(weak)) { + h$debugAlloc.shouldBeDead_reported.delete(key); + } + } */ + } else { + // no support for weaks in the JS runtime + // we don't keep track of shouldBeDead, since that would leak everything ever allocated + // but we can still record use-after-unreachable cases + for(elem of h$debugAlloc.allocatedHeapObjects) { + if(getMark(elem) !== mark) { + h$debugAlloc.allocatedHeapObjects.delete(elem); + elem.__ghcjsShouldBeDeadSince = timestamp; + } + } + } +} +#endif + +/* +var h$debug = {}; + +function h$loadDebugTools() { + function load(m, p) { + if(h$isNode()) { + try { + var t = require(m); + h$debug[p] = t; + } catch(e) { } + } + } + load('gc-stats', 'gcStats'); + load('v8-natives', 'v8'); + var t; + if(h$isNode()) { + try { + t = require('gc-stats'); + h$debug.gcStats = t; + } catch(e) { } + try { + require(''); + } catch(e) { } + } +} +*/ diff --git a/rts/js/enum.js b/rts/js/enum.js new file mode 100644 index 0000000000..a5f8ca8d88 --- /dev/null +++ b/rts/js/enum.js @@ -0,0 +1,38 @@ +//#OPTIONS: CPP + +// some Enum conversion things + +// an array of generic enums +var h$enums = []; +function h$initEnums() { + for(var i=0;i<256;i++) { + h$enums[i] = h$makeEnum(i); + } +} +h$initStatic.push(h$initEnums); + +function h$makeEnum(tag) { + var f = function() { + return h$stack[h$sp]; + } + h$setObjInfo(f, 2, "Enum", [], tag+1, 0, [1], null); +#ifdef GHCJS_PROF + return h$c0(f, h$CCS_SYSTEM); +#else + return h$c0(f); +#endif +} + +// used for all non-Bool enums +function h$tagToEnum(tag) { + if(tag >= h$enums.length) { + return h$makeEnum(tag); + } else { + return h$enums[tag]; + } +} + +function h$dataTag(e) { + return (e===true)?1:((typeof e !== 'object')?0:(e.f.a-1)); +} + diff --git a/rts/js/environment.js b/rts/js/environment.js new file mode 100644 index 0000000000..193d6a6029 --- /dev/null +++ b/rts/js/environment.js @@ -0,0 +1,508 @@ +//#OPTIONS: CPP + +#ifdef GHCJS_TRACE_ENV +function h$logEnv() { h$log.apply(h$log,arguments); } +#define TRACE_ENV(args...) h$logEnv(args) +#else +#define TRACE_ENV(args...) +#endif + +// set up debug logging for the current JS environment/engine +// browser also logs to <div id="output"> if jquery is detected +// the various debug tracing options use h$log +#ifndef GHCJS_BROWSER +var h$glbl; +function h$getGlbl() { h$glbl = this; } +h$getGlbl(); +#endif +#ifdef GHCJS_LOG_BUFFER +var h$logBufferSize = 6000; +var h$logBufferShrink = 1000; +var h$logBuffer = []; +#endif +function h$log() { +#ifdef GHCJS_LOG_BUFFER + if(!h$logBuffer) return; + var s = ''; + for(var i=0;i<arguments.length;i++) { s = s + arguments[i]; } + h$logBuffer.push(s); + if(h$logBuffer.length > h$logBufferSize) h$logBuffer = h$logBuffer.slice(h$logBufferShrink); +#else + try { +#ifndef GHCJS_BROWSER + if(h$glbl) { + if(h$glbl.console && h$glbl.console.log) { + h$glbl.console.log.apply(h$glbl.console,arguments); + } else { + h$glbl.print.apply(this,arguments); + } + } else { + if(typeof console !== 'undefined') { +#endif + console.log.apply(console, arguments); +#ifndef GHCJS_BROWSER + } else if(typeof print !== 'undefined') { + print.apply(null, arguments); + } + } +#endif + } catch(ex) { + // ignore console.log exceptions (for example for IE9 when console is closed) + } +#endif +#ifdef GHCJS_LOG_JQUERY + // if we have jquery, add to <div id='output'> element + if(typeof(jQuery) !== 'undefined') { + var x = ''; + for(var i=0;i<arguments.length;i++) { x = x + arguments[i]; } + var xd = jQuery("<div></div>"); + xd.text(x); + jQuery('#output').append(xd); + } +#endif +} + +function h$collectProps(o) { + var props = []; + for(var p in o) { props.push(p); } + return("{"+props.join(",")+"}"); +} + + + +// load the command line arguments in h$programArgs +// the first element is the program name +var h$programArgs_; +var h$rtsArgs_; + +function h$programArgs() { + if (!h$programArgs_) { + h$initArgs(); + } + return h$programArgs_; +} + +function h$rtsArgs() { + if (!h$rtsArgs_) { + h$initArgs(); + } + return h$rtsArgs_; +} + +function h$initArgs() { + #ifdef GHCJS_BROWSER + h$programArgs_ = [ "a.js" ]; + #else + if(h$isNode()) { + h$programArgs_ = process.argv.slice(1); + } else if(h$isJvm()) { + h$programArgs_ = h$getGlobal(this).arguments.slice(0); + h$programArgs_.unshift("a.js"); + } else if(h$isJsShell() && typeof h$getGlobal(this).scriptArgs !== 'undefined') { + h$programArgs_ = h$getGlobal(this).scriptArgs.slice(0); + h$programArgs_.unshift("a.js"); + } else if((h$isJsShell() || h$isJsCore()) && typeof h$getGlobal(this).arguments !== 'undefined') { + h$programArgs_ = h$getGlobal(this).arguments.slice(0); + h$programArgs_.unshift("a.js"); + } else { + h$programArgs_ = [ "a.js" ]; + } + #endif + + //filter RTS arguments + { + var prog_args = []; + var rts_args = []; + var in_rts = false; + var i = 0; + for(i=0;i<h$programArgs_.length;i++) { + var a = h$programArgs_[i]; + // The '--RTS' argument disables all future + // +RTS ... -RTS processing. + if (a === "--RTS") { + break; + } + // The '--' argument is passed through to the program, but + // disables all further +RTS ... -RTS processing. + else if (a === "--") { + break; + } + else if (a === "+RTS") { + in_rts = true; + } + else if (a === "-RTS") { + in_rts = false; + } + else if (in_rts) { + rts_args.push(a); + } + else { + prog_args.push(a); + } + } + // process remaining program arguments + for (;i<h$programArgs_.length;i++) { + prog_args.push(h$programArgs_[i]); + } + //set global variables + h$programArgs_ = prog_args; + h$rtsArgs_ = rts_args; + } +} + +function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { + TRACE_ENV("getProgArgV") + var c = h$programArgs().length; + if(c === 0) { + argc_v.dv.setInt32(argc_off, 0, true); + } else { + argc_v.dv.setInt32(argc_off, c, true); + var argv = h$newByteArray(4*c); + argv.arr = []; + for(var i=0;i<h$programArgs().length;i++) { + argv.arr[4*i] = [ h$encodeUtf8(h$programArgs()[i]), 0 ]; + } + if(!argv_v.arr) { argv_v.arr = []; } + argv_v.arr[argv_off] = [argv, 0]; + } +} + +function h$setProgArgv(n, ptr_d, ptr_o) { + args = []; + for(var i=0;i<n;i++) { + var p = ptr_d.arr[ptr_o+4*i]; + var arg = h$decodeUtf8z(p[0], p[1]); + args.push(arg); + } + h$programArgs_ = args; +} + +function h$getpid() { +#ifndef GHCJS_BROWSER + if(h$isNode()) return process.id; +#endif + return 0; +} + +function h$cpuTimePrecision() { + return 1000; +} + +var h$fakeCpuTime = 1.0; + +function h$getCPUTime() { +#ifndef GHCJS_BROWSER +if(h$isNode()) { + var t = process.cpuUsage(); + var cput = t.user + t.system; + TRACE_ENV("getCPUTime: " + cput) + return cput; +} +#endif + // XXX this allows more testsuites to run + // but I don't really like returning a fake value here + TRACE_ENV("getCPUTime: returning fake value") + return ++h$fakeCpuTime; + return -1; +} + +function h$__hscore_environ() { + TRACE_ENV("hscore_environ") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + var env = [], i; + for(i in process.env) { + var envv = i + '=' + process.env[i]; + TRACE_ENV("hscore_environ: " + envv) + env.push(envv); + } + if(env.length === 0) return null; + var p = h$newByteArray(4*env.length+1); + p.arr = []; + for(i=0;i<env.length;i++) p.arr[4*i] = [h$encodeUtf8(env[i]), 0]; + p.arr[4*env.length] = [null, 0]; + RETURN_UBX_TUP2(p, 0); + } +#endif + RETURN_UBX_TUP2(null, 0); +} + +function h$__hsbase_unsetenv(name, name_off) { + return h$unsetenv(name, name_off); +} + +function h$getenv(name, name_off) { + TRACE_ENV("getenv") +#ifndef GHCJS_BROWSER + if(h$isNode()) { + var n = h$decodeUtf8z(name, name_off); + TRACE_ENV("getenv (node): " + n) + if(typeof process.env[n] !== 'undefined') { + TRACE_ENV("getenv (node): " + n + " -> " + process.env[n]) + RETURN_UBX_TUP2(h$encodeUtf8(process.env[n]), 0); + } + } +#endif + RETURN_UBX_TUP2(null, 0); +} + +function h$setenv(name, name_off, val, val_off, overwrite) { + var n = h$decodeUtf8z(name, name_off); + var v = h$decodeUtf8z(val, val_off); + TRACE_ENV("setenv: " + n + " -> " + v) + if(n.indexOf('=') !== -1) { + h$setErrno("EINVAL"); + return -1; + } +#ifndef GHCJS_BROWSER + if(h$isNode()) { + if(overwrite || typeof process.env[n] !== 'undefined') process.env[n] = v; + } +#endif + return 0; +} + +function h$unsetenv(name, name_off) { + var n = h$decodeUtf8z(name, name_off); + TRACE_ENV("unsetenv: " + n) + if(n.indexOf('=') !== -1) { + h$setErrno("EINVAL"); + return -1; + } +#ifndef GHCJS_BROWSER + if(h$isNode()) delete process.env[n]; +#endif + return 0; +} + +/* + Note: + SUSv2 specifies that the argument passed to putenv is made part + of the environment. Later changes to the value will be reflected + in the environment. + + this implementation makes a copy instead. + */ +function h$putenv(str, str_off) { +#ifndef GHCJS_BROWSER + var x = h$decodeUtf8z(str, str_off); + var i = x.indexOf('='); + TRACE_ENV("putenv: " + x) + if(i === -1) { // remove the value + TRACE_ENV("putenv unset: " + x) + if(h$isNode()) delete process.env[x]; + } else { // set the value + var name = x.substring(0, i) + var val = x.substring(i+1); + TRACE_ENV("putenv set: " + name + " -> " + val) + if(h$isNode()) process.env[name] = val; + } +#endif + return 0; +} + +function h$errorBelch() { + h$log("### errorBelch: do we need to handle a vararg function here?"); +} + +function h$errorBelch2(buf1, buf_offset1, buf2, buf_offset2) { + var pat = h$decodeUtf8z(buf1, buf_offset1); + h$errorMsg(h$append_prog_name(pat), h$decodeUtf8z(buf2, buf_offset2)); +} + +// append program name to the given string if possible +function h$append_prog_name(str) { + // basename that only works with Unix paths for now... + function basename(path) { + return path.split('/').reverse()[0]; + } + + // only works for node for now + if(h$isNode()) { + return basename(process.argv[1]) + ": " + str; + } + + return str; +} + +function h$debugBelch2(buf1, buf_offset1, buf2, buf_offset2) { + h$errorMsg(h$decodeUtf8z(buf1, buf_offset1), h$decodeUtf8z(buf2, buf_offset2)); +} + +function h$errorMsg(pat) { +#ifndef GHCJS_BROWSER + function stripTrailingNewline(xs) { + return xs.replace(/\r?\n$/, ""); + } +#endif + // poor man's vprintf + var str = pat; + for(var i=1;i<arguments.length;i++) { + str = str.replace(/%s/, arguments[i]); + } +#ifndef GHCJS_BROWSER + if(h$isGHCJSi()) { + // ignore message + } else if(h$isNode()) { + process.stderr.write(str); + } else if (h$isJsShell() && typeof printErr !== 'undefined') { + if(str.length) printErr(stripTrailingNewline(str)); + } else if (h$isJsShell() && typeof putstr !== 'undefined') { + putstr(str); + } else if (h$isJsCore()) { + if(str.length) { + if(h$base_stderrLeftover.val !== null) { + debug(h$base_stderrLeftover.val + stripTrailingNewline(str)); + h$base_stderrLeftover.val = null; + } else { + debug(stripTrailingNewline(str)); + } + } + } else { +#endif + if(typeof console !== 'undefined') { + console.log(str); + } +#ifndef GHCJS_BROWSER + } +#endif +} + +// this needs to be imported with foreign import ccall safe/interruptible +function h$performMajorGC() { + // save current thread state so we can enter the GC + var t = h$currentThread, err = null; + t.sp = h$sp; + h$currentThread = null; + + try { + h$gc(t); + } catch(e) { + err = e; + } + + // restore thread state + h$currentThread = t; + h$sp = t.sp; + h$stack = t.stack; + + if(err) throw err; +} + + +function h$baseZCSystemziCPUTimeZCgetrusage() { + return 0; +} + +function h$getrusage() { + return 0; +} + + +// fixme need to fix these struct locations + +function h$gettimeofday(tv_v,tv_o,tz_v,tz_o) { + var now = Date.now(); + tv_v.dv.setInt32(tv_o, (now / 1000)|0, true); + tv_v.dv.setInt32(tv_o + 4, ((now % 1000) * 1000)|0, true); + if(tv_v.len >= tv_o + 12) { + tv_v.dv.setInt32(tv_o + 8, ((now % 1000) * 1000)|0, true); + } + return 0; +} + +function h$traceEvent(ev_v,ev_o) { + h$errorMsg(h$decodeUtf8z(ev_v, ev_o)); +} + +function h$traceMarker(ev_v,ev_o) { + h$errorMsg(h$decodeUtf8z(ev_v, ev_o)); +} + +var h$__hscore_gettimeofday = h$gettimeofday; + +var h$myTimeZone = h$encodeUtf8("UTC"); +function h$localtime_r(timep_v, timep_o, result_v, result_o) { + var t = timep_v.i3[timep_o]; + var d = new Date(t * 1000); + result_v.dv.setInt32(result_o , d.getSeconds(), true); + result_v.dv.setInt32(result_o + 4 , d.getMinutes(), true); + result_v.dv.setInt32(result_o + 8 , d.getHours(), true); + result_v.dv.setInt32(result_o + 12, d.getDate(), true); + result_v.dv.setInt32(result_o + 16, d.getMonth(), true); + result_v.dv.setInt32(result_o + 20, d.getFullYear()-1900, true); + result_v.dv.setInt32(result_o + 24, d.getDay(), true); + result_v.dv.setInt32(result_o + 28, 0, true); // fixme yday 1-365 (366?) + result_v.dv.setInt32(result_o + 32, -1, true); // dst information unknown + result_v.dv.setInt32(result_o + 40, 0, true); // gmtoff? + if(!result_v.arr) result_v.arr = []; + result_v.arr[result_o + 40] = [h$myTimeZone, 0]; + result_v.arr[result_o + 48] = [h$myTimeZone, 0]; + RETURN_UBX_TUP2(result_v, result_o); +} +var h$__hscore_localtime_r = h$localtime_r; + +function h$checkForeignRefs(refs) { + function argSize(t) { + if(t === "ghc-prim:GHC.Prim.Word64#") return 2; + if(t === "ghc-prim:GHC.Prim.State#") return 0; + if(t === "ghc-prim:GHC.Prim.Void#") return 0; + if(t === "ghc-prim:GHC.Prim.Int#") return 1; + if(t === "ghc-prim:GHC.Prim.Int64#") return 2; + if(t === "ghc-prim:GHC.Prim.Weak#") return 1; + if(t === "ghc-prim:GHC.Prim.Addr#") return 2; + if(t === "ghc-prim:GHC.Prim.Word#") return 1; + if(t === "ghc-prim:GHC.Prim.Float#") return 1; + if(t === "ghc-prim:GHC.Prim.Double#") return 1; + if(t === "ghc-prim:GHC.Prim.ByteArray#") return 2; + if(t === "ghc-prim:GHC.Prim.ThreadId#") return 1; + console.warn("unknown argument type: " + t); + return 1; + } + function callStr(r) { + return r.pattern + '(' + r.arguments.join(', ') + ') -> ' + r.result + ' ' + r.span; + } + function checkRef(r) { + if(r.cconv === "ccall") { + var f = null; + try { + f = eval(r.pattern); + } catch(e) { } + if(!f) { + console.warn("referenced pattern does not exist: " + callStr(r)); + return; + } + if(typeof f !== 'function') { + console.warn("referenced pattern is not a function: " + callStr(r)); + return; + } + var s = 0, ba = 0; + for(var i = 0; i < r.arguments.length; i++) { + var a = r.arguments[i]; + s += argSize(a); + ba += a === "ghc-prim:GHC.Prim.ByteArray#" ? 1 : 0; + } + if(f.length != s) { + console.warn("number of arguments does not seem to match: " + callStr(r)); + } + if(ba !== 0 && f.length === (s - ba)) { + console.warn("number of arguments matches old ByteArray calling convention: " + callStr(r)); + } + } + // todo: check other calling conventions + } + for(var i=0;i<refs.length;i++) { + checkRef(refs[i]); + } +} + +var h$GHCConcSignalSignalHandlerStore_d = null; +var h$GHCConcSignalSignalHandlerStore_o = 0; + +function h$getOrSetGHCConcSignalSignalHandlerStore(d,o) { + if(d) { + h$GHCConcSignalSignalHandlerStore_d = d; + h$GHCConcSignalSignalHandlerStore_o = o; + } + RETURN_UBX_TUP2(h$GHCConcSignalSignalHandlerStore_d, h$GHCConcSignalSignalHandlerStore_o); +} diff --git a/rts/js/gc.js b/rts/js/gc.js new file mode 100644 index 0000000000..6c9934ed33 --- /dev/null +++ b/rts/js/gc.js @@ -0,0 +1,638 @@ +//#OPTIONS: CPP + +/* + Do garbage collection where the JavaScript GC doesn't suffice or needs some help: + + - run finalizers for weak references + - find unreferenced CAFs and reset them (unless h$retainCAFs is set) + - shorten stacks that are mostly empty + - reset unused parts of stacks to null + - reset registers to null + - reset return variables to null + - throw exceptions to threads that are blocked on an unreachable MVar/STM transaction + - drop unnecessary references for selector thunks + + The gc uses the .m field to store its mark in all the objects it marks. for heap objects, + the .m field is also used for other things, like stable names, the gc only changes + the two least significant bits for these. + + The gc starts with all threads as roots in addition to callbacks passed to JavaScript + that that are retained. If you have custom JavaScript data structures that contain + Haskell heap object references, you can use extensible retention to find these + references and add thm to the work queue. h$registerExtensibleRetensionRoot(f) calls + f(currentMark) at the start of every gc, h$registerExtensibleRetention(f) calls f(o, currentMark) + for every unknown object found on the Haskell heap. + + Extensible retention is a low-level mechanism and should typically only be used by + bindings that guarantee that the shape of the JS objects exactly matches what + the scanner expects. Care should be taken to make sure that the objects never + escape the reach of the scanner. + + Having correct reachability information is important, even if you choose to turn off + features like weak references and deallocating CAFs in production, since it helps + debugging by providing the profiler with accurate data and by properly raising + exceptions when threads become blocked indefinitely, usually indicating a bug or + memory leak. + + assumptions: + - all threads suspended, no active registers + - h$currentThread == null or at least unused: + 1. all reachable threads must be in h$threads or h$blocked + 2. no registers contain any usable value + notes: + - gc() may replace the stack of any thread, make sure to reload h$stack after gc() +*/ + +/* + fixme, todo: + - mark posted exceptions to thread +*/ + +#ifdef GHCJS_TRACE_GC +function h$traceGC() { h$log.apply(h$log, arguments); } +#define TRACE_GC(args...) h$traceGC(args) +#else +#define TRACE_GC(args...) +#endif + +// these macros use a local mark variable +#define IS_MARKED(obj) ((typeof obj.m === 'number' && (obj.m & 3) === mark) || (typeof obj.m === 'object' && ((obj.m.m & 3) === mark))) +#define IS_MARKED_M(obj) ((obj.m & 3) === mark) +#define MARK_OBJ(obj) if(typeof obj.m === 'number') obj.m = (obj.m&-4)|mark; else obj.m.m = (obj.m.m & -4)|mark; + +var h$gcMark = 2; // 2 or 3 (objects initialized with 0) + +#ifdef GHCJS_TRACE_GC +var h$gcTime = 0; +#endif + +#ifdef GHCJS_RETAIN_CAFS +var h$retainCAFs = true; +#else +var h$retainCAFs = false; +#endif + +// FIXME remove this? declared in rts.js now +// var h$CAFs = []; +// var h$CAFsReset = []; + +// +var h$extensibleRetentionRoots = []; +var h$extensibleRetentionCallbacks = []; + + +/* + after registering an extensible extension root f, + f(currentMark) is called at the start of each gc invocation and is + expected to return an array with Haskell heap objects + to be treated as extra roots. + */ +function h$registerExtensibleRetentionRoot(f) { + h$extensibleRetentionRoots.push(f); +} + +function h$unregisterExtensibleRetentionRoot(f) { + h$extensibleRetentionRoots = h$extensibleRetentionRoots.filter(function(g) { return f !== g; }); +} + +/* + after registering an extensible retention callback f, + f(o, currentMark) is called for every unknown object encountered on the + Haskell heap. f should return an array with found objects. If no objects + are found, f should return a boolean indicating whether the gc should skip + processing the objects with other extensible retention callbacks. + + The gc may encounter the same object multiple times during the same scan, + so a callback should attempt to quickly return if the object has been scanned + already. + + return value: + - array scan objects contained in array, do not call other extension callbacks + - true do not call other extension callbacks with this object + - false call other extension callbacks with this object + + Use -DGHCJS_TRACE_GC_UNKNOWN to find the JavaScript objects reachable + (through JSVal) on the Haskell heap for which none of the registered + extensible retention callbacks has returned true or an array. + */ +function h$registerExtensibleRetention(f) { + h$extensibleRetentionCallbacks.push(f); +} + +function h$unregisterExtensibleRetention(f) { + h$extensibleRetentionCallbacks = h$extensibleRetentionCallbacks.filter(function(g) { return f !== g; }); +} + +// check whether the object is marked by the latest gc +function h$isMarked(obj) { + return (typeof obj === 'object' || typeof obj === 'function') && + ((typeof obj.m === 'number' && (obj.m & 3) === h$gcMark) || (obj.m && typeof obj.m === 'object' && obj.m.m === h$gcMark)); +} + +// do a quick gc of a thread: +// - reset the stack (possibly shrinking storage for it) +// - reset all global data +// checks all known threads if t is null, but not h$currentThread +function h$gcQuick(t) { +#ifdef GHCJS_DISABLE_GC + return; +#endif + if(h$currentThread !== null) throw "h$gcQuick: GC can only run when no thread is running"; +#ifdef GHCJS_TRACE_GC + var start = Date.now(); +#endif + h$resetRegisters(); + h$resetResultVars(); + var i; + if(t !== null) { // reset specified threads + if(t instanceof h$Thread) { // only thread t + h$resetThread(t); + } else { // assume it's an array + for(var i=0;i<t.length;i++) h$resetThread(t[i]); + } + } else { // all threads, h$currentThread assumed unused + var nt, runnable = h$threads.iter(); + while((nt = runnable()) !== null) h$resetThread(nt); + var iter = h$blocked.iter(); + while((nt = iter.next()) !== null) h$resetThread(nt); + } +#ifdef GHCJS_TRACE_GC + var time = Date.now() - start; + h$gcTime += time; + TRACE_GC("time (quick): " + time + "ms") + TRACE_GC("time (total): " + h$gcTime + "ms") +#endif +} + +// run full marking for threads in h$blocked and h$threads, optionally t if t /= null +#ifdef GHCJS_TRACE_GC +var h$marked = 0; +#endif +function h$gc(t) { +#ifdef GHCJS_DISABLE_GC + return; +#endif +#ifndef GHCJS_BROWSER + // fixme, should enable again later when proper CAF management + // and retention of the standard handles in GHCJSi work + if(h$isGHCJSi()) return; +#endif + + if(h$currentThread !== null) throw "h$gc: GC can only be run when no thread is running"; +#ifdef GHCJS_TRACE_GC + h$marked = 0; + TRACE_GC("gc: " + (t!==null?h$threadString(t):"null")) + var start = Date.now(); +#endif + TRACE_GC("full gc of thread " + h$threadString(t)) + h$resetRegisters(); + h$resetResultVars(); + h$gcMark = 5-h$gcMark; + var i; + TRACE_GC("scanning extensible retention roots") + for(i=h$extensibleRetentionRoots.length-1;i>=0;i--) { + var a = h$extensibleRetentionRoots[i](h$gcMark); + if(a) h$follow(a, a.length-1); + } + TRACE_GC("scanning threads, runnable: " + h$threads.length() + " blocked: " + h$blocked.size() + " t: " + t) + + // mark al runnable threads and the running thread + if(t !== null) { + h$markThread(t); + h$resetThread(t); + } + var nt, runnable = h$threads.iter(); + while((nt = runnable()) !== null) { + h$markThread(nt); + h$resetThread(nt); + } + + // some blocked threads are always considered reachable, mark them + // - delayed threads + // - threads blocked on async FFI + var iter = h$blocked.iter(); + while((nt = iter.next()) !== null) { + if(nt.delayed || + (nt.blockedOn instanceof h$MVar && nt.stack && nt.stack[nt.sp] === h$unboxFFIResult)) { + h$markThread(nt); + } + h$resetThread(nt); + } + TRACE_GC("scanning permanent retention roots") + iter = h$extraRoots.iter(); + while((nt = iter.next()) !== null) h$follow(nt.root); + + TRACE_GC("scanning stable pointers") + for(i=0;i<h$stablePtrData.length;i++) { + if(h$stablePtrData[i]) h$follow(h$stablePtrData[i]); + } + + // clean up threads waiting on unreachable synchronization primitives + h$resolveDeadlocks(); + + // clean up unreachable weak refs + var toFinalize = h$markRetained(); + h$finalizeWeaks(toFinalize); + + h$finalizeCAFs(); // restore all unreachable CAFs to unevaluated state + + var now = Date.now(); + h$lastGc = now; +#ifdef GHCJS_TRACE_GC + var time = now - start; + h$gcTime += time; + TRACE_GC("time: " + time + "ms") + TRACE_GC("time (total): " + h$gcTime + "ms") + TRACE_GC("marked objects: " + h$marked) +#endif + h$debugAlloc_verifyReachability(h$gcMark); +} + +function h$markWeaks() { + var i, w, marked, mark = h$gcMark; + do { + marked = false; + for (i = 0; i < h$weakPointerList.length; ++i) { + w = h$weakPointerList[i]; + if (IS_MARKED_M(w.keym)) { + if (w.val !== null && !IS_MARKED(w.val)) { + h$follow(w.val); + marked = true; + } + if (w.finalizer !== null && !IS_MARKED(w.finalizer)) { + h$follow(w.finalizer); + marked = true; + } + } + } + } while(marked); +} + + +function h$markRetained() { + var iter, marked, w, i, mark = h$gcMark; + var newList = []; + var toFinalize = []; + + /* + 2. Scan the Weak Pointer List. If a weak pointer object has a key that is + marked (i.e. reachable), then mark all heap reachable from its value + or its finalizer, and move the weak pointer object to a new list + */ + do { + TRACE_GC("mark retained iteration 1/2") + marked = false; + + for (i = 0; i < h$weakPointerList.length; ++i) { + w = h$weakPointerList[i]; + if (w === null) { + // don't handle items deleted in earlier iteration + continue; + } + if (IS_MARKED_M(w.keym)) { + if (w.val !== null && !IS_MARKED(w.val)) { + h$follow(w.val); + } + + if (w.finalizer !== null && !IS_MARKED(w.finalizer)) { + h$follow(w.finalizer); + } + + newList.push(w); + // instead of removing the item from the h$weakpointerList + // we set it to null if we push it to newList. + h$weakPointerList[i] = null; + + marked = true; + } + } + + /* + 3. Repeat from step (2), until a complete scan of Weak Pointer List finds + no weak pointer object with a marked keym. + */ + } while(marked); + + + /* + 4. Scan the Weak Pointer List again. If the weak pointer object is reachable + then tombstone it. If the weak pointer object has a finalizer then move + it to the Finalization Pending List, and mark all the heap reachable + from the finalizer. If the finalizer refers to the key (and/or value), + this step will "resurrect" it. + */ + + for (i = 0; i < h$weakPointerList.length; ++i) { + w = h$weakPointerList[i]; + if (w === null) { + // don't handle items deleted in step 2 + continue; + } + + TRACE_GC("mark retained iteration 2/2") + if(w.val !== null) { + w.val = null; + } + + if(w.finalizer !== null) { + if(!IS_MARKED(w.finalizer)) { + TRACE_GC("following finalizer") + h$follow(w.finalizer); + } + toFinalize.push(w); + } + } + + /* + 5. The list accumulated in step (3) becomes the new Weak Pointer List. + Mark any unreachable weak pointer objects on this list as reachable. + */ + h$weakPointerList = newList; + + // marking the weak pointer objects as reachable is not necessary + + return toFinalize; +} + +function h$markThread(t) { + var mark = h$gcMark; + TRACE_GC("marking thread: " + h$threadString(t)) + if(IS_MARKED(t)) return; + h$follow(t); +} + +#define ADDW(x) work[w++] = x; +#define ADDW2(x,y) { work[w++] = x; work[w++] = y; } +#define ADDW3(x,y,z) { work[w++] = x; work[w++] = y; work[w++] = z; } +#define ADDW4(x,y,z,v) { work[w++] = x; work[w++] = y; work[w++] = z; work[w++] = v; } + +// big object, not handled by 0..7 cases +// keep out of h$follow to prevent deopt +function h$followObjGen(c, work, w) { + ADDW(c.d1); + var d = c.d2; + for(var x in d) { +// if(d.hasOwnProperty(x)) { + ADDW(d[x]); +// } + } + return w; +} + +// follow all references in the object obj and mark them with the current mark +// if sp is a number, obj is assumed to be an array for which indices [0..sp] need +// to be followed (used for thread stacks) +function h$follow(obj, sp) { + var i, ii, iter, c, work, w; +#ifdef GHCJS_TRACE_GC + var start = Date.now(); +#endif + TRACE_GC("following") + var work, mark = h$gcMark; + if(typeof sp === 'number') { + work = obj.slice(0, sp+1); + w = sp + 1; + } else { + work = [obj]; + w = 1; + } + while(w > 0) { + TRACE_GC("work length: " + work.length + " w: " + w) + c = work[--w]; + TRACE_GC("[" + work.length + "] mark step: " + typeof c) +#ifdef GHCJS_TRACE_GC + if(typeof c === 'object') { + if(c !== null) { + TRACE_GC("object: " + c.toString()) + TRACE_GC("object props: " + h$collectProps(c)) + TRACE_GC("object mark: " + c.m + " (" + typeof(c.m) + ") (current: " + mark + ")") + } else { + TRACE_GC("object: " + c) + } + } +#endif + if(c !== null && c !== undefined && typeof c === 'object' && ((typeof c.m === 'number' && (c.m&3) !== mark) || (typeof c.m === 'object' && c.m !== null && typeof c.m.m === 'number' && (c.m.m&3) !== mark))) { + var doMark = false; + var cf = c.f; + TRACE_GC("first accepted") + if(typeof cf === 'function' && (typeof c.m === 'number' || typeof c.m === 'object')) { + TRACE_GC("marking heap object: " + c.f.n + " size: " + c.f.size) + // only change the two least significant bits for heap objects + MARK_OBJ(c); + // dynamic references + var d = c.d2; + switch(cf.size) { + case 0: break; + case 1: ADDW(c.d1); break; + case 2: ADDW2(c.d1, d); break; + case 3: var d3=c.d2; ADDW3(c.d1, d3.d1, d3.d2); break; + case 4: var d4=c.d2; ADDW4(c.d1, d4.d1, d4.d2, d4.d3); break; + case 5: var d5=c.d2; ADDW4(c.d1, d5.d1, d5.d2, d5.d3); ADDW(d5.d4); break; + case 6: var d6=c.d2; ADDW4(c.d1, d6.d1, d6.d2, d6.d3); ADDW2(d6.d4, d6.d5); break; + case 7: var d7=c.d2; ADDW4(c.d1, d7.d1, d7.d2, d7.d3); ADDW3(d7.d4, d7.d5, d7.d6); break; + case 8: var d8=c.d2; ADDW4(c.d1, d8.d1, d8.d2, d8.d3); ADDW4(d8.d4, d8.d5, d8.d6, d8.d7); break; + case 9: var d9=c.d2; ADDW4(c.d1, d9.d1, d9.d2, d9.d3); ADDW4(d9.d4, d9.d5, d9.d6, d9.d7); ADDW(d9.d8); break; + case 10: var d10=c.d2; ADDW4(c.d1, d10.d1, d10.d2, d10.d3); ADDW4(d10.d4, d10.d5, d10.d6, d10.d7); ADDW2(d10.d8, d10.d9); break; + case 11: var d11=c.d2; ADDW4(c.d1, d11.d1, d11.d2, d11.d3); ADDW4(d11.d4, d11.d5, d11.d6, d11.d7); ADDW3(d11.d8, d11.d9, d11.d10); break; + case 12: var d12=c.d2; ADDW4(c.d1, d12.d1, d12.d2, d12.d3); ADDW4(d12.d4, d12.d5, d12.d6, d12.d7); ADDW4(d12.d8, d12.d9, d12.d10, d12.d11); break; + default: w = h$followObjGen(c,work,w); + } + // static references + var s = cf.s; + if(s !== null) { + TRACE_GC("adding static marks") + for(var i=0;i<s.length;i++) ADDW(s[i]); + } + } else if(typeof c.len === 'number' && c.buf instanceof ArrayBuffer) { + TRACE_GC("marking ByteArray") + MARK_OBJ(c); + } else if(c instanceof h$Weak) { + MARK_OBJ(c); + } else if(c instanceof h$MVar) { + TRACE_GC("marking MVar") + MARK_OBJ(c); + iter = c.writers.iter(); + while((ii = iter()) !== null) { + ADDW(ii[1]); // value + ADDW(ii[0]); // thread + } + iter = c.readers.iter(); + while((ii = iter()) !== null) { + ADDW(ii); + } + if(c.waiters) { + for(i=c.waiters.length-1;i>=0;i--) { + ADDW(c.waiters[i]); + } + } + if(c.val !== null && !IS_MARKED(c.val)) ADDW(c.val); + } else if(c instanceof h$MutVar) { + TRACE_GC("marking MutVar") + MARK_OBJ(c); + ADDW(c.val); + } else if(c instanceof h$TVar) { + TRACE_GC("marking TVar") + MARK_OBJ(c); + ADDW(c.val); + iter = c.blocked.iter(); + while((ii = iter.next()) !== null) { + ADDW(ii); + } + if(c.invariants) { + iter = c.invariants.iter(); + while((ii = iter.next()) !== null) { + ADDW(ii); + } + } + } else if(c instanceof h$Thread) { + TRACE_GC("marking Thread") + MARK_OBJ(c); + if(c.stack) { + for(i=c.sp;i>=0;i--) { + ADDW(c.stack[i]); + } + } + for(i=0;i<c.excep.length;i++) { + ADDW(c.excep[i]); + } + } else if(c instanceof h$Transaction) { + // - the accessed TVar values don't need to be marked + // - parents are also on the stack, so they should've been marked already + TRACE_GC("marking STM transaction") + MARK_OBJ(c); + for(i=c.invariants.length-1;i>=0;i--) { + ADDW(c.invariants[i].action); + } + ADDW(c.action); + iter = c.tvars.iter(); + while((ii = iter.nextVal()) !== null) { + ADDW(ii.val); + } + } else if(c instanceof Array && c.__ghcjsArray) { + // only for Haskell arrays with lifted values + MARK_OBJ(c); + TRACE_GC("marking array") + for(i=0;i<c.length;i++) { + var x = c[i]; + if(typeof x === 'object' && x !== null && !IS_MARKED(x)) { + ADDW(x); + } + } + } else if(typeof c === 'object') { + TRACE_GC("extensible retention marking") +#ifdef GHCJS_TRACE_GC_UNKNOWN + var extensibleMatched = false; +#endif + for(i=h$extensibleRetentionCallbacks.length-1;i>=0;i--) { + var x = h$extensibleRetentionCallbacks[i](c, mark); + if(x === false) continue; +#ifdef GHCJS_TRACE_GC_UNKNOWN + extensibleMatched = true; +#endif + if(x !== true) { + for(j=x.length-1;j>=0;j--) { + ADDW(x[j]); + } + } + break; + } +#ifdef GHCJS_TRACE_GC_UNKNOWN + if(!extensibleMatched) { + TRACE_GC("unknown object: " + h$collectProps(c)) + } +#endif + } // otherwise: not an object, no followable values + } + } + TRACE_GC("h$follow: " + (Date.now()-start) + "ms") +} + +// resetThread clears the stack above the stack pointer +// and shortens the stack array if there is too much +// unused space +function h$resetThread(t) { +#ifdef GHCJS_TRACE_GC + var start = Date.now(); +#endif + var stack = t.stack; + if(!stack) return; + var sp = t.sp; + if(stack.length - sp > sp && stack.length > 100) { + t.stack = t.stack.slice(0,sp+1); + } else { + for(var i=sp+1;i<stack.length;i++) { + stack[i] = null; + } + } + TRACE_GC("h$resetThread: " + (Date.now()-start) + "ms") +} + +/* + Post exceptions to all threads that are waiting on an unreachable synchronization + object and haven't been marked reachable themselves. + + All woken up threads are marked. + */ +function h$resolveDeadlocks() { + TRACE_GC("resolving deadlocks") + var kill, t, iter, bo, mark = h$gcMark; + do { + h$markWeaks(); + // deal with unreachable blocked threads: kill an unreachable thread and restart the process + kill = null; + iter = h$blocked.iter(); + while((t = iter.next()) !== null) { + // we're done if the thread is already reachable + if(IS_MARKED(t)) continue; + + // check what we're blocked on + bo = t.blockedOn; + if(bo instanceof h$MVar) { + // blocked on MVar + if(bo.m === mark) throw "assertion failed: thread should have been marked"; + // MVar unreachable + kill = h$baseZCGHCziJSziPrimziInternalziblockedIndefinitelyOnMVar; + break; + } else if(t.blockedOn instanceof h$TVarsWaiting) { + // blocked in STM transaction + kill = h$baseZCGHCziJSziPrimziInternalziblockedIndefinitelyOnSTM; + break; + } else { + // blocked on something else, we can't do anything + } + } + if(kill) { + h$killThread(t, kill); + h$markThread(t); + } + } while(kill); +} + +// register a CAF (after initialising the heap object) +function h$addCAF(o) { + h$CAFs.push(o); + h$CAFsReset.push([o.f, o.d1, o.d2]); +} + +// reset unreferenced CAFs to their initial value +function h$finalizeCAFs() { + if(h$retainCAFs) return; +#ifdef GHCJS_TRACE_GC + var start = Date.now(); +#endif + var mark = h$gcMark; + for(var i=0;i<h$CAFs.length;i++) { + var c = h$CAFs[i]; + if(c.m & 3 !== mark) { + var cr = h$CAFsReset[i]; + if(c.f !== cr[0]) { // has been updated, reset it + TRACE_GC("resetting CAF: " + cr.n) + c.f = cr[0]; + c.d1 = cr[1]; + c.d2 = cr[2]; + } + } + } + TRACE_GC("h$finalizeCAFs: " + (Date.now()-start) + "ms") +} + diff --git a/rts/js/globals.js b/rts/js/globals.js new file mode 100644 index 0000000000..4ae7ae8ee9 --- /dev/null +++ b/rts/js/globals.js @@ -0,0 +1,24 @@ +//#OPTIONS: CPP + +// Globals used by GHC + +#define GVAR(name,nvar) \ + var h$global_ ## nvar ## _a = null;\ + var h$global_ ## nvar ## _o = null;\ + function name(a,o) {\ + if (!h$global_ ## nvar ## _a) {\ + h$global_ ## nvar ## _a = a;\ + h$global_ ## nvar ## _o = o;\ + }\ + RETURN_UBX_TUP2(h$global_ ## nvar ##_a, h$global_ ## nvar ##_o);\ + } + +GVAR(h$getOrSetLibHSghcGlobalHasPprDebug, has_ppr_debug) +GVAR(h$getOrSetLibHSghcGlobalHasNoDebugOutput, has_no_debug_output) +GVAR(h$getOrSetLibHSghcGlobalHasNoStateHack, has_no_state_hack) +GVAR(h$getOrSetLibHSghcFastStringTable, faststring_table) + +var h$ghc_unique_inc = h$newByteArray(4); +h$ghc_unique_inc.i3[0] = 1; +var h$ghc_unique_counter = h$newByteArray(4); +h$ghc_unique_counter.i3[0] = 0; diff --git a/rts/js/goog.js b/rts/js/goog.js new file mode 100644 index 0000000000..09389149c5 --- /dev/null +++ b/rts/js/goog.js @@ -0,0 +1,55 @@ +/* + set up the google closure library. this is a rather hacky setup + to make it work with our shims without requiring compilation + or pulling in the google closure library module loader + */ +var goog = {}; +goog.global = h$getGlobal(this); +goog.provide = function() { }; +goog.require = function() { }; +goog.isDef = function(val) { return val !== undefined; }; +goog.inherits = function(childCtor, parentCtor) { + /** @constructor */ + function tempCtor() {}; + tempCtor.prototype = parentCtor.prototype; + childCtor.superClass_ = parentCtor.prototype; + childCtor.prototype = new tempCtor(); + /** @override */ + childCtor.prototype.constructor = childCtor; + + /** + * Calls superclass constructor/method. + * + * This function is only available if you use goog.inherits to + * express inheritance relationships between classes. + * + * NOTE: This is a replacement for goog.base and for superClass_ + * property defined in childCtor. + * + * @param {!Object} me Should always be "this". + * @param {string} methodName The method name to call. Calling + * superclass constructor can be done with the special string + * 'constructor'. + * @param {...*} var_args The arguments to pass to superclass + * method/constructor. + * @return {*} The return value of the superclass method/constructor. + */ + childCtor.base = function(me, methodName, var_args) { + // Copying using loop to avoid deop due to passing arguments object to + // function. This is faster in many JS engines as of late 2014. + var args = new Array(arguments.length - 2); + for (var i = 2; i < arguments.length; i++) { + args[i - 2] = arguments[i]; + } + return parentCtor.prototype[methodName].apply(me, args); + }; +}; + +goog.isString = function(v) { + return typeof v === 'string'; +} + +goog.math = {}; +goog.crypt = {}; + + diff --git a/rts/js/hscore.js b/rts/js/hscore.js new file mode 100644 index 0000000000..95751477e4 --- /dev/null +++ b/rts/js/hscore.js @@ -0,0 +1,104 @@ +//#OPTIONS: CPP + +#ifdef GHCJS_TRACE_HSCORE +function h$logHscore() { h$log.apply(h$log,arguments); } +#define TRACE_HSCORE(args...) h$logHscore(args) +#else +#define TRACE_HSCORE(args...) +#endif + +function h$__hscore_sizeof_termios() { + TRACE_HSCORE("hscore_sizeof_termios") + return 4; +} + +function h$tcgetattr(x, y, z) { + TRACE_HSCORE("tcgetattr: " + x + " " + y + " " + z) + return 0; +} + +function h$__hscore_get_saved_termios(r) { + TRACE_HSCORE("hscore_get_saved_termios: " + r) + RETURN_UBX_TUP2(null, 0); +} + +function h$__hscore_set_saved_termios(a, b, c) { + TRACE_HSCORE("hscore_set_saved_termios: " + a + " " + b + " " + c) + RETURN_UBX_TUP2(null, 0); +} + +function h$__hscore_sizeof_sigset_t() { + TRACE_HSCORE("hscore_sizeof_sigset_t") + return 4; +} + +function h$sigemptyset(a, b) { + TRACE_HSCORE("sigemptyset: " + a + " " + b) + RETURN_UBX_TUP2(null, 0); +} + +function h$__hscore_sigttou() { + TRACE_HSCORE("hscore_sigttou") + return 0; +} + +function h$sigaddset(a, b, c) { + TRACE_HSCORE("sigaddset: " + a + " " + b + " " + c) + return 0; +} + +function h$__hscore_sig_block() { + TRACE_HSCORE("hscore_sig_block") + return 0; +} + +function h$sigprocmask(a,b,c,d,e) { + TRACE_HSCORE("sigprocmask: " + a + " " + b + " " + c + " " + d + " " + e) + RETURN_UBX_TUP2(0, 0); +} + +function h$__hscore_lflag(a,b) { + TRACE_HSCORE("hscore_lflag: " + a + " " + b) + return 0; +} + +function h$__hscore_icanon() { + TRACE_HSCORE("hscore_icanon") + return 0; +} + +function h$__hscore_poke_lflag(a, b, c) { + TRACE_HSCORE("hscore_poke_lflag: " + a + " " + b + " " + c) + return 0; +} + +function h$__hscore_ptr_c_cc(a, b) { + TRACE_HSCORE("hscore_ptr_c_cc: " + a + " " + b) + RETURN_UBX_TUP2(h$newByteArray(8), 0); // null; +} + +function h$__hscore_vmin() { + TRACE_HSCORE("hscore_vmin") + RETURN_UBX_TUP2(h$newByteArray(8), 0); // null; +} + +function h$__hscore_vtime() { + TRACE_HSCORE("hscore_vtime") + return 0; +} + +function h$__hscore_tcsanow() { + TRACE_HSCORE("hscore_tcsanow") + return 0; +} + +function h$tcsetattr(a,b,c,d) { + TRACE_HSCORE("tcsetattr: " + a + " " + b + " " + c + " " + d) + return 0; +} + +function h$__hscore_sig_setmask() { + TRACE_HSCORE("hscore_sig_setmask") + return 0; +} + diff --git a/rts/js/md5.js b/rts/js/md5.js new file mode 100644 index 0000000000..402678925e --- /dev/null +++ b/rts/js/md5.js @@ -0,0 +1,523 @@ + +function h$MD5Init(ctx, ctx_off) { + if(!ctx.arr) { ctx.arr = []; } + ctx.arr[ctx_off] = new goog.crypt.Md5(); +} +var h$__hsbase_MD5Init = h$MD5Init; + +function h$MD5Update(ctx, ctx_off, data, data_off, len) { + var arr = new Uint8Array(data.buf, data_off); + ctx.arr[ctx_off].update(arr, len); +} +var h$__hsbase_MD5Update = h$MD5Update; + +function h$MD5Final(dst, dst_off, ctx, ctx_off) { + var digest = ctx.arr[ctx_off].digest(); + for(var i=0;i<16;i++) { + dst.u8[dst_off+i] = digest[i]; + } +} +var h$__hsbase_MD5Final = h$MD5Final; + + +/************************************************** + * Temporarilyl vendored Closure Library + **************************************************/ + + +// Copyright 2011 The Closure Library Authors. All Rights Reserved. +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS-IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +// See the License for the specific language governing permissions and +// limitations under the License. + +/** + * @fileoverview MD5 cryptographic hash. + * Implementation of http://tools.ietf.org/html/rfc1321 with common + * optimizations and tweaks (see http://en.wikipedia.org/wiki/MD5). + * + * Usage: + * var md5 = new goog.crypt.Md5(); + * md5.update(bytes); + * var hash = md5.digest(); + * + * Performance: + * Chrome 23 ~680 Mbit/s + * Chrome 13 (in a VM) ~250 Mbit/s + * Firefox 6.0 (in a VM) ~100 Mbit/s + * IE9 (in a VM) ~27 Mbit/s + * Firefox 3.6 ~15 Mbit/s + * IE8 (in a VM) ~13 Mbit/s + * + */ + +/** + * MD5 cryptographic hash constructor. + * @constructor + * @extends {goog.crypt.Hash} + * @final + * @struct + */ +goog.crypt.Md5 = function() { + + this.blockSize = 512 / 8; + + /** + * Holds the current values of accumulated A-D variables (MD buffer). + * @type {!Array<number>} + * @private + */ + this.chain_ = new Array(4); + + /** + * A buffer holding the data until the whole block can be processed. + * @type {!Array<number>} + * @private + */ + this.block_ = new Array(this.blockSize); + + /** + * The length of yet-unprocessed data as collected in the block. + * @type {number} + * @private + */ + this.blockLength_ = 0; + + /** + * The total length of the message so far. + * @type {number} + * @private + */ + this.totalLength_ = 0; + + this.reset(); +}; + + +/** + * Integer rotation constants used by the abbreviated implementation. + * They are hardcoded in the unrolled implementation, so it is left + * here commented out. + * @type {Array<number>} + * @private + * +goog.crypt.Md5.S_ = [ + 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22, + 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, + 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, + 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21 +]; + */ + +/** + * Sine function constants used by the abbreviated implementation. + * They are hardcoded in the unrolled implementation, so it is left + * here commented out. + * @type {Array<number>} + * @private + * +goog.crypt.Md5.T_ = [ + 0xd76aa478, 0xe8c7b756, 0x242070db, 0xc1bdceee, + 0xf57c0faf, 0x4787c62a, 0xa8304613, 0xfd469501, + 0x698098d8, 0x8b44f7af, 0xffff5bb1, 0x895cd7be, + 0x6b901122, 0xfd987193, 0xa679438e, 0x49b40821, + 0xf61e2562, 0xc040b340, 0x265e5a51, 0xe9b6c7aa, + 0xd62f105d, 0x02441453, 0xd8a1e681, 0xe7d3fbc8, + 0x21e1cde6, 0xc33707d6, 0xf4d50d87, 0x455a14ed, + 0xa9e3e905, 0xfcefa3f8, 0x676f02d9, 0x8d2a4c8a, + 0xfffa3942, 0x8771f681, 0x6d9d6122, 0xfde5380c, + 0xa4beea44, 0x4bdecfa9, 0xf6bb4b60, 0xbebfbc70, + 0x289b7ec6, 0xeaa127fa, 0xd4ef3085, 0x04881d05, + 0xd9d4d039, 0xe6db99e5, 0x1fa27cf8, 0xc4ac5665, + 0xf4292244, 0x432aff97, 0xab9423a7, 0xfc93a039, + 0x655b59c3, 0x8f0ccc92, 0xffeff47d, 0x85845dd1, + 0x6fa87e4f, 0xfe2ce6e0, 0xa3014314, 0x4e0811a1, + 0xf7537e82, 0xbd3af235, 0x2ad7d2bb, 0xeb86d391 +]; + */ + + +/** @override */ +goog.crypt.Md5.prototype.reset = function() { + this.chain_[0] = 0x67452301; + this.chain_[1] = 0xefcdab89; + this.chain_[2] = 0x98badcfe; + this.chain_[3] = 0x10325476; + + this.blockLength_ = 0; + this.totalLength_ = 0; +}; + + +/** + * Internal compress helper function. It takes a block of data (64 bytes) + * and updates the accumulator. + * @param {Array<number>|Uint8Array|string} buf The block to compress. + * @param {number=} opt_offset Offset of the block in the buffer. + * @private + */ +goog.crypt.Md5.prototype.compress_ = function(buf, opt_offset) { + if (!opt_offset) { + opt_offset = 0; + } + + // We allocate the array every time, but it's cheap in practice. + var X = new Array(16); + + // Get 16 little endian words. It is not worth unrolling this for Chrome 11. + if (goog.isString(buf)) { + for (var i = 0; i < 16; ++i) { + X[i] = (buf.charCodeAt(opt_offset++)) | + (buf.charCodeAt(opt_offset++) << 8) | + (buf.charCodeAt(opt_offset++) << 16) | + (buf.charCodeAt(opt_offset++) << 24); + } + } else { + for (var i = 0; i < 16; ++i) { + X[i] = (buf[opt_offset++]) | + (buf[opt_offset++] << 8) | + (buf[opt_offset++] << 16) | + (buf[opt_offset++] << 24); + } + } + + var A = this.chain_[0]; + var B = this.chain_[1]; + var C = this.chain_[2]; + var D = this.chain_[3]; + var sum = 0; + + /* + * This is an abbreviated implementation, it is left here commented out for + * reference purposes. See below for an unrolled version in use. + * + var f, n, tmp; + for (var i = 0; i < 64; ++i) { + + if (i < 16) { + f = (D ^ (B & (C ^ D))); + n = i; + } else if (i < 32) { + f = (C ^ (D & (B ^ C))); + n = (5 * i + 1) % 16; + } else if (i < 48) { + f = (B ^ C ^ D); + n = (3 * i + 5) % 16; + } else { + f = (C ^ (B | (~D))); + n = (7 * i) % 16; + } + + tmp = D; + D = C; + C = B; + sum = (A + f + goog.crypt.Md5.T_[i] + X[n]) & 0xffffffff; + B += ((sum << goog.crypt.Md5.S_[i]) & 0xffffffff) | + (sum >>> (32 - goog.crypt.Md5.S_[i])); + A = tmp; + } + */ + + /* + * This is an unrolled MD5 implementation, which gives ~30% speedup compared + * to the abbreviated implementation above, as measured on Chrome 11. It is + * important to keep 32-bit croppings to minimum and inline the integer + * rotation. + */ + sum = (A + (D ^ (B & (C ^ D))) + X[0] + 0xd76aa478) & 0xffffffff; + A = B + (((sum << 7) & 0xffffffff) | (sum >>> 25)); + sum = (D + (C ^ (A & (B ^ C))) + X[1] + 0xe8c7b756) & 0xffffffff; + D = A + (((sum << 12) & 0xffffffff) | (sum >>> 20)); + sum = (C + (B ^ (D & (A ^ B))) + X[2] + 0x242070db) & 0xffffffff; + C = D + (((sum << 17) & 0xffffffff) | (sum >>> 15)); + sum = (B + (A ^ (C & (D ^ A))) + X[3] + 0xc1bdceee) & 0xffffffff; + B = C + (((sum << 22) & 0xffffffff) | (sum >>> 10)); + sum = (A + (D ^ (B & (C ^ D))) + X[4] + 0xf57c0faf) & 0xffffffff; + A = B + (((sum << 7) & 0xffffffff) | (sum >>> 25)); + sum = (D + (C ^ (A & (B ^ C))) + X[5] + 0x4787c62a) & 0xffffffff; + D = A + (((sum << 12) & 0xffffffff) | (sum >>> 20)); + sum = (C + (B ^ (D & (A ^ B))) + X[6] + 0xa8304613) & 0xffffffff; + C = D + (((sum << 17) & 0xffffffff) | (sum >>> 15)); + sum = (B + (A ^ (C & (D ^ A))) + X[7] + 0xfd469501) & 0xffffffff; + B = C + (((sum << 22) & 0xffffffff) | (sum >>> 10)); + sum = (A + (D ^ (B & (C ^ D))) + X[8] + 0x698098d8) & 0xffffffff; + A = B + (((sum << 7) & 0xffffffff) | (sum >>> 25)); + sum = (D + (C ^ (A & (B ^ C))) + X[9] + 0x8b44f7af) & 0xffffffff; + D = A + (((sum << 12) & 0xffffffff) | (sum >>> 20)); + sum = (C + (B ^ (D & (A ^ B))) + X[10] + 0xffff5bb1) & 0xffffffff; + C = D + (((sum << 17) & 0xffffffff) | (sum >>> 15)); + sum = (B + (A ^ (C & (D ^ A))) + X[11] + 0x895cd7be) & 0xffffffff; + B = C + (((sum << 22) & 0xffffffff) | (sum >>> 10)); + sum = (A + (D ^ (B & (C ^ D))) + X[12] + 0x6b901122) & 0xffffffff; + A = B + (((sum << 7) & 0xffffffff) | (sum >>> 25)); + sum = (D + (C ^ (A & (B ^ C))) + X[13] + 0xfd987193) & 0xffffffff; + D = A + (((sum << 12) & 0xffffffff) | (sum >>> 20)); + sum = (C + (B ^ (D & (A ^ B))) + X[14] + 0xa679438e) & 0xffffffff; + C = D + (((sum << 17) & 0xffffffff) | (sum >>> 15)); + sum = (B + (A ^ (C & (D ^ A))) + X[15] + 0x49b40821) & 0xffffffff; + B = C + (((sum << 22) & 0xffffffff) | (sum >>> 10)); + sum = (A + (C ^ (D & (B ^ C))) + X[1] + 0xf61e2562) & 0xffffffff; + A = B + (((sum << 5) & 0xffffffff) | (sum >>> 27)); + sum = (D + (B ^ (C & (A ^ B))) + X[6] + 0xc040b340) & 0xffffffff; + D = A + (((sum << 9) & 0xffffffff) | (sum >>> 23)); + sum = (C + (A ^ (B & (D ^ A))) + X[11] + 0x265e5a51) & 0xffffffff; + C = D + (((sum << 14) & 0xffffffff) | (sum >>> 18)); + sum = (B + (D ^ (A & (C ^ D))) + X[0] + 0xe9b6c7aa) & 0xffffffff; + B = C + (((sum << 20) & 0xffffffff) | (sum >>> 12)); + sum = (A + (C ^ (D & (B ^ C))) + X[5] + 0xd62f105d) & 0xffffffff; + A = B + (((sum << 5) & 0xffffffff) | (sum >>> 27)); + sum = (D + (B ^ (C & (A ^ B))) + X[10] + 0x02441453) & 0xffffffff; + D = A + (((sum << 9) & 0xffffffff) | (sum >>> 23)); + sum = (C + (A ^ (B & (D ^ A))) + X[15] + 0xd8a1e681) & 0xffffffff; + C = D + (((sum << 14) & 0xffffffff) | (sum >>> 18)); + sum = (B + (D ^ (A & (C ^ D))) + X[4] + 0xe7d3fbc8) & 0xffffffff; + B = C + (((sum << 20) & 0xffffffff) | (sum >>> 12)); + sum = (A + (C ^ (D & (B ^ C))) + X[9] + 0x21e1cde6) & 0xffffffff; + A = B + (((sum << 5) & 0xffffffff) | (sum >>> 27)); + sum = (D + (B ^ (C & (A ^ B))) + X[14] + 0xc33707d6) & 0xffffffff; + D = A + (((sum << 9) & 0xffffffff) | (sum >>> 23)); + sum = (C + (A ^ (B & (D ^ A))) + X[3] + 0xf4d50d87) & 0xffffffff; + C = D + (((sum << 14) & 0xffffffff) | (sum >>> 18)); + sum = (B + (D ^ (A & (C ^ D))) + X[8] + 0x455a14ed) & 0xffffffff; + B = C + (((sum << 20) & 0xffffffff) | (sum >>> 12)); + sum = (A + (C ^ (D & (B ^ C))) + X[13] + 0xa9e3e905) & 0xffffffff; + A = B + (((sum << 5) & 0xffffffff) | (sum >>> 27)); + sum = (D + (B ^ (C & (A ^ B))) + X[2] + 0xfcefa3f8) & 0xffffffff; + D = A + (((sum << 9) & 0xffffffff) | (sum >>> 23)); + sum = (C + (A ^ (B & (D ^ A))) + X[7] + 0x676f02d9) & 0xffffffff; + C = D + (((sum << 14) & 0xffffffff) | (sum >>> 18)); + sum = (B + (D ^ (A & (C ^ D))) + X[12] + 0x8d2a4c8a) & 0xffffffff; + B = C + (((sum << 20) & 0xffffffff) | (sum >>> 12)); + sum = (A + (B ^ C ^ D) + X[5] + 0xfffa3942) & 0xffffffff; + A = B + (((sum << 4) & 0xffffffff) | (sum >>> 28)); + sum = (D + (A ^ B ^ C) + X[8] + 0x8771f681) & 0xffffffff; + D = A + (((sum << 11) & 0xffffffff) | (sum >>> 21)); + sum = (C + (D ^ A ^ B) + X[11] + 0x6d9d6122) & 0xffffffff; + C = D + (((sum << 16) & 0xffffffff) | (sum >>> 16)); + sum = (B + (C ^ D ^ A) + X[14] + 0xfde5380c) & 0xffffffff; + B = C + (((sum << 23) & 0xffffffff) | (sum >>> 9)); + sum = (A + (B ^ C ^ D) + X[1] + 0xa4beea44) & 0xffffffff; + A = B + (((sum << 4) & 0xffffffff) | (sum >>> 28)); + sum = (D + (A ^ B ^ C) + X[4] + 0x4bdecfa9) & 0xffffffff; + D = A + (((sum << 11) & 0xffffffff) | (sum >>> 21)); + sum = (C + (D ^ A ^ B) + X[7] + 0xf6bb4b60) & 0xffffffff; + C = D + (((sum << 16) & 0xffffffff) | (sum >>> 16)); + sum = (B + (C ^ D ^ A) + X[10] + 0xbebfbc70) & 0xffffffff; + B = C + (((sum << 23) & 0xffffffff) | (sum >>> 9)); + sum = (A + (B ^ C ^ D) + X[13] + 0x289b7ec6) & 0xffffffff; + A = B + (((sum << 4) & 0xffffffff) | (sum >>> 28)); + sum = (D + (A ^ B ^ C) + X[0] + 0xeaa127fa) & 0xffffffff; + D = A + (((sum << 11) & 0xffffffff) | (sum >>> 21)); + sum = (C + (D ^ A ^ B) + X[3] + 0xd4ef3085) & 0xffffffff; + C = D + (((sum << 16) & 0xffffffff) | (sum >>> 16)); + sum = (B + (C ^ D ^ A) + X[6] + 0x04881d05) & 0xffffffff; + B = C + (((sum << 23) & 0xffffffff) | (sum >>> 9)); + sum = (A + (B ^ C ^ D) + X[9] + 0xd9d4d039) & 0xffffffff; + A = B + (((sum << 4) & 0xffffffff) | (sum >>> 28)); + sum = (D + (A ^ B ^ C) + X[12] + 0xe6db99e5) & 0xffffffff; + D = A + (((sum << 11) & 0xffffffff) | (sum >>> 21)); + sum = (C + (D ^ A ^ B) + X[15] + 0x1fa27cf8) & 0xffffffff; + C = D + (((sum << 16) & 0xffffffff) | (sum >>> 16)); + sum = (B + (C ^ D ^ A) + X[2] + 0xc4ac5665) & 0xffffffff; + B = C + (((sum << 23) & 0xffffffff) | (sum >>> 9)); + sum = (A + (C ^ (B | (~D))) + X[0] + 0xf4292244) & 0xffffffff; + A = B + (((sum << 6) & 0xffffffff) | (sum >>> 26)); + sum = (D + (B ^ (A | (~C))) + X[7] + 0x432aff97) & 0xffffffff; + D = A + (((sum << 10) & 0xffffffff) | (sum >>> 22)); + sum = (C + (A ^ (D | (~B))) + X[14] + 0xab9423a7) & 0xffffffff; + C = D + (((sum << 15) & 0xffffffff) | (sum >>> 17)); + sum = (B + (D ^ (C | (~A))) + X[5] + 0xfc93a039) & 0xffffffff; + B = C + (((sum << 21) & 0xffffffff) | (sum >>> 11)); + sum = (A + (C ^ (B | (~D))) + X[12] + 0x655b59c3) & 0xffffffff; + A = B + (((sum << 6) & 0xffffffff) | (sum >>> 26)); + sum = (D + (B ^ (A | (~C))) + X[3] + 0x8f0ccc92) & 0xffffffff; + D = A + (((sum << 10) & 0xffffffff) | (sum >>> 22)); + sum = (C + (A ^ (D | (~B))) + X[10] + 0xffeff47d) & 0xffffffff; + C = D + (((sum << 15) & 0xffffffff) | (sum >>> 17)); + sum = (B + (D ^ (C | (~A))) + X[1] + 0x85845dd1) & 0xffffffff; + B = C + (((sum << 21) & 0xffffffff) | (sum >>> 11)); + sum = (A + (C ^ (B | (~D))) + X[8] + 0x6fa87e4f) & 0xffffffff; + A = B + (((sum << 6) & 0xffffffff) | (sum >>> 26)); + sum = (D + (B ^ (A | (~C))) + X[15] + 0xfe2ce6e0) & 0xffffffff; + D = A + (((sum << 10) & 0xffffffff) | (sum >>> 22)); + sum = (C + (A ^ (D | (~B))) + X[6] + 0xa3014314) & 0xffffffff; + C = D + (((sum << 15) & 0xffffffff) | (sum >>> 17)); + sum = (B + (D ^ (C | (~A))) + X[13] + 0x4e0811a1) & 0xffffffff; + B = C + (((sum << 21) & 0xffffffff) | (sum >>> 11)); + sum = (A + (C ^ (B | (~D))) + X[4] + 0xf7537e82) & 0xffffffff; + A = B + (((sum << 6) & 0xffffffff) | (sum >>> 26)); + sum = (D + (B ^ (A | (~C))) + X[11] + 0xbd3af235) & 0xffffffff; + D = A + (((sum << 10) & 0xffffffff) | (sum >>> 22)); + sum = (C + (A ^ (D | (~B))) + X[2] + 0x2ad7d2bb) & 0xffffffff; + C = D + (((sum << 15) & 0xffffffff) | (sum >>> 17)); + sum = (B + (D ^ (C | (~A))) + X[9] + 0xeb86d391) & 0xffffffff; + B = C + (((sum << 21) & 0xffffffff) | (sum >>> 11)); + + this.chain_[0] = (this.chain_[0] + A) & 0xffffffff; + this.chain_[1] = (this.chain_[1] + B) & 0xffffffff; + this.chain_[2] = (this.chain_[2] + C) & 0xffffffff; + this.chain_[3] = (this.chain_[3] + D) & 0xffffffff; +}; + + +/** @override */ +goog.crypt.Md5.prototype.update = function(bytes, opt_length) { + if (!goog.isDef(opt_length)) { + opt_length = bytes.length; + } + var lengthMinusBlock = opt_length - this.blockSize; + + // Copy some object properties to local variables in order to save on access + // time from inside the loop (~10% speedup was observed on Chrome 11). + var block = this.block_; + var blockLength = this.blockLength_; + var i = 0; + + // The outer while loop should execute at most twice. + while (i < opt_length) { + // When we have no data in the block to top up, we can directly process the + // input buffer (assuming it contains sufficient data). This gives ~30% + // speedup on Chrome 14 and ~70% speedup on Firefox 6.0, but requires that + // the data is provided in large chunks (or in multiples of 64 bytes). + if (blockLength == 0) { + while (i <= lengthMinusBlock) { + this.compress_(bytes, i); + i += this.blockSize; + } + } + + if (goog.isString(bytes)) { + while (i < opt_length) { + block[blockLength++] = bytes.charCodeAt(i++); + if (blockLength == this.blockSize) { + this.compress_(block); + blockLength = 0; + // Jump to the outer loop so we use the full-block optimization. + break; + } + } + } else { + while (i < opt_length) { + block[blockLength++] = bytes[i++]; + if (blockLength == this.blockSize) { + this.compress_(block); + blockLength = 0; + // Jump to the outer loop so we use the full-block optimization. + break; + } + } + } + } + + this.blockLength_ = blockLength; + this.totalLength_ += opt_length; +}; + + +/** @override */ +goog.crypt.Md5.prototype.digest = function() { + // This must accommodate at least 1 padding byte (0x80), 8 bytes of + // total bitlength, and must end at a 64-byte boundary. + var pad = new Array((this.blockLength_ < 56 ? + this.blockSize : + this.blockSize * 2) - this.blockLength_); + + // Add padding: 0x80 0x00* + pad[0] = 0x80; + for (var i = 1; i < pad.length - 8; ++i) { + pad[i] = 0; + } + // Add the total number of bits, little endian 64-bit integer. + var totalBits = this.totalLength_ * 8; + for (var i = pad.length - 8; i < pad.length; ++i) { + pad[i] = totalBits & 0xff; + totalBits /= 0x100; // Don't use bit-shifting here! + } + this.update(pad); + + var digest = new Array(16); + var n = 0; + for (var i = 0; i < 4; ++i) { + for (var j = 0; j < 32; j += 8) { + digest[n++] = (this.chain_[i] >>> j) & 0xff; + } + } + return digest; +}; + +// Copyright 2011 The Closure Library Authors. All Rights Reserved. +// +// Licensed under the Apache License, Version 2.0 (the "License"); +// you may not use this file except in compliance with the License. +// You may obtain a copy of the License at +// +// http://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS-IS" BASIS, +// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +// See the License for the specific language governing permissions and +// limitations under the License. + +/** + * @fileoverview Abstract cryptographic hash interface. + * + * See goog.crypt.Sha1 and goog.crypt.Md5 for sample implementations. + * + */ + + + + +/** + * Create a cryptographic hash instance. + * + * @constructor + * @struct + */ +goog.crypt.Hash = function() { + /** + * The block size for the hasher. + * @type {number} + */ + this.blockSize = -1; +}; + + +/** + * Resets the internal accumulator. + */ +goog.crypt.Hash.prototype.reset = goog.abstractMethod; + + +/** + * Adds a byte array (array with values in [0-255] range) or a string (might + * only contain 8-bit, i.e., Latin1 characters) to the internal accumulator. + * + * Many hash functions operate on blocks of data and implement optimizations + * when a full chunk of data is readily available. Hence it is often preferable + * to provide large chunks of data (a kilobyte or more) than to repeatedly + * call the update method with few tens of bytes. If this is not possible, or + * not feasible, it might be good to provide data in multiplies of hash block + * size (often 64 bytes). Please see the implementation and performance tests + * of your favourite hash. + * + * @param {Array<number>|Uint8Array|string} bytes Data used for the update. + * @param {number=} opt_length Number of bytes to use. + */ +goog.crypt.Hash.prototype.update = goog.abstractMethod; + + +/** + * @return {!Array<number>} The finalized hash computed + * from the internal accumulator. + */ +goog.crypt.Hash.prototype.digest = goog.abstractMethod; diff --git a/rts/js/mem.js b/rts/js/mem.js new file mode 100644 index 0000000000..c1f586c282 --- /dev/null +++ b/rts/js/mem.js @@ -0,0 +1,1444 @@ +//#OPTIONS: CPP + +// #define GHCJS_TRACE_META 1 + +#ifdef GHCJS_TRACE_META +function h$logMeta(args) { h$log.apply(h$log,arguments); } +#define TRACE_META(args...) h$logMeta(args) +#else +#define TRACE_META(args...) +#endif +// memory management and pointer emulation + +// static init, non-caf +#ifdef GHCJS_PROF +function h$sti(i,c,xs,ccs) { +#else +function h$sti(i,c,xs) { +#endif + i.f = c; +#ifdef GHCJS_PROF + i.cc = ccs; +#endif + h$init_closure(i,xs); +} + +// static init, caf +#ifdef GHCJS_PROF +function h$stc(i,c,xs,ccs) { +#else +function h$stc(i,c,xs) { +#endif + i.f = c; +#ifdef GHCJS_PROF + i.cc = ccs; +#endif + h$init_closure(i,xs); + h$addCAF(i); +} + +#ifdef GHCJS_PROF +function h$stl(o, xs, t, ccs) { +#else +function h$stl(o, xs, t) { +#endif + var r = t ? t : h$ghczmprimZCGHCziTypesziZMZN; + var x; + if(xs.length > 0) { + for(var i=xs.length-1;i>=0;i--) { + x = xs[i]; + if(!x && x !== false && x !== 0) throw "h$toHsList: invalid element"; + r = MK_CONS_CC(x, r, ccs); + } + } + // fixme direct object manip + o.f = r.f; + o.d1 = r.d1; + o.d2 = r.d2; + o.m = r.m; +#ifdef GHCJS_PROF + o.cc = ccs; +#endif +} + +// some utilities for constructing common objects from JS in the RTS or foreign code. +// when profiling, the current ccs is assigned + +// #ifdef GHCJS_PROF +// var h$nil = h$c(h$ghczmprimZCGHCziTypesziZMZN_con_e, h$CCS_SYSTEM); +// #else +// var h$nil = h$c(h$ghczmprimZCGHCziTypesziZMZN_con_e); +// #endif + +// #ifdef GHCJS_PROF +// var h$nothing = h$c(h$baseZCGHCziBaseziNothing_con_e, h$CCS_SYSTEM); +// #else +//var h$nothing = h$c(h$baseZCGHCziBaseziNothing_con_e); +// #endif + +// delayed init for top-level closures +var h$staticDelayed = []; +function h$d() { +#ifdef GHCJS_PROF + // pass a temporary CCS that won't make assertions in h$cN family alert + var c = h$c(null, h$CCS_SYSTEM); +#else + var c = h$c(null); +#endif + h$staticDelayed.push(c); + return c; +} + +var h$allocN = 0; +function h$traceAlloc(x) { + h$log("allocating: " + (++h$allocN)); + x.alloc = h$allocN; +} + +// fixme remove this when we have a better way to immediately init these things +function h$di(c) { + h$staticDelayed.push(c); +} + +// initialize global object to primitive value +function h$p(x) { + h$staticDelayed.push(x); + return x; +} + +var h$entriesStack = []; +var h$staticsStack = []; +var h$labelsStack = []; + +function h$scheduleInit(entries, objs, lbls, infos, statics) { + var d = h$entriesStack.length; + h$entriesStack.push(entries); + h$staticsStack.push(objs); + h$labelsStack.push(lbls); + h$initStatic.push(function() { + h$initInfoTables(d, entries, objs, lbls, infos, statics); + }); +} + +// initialize packed info tables +// see Gen2.Compactor for how the data is encoded +function h$initInfoTables ( depth // depth in the base chain + , funcs // array with all entry functions + , objects // array with all the global heap objects + , lbls // array with non-haskell labels + , infoMeta // packed info + , infoStatic + ) { + TRACE_META("decoding info tables") + var n, i, j, o, pos = 0, info; + function code(c) { + if(c < 34) return c - 32; + if(c < 92) return c - 33; + return c - 34; + } + function next() { + var c = info.charCodeAt(pos); + if(c < 124) { + TRACE_META("pos: " + pos + " decoded: " + code(c)) + pos++; + return code(c); + } + if(c === 124) { + pos+=3; + var r = 90 + 90 * code(info.charCodeAt(pos-2)) + + code(info.charCodeAt(pos-1)); + TRACE_META("pos: " + (pos-3) + " decoded: " + r) + return r; + } + if(c === 125) { + pos+=4; + var r = 8190 + 8100 * code(info.charCodeAt(pos-3)) + + 90 * code(info.charCodeAt(pos-2)) + + code(info.charCodeAt(pos-1)); + TRACE_META("pos: " + (pos-4) + " decoded: " + r) + return r; + } + throw ("h$initInfoTables: invalid code in info table: " + c + " at " + pos) + } + function nextCh() { + return next(); // fixme map readable chars + } + function nextInt() { + var n = next(); + var r; + if(n === 0) { + var n1 = next(); + var n2 = next(); + r = n1 << 16 | n2; + } else { + r = n - 12; + } + TRACE_META("decoded int: " + r) + return r; + } + function nextSignificand() { + var n = next(); + var n1, n2, n3, n4, n5; + var r; + if(n < 2) { + n1 = next(); + n2 = next(); + n3 = next(); + n4 = next(); + n5 = n1 * 281474976710656 + n2 * 4294967296 + n3 * 65536 + n4; + r = n === 0 ? -n5 : n5; + } else { + r = n - 12; + } + TRACE_META("decoded significand:" + r) + return r; + } + function nextEntry(o) { return nextIndexed("nextEntry", h$entriesStack, o); } + function nextObj(o) { return nextIndexed("nextObj", h$staticsStack, o); } + function nextLabel(o) { return nextIndexed("nextLabel", h$labelsStack, o); } + function nextIndexed(msg, stack, o) { + var n = (o === undefined) ? next() : o; + var i = depth; + while(n >= stack[i].length) { + n -= stack[i].length; + i--; + if(i < 0) throw (msg + ": cannot find item " + n + ", stack length: " + stack.length + " depth: " + depth); + } + return stack[i][n]; + } + function nextArg() { + var o = next(); + var n, n1, n2, d0, d1, d2, d3; + var isString = false; + switch(o) { + case 0: + TRACE_META("bool arg: false") + return false; + case 1: + TRACE_META("bool arg: true") + return true; + case 2: + TRACE_META("int constant: 0") + return 0; + case 3: + TRACE_META("int constant: 1") + return 1; + case 4: + TRACE_META("int arg") + return nextInt(); + case 5: + TRACE_META("literal arg: null") + return null; + case 6: + TRACE_META("double arg") + n = next(); + switch(n) { + case 0: + return -0.0; + case 1: + return 0.0; + case 2: + return 1/0; + case 3: + return -1/0; + case 4: + return 0/0; + case 5: + n1 = nextInt(); + var ns = nextSignificand(); + if(n1 > 600) { + return ns * Math.pow(2,n1-600) * Math.pow(2,600); + } else if(n1 < -600) { + return ns * Math.pow(2,n1+600) * Math.pow(2,-600); + } else { + return ns * Math.pow(2, n1); + } + default: + n1 = n - 36; + return nextSignificand() * Math.pow(2, n1); + } + case 7: + TRACE_META("string arg") + isString = true; + // no break, strings are null temrinated UTF8 encoded binary with + case 8: + TRACE_META("binary arg") + n = next(); + var ba = h$newByteArray(isString ? (n+1) : n); + var b8 = ba.u8; + if(isString) b8[n] = 0; + var p = 0; + while(n > 0) { + switch(n) { + case 1: + d0 = next(); + d1 = next(); + b8[p] = ((d0 << 2) | (d1 >> 4)); + break; + case 2: + d0 = next(); + d1 = next(); + d2 = next(); + b8[p++] = ((d0 << 2) | (d1 >> 4)); + b8[p] = ((d1 << 4) | (d2 >> 2)); + break; + default: + d0 = next(); + d1 = next(); + d2 = next(); + d3 = next(); + b8[p++] = ((d0 << 2) | (d1 >> 4)); + b8[p++] = ((d1 << 4) | (d2 >> 2)); + b8[p++] = ((d2 << 6) | d3); + break; + } + n -= 3; + } + return ba; + case 9: + var isFun = next() === 1; + var lbl = nextLabel(); + return h$initPtrLbl(isFun, lbl); + case 10: + var c = { f: nextEntry(), d1: null, d2: null, m: 0 }; + var n = next(); + var args = []; + while(n--) { + args.push(nextArg()); + } + return h$init_closure(c, args); + default: + TRACE_META("object arg: " + (o-11)) + return nextObj(o-11); + } + } + info = infoMeta; pos = 0; + for(i=0;i<funcs.length;i++) { + o = funcs[i]; + var ot; + var oa = 0; + var oregs = 256; // one register no skip + switch(next()) { + case 0: // thunk + ot = 0; + break; + case 1: // fun + ot = 1; + var arity = next(); + var skipRegs = next()-1; + if(skipRegs === -1) throw "h$initInfoTables: unknown register info for function"; + var skip = skipRegs & 1; + var regs = skipRegs >>> 1; + oregs = (regs << 8) | skip; + oa = arity + ((regs-1+skip) << 8); + break; + case 2: // con + ot = 2; + oa = next(); + break; + case 3: // stack frame + ot = -1; + oa = 0; + oregs = next() - 1; + if(oregs !== -1) oregs = ((oregs >>> 1) << 8) | (oregs & 1); + break; + default: throw ("h$initInfoTables: invalid closure type") + } + var size = next() - 1; + var nsrts = next(); + var srt = null; + if(nsrts > 0) { + srt = []; + for(var j=0;j<nsrts;j++) { + srt.push(nextObj()); + } + } + + // h$log("result: " + ot + " " + oa + " " + oregs + " [" + srt + "] " + size); + // h$log("orig: " + o.t + " " + o.a + " " + o.r + " [" + o.s + "] " + o.size); + // if(ot !== o.t || oa !== o.a || oregs !== o.r || size !== o.size) throw "inconsistent"; + + o.t = ot; + o.i = []; + o.n = ""; + o.a = oa; + o.r = oregs; + o.s = srt; + o.m = 0; + o.size = size; + } + info = infoStatic; + pos = 0; + for(i=0;i<objects.length;i++) { + TRACE_META("start iteration") + o = objects[i]; + // traceMetaObjBefore(o); + var nx = next(); + TRACE_META("static init object: " + i + " tag: " + nx) + switch(nx) { + case 0: // no init, could be a primitive value (still in the list since others might reference it) + // h$log("zero init"); + break; + case 1: // staticfun + o.f = nextEntry(); + TRACE_META("staticFun") + n = next(); + TRACE_META("args: " + n) + if(n === 0) { + o.d1 = null; + o.d2 = null; + } else if(n === 1) { + o.d1 = nextArg(); + o.d2 = null; + } else if(n === 2) { + o.d1 = nextArg(); + o.d2 = nextArg(); + } else { + for(j=0;j<n;j++) { + h$setField(o, j, nextArg()); + } + } + + break; + case 2: // staticThunk + TRACE_META("staticThunk") + o.f = nextEntry(); + n = next(); + TRACE_META("args: " + n) + if(n === 0) { + o.d1 = null; + o.d2 = null; + } else if(n === 1) { + o.d1 = nextArg(); + o.d2 = null; + } else if(n === 2) { + o.d1 = nextArg(); + o.d2 = nextArg(); + } else { + for(j=0;j<n;j++) { + h$setField(o, j, nextArg()); + } + } + h$addCAF(o); + break; + case 3: // staticPrim false, no init + TRACE_META("staticBool false") + break; + case 4: // staticPrim true, no init + TRACE_META("staticBool true") + break; + case 5: + TRACE_META("staticInt") + break; + case 6: // staticString + TRACE_META("staticDouble") + break; + case 7: // staticBin + TRACE_META("staticBin: error unused") + n = next(); + var b = h$newByteArray(n); + for(j=0;j>n;j++) { + b.u8[j] = next(); + } + break; + case 8: // staticEmptyList + TRACE_META("staticEmptyList") + o.f = HS_NIL_CON; + break; + case 9: // staticList + TRACE_META("staticList") + n = next(); + var hasTail = next(); + var c = (hasTail === 1) ? nextObj() : HS_NIL; + TRACE_META("list length: " + n) + while(n--) { + c = MK_CONS(nextArg(), c); + } + o.f = c.f; + o.d1 = c.d1; + o.d2 = c.d2; + break; + case 10: // staticData n args + TRACE_META("staticData") + n = next(); + TRACE_META("args: " + n) + o.f = nextEntry(); + for(j=0;j<n;j++) { + h$setField(o, j, nextArg()); + } + break; + case 11: // staticData 0 args + TRACE_META("staticData0") + o.f = nextEntry(); + break; + case 12: // staticData 1 args + TRACE_META("staticData1") + o.f = nextEntry(); + o.d1 = nextArg(); + break; + case 13: // staticData 2 args + TRACE_META("staticData2") + o.f = nextEntry(); + o.d1 = nextArg(); + o.d2 = nextArg(); + break; + case 14: // staticData 3 args + TRACE_META("staticData3") + o.f = nextEntry(); + o.d1 = nextArg(); + // should be the correct order + o.d2 = { d1: nextArg(), d2: nextArg()}; + break; + case 15: // staticData 4 args + TRACE_META("staticData4") + o.f = nextEntry(); + o.d1 = nextArg(); + // should be the correct order + o.d2 = { d1: nextArg(), d2: nextArg(), d3: nextArg() }; + break; + case 16: // staticData 5 args + TRACE_META("staticData5") + o.f = nextEntry(); + o.d1 = nextArg(); + o.d2 = { d1: nextArg(), d2: nextArg(), d3: nextArg(), d4: nextArg() }; + break; + case 17: // staticData 6 args + TRACE_META("staticData6") + o.f = nextEntry(); + o.d1 = nextArg(); + o.d2 = { d1: nextArg(), d2: nextArg(), d3: nextArg(), d4: nextArg(), d5: nextArg() }; + break; + default: + throw ("invalid static data initializer: " + nx); + } + } + h$staticDelayed = null; +} + +function h$initPtrLbl(isFun, lbl) { + return lbl; +} + +function h$callDynamic(f) { + return f.apply(f, Array.prototype.slice.call(arguments, 2)); +} + +// slice an array of heap objects +function h$sliceArray(a, start, n) { + var r = a.slice(start, start+n); + r.__ghcjsArray = true; + r.m = 0; + return r; +} + +// copy between two mutable arrays. Range may overlap +function h$copyMutableArray(a1,o1,a2,o2,n) { + if (n <= 0) return; + + if (o1 < o2) { + for (var i=n-1;i>=0;i--) { // start from the end to handle potential overlap + a2[o2+i] = a1[o1+i]; + } + } else { + for (var i=0;i<n;i++) { + a2[o2+i] = a1[o1+i]; + } + } +} + +function h$memcpy() { + if(arguments.length === 3) { // ByteArray# -> ByteArray# copy + var dst = arguments[0]; + var src = arguments[1]; + var n = arguments[2]; + for(var i=n-1;i>=0;i--) { + dst.u8[i] = src.u8[i]; + } + RETURN_UBX_TUP2(dst, 0); + } else if(arguments.length === 5) { // Addr# -> Addr# copy + var dst = arguments[0]; + var dst_off = arguments[1] + var src = arguments[2]; + var src_off = arguments[3]; + var n = arguments[4]; + for(var i=n-1;i>=0;i--) { + dst.u8[i+dst_off] = src.u8[i+src_off]; + } + RETURN_UBX_TUP2(dst, dst_off); + } else { + throw "h$memcpy: unexpected argument"; + } +} + +// note: only works for objects bigger than two! +function h$setField(o,n,v) { + if(n > 0 && !o.d2) o.d2 = {}; + switch(n) { + case 0: + o.d1 = v; + return; + case 1: + o.d2.d1 = v; + return; + case 2: + o.d2.d2 = v; + return; + case 3: + o.d2.d3 = v; + return; + case 4: + o.d2.d4 = v; + return; + case 5: + o.d2.d5 = v; + return; + case 6: + o.d2.d6 = v; + return; + case 7: + o.d2.d7 = v; + return; + case 8: + o.d2.d8 = v; + return; + case 9: + o.d2.d9 = v; + return; + case 10: + o.d2.d10 = v; + return; + case 11: + o.d2.d11 = v; + return; + case 12: + o.d2.d12 = v; + return; + case 13: + o.d2.d13 = v; + return; + case 14: + o.d2.d14 = v; + return; + case 15: + o.d2.d15 = v; + return; + case 16: + o.d2.d16 = v; + return; + case 17: + o.d2.d17 = v; + return; + case 18: + o.d2.d18 = v; + return; + case 19: + o.d2.d19 = v; + return; + case 20: + o.d2.d20 = v; + return; + case 21: + o.d2.d21 = v; + return; + case 22: + o.d2.d22 = v; + return; + case 23: + o.d2.d23 = v; + return; + case 24: + o.d2.d24 = v; + return; + case 25: + o.d2.d25 = v; + return; + case 26: + o.d2.d26 = v; + return; + case 27: + o.d2.d27 = v; + return; + case 28: + o.d2.d28 = v; + return; + case 29: + o.d2.d29 = v; + return; + case 30: + o.d2.d30 = v; + return; + case 31: + o.d2.d31 = v; + return; + case 32: + o.d2.d32 = v; + return; + case 33: + o.d2.d33 = v; + return; + case 34: + o.d2.d34 = v; + return; + case 35: + o.d2.d35 = v; + return; + case 36: + o.d2.d36 = v; + return; + case 37: + o.d2.d37 = v; + return; + case 38: + o.d2.d38 = v; + return; + case 39: + o.d2.d39 = v; + return; + case 40: + o.d2.d40 = v; + return; + case 41: + o.d2.d41 = v; + return; + case 42: + o.d2.d42 = v; + return; + case 43: + o.d2.d43 = v; + return; + case 44: + o.d2.d44 = v; + return; + case 45: + o.d2.d45 = v; + return; + case 45: + o.d2.d45 = v; + return; + case 46: + o.d2.d46 = v; + return; + case 47: + o.d2.d47 = v; + return; + case 48: + o.d2.d48 = v; + return; + case 49: + o.d2.d49 = v; + return; + case 50: + o.d2.d50 = v; + return; + case 51: + o.d2.d51 = v; + return; + case 52: + o.d2.d52 = v; + return; + case 53: + o.d2.d53 = v; + return; + case 54: + o.d2.d54 = v; + return; + case 55: + o.d2.d55 = v; + return; + case 56: + o.d2.d56 = v; + return; + case 57: + o.d2.d57 = v; + return; + case 58: + o.d2.d58 = v; + return; + case 59: + o.d2.d59 = v; + return; + case 60: + o.d2.d60 = v; + return; + case 61: + o.d2.d61 = v; + return; + case 62: + o.d2.d62 = v; + return; + case 63: + o.d2.d63 = v; + return; + case 64: + o.d2.d64 = v; + return; + case 65: + o.d2.d65 = v; + return; + case 66: + o.d2.d66 = v; + return; + case 67: + o.d2.d67 = v; + return; + case 68: + o.d2.d68 = v; + return; + case 69: + o.d2.d69 = v; + return; + case 70: + o.d2.d70 = v; + return; + case 71: + o.d2.d71 = v; + return; + case 72: + o.d2.d72 = v; + return; + case 73: + o.d2.d73 = v; + return; + case 74: + o.d2.d74 = v; + return; + case 75: + o.d2.d75 = v; + return; + case 76: + o.d2.d76 = v; + return; + case 77: + o.d2.d77 = v; + return; + case 78: + o.d2.d78 = v; + return; + case 79: + o.d2.d79 = v; + return; + case 80: + o.d2.d80 = v; + return; + case 81: + o.d2.d81 = v; + return; + case 82: + o.d2.d82 = v; + return; + case 83: + o.d2.d83 = v; + return; + case 84: + o.d2.d84 = v; + return; + case 85: + o.d2.d85 = v; + return; + case 86: + o.d2.d86 = v; + return; + case 87: + o.d2.d87 = v; + return; + case 88: + o.d2.d88 = v; + return; + case 89: + o.d2.d89 = v; + return; + case 90: + o.d2.d90 = v; + return; + case 91: + o.d2.d91 = v; + return; + case 92: + o.d2.d92 = v; + return; + case 93: + o.d2.d93 = v; + return; + case 94: + o.d2.d94 = v; + return; + case 95: + o.d2.d95 = v; + return; + case 96: + o.d2.d96 = v; + return; + case 97: + o.d2.d97 = v; + return; + case 98: + o.d2.d98 = v; + return; + case 99: + o.d2.d99 = v; + return; + case 100: + o.d2.d100 = v; + return; + case 101: + o.d2.d101 = v; + return; + case 102: + o.d2.d102 = v; + return; + case 103: + o.d2.d103 = v; + return; + case 104: + o.d2.d104 = v; + return; + case 105: + o.d2.d105 = v; + return; + case 106: + o.d2.d106 = v; + return; + case 107: + o.d2.d107 = v; + return; + default: + o.d2["d"+n] = v; // this requires all.js.externs for closure compiler! + } +} + +function h$mkSelThunk(r, f, rf) { + var sn = h$makeStableName(r); +#ifdef GHCJS_PROF + var ccs = h$currentThread ? h$currentThread.ccs : h$CCS_SYSTEM; + var res = h$c2(f, r, rf, ccs); +#else + var res = h$c2(f, r, rf); +#endif + if(sn.sel) { + sn.sel.push(res); + } else { + sn.sel = [res]; + } + return res; +} + +function h$memchr(a_v, a_o, c, n) { + for(var i=0;i<n;i++) { + if(a_v.u8[a_o+i] === c) { + RETURN_UBX_TUP2(a_v, a_o+i); + } + } + RETURN_UBX_TUP2(null, 0); +} + +function h$strlen(a_v, a_o) { + var i=0; + while(true) { + if(a_v.u8[a_o+i] === 0) { return i; } + i++; + } +} + +function h$newArray(len, e) { + var r = []; + r.__ghcjsArray = true; + r.m = 0; + if(e === null) e = r; + for(var i=0;i<len;i++) r[i] = e; + return r; +} + +function h$roundUpToMultipleOf(n,m) { + var rem = n % m; + return rem === 0 ? n : n - rem + m; +} + +// len in bytes +function h$newByteArray(len) { + var len0 = Math.max(h$roundUpToMultipleOf(len, 8), 8); + var buf = new ArrayBuffer(len0); + return { buf: buf + , len: len + , i3: new Int32Array(buf) + , u8: new Uint8Array(buf) + , u1: new Uint16Array(buf) + , f3: new Float32Array(buf) + , f6: new Float64Array(buf) + , dv: new DataView(buf) + , m: 0 + } +} + +function h$resizeMutableByteArray(a, n) { + var r; + if(a.len == n) { + r = a; + } else { + r = h$newByteArray(n); + for(var i = n - 1; i >= 0; i--) { + r.u8[i] = a.u8[i]; + } + } + return r +} + +/* + This implementation does not perform in-place shrinking of the byte array. + It only reuses the original byte array if the new given length is exactly + equal to old length. This implementation matches the expected semantics + for this primitive, but it is probably possible to make this more efficient. + */ +function h$shrinkMutableByteArray(a, n) { + if(a.len !== n) { + var r = h$newByteArray(n); + for(var i = n - 1; i >= 0; i--) { + r.u8[i] = a.u8[i]; + } + a.buf = r.buf; + a.len = r.len; + a.i3 = r.i3; + a.u8 = r.u8; + a.u1 = r.u1; + a.f3 = r.f3; + a.f6 = r.f6; + a.dv = r.dv; + } +} + +function h$shrinkMutableCharArray(a, n) { + a.length = n; +} + +function h$compareByteArrays(a1,o1,a2,o2,n) { + for(var i = 0; i < n; i++) { + var x = a1.u8[i + o1]; + var y = a2.u8[i + o2]; + if(x < y) return -1; + if(x > y) return 1; + } + return 0; +} + +/* + Unboxed arrays in GHC use the ByteArray# and MutableByteArray# + primitives. In GHCJS these primitives are represented by an + object that contains a JavaScript ArrayBuffer and several views + (typed arrays) on that buffer. + + Usually you can use GHCJS.Foreign.wrapBuffer and + GHCJS.Foreign.wrapMutableBuffer to do the conversion. If you need + more control or lower level acces, read on. + + You can use h$wrapBuffer to wrap any JavaScript ArrayBuffer + into such an object, without copying the buffer. Since typed array + access is aligned, not all views are available + if the offset of the buffer is not a multiple of 8. + + Since IO has kind * -> *, you cannot return IO ByteArray# + from a foreign import, even with the UnliftedFFITypes + extension. Return a JSVal instead and use unsafeCoerce + to convert it to a Data.Primitive.ByteArray.ByteArray or + Data.Primitive.ByteArray.MutableByteArray (primitive package) + and pattern match on the constructor to get the + primitive value out. + + These types have the same runtime representation (a data + constructor with one regular (one JavaScript variable) + field) as a JSVal, so the conversion is safe, as long + as everything is fully evaluated. +*/ +function h$wrapBuffer(buf, unalignedOk, offset, length) { + if(!unalignedOk && offset && offset % 8 !== 0) { + throw ("h$wrapBuffer: offset not aligned:" + offset); + } + if(!buf || !(buf instanceof ArrayBuffer)) + throw "h$wrapBuffer: not an ArrayBuffer" + if(!offset) { offset = 0; } + if(!length || length < 0) { length = buf.byteLength - offset; } + return { buf: buf + , len: length + , i3: (offset%4) ? null : new Int32Array(buf, offset, length >> 2) + , u8: new Uint8Array(buf, offset, length) + , u1: (offset%2) ? null : new Uint16Array(buf, offset, length >> 1) + , f3: (offset%4) ? null : new Float32Array(buf, offset, length >> 2) + , f6: (offset%8) ? null : new Float64Array(buf, offset, length >> 3) + , dv: new DataView(buf, offset, length) + }; +} + +var h$arrayBufferCounter = 0; + +function h$arrayBufferId(a) { + if (a.__ghcjsArrayBufferId === undefined) + a.__ghcjsArrayBufferId = h$arrayBufferCounter++; + return a.__ghcjsArrayBufferId; +} + +function h$comparePointer(a1,o1,a2,o2) { + if (a1 === null) { + return a2 === null ? 0 : -1; + } else if (a2 === null) { + return 1; + } + var i1 = h$arrayBufferId(a1.buf); + var i2 = h$arrayBufferId(a2.buf); + if (i1 === i2) { + var bo1 = a1.dv.byteOffset + o1; + var bo2 = a2.dv.byteOffset + o2; + return bo1 === bo2 ? 0 : (bo1 < bo2 ? -1 : 1); + } + else + return i1 < i2 ? -1 : 1; +} + +/* + A StableName is represented as either a h$StableName object (for most heap objects) + or a number (for heap objects with unboxed representation) + + Holding on to a StableName does not keep the original object alive. + */ +var h$stableNameN = 1; +/** @constructor */ +function h$StableName(m) { + this.m = m; + this.s = null; + this.sel = null; +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_notifyAlloc(this); +#endif +} + +var h$stableName_false = new h$StableName(0); +var h$stableName_true = new h$StableName(0); + +function h$makeStableName(x) { + if(x === false) { + return h$stableName_false; + } else if(x === true) { + return h$stableName_true; + } else if(typeof x === 'number') { + return x; + } else if(IS_WRAPPED_NUMBER(x)) { + return UNWRAP_NUMBER(x); + } else if(typeof x === 'object') { + if(typeof x.m !== 'object') { + x.m = new h$StableName(x.m); + } + return x.m; + } else { + throw new Error("h$makeStableName: invalid argument"); + } +} + +function h$stableNameInt(s) { + if(typeof s === 'number') { + if(s!=s) return 999999; // NaN + var s0 = s|0; + if(s0 === s) return s0; + h$convertDouble[0] = s; + return h$convertInt[0] ^ h$convertInt[1]; + } else { + var x = s.s; + if(x === null) { + x = s.s = h$stableNameN = (h$stableNameN+1)|0; + } + return x; + } +} + +function h$eqStableName(s1o,s2o) { + if(s1o!=s1o && s2o!=s2o) return 1; // NaN + return s1o === s2o ? 1 : 0; +} + +function h$malloc(n) { + RETURN_UBX_TUP2(h$newByteArray(n), 0); +} + +function h$calloc(n,size) { + RETURN_UBX_TUP2(h$newByteArray(n*size), 0); +} + +function h$free() { + +} + +function h$memset() { + var buf_v, buf_off, chr, n; + buf_v = arguments[0]; + if(arguments.length == 4) { // Addr# + buf_off = arguments[1]; + chr = arguments[2]; + n = arguments[3]; + } else if(arguments.length == 3) { // ByteString# + buf_off = 0; + chr = arguments[1]; + n = arguments[2]; + } else { + throw("h$memset: unexpected argument") + } + var end = buf_off + n; + for(var i=buf_off;i<end;i++) { + buf_v.u8[i] = chr; + } + RETURN_UBX_TUP2(buf_v, buf_off); +} + +function h$memcmp(a_v, a_o, b_v, b_o, n) { + for(var i=0;i<n;i++) { + var a = a_v.u8[a_o+i]; + var b = b_v.u8[b_o+i]; + var c = a-b; + if(c !== 0) { return c; } + } + return 0; +} + +function h$memmove(a_v, a_o, b_v, b_o, n) { + if(n > 0) { + var tmp = new Uint8Array(b_v.buf.slice(b_o,b_o+n)); + for(var i=0;i<n;i++) { + a_v.u8[a_o+i] = tmp[i]; + } + } + RETURN_UBX_TUP2(a_v, a_o); +} +function h$mkPtr(v, o) { + return MK_PTR(v, o); +}; +function h$mkFunctionPtr(f) { + var d = h$newByteArray(4); + d.arr = [f]; + return d; +} +var h$freeHaskellFunctionPtr = function () { +} + +// extra roots for the heap scanner: objects with root property +var h$extraRootsN = 0; +var h$extraRoots = new h$Set(); +function h$addExtraRoot() { + // fixme +} + +function h$createAdjustor(cconv, stbl_d, stbl_o, lbl_d, lbl_o, typeStr_d, typeStr_o) { + // fixme shouldn't we just use stablePtr for this? + var func = lbl_d.arr[lbl_o]; + // var typeStr = h$decodeUtf8z(typeStr_d, typeStr_o); + var stbl = h$deRefStablePtr(stbl_o); + if(typeof func !== 'function') { + throw new Error("h$createAdjustor: not a function"); + } + RETURN_UBX_TUP2(h$stablePtrBuf, h$makeStablePtr(func.bind(null, stbl_o))); +} + + +function h$makeCallback(f, extraArgs, action) { + var args = extraArgs.slice(0); + args.unshift(action); + var c = function() { + return f.apply(this, args); + } + c._key = ++h$extraRootsN; + c.root = action; + h$extraRoots.add(c); + return c; +} + +function h$makeCallbackApply(n, f, extraArgs, fun) { + var c; + if(n === 1) { + c = function(x) { + var args = extraArgs.slice(0); + var action = MK_AP1(fun, MK_JSVAL(x)); + args.unshift(action); + return f.apply(this, args); + } + } else if (n === 2) { + c = function(x,y) { + var args = extraArgs.slice(0); + var action = MK_AP2(fun, MK_JSVAL(x), MK_JSVAL(y)); + args.unshift(action); + return f.apply(this, args); + } + } else if (n === 3) { + c = function(x,y,z) { + var args = extraArgs.slice(0); + var action = MK_AP1(MK_AP2(fun, MK_JSVAL(x), MK_JSVAL(y)), MK_JSVAL(z)); + args.unshift(action); + return f.apply(this, args); + } + } else { + throw new Error("h$makeCallbackApply: unsupported arity"); + } + c.root = fun; + c._key = ++h$extraRootsN; + h$extraRoots.add(c); + return c; +} + +function h$retain(c) { + var k = c._key; + if(typeof k !== 'number') throw new Error("retained object does not have a key"); + if(k === -1) c._key = ++h$extraRootsN; + h$extraRoots.add(c); +} + +function h$release(c) { + h$extraRoots.remove(c); +} + +function h$isInstanceOf(o,c) { + return o instanceof c; +} + +function h$getpagesize() { + return 4096; +} + +var h$MAP_ANONYMOUS = 0x20; +function h$mmap(addr_d, addr_o, len, prot, flags, fd, offset1, offset2) { + if(flags & h$MAP_ANONYMOUS || fd === -1) { + RETURN_UBX_TUP2(h$newByteArray(len), 0); + } else { + throw "h$mmap: mapping a file is not yet supported"; + } +} + +function h$mprotect(addr_d, addr_o, size, prot) { + return 0; +} + +function h$munmap(addr_d, addr_o, size) { + if(addr_d && addr_o === 0 && size >= addr_d.len) { + addr_d.buf = null; + addr_d.i3 = null; + addr_d.u8 = null; + addr_d.u1 = null; + addr_d.f3 = null; + addr_d.f6 = null; + addr_d.dv = null; + } + return 0; +} + +function h$pdep8(src, mask) { + // console.log("pdep8: " + src + " " + mask); + var bit, k = 0, dst = 0; + for(bit=0;bit<8;bit++) { + if((mask & (1 << bit)) !== 0) { + dst |= ((src >>> k) & 1) << bit; + k++; + } + } + return dst; +} + +function h$pdep16(src, mask) { + // console.log("pdep16: " + src + " " + mask); + var bit, k = 0, dst = 0; + for(bit=0;bit<16;bit++) { + if((mask & (1 << bit)) !== 0) { + dst |= ((src >>> k) & 1) << bit; + k++; + } + } + return dst; +} + +function h$pdep32(src, mask) { + // console.log("pdep32: " + src + " " + mask); + var bit, k = 0, dst = 0; + for(bit=0;bit<32;bit++) { + if((mask & (1 << bit)) !== 0) { + dst |= ((src >>> k) & 1) << bit; + k++; + } + } + return (dst >>> 0); +} + +function h$pdep64(src_b, src_a, mask_b, mask_a) { + // console.log(["pdep64: ", src_b, src_a, mask_b, mask_a].join(" ")); + var bit, k = 0, dst_a = 0, dst_b = 0; + for(bit=0;bit<32;bit++) { + if((mask_a & (1 << bit)) !== 0) { + dst_a |= ((src_a >>> k) & 1) << bit; + k++; + } + } + for(bit=0;bit<32;bit++) { + if((mask_b & (1 << bit)) !== 0) { + if(k >= 32) { + dst_b |= ((src_b >>> (k - 32)) & 1) << bit; + } else { + dst_b |= ((src_a >>> k) & 1) << bit; + } + k++; + } + } + RETURN_UBX_TUP2((dst_b >>> 0), (dst_a >>> 0)); +} + +function h$pext8(src, mask) { + var bit, k = 0, dst = 0; + for(bit=0;bit<8;bit++) { + if((mask & (1 << bit)) !== 0) { + dst |= ((src >>> bit) & 1) << k; + k++; + } + } + return dst; +} + +function h$pext16(src, mask) { + var bit, k = 0, dst = 0; + for(bit=0;bit<16;bit++) { + if((mask & (1 << bit)) !== 0) { + dst |= ((src >>> bit) & 1) << k; + k++; + } + } + return dst; +} + +function h$pext32(src, mask) { + var bit, k = 0, dst = 0; + for(bit=0;bit<32;bit++) { + if((mask & (1 << bit)) !== 0) { + dst |= ((src >>> bit) & 1) << k; + k++; + } + } + return dst; +} + +function h$pext64(src_b, src_a, mask_b, mask_a) { + // console.log(["pext64: ", src_b, src_a, mask_b, mask_a].join(" ")); + var bit, k = 0, dst_a = 0, dst_b = 0; + for(bit=0;bit<32;bit++) { + if((mask_a & (1 << bit)) !== 0) { + dst_a |= ((src_a >>> bit) & 1) << k; + k++; + } + } + for(bit=0;bit<32;bit++) { + if((mask_b & (1 << bit)) !== 0) { + if(k >= 32) { + dst_b |= ((src_b >>> bit) & 1) << (k-32); + } else { + dst_a |= ((src_b >>> bit) & 1) << k; + } + k++; + } + } + RETURN_UBX_TUP2(dst_b, dst_a); +} + +function h$getThreadLabel(t) { + if (t.label) { + RETURN_UBX_TUP2(1, t.label); + } else { + RETURN_UBX_TUP2(0, 0); + } +} diff --git a/rts/js/node-exports.js b/rts/js/node-exports.js new file mode 100644 index 0000000000..a8d2db82a5 --- /dev/null +++ b/rts/js/node-exports.js @@ -0,0 +1,19 @@ +// add exported things to global again, run this after all node modules +/* +var h$glbl = this; +for(p in exports) { +// console.log("exporting: " + p); +// console.log("type: " + (typeof this[p])); + if(typeof this[p] === 'undefined') { + h$glbl[p] = exports[p]; + } +} +*/ +if(typeof exports !== 'undefined') { + if(typeof WeakMap === 'undefined' && typeof global !== 'undefined') { + global.WeakMap = exports.WeakMap; + } +// var Map = exports.Map; +// var Set = exports.Set; +} + diff --git a/rts/js/object.js b/rts/js/object.js new file mode 100644 index 0000000000..e6873ebcec --- /dev/null +++ b/rts/js/object.js @@ -0,0 +1,102 @@ +//#OPTIONS: CPP + +// JS Objects stuff + +function h$isFloat (n) { + return n===+n && n!==(n|0); +} + +function h$isInteger (n) { + return n===+n && n===(n|0); +} + +/* + -- 0 - null, 1 - integer, + -- 2 - float, 3 - bool, + -- 4 - string, 5 - array + -- 6 - object +*/ +function h$typeOf(o) { + if (!(o instanceof Object)) { + if (o == null) { + return 0; + } else if (typeof o == 'number') { + if (h$isInteger(o)) { + return 1; + } else { + return 2; + } + } else if (typeof o == 'boolean') { + return 3; + } else { + return 4; + } + } else { + if (Object.prototype.toString.call(o) == '[object Array]') { + // it's an array + return 5; + } else if (!o) { + // null + return 0; + } else { + // it's an object + return 6; + } + } +} + +function h$flattenObj(o) { + var l = [], i = 0; + for (var prop in o) { + l[i++] = [prop, o[prop]]; + } + return l; +} + +/* + + build an object from key/value pairs: + var obj = h$buildObject(key1, val1, key2, val2, ...); + + note: magic name: + invocations of this function are replaced by object literals wherever + possible + + */ +function h$buildObject() { + var r = {}, l = arguments.length; + for(var i = 0; i < l; i += 2) { + var k = arguments[i], v = arguments[i+1]; + r[k] = v; + } + return r; +} + +// same as above, but from a list: [k1,v1,k2,v2,...] +function h$buildObjectFromList(xs) { + var r = {}, k, v, t; + while(IS_CONS(xs)) { + xs = CONS_TAIL(xs); + t = CONS_TAIL(xs); + if(IS_CONS(t)) { + k = CONS_HEAD(xs); + v = CONS_HEAD(t); + xs = CONS_TAIL(t); + r[k] = v; + } else { + return r; + } + } + return r; +} + +// same as above, but from a list of tuples [(k1,v1),(k2,v2),...] +function h$buildObjectFromTupList(xs) { + var r = {}; + while(IS_CONS(xs)) { + var h = CONS_HEAD(xs); + xs = CONS_TAIL(xs); + r[JSVAL_VAL(TUP2_1(h))] = JSVAL_VAL(TUP2_2(h)); + } + return r; +} diff --git a/rts/js/profiling.js b/rts/js/profiling.js new file mode 100644 index 0000000000..f972642658 --- /dev/null +++ b/rts/js/profiling.js @@ -0,0 +1,334 @@ +//#OPTIONS: CPP + +// Used definitions: GHCJS_TRACE_PROF and GHCJS_ASSERT_PROF + +#ifdef GHCJS_ASSERT_PROF +function assert(condition, message) { + if (!condition) { + console.trace(message || "Assertion failed"); + } +} +#define ASSERT(args...) { assert(args); } +#else +#define ASSERT(args...) +#endif + +#ifdef GHCJS_TRACE_PROF +#define TRACE(args...) { h$log(args); } +#else +#define TRACE(args...) +#endif + +/* + install the ghcjs-profiling package from /utils/ghcjs-node-profiling + to collect cost centre stack information with the node.js profiler + */ +var h$registerCC = null, h$registerCCS = null, h$setCCS = null; +var h$runProf = function(f) { + f(); +} +if(h$isNode()) { + (function() { + try { + var p = require('ghcjs-profiling'); + if(p.isProfiling()) { + h$registerCC = p.registerCC; + h$registerCCS = p.registerCCS; + h$setCCS = p.setCCS; + h$runProf = p.runCC; + } + } catch(e) {} + })(); +} + +var h$cachedCurrentCcs = -1; +function h$reportCurrentCcs() { + if(h$setCCS) { + if(h$currentThread) { + var ccsKey = h$currentThread.ccs._key; + if(h$cachedCurrentCcs !== ccsKey) { + h$cachedCurrentCcs = ccsKey; + h$setCCS(ccsKey); + } + } else if(h$cachedCurrentCcs !== -1) { + h$cachedCurrentCcs = -1; + h$setCCS(2147483647); // set to invalid CCS + } + } +} + + +var h$ccList = []; +var h$ccsList = []; + +var h$CCUnique = 0; +/** @constructor */ +function h$CC(label, module, srcloc, isCaf) { + //TRACE("h$CC(", label, ", ", module, ", ", srcloc, ", ", isCaf, ")") + this.label = label; + this.module = module; + this.srcloc = srcloc; + this.isCaf = isCaf; + this._key = h$CCUnique++; + this.memAlloc = 0; + this.timeTicks = 0; + if(h$registerCC) h$registerCC(this._key, label, module + ' ' + srcloc, -1,-1); + h$ccList.push(this); +} + + +var h$CCSUnique = 0; +/** @constructor */ +function h$CCS(parent, cc) { + //TRACE("h$mkCCS(", parent, cc, ")") + if (parent !== null && parent.consed.has(cc)) { + return (parent.consed.get(cc)); + } + this.consed = new h$Map(); + this.cc = cc; + this._key = h$CCSUnique++; + if (parent) { + this.root = parent.root; + this.depth = parent.depth + 1; + this.prevStack = parent; + parent.consed.put(cc,this); + } else { + this.root = this; + this.depth = 0; + this.prevStack = null; + } + this.prevStack = parent; + this.sccCount = 0; + this.timeTicks = 0; + this.memAlloc = 0; + this.inheritedTicks = 0; + this.inheritedAlloc = 0; + if(h$registerCCS) { + var x = this, stack = []; + while(x) { stack.push(x.cc._key); x = x.prevStack; } + h$registerCCS(this._key, stack); + } + h$ccsList.push(this); /* we need all ccs for statistics, not just the root ones */ +} + + +// +// Built-in cost-centres and stacks +// + +var h$CC_MAIN = new h$CC("MAIN", "MAIN", "<built-in>", false); +var h$CC_SYSTEM = new h$CC("SYSTEM", "SYSTEM", "<built-in>", false); +var h$CC_GC = new h$CC("GC", "GC", "<built-in>", false); +var h$CC_OVERHEAD = new h$CC("OVERHEAD_of", "PROFILING", "<built-in>", false); +var h$CC_DONT_CARE = new h$CC("DONT_CARE", "MAIN", "<built-in>", false); +var h$CC_PINNED = new h$CC("PINNED", "SYSTEM", "<built-in>", false); +var h$CC_IDLE = new h$CC("IDLE", "IDLE", "<built-in>", false); +var h$CAF_cc = new h$CC("CAF", "CAF", "<built-in>", false); + +var h$CCS_MAIN = new h$CCS(null, h$CC_MAIN); + +var h$CCS_SYSTEM = new h$CCS(h$CCS_MAIN, h$CC_SYSTEM); +var h$CCS_GC = new h$CCS(h$CCS_MAIN, h$CC_GC); +var h$CCS_OVERHEAD = new h$CCS(h$CCS_MAIN, h$CC_OVERHEAD); +var h$CCS_DONT_CARE = new h$CCS(h$CCS_MAIN, h$CC_DONT_CARE); +var h$CCS_PINNED = new h$CCS(h$CCS_MAIN, h$CC_PINNED); +var h$CCS_IDLE = new h$CCS(h$CCS_MAIN, h$CC_IDLE); +var h$CAF = new h$CCS(h$CCS_MAIN, h$CAF_cc); + + +// +// Cost-centre entries, SCC +// + +#ifdef GHCJS_TRACE_PROF +function h$ccsString(ccs) { + var labels = []; + do { + labels.push(ccs.cc.module+'.'+ccs.cc.label+' '+ccs.cc.srcloc); + ccs = ccs.prevStack; + } while (ccs !== null); + return '[' + labels.reverse().join(', ') + ']'; +} +#endif + +function h$pushRestoreCCS() { + TRACE("push restoreccs:" + h$ccsString(h$currentThread.ccs)) + if(h$stack[h$sp] !== h$setCcs_e) { + h$sp += 2; + h$stack[h$sp-1] = h$currentThread.ccs; + h$stack[h$sp] = h$setCcs_e; + } +} + +function h$restoreCCS(ccs) { + TRACE("restoreccs from:", h$ccsString(h$currentThread.ccs)) + TRACE(" to:", h$ccsString(ccs)) + h$currentThread.ccs = ccs; + h$reportCurrentCcs(); +} + +function h$enterThunkCCS(ccsthunk) { + ASSERT(ccsthunk !== null && ccsthunk !== undefined, "ccsthunk is null or undefined") + TRACE("entering ccsthunk:", h$ccsString(ccsthunk)) + h$currentThread.ccs = ccsthunk; + h$reportCurrentCcs(); +} + +function h$enterFunCCS(ccsapp, // stack at call site + ccsfn // stack of function + ) { + ASSERT(ccsapp !== null && ccsapp !== undefined, "ccsapp is null or undefined") + ASSERT(ccsfn !== null && ccsfn !== undefined, "ccsfn is null or undefined") + TRACE("ccsapp:", h$ccsString(ccsapp)) + TRACE("ccsfn:", h$ccsString(ccsfn)) + + // common case 1: both stacks are the same + if (ccsapp === ccsfn) { + return; + } + + // common case 2: the function stack is empty, or just CAF + if (ccsfn.prevStack === h$CCS_MAIN) { + return; + } + + // FIXME: do we need this? + h$currentThread.ccs = h$CCS_OVERHEAD; + + // common case 3: the stacks are completely different (e.g. one is a + // descendent of MAIN and the other of a CAF): we append the whole + // of the function stack to the current CCS. + if (ccsfn.root !== ccsapp.root) { + h$currentThread.ccs = h$appendCCS(ccsapp, ccsfn); + h$reportCurrentCcs(); + return; + } + + // uncommon case 4: ccsapp is deeper than ccsfn + if (ccsapp.depth > ccsfn.depth) { + var tmp = ccsapp; + var dif = ccsapp.depth - ccsfn.depth; + for (var i = 0; i < dif; i++) { + tmp = tmp.prevStack; + } + h$currentThread.ccs = h$enterFunEqualStacks(ccsapp, tmp, ccsfn); + h$reportCurrentCcs(); + return; + } + + // uncommon case 5: ccsfn is deeper than CCCS + if (ccsfn.depth > ccsapp.depth) { + h$currentThread.ccs = h$enterFunCurShorter(ccsapp, ccsfn, ccsfn.depth - ccsapp.depth); + h$reportCurrentCcs(); + return; + } + + // uncommon case 6: stacks are equal depth, but different + h$currentThread.ccs = h$enterFunEqualStacks(ccsapp, ccsapp, ccsfn); + h$reportCurrentCcs(); +} + +function h$appendCCS(ccs1, ccs2) { + if (ccs1 === ccs2) { + return ccs1; + } + + if (ccs2 === h$CCS_MAIN || ccs2.cc.isCaf) { + // stop at a CAF element + return ccs1; + } + + return h$pushCostCentre(h$appendCCS(ccs1, ccs2.prevStack), ccs2.cc); +} + +function h$enterFunCurShorter(ccsapp, ccsfn, n) { + if (n === 0) { + ASSERT(ccsapp.length === ccsfn.length, "ccsapp.length !== ccsfn.length") + return h$enterFunEqualStacks(ccsapp, ccsapp, ccsfn); + } else { + ASSERT(ccsfn.depth > ccsapp.depth, "ccsfn.depth <= ccsapp.depth") + return h$pushCostCentre(h$enterFunCurShorter(ccsapp, ccsfn.prevStack, n-1), ccsfn.cc); + } +} + +function h$enterFunEqualStacks(ccs0, ccsapp, ccsfn) { + ASSERT(ccsapp.depth === ccsfn.depth, "ccsapp.depth !== ccsfn.depth") + if (ccsapp === ccsfn) return ccs0; + return h$pushCostCentre(h$enterFunEqualStacks(ccs0, ccsapp.prevStack, ccsfn.prevStack), ccsfn.cc); +} + +function h$pushCostCentre(ccs, cc) { + TRACE("pushing cost centre", cc.label, "to", h$ccsString(ccs)) + if (ccs === null) { + // when is ccs null? + return new h$CCS(ccs, cc); + } + + if (ccs.cc === cc) { + return ccs; + } else { + var temp_ccs = h$checkLoop(ccs, cc); + if (temp_ccs !== null) { + return temp_ccs; + } + return new h$CCS(ccs, cc); + } +} + +function h$checkLoop(ccs, cc) { + while (ccs !== null) { + if (ccs.cc === cc) + return ccs; + ccs = ccs.prevStack; + } + return null; +} + +// +// Emulating pointers for cost-centres and cost-centre stacks +// + +var h$ccsCC_offset = 4; // ccs->cc +var h$ccsPrevStackOffset = 8; // ccs->prevStack + +var h$ccLabel_offset = 4; // cc->label +var h$ccModule_offset = 8; // cc->module +var h$ccsrcloc_offset = 12; // cc->srcloc + +function h$buildCCPtr(o) { + // last used offset is 12, so we need to allocate 20 bytes + ASSERT(o !== null) + var cc = h$newByteArray(20); +#ifdef GHCJS_TRACE_PROF + cc.myTag = "cc pointer"; +#endif + cc.arr = []; + cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; + cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; + cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + return cc; +} + +function h$buildCCSPtr(o) { + ASSERT(o !== null) + // last used offset is 8, allocate 16 bytes + var ccs = h$newByteArray(16); +#ifdef GHCJS_TRACE_PROF + ccs.myTag = "ccs pointer"; +#endif + ccs.arr = []; + if (o.prevStack !== null) { + ccs.arr[h$ccsPrevStackOffset] = [h$buildCCSPtr(o.prevStack), 0]; + } + // FIXME: we may need this part: + // else { + // ccs.arr[h$ccsPrevStackOffset] = [null, 0]; + // } + ccs.arr[h$ccsCC_offset] = [h$buildCCPtr(o.cc), 0]; + return ccs; +} + +// run the action with an empty CCS +function h$clearCCS(a) { + throw new Error("ClearCCSOp not implemented"); +} diff --git a/rts/js/rts.js b/rts/js/rts.js new file mode 100644 index 0000000000..e3dcf07137 --- /dev/null +++ b/rts/js/rts.js @@ -0,0 +1,715 @@ +//#OPTIONS: CPP + +var h$start = new Date(); + +function h$rts_eval(action, unbox) { + return new Promise((accept, reject) => + h$run(MK_AP3( h$baseZCGHCziJSziPrimziresolveIO + , x => { accept(unbox(x))} + , e => { reject(new h$HaskellException(e))} + , action + )) + ); +} + +function h$rts_eval_sync(closure, unbox) { + var res, status = 0; + try { + h$runSync(MK_AP3( h$baseZCGHCziJSziPrimziresolveIO + , MK_JSVAL(x => { status = 1; res = unbox(x); }) + , MK_JSVAL(e => { status = 2; res = new h$HaskellException(e); }) + , closure), false); + } catch(e) { status = 2; res = e; } + switch(status) { + case 0: throw new h$HaskellException("internal error"); // thread didn't reach update frame + case 1: return res; + default: throw res; + } +} + + +function h$rts_apply(f, x) { + return MK_AP1(f, x); +} + +/* + marshalling for "foreign export" + */ +/* + | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , boolTyConKey + ] + */ + +function h$rts_mkChar(x) { return x|0; } +function h$rts_getChar(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkWord(x) { return x|0; } +function h$rts_getWord(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkInt(x) { return x|0; } +function h$rts_getInt(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkInt32(x) { return x|0; } +function h$rts_getInt32(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkWord32(x) { return x|0; } +function h$rts_getWord32(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkInt16(x) { return (x<<16)>>16; } +function h$rts_getInt16(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkInt64(x) { throw new Error("rts_mkInt64"); /* return MK_INT64(); */ } +function h$rts_getInt64(x) { throw new Error("rts_getInt64"); } + +function h$rts_mkWord64(x) { throw new Error("rts_mkWord64"); /* return MK_WORD64(); */ } +function h$rts_getWord64(x) { throw new Error("rts_getWord64"); } + +function h$rts_mkWord16(x) { return x&0xffff; } +function h$rts_getWord16(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkInt8(x) { return (x<<24)>>24; } +function h$rts_getInt8(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkWord8(x) { return x&0xff; } +function h$rts_getWord8(x) { return UNWRAP_NUMBER(x); } + +function h$rts_mkFloat(x) { return x; } +function h$rts_getFloat(x) { return x; } + +function h$rts_mkDouble(x) { return x; } +function h$rts_getDouble(x) { return x; } + +function h$rts_mkBool(x) { return x; } +function h$rts_getBool(x) { return x; } + +function h$rts_getUnit(x) { return 0; } + +function h$rts_toString(x) { + var buf; + if(typeof x === 'object' && + typeof x.len === 'number' && + x.buf instanceof ArrayBuffer) { + buf = x; + } else if(typeof x === 'object' && + x.buffer instanceof ArrayBuffer && + typeof x.byteOffset === 'number') { + buf = h$wrapBuffer(x.buffer, true, x.byteOffset, x.byteLength); + } else if(x instanceof ArrayBuffer) { + buf = h$wrapBuffer(x, true, 0, x.byteLength); + } else { + throw new Error("rts_toString: unsupported value" + x); + } + return h$decodeUtf8z(buf); +} + +function h$rts_mkPtr(x) { + var buf, off = 0; + if(typeof x == 'string') { + // string: UTF-8 encode + buf = h$encodeUtf8(x); + off = 0; + } else if(typeof x == 'object' && + typeof x.len == 'number' && + x.buf instanceof ArrayBuffer) { + // already a Haskell ByteArray + buf = x; + off = 0; + } else if(x.isView) { + // ArrayBufferView: make ByteArray with the same byteOffset + buf = h$wrapBuffer(x.buffer, true, 0, x.buffer.byteLength); + off = x.byteOffset; + } else { + // plain ArrayBuffer + buf = h$wrapBuffer(x, true, 0, x.byteLength); + off = 0; + } + return MK_PTR(buf, off); +} + +function h$rts_getPtr(x) { + var arr = x.d1; + var offset = x.d2; + return new Uint8Array(arr.buf, offset); +} + +function h$rts_mkFunPtr(x) { + // not yet implemented + throw new Error("rts_mkFunPtr"); +} + +function h$rts_getFunPtr(x) { + // not yet implemented + throw new Error("rts_getFunPtr"); +} + +function h$rts_toIO(x) { + return MK_AP1(h$baseZCGHCziJSziPrimzitoIO, x); +} + +// running IO actions + +function h$rts_evalIO_sync(closure) { + // return h$runSyncReturn(closure, false); +} + +async function h$rts_evalIO(closure) { + +} + +/* +function h$handleCallback(f, result) { + try { + f(result); + } catch() { + + } +} +*/ + +/* end foreign export stuff */ + +function h$runio(c) { + return h$c1(h$runio_e, c); +} + +function h$runInitStatic() { + if(h$initStatic.length == 0) return; + for(var i=h$initStatic.length - 1;i>=0;i--) { + h$initStatic[i](); + } + h$initStatic = []; +} + +function h$o(o, typ, a, size, regs, srefs) { + h$setObjInfo(o, typ, "", [], a, size, regs, srefs); +} + +// set heap/stack object information +function h$setObjInfo(o, typ, name, fields, a, size, regs, srefs) { + o.t = typ; + o.i = fields; + o.n = name; + o.a = a; + o.r = regs; + o.s = srefs; + o.m = 0 + o.size = size; +} + +var h$gccheckcnt = 0; + +function h$gc_check(next) { + // h$log("gc_check: todo"); + if(++h$gccheckcnt > 1000) { + for(var i=h$sp+1;i<h$stack.length;i++) { + h$stack[i] = null; + } + h$gccheckcnt = 0; + } + return 0; +} + +// print a closure +// fixme, property access here might be closure compiler incompatible + +function h$printcl(i) { + var cl = i.f; + var d = i.d1; + var r = ""; + switch(cl.t) { + case h$ct_thunk: + r += "thunk"; + break; + case h$ct_con: + r += "con[" + cl.a + "]"; + break; + case h$ct_fun: + r += "fun[" + cl.a + "]"; + break; + default: + r += "unknown closure type"; + break; + } + r += " :: " + cl.n + " ->"; + var idx = 1; + // fixme update for single field data + for(var i=0;i<cl.i.length;i++) { + r += " "; + switch(cl.i[i]) { + case h$vt_ptr: + r += "[ Ptr :: " + d["d"+idx].f.n + "]"; + idx++; + break; + case h$vt_void: + r += "void"; + break; + case h$vt_double: + r += "(" + d["d"+idx] + " :: double)"; + idx++; + break; + case h$vt_int: + r += "(" + d["d"+idx] + " :: int)"; + idx++; + break; + case h$vt_long: + r += "(" + d["d"+idx] + "," + d["d"+(idx+1)] + " :: long)"; + idx+=2; + break; + case h$vt_addr: + r += "(" + d["d"+idx].length + "," + d["d"+(idx+1)] + " :: ptr)"; + idx+=2; + break; + case h$vt_rtsobj: + r += "(" + d["d"+idx].toString() + " :: RTS object)"; + idx++; + break; + default: + r += "unknown field: " + cl.i[i]; + } + } + +} + +function h$init_closure(c, xs) { + c.m = 0; + switch(xs.length) { + case 0: + c.d1 = null; c.d2 = null; + return c; + case 1: + c.d1 = xs[0]; c.d2 = null; + return c; + case 2: + c.d1 = xs[0]; c.d2 = xs[1]; + return c; + case 3: + c.d1 = xs[0]; c.d2 = { d1: xs[1], d2: xs[2] }; + return c; + case 4: + c.d1 = xs[0]; c.d2 = { d1: xs[1], d2: xs[2], d3: xs[3] }; + return c; + case 5: + c.d1 = xs[0]; c.d2 = { d1: xs[1], d2: xs[2], d3: xs[3], d4: xs[4] }; + return c; + case 6: + c.d1 = xs[0]; c.d2 = { d1: xs[1], d2: xs[2], d3: xs[3], d4: xs[4], d5: xs[5] }; + return c; + case 7: + c.d1 = xs[0]; c.d2 = { d1: xs[1], d2: xs[2], d3: xs[3], d4: xs[4], d5: xs[5], d6: xs[6] }; + return c; + default: + c.d1 = xs[0]; c.d2 = { d1: xs[1], d2: xs[2], d3: xs[3], d4: xs[4], d5: xs[5], d6: xs[6] }; + // fixme does closure compiler bite us here? + for(var i=7;i<xs.length;i++) { + c.d2["d"+i] = xs[i]; + } + return c; + } +} + + + +function h$checkStack(f) { + // some code doesn't write a stack frame header when called immediately + if(f.t === h$ct_stackframe) h$stack[h$sp] = f; + var idx = h$sp; + while(idx >= 0) { + f = h$stack[idx]; + var size, offset; + if(typeof(f) === 'function') { + if(f === h$ap_gen) { + size = (h$stack[idx - 1] >> 8) + 2; + offset = 2; + } else { + var tag = h$stack[idx].size; + if(tag <= 0) { + size = h$stack[idx-1]; + offset = 2; + } else { + size = (tag & 0xff) + 1; + offset = 1; + } + } + // if(size < 1) throw("invalid stack frame size at: stack[" + idx + "], frame: " + h$stack[idx].n); + // h$log("checking frame: " + h$stack[idx].n + " size " + size); + // if(f !== h$returnf && f !== h$restoreThread) { + // for(var i=0;i<size-offset;i++) { + // if(typeof h$stack[idx-offset-i] === 'function') { + // h$dumpStackTop(h$stack, 0, h$sp); + // throw("unexpected function in frame at: " + idx + " " + h$stack[idx].n); + // } + // } + // } + idx = idx - size; + } else { + h$dumpStackTop(h$stack, 0, h$sp); + throw("invalid stack object at: " + idx); + } + } +} + +function h$printReg(r) { + if(r === null) { + return "null"; + } else if(typeof r === 'object' && r.hasOwnProperty('f') && r.hasOwnProperty('d1') && r.hasOwnProperty('d2')) { + if(typeof(r.f) !== 'function') { + return "dodgy object"; + } else if(r.f.t === h$ct_blackhole && r.x) { + return ("blackhole: -> " + h$printReg({ f: r.x.x1, d: r.d1.x2 }) + ")"); + } else { + var iv = ""; + if(r.f.n === "integer-gmp:GHC.Integer.Type.Jp#" || + r.f.n === "integer-gmp:GHC.Integer.Type.Jn#") { + iv = ' [' + r.d1.join(',') + '](' + h$ghcjsbn_showBase(r.d1, 10) + ')' + } else if(r.f.n === "integer-gmp:GHC.Integer.Type.S#") { + iv = ' (S: ' + r.d1 + ')'; + } + return ((r.alloc ? r.alloc + ': ' : '') + r.f.n + " (" + h$closureTypeName(r.f.t) + ", " + r.f.a + ")" + iv); + } + } else if(typeof r === 'object') { + var res = h$collectProps(r); + if(res.length > 40) { + return (res.substr(0,40)+"..."); + } else { + return res; + } + } else { + var xs = new String(r) + ""; + if(xs.length > 40) { + return xs.substr(0,40)+"..."; + } else { + return xs; + } + } +} + + +function h$stackFrameSize(f) { + if(f === h$ap_gen) { // h$ap_gen is special + return (h$stack[h$sp - 1] >> 8) + 2; + } else { + var tag = f.size; + if(tag < 0) { + return h$stack[h$sp-1]; + } else { + return (tag & 0xff) + 1; + } + } +} + + +// throw an exception: unwind the thread's stack until you find a handler +function h$throw(e, async) { + //h$log("throwing exception: " + async); + //h$dumpStackTop(h$stack, 0, h$sp); + var origSp = h$sp; + var lastBh = null; // position of last blackhole frame + var f; + while(h$sp > 0) { + //h$log("unwinding frame: " + h$sp); + f = h$stack[h$sp]; + if(f === null || f === undefined) { + throw("h$throw: invalid object while unwinding stack"); + } + if(f === h$catch_e) break; + if(f === h$atomically_e) { + if(async) { // async exceptions always propagate + h$currentThread.transaction = null; + } else if(!h$stmValidateTransaction()) { // restart transaction if invalid, don't propagate exception + h$sp++; + h$stack[h$sp] = h$checkInvariants_e; + return h$stmStartTransaction(h$stack[h$sp-1]); + } + } + if(f === h$catchStm_e && !async) break; // catchSTM only catches sync + if(f === h$upd_frame) { + var t = h$stack[h$sp-1]; + // wake up threads blocked on blackhole + var waiters = t.d2; + if(waiters !== null) { + for(var i=0;i<waiters.length;i++) { + h$wakeupThread(waiters[i]); + } + } + if(async) { + // convert blackhole back to thunk + if(lastBh === null) { + h$makeResumable(t,h$sp+1,origSp,[]); // [`R1`,h$return]); + } else { + h$makeResumable(t,h$sp+1,lastBh-2,[h$ap_0_0,h$stack[lastBh-1],h$return]); + } + lastBh = h$sp; + } else { + // just raise the exception in the thunk + t.f = h$raise_e; + t.d1 = e; + t.d2 = null; + } + } + var size = h$stackFrameSize(f); + h$sp = h$sp - size; +} +//h$log("unwound stack to: " + `Sp`); +//h$dumpStackTop(`Stack`,0,origSp); +if(h$sp > 0) { + var maskStatus = h$stack[h$p - 2]; + var handler = h$stack[h$sp - 1]; + if(f === h$catchStm_e) { + h$currentThread.transaction = h$stack[h$sp-3]; + h$sp -= 4; + } else if(h$sp > 3) { // don't pop the toplevel handler + h$sp -= 3; +} +h$r1 = handler; +h$r2 = e; +if(f !== h$catchStm_e) { // don't clobber mask in STM? +if(maskStatus === 0 && h$stack[h$sp] !== h$maskFrame && h$stack[h$sp] !== h$maskUnintFrame) { + h$stack[h$sp+1] = h$unmaskFrame; + h$sp += 1; +} else if(maskStatus === 1) { + h$stack[h$sp+1] = h$maskUnintFrame; + h$sp += 1; +} +h$currentThread.mask = 2; +} +return h$ap_2_1_fast(); +} else { + throw "unhandled exception in haskell thread"; +} +} + +// print top stack frame +function h$logStack() { + if(typeof h$stack[h$sp] === 'undefined') { + h$log("warning: invalid stack frame"); + return; + } + var size = 0; + var gt = h$stack[h$sp].size; + if(gt === -1) { + size = h$stack[h$sp - 1] & 0xff; + } else { + size = gt & 0xff; + } + h$dumpStackTop(h$stack, h$sp-size-2, h$sp); + for(var i=Math.max(0,h$sp-size+1); i <= h$sp; i++) { + if(typeof h$stack[i] === 'undefined') { + throw "undefined on stack"; + } + } +} + +// fixme check if still used +function h$ascii(s) { + var res = []; + for(var i=0;i<s.length;i++) { + res.push(s.charCodeAt(i)); + } + res.push(0); + return res; +} + + +function h$dumpStackTop(stack, start, sp) { + start = Math.max(start,0); + for(var i=start;i<=sp;i++) { + var s = stack[i]; + if(s && s.n) { + h$log("stack[" + i + "] = " + s.n); + } else { + if(s === null) { + h$log("stack[" + i + "] = null WARNING DANGER"); + } else if(typeof s === 'object' && s !== null && s.hasOwnProperty("f") && s.hasOwnProperty("d1") && s.hasOwnProperty("d2")) { + if(typeof(s.f) !== 'function') { + h$log("stack[" + i + "] = WARNING: dodgy object"); + } else { + if(s.d1 === undefined) { h$log("WARNING: stack[" + i + "] d1 undefined"); } + if(s.d2 === undefined) { h$log("WARNING: stack[" + i + "] d2 undefined"); } + if(s.f.t === h$ct_blackhole && s.d1 && s.d1.x1 && s.d1.x1.n) { + h$log("stack[" + i + "] = blackhole -> " + s.d1.x1.n); + } else { + var iv = ""; + if(s.f.n === "integer-gmp:GHC.Integer.Type.Jp#" || + s.f.n === "integer-gmp:GHC.Integer.Type.Jn#") { + iv = ' [' + s.d1.join(',') + '](' + h$ghcjsbn_showBase(s.d1, 10) + ')' + } else if(s.f.n === "integer-gmp:GHC.Integer.Type.S#") { + iv = ' (S: ' + s.d1 + ')'; + } + h$log("stack[" + i + "] = -> " + (s.alloc ? s.alloc + ': ' : '') + s.f.n + " (" + h$closureTypeName(s.f.t) + ", a: " + s.f.a + ")" + iv); + } + } + } else if(h$isInstanceOf(s,h$MVar)) { + var val = s.val === + null ? " empty" + : " value -> " + (typeof s.val === 'object' ? s.val.f.n + " (" + h$closureTypeName(s.val.f.t) + ", a: " + s.val.f.a + ")" : s.val); + h$log("stack[" + i + "] = MVar " + val); + } else if(h$isInstanceOf(s,h$MutVar)) { + h$log("stack[" + i + "] = IORef -> " + (typeof s.val === 'object' ? (s.val.f.n + " (" + h$closureTypeName(s.val.f.t) + ", a: " + s.val.f.a + ")") : s.val)); + } else if(Array.isArray(s)) { + h$log("stack[" + i + "] = " + ("[" + s.join(",") + "]").substring(0,50)); + } else if(typeof s === 'object') { + h$log("stack[" + i + "] = " + h$collectProps(s).substring(0,50)); + } else if(typeof s === 'function') { + var re = new RegExp("([^\\n]+)\\n(.|\\n)*"); + h$log("stack[" + i + "] = " + (""+s).substring(0,50).replace(re,"$1")); + } else { + h$log("stack[" + i + "] = " + (""+s).substring(0,50)); + } + } + } +} + + +/* check that a haskell heap object is what we expect: +f is a haskell entry function +d exists, but might be null, if it isn't, warn for any undefined/null fields or fields with unfamiliar names +*/ +function h$checkObj(obj) { + if(typeof obj === 'boolean' || typeof obj === 'number') { return; } + if(!obj.hasOwnProperty("f") || + obj.f === null || + obj.f === undefined || + obj.f.a === undefined || + typeof obj.f !== 'function') { + h$log("h$checkObj: WARNING, something wrong with f:"); + h$log((""+obj).substring(0,200)); + h$log(h$collectProps(obj)); + h$log(typeof obj.f); + } + if(!obj.hasOwnProperty("d1") || obj.d1 === undefined) { + h$log("h$checkObj: WARNING, something wrong with d1:"); + h$log((""+obj).substring(0,200)); + } else if(!obj.hasOwnProperty("d2") || obj.d2 === undefined) { + h$log("h$checkObj: WARNING, something wrong with d2:"); + h$log((""+obj).substring(0,200)); + } else if(obj.d2 !== null && typeof obj.d2 === 'object' && obj.f.size !== 2) { + var d = obj.d2; + for(var p in d) { + if(d.hasOwnProperty(p)) { + if(p.substring(0,1) != "d") { + h$log("h$checkObj: WARNING, unexpected field name: " + p); + h$log((""+obj).substring(0,200)); + } + if(d[p] === undefined) { + h$log("h$checkObj: WARNING, undefined field detected: " + p); + h$log((""+obj).substring(0,200)); + } + // if(d[p] === null) { + // h$log("h$checkObj: WARNING, null field detected: " + p); + // h$log((""+obj).substring(0,200)); + // } + } + } + switch(obj.f.size) { + case 6: if(d.d5 === undefined) { h$log("h$checkObj: WARNING, undefined field detected: d5"); } + case 5: if(d.d4 === undefined) { h$log("h$checkObj: WARNING, undefined field detected: d4"); } + case 4: if(d.d3 === undefined) { h$log("h$checkObj: WARNING, undefined field detected: d3"); } + case 3: if(d.d2 === undefined) { h$log("h$checkObj: WARNING, undefined field detected: d2"); } + if(d.d1 === undefined) { h$log("h$checkObj: WARNING, undefined field detected: d1"); } + default: d = obj.d2; // dummy + } + } +} + +function h$traceForeign(f, as) { + if(!h$rts_traceForeign) { return; } + var bs = []; + for(var i=0;i<as.length;i++) { + var ai = as[i]; + if(ai === null) { + bs.push("null"); + } else if(typeof ai === 'object') { + var astr = ai.toString(); + if(astr.length > 40) { + bs.push(astr.substring(0,40)+"..."); + } else { + bs.push(astr); + } + } else { + bs.push(""+ai); + } + } + h$log("ffi: " + f + "(" + bs.join(",") + ")"); +} + +function h$papArity(cp) { + return cp.d2.d1; +} + +// carefully suspend the current thread, looking at the +// function that would be called next +function h$suspendCurrentThread(next) { + // `assertRts s (next |!== (TxtI "h$reschedule")) ("suspend called with h$reschedule"::String)`; + if(next === h$reschedule) { throw "suspend called with h$reschedule"; } + // some stack calls do not write the function to the stack top as an optimization + // do it here + if(next.t === h$ct_stackframe) h$stack[h$sp] = next; + if(h$stack[h$sp] === h$restoreThread || next === h$return) { + h$currentThread.sp = h$sp; + return; + } + var nregs; + var skipregs = 0; + var t = next.t; + // pap arity + if(t === h$ct_pap) { + nregs = (h$papArity(h$r1) >> 8) + 1; + } else if(t === h$ct_fun || t === h$ct_stackframe) { + // for normal functions, the number active registers is in the .r proprty + nregs = next.r >> 8; + skipregs = next.r & 0xff; + } else { + nregs = 1; // Thunk, Con, Blackhole only have R1 + } + // h$log("suspending: " + `Sp` + " nregs: " + nregs); + h$sp = h$sp+nregs+skipregs+3; + var i; + for(i=1;i<=skipregs;i++) { + h$stack[h$sp-2-i] = null; + } + for(i=skipregs+1;i<=nregs+skipregs;i++) { + h$stack[h$sp-2-i] = h$getReg(i); + } + h$stack[h$sp-2] = next; + h$stack[h$sp-1] = nregs+skipregs+3; + h$stack[h$sp] = h$restoreThread; + h$currentThread.sp = h$sp; +} + +function h$static_thunk(f) { + // fixme push stuff to restore stuff here + var h; + if(!h$rts_profiling) { + h = { f: f, d1: null, d2: null, m: 0 }; + } else { + h = { f: f, d1: null, d2: null, m: 0, cc: h$CCS_SYSTEM }; + } + h$CAFs.push(h); + h$CAFsReset.push(f); + return h; +} + +function h$catch(a, handler) { + h$sp += 3; + h$stack[h$sp-2] = h$currentThread.mask; + h$stack[h$sp-1] = handler; + h$stack[h$sp] = h$catch_e; + h$r1 = a; + return h$ap_1_0_fast(); +} + +function h$keepAlive(x, f) { + h$sp += 2; + h$stack[h$sp-1] = x; + h$stack[h$sp] = h$keepAlive_e; + h$r1 = f; + return h$ap_1_0_fast(); +} diff --git a/rts/js/stableptr.js b/rts/js/stableptr.js new file mode 100644 index 0000000000..82fc2d336c --- /dev/null +++ b/rts/js/stableptr.js @@ -0,0 +1,75 @@ +//#OPTIONS: CPP + +/* + Stable pointers are all allocated in the h$StablePtrData buffer and + can therefore be distinguished by offset + + StablePtr# is treated as Word32# when it comes to writing and reading them + */ + + #ifdef GHCJS_TRACE_STABLEPTR + function h$logStablePtr(args) { h$log.apply(h$log,arguments); } + #define TRACE_STABLEPTR(args...) h$logStablePtr(args) + #else + #define TRACE_STABLEPTR(args...) + #endif + +var h$stablePtrData = [null]; +var h$stablePtrBuf = h$newByteArray(8); +var h$stablePtrN = 1; +var h$stablePtrFree = []; + +function h$makeStablePtr(v) { + TRACE_STABLEPTR("makeStablePtr") + if(!v) return 0; + var slot = h$stablePtrFree.pop(); + if(slot === undefined) { + slot = h$stablePtrN++; + } + TRACE_STABLEPTR(" -> slot:" + slot) + h$stablePtrData[slot] = v; + return slot << 2; +} + +var h$foreignExports = []; +function h$foreignExport(f, packageName, moduleName, functionName, typeSig) { + h$foreignExports.push({ exported: f, + package: packageName, + mod: moduleName, + name: functionName, + sig: typeSig + }); + // console.log("foreign export:", f, packageName, moduleName, functionName, typeSig); + h$makeStablePtr(f); + if(typeof exports === 'object') { + if(typeof exports[functionName] === 'undefined') { + exports[functionName] = f; + } + } +} +/* +function h$foreignExportStablePtr(x) { + // h$makeStablePtr(x); +} +*/ +function h$deRefStablePtr(stable_o) { + var slot = stable_o >> 2; + return h$stablePtrData[slot]; +} + +function h$hs_free_stable_ptr(stable_d, stable_o) { + var slot = stable_o >> 2; + TRACE_STABLEPTR("hs_free_stable_ptr") + if(h$stablePtrData[slot] !== null) { + h$stablePtrData[slot] = null; + h$stablePtrFree.push(slot); + } +} + +// not strictly stableptr, but we make it work only for stable pointers +function h$addrToAny(addr_v, addr_o) { + TRACE_STABLEPTR("addrToAny") + TRACE_STABLEPTR(addr_v === h$stablePtrBuf) + var slot = addr_o >> 2; + return h$stablePtrData[slot]; +} diff --git a/rts/js/staticpointer.js b/rts/js/staticpointer.js new file mode 100644 index 0000000000..9733490df5 --- /dev/null +++ b/rts/js/staticpointer.js @@ -0,0 +1,59 @@ +//#OPTIONS: CPP + +// static pointers +var h$static_pointer_table = null; +var h$static_pointer_table_keys = null; + +function h$hs_spt_insert(key1,key2,key3,key4,ref) { + // h$log("hs_spt_insert: " + key1 + " " + key2 + " " + key3 + " " + key4 + " -> " + h$collectProps(ref)); + if(!h$static_pointer_table) { + h$static_pointer_table = []; + h$static_pointer_table_keys = []; + } + if(!h$hs_spt_lookup_key(key1,key2,key3,key4)) { + var ba = h$newByteArray(16); + ba.i3[0] = key2; + ba.i3[1] = key1; + ba.i3[2] = key4; + ba.i3[3] = key3; + h$static_pointer_table_keys.push([ba,0]); + h$retain({ root: ref, _key: -1 }); + } + var s = h$static_pointer_table; + if(!s[key1]) s[key1] = []; + if(!s[key1][key2]) s[key1][key2] = []; + if(!s[key1][key2][key3]) s[key1][key2][key3] = []; + s[key1][key2][key3][key4] = ref; +} + +function h$hs_spt_key_count() { + return h$static_pointer_table_keys ? + h$static_pointer_table_keys.length : 0; +} + +function h$hs_spt_keys(tgt_d, tgt_o, n) { + var ks = h$static_pointer_table_keys; + if(!tgt_d.arr) tgt_d.arr = []; + for(var i=0;(i<n&&i<ks.length);i++) tgt_d.arr[tgt_o+4*i] = ks[i]; + return Math.min(n,ks.length); +} + +function h$hs_spt_lookup(key_v,key_o) { + // We know that the array is freshly allocated so we don't have to care + // about the offset (should be 0). + // + // note that the order of the keys is weird due to endianness + var key2 = key_v.i3[0] >>> 0; + var key1 = key_v.i3[1] >>> 0; + var key4 = key_v.i3[2] >>> 0; + var key3 = key_v.i3[3] >>> 0; + RETURN_UBX_TUP2(h$hs_spt_lookup_key(key1,key2,key3,key4), 0); +} + +function h$hs_spt_lookup_key(key1,key2,key3,key4) { + // h$log("hs_spt_lookup_key: " + key1 + " " + key2 + " " + key3 + " " + key4); + var s = h$static_pointer_table; + if(s && s[key1] && s[key1][key2] && s[key1][key2][key3] && + s[key1][key2][key3][key4]) return s[key1][key2][key3][key4]; + return null; +} diff --git a/rts/js/stm.js b/rts/js/stm.js new file mode 100644 index 0000000000..6590832f88 --- /dev/null +++ b/rts/js/stm.js @@ -0,0 +1,256 @@ +//#OPTIONS: CPP + +// software transactional memory + +#ifdef GHCJS_TRACE_STM +function h$logStm() { if(arguments.length == 1) { + h$log("stm: " + arguments[0]); + } else { + h$log.apply(h$log,arguments); + } + } +#define TRACE_STM(args...) h$logStm(args) +#else +#define TRACE_STM(args...) +#endif + + +var h$stmTransactionActive = 0; +var h$stmTransactionWaiting = 4; +/** @constructor */ +function h$Transaction(o, parent) { + TRACE_STM("h$Transaction: " + o + " -> " + parent) + this.action = o; + // h$TVar -> h$WrittenTVar, transaction-local changed values + this.tvars = new h$Map(); + // h$TVar -> h$LocalTVar, all local tvars accessed anywhere in the transaction + this.accessed = parent===null?new h$Map():parent.accessed; + this.parent = parent; + this.state = h$stmTransactionActive; + this.m = 0; // gc mark +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_notifyAlloc(this); +#endif +} + +/** @constructor */ +function h$WrittenTVar(tv,v) { + this.tvar = tv; + this.val = v; +} + +var h$TVarN = 0; +/** @constructor */ +function h$TVar(v) { + TRACE_STM("creating TVar, value: " + h$collectProps(v)) + this.val = v; // current value + this.blocked = new h$Set(); // threads that get woken up if this TVar is updated + this.m = 0; // gc mark + this._key = ++h$TVarN; // for storing in h$Map/h$Set +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_notifyAlloc(this); +#endif +} + +/** @constructor */ +function h$TVarsWaiting(s) { + this.tvars = s; // h$Set of TVars we're waiting on +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_notifyAlloc(this); +#endif +} + +// local view of a TVar +/** @constructor */ +function h$LocalTVar(v) { + TRACE_STM("creating TVar view for: " + h$collectProps(v)) + this.readVal = v.val; // the value when read from environment + this.val = v.val; // the current uncommitted value + this.tvar = v; +} + +function h$atomically(o) { + h$p2(o, h$atomically_e); + return h$stmStartTransaction(o); +} + +function h$stmStartTransaction(o) { + TRACE_STM("starting transaction: " + h$collectProps(o)) + var t = new h$Transaction(o, null); + h$currentThread.transaction = t; + h$r1 = o; + return h$ap_1_0_fast(); +} + +// commit current transaction, +// if it's top-level, commit the TVars, otherwise commit to parent +function h$stmCommitTransaction() { + var t = h$currentThread.transaction; + var tvs = t.tvars; + var wtv, i = tvs.iter(); + if(t.parent === null) { // top-level commit + TRACE_STM("committing top-level transaction") + // write new value to TVars and collect blocked threads + var thread, threadi, blockedThreads = new h$Set(); + while((wtv = i.nextVal()) !== null) { + h$stmCommitTVar(wtv.tvar, wtv.val, blockedThreads); + } + // wake up all blocked threads + threadi = blockedThreads.iter(); + while((thread = threadi.next()) !== null) { + h$stmRemoveBlockedThread(thread.blockedOn, thread); + h$wakeupThread(thread); + } + } else { // commit subtransaction + TRACE_STM("committing subtransaction") + var tpvs = t.parent.tvars; + while((wtv = i.nextVal()) !== null) tpvs.put(wtv.tvar, wtv); + } + h$currentThread.transaction = t.parent; +} + +function h$stmValidateTransaction() { + var ltv, i = h$currentThread.transaction.accessed.iter(); + while((ltv = i.nextVal()) !== null) { + if(ltv.readVal !== ltv.tvar.val) return false; + } + return true; +} + +function h$stmAbortTransaction() { + h$currentThread.transaction = h$currentThread.transaction.parent; +} + +function h$stmRetry() { + // unwind stack to h$atomically_e or h$stmCatchRetry_e frame + while(h$sp > 0) { + var f = h$stack[h$sp]; + if(f === h$atomically_e || f === h$stmCatchRetry_e) { + break; + } + var size; + if(f === h$ap_gen) { + size = ((h$stack[h$sp-1] >> 8) + 2); + } else { + var tag = f.gtag; + if(tag < 0) { // dynamic size + size = h$stack[h$sp-1]; + } else { + size = (tag & 0xff) + 1; + } + } + h$sp -= size; + } + // either h$sp == 0 or at a handler + if(h$sp > 0) { + if(f === h$atomically_e) { + return h$stmSuspendRetry(); + } else { // h$stmCatchRetry_e + var b = h$stack[h$sp-1]; + h$stmAbortTransaction(); + h$sp -= 2; + h$r1 = b; + return h$ap_1_0_fast(); + } + } else { + throw "h$stmRetry: STM retry outside a transaction"; + } +} + +function h$stmSuspendRetry() { + var tv, i = h$currentThread.transaction.accessed.iter(); + var tvs = new h$Set(); + while((tv = i.next()) !== null) { + TRACE_STM("h$stmSuspendRetry, accessed: " + h$collectProps(tv)) + tv.blocked.add(h$currentThread); + tvs.add(tv); + } + var waiting = new h$TVarsWaiting(tvs); + h$currentThread.interruptible = true; + h$p2(waiting, h$stmResumeRetry_e); + return h$blockThread(h$currentThread, waiting); +} + +function h$stmCatchRetry(a,b) { + h$currentThread.transaction = new h$Transaction(b, h$currentThread.transaction); + h$p2(b, h$stmCatchRetry_e); + h$r1 = a; + return h$ap_1_0_fast(); +} + +function h$catchStm(a,handler) { + h$p4(h$currentThread.transaction, h$currentThread.mask, handler, h$catchStm_e); + h$currentThread.transaction = new h$Transaction(handler, h$currentThread.transaction); + h$r1 = a; + return h$ap_1_0_fast(); +} + +function h$newTVar(v) { + return new h$TVar(v); +} + +function h$readTVar(tv) { + return h$readLocalTVar(h$currentThread.transaction,tv); +} + +function h$readTVarIO(tv) { + return tv.val; +} + +function h$writeTVar(tv, v) { + h$setLocalTVar(h$currentThread.transaction, tv, v); +} + +function h$sameTVar(tv1, tv2) { + return tv1 === tv2; +} + +// get the local value of the TVar in the transaction t +// tvar is added to the read set +function h$readLocalTVar(t, tv) { + var t0 = t; + while(t0 !== null) { + var v = t0.tvars.get(tv); + if(v !== null) { + TRACE_STM("h$readLocalTVar: found locally modified value: " + h$collectProps(v)) + return v.val; + } + t0 = t0.parent; + } + var lv = t.accessed.get(tv); + if(lv !== null) { + TRACE_STM("h$readLocalTVar: found TVar value: " + h$collectProps(lv)) + return lv.val; + } else { + TRACE_STM("h$readLocalTVar: TVar value not found, adding: " + h$collectProps(tv)) + t.accessed.put(tv, new h$LocalTVar(tv)); + return tv.val; + } +} + +function h$setLocalTVar(t, tv, v) { + if(!t.accessed.has(tv)) t.accessed.put(tv, new h$LocalTVar(tv)); + if(t.tvars.has(tv)) { + t.tvars.get(tv).val = v; + } else { + t.tvars.put(tv, new h$WrittenTVar(tv, v)); + } +} + +function h$stmCommitTVar(tv, v, threads) { + TRACE_STM("committing tvar: " + tv._key + " " + (v === tv.val)) + if(v !== tv.val) { + var thr, iter = tv.blocked.iter(); + while((thr = iter.next()) !== null) threads.add(thr); + tv.blocked.clear(); + tv.val = v; + } +} + +// remove the thread from the queues of the TVars in s +function h$stmRemoveBlockedThread(s, thread) { + var tv, i = s.tvars.iter(); + while((tv = i.next()) !== null) { + tv.blocked.remove(thread); + } +} diff --git a/rts/js/string.js b/rts/js/string.js new file mode 100644 index 0000000000..da5e0c610e --- /dev/null +++ b/rts/js/string.js @@ -0,0 +1,791 @@ +//#OPTIONS: CPP + +// encode a string constant +function h$str(s) { + var enc = null; + return function() { + if(enc === null) { + enc = h$encodeModifiedUtf8(s); + } + return enc; + } +} + +// encode a packed string +// since \0 is used to separate strings (and a common occurrence) +// we add the following mapping: +// - \0 -> \cz\0 +// - \cz -> \cz\cz +// +// decoding to bytes, the following is produced: +// - \cz\0 -> C0 80 +// - \cz\cz -> 1A +// +// additionally, for dealing with raw binary data we have an escape sequence +// to pack base64 encoded runs: +// +// - \cz\xNN -> followed by NN-0x1f (31 decimal) bytes of base64 encoded +// data. supported range: 0x20 .. 0x9f (1-128 bytes data) +// + +function h$pstr(s) { + var enc = null; + return function() { + if(enc === null) { + enc = h$encodePackedUtf8(s); + } + return enc; + } +} +// encode a raw string from bytes +function h$rstr(d) { + var enc = null; + return function() { + if(enc === null) { + enc = h$rawStringData(d); + } + return enc; + } +} + +// these aren't added to the CAFs, so the list stays in mem indefinitely, is that a problem? +#ifdef GHCJS_PROF +function h$strt(str, cc) { return MK_LAZY_CC(function() { return h$toHsString(str, cc); }, cc); } +function h$strta(str, cc) { return MK_LAZY_CC(function() { return h$toHsStringA(str, cc); }, cc); } +function h$strtb(arr, cc) { return MK_LAZY_CC(function() { return h$toHsStringMU8(arr, cc); }, cc); } +#else +function h$strt(str) { return MK_LAZY(function() { return h$toHsString(str); }); } +function h$strta(str) { return MK_LAZY(function() { return h$toHsStringA(str); }); } +function h$strtb(arr) { return MK_LAZY(function() { return h$toHsStringMU8(arr); }); } +#endif + +// unpack strings without thunks +#ifdef GHCJS_PROF +function h$ustra(str, cc) { return h$toHsStringA(str, cc); } +function h$ustr(str, cc) { return h$toHsString(str, cc); } // utf8 string, string argument +function h$urstra(arr, cc) { return h$toHsList(arr, cc); } // ascii string, array of codepoints argument +function h$urstr(arr, cc) { return h$toHsStringMU8(arr, cc); } // utf8 string, array of bytes argumnt +#else +function h$ustra(str) { return h$toHsStringA(str); } +function h$ustr(str) { return h$toHsString(str); } +function h$urstra(arr) { return h$toHsList(arr); } +function h$urstr(arr) { return h$toHsStringMU8(arr); } +#endif + +function h$caseMapping(x) { + return (x%2)?-((x+1)>>1):(x>>1); +} + +var h$toUpper = null; +function h$u_towupper(ch) { + if(h$toUpper == null) { h$toUpper = h$decodeMapping(h$toUpperMapping, h$caseMapping); } + return ch+(h$toUpper[ch]|0); +} + +var h$toLower = null; +function h$u_towlower(ch) { + if(h$toLower == null) { h$toLower = h$decodeMapping(h$toLowerMapping, h$caseMapping); } + return ch+(h$toLower[ch]|0); +} + +var h$toTitle = null; +function h$u_towtitle(ch) { + if(h$toTitle == null) { h$toTitle = h$decodeMapping(h$toTitleMapping, h$caseMapping); } + return ch+(h$toTitle[ch]|0); +} + +var h$alpha = null; +function h$u_iswalpha(a) { + if(h$alpha == null) { h$alpha = h$decodeRLE(h$alphaRanges); } + return h$alpha[a]|0; +} + +var h$alnum = null; +function h$u_iswalnum(a) { + if(h$alnum == null) { h$alnum = h$decodeRLE(h$alnumRanges); } + return h$alnum[a] == 1 ? 1 : 0; +} + +// var h$spaceChars = [9,10,11,12,13,32,160,5760,8192,8193,8194,8195,8196,8197,8198,8199,8200,8201,8202,8239,8287,12288]; +function h$isSpace(a) { + if(a<5760) return a===32||(a>=9&&a<=13)||a===160; + return (a>=8192&&a<=8202)||a===5760||a===8239||a===8287||a===12288; +} + +function h$u_iswspace(a) { + return h$isSpace(a)?1:0; +} + +var h$lower = null; +function h$u_iswlower(a) { + if(h$lower == null) { h$lower = h$decodeRLE(h$lowerRanges); } + if(a < 0x30000) return h$lower[a]|0; + if(a < 0xE0000) return 0; + return h$lower[a-0xB0000]|0; +} + +var h$upper = null; +function h$u_iswupper(a) { + if(h$upper == null) { h$upper = h$decodeRLE(h$upperRanges); } + if(a < 0x30000) return h$upper[a]|0; + if(a < 0xE0000) return 0; + return h$upper[a-0xB0000]|0; +} + + +var h$cntrlChars = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159]; +var h$cntrl = null; +function h$u_iswcntrl(a) { + if(h$cntrl === null) { + h$cntrl = []; + for(var i=0;i<=159;i++) h$cntrl[i] = (h$cntrlChars.indexOf(i) !== -1) ? 1 : 0; + } + return a <= 159 ? h$cntrl[a] : 0; +} + +var h$print = null; +function h$u_iswprint(a) { + if(h$print == null) { h$print = h$decodeRLE(h$printRanges); } + if(a < 0x30000) return h$print[a]|0; + if(a < 0xE0000) return 0; + return h$print[a-0xB0000]|0; +} + +// decode a packed string (Compactor encoding method) to an array of numbers +function h$decodePacked(s) { + function f(o) { + var c = s.charCodeAt(o); + return c<34?c-32:c<92?c-33:c-34; + } + var r=[], i=0; + while(i < s.length) { + var c = s.charCodeAt(i); + if(c < 124) r.push(f(i++)); + else if(c === 124) { + i += 3; r.push(90+90*f(i-2)+f(i-1)); + } else if(c === 125) { + i += 4; + r.push(8190+8100*f(i-3)+90*f(i-2)+f(i-1)); + } else throw ("h$decodePacked: invalid: " + c); + } + return r; +} + +// decode string with encoded character ranges +function h$decodeRLE(str) { + var r = [], x = 0, i = 0, j = 0, v, k, a = h$decodePacked(str); + while(i < a.length) { + v = a[i++]; + if(v === 0) { // alternating + k = a[i++]; + while(k--) { + r[j++] = x; + r[j++] = 1-x; + } + } else { + if(v <= 2) { + k = (a[i]<<16)+a[i+1]; + i+=2; + } else k = (v-1)>>1; + if(v%2) { + r[j++] = x; + x = 1-x; + } + while(k--) r[j++] = x; + x = 1-x; + } + } + r.shift(); + return r; +} + +function h$decodeMapping(str, f) { + var r = [], i = 0, j = 0, k, v, v2, a = h$decodePacked(str); + while(i < a.length) { + v = a[i++]; + if(v === 0) { // alternating + k = a[i]; + v = f(a[i+1]); + v2 = f(a[i+2]); + while(k--) { + r[j++] = v; + r[j++] = v2; + } + i+=3; + } else { + if(v === 2) { + k = (a[i] << 16) + a[i+1]; + v = a[i+2]; + i += 3; + } else if(v%2) { + k = 1; + v = v>>1; + } else { + k = (v>>1)-1; + v = a[i++]; + } + v = f(v); + while(k--) r[j++] = v; + } + } + return r; +} + +var h$unicodeCat = null; +function h$u_gencat(a) { + if(h$unicodeCat == null) h$unicodeCat = h$decodeMapping(h$catMapping, function(x) { return x; }); + // private use + if(a >= 0xE000 && a <= 0xF8FF || a >= 0xF0000 & a <= 0xFFFFD || a >= 0x100000 && a <= 0x10FFFD) return 28; + var c = a < 0x30000 ? (h$unicodeCat[a]|0) : + (a < 0xE0000 ? 0 : (h$unicodeCat[a-0xB0000]|0)); + return c?c-1:29; +} + +function h$localeEncoding() { + // h$log("### localeEncoding"); + RETURN_UBX_TUP2(h$encodeUtf8("UTF-8"), 0); // offset 0 +} + +function h$wcwidth(wch) { + return 1; // XXX: add real implementation +} + +function h$rawStringData(str) { + var v = h$newByteArray(str.length+1); + var u8 = v.u8; + for(var i=0;i<str.length;i++) { + u8[i] = str[i]; + } + u8[str.length] = 0; + return v; +} + +// encode a javascript string to a zero terminated utf8 byte array +function h$encodeUtf8(str) { + return h$encodeUtf8Internal(str, false, false); +} + +function h$encodeModifiedUtf8(str) { + return h$encodeUtf8Internal(str, true, false); +} + +function h$encodePackedUtf8(str) { + return h$encodeUtf8Internal(str, false, true); +} + +// modified: encode \0 -> 192 128 +// packed: encode \cz\cz -> 26 +// \cz\0 -> 192 128 +function h$encodeUtf8Internal(str, modified, packed) { + var i, j, c, low, b64bytes, b64chars; + function base64val(cc) { + if(cc >= 65 && cc <= 90) return cc - 65; // A-Z + if(cc >= 97 && cc <= 122) return cc - 71; // a-z + if(cc >= 48 && cc <= 57) return cc + 4; // 0-9 + if(cc === 43) return 62; // + + if(cc === 47) return 63; // / + if(cc === 61) return 0; // = (treat padding as zero) + throw new Error("invalid base64 value: " + cc); + } + var n = 0; + var czescape = false; + for(i=0;i<str.length;i++) { + // non-BMP encoded as surrogate pair in JavaScript string, get actual codepoint + var c = str.charCodeAt(i); + if (0xD800 <= c && c <= 0xDBFF) { + low = str.charCodeAt(i+1); + c = ((c - 0xD800) * 0x400) + (low - 0xDC00) + 0x10000; + i++; + } + if(czescape) { + if(c === 26) { // \cz\cz -> 26 + n+=1; + } else if(c === 0) { // \cz\0 -> 192 128 + n+=2 + } else if(c >= 0x20 && c <= 0x9f) { + b64bytes = c - 0x1f; // number of bytes in base64 encoded run + b64chars = ((b64bytes + 2) / 3) << 2; + n += b64bytes; + i += b64chars; + } else { + throw new Error("invalid cz escaped character: " + c); + } + czescape = false; + } else { + if(c === 26 && packed) { + czescape = true; + } else if(c === 0 && modified) { + n+=2; + } else if(c <= 0x7F) { + n++; + } else if(c <= 0x7FF) { + n+=2; + } else if(c <= 0xFFFF) { + n+=3; + } else if(c <= 0x1FFFFF) { + n+=4; + } else if(c <= 0x3FFFFFF) { + n+=5; + } else { + n+=6; + } + } + } + var v = h$newByteArray(n+1); + var u8 = v.u8; + n = 0; + for(i=0;i<str.length;i++) { + c = str.charCodeAt(i); + // non-BMP encoded as surrogate pair in JavaScript string, get actual codepoint + if (0xD800 <= c && c <= 0xDBFF) { + low = str.charCodeAt(i+1); + c = ((c - 0xD800) * 0x400) + (low - 0xDC00) + 0x10000; + i++; + } +// h$log("### encoding char " + c + " to UTF-8: " + String.fromCodePoint(c)); + if(packed && !czescape && c === 26) { + czescape = true; + } else if(c === 0 && (modified || czescape)) { + u8[n] = 192; + u8[n+1] = 128; + n+=2; + czescape = false; + } else if(czescape) { + if(c >= 0x20 && c <= 0x9f) { + b64bytes = c - 0x1f; + while(b64bytes > 0) { + var c1 = base64val(str.charCodeAt(i+1)), + c2 = base64val(str.charCodeAt(i+2)), + c3 = base64val(str.charCodeAt(i+3)), + c4 = base64val(str.charCodeAt(i+4)); + i+=4; + u8[n] = (c1<<2)|(c2>>4); + n++; + if(b64bytes >= 2) { + u8[n] = ((c2&0xf)<<4)|(c3 >> 2); + n++; + } + if(b64bytes >= 3) { + u8[n] = ((c3&0x3)<<6)|c4; + n++; + } + b64bytes -= 3; + } + } else { + u8[n] = c; + n++; + } + czescape = false; + } else if(c <= 0x7F) { + u8[n] = c; + n++; + } else if(c <= 0x7FF) { + u8[n] = (c >> 6) | 0xC0; + u8[n+1] = (c & 0x3F) | 0x80; + n+=2; + } else if(c <= 0xFFFF) { + u8[n] = (c >> 12) | 0xE0; + u8[n+1] = ((c >> 6) & 0x3F) | 0x80; + u8[n+2] = (c & 0x3F) | 0x80; + n+=3; + } else if(c <= 0x1FFFFF) { + u8[n] = (c >> 18) | 0xF0; + u8[n+1] = ((c >> 12) & 0x3F) | 0x80; + u8[n+2] = ((c >> 6) & 0x3F) | 0x80; + u8[n+3] = (c & 0x3F) | 0x80; + n+=4; + } else if(c <= 0x3FFFFFF) { + u8[n] = (c >> 24) | 0xF8; + u8[n+1] = ((c >> 18) & 0x3F) | 0x80; + u8[n+2] = ((c >> 12) & 0x3F) | 0x80; + u8[n+3] = ((c >> 6) & 0x3F) | 0x80; + u8[n+4] = (c & 0x3F) | 0x80; + n+=5; + } else { + u8[n] = (c >>> 30) | 0xFC; + u8[n+1] = ((c >> 24) & 0x3F) | 0x80; + u8[n+2] = ((c >> 18) & 0x3F) | 0x80; + u8[n+3] = ((c >> 12) & 0x3F) | 0x80; + u8[n+4] = ((c >> 6) & 0x3F) | 0x80; + u8[n+5] = (c & 0x3F) | 0x80; + n+=6; + } + } + u8[v.len-1] = 0; // terminator +// h$log("### encodeUtf8: " + str); +// h$log(v); + return v; +} + + +// encode a javascript string to a zero terminated utf16 byte array +function h$encodeUtf16(str) { + var n = 0; + var i; + for(i=0;i<str.length;i++) { + var c = str.charCodeAt(i); + if(c <= 0xFFFF) { + n += 2; + } else { + n += 4; + } + } + var v = h$newByteArray(n+1); + var dv = v.dv; + n = 0; + for(i=0;i<str.length;i++) { + var c = str.charCodeAt(i); + if(c <= 0xFFFF) { + dv.setUint16(n, c, true); + n+=2; + } else { + var c0 = c - 0x10000; + dv.setUint16(n, c0 >> 10, true); + dv.setUint16(n+2, c0 & 0x3FF, true); + n+=4; + } + } + dv.setUint8(v.len-1,0); // terminator + return v; +} + + +/* +function h$encodeUtf16(str) { + var b = new DataView(new ArrayBuffer(str.length * 2)); + for(var i=str.length-1;i>=0;i--) { + b.setUint16(i<<1, str.charCodeAt(i)); + } + h$ret1 = 0; + return b; +} +var h$eU16 = h$encodeUtf16; + +function h$decodeUtf16(v,start) { + return h$decodeUtf16(v, v.byteLength - start, start); +} + +function h$decodeUtf16z(v,start) { + var len = v.byteLength - start; + for(var i=start;i<l;i+=2) { + if(v.getUint16(i) === 0) { + len = i; + break; + } + } + return h$decodeUtf16l(v,l,start) +} +*/ + +function h$decodeUtf16l(v, byteLen, start) { + // perhaps we can apply it with an Uint16Array view, but that might give us endianness problems + var a = []; + for(var i=0;i<byteLen;i+=2) { + a[i>>1] = v.dv.getUint16(i+start,true); + } + return h$charCodeArrayToString(arr); +} +var h$dU16 = h$decodeUtf16; + +// decode a buffer with UTF-8 chars to a JS string +// stop at the first zero +function h$decodeUtf8z(v,start) { + var n = start; + var max = v.len; + while(n < max) { + if(v.u8[n] === 0) { break; } + n++; + } + return h$decodeUtf8(v,n,start); +} + +// decode a buffer with Utf8 chars to a JS string +// invalid characters are ignored +function h$decodeUtf8(v,n0,start) { +// h$log("### decodeUtf8"); +// h$log(v); + var n = n0 || v.len; + var arr = []; + var i = start || 0; + var code; + var u8 = v.u8; +// h$log("### decoding, starting at: " + i); + while(i < n) { + var c = u8[i]; + while((c & 0xC0) === 0x80) { + c = u8[++i]; + } +// h$log("### lead char: " + c); + if((c & 0x80) === 0) { + code = (c & 0x7F); + i++; + } else if((c & 0xE0) === 0xC0) { + code = ( ((c & 0x1F) << 6) + | (u8[i+1] & 0x3F) + ); + i+=2; + } else if((c & 0xF0) === 0xE0) { + code = ( ((c & 0x0F) << 12) + | ((u8[i+1] & 0x3F) << 6) + | (u8[i+2] & 0x3F) + ); + i+=3; + } else if ((c & 0xF8) === 0xF0) { + code = ( ((c & 0x07) << 18) + | ((u8[i+1] & 0x3F) << 12) + | ((u8[i+2] & 0x3F) << 6) + | (u8[i+3] & 0x3F) + ); + i+=4; + } else if((c & 0xFC) === 0xF8) { + code = ( ((c & 0x03) << 24) + | ((u8[i+1] & 0x3F) << 18) + | ((u8[i+2] & 0x3F) << 12) + | ((u8[i+3] & 0x3F) << 6) + | (u8[i+4] & 0x3F) + ); + i+=5; + } else { + code = ( ((c & 0x01) << 30) + | ((u8[i+1] & 0x3F) << 24) + | ((u8[i+2] & 0x3F) << 18) + | ((u8[i+3] & 0x3F) << 12) + | ((u8[i+4] & 0x3F) << 6) + | (u8[i+5] & 0x3F) + ); + i+=6; + } + // h$log("### decoded codePoint: " + code + " - " + String.fromCharCode(code)); // String.fromCodePoint(code)); + // need to deal with surrogate pairs + if(code > 0xFFFF) { + var offset = code - 0x10000; + arr.push(0xD800 + (offset >> 10), 0xDC00 + (offset & 0x3FF)); + } else { + arr.push(code); + } + } + return h$charCodeArrayToString(arr); +} + +// fixme what if terminator, then we read past end +function h$decodeUtf16(v) { + var n = v.len; + var arr = []; + var dv = v.dv; + for(var i=0;i<n;i+=2) { + arr.push(dv.getUint16(i,true)); + } + return h$charCodeArrayToString(arr); +} + +function h$charCodeArrayToString(arr) { + if(arr.length <= 60000) { + return String.fromCharCode.apply(this, arr); + } + var r = ''; + for(var i=0;i<arr.length;i+=60000) { + r += String.fromCharCode.apply(this, arr.slice(i, i+60000)); + } + return r; +} + +function h$hs_iconv_open(to,to_off,from,from_off) { + h$errno = h$EINVAL; // no encodings supported + return -1; +// var fromStr = decodeUtf8(from, from_off); +// var toStr = decodeUtf8(to, to_off); +// h$log("#### hs_iconv_open: " + fromStr + " -> " + toStr); +// return 1; // fixme? +} + +function h$hs_iconv_close(iconv) { + return 0; +} + +// ptr* -> ptr (array) +function h$derefPtrA(ptr, ptr_off) { + return ptr.arr[ptr_off][0]; +} +// ptr* -> ptr (offset) +function h$derefPtrO(ptr, ptr_off) { + return ptr.arr[ptr_off][1]; +} + +// word** -> word ptr[x][y] +function h$readPtrPtrU32(ptr, ptr_off, x, y) { + x = x || 0; + y = y || 0; + var arr = ptr.arr[ptr_off + 4 * x]; + return arr[0].dv.getInt32(arr[1] + 4 * y, true); +} + +// char** -> char ptr[x][y] +function h$readPtrPtrU8(ptr, ptr_off, x, y) { + x = x || 0; + y = y || 0; + var arr = ptr.arr[ptr_off + 4 * x]; + return arr[0].dv.getUint8(arr[1] + y); +} + +// word** ptr[x][y] = v +function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { + x = x || 0; + y = y || 0; + var arr = ptr.arr[ptr_off + 4 * x]; + arr[0].dv.putInt32(arr[1] + y, v); +} + +// unsigned char** ptr[x][y] = v +function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { + x = x || 0; + y = y || 0; + var arr = ptr.arr[ptr_off+ 4 * x]; + arr[0].dv.putUint8(arr[1] + y, v); +} + +// convert JavaScript String to a Haskell String +#ifdef GHCJS_PROF +function h$toHsString(str, cc) { +#else +function h$toHsString(str) { +#endif + if(typeof str !== 'string') return HS_NIL; + var i = str.length - 1; + var r = HS_NIL; + while(i>=0) { + var cp = str.charCodeAt(i); + if(cp >= 0xDC00 && cp <= 0xDFFF && i > 0) { + --i; + cp = (cp - 0xDC00) + (str.charCodeAt(i) - 0xD800) * 1024 + 0x10000; + } + r = MK_CONS_CC(cp, r, cc); + --i; + } + return r; +} + +// string must have been completely forced first +function h$fromHsString(str) { + var xs = ''; + while(IS_CONS(str)) { + var h = CONS_HEAD(str); + xs += String.fromCharCode(UNWRAP_NUMBER(h)); + str = CONS_TAIL(str); + } + return xs; +} + +// list of JSVal to array, list must have been completely forced first +function h$fromHsListJSVal(xs) { + var arr = []; + while(IS_CONS(xs)) { + arr.push(JSVAL_VAL(CONS_HEAD(xs))); + xs = CONS_TAIL(xs); + } + return arr; +} + +// ascii only version of the above +#ifdef GHCJS_PROF +function h$toHsStringA(str, cc) { +#else +function h$toHsStringA(str) { +#endif + if(typeof str !== 'string') return HS_NIL; + var i = str.length - 1; + var r = HS_NIL; + while(i>=0) { + r = MK_CONS_CC(str.charCodeAt(i), r, cc); + --i; + } + return r; +} + +// convert array with modified UTF-8 encoded text +#ifdef GHCJS_PROF +function h$toHsStringMU8(arr, cc) { +#else +function h$toHsStringMU8(arr) { +#endif + var i = arr.length - 1, accept = false, b, n = 0, cp = 0, r = HS_NIL; + while(i >= 0) { + b = arr[i]; + if(!(b & 128)) { + cp = b; + accept = true; + } else if((b & 192) === 128) { + cp += (b & 32) * Math.pow(64, n) + } else { + cp += (b&((1<<(6-n))-1)) * Math.pow(64, n); + accept = true; + } + if(accept) { + r = MK_CONS_CC(cp, r, cc); + cp = 0 + n = 0; + } else { + n++; + } + accept = false; + i--; + } + return r; +} + +#ifdef GHCJS_PROF +function h$toHsList(arr, cc) { +#else +function h$toHsList(arr) { +#endif + var r = HS_NIL; + for(var i=arr.length-1;i>=0;i--) { + r = MK_CONS_CC(arr[i], r, cc); + } + return r; +} + +// array of JS values to Haskell list of JSVal +#ifdef GHCJS_PROF +function h$toHsListJSVal(arr, cc) { +#else +function h$toHsListJSVal(arr) { +#endif + var r = HS_NIL; + for(var i=arr.length-1;i>=0;i--) { + r = MK_CONS_CC(MK_JSVAL(arr[i]), r, cc); + } + return r; +} + +// unpack ascii string, append to existing Haskell string +#ifdef GHCJS_PROF +function h$appendToHsStringA(str, appendTo, cc) { +#else +function h$appendToHsStringA(str, appendTo) { +#endif + var i = str.length - 1; + var r = appendTo; + while(i>=0) { + r = MK_CONS_CC(str.charCodeAt(i), r, cc); + --i; + } + return r; +} + +// throw e wrapped in a GHCJS.Prim.JSException in the current thread +function h$throwJSException(e) { + // create a JSException object and wrap it in a SomeException + // adding the Exception dictionary + var strVal; + if(typeof e === 'string') { + strVal = e; + } else if(e instanceof Error) { + strVal = e.toString() + '\n' + Array.prototype.join.call(e.stack, '\n'); + } else { + strVal = "" + e; + } + var someE = MK_SOMEEXCEPTION(HS_JSEXCEPTION_EXCEPTION, + MK_JSEXCEPTION(MK_JSVAL(e), h$toHsString(strVal)) + ); + return h$throw(someE, true); +} diff --git a/rts/js/structs.js b/rts/js/structs.js new file mode 100644 index 0000000000..15d435df2d --- /dev/null +++ b/rts/js/structs.js @@ -0,0 +1,463 @@ +//#OPTIONS: CPP + +/* + simple set with reasonably fast iteration though an array, which may contain nulls + elements must be objects that have a unique _key property + collections are expected to be homogeneous + + when iterating over a set with an iterator, the following operations are safe: + + - adding an element to the set (the existing iterator will iterate over the new elements) + - removing the last returned element through the iterator + + behaviour for deleting elements is unpredictable and unsafe +*/ + +/** @constructor */ +function h$Set(s) { + this._vals = []; + this._keys = []; + this._size = 0; +} + +h$Set.prototype.size = function() { + return this._size; +} + +h$Set.prototype.add = function(o) { +#ifdef GHCJS_STRUCTS_ASSERTS + if((typeof o !== 'object' && typeof o !== 'function') || typeof o._key !== 'number') throw ("h$Set.add: invalid element: " + o); + if(this._size > 0) { +// if(this._storedProto !== o.prototype) throw ("h$Set.add: unexpected element prototype: " + o) + } else { + this._storedProto = o.prototype; + } + if(this._keys[o._key] !== undefined && this._vals[this._keys[o._key]] !== o) throw ("h$Set.add: duplicate key: " + o); +#endif + var k = this._keys, v = this._vals; + if(k[o._key] === undefined) { + k[o._key] = this._size; + v[this._size++] = o; + } +} + +h$Set.prototype.remove = function(o) { + if(this._size === 0) return; + var k = this._keys, v = this._vals, x = k[o._key]; + if(x !== undefined) { + delete k[o._key]; + var ls = --this._size; + if(ls !== x) { + var l = v[ls]; + v[x] = l; + k[l._key] = x; + } + v[ls] = undefined; + if(v.length > 10 && 2 * v.length > 3 * ls) this._vals = v.slice(0, ls); + } +} + +h$Set.prototype.has = function(o) { + return this._keys[o._key] !== undefined; +} + +h$Set.prototype.clear = function() { + if(this._size > 0) { + this._keys = []; + this._vals = []; + this._size = 0; + } +} + +h$Set.prototype.iter = function() { + return new h$SetIter(this); +} + +// returns an array with all values, might contain additional nulls at the end +h$Set.prototype.values = function() { + return this._vals; +} + +/** @constructor */ +function h$SetIter(s) { + this._n = 0; + this._s = s; + this._r = true; +} + +h$SetIter.prototype.next = function() { + if(this._n < this._s._size) { + this._r = false; + return this._s._vals[this._n++]; + } else { + this._r = true; + return null; + } +} + +h$SetIter.prototype.peek = function() { + if(this._n < this._s._size) { + return this._s._vals[this._n]; + } else { + return null; + } +} + +// remove the last element returned +h$SetIter.prototype.remove = function() { + if(!this._r) { + this._s.remove(this._s._vals[--this._n]); + this._r = true; + } +} + +/* + map, iteration restrictions are the same as for set + keys need to be objects with a unique _key property + + keys are expected to have the same prototype + + values may be anything (but note that the values array might have additional nulls) +*/ + +/** @constructor */ +function h$Map() { + this._pairsKeys = []; + this._pairsValues = []; + this._keys = []; + this._size = 0; +} + +h$Map.prototype.size = function() { + return this._size; +} + +h$Map.prototype.put = function(k,v) { +#ifdef GHCJS_STRUCTS_ASSERTS + if((typeof k !== 'object' && typeof k !== 'function') || typeof k._key !== 'number') throw ("h$Map.add: invalid key: " + k); + if(this._size > 0) { + if(this._storedProto !== k.prototype) throw ("h$Map.add: unexpected key prototype: " + k) + } else { + this._storedProto = k.prototype; + } + if(this._keys[k._key] !== undefined && this._pairsKeys[this._keys[k._key]] !== k) throw ("h$Map.add: duplicate key: " + k); +#endif + var ks = this._keys, pk = this._pairsKeys, pv = this._pairsValues, x = ks[k._key]; + if(x === undefined) { + var n = this._size++; + ks[k._key] = n; + pk[n] = k; + pv[n] = v; + } else { + pv[x] = v; + } +} + +h$Map.prototype.remove = function(k) { + var kk = k._key, ks = this._keys, pk = this._pairsKeys, pv = this._pairsValues, x = ks[kk]; + if(x !== undefined) { + delete ks[kk]; + var ss = --this._size; + if(ss !== x) { + var pks = pk[ss]; + pk[x] = pks; + pv[x] = pv[ss]; + ks[pks._key] = x; + } + pv[ss] = undefined; + pk[ss] = undefined; + + if(pk.length > 10 && 2 * pk.length > 3 * this._size) { + this._pairsKeys = pk.slice(0,ss); + this._pairsValues = pv.slice(0,ss); + } + } +} + +h$Map.prototype.has = function(k) { + return this._keys[k._key] !== undefined; +} + +h$Map.prototype.get = function(k) { + var n = this._keys[k._key]; + if(n !== undefined) { + return this._pairsValues[n]; + } else { + return null; + } +} + +h$Map.prototype.iter = function() { + return new h$MapIter(this); +} + +// returned array might have some trailing nulls +h$Map.prototype.keys = function () { + return this._pairsKeys; +} + +// returned array might have some trailing nulls +h$Map.prototype.values = function() { + return this._pairsValues; +} + +/** @constructor */ +function h$MapIter(m) { + this._n = 0; + this._m = m; +} + +h$MapIter.prototype.next = function() { + return this._n < this._m._size ? this._m._pairsKeys[this._n++] : null; +} + +h$MapIter.prototype.nextVal = function() { + return this._n < this._m._size ? this._m._pairsValues[this._n++] : null; +} + +h$MapIter.prototype.peek = function() { + return this._n < this._m._size ? this._m._pairsKeys[this._n] : null; +} + +h$MapIter.prototype.peekVal = function() { + return this._n < this._m._size ? this._m._pairsValues[this._n] : null; +} + +/* + simple queue, returns null when empty + it's safe to enqueue new items while iterating, not safe to dequeue + (new items will not be iterated over) +*/ +#ifndef GHCJS_QUEUE_BLOCK_SIZE +#define GHCJS_QUEUE_BLOCK_SIZE 1000 +#endif + +/** @constructor */ +function h$Queue() { + var b = { b: [], n: null }; + this._blocks = 1; + this._first = b; + this._fp = 0; + this._last = b; + this._lp = 0; +} + +h$Queue.prototype.length = function() { + return GHCJS_QUEUE_BLOCK_SIZE * (this._blocks - 1) + this._lp - this._fp; +} + +h$Queue.prototype.isEmpty = function() { + return this._blocks === 1 && this._lp >= this._fp; +} + +h$Queue.prototype.enqueue = function(o) { + if(this._lp === GHCJS_QUEUE_BLOCK_SIZE) { + var newBlock = { b: [o], n: null }; + this._blocks++; + this._last.n = newBlock; + this._last = newBlock; + this._lp = 1; + } else { + this._last.b[this._lp++] = o; + } +} + +h$Queue.prototype.dequeue = function() { + if(this._blocks === 1 && this._fp >= this._lp) { + return null; + } else { + var qfb = this._first.b, r = qfb[this._fp]; + qfb[this._fp] = null; + if(++this._fp === GHCJS_QUEUE_BLOCK_SIZE) { + if(this._blocks === 1) { + this._lp = 0; + } else { + this._blocks--; + this._first = this._first.n; + } + this._fp = 0; + } else if(this._blocks === 1 && this._fp >= this._lp) { + this._lp = this._fp = 0; + } + return r; + } +} + +h$Queue.prototype.peek = function() { + if(this._blocks === 0 || (this._blocks === 1 && this._fp >= this._lp)) { + return null; + } else { + return this._first.b[this._fp]; + } +} + +h$Queue.prototype.iter = function() { + var b = this._first, bp = this._fp, lb = this._last, lp = this._lp; + return function() { + if(b === null || (b === lb && bp >= lp)) { + return null; + } else { + var r = b.b[bp]; + if(++bp === GHCJS_QUEUE_BLOCK_SIZE) { + b = b.n; + bp = 0; + if(b === null) lb = null; + } + return r; + } + } +} + +/* + binary min-heap / set + - iteration is not in order of priority + - values can be removed, need to have the ._key property +*/ + +/** @constructor */ +function h$HeapSet() { + this._keys = []; + this._prios = []; + this._vals = []; + this._size = 0; +} + +h$HeapSet.prototype.size = function() { + return this._size; +} + +// add a node, if it already exists, it's moved to the new priority +h$HeapSet.prototype.add = function(op,o) { +#ifdef GHCJS_STRUCTS_ASSERTS + if((typeof o !== 'object' && typeof o !== 'function') || typeof o._key !== 'number') throw ("h$HeapSet.add: invalid element: " + o); + if(this._size > 0) { + if(this._storedProto !== o.prototype) throw ("h$HeapSet.add: unexpected element prototype: " + o) + } else { + this._storedProto = o.prototype; + } + if(this._keys[o._key] !== undefined && this._vals[this._keys[o._key]] !== o) throw ("h$Set.add: duplicate key: " + o); +#endif + var p = this._prios, k = this._keys, v = this._vals, x = k[o._key]; + if(x !== undefined) { // adjust node + var oop = p[x]; + if(oop !== op) { + p[x] = op; + if(op < oop) { + this._upHeap(x); + } else { + this._downHeap(x, this._size); + } + } + } else { // new node + var s = this._size++; + k[o._key] = s; + p[s] = op; + v[s] = o; + this._upHeap(s); + } +} + +h$HeapSet.prototype.has = function(o) { + return this._keys[o._key] !== undefined; +} + +h$HeapSet.prototype.prio = function(o) { + var x = this._keys[o._key]; + if(x !== undefined) { + return this._prios[x]; + } else { + return null; + } +} + +h$HeapSet.prototype.peekPrio = function() { + return this._size > 0 ? this._prios[0] : null; +} + +h$HeapSet.prototype.peek = function() { + return this._size > 0 ? this._vals[0] : null; +} + +h$HeapSet.prototype.pop = function() { + if(this._size > 0) { + var v = this._vals[0]; + this._removeNode(0); + return v; + } else { + return null; + } +} + +h$HeapSet.prototype.remove = function(o) { + var x = this._keys[o._key]; + if(x !== undefined) this._removeNode(x); +} + +h$HeapSet.prototype.iter = function() { + var n = 0, v = this._vals, s = this._size; + return function() { + return n < s ? v[n++] : null; + } +} + +// may be longer than this.size(), remainder is filled with nulls +h$HeapSet.prototype.values = function() { + return this._vals; +} + +h$HeapSet.prototype._removeNode = function(i) { + var p = this._prios, v = this._vals, s = --this._size, k = this._keys; + delete k[v[i]._key]; + if(i !== s) { + v[i] = v[s]; + p[i] = p[s]; + k[v[i]._key] = i; + } + v[s] = null; + p[s] = null; + this._downHeap(i,s); +} + +h$HeapSet.prototype._downHeap = function(i,s) { + var p = this._prios, v = this._vals, k = this._keys; + var j,l,r,ti,tj; + while(true) { + j = i, r = 2*(i+1), l = r-1; + if(l < s && p[l] < p[i]) i = l; + if(r < s && p[r] < p[i]) i = r; + if(i !== j) { + ti = v[i]; + tj = v[j]; + v[j] = ti; + v[i] = tj; + k[ti._key] = j; + k[tj._key] = i; + ti = p[i]; + p[i] = p[j]; + p[j] = ti; + } else { + break; + } + } +} + +h$HeapSet.prototype._upHeap = function(i) { + var ti, tj, j, p = this._prios, v = this._vals, k = this._keys; + while(i !== 0) { + j = (i-1) >> 1; + if(p[i] < p[j]) { + ti = v[i]; + tj = v[j]; + v[j] = ti; + v[i] = tj; + k[ti._key] = j; + k[tj._key] = i; + ti = p[i]; + p[i] = p[j]; + p[j] = ti; + i = j; + } else { + break; + } + } +} diff --git a/rts/js/thread.js b/rts/js/thread.js new file mode 100644 index 0000000000..b284b3209d --- /dev/null +++ b/rts/js/thread.js @@ -0,0 +1,1432 @@ +//#OPTIONS: CPP + +// preemptive threading support + +// run gc when this much time has passed (ms) +#ifndef GHCJS_GC_INTERVAL +#define GHCJS_GC_INTERVAL 1000 +#endif + +// preempt threads after the scheduling quantum (ms) +#ifndef GHCJS_SCHED_QUANTUM +#define GHCJS_SCHED_QUANTUM 25 +#endif + +// check sched quantum after 10*GHCJS_SCHED_CHECK calls +#ifndef GHCJS_SCHED_CHECK +#define GHCJS_SCHED_CHECK 1000 +#endif + +// yield to js after running haskell for GHCJS_BUSY_YIELD ms +#ifndef GHCJS_BUSY_YIELD +#define GHCJS_BUSY_YIELD 500 +#endif + +// Watch for insertion of null or undefined in the stack +//#define GHCJS_DEBUG_STACK + +#ifdef GHCJS_TRACE_SCHEDULER +function h$logSched() { if(arguments.length == 1) { + if(h$currentThread != null) { + h$log((Date.now()/1000) + " sched: " + h$threadString(h$currentThread) + + "[" + h$currentThread.mask + "," + + (h$currentThread.interruptible?1:0) + "," + + h$currentThread.excep.length + + "] -> " + arguments[0]); + } else { + h$log("sched: " + h$threadString(h$currentThread) + " -> " + arguments[0]); + } + } else { + h$log.apply(log,arguments); + } + } +#define TRACE_SCHEDULER(args...) h$logSched(args) +#else +#define TRACE_SCHEDULER(args...) +#endif + +#ifdef GHCJS_TRACE_CALLS +// print function to be called from trampoline and first few registers +function h$logCall(c) { + var f = c; + if(c && c.n) { + f = c.n; + } else { + f = c.toString().substring(0,20); // h$collectProps(c); + } + h$log(h$threadString(h$currentThread) + ":" + h$sp + " calling: " + f + " " + JSON.stringify([h$printReg(h$r1), h$printReg(h$r2), h$printReg(h$r3), h$printReg(h$r4), h$printReg(h$r5)])); + h$checkStack(c); +} +#endif + +var h$threadIdN = 0; + +// all threads except h$currentThread +// that are not finished/died can be found here +var h$threads = new h$Queue(); +var h$blocked = new h$Set(); + +/** @constructor */ +function h$Thread() { + this.tid = ++h$threadIdN; + this.status = THREAD_RUNNING; + this.stack = [h$done, 0, h$baseZCGHCziConcziSynczireportError, h$catch_e]; +#ifdef GHCJS_DEBUG_STACK + this.stack = new Proxy(this.stack, { + set(obj,prop,value) { + if (value === undefined || value === null) { + throw new Error("setting stack offset " + prop + " to " + value); + } + else { + return Reflect.set(...arguments); + } + } + }); +#endif + this.sp = 3; + this.mask = 0; // async exceptions masked (0 unmasked, 1: uninterruptible, 2: interruptible) + this.interruptible = false; // currently in an interruptible operation + this.excep = []; // async exceptions waiting for unmask of this thread + this.delayed = false; // waiting for threadDelay + this.blockedOn = null; // object on which thread is blocked + this.retryInterrupted = null; // how to retry blocking operation when interrupted + this.transaction = null; // for STM + this.noPreemption = false; + this.isSynchronous = false; + this.continueAsync = false; + this.m = 0; // gc mark + this.result = null; // result value (used for GHCJS.Foreign.Callback) + this.resultIsException = false; +#ifdef GHCJS_PROF + this.ccs = h$CCS_SYSTEM; // cost-centre stack +#endif + this._key = this.tid; // for storing in h$Set / h$Map +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_notifyAlloc(this); +#endif +} + +function h$rts_getThreadId(t) { + return t.tid; +} + +function h$cmp_thread(t1,t2) { + if(t1.tid < t2.tid) return -1; + if(t1.tid > t2.tid) return 1; + return 0; +} + +// description of the thread, if unlabeled then just the thread id +function h$threadString(t) { + if(t === null) { + return "<no thread>"; + } else if(t.label) { + var str = h$decodeUtf8z(t.label[0], t.label[1]); + return str + " (" + t.tid + ")"; + } else { + return (""+t.tid); + } +} + +function h$fork(a, inherit) { + h$r1 = h$forkThread(a, inherit); + return h$yield(); +} + +function h$forkThread(a, inherit) { + var t = new h$Thread(); + TRACE_SCHEDULER("sched: forking: " + h$threadString(t)) + if(inherit && h$currentThread) { + t.mask = h$currentThread.mask; + } +#ifdef GHCJS_PROF + t.ccs = h$CCS_MAIN; +#endif + // TRACE_SCHEDULER("sched: action forked: " + a.f.n) + t.stack[4] = h$ap_1_0; + t.stack[5] = a; + t.stack[6] = h$return; + t.sp = 6; + h$wakeupThread(t); + return t; +} + +function h$threadStatus(t) { + // status, capability, locked + RETURN_UBX_TUP3(t.status, 1, 0); +} + +function h$waitRead(fd) { + h$fds[fd].waitRead.push(h$currentThread); + h$currentThread.interruptible = true; + return h$blockThread(h$currentThread,fd,[h$waitRead,fd]); +} + +function h$waitWrite(fd) { + h$fds[fd].waitWrite.push(h$currentThread); + h$currentThread.interruptible = true; + return h$blockThread(h$currentThread,fd,[h$waitWrite,fd]); +} + +// threadDelay support: +var h$delayed = new h$HeapSet(); +function h$wakeupDelayed(now) { + while(h$delayed.size() > 0 && h$delayed.peekPrio() < now) { + var t = h$delayed.pop(); + TRACE_SCHEDULER("delay timeout expired: " + t.tid) + // might have been woken up early, don't wake up again in that case + if(t.delayed) { + t.delayed = false; + h$wakeupThread(t); + } + } +} + +function h$delayThread(time) { + var ms = time/1000; // we have no microseconds in JS + return h$delayThreadMs(ms); +} + +function h$sleep(secs) { + return h$delayThreadMs(secs*1000); +} + +function h$delayThreadMs(ms) { + var now = Date.now(); + TRACE_SCHEDULER("delaying " + h$threadString(h$currentThread) + " " + ms + "ms (" + (now+ms) + ")") + h$delayed.add(now+ms, h$currentThread); + h$currentThread.delayed = true; + h$currentThread.interruptible = true; + return h$blockThread(h$currentThread, h$delayed,[h$resumeDelayThread]); +} + +function h$resumeDelayThread() { + h$r1 = false; + return h$rs(); // stack[h$sp]; +} + +function h$yield() { + if(h$currentThread.isSynchronous) { + return h$stack[h$sp]; + } else { + h$sp += 2; + h$stack[h$sp-1] = h$r1; + h$stack[h$sp] = h$return; + h$currentThread.sp = h$sp; + return h$reschedule; + } +} + +// raise the async exception in the thread if not masked +function h$killThread(t, ex) { + TRACE_SCHEDULER("killThread: " + h$threadString(t)) + if(t === h$currentThread) { + // if target is self, then throw even if masked + h$sp += 2; + h$stack[h$sp-1] = h$r1; + h$stack[h$sp] = h$return; + return h$throw(ex,true); + } else { + TRACE_SCHEDULER("killThread mask: " + t.mask) + if(t.mask === 0 || (t.mask === 2 && t.interruptible)) { + if(t.stack) { // finished threads don't have a stack anymore + h$forceWakeupThread(t); + t.sp += 2; + t.stack[t.sp-1] = ex; + t.stack[t.sp] = h$raiseAsync_frame; + } + return h$stack ? h$stack[h$sp] : null; + } else { + t.excep.push([h$currentThread,ex]); + if(h$currentThread) { + h$currentThread.interruptible = true; + h$sp += 2; + h$stack[h$sp-1] = h$r1; + h$stack[h$sp] = h$return; + return h$blockThread(h$currentThread,t,null); + } else { + return null; + } + } + } +} + +function h$maskStatus() { + TRACE_SCHEDULER("mask status: " + h$currentThread.mask) + return h$currentThread.mask; +} + +function h$maskAsync(a) { + TRACE_SCHEDULER("mask: thread " + h$threadString(h$currentThread)) + if(h$currentThread.mask !== 2) { + if(h$currentThread.mask === 0 && h$stack[h$sp] !== h$maskFrame && h$stack[h$sp] !== h$maskUnintFrame) { + h$stack[++h$sp] = h$unmaskFrame; + } + if(h$currentThread.mask === 1) { + h$stack[++h$sp] = h$maskUnintFrame; + } + h$currentThread.mask = 2; + } + h$r1 = a; + return h$ap_1_0_fast(); +} + +function h$maskUnintAsync(a) { + TRACE_SCHEDULER("mask unint: thread " + h$threadString(h$currentThread)) + if(h$currentThread.mask !== 1) { + if(h$currentThread.mask === 2) { + h$stack[++h$sp] = h$maskFrame; + } else { + h$stack[++h$sp] = h$unmaskFrame; + } + h$currentThread.mask = 1; + } + h$r1 = a; + return h$ap_1_0_fast(); +} + +function h$unmaskAsync(a) { + TRACE_SCHEDULER("unmask: " + h$threadString(h$currentThread)) + if(h$currentThread.excep.length > 0) { + h$currentThread.mask = 0; + h$sp += 3; + h$stack[h$sp-2] = h$ap_1_0; + h$stack[h$sp-1] = a; + h$stack[h$sp] = h$return; + return h$reschedule; + } + if(h$currentThread.mask !== 0) { + if(h$stack[h$sp] !== h$unmaskFrame) { + if(h$currentThread.mask === 2) { + h$stack[++h$sp] = h$maskFrame; + } else { + h$stack[++h$sp] = h$maskUnintFrame; + } + } + h$currentThread.mask = 0; + } + h$r1 = a; + return h$ap_1_0_fast(); +} + +function h$pendingAsync() { + var t = h$currentThread; + return (t.excep.length > 0 && (t.mask === 0 || (t.mask === 2 && t.interruptible))); +} + +// post the first of the queued async exceptions to +// this thread, restore frame is in thread if alreadySuspended + +function h$postAsync(alreadySuspended,next) { + var t = h$currentThread; + var v = t.excep.shift(); + TRACE_SCHEDULER("posting async to " + h$threadString(t) + " mask status: " + t.mask + " remaining exceptions: " + t.excep.length) + var tposter = v[0]; // posting thread, blocked + var ex = v[1]; // the exception + if(v !== null && tposter !== null) { + h$wakeupThread(tposter); + } + if(!alreadySuspended) { + h$suspendCurrentThread(next); + } + h$sp += 2; + h$stack[h$sp-1] = ex; + h$stack[h$sp] = h$raiseAsync_frame; + t.sp = h$sp; +} + +// wakeup thread, thread has already been removed +// from any queues it was blocked on +function h$wakeupThread(t) { + TRACE_SCHEDULER("sched: waking up: " + h$threadString(t)) + if(t.status === THREAD_BLOCKED) { + t.blockedOn = null; + t.status = THREAD_RUNNING; + h$blocked.remove(t); + } + t.interruptible = false; + t.retryInterrupted = null; + h$threads.enqueue(t); + h$startMainLoop(); +} + +// force wakeup, remove this thread from any +// queue it's blocked on +function h$forceWakeupThread(t) { + TRACE_SCHEDULER("forcing wakeup of: " + h$threadString(t)) + if(t.status === THREAD_BLOCKED) { + h$removeThreadBlock(t); + h$wakeupThread(t); + } +} + +function h$removeThreadBlock(t) { + var i; + if(t.status === THREAD_BLOCKED) { + var o = t.blockedOn; + if(o === null || o === undefined) { + throw ("h$removeThreadBlock: blocked on null or undefined: " + h$threadString(t)); + } else if(o === h$delayed) { + // thread delayed + h$delayed.remove(t); + t.delayed = false; + } else if(o instanceof h$MVar) { + TRACE_SCHEDULER("blocked on MVar") + TRACE_SCHEDULER("MVar before: " + o.readers.length() + " " + o.writers.length() + " " + o.waiters.length) + // fixme this is rather inefficient + var r, rq = new h$Queue(); + while((r = o.readers.dequeue()) !== null) { + if(r !== t) rq.enqueue(r); + } + var w, wq = new h$Queue(); + while ((w = o.writers.dequeue()) !== null) { + if(w[0] !== t) wq.enqueue(w); + } + o.readers = rq; + o.writers = wq; + if(o.waiters) { + var wa = [], wat; + for(i=0;i<o.waiters.length;i++) { + wat = o.waiters[i]; + if(wat !== t) wa.push(wat); + } + o.waiters = wa; + } + TRACE_SCHEDULER("MVar after: " + o.readers.length() + " " + o.writers.length() + " " + o.waiters.length) +/* } else if(o instanceof h$Fd) { + TRACE_SCHEDULER("blocked on fd") + h$removeFromArray(o.waitRead,t); + h$removeFromArray(o.waitWrite,t); */ + } else if(o instanceof h$Thread) { + TRACE_SCHEDULER("blocked on async exception") + // set thread (first in pair) to null, exception will still be delivered + // but this thread not woken up again + // fixme: are these the correct semantics? + for(i=0;i<o.excep.length;i++) { + if(o.excep[i][0] === t) { + o.excep[i][0] = null; + break; + } + } + } else if (o instanceof h$TVarsWaiting) { + h$stmRemoveBlockedThread(o, t) + } else if(IS_BLACKHOLE(o)) { + TRACE_SCHEDULER("blocked on blackhole") + h$removeFromArray(BLACKHOLE_QUEUE(o),t); + } else { + throw ("h$removeThreadBlock: blocked on unknown object: " + h$collectProps(o)); + } + if(t.retryInterrupted) { + t.sp+=2; + t.stack[t.sp-1] = t.retryInterrupted; + t.stack[t.sp] = h$retryInterrupted; + } + } +} + +function h$removeFromArray(a,o) { + var i; + while((i = a.indexOf(o)) !== -1) { + a.splice(i,1); + } +} + +function h$finishThread(t) { + TRACE_SCHEDULER("sched: finishing: " + h$threadString(t)) + t.status = THREAD_FINISHED; + h$blocked.remove(t); + t.stack = null; + t.mask = 0; + for(var i=0;i<t.excep.length;i++) { + var v = t.excep[i]; + var tposter = v[0]; + if(v !== null && tposter !== null) { + h$wakeupThread(tposter); + } + } + t.excep = []; +} + +function h$blockThread(t,o,resume) { + TRACE_SCHEDULER("sched: blocking: " + h$threadString(t)) + if(t !== h$currentThread) { + throw "h$blockThread: blocked thread is not the current thread"; + } + if(o === undefined || o === null) { + throw ("h$blockThread, no block object: " + h$threadString(t)); + } + t.status = THREAD_BLOCKED; + t.blockedOn = o; + t.retryInterrupted = resume; + t.sp = h$sp; + h$blocked.add(t); + return h$reschedule; +} + +// the main scheduler, called from h$mainLoop +// returns null if nothing to do, otherwise +// the next function to run +var h$lastGc = Date.now(); +var h$gcInterval = GHCJS_GC_INTERVAL; // ms +function h$scheduler(next) { + TRACE_SCHEDULER("sched: scheduler: " + h$sp) + // if we have a running synchronous thread, the only thing we can do is continue + if(h$currentThread && + h$currentThread.isSynchronous && + h$currentThread.status === THREAD_RUNNING) { + return next; + } + var now = Date.now(); + h$wakeupDelayed(now); + // find the next runnable thread in the run queue + // remove non-runnable threads + if(h$currentThread && h$pendingAsync()) { + TRACE_SCHEDULER("sched: received async exception, continuing thread") + if(h$currentThread.status !== THREAD_RUNNING) { + h$forceWakeupThread(h$currentThread); + h$currentThread.status = THREAD_RUNNING; + } + h$postAsync(next === h$reschedule, next); + return h$stack[h$sp]; + } + var t; + while(t = h$threads.dequeue()) { + if(t.status === THREAD_RUNNING) { break; } + } + // if no other runnable threads, just continue current (if runnable) + if(t === null) { + TRACE_SCHEDULER("sched: no other runnable threads") + if(h$currentThread && h$currentThread.status === THREAD_RUNNING) { + // do gc after a while + if(now - h$lastGc > h$gcInterval) { + // save active data for the thread on its stack + if(next !== h$reschedule && next !== null) { + h$suspendCurrentThread(next); + next = h$stack[h$sp]; + } + var ct = h$currentThread; + h$currentThread = null; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + h$gc(ct); + h$currentThread = ct; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + // gc might replace the stack of a thread, so reload it + h$stack = h$currentThread.stack; + h$sp = h$currentThread.sp + } + TRACE_SCHEDULER("sched: continuing: " + h$threadString(h$currentThread)) + return (next===h$reschedule || next === null)?h$stack[h$sp]:next; // just continue + } else { + TRACE_SCHEDULER("sched: pausing") + h$currentThread = null; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + // We could set a timer here so we do a gc even if Haskell pauses for a long time. + // However, currently this isn't necessary because h$mainLoop always sets a timer + // before it pauses. + if(now - h$lastGc > h$gcInterval) + h$gc(null); + return null; // pause the haskell runner + } + } else { // runnable thread in t, switch to it + TRACE_SCHEDULER("sched: switching to: " + h$threadString(t)) + if(h$currentThread !== null) { + if(h$currentThread.status === THREAD_RUNNING) { + h$threads.enqueue(h$currentThread); + } + // if h$reschedule called, thread takes care of suspend + if(next !== h$reschedule && next !== null) { + TRACE_SCHEDULER("sched: suspending: " + h$threadString(h$currentThread)) + // suspend thread: push h$restoreThread stack frame + h$suspendCurrentThread(next); + } else { + TRACE_SCHEDULER("sched: no suspend needed, reschedule called from: " + h$threadString(h$currentThread)) + h$currentThread.sp = h$sp; + } + if(h$pendingAsync()) h$postAsync(true, next); + } else { + TRACE_SCHEDULER("sched: no suspend needed, no running thread") + } + // gc if needed + if(now - h$lastGc > h$gcInterval) { + h$currentThread = null; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + h$gc(t); + } + // schedule new one + h$currentThread = t; + h$stack = t.stack; + h$sp = t.sp; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + TRACE_SCHEDULER("sched: scheduling " + h$threadString(t) + " sp: " + h$sp) + // TRACE_SCHEDULER("sp thing: " + h$stack[h$sp].n) + // h$dumpStackTop(h$stack,0,h$sp); + return h$stack[h$sp]; + } +} + +function h$scheduleMainLoop() { + TRACE_SCHEDULER("scheduling next main loop wakeup") + if(h$mainLoopImmediate) return; + h$clearScheduleMainLoop(); + if(h$delayed.size() === 0) { +#ifndef GHCJS_BROWSER + if(typeof setTimeout !== 'undefined') { +#endif + TRACE_SCHEDULER("scheduling main loop wakeup in " + h$gcInterval + "ms") + h$mainLoopTimeout = setTimeout(h$mainLoop, h$gcInterval); +#ifndef GHCJS_BROWSER + } +#endif + return; + } + var now = Date.now(); + var delay = Math.min(Math.max(h$delayed.peekPrio()-now, 0), h$gcInterval); +#ifndef GHCJS_BROWSER + if(typeof setTimeout !== 'undefined') { +#endif + if(delay >= 1) { + TRACE_SCHEDULER("scheduling main loop wakeup in " + delay + "ms") + // node.js 0.10.30 has trouble with non-integral delays + h$mainLoopTimeout = setTimeout(h$mainLoop, Math.round(delay)); + } else { + h$mainLoopImmediate = setImmediate(h$mainLoop); + } +#ifndef GHCJS_BROWSER + } +#endif +} + +var h$animationFrameMainLoop = false; +#ifdef GHCJS_ANIMATIONFRAME_MAINLOOP +h$animationFrameMainLoop = true; +#endif + +function h$clearScheduleMainLoop() { + if(h$mainLoopTimeout) { + clearTimeout(h$mainLoopTimeout); + h$mainLoopTimeout = null; + } + if(h$mainLoopImmediate) { + clearImmediate(h$mainLoopImmediate); + h$mainLoopImmediate = null; + } + if(h$mainLoopFrame) { + cancelAnimationFrame(h$mainLoopFrame); + h$mainLoopFrame = null; + } +} + +function h$startMainLoop() { + TRACE_SCHEDULER("start main loop: " + h$running) + if(h$running) return; +#ifndef GHCJS_BROWSER + if(typeof setTimeout !== 'undefined') { +#endif + if(!h$mainLoopImmediate) { + h$clearScheduleMainLoop(); + h$mainLoopImmediate = setImmediate(h$mainLoop); + } +#ifndef GHCJS_BROWSER + } else { + while(true) { + // the try/catch block appears to prevent a crash with + // Safari on iOS 10, even though this path is never taken + // in a browser. + try { + h$mainLoop(); + } catch(e) { + throw e; + } + } + } +#endif +} + +#if defined(GHCJS_TRACE_CALLS) || defined(GHCJS_TRACE_STACK) +var h$traceCallsTicks = 0; +#ifndef GHCJS_TRACE_CALLS_DELAY +#define GHCJS_TRACE_CALLS_DELAY 0 +#endif +var h$traceCallsDelay = GHCJS_TRACE_CALLS_DELAY; +#endif + +var h$busyYield = GHCJS_BUSY_YIELD; +var h$schedQuantum = GHCJS_SCHED_QUANTUM; + +var h$mainLoopImmediate = null; // immediate id if main loop has been scheduled immediately +var h$mainLoopTimeout = null; // timeout id if main loop has been scheduled with a timeout +var h$mainLoopFrame = null; // timeout id if main loop has been scheduled with an animation frame +var h$running = false; +var h$nextThread = null; +function h$mainLoop() { +#ifdef GHCJS_PROF + h$runProf(h$actualMainLoop); +} +function h$actualMainLoop() { +#endif + if(h$running) return; + h$clearScheduleMainLoop(); + if(h$currentThread) { + h$scheduleMainLoop(); + return; + } + h$running = true; + h$runInitStatic(); + h$currentThread = h$nextThread; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + if(h$nextThread !== null) { + h$stack = h$currentThread.stack; + h$sp = h$currentThread.sp; + } + var c = null; + var start = Date.now(); + do { + c = h$scheduler(c); + if(c === null) { // no running threads + h$nextThread = null; + h$running = false; + h$currentThread = null; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + h$scheduleMainLoop(); + return; + } + // yield to js after h$busyYield (default value GHCJS_BUSY_YIELD) + if(!h$currentThread.isSynchronous && Date.now() - start > h$busyYield) { + TRACE_SCHEDULER("yielding to js") + if(c !== h$reschedule) h$suspendCurrentThread(c); + h$nextThread = h$currentThread; + h$currentThread = null; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + h$running = false; + if(h$animationFrameMainLoop) { + h$mainLoopFrame = requestAnimationFrame(h$mainLoop); + } else { + h$mainLoopImmediate = setImmediate(h$mainLoop); + } + return; + } +#ifdef GHCJS_NO_CATCH_MAINLOOP + // for debugging purposes only, may leave threads in inconsistent state! + c = h$runThreadSlice(c); +#else + c = h$runThreadSliceCatch(c); +#endif + } while(true); +} + +function h$runThreadSliceCatch(c) { + try { + return h$runThreadSlice(c); + } catch(e) { + // uncaught exception in haskell code, kill thread +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + c = null; + if(h$stack && h$stack[0] === h$doneMain_e) { + h$stack = null; + h$reportMainLoopException(e, true); + h$doneMain_e(); + } else { + h$stack = null; + h$reportMainLoopException(e, false); + } + h$finishThread(h$currentThread); + h$currentThread.status = THREAD_DIED; + h$currentThread = null; + } + return h$reschedule; +} + +/* + run thread h$currentThread for a single time slice + + - c: the next function to call from the trampoline + + returns: + the next function to call in this thread + + preconditions: + h$currentThread is the thread to run + h$stack is the stack of this thread + h$sp is the stack pointer + + any global variables needed to pass arguments have been set + the caller has to update the thread state object + */ +function h$runThreadSlice(c) { + var count, scheduled = Date.now(); + while(c !== h$reschedule && + (h$currentThread.noPreemption || h$currentThread.isSynchronous || + (Date.now() - scheduled < h$schedQuantum))) { + count = 0; + while(c !== h$reschedule && ++count < GHCJS_SCHED_CHECK) { +#if defined(GHCJS_TRACE_CALLS) || defined(GHCJS_TRACE_STACK) + h$traceCallsTicks++; + if(h$traceCallsTicks % 1000000 === 0) h$log("ticks: " + h$traceCallsTicks); +#endif +#ifdef GHCJS_TRACE_CALLS + if(h$traceCallsDelay >= 0 && h$traceCallsTicks >= h$traceCallsDelay) h$logCall(c); +#endif +#ifdef GHCJS_TRACE_STACK + if(h$traceCallsDelay >= 0 && h$traceCallsTicks >= h$traceCallsDelay) h$logStack(c); +#endif + c = c(); +#if !defined(GHCJS_TRACE_CALLS) && !defined(GHCJS_TRACE_STACK) && !defined(GHCJS_SCHED_DEBUG) + c = c(); + c = c(); + c = c(); + c = c(); + c = c(); + c = c(); + c = c(); + c = c(); + c = c(); +#endif + } + if(c === h$reschedule && + (h$currentThread.noPreemption || h$currentThread.isSynchronous) && + h$currentThread.status === THREAD_BLOCKED) { + c = h$handleBlockedSyncThread(c); + } + } + return c; +} + +function h$reportMainLoopException(e, isMainThread) { + if(e instanceof h$ThreadAbortedError) return; + var main = isMainThread ? " main" : ""; + h$log("uncaught exception in Haskell" + main + " thread: " + e.toString()); + if(e.stack) h$log(e.stack); + if (h$isNode()) { + process.exit(1); + } +} + + +function h$handleBlockedSyncThread(c) { + TRACE_SCHEDULER("handling blocked sync thread") + /* + if we have a blocked synchronous/non-preemptible thread, + and it's blocked on a black hole, first try to clear + it. + */ + var bo = h$currentThread.blockedOn; + if(h$currentThread.status === THREAD_BLOCKED && + IS_BLACKHOLE(bo) && + h$runBlackholeThreadSync(bo)) { + TRACE_SCHEDULER("blackhole succesfully removed") + c = h$stack[h$sp]; + } + /* + if still blocked, then either fall back to async, + or throw a WouldBlock exception + */ + if(h$currentThread.isSynchronous && h$currentThread.status === THREAD_BLOCKED) { + if(h$currentThread.continueAsync) { + h$currentThread.isSynchronous = false; + h$currentThread.continueAsync = false; + } else if(h$currentThread.isSynchronous) { + TRACE_SCHEDULER("blocking synchronous thread: exception") + h$sp += 2; + h$currentThread.sp = h$sp; + h$stack[h$sp-1] = h$baseZCGHCziJSziPrimziInternalziwouldBlock; + h$stack[h$sp] = h$raiseAsync_frame; + h$forceWakeupThread(h$currentThread); + c = h$raiseAsync_frame; + } // otherwise a non-preemptible thread, keep it in the same state + } + return c; +} + +// run the supplied IO action in a new thread +// returns immediately, thread is started in background +function h$run(a) { + TRACE_SCHEDULER("sched: starting thread") + var t = h$forkThread(a, false); + h$startMainLoop(); + return t; +} + +/** @constructor */ +function h$WouldBlock() { + +} + +h$WouldBlock.prototype.toString = function() { + return "Haskell Operation would block"; +} + +/** @constructor */ +function h$HaskellException(msg) { + this._msg = msg; +} + +h$HaskellException.prototype.toString = function() { + return this._msg; +} + +function h$setCurrentThreadResultWouldBlock() { + h$currentThread.result = new h$WouldBlock(); + h$currentThread.resultIsException = true; +} + +function h$setCurrentThreadResultJSException(e) { + h$currentThread.result = e; + h$currentThread.resultIsException = true; +} + +function h$setCurrentThreadResultHaskellException(msg) { + h$currentThread.result = new h$HaskellException(msg); + h$currentThread.resultIsException = true; +} + +function h$setCurrentThreadResultValue(v) { + h$currentThread.result = v; + h$currentThread.resultIsException = false; +} + +/* + run a Haskell (IO JSVal) action synchronously, returning + the result. Uncaught Haskell exceptions are thrown as a + h$HaskellException. If the action could not finish due to + blocking, a h$WouldBlock exception is thrown instead. + + - a: the (IO JSVal) action + - cont: continue async if blocked + (the call to h$runSyncReturn would still throw h$WouldBlock, + since there would be no return value) + + returns: the result of the IO action + */ +function h$runSyncReturn(a, cont) { + var t = new h$Thread(); + TRACE_SCHEDULER("h$runSyncReturn created thread: " + h$threadString(t)) + var aa = MK_AP1(h$baseZCGHCziJSziPrimziInternalzisetCurrentThreadResultValue, a); + h$runSyncAction(t, aa, cont); + if(t.status === THREAD_FINISHED) { + if(t.resultIsException) { + throw t.result; + } else { + return t.result; + } + } else if(t.status === THREAD_BLOCKED) { + throw new h$WouldBlock(); + } else { + throw new Error("h$runSyncReturn: Unexpected thread status: " + t.status); + } +} + +/* + run a Haskell IO action synchronously, ignoring the result + or any exception in the Haskell code + + - a: the IO action + - cont: continue async if blocked + + returns: true if the action ran to completion, false otherwise + + throws: any uncaught Haskell or JS exception except WouldBlock + */ +function h$runSync(a, cont) { + var t = new h$Thread(); + TRACE_SCHEDULER("h$runSync created thread: " + h$threadString(t)) + h$runSyncAction(t, a, cont); + if(t.resultIsException) { + if(t.result instanceof h$WouldBlock) { + return false; + } else { + throw t.result; + } + } + return t.status === THREAD_FINISHED; +} + +function h$runSyncAction(t, a, cont) { + h$runInitStatic(); + var c = h$return; + t.stack[2] = h$baseZCGHCziJSziPrimziInternalzisetCurrentThreadResultException; + t.stack[4] = h$ap_1_0; + t.stack[5] = a; + t.stack[6] = h$return; + t.sp = 6; + t.status = THREAD_RUNNING; +#ifdef GHCJS_PROF + // fixme this looks wrong + // t.ccs = h$currentThread.ccs; // TODO: not sure about this +#endif + t.isSynchronous = true; + t.continueAsync = cont; + var ct = h$currentThread; + var csp = h$sp; + var cr1 = h$r1; // do we need to save more than this? + var caught = false, excep = null; + h$currentThread = t; + h$stack = t.stack; + h$sp = t.sp; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + try { + c = h$runThreadSlice(c); + if(c !== h$reschedule) { + throw new Error("h$runSyncAction: h$reschedule expected"); + } + } catch(e) { + h$finishThread(h$currentThread); + h$currentThread.status = THREAD_DIED; + caught = true; + excep = e; + } + if(ct !== null) { + h$currentThread = ct; + h$stack = ct.stack; + h$sp = csp; + h$r1 = cr1; + } else { + h$currentThread = null; + h$stack = null; + } +#ifdef GHCJS_PROF + // fixme? + h$reportCurrentCcs(); +#endif + if(t.status !== THREAD_FINISHED && !cont) { + h$removeThreadBlock(t); + h$finishThread(t); + } + if(caught) throw excep; +} + +// run other threads synchronously until the blackhole is 'freed' +// returns true for success, false for failure, a thread blocks +function h$runBlackholeThreadSync(bh) { + TRACE_SCHEDULER("trying to remove black hole") + var ct = h$currentThread; + var sp = h$sp; + var success = false; + var bhs = []; + var currentBh = bh; + // we don't handle async exceptions here, + // don't run threads with pending exceptions + if(BLACKHOLE_TID(bh).excep.length > 0) { + TRACE_SCHEDULER("aborting due to queued async exceptions") + return false; + } + h$currentThread = BLACKHOLE_TID(bh); + h$stack = h$currentThread.stack; + h$sp = h$currentThread.sp; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + var c = (h$currentThread.status === THREAD_RUNNING)?h$stack[h$sp]:h$reschedule; + TRACE_SCHEDULER("switched thread status running: " + (h$currentThread.status === THREAD_RUNNING)) + try { + while(true) { + while(c !== h$reschedule && IS_BLACKHOLE(currentBh)) { + c = c(); + c = c(); + c = c(); + c = c(); + c = c(); + } + if(c === h$reschedule) { + // perhaps new blackhole, then continue with that thread, + // otherwise fail + if(IS_BLACKHOLE(h$currentThread.blockedOn)) { + TRACE_SCHEDULER("following another black hole") + bhs.push(currentBh); + currentBh = h$currentThread.blockedOn; + h$currentThread = BLACKHOLE_TID(h$currentThread.blockedOn); + if(h$currentThread.excep.length > 0) { + break; + } + h$stack = h$currentThread.stack; + h$sp = h$currentThread.sp; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + c = (h$currentThread.status === THREAD_RUNNING)?h$stack[h$sp]:h$reschedule; + } else { + TRACE_SCHEDULER("thread blocked on something that's not a black hole, failing") + break; + } + } else { // blackhole updated: suspend thread and pick up the old one + TRACE_SCHEDULER("blackhole updated, switching back (" + h$sp + ")") + TRACE_SCHEDULER("next: " + c.toString()) + h$suspendCurrentThread(c); + if(bhs.length > 0) { + TRACE_SCHEDULER("to next black hole") + currentBh = bhs.pop(); + h$currentThread = BLACKHOLE_TID(currentBh); + h$stack = h$currentThread.stack; + h$sp = h$currentThread.sp; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + } else { + TRACE_SCHEDULER("last blackhole removed, success!") + success = true; + break; + } + } + } + } catch(e) { } + // switch back to original thread + h$sp = sp; + h$stack = ct.stack; + h$currentThread = ct; +#ifdef GHCJS_PROF + h$reportCurrentCcs(); +#endif + return success; +} + +function h$syncThreadState(tid) { + return (tid.isSynchronous ? 1 : 0) | + ((tid.continueAsync || !tid.isSynchronous) ? 2 : 0) | + ((tid.noPreemption || tid.isSynchronous) ? 4 : 0); +} + +// run the supplied IO action in a main thread +// (program exits when this thread finishes) +function h$main(a) { + var t = new h$Thread(); +#ifdef GHCJS_PROF + t.ccs = a.cc; +#endif + //TRACE_SCHEDULER("sched: starting main thread") + t.stack[0] = h$doneMain_e; +#ifndef GHCJS_BROWSER + if(!h$isBrowser() && !h$isGHCJSi()) { + t.stack[2] = h$baseZCGHCziTopHandlerzitopHandler; + } +#endif + t.stack[4] = h$ap_1_0; + t.stack[5] = h$flushStdout; + t.stack[6] = h$return; + t.stack[7] = h$ap_1_0; + t.stack[8] = a; + t.stack[9] = h$return; + t.sp = 9; + t.label = [h$encodeUtf8("main"), 0]; + h$wakeupThread(t); + h$startMainLoop(); + return t; +} + +function h$doneMain() { +#ifndef GHCJS_BROWSER + if(h$isGHCJSi()) { + if(h$currentThread.stack) { + global.h$GHCJSi.done(h$currentThread); + } + } else { +#endif + h$exitProcess(0); +#ifndef GHCJS_BROWSER + } +#endif + h$finishThread(h$currentThread); + return h$reschedule; +} + +/** @constructor */ +function h$ThreadAbortedError(code) { + this.code = code; +} + +h$ThreadAbortedError.prototype.toString = function() { + return "Thread aborted, exit code: " + this.code; +} + +function h$exitProcess(code) { +#ifndef GHCJS_BROWSER + if(h$isNode()) { + process.exit(code); + } else if(h$isJvm()) { + java.lang.System.exit(code); + } else if(h$isJsShell()) { + quit(code); + } else if(h$isJsCore()) { + if(h$base_stdoutLeftover.val !== null) print(h$base_stdoutLeftover.val); + if(h$base_stderrLeftover.val !== null) debug(h$base_stderrLeftover.val); + // jsc does not support returning a nonzero value, print it instead + if(code !== 0) debug("GHCJS JSC exit status: " + code); + quit(); + } else { +#endif + if(h$currentThread) { + h$finishThread(h$currentThread); + h$stack = null; + throw new h$ThreadAbortedError(code); + } +#ifndef GHCJS_BROWSER + } +#endif +} + +// MVar support +var h$mvarId = 0; +/** @constructor */ +function h$MVar() { + TRACE_SCHEDULER("h$MVar constructor") + this.val = null; + this.readers = new h$Queue(); + this.writers = new h$Queue(); + this.waiters = null; // waiting for a value in the MVar with ReadMVar + this.m = 0; // gc mark + this.id = ++h$mvarId; +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_notifyAlloc(this); +#endif +} + +// set the MVar to empty unless there are writers +function h$notifyMVarEmpty(mv) { + var w = mv.writers.dequeue(); + if(w !== null) { + var thread = w[0]; + var val = w[1]; + TRACE_SCHEDULER("notifyMVarEmpty(" + mv.id + "): writer ready: " + h$threadString(thread)) + mv.val = val; + // thread is null if some JavaScript outside Haskell wrote to the MVar + if(thread !== null) { + h$wakeupThread(thread); + } + } else { + TRACE_SCHEDULER("notifyMVarEmpty(" + mv.id + "): no writers") + mv.val = null; + } + TRACE_SCHEDULER("notifyMVarEmpty(" + mv.id + "): " + mv.val) +} + +// set the MVar to val unless there are readers +function h$notifyMVarFull(mv,val) { + if(mv.waiters && mv.waiters.length > 0) { + for(var i=0;i<mv.waiters.length;i++) { + var w = mv.waiters[i]; + TRACE_SCHEDULER("notifyMVarFull: notifying waiter: " + h$threadString(w)) + w.sp += 2; + w.stack[w.sp-1] = val; + w.stack[w.sp] = h$return; + h$wakeupThread(w); + } + mv.waiters = null; + } + var r = mv.readers.dequeue(); + if(r !== null) { + TRACE_SCHEDULER("notifyMVarFull(" + mv.id + "): reader ready: " + h$threadString(r)) + r.sp += 2; + r.stack[r.sp-1] = val; + r.stack[r.sp] = h$return; + h$wakeupThread(r); + mv.val = null; + } else { + TRACE_SCHEDULER("notifyMVarFull(" + mv.id + "): no readers") + mv.val = val; + } + TRACE_SCHEDULER("notifyMVarFull(" + mv.id + "): " + mv.val) +} + +function h$takeMVar(mv) { + TRACE_SCHEDULER("h$takeMVar(" + mv.id + "): " + mv.val + " " + h$threadString(h$currentThread)) + if(mv.val !== null) { + h$r1 = mv.val; + h$notifyMVarEmpty(mv); + return h$stack[h$sp]; + } else { + mv.readers.enqueue(h$currentThread); + h$currentThread.interruptible = true; + return h$blockThread(h$currentThread,mv,[h$takeMVar,mv]); + } +} + +function h$tryTakeMVar(mv) { + TRACE_SCHEDULER("h$tryTakeMVar(" + mv.id + "): " + mv.val) + if(mv.val === null) { + RETURN_UBX_TUP2(0, null); + } else { + var v = mv.val; + h$notifyMVarEmpty(mv); + RETURN_UBX_TUP2(1, v); + } +} + +function h$readMVar(mv) { + TRACE_SCHEDULER("h$readMVar(" + mv.id + "): " + mv.val) + if(mv.val === null) { + if(mv.waiters) { + mv.waiters.push(h$currentThread); + } else { + mv.waiters = [h$currentThread]; + } + h$currentThread.interruptible = true; + return h$blockThread(h$currentThread,mv,[h$readMVar,mv]); + } else { + h$r1 = mv.val; + return h$stack[h$sp]; + } +} + +function h$putMVar(mv,val) { + TRACE_SCHEDULER("h$putMVar(" + mv.id + "): " + mv.val) + if(mv.val !== null) { + mv.writers.enqueue([h$currentThread,val]); + h$currentThread.interruptible = true; + return h$blockThread(h$currentThread,mv,[h$putMVar,mv,val]); + } else { + h$notifyMVarFull(mv,val); + return h$stack[h$sp]; + } +} + +function h$tryPutMVar(mv,val) { + TRACE_SCHEDULER("h$tryPutMVar(" + mv.id + "): " + mv.val) + if(mv.val !== null) { + return 0; + } else { + h$notifyMVarFull(mv,val); + return 1; + } +} + +// box up a JavaScript value and write it to the MVar synchronously +function h$writeMVarJs1(mv,val) { + var v = MK_DATA1_1(val); + if(mv.val !== null) { + TRACE_SCHEDULER("h$writeMVarJs1: was full") + mv.writers.enqueue([null,v]); + } else { + TRACE_SCHEDULER("h$writeMVarJs1: was empty") + h$notifyMVarFull(mv,v); + } +} + +function h$writeMVarJs2(mv,val1,val2) { + var v = MK_DATA1_2(val1, val2); + if(mv.val !== null) { + TRACE_SCHEDULER("h$writeMVarJs2: was full") + mv.writers.enqueue([null,v]); + } else { + TRACE_SCHEDULER("h$writeMVarJs2: was empty") + h$notifyMVarFull(mv,v); + } +} + +// IORef support +/** @constructor */ +function h$MutVar(v) { + this.val = v; + this.m = 0; +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_notifyAlloc(this); +#endif +} + +function h$atomicModifyMutVar(mv, fun) { + var oldVal = mv.val; + var thunk = MK_AP1(fun, oldVal); + mv.val = thunk; + RETURN_UBX_TUP2(oldVal, thunk); +} + +function h$atomicModifyMutVar2(mv, fun) { + var oldVal = mv.val; + var thunk = MK_AP1(fun, oldVal); + mv.val = MK_SELECT1(thunk); + RETURN_UBX_TUP2(oldVal, thunk); +} + +// Black holes and updates +// caller must save registers on stack +function h$blockOnBlackhole(c) { + TRACE_SCHEDULER("blackhole, blocking: " + h$collectProps(c)) + if(BLACKHOLE_TID(c) === h$currentThread) { + TRACE_SCHEDULER("NonTermination") + return h$throw(h$baseZCControlziExceptionziBasezinonTermination, true); + } + TRACE_SCHEDULER("blackhole, blocking thread: " + h$threadString(h$currentThread)) + if(BLACKHOLE_QUEUE(c) === null) { + SET_BLACKHOLE_QUEUE(c,[h$currentThread]); + } else { + BLACKHOLE_QUEUE(c).push(h$currentThread); + } + return h$blockThread(h$currentThread,c,[h$resumeBlockOnBlackhole,c]); +} + +function h$resumeBlockOnBlackhole(c) { + h$r1 = c; + return h$ap_0_0_fast(); +} + +// async exception happened in a black hole, make a thunk +// to resume the computation +// var h$debugResumableId = 0; +function h$makeResumable(bh,start,end,extra) { + var s = h$stack.slice(start,end+1); + if(extra) { + s = s.concat(extra); + } +// TRACE_SCHEDULER("making resumable " + (h$debugResumableId+1) + ", stack: ") +// h$dumpStackTop(s,0,s.length-1); + MAKE_RESUMABLE(bh, s); +} + +var h$enabled_capabilities = h$newByteArray(4); +h$enabled_capabilities.i3[0] = 1; + +function h$rtsSupportsBoundThreads() { + return 0; +} + +function h$rts_setMainThread(t) { + +} + +// async foreign calls +function h$mkForeignCallback(x) { + return function() { + if(x.mv === null) { // callback called synchronously + x.mv = arguments; + } else { + h$notifyMVarFull(x.mv, MK_DATA1_1(arguments)); + h$mainLoop(); + } + } +} + +// event listeners through MVar +function h$makeMVarListener(mv, stopProp, stopImmProp, preventDefault) { + var f = function(event) { + TRACE_SCHEDULER("MVar listener callback") + h$writeMVarJs1(mv,event); + if(stopProp) { event.stopPropagation(); } + if(stopImmProp) { event.stopImmediatePropagation(); } + if(preventDefault) { event.preventDefault(); } + } + f.root = mv; + return f; +} + +function h$rs() { + return h$stack[h$sp]; +} + +const rts_isThreaded = 0; diff --git a/rts/js/unicode.js b/rts/js/unicode.js new file mode 100644 index 0000000000..8393da2c99 --- /dev/null +++ b/rts/js/unicode.js @@ -0,0 +1,11 @@ +// Unicode tables generated by ghcjs/utils/genUnicode.hs +var h$printRanges = "f|!-f=|/q'/+1$J|(mo'| -')| 63Y+/EO'|$9| ('| ?'|!9?| ?'| +'AZ'$9| 3M2MA|#V2'''O0$)+'5'''+3*','U').+''O0&&&'$-+''))0+$1E7)4(N0&,'7(('@+';11(2'''O0&,'5''')3'+','G7'.))*)'$&)')));+-))*'.>M-=(PB)3(*1'(-+'71O(P6,'5(*1'1$+'7&=+2(| .(.+C'W''F)S4$'1)*/$2/7');| =+^n'$,R$P'-$.'7'+d| Yk+rk@<n|$G$-&|(E*'1$*'v*'f*'1$*'A| :*'| O'd)W/| v'/'|.r)|! 1=09Q5K;=(&;|!+'7/7/?'7/|! 1z-| U7b:+;+(x'-9| +W/9)| E'| K]'9/7/?'A| K| b+| #)|!W3| A)A)| A1z'93z-|%U|&<'/'p'/'3 $a'| 3@>'/H')48-S1| +C''Y<)dCfA|#-+|.fU9M|H;'d'|#C| &|#<-| #$-&| 91'?S510000000|!N| )W| {;|$hW;+| I| u'|!=-z|!*y-l;| '|$y} ^y7}%1UC|9t)| 75|'fK|$+3|$;'-| )| 3+7/| 93| U3;/|!W9`)| f8+f| 65?'7'|!=S[7/'/'/510| 83|!l'7/}!e;;Q+| +}!'n|(/'|!Cp1;--W,$&&|!gE|(-C| I'| 5t?'W/| /H*+-|#!+|$7)/'/'/'))10='';VH&@'?h|!f-)+| #)| z:+| &| %|!t^)| +A[+l5`-z-`m+?x|#Q'7/l+l+t3| 19|#4|&v5O73|#E/'$| &)&Q| X35| )I&-f)Y-| H| 9+K'| -&-3(]')+7151| Idr+;5| 5)^'Y-W1+;1| j| [| 7| /=| /1| %37|&Sb|!rt3x|# Q5| f+`A| E*?U17/| 3D5r5| f'CJ9G{| K1$*@8/| ?-7/+2'''O0&,6''')'.,1'1)-|#+|!#$(d| Y37|#b| 5'ph| S97/=I| ;17| 5Y'A+C|$;| A|!7| p;|#T3'| %'9Y| Y3| p^| ;|%p5| !>7^)d'O>| [1&{)$'437//&m&.17|&tU|$I| -=|4Q|!;|!M,9|$C|^)|7l|{ |,z}!+p|,^1b6+'|!/`'/7| U770L-I|/=|!%|!9| `+| ;1E| I+[} NC3|0j}!>j|&E| +)E+3|(l|S=|!E-=)517'+} 47|%M7r'| ^3|!KQ| U|#IK;| x5U|##| t| V&'&''+:$0| J*'30Z*,$)1|'T'|&O'|/YA-@|>71D'1&,|$f| #)?'7+'|(3| =-|<J|$E'Cv| `-7+'|1K| Q| b| C|$?+X&$'$7* #/* $)&$' &'$'+0**$6D-),D| 1'|&#| +|!7;A'A@m7=)|!))| C| ;^=| +51'?/|#I|5n7=)9-|!W;|! 1;K;+| 937/t3`| n;|!8*)v'/)^'|##;?'++)-)=/|>l}*Q/v} !59|$x'} F'?} m)|ez|,'|G1|%A"; +var h$alnumRanges = "| +71W/W| '0'$)'(Pa|*2+;?-1$|!q-&'+$/$)$J| o|#*3|#bo'.v| WY++| #zM7+'|!4$A'1A'B$`^|! 9>z5'+,O+4(PU19| 3M2| U| 5)F07+7B+3'''O0$)+)B<'(+;'/'2/+''O0&&&b+$17')C5(N0&,)F@'+7583'''O0&,)_'(+709$/))*)'$&)')));OL=G3(PB)V)-'+731$+3(P6,)c$'+7&G3(u'B,)6+I.-G)S4$'1b7E| )&;157r'$,R$6&5&-$57'+daK;3kY-|!UzK9//++)('1)+=;$7/p$-&z|'F*'1$*'v*'f*'1$*'A| :*'| O?K)CC| v'/)|-j'EV-| `)91=*?G?G?=(A| 1j*(7/7O7/|! 1-'h$-| U7brt'-9| +W/9nQ5| 3z7/7=|!(| 'E1+7v`=| 9Wl[7)| +'51z')v+.&),|$;| I|&3'/'p'/'3 $a'| 30$))0)+'/+=-)0|!U''/-9/=|!9*&7$)-/ $+8'+--+$| =|0/| A| fO|.#`|91| '| &|!y/+)'5&p$-&| 91BQ510000000| j|*H)U51-'-+| v/)|!!*-z|!*)+7Y| 3Cd7`3@d7rA|'-} X;| ^}%0/C|9t| O| %'|& )[K| 'Cb'| jr5'|!='| 3'-| )9(*P=/7| 1?| -[7S/)$'o7QU^1| '[9/-TuQ)2+7/Q)(| -$)''-'$R)'91);/'/'/510y:3|!U=7/}!e;;Q+| +}!'n|(/'|!Cp1;--$7<,$&&|!Ff|()G| I'| 5t;|!W-|#!I71W/W9|! )/'/'/')j;VH&@'?h|!f;| #;| ;E'|%I^)| +CY+l5`-p7`'l+3,x|#Q'7/l+l+t3| 1|#M|&v5O73|#E/'$| &)&Q'b'p35| )I&-f+W| U| 9+K'| 'A+(]75Qbcd3Z/-C| 57O'Y-WQ1| j| [| 7| /=| /1x;7|&Sb|!rt3O9+|#+Q;| 3W`I| #dU175lA7+8j):| )?+99$+K9GT| r1$*@61| 'E793'''O0&,)F:-|#Q| 3G+-7-c| )K'$37|#b| 'v+l| )K87pz=07| 5YM;|$C| |!W| p;|#T3'rC)[6t1L8| %Ig| ;|%p5mE@^-`|!O1&oM47//&c?07|&tI|$UMz|4O|!;|!ME|$C|^)|7l|{ |,z}!+p|,^1b6|!;`G| )C+;70L-I|/=| x|!A| `-| L=| I'$[} NC3|0j}!>j|&E| +)E+3|(l|S=|!E-=)517} DdK|!GU|##| t| V&'&''+:$0| J*'30Z*,$)1|'T'UTaTaTaTaT2'| -|S5| #71'7+'|(3| +7|<W|$E'5| )| Q;7|1W| ?(*| b| #@|$?+X&$'$7* #/* $)&$' &'$'+0**$6D-),D|,t=|v'}*Q/v} !59|$x'} F'?} m)|ez|,'"; +var h$lowerRanges = "|!3W| =uS2 <& (& 8' #)'$&('+&()'& #&$'$'($&'')/&& )' )&'$( >1'&'$+ %| SX|$=$(()GXj&)) ,,$'&'| /| ) 25 ;& '' Q| )v|a1z')|0t/|PG5|!^| | G=g|!; l5 Q43/73333/73333?'333333-&/()&3+''337)&|&+(')X**&'3++| 2|]a| ''(' $+$'.- R'1$*:p$-}'Zi 7H .|#! ') @2 #' %*$&$) +-, &(| 4|28z-33| j}${p1;-|7`W|;?t|#%l|L3| /|d/d}%DGd}&F#WW1FWWW+$08WWWWWWWWWWWWWWWWW[[U.WU.WU.WU.WU.$} ([h"; +var h$upperRanges = "| MW|!9Q0f <& (& 8' #)'$&('+&()'& #&$'$'($&)0'&& )' )&'$( >1'&'$+ %|&I$(2.$)$&D4j&)) ,,&$''| /| ) 14 <' '' P&p|a5p$-|0&| v|Pxz')|'- l4 Q433/73333/9 $23S333333-9-9+;-9-|%l*()')'(-/ $+'+7'-| B|[]| '| +$)' $+$'2) R3$*}']( 7H .|#! '( ?6 #' %+$&$( +-, &)$)}%NxW|;/t|#%l|K^| /|dpd}%DGd}&F/WWWWWW$''&''+2WWW'*'30Y'*,$)1YWWWWWWWWWWW`UfUfUfUfUf} 'sh"; +var h$alphaRanges = "| MW/W| '6*,Qa|*2+;?-1$|!q-&'+$/$)$J| o|#*3|#bo'.v| WY++| #zj'|!4$A'1'7)'B$`^|! 9Rf5'+,O+4(PU19| 3M2| U| 5)F07AC+3'''O0$)+)B<'(?'72/+''O0&&&b+$I)C5(N0&,)F@'Q83'''O0&,)_'(AD$/))*)'$&)')));O| 03(PB)V)-'`*3(P6,)c$'A'G3(u'B,)3)S/-G)S4$'1| =| )&;1| ='$,R$6&5&-$M+d| F3kY-|!UzKB/++)('1)+=;Dp$-&z|'F*'1$*'v*'f*'1$*'A| :*'| OnCC| v'/)|-j'EV-| `/31=*?G?G?=(A| 1j*| N|! 1-'h$-| U7b| +`'-9| +W| 5Q5| 3| n|!(| 'E1| 7`='7| Wlv)7l'51z')v+.&),|$;| I|&3'/'p'/'3 $a'| 30$))0)+'/+=-)0|!W<B=|!9*&7$)-/ $+8'+--+| 0'|[[| '| &|!y/+)';p$-&| 91BQ510000000| j|*H'x--'+| v/)|!!*-z|!*EY| 3C|+E} X;| ^}%0/C|9t| O| %'|& )C7'K| 'Cb'| U| +5'|!='| 3'-| )9(*P^| 1?| -| E/)$'9[7QU^1| '[B-67-uQ)2KQ)(| -$)''-'$R)'91);/'/'/510y:3|!U^}!e;;Q+| +}!'n|(/'|!Cp1;--$7<,$&&|!Ff|()G| I'| 5t;|!W-|#!lW/W9|! )/'/'/')j;VH&@'?h|!f|(^^)| +| 'd=K2/p7`'l+3| )|#QGl+l+t3| 1|#M|&v5O73|#E/'$| &)&Q7Q5b| KI&7O7W| U| 9/'| I@+(]x^)^j3ZY| 57O7I=G|!K| [| 7| /=| /=l|*W^72O|#IQ;| 3| `| #dUWl^8j):| )?+M$iGT| r1$*@61| 'p3'''O0&,)F:-|#Q| 3G+Kc| )K'$|$+| 'v+l| )K| >z=| VY|%+| |!W| Ib|#T3'rC)[6t1L8| %Ig| ;|%p5mE| *`|!O1&oMT/&c?|':I|& |4O|%-|$C|^)|7l|{ |,z}!+p|,^1b|!Q`G| )C+bM-I|/=| I|!p| `-| L=| I'$[} NC3|0j}!>j|&E| +)E+3|(l|S=|!E-=)517} K-| t| V&'&''+:$0| J*'30Z*,$)1|'T'UTaTaTaTaT2|TC| #71C'|(3| |<t|$E| ?| Q|:x+X&$'$7* #/* $)&$' &'$'+0**$6D-),D} (7}*Q/v} !59|$x'} F'?} m)|ez|,'"; +var h$toLowerMapping = "| K Wb|!9 Qb!1bf 9# !|$F ## &' (# &' 8# !|!_# # #) !|$^# ! # ! |$U !# '|$S&' !| f|$M !|$O# ! |$S !|$W !|$`|$[&) !|$`|$d ! |$f $# !|$n# ! |$n' !# !|$n#!'|$l ## !|$p#) &1 !%# ! % !# !%# ) #' )# &' !%# ! # ! |!. !| 6# 4 # ! |!q * #1 !}![r# ! |#X}%=]' !# !|$>| Q !| U# % #|&I !# &) &3 |%0/ !n )l ! | G!'| E!Eb!5bj B3 ,# &- |!]' !# !.#' )|!qC| hdb| ) 1# &5 <# !?# ' #' P# &' p| '|a5 p} hG ! } hG- }#To|0' | j})U[/1|Px z|cm' )|cm|'- l# &5 !} p4 P# &5 303 /07 303 303 /09 $0 @3 30S 303 303 303 '0'| ZD9 +| sD9 '0'|!4; '0'|!L<9 '|!m'|!iD|&Y }#a() !}!&:}!#V/ | 8| # CAI &|23 WU|Ht | '| '| + !# !}!Zc|ue}%:e' $# !}![R}!Zo !}![X}![V ! #' &3 '}!]> R# &3 !# &+ &}']) 7# &I .# &|## '# &) ?# &7 ## !}(b.# % #+ !# }4p*' !# &) +# !}*H0}*HF !}*H>}*H* !}*H0 !}*G&}*GV !}*G,|4Y &# &) !# !| &}*H.}1JX}%Nx Wb|;/ tr|#% lr|K^ | /| G|dp db}%DG db}'dY hf}c/Q "; +var h$toUpperMapping = "|!1 Wa| = |A$x Qa!1a !|!` 9! !|%. #! $' (! $' 7! $' #! !!|&]|(_' !! $' $) $- $' |$>) !!|#Y) |%i' #! $' $+ $' $) !! $' $) !! |!N- !!$ ! ! !$ !!$ ) ! !| e )! $' !!$ ! !) 4! $) )! $3 $' '}!]? ! !+ %! !!}![Y !}![S}![W !|$]|$T!'|$R ! |$L ! |$N}4qo) !|$R}*H? ! |$V ! }*GS !}*H1 !|$Z|$_ !}*H1}!Zd}4q6' !|$_ !}!Zp|$c' |)N1 }%:g' !|$m !}*H/|$m) !}*GW|$m|#&'|$k|#.- |)c7 !}*G-}*G'|#b |#ez !! $) $) )|!r| % | _)k!Ea| B5a|!m'| D ! | B|!P) !| $| 2 !0 ,! !!| s !| g/ !|!T |$8' $' $| 1 daC| g 2 !5 ;! $' '! !!> Q !| + p| &|a5 z|cn' )|cn|0t /0|PG !} Py} Pw}#'N'} Pa !} Pc} PT !} O@}(``|%A }1H>) } pPC }1JZ|!S l! $- |!X- P! $313 /17 313 313 /19 $1 B3 313 '| [+| t'|!5'|!n'|!M'|!j' 313 313 313 '1 ! 37 }#R4+ F; '1? '1) >= F|'b | 6f C@+ $|2f WT|IE | '| &' $) !}![q}![k $ !/ $' $7 R! $3 !! $+ $; p} hF ! } hF- }#Tm}'Zj 7! $I .! $|## '! $) ?! $7 !! $' %! $+ $+ !! !!| '' *! $9 &! $) $|49 |I6[ | j})UZ}%9' Wa|;? tq|#% lq|L3 | /| F|d/ da}%DG da}'d^ he}c.h "; +var h$toTitleMapping = "|!1 Wa| = |A$x Qa!1a !|!` 9! !|%. #! $' (! $' 7! $' #! !!|&]|(_' !! $' $) $- $' |$>) !!|#Y) |%i' #! $' $+ $' $) !! $' $) !! |!N+ !# !!# ! ! !# )! !!| e * ! ! # # !) 4! $) )! $3 $' '}!]? ! !+ %! !!}![Y !}![S}![W !|$]|$T!'|$R ! |$L ! |$N}4qo) !|$R}*H? ! |$V ! }*GS !}*H1 !|$Z|$_ !}*H1}!Zd}4q6' !|$_ !}!Zp|$c' |)N1 }%:g' !|$m !}*H/|$m) !}*GW|$m|#&'|$k|#.- |)c7 !}*G-}*G'|#b |#ez !! $) $) )|!r| % | _)k!Ea| B5a|!m'| D ! | B|!P) !| $| 2 !0 ,! !!| s !| g/ !|!T |$8' $' $| 1 daC| g 2 !5 ;! $' '! !!> Q !| + p| &|s1 /0|PG !} Py} Pw}#'N'} Pa !} Pc} PT !} O@}(``|%A }1H>) } pPC }1JZ|!S l! $- |!X- P! $313 /17 313 313 /19 $1 B3 313 '| [+| t'|!5'|!n'|!M'|!j' 313 313 313 '1 ! 37 }#R4+ F; '1? '1) >= F|'b | 6f C@+ $|2f WT|IE | '| &' $) !}![q}![k $ !/ $' $7 R! $3 !! $+ $; p} hF ! } hF- }#Tm}'Zj 7! $I .! $|## '! $) ?! $7 !! $' %! $+ $+ !! !!| '' *! $9 &! $) $|49 |I6[ | j})UZ}%9' Wa|;? tq|#% lq|L3 | /| F|d/ da}%DG da}'d^ he}c.h "; +var h$catMapping = "d;P)3J)3 !/0 !34 !3.'37*'3)4'3W! !/3 !06 !-6W# !/4 !04f; !83+5 !73 !67 !&1 !4< !76 !74', !6#'3 !6, !&2),FQ!H1!S#H3# <!#$'# (!#$'# 8!#'! ##!)#'! !#!&'!&)!'#+!&'!&)!)#'!&'! ##!&'! !#!'# !!#'!&)! !#!&'!'# !&!)#+& !!$ !#! !$# !!$ )#!'# )!#$'# !!$ !#!&)! >#!1#'!&'!'# !!#+! %#!| S#,Y#G%+6;%?6-%16 !%6*E6|!O' #!# !%6 !!#' *)# !3!+ '6 !!3)! ! !!'!&E!!5!j#$'#)!)# ,!#$-# !!# !4!&'!'#| /!| )# 2!#N-'') <!#'! '#!'# Q!#!p!' */3v# !3.' '7 !5 | #' !.'F''F'' !3'3 Y&+ +&'39 /<)4'3J'3'79' !3<!'3d&*7&M'7*+3'&.|!5& !3&1' !<7/''%''N+''&7*)&'7,?3 ! < !&'`&Y'' |! &9',? 7*f&5''%N)3*' .'5O&+'*5'*)'*-'' A3!U&)'' !3 9&| 3 M&!3&M A'Xd'0| 5& !'( !'&)(3'+(.'(,1'7&'''37* !3%A&.'(!3&' '&' O&!1& ! &) +&' !'&)(+'' '(' '( !'&3 0+ '&!)&''' 7*'&'5/, !75 !&3.' '' !( /&+ '&' O&!1&!'&!'&!'&' !' )(''+ ''' )') .1 +& ! &1 7*'')& !'37 '' !( 5&!)&!O&!1&!'&!-&' !'&)(-'!'' !( '(.' ,A '&''' 7* !351 ,/' ! ''(!3&' '&' O&!1&!'&!-&' !'& !('0+'' '(' '(.3 !'(+ '&!)&''' 7* !7&/,7 !'&!/&) )&!+&) '& ! &!'&) '&) )&) ;&+ '(.'() )(!)(.' ,/ 0? 7*),/7 !57- .)(.3&!)&!Q&!C&) ,)'+(!)'!+'1 ''!)&- '&''' 7*1 F1, !7&.'(F3&!)&!Q&!7&!-&' !'& !('-( ! ''(!'(''1 '(1 !& '&''' 7*!'&= '''(!3&!)&!v&'',)(+'!)(!)( !'&N+ )&01,)&''' 7*5,N/&' '(!G&) S&!5& ! &' 1&) .+ )()' ! '!3(/ 7*' '(F; | )&.'&1'+ J/&*3'F7*'3n '& ! &!-&!S& ! &!7&.'&5',' -& ! %!/'' 7*' +&d ,)7A3 !73)7''/77*7, $7' #/0'(3&!l&+ ?'0-'F''-&9'!l'!37./7!'7-3+7'3n z&'(+'0/'0'''('',7*/3/&'(''+&)',)('&1()&+'=&.'(''/( !'&07*)(.'7p! ! !- $' z# !3%)#|'?&!+&' 1& ! &!+&' v&!+&' f&!+&' 1& ! &!+&' A&!| ;&!+&' | O&' )'53K,) C&77/ | v!' /#' <|-j&'3E&PW& !/0) | `&)3)+3&1 =&!+&)'9 G&)''35 G&''; =&!)&!''; | 1&''01'3(.'(9')3*)3 !5&.' 7*/ 7,/ /3<+3)' !< 7*/ j&*| 3&1 -&''h& !'&- | U&7 b&!)'+('')(+ '(./()'+ N) '37*`&' -&9 | &+ W&/ 7*8) h7Q&'''(.' '3| 3& !('01' ! ' !(''(3'/(7'' .7*/ 7*/ 13*/3' ?'2| K +'0| '& !'(-' !('-(.'(1&+ 7*13775'57) ''0`&0+''(''0)''&7*| & !'('')( !'()''(3 +3l&3(3''('') -37*) )&7*`&/%'35#1 z!' )!333 )'F='01'+&./&.'&0'',- | #| G%=#*h#n%| ='!-' l!#$5# Q!#$5#3!/#' /!' 3#3!3#3!/#' /!' 3# % !3#3!?#' 3#3$3#3$3#3$-#!'#+! !$6&)6)#!'#+!()6+#' '#+!!)63#-!)6' )#!'#+!('6!98-</.'3 !12>'1 !2/B33 !9:-<P53 !12+3'-)3 !4/@93 !43:73P-<!7< !,%' /,)4 !/0*7,)4 !/0!=%) d5C ='+).));'A '7$+7$'7&)!'#)! !#7$'7H-!/7 $!7+! !7#+!&+&&'7'#'!-4$+# !74'7 !#7C,j+ !!#++8'7+ -4-7'4+7H'7H'7H17Hb7'4'7 !47Hb7|%z437 #/0K7'417 !/0| l7H`7U4t7/4| S7U 97M | A,| f7O,|$)7H57H| 5734|!M7H|%Q7 (/0`,| 7-4 !/0b4 &/0C4|%b7|!v4 ,/0| G4 #/0d4 !/0|%f4| )7M4'7/4r7' d7' |!?7| '!!| '# ! !&)!'# $!#+! !#!'#$/#'%)! R#!'#/7 #!#)' !!#- +38'3p# ! #- &' | 9&1 !%3? .Q&5 1&!1&!1&!1&!1&!1&!1&!1&!d''3 #12)3 !12 !31D53<'3 !.3 !12'3 !12 %/0-3*73'.+3 !.3>=3| ) W7!|! 7; |$h7W ;7+ P)3 !7% !&+ &/0'7 %/0 !./'0N5++''(<-%'7)+ !%&F'7!| v&' '''6'% !&.|!#&F)%,- z&!|!+&!'7+,77Y&- l7; C&b7!7,`73,NA,d77,r7A,| G7!|%b7} X;&7 | I7}%0/&C M&*|9G&) | 775 t&/%'3|%z&*)3C&7*'&K 8!# !&'))F7' !3% /!#'%''| U&7+''/33 Q65%'6 '!#$)# @!#*3# #!#'! %#! !#%'6 #!# !&! !#!)# +!#-!&-! &#!&' !!#)!| ) ,'%&1&.)&.+&.Q&'(''0+7+ /,'7 !57/ | 1&+33 '(| -&C(''3 '37*/ G'/&)3 !&3'&.7*[&3''3Q&9''(9 F^&) )'0| '&.'(+''(.+(=3 ! %7*+ '3-& !'%5&7*-&!v&/''('''(''5 )&.3& !'(' 7*' +3C&*/&)7 !&( !'(| -& !'&)''&''-&'' !&',S '&*'39&0'''('3,'% !('7 /&' /&' /&5 1&!1&!z#L+%3#3 | j#j&'(.'(.'( !3(.' 7*/ }!e;&; Q&+ | +&+ |MQ=} T7 |(/&' |!C&p 1#; -#- !&'7&H=&!-& ! &!'&!'&!|!G&C6E |()& !0/C | I&' | 5&t ;& !57' C'13 !/0F/ C'F'.'- )/0'3 !/0+3)-)3!+3 !./ #0/@)3 !4.)4 ! 3J'3+ -&!|##&' !< )3J)3 !/0 !34 !3.'37*'3)4'3W! !/3 !06 !-6W# !/4 !04 !/0 !3/@'37&*| #&'%b&) /&' /&' /&' )&) '5 !46N'5 ! 7+4'77 )<'7' ;&!W&!I&!'&!A&' ?&h |!f&- )3+ | #,) 57| 3++,E7',)7!;7+ N| ' | #7.|!t ^&) | +&A .Y,+ d&+,5 K&63&6- p&-'- `& ! 3l&+ 3&F-+x t!t#| f&' 7*/ l!+ l#+ t&3 | 1&9 F|#5 |&v&5 O&7 3&|#E /&' !& | &!'&) ,' Q& ! 33,Q&'71,b&3 5,| ) I&!'&- -,O&/,) FW&- F| I | 9&+ ','&C,' | %,,)'!''- +'+&!)&!^&' )'+ .5,1 531 ^&',F^&),d 3&N[&''+ -,135 | 5&) 13O&' 3,I&- 3,G&1 +3; 1,| j | [&| 7 | /!= | /#1 /,l&+'3 7*|&S b,|!r ^&7,,3 O&9'+,-3|# Q&5 !('0| 3&A'13+ K,7*A )'0| #&)(+''('''3X+39 X' U&1 7*/ )'l&-'03'!7*+3,'(5 j&.'3,5 ''0| )&)(5''(+&+3+'F' 7* !&3,)3!K,9 G&!U&)()''( !'(''/3.| K 1& ! &!+&!A&!7&F/ | '&.)(3'- 7*/ '''(!3&' '&' O&!1&!'&!-&!'','(.+(' '(' )(' ,/ 0- -&'(' 1') -'|#+ | 3&)(3''()' !('+&-37* # 3 !'&d | )&)(/' !('+(''0'''& !3&3 7*|#b | '&)(+'' +(''0''Q3+&''h | )&)(3''( !'('')3,9 7*/ =3I z& !'(.'(/' !(',1 7*| 5 Y&' )''(+'0-'+ 7*',)3N|$; | &)(5'0''F|!7 d!d#7*5,; ,|#U 3&' r& !('0+'' ''+(.)&0Y ,7't&/' !(&+'33.3 ,/''()'| %&='0'')3,-3^ | ;&|%p 5&!n&01'!/' !(',-37 7*I,) '3`&' O' ! (1'0''0''| [ 1&!'&!p&/') !' ''!1' !&'3 7*/ /&!'&!d&-(!''!'( !'( !'&1 7*|&t I&'''('3|$I M,37+5E7= F|4O&|!; |!M+!-39 |$C&|^) |7l&!5<|zh |,z&}!+p |,^&1 b&!7*+ '3|!/ `&' -'F7 | )&1'-3+7+% !377 7*!1,!M&- I&|/= d!d#Q,+3|!9 | `&+ !'&| 7(1 +'=%| I '% !3%[ } NC&3 |0j&}!>j |&E&| + )&E +&3 |(l&|S= |!E&- =&) 5&1 7&' N''F+<} 4/ |%M77 r7' | A7'()')7/(3<3''71'`7+'| ?7Q | M7)'N|#I K,; | x75 U,|## W!W#W!1#!G#W!W# !! '!' $' '!' +!!3!+# ! #!1#!9#W!W#'!!+!' 3!!1!!W#'!!+!!-! ! !) 1!!W#W!W#W!W#W!W#W!W#W!W#W![#' U!HU#H/#U!HU#H/#U!HU#H/#U!HU#H/#U!HU#H/# !!#' | -*|+E7| 7'+7| -'37.?7.'7-3A -'!A'|>7 1'!E'' 1'!''!-'|$f | #&) 1'1%' 7*+ '&|(3 | &+'7*- J|<K |$E&' 5,1'v h!h#1'- 7*+ '3|1K | ?,N),J+,| b | #,NA,|$? +&!Y&!'& ! &' !& 7&!+& # &/ ,+ $& )&!'& ! &' && '& ! &' +&!1&!+&!+& ! &!7&!E&- )&!-&!E&| 1 '4|&# | 7+ |!77; A7' A7!A7!n77 =,) |!)7) | C7| ; ^7= | 7+ 571 '7? /7|#I |%W7-6|0/77 =7) 97- |!W7; |! 71 ;7K ;7+ | 973 77/ t73 `7| n ;7!|!97!+7) v7' /7) ^7' |##7; ?7' +7+ )7- )7= /7|>l }*Q/&v } !5&9 |$x&' } F'&? } m)&|ez |,'&|AO X` |!/<|!p |%A'}PF' "; + diff --git a/rts/js/verify.js b/rts/js/verify.js new file mode 100644 index 0000000000..a04a562b7f --- /dev/null +++ b/rts/js/verify.js @@ -0,0 +1,175 @@ +//#OPTIONS: CPP + +/* + Runtime inspection of Haskell data. + + The code generator can emit calls to these functions + */ +/* +function h$verify_rep_int64(x, y) { + +} + +function h$verify_rep_word64(x, y) { + +} +*/ + +/* + an int rep is an integer in range [-2^31..2^31-1] + (for Word# values, the value is treated as unsigned by the RTS. From + JavaScript it still looks signed. + ) + */ +function h$verify_rep_int(x) { + if(typeof x === 'number' && + (x|0) === x + ) return; + throw new Error("invalid int rep " + h$show_val(x)); +} + +/* +function h$verify_rep_word(x, y) { + +} +*/ +/* + a long rep is two integers in rage [-2^31..2^31-1] + */ +function h$verify_rep_long(x, y) { + if(typeof x === 'number' && + typeof y === 'number' && + (x|0) === x && + (y|0) === y + ) return; + throw new Error("invalid long rep " + h$show_val(x) + " " + h$show_val(y)); +} + +/* +function h$verify_rep_float(x) { + +} +*/ + +function h$verify_rep_double(x) { + if(typeof x === 'number') return; + throw new Error("invalid double rep " + h$show_val(x)); +} + +/* + an array rep is a JavaScript array. The elements are other + array reps or heap objects. + */ +function h$verify_rep_arr(x) { + if(h$verify_rep_is_arr(x)) return; + throw new Error("invalid array rep " + h$show_val(x)); +} + +function h$verify_rep_is_arr(x) { + // XXX check the elements? + return (typeof x === 'object' + && x + && Array.isArray(x) + // XXX enable this check + // && x.__ghcjsArray === true + ); +} + +function h$verify_rep_rtsobj(x) { + // unspecified unlifted value +} + +/* + an rts object rep is one of the known RTS object types + */ +function h$verify_rep_is_rtsobj(o) { + return (o instanceof h$MVar || + o instanceof h$MutVar || + o instanceof h$TVar || + o instanceof h$Transaction || + o instanceof h$Thread || + o instanceof h$Weak || + o instanceof h$StableName || + h$verify_rep_is_bytearray(o) || + h$verify_rep_is_arr(o)); +} + +function h$verify_rep_is_bytearray(o) { + return (typeof o === 'object' && + o && + typeof o.buf === 'object' && + o.buf && + o.buf instanceof ArrayBuffer && + typeof o.len === 'number'); +} + +/* + a heap object rep is either an object or an unboxed heap object + + unboxed heap objects store evaluated values of type 'number' or 'boolean' + without wrapping them in a normal heap object. this is only done for + data types with a single constructor and a single field of an appropriate type + */ +function h$verify_rep_heapobj(o) { + // possibly an unlifted rts object + // XXX: we should do a different check for these + if(h$verify_rep_is_rtsobj(o)) return; + // unboxed rep + if(typeof o === 'number' || typeof o === 'boolean') return; + // boxed rep + if(typeof o === 'object' && + o && + typeof o.f === 'function' && + typeof o.f.a === 'number' && + (typeof o.m === 'number' || (typeof o.m === 'object' && o.m)) + ) return; + throw new Error("invalid heapobj rep " + h$show_val(o)); +} + +/* + an addr rep is a data object and an integer offset + */ +function h$verify_rep_addr(v, o) { + if(typeof o === 'number' && + (o|0) === o && + // o >= 0 && // XXX we could treat it as unsigned, should we? + typeof v === 'object' + ) return; + throw new Error("invalid addr rep " + h$show_val(v) + " " + o); +} + +/* + v must be a value of type tc that can be matched + */ +function h$verify_match_alg(tc, v) { + if(typeof v === 'boolean') { + if(tc === "ghc-prim:GHC.Types.Bool") return; + throw new Error("invalid pattern match boolean rep " + tc); + } else if(typeof v === 'number') { + // h$log("h$verify_match_alg number: " + tc); + return; + } else if(typeof v === 'object') { + // h$log("verify_match_alg_obj: " + tc); + if(!(typeof v.f === 'function' && + typeof v.f.a === 'number' && + typeof v.f.t === 'number' && + v.f.t === 2 /// con + )) { + throw new Error("not a data constructor " + tc + ": " + h$show_val(v)); + } + // XXX add check for the type + return; + } + throw new Error("invalid pattern match rep " + tc + ": " + h$show_val(v)); +} + +/* + debug show object + */ + +function h$show_val(o) { + if(typeof o === 'undefined') return '<undefined>' + if(o === null) return '<null>' + if(typeof o !== 'object') return '[' + (typeof o) + ': ' + o + ']' + return '' + o + ' [' + o.constructor.name + '] ' + h$collectProps(o); +} diff --git a/rts/js/weak.js b/rts/js/weak.js new file mode 100644 index 0000000000..f8b76a86d4 --- /dev/null +++ b/rts/js/weak.js @@ -0,0 +1,90 @@ +//#OPTIONS: CPP + +// weak reference support + +var h$weakPointerList = []; + +#ifdef GHCJS_TRACE_WEAK +function h$traceWeak() { h$log.apply(h$log, arguments) } +#define TRACE_WEAK(args...) h$traceWeak(args) +#else +#define TRACE_WEAK(args...) +#endif + +// called by the GC after marking the heap +function h$finalizeWeaks(toFinalize) { + var mark = h$gcMark; + var i, w; + + TRACE_WEAK("to finalize: " + toFinalize.length) + // start a finalizer thread if any finalizers need to be run + if(toFinalize.length > 0) { + var t = new h$Thread(); + for(i=0;i<toFinalize.length;i++) { + w = toFinalize[i]; + t.sp += 6; + t.stack[t.sp-5] = 0; // mask + t.stack[t.sp-4] = h$noop; // handler, dummy + t.stack[t.sp-3] = h$catch_e; + t.stack[t.sp-2] = h$ap_1_0; + t.stack[t.sp-1] = w.finalizer; + t.stack[t.sp] = h$return; + w.finalizer = null; + } + h$wakeupThread(t); + } +} + +var h$weakN = 0; +/** @constructor */ +function h$Weak(key, val, finalizer) { + if(typeof key !== 'object') { + // can't attach a StableName to objects with unboxed storage + // our weak ref will be finalized soon. + TRACE_WEAK("WARNING: making weak for object with unboxed storage") + this.keym = new h$StableName(0); + } else { + if(typeof key.m !== 'object') { + if(typeof key.m !== 'number') { + h$log("attaching weak to unsupported object"); + } + key.m = new h$StableName(key.m); + } + this.keym = key.m; + } + TRACE_WEAK("making weak of: " + h$stableNameInt(this.keym)) + this.keym = key.m; + this.val = val; + this.finalizer = null; + if(finalizer !== null) { + this.finalizer = finalizer; + } + this.m = 0; + this._key = ++h$weakN; + h$weakPointerList.push(this); +#ifdef GHCJS_DEBUG_ALLOC + h$debugAlloc_notifyAlloc(this); +#endif +} + +function h$makeWeak(key, val, fin) { + TRACE_WEAK("h$makeWeak") + return new h$Weak(key, val, fin) +} + +function h$makeWeakNoFinalizer(key, val) { + TRACE_WEAK("h$makeWeakNoFinalizer") + return new h$Weak(key, val, null); +} + +function h$finalizeWeak(w) { + TRACE_WEAK("finalizing weak of " + h$stableNameInt(w.keym)) + w.val = null; + if(w.finalizer === null || w.finalizer.finalizer === null) { + RETURN_UBX_TUP2(null, 0); + } else { + var r = w.finalizer; + w.finalizer = null; + RETURN_UBX_TUP2(r, 1); + } +} diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in index 641502ff45..9cdaae0bbe 100644 --- a/rts/rts.cabal.in +++ b/rts/rts.cabal.in @@ -66,570 +66,616 @@ library -- set without version ghc-options: -this-unit-id rts - -- If we are using an in-tree libffi then we must declare it as a bundled - -- library to ensure that Cabal installs it. - if !flag(use-system-libffi) - if os(windows) - extra-bundled-libraries: Cffi-6 - else - extra-bundled-libraries: Cffi - install-includes: ffi.h ffitarget.h - -- ^ see Note [Packaging libffi headers] in - -- GHC.Driver.CodeOutput. - - -- Here we declare several flavours to be available when passing the - -- suitable (combination of) flag(s) when configuring the RTS from hadrian, - -- using Cabal. - if flag(threaded) - extra-library-flavours: _thr - - if flag(profiling) - extra-library-flavours: _p + exposed: True + exposed-modules: + + if os(ghcjs) + + include-dirs: include + -- dummy file to force the build of a .a lib + -- FIXME (Luite, 2022-08) do we still need the c-sources file? + c-sources: version.c + + js-sources: + js/structs.js + js/arith.js + js/compact.js + js/debug.js + js/enum.js + js/environment.js + js/gc.js + js/goog.js + js/hscore.js + js/md5.js + js/mem.js + js/node-exports.js + js/object.js + js/profiling.js + js/rts.js + js/stableptr.js + js/staticpointer.js + js/stm.js + js/string.js + js/thread.js + js/unicode.js + js/verify.js + js/weak.js + js/globals.js + + install-includes: HsFFI.h MachDeps.h Rts.h RtsAPI.h Stg.h + ghcautoconf.h ghcconfig.h ghcplatform.h ghcversion.h + DerivedConstants.h + stg/MachRegs.h + stg/MachRegsForHost.h + stg/Types.h + + else + -- If we are using an in-tree libffi then we must declare it as a bundled + -- library to ensure that Cabal installs it. + if !flag(use-system-libffi) + if os(windows) + extra-bundled-libraries: Cffi-6 + else + extra-bundled-libraries: Cffi + + install-includes: ffi.h ffitarget.h + -- ^ see Note [Packaging libffi headers] in + -- GHC.Driver.CodeOutput. + + -- Here we declare several flavours to be available when passing the + -- suitable (combination of) flag(s) when configuring the RTS from hadrian, + -- using Cabal. if flag(threaded) - extra-library-flavours: _thr_p - if flag(debug) - extra-library-flavours: _debug_p + extra-library-flavours: _thr + if flag(dynamic) + extra-dynamic-library-flavours: _thr + + if flag(profiling) + extra-library-flavours: _p if flag(threaded) - extra-library-flavours: _thr_debug_p - if flag(debug) - extra-library-flavours: _debug - if flag(threaded) - extra-library-flavours: _thr_debug - if flag(dynamic) - extra-dynamic-library-flavours: _debug + extra-library-flavours: _thr_p + if flag(debug) + extra-library-flavours: _debug_p + if flag(threaded) + extra-library-flavours: _thr_debug_p + + if flag(debug) + extra-library-flavours: _debug + if flag(dynamic) + extra-dynamic-library-flavours: _debug if flag(threaded) - extra-dynamic-library-flavours: _thr_debug - if flag(dynamic) && flag(threaded) - extra-dynamic-library-flavours: _thr + extra-library-flavours: _thr_debug + if flag(dynamic) + extra-dynamic-library-flavours: _thr_debug - if flag(thread-sanitizer) - cc-options: -fsanitize=thread - ld-options: -fsanitize=thread - extra-libraries: tsan + if flag(thread-sanitizer) + cc-options: -fsanitize=thread + ld-options: -fsanitize=thread + extra-libraries: tsan - exposed: True - exposed-modules: - if os(linux) - -- the RTS depends upon libc. while this dependency is generally - -- implicitly added by `cc`, we must explicitly add it here to ensure - -- that it is ordered correctly with libpthread, since ghc-prim.cabal - -- also explicitly lists libc. See #19029. - extra-libraries: c - if flag(libm) - -- for ldexp() - extra-libraries: m - if flag(librt) - extra-libraries: rt - if flag(libdl) - extra-libraries: dl - if flag(use-system-libffi) - extra-libraries: ffi - if os(windows) - extra-libraries: - -- for the linker - wsock32 gdi32 winmm - -- for crash dump - dbghelp - -- for process information - psapi - -- TODO: Hadrian will use this cabal file, so drop WINVER from Hadrian's configs. - -- Minimum supported Windows version. - -- These numbers can be found at: - -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx - -- If we're compiling on windows, enforce that we only support Windows 7+ - -- Adding this here means it doesn't have to be done in individual .c files - -- and also centralizes the versioning. - cpp-options: -D_WIN32_WINNT=0x06010000 - cc-options: -D_WIN32_WINNT=0x06010000 - if flag(need-pthread) - -- for pthread_getthreadid_np, pthread_create, ... - extra-libraries: pthread - if flag(need-atomic) - -- for sub-word-sized atomic operations (#19119) - extra-libraries: atomic - if flag(libbfd) - -- for debugging - extra-libraries: bfd iberty - if flag(mingwex) - extra-libraries: mingwex - if flag(libdw) - -- for backtraces - extra-libraries: elf dw - if flag(libnuma) - extra-libraries: numa - if !flag(smp) - cpp-options: -DNOSMP - - include-dirs: include - @FFIIncludeDir@ - @LibdwIncludeDir@ - includes: Rts.h - install-includes: Cmm.h HsFFI.h MachDeps.h Rts.h RtsAPI.h Stg.h - ghcautoconf.h ghcconfig.h ghcplatform.h ghcversion.h - -- ^ from include - DerivedConstants.h - rts/EventLogConstants.h - rts/EventTypes.h - -- ^ generated - rts/Adjustor.h - rts/ExecPage.h - rts/BlockSignals.h - rts/Bytecodes.h - rts/Config.h - rts/Constants.h - rts/EventLogFormat.h - rts/EventLogWriter.h - rts/FileLock.h - rts/Flags.h - rts/ForeignExports.h - rts/GetTime.h - rts/Globals.h - rts/Hpc.h - rts/IOInterface.h - rts/Libdw.h - rts/LibdwPool.h - rts/Linker.h - rts/Main.h - rts/Messages.h - rts/NonMoving.h - rts/OSThreads.h - rts/Parallel.h - rts/PrimFloat.h - rts/Profiling.h - rts/IPE.h - rts/PosixSource.h - rts/Signals.h - rts/SpinLock.h - rts/StableName.h - rts/StablePtr.h - rts/StaticPtrTable.h - rts/TTY.h - rts/Threads.h - rts/Ticky.h - rts/Time.h - rts/Timer.h - rts/TSANUtils.h - rts/Types.h - rts/Utils.h - rts/prof/CCS.h - rts/prof/Heap.h - rts/prof/LDV.h - rts/storage/Block.h - rts/storage/ClosureMacros.h - rts/storage/ClosureTypes.h - rts/storage/Closures.h - rts/storage/FunTypes.h - rts/storage/Heap.h - rts/storage/GC.h - rts/storage/InfoTables.h - rts/storage/MBlock.h - rts/storage/TSO.h - stg/DLL.h - stg/MachRegs.h - stg/MachRegsForHost.h - stg/MiscClosures.h - stg/Prim.h - stg/Regs.h - stg/SMP.h - stg/Ticky.h - stg/Types.h - if flag(64bit) - if flag(leading-underscore) - ld-options: - "-Wl,-u,_hs_atomic_add64" - "-Wl,-u,_hs_atomic_sub64" - "-Wl,-u,_hs_atomic_and64" - "-Wl,-u,_hs_atomic_nand64" - "-Wl,-u,_hs_atomic_or64" - "-Wl,-u,_hs_atomic_xor64" - "-Wl,-u,_hs_atomicread64" - "-Wl,-u,_hs_atomicwrite64" - else - ld-options: - "-Wl,-u,hs_atomic_add64" - "-Wl,-u,hs_atomic_sub64" - "-Wl,-u,hs_atomic_and64" - "-Wl,-u,hs_atomic_nand64" - "-Wl,-u,hs_atomic_or64" - "-Wl,-u,hs_atomic_xor64" - "-Wl,-u,hs_atomicread64" - "-Wl,-u,hs_atomicwrite64" - if flag(leading-underscore) - ld-options: - "-Wl,-u,_base_GHCziTopHandler_runIO_closure" - "-Wl,-u,_base_GHCziTopHandler_runNonIO_closure" - "-Wl,-u,_ghczmprim_GHCziTupleziPrim_Z0T_closure" - "-Wl,-u,_ghczmprim_GHCziTypes_True_closure" - "-Wl,-u,_ghczmprim_GHCziTypes_False_closure" - "-Wl,-u,_base_GHCziPack_unpackCString_closure" - "-Wl,-u,_base_GHCziWeakziFinalizze_runFinalizzerBatch_closure" - "-Wl,-u,_base_GHCziIOziException_stackOverflow_closure" - "-Wl,-u,_base_GHCziIOziException_heapOverflow_closure" - "-Wl,-u,_base_GHCziIOziException_allocationLimitExceeded_closure" - "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" - "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" - "-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure" - "-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure" - "-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure" - "-Wl,-u,_base_GHCziIOPort_doubleReadException_closure" - "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure" - "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure" - "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure" - "-Wl,-u,_base_GHCziConcziSync_runSparks_closure" - "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" - "-Wl,-u,_base_GHCziConcziIO_interruptIOManager_closure" - "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" - "-Wl,-u,_base_GHCziConcziSignal_runHandlersPtr_closure" - "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure" - "-Wl,-u,_base_GHCziTopHandler_runMainIO_closure" - "-Wl,-u,_ghczmprim_GHCziTypes_Czh_con_info" - "-Wl,-u,_ghczmprim_GHCziTypes_Izh_con_info" - "-Wl,-u,_ghczmprim_GHCziTypes_Fzh_con_info" - "-Wl,-u,_ghczmprim_GHCziTypes_Dzh_con_info" - "-Wl,-u,_ghczmprim_GHCziTypes_Wzh_con_info" - "-Wl,-u,_base_GHCziPtr_Ptr_con_info" - "-Wl,-u,_base_GHCziPtr_FunPtr_con_info" - "-Wl,-u,_base_GHCziInt_I8zh_con_info" - "-Wl,-u,_base_GHCziInt_I16zh_con_info" - "-Wl,-u,_base_GHCziInt_I32zh_con_info" - "-Wl,-u,_base_GHCziInt_I64zh_con_info" - "-Wl,-u,_base_GHCziWord_W8zh_con_info" - "-Wl,-u,_base_GHCziWord_W16zh_con_info" - "-Wl,-u,_base_GHCziWord_W32zh_con_info" - "-Wl,-u,_base_GHCziWord_W64zh_con_info" - "-Wl,-u,_base_GHCziStable_StablePtr_con_info" - "-Wl,-u,_hs_atomic_add8" - "-Wl,-u,_hs_atomic_add16" - "-Wl,-u,_hs_atomic_add32" - "-Wl,-u,_hs_atomic_sub8" - "-Wl,-u,_hs_atomic_sub16" - "-Wl,-u,_hs_atomic_sub32" - "-Wl,-u,_hs_atomic_and8" - "-Wl,-u,_hs_atomic_and16" - "-Wl,-u,_hs_atomic_and32" - "-Wl,-u,_hs_atomic_nand8" - "-Wl,-u,_hs_atomic_nand16" - "-Wl,-u,_hs_atomic_nand32" - "-Wl,-u,_hs_atomic_or8" - "-Wl,-u,_hs_atomic_or16" - "-Wl,-u,_hs_atomic_or32" - "-Wl,-u,_hs_atomic_xor8" - "-Wl,-u,_hs_atomic_xor16" - "-Wl,-u,_hs_atomic_xor32" - "-Wl,-u,_hs_cmpxchg8" - "-Wl,-u,_hs_cmpxchg16" - "-Wl,-u,_hs_cmpxchg32" - "-Wl,-u,_hs_cmpxchg64" - "-Wl,-u,_hs_xchg8" - "-Wl,-u,_hs_xchg16" - "-Wl,-u,_hs_xchg32" - "-Wl,-u,_hs_xchg64" - "-Wl,-u,_hs_atomicread8" - "-Wl,-u,_hs_atomicread16" - "-Wl,-u,_hs_atomicread32" - "-Wl,-u,_hs_atomicwrite8" - "-Wl,-u,_hs_atomicwrite16" - "-Wl,-u,_hs_atomicwrite32" - "-Wl,-u,_base_GHCziStackziCloneStack_StackSnapshot_closure" - - if flag(find-ptr) - -- This symbol is useful in gdb, but not referred to anywhere, - -- so we need to force it to be included in the binary. - ld-options: "-Wl,-u,_findPtr" + if os(linux) + -- the RTS depends upon libc. while this dependency is generally + -- implicitly added by `cc`, we must explicitly add it here to ensure + -- that it is ordered correctly with libpthread, since ghc-prim.cabal + -- also explicitly lists libc. See #19029. + extra-libraries: c + if flag(libm) + -- for ldexp() + extra-libraries: m + if flag(librt) + extra-libraries: rt + if flag(libdl) + extra-libraries: dl + if flag(use-system-libffi) + extra-libraries: ffi + if os(windows) + extra-libraries: + -- for the linker + wsock32 gdi32 winmm + -- for crash dump + dbghelp + -- for process information + psapi + -- TODO: Hadrian will use this cabal file, so drop WINVER from Hadrian's configs. + -- Minimum supported Windows version. + -- These numbers can be found at: + -- https://msdn.microsoft.com/en-us/library/windows/desktop/aa383745(v=vs.85).aspx + -- If we're compiling on windows, enforce that we only support Windows 7+ + -- Adding this here means it doesn't have to be done in individual .c files + -- and also centralizes the versioning. + cpp-options: -D_WIN32_WINNT=0x06010000 + cc-options: -D_WIN32_WINNT=0x06010000 + if flag(need-pthread) + -- for pthread_getthreadid_np, pthread_create, ... + extra-libraries: pthread + if flag(need-atomic) + -- for sub-word-sized atomic operations (#19119) + extra-libraries: atomic + if flag(libbfd) + -- for debugging + extra-libraries: bfd iberty + if flag(mingwex) + extra-libraries: mingwex + if flag(libdw) + -- for backtraces + extra-libraries: elf dw + if flag(libnuma) + extra-libraries: numa + if !flag(smp) + cpp-options: -DNOSMP - else - ld-options: - "-Wl,-u,base_GHCziTopHandler_runIO_closure" - "-Wl,-u,base_GHCziTopHandler_runNonIO_closure" - "-Wl,-u,ghczmprim_GHCziTupleziPrim_Z0T_closure" - "-Wl,-u,ghczmprim_GHCziTypes_True_closure" - "-Wl,-u,ghczmprim_GHCziTypes_False_closure" - "-Wl,-u,base_GHCziPack_unpackCString_closure" - "-Wl,-u,base_GHCziWeakziFinalizze_runFinalizzerBatch_closure" - "-Wl,-u,base_GHCziIOziException_stackOverflow_closure" - "-Wl,-u,base_GHCziIOziException_heapOverflow_closure" - "-Wl,-u,base_GHCziIOziException_allocationLimitExceeded_closure" - "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" - "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" - "-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure" - "-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure" - "-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure" - "-Wl,-u,base_GHCziIOPort_doubleReadException_closure" - "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure" - "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure" - "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure" - "-Wl,-u,base_GHCziConcziSync_runSparks_closure" - "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure" - "-Wl,-u,base_GHCziConcziIO_interruptIOManager_closure" - "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" - "-Wl,-u,base_GHCziConcziSignal_runHandlersPtr_closure" - "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure" - "-Wl,-u,base_GHCziTopHandler_runMainIO_closure" - "-Wl,-u,ghczmprim_GHCziTypes_Czh_con_info" - "-Wl,-u,ghczmprim_GHCziTypes_Izh_con_info" - "-Wl,-u,ghczmprim_GHCziTypes_Fzh_con_info" - "-Wl,-u,ghczmprim_GHCziTypes_Dzh_con_info" - "-Wl,-u,ghczmprim_GHCziTypes_Wzh_con_info" - "-Wl,-u,base_GHCziPtr_Ptr_con_info" - "-Wl,-u,base_GHCziPtr_FunPtr_con_info" - "-Wl,-u,base_GHCziInt_I8zh_con_info" - "-Wl,-u,base_GHCziInt_I16zh_con_info" - "-Wl,-u,base_GHCziInt_I32zh_con_info" - "-Wl,-u,base_GHCziInt_I64zh_con_info" - "-Wl,-u,base_GHCziWord_W8zh_con_info" - "-Wl,-u,base_GHCziWord_W16zh_con_info" - "-Wl,-u,base_GHCziWord_W32zh_con_info" - "-Wl,-u,base_GHCziWord_W64zh_con_info" - "-Wl,-u,base_GHCziStable_StablePtr_con_info" - "-Wl,-u,hs_atomic_add8" - "-Wl,-u,hs_atomic_add16" - "-Wl,-u,hs_atomic_add32" - "-Wl,-u,hs_atomic_sub8" - "-Wl,-u,hs_atomic_sub16" - "-Wl,-u,hs_atomic_sub32" - "-Wl,-u,hs_atomic_and8" - "-Wl,-u,hs_atomic_and16" - "-Wl,-u,hs_atomic_and32" - "-Wl,-u,hs_atomic_nand8" - "-Wl,-u,hs_atomic_nand16" - "-Wl,-u,hs_atomic_nand32" - "-Wl,-u,hs_atomic_or8" - "-Wl,-u,hs_atomic_or16" - "-Wl,-u,hs_atomic_or32" - "-Wl,-u,hs_atomic_xor8" - "-Wl,-u,hs_atomic_xor16" - "-Wl,-u,hs_atomic_xor32" - "-Wl,-u,hs_cmpxchg8" - "-Wl,-u,hs_cmpxchg16" - "-Wl,-u,hs_cmpxchg32" - "-Wl,-u,hs_cmpxchg64" - "-Wl,-u,hs_xchg8" - "-Wl,-u,hs_xchg16" - "-Wl,-u,hs_xchg32" - "-Wl,-u,hs_xchg64" - "-Wl,-u,hs_atomicread8" - "-Wl,-u,hs_atomicread16" - "-Wl,-u,hs_atomicread32" - "-Wl,-u,hs_atomicwrite8" - "-Wl,-u,hs_atomicwrite16" - "-Wl,-u,hs_atomicwrite32" - "-Wl,-u,base_GHCziStackziCloneStack_StackSnapshot_closure" - - if flag(find-ptr) - -- This symbol is useful in gdb, but not referred to anywhere, - -- so we need to force it to be included in the binary. - ld-options: "-Wl,-u,findPtr" - - if os(windows) + include-dirs: include + @FFIIncludeDir@ + @LibdwIncludeDir@ + + + includes: Rts.h + install-includes: Cmm.h HsFFI.h MachDeps.h Rts.h RtsAPI.h Stg.h + ghcautoconf.h ghcconfig.h ghcplatform.h ghcversion.h + -- ^ from include + DerivedConstants.h + rts/EventLogConstants.h + rts/EventTypes.h + -- ^ generated + rts/Adjustor.h + rts/ExecPage.h + rts/BlockSignals.h + rts/Bytecodes.h + rts/Config.h + rts/Constants.h + rts/EventLogFormat.h + rts/EventLogWriter.h + rts/FileLock.h + rts/Flags.h + rts/ForeignExports.h + rts/GetTime.h + rts/Globals.h + rts/Hpc.h + rts/IOInterface.h + rts/Libdw.h + rts/LibdwPool.h + rts/Linker.h + rts/Main.h + rts/Messages.h + rts/NonMoving.h + rts/OSThreads.h + rts/Parallel.h + rts/PrimFloat.h + rts/Profiling.h + rts/IPE.h + rts/PosixSource.h + rts/Signals.h + rts/SpinLock.h + rts/StableName.h + rts/StablePtr.h + rts/StaticPtrTable.h + rts/TTY.h + rts/Threads.h + rts/Ticky.h + rts/Time.h + rts/Timer.h + rts/TSANUtils.h + rts/Types.h + rts/Utils.h + rts/prof/CCS.h + rts/prof/Heap.h + rts/prof/LDV.h + rts/storage/Block.h + rts/storage/ClosureMacros.h + rts/storage/ClosureTypes.h + rts/storage/Closures.h + rts/storage/FunTypes.h + rts/storage/Heap.h + rts/storage/GC.h + rts/storage/InfoTables.h + rts/storage/MBlock.h + rts/storage/TSO.h + stg/DLL.h + stg/MachRegs.h + stg/MachRegsForHost.h + stg/MiscClosures.h + stg/Prim.h + stg/Regs.h + stg/SMP.h + stg/Ticky.h + stg/Types.h + if flag(64bit) + if flag(leading-underscore) + ld-options: + "-Wl,-u,_hs_atomic_add64" + "-Wl,-u,_hs_atomic_sub64" + "-Wl,-u,_hs_atomic_and64" + "-Wl,-u,_hs_atomic_nand64" + "-Wl,-u,_hs_atomic_or64" + "-Wl,-u,_hs_atomic_xor64" + "-Wl,-u,_hs_atomicread64" + "-Wl,-u,_hs_atomicwrite64" + else + ld-options: + "-Wl,-u,hs_atomic_add64" + "-Wl,-u,hs_atomic_sub64" + "-Wl,-u,hs_atomic_and64" + "-Wl,-u,hs_atomic_nand64" + "-Wl,-u,hs_atomic_or64" + "-Wl,-u,hs_atomic_xor64" + "-Wl,-u,hs_atomicread64" + "-Wl,-u,hs_atomicwrite64" if flag(leading-underscore) ld-options: - "-Wl,-u,_base_GHCziEventziWindows_processRemoteCompletion_closure" + "-Wl,-u,_base_GHCziTopHandler_runIO_closure" + "-Wl,-u,_base_GHCziTopHandler_runNonIO_closure" + "-Wl,-u,_ghczmprim_GHCziTupleziPrim_Z0T_closure" + "-Wl,-u,_ghczmprim_GHCziTypes_True_closure" + "-Wl,-u,_ghczmprim_GHCziTypes_False_closure" + "-Wl,-u,_base_GHCziPack_unpackCString_closure" + "-Wl,-u,_base_GHCziWeakziFinalizze_runFinalizzerBatch_closure" + "-Wl,-u,_base_GHCziIOziException_stackOverflow_closure" + "-Wl,-u,_base_GHCziIOziException_heapOverflow_closure" + "-Wl,-u,_base_GHCziIOziException_allocationLimitExceeded_closure" + "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" + "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" + "-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure" + "-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure" + "-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure" + "-Wl,-u,_base_GHCziIOPort_doubleReadException_closure" + "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure" + "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure" + "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure" + "-Wl,-u,_base_GHCziConcziSync_runSparks_closure" + "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + "-Wl,-u,_base_GHCziConcziIO_interruptIOManager_closure" + "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" + "-Wl,-u,_base_GHCziConcziSignal_runHandlersPtr_closure" + "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure" + "-Wl,-u,_base_GHCziTopHandler_runMainIO_closure" + "-Wl,-u,_ghczmprim_GHCziTypes_Czh_con_info" + "-Wl,-u,_ghczmprim_GHCziTypes_Izh_con_info" + "-Wl,-u,_ghczmprim_GHCziTypes_Fzh_con_info" + "-Wl,-u,_ghczmprim_GHCziTypes_Dzh_con_info" + "-Wl,-u,_ghczmprim_GHCziTypes_Wzh_con_info" + "-Wl,-u,_base_GHCziPtr_Ptr_con_info" + "-Wl,-u,_base_GHCziPtr_FunPtr_con_info" + "-Wl,-u,_base_GHCziInt_I8zh_con_info" + "-Wl,-u,_base_GHCziInt_I16zh_con_info" + "-Wl,-u,_base_GHCziInt_I32zh_con_info" + "-Wl,-u,_base_GHCziInt_I64zh_con_info" + "-Wl,-u,_base_GHCziWord_W8zh_con_info" + "-Wl,-u,_base_GHCziWord_W16zh_con_info" + "-Wl,-u,_base_GHCziWord_W32zh_con_info" + "-Wl,-u,_base_GHCziWord_W64zh_con_info" + "-Wl,-u,_base_GHCziStable_StablePtr_con_info" + "-Wl,-u,_hs_atomic_add8" + "-Wl,-u,_hs_atomic_add16" + "-Wl,-u,_hs_atomic_add32" + "-Wl,-u,_hs_atomic_sub8" + "-Wl,-u,_hs_atomic_sub16" + "-Wl,-u,_hs_atomic_sub32" + "-Wl,-u,_hs_atomic_and8" + "-Wl,-u,_hs_atomic_and16" + "-Wl,-u,_hs_atomic_and32" + "-Wl,-u,_hs_atomic_nand8" + "-Wl,-u,_hs_atomic_nand16" + "-Wl,-u,_hs_atomic_nand32" + "-Wl,-u,_hs_atomic_or8" + "-Wl,-u,_hs_atomic_or16" + "-Wl,-u,_hs_atomic_or32" + "-Wl,-u,_hs_atomic_xor8" + "-Wl,-u,_hs_atomic_xor16" + "-Wl,-u,_hs_atomic_xor32" + "-Wl,-u,_hs_cmpxchg8" + "-Wl,-u,_hs_cmpxchg16" + "-Wl,-u,_hs_cmpxchg32" + "-Wl,-u,_hs_cmpxchg64" + "-Wl,-u,_hs_xchg8" + "-Wl,-u,_hs_xchg16" + "-Wl,-u,_hs_xchg32" + "-Wl,-u,_hs_xchg64" + "-Wl,-u,_hs_atomicread8" + "-Wl,-u,_hs_atomicread16" + "-Wl,-u,_hs_atomicread32" + "-Wl,-u,_hs_atomicwrite8" + "-Wl,-u,_hs_atomicwrite16" + "-Wl,-u,_hs_atomicwrite32" + "-Wl,-u,_base_GHCziStackziCloneStack_StackSnapshot_closure" + + if flag(find-ptr) + -- This symbol is useful in gdb, but not referred to anywhere, + -- so we need to force it to be included in the binary. + ld-options: "-Wl,-u,_findPtr" + else ld-options: - "-Wl,-u,base_GHCziEventziWindows_processRemoteCompletion_closure" - - if os(osx) - ld-options: "-Wl,-search_paths_first" - -- See Note [fd_set_overflow] - "-Wl,-U,___darwin_check_fd_set_overflow" - if !arch(x86_64) && !arch(aarch64) - ld-options: -read_only_relocs warning - - cmm-sources: Apply.cmm - Compact.cmm - ContinuationOps.cmm - Exception.cmm - HeapStackCheck.cmm - PrimOps.cmm - StgMiscClosures.cmm - StgStartup.cmm - StgStdThunks.cmm - Updates.cmm - -- AutoApply is generated - AutoApply.cmm - - -- Adjustor stuff - if flag(libffi-adjustors) - c-sources: adjustor/LibffiAdjustor.c - else - -- Use GHC's native adjustors - if arch(i386) - asm-sources: adjustor/Nativei386Asm.S - c-sources: adjustor/Nativei386.c - if arch(x86_64) - if os(mingw32) - asm-sources: adjustor/NativeAmd64MingwAsm.S - c-sources: adjustor/NativeAmd64Mingw.c + "-Wl,-u,base_GHCziTopHandler_runIO_closure" + "-Wl,-u,base_GHCziTopHandler_runNonIO_closure" + "-Wl,-u,ghczmprim_GHCziTupleziPrim_Z0T_closure" + "-Wl,-u,ghczmprim_GHCziTypes_True_closure" + "-Wl,-u,ghczmprim_GHCziTypes_False_closure" + "-Wl,-u,base_GHCziPack_unpackCString_closure" + "-Wl,-u,base_GHCziWeakziFinalizze_runFinalizzerBatch_closure" + "-Wl,-u,base_GHCziIOziException_stackOverflow_closure" + "-Wl,-u,base_GHCziIOziException_heapOverflow_closure" + "-Wl,-u,base_GHCziIOziException_allocationLimitExceeded_closure" + "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" + "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" + "-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure" + "-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure" + "-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure" + "-Wl,-u,base_GHCziIOPort_doubleReadException_closure" + "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure" + "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure" + "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure" + "-Wl,-u,base_GHCziConcziSync_runSparks_closure" + "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + "-Wl,-u,base_GHCziConcziIO_interruptIOManager_closure" + "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" + "-Wl,-u,base_GHCziConcziSignal_runHandlersPtr_closure" + "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure" + "-Wl,-u,base_GHCziTopHandler_runMainIO_closure" + "-Wl,-u,ghczmprim_GHCziTypes_Czh_con_info" + "-Wl,-u,ghczmprim_GHCziTypes_Izh_con_info" + "-Wl,-u,ghczmprim_GHCziTypes_Fzh_con_info" + "-Wl,-u,ghczmprim_GHCziTypes_Dzh_con_info" + "-Wl,-u,ghczmprim_GHCziTypes_Wzh_con_info" + "-Wl,-u,base_GHCziPtr_Ptr_con_info" + "-Wl,-u,base_GHCziPtr_FunPtr_con_info" + "-Wl,-u,base_GHCziInt_I8zh_con_info" + "-Wl,-u,base_GHCziInt_I16zh_con_info" + "-Wl,-u,base_GHCziInt_I32zh_con_info" + "-Wl,-u,base_GHCziInt_I64zh_con_info" + "-Wl,-u,base_GHCziWord_W8zh_con_info" + "-Wl,-u,base_GHCziWord_W16zh_con_info" + "-Wl,-u,base_GHCziWord_W32zh_con_info" + "-Wl,-u,base_GHCziWord_W64zh_con_info" + "-Wl,-u,base_GHCziStable_StablePtr_con_info" + "-Wl,-u,hs_atomic_add8" + "-Wl,-u,hs_atomic_add16" + "-Wl,-u,hs_atomic_add32" + "-Wl,-u,hs_atomic_sub8" + "-Wl,-u,hs_atomic_sub16" + "-Wl,-u,hs_atomic_sub32" + "-Wl,-u,hs_atomic_and8" + "-Wl,-u,hs_atomic_and16" + "-Wl,-u,hs_atomic_and32" + "-Wl,-u,hs_atomic_nand8" + "-Wl,-u,hs_atomic_nand16" + "-Wl,-u,hs_atomic_nand32" + "-Wl,-u,hs_atomic_or8" + "-Wl,-u,hs_atomic_or16" + "-Wl,-u,hs_atomic_or32" + "-Wl,-u,hs_atomic_xor8" + "-Wl,-u,hs_atomic_xor16" + "-Wl,-u,hs_atomic_xor32" + "-Wl,-u,hs_cmpxchg8" + "-Wl,-u,hs_cmpxchg16" + "-Wl,-u,hs_cmpxchg32" + "-Wl,-u,hs_cmpxchg64" + "-Wl,-u,hs_xchg8" + "-Wl,-u,hs_xchg16" + "-Wl,-u,hs_xchg32" + "-Wl,-u,hs_xchg64" + "-Wl,-u,hs_atomicread8" + "-Wl,-u,hs_atomicread16" + "-Wl,-u,hs_atomicread32" + "-Wl,-u,hs_atomicwrite8" + "-Wl,-u,hs_atomicwrite16" + "-Wl,-u,hs_atomicwrite32" + "-Wl,-u,base_GHCziStackziCloneStack_StackSnapshot_closure" + + if flag(find-ptr) + -- This symbol is useful in gdb, but not referred to anywhere, + -- so we need to force it to be included in the binary. + ld-options: "-Wl,-u,findPtr" + + if os(windows) + if flag(leading-underscore) + ld-options: + "-Wl,-u,_base_GHCziEventziWindows_processRemoteCompletion_closure" else - asm-sources: adjustor/NativeAmd64Asm.S - c-sources: adjustor/NativeAmd64.c - if arch(ppc) || arch(ppc64) - asm-sources: AdjustorAsm.S - c-sources: adjustor/NativePowerPC.c - if arch(ia64) - c-sources: adjustor/NativeIA64.c - - -- Use assembler STG entrypoint on architectures where it is used - if arch(ppc) || arch(ppc64) || arch(s390x) || arch(riscv64) - asm-sources: StgCRunAsm.S - - c-sources: Adjustor.c - adjustor/AdjustorPool.c - ExecPage.c - Arena.c - Capability.c - CheckUnload.c - CloneStack.c - ClosureFlags.c - ClosureSize.c - Continuation.c - Disassembler.c - FileLock.c - ForeignExports.c - Globals.c - Hash.c - Heap.c - Hpc.c - HsFFI.c - Inlines.c - Interpreter.c - IOManager.c - LdvProfile.c - Libdw.c - LibdwPool.c - Linker.c - ReportMemoryMap.c - Messages.c - OldARMAtomic.c - PathUtils.c - Pool.c - Printer.c - ProfHeap.c - ProfilerReport.c - ProfilerReportJson.c - Profiling.c - IPE.c - Proftimer.c - RaiseAsync.c - RetainerProfile.c - RetainerSet.c - RtsAPI.c - RtsDllMain.c - RtsFlags.c - RtsMain.c - RtsMessages.c - RtsStartup.c - RtsSymbolInfo.c - RtsSymbols.c - RtsUtils.c - STM.c - Schedule.c - Sparks.c - SpinLock.c - StableName.c - StablePtr.c - StaticPtrTable.c - Stats.c - StgCRun.c - StgPrimFloat.c - Task.c - ThreadLabels.c - ThreadPaused.c - Threads.c - Ticky.c - Timer.c - TopHandler.c - Trace.c - TraverseHeap.c - TraverseHeapTest.c - WSDeque.c - Weak.c - eventlog/EventLog.c - eventlog/EventLogWriter.c - hooks/FlagDefaults.c - hooks/LongGCSync.c - hooks/MallocFail.c - hooks/OnExit.c - hooks/OutOfHeap.c - hooks/StackOverflow.c - linker/CacheFlush.c - linker/Elf.c - linker/InitFini.c - linker/LoadArchive.c - linker/M32Alloc.c - linker/MMap.c - linker/MachO.c - linker/macho/plt.c - linker/macho/plt_aarch64.c - linker/PEi386.c - linker/SymbolExtras.c - linker/elf_got.c - linker/elf_plt.c - linker/elf_plt_aarch64.c - linker/elf_plt_arm.c - linker/elf_reloc.c - linker/elf_reloc_aarch64.c - linker/elf_tlsgd.c - linker/elf_util.c - sm/BlockAlloc.c - sm/CNF.c - sm/Compact.c - sm/Evac.c - sm/Evac_thr.c - sm/GC.c - sm/GCAux.c - sm/GCUtils.c - sm/MBlock.c - sm/MarkWeak.c - sm/NonMoving.c - sm/NonMovingCensus.c - sm/NonMovingMark.c - sm/NonMovingScav.c - sm/NonMovingShortcut.c - sm/NonMovingSweep.c - sm/Sanity.c - sm/Scav.c - sm/Scav_thr.c - sm/Storage.c - sm/Sweep.c - fs.c - -- I wish we had wildcards..., this would be: - -- *.c hooks/**/*.c sm/**/*.c eventlog/**/*.c linker/**/*.c - - if os(windows) - c-sources: win32/AsyncMIO.c - win32/AsyncWinIO.c - win32/AwaitEvent.c - win32/ConsoleHandler.c - win32/GetEnv.c - win32/GetTime.c - win32/MIOManager.c - win32/OSMem.c - win32/OSThreads.c - win32/ThrIOManager.c - win32/Ticker.c - win32/WorkQueue.c - win32/veh_excn.c - -- win32/**/*.c - elif arch(wasm32) - asm-sources: wasm/Wasm.S - c-sources: wasm/StgRun.c - wasm/GetTime.c - wasm/OSMem.c - wasm/OSThreads.c - posix/Select.c - else - c-sources: posix/GetEnv.c - posix/GetTime.c - posix/Ticker.c - posix/OSMem.c - posix/OSThreads.c - posix/Select.c - posix/Signals.c - posix/TTY.c - -- ticker/*.c - -- We don't want to compile posix/ticker/*.c, these will be #included - -- from Ticker.c + ld-options: + "-Wl,-u,base_GHCziEventziWindows_processRemoteCompletion_closure" + + if os(osx) + ld-options: "-Wl,-search_paths_first" + -- See Note [fd_set_overflow] + "-Wl,-U,___darwin_check_fd_set_overflow" + if !arch(x86_64) && !arch(aarch64) + ld-options: -read_only_relocs warning + + cmm-sources: Apply.cmm + Compact.cmm + ContinuationOps.cmm + Exception.cmm + HeapStackCheck.cmm + PrimOps.cmm + StgMiscClosures.cmm + StgStartup.cmm + StgStdThunks.cmm + Updates.cmm + -- AutoApply is generated + AutoApply.cmm + + -- Adjustor stuff + if flag(libffi-adjustors) + c-sources: adjustor/LibffiAdjustor.c + else + -- Use GHC's native adjustors + if arch(i386) + asm-sources: adjustor/Nativei386Asm.S + c-sources: adjustor/Nativei386.c + if arch(x86_64) + if os(mingw32) + asm-sources: adjustor/NativeAmd64MingwAsm.S + c-sources: adjustor/NativeAmd64Mingw.c + else + asm-sources: adjustor/NativeAmd64Asm.S + c-sources: adjustor/NativeAmd64.c + if arch(ppc) || arch(ppc64) + asm-sources: AdjustorAsm.S + c-sources: adjustor/NativePowerPC.c + if arch(ia64) + c-sources: adjustor/NativeIA64.c + + -- Use assembler STG entrypoint on architectures where it is used + if arch(ppc) || arch(ppc64) || arch(s390x) || arch(riscv64) + asm-sources: StgCRunAsm.S + + c-sources: Adjustor.c + adjustor/AdjustorPool.c + ExecPage.c + Arena.c + Capability.c + CheckUnload.c + CloneStack.c + ClosureFlags.c + ClosureSize.c + Continuation.c + Disassembler.c + FileLock.c + ForeignExports.c + Globals.c + Hash.c + Heap.c + Hpc.c + HsFFI.c + Inlines.c + Interpreter.c + IOManager.c + LdvProfile.c + Libdw.c + LibdwPool.c + Linker.c + ReportMemoryMap.c + Messages.c + OldARMAtomic.c + PathUtils.c + Pool.c + Printer.c + ProfHeap.c + ProfilerReport.c + ProfilerReportJson.c + Profiling.c + IPE.c + Proftimer.c + RaiseAsync.c + RetainerProfile.c + RetainerSet.c + RtsAPI.c + RtsDllMain.c + RtsFlags.c + RtsMain.c + RtsMessages.c + RtsStartup.c + RtsSymbolInfo.c + RtsSymbols.c + RtsUtils.c + STM.c + Schedule.c + Sparks.c + SpinLock.c + StableName.c + StablePtr.c + StaticPtrTable.c + Stats.c + StgCRun.c + StgPrimFloat.c + Task.c + ThreadLabels.c + ThreadPaused.c + Threads.c + Ticky.c + Timer.c + TopHandler.c + Trace.c + TraverseHeap.c + TraverseHeapTest.c + WSDeque.c + Weak.c + eventlog/EventLog.c + eventlog/EventLogWriter.c + hooks/FlagDefaults.c + hooks/LongGCSync.c + hooks/MallocFail.c + hooks/OnExit.c + hooks/OutOfHeap.c + hooks/StackOverflow.c + linker/CacheFlush.c + linker/Elf.c + linker/InitFini.c + linker/LoadArchive.c + linker/M32Alloc.c + linker/MMap.c + linker/MachO.c + linker/macho/plt.c + linker/macho/plt_aarch64.c + linker/PEi386.c + linker/SymbolExtras.c + linker/elf_got.c + linker/elf_plt.c + linker/elf_plt_aarch64.c + linker/elf_plt_arm.c + linker/elf_reloc.c + linker/elf_reloc_aarch64.c + linker/elf_tlsgd.c + linker/elf_util.c + sm/BlockAlloc.c + sm/CNF.c + sm/Compact.c + sm/Evac.c + sm/Evac_thr.c + sm/GC.c + sm/GCAux.c + sm/GCUtils.c + sm/MBlock.c + sm/MarkWeak.c + sm/NonMoving.c + sm/NonMovingCensus.c + sm/NonMovingMark.c + sm/NonMovingScav.c + sm/NonMovingShortcut.c + sm/NonMovingSweep.c + sm/Sanity.c + sm/Scav.c + sm/Scav_thr.c + sm/Storage.c + sm/Sweep.c + fs.c + -- I wish we had wildcards..., this would be: + -- *.c hooks/**/*.c sm/**/*.c eventlog/**/*.c linker/**/*.c + + if os(windows) + c-sources: win32/AsyncMIO.c + win32/AsyncWinIO.c + win32/AwaitEvent.c + win32/ConsoleHandler.c + win32/GetEnv.c + win32/GetTime.c + win32/MIOManager.c + win32/OSMem.c + win32/OSThreads.c + win32/ThrIOManager.c + win32/Ticker.c + win32/WorkQueue.c + win32/veh_excn.c + -- win32/**/*.c + elif arch(wasm32) + asm-sources: wasm/Wasm.S + c-sources: wasm/StgRun.c + wasm/GetTime.c + wasm/OSMem.c + wasm/OSThreads.c + posix/Select.c + else + c-sources: posix/GetEnv.c + posix/GetTime.c + posix/Ticker.c + posix/OSMem.c + posix/OSThreads.c + posix/Select.c + posix/Signals.c + posix/TTY.c + -- ticker/*.c + -- We don't want to compile posix/ticker/*.c, these will be #included + -- from Ticker.c -- Note [fd_set_overflow] diff --git a/rts/version.c b/rts/version.c new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/rts/version.c diff --git a/testsuite/config/ghc b/testsuite/config/ghc index 9e6fa8db0a..8916ffa3a9 100644 --- a/testsuite/config/ghc +++ b/testsuite/config/ghc @@ -8,16 +8,17 @@ import re # config.compiler_always_flags = ghc_compiler_always_flags.split() -# By default, the 'normal' and 'hpc' ways are enabled. In addition, certain +# By default, the 'normal' way is enabled. In addition, certain # ways are enabled automatically if this GHC supports them. Ways that fall in -# this group are 'optasm', 'optllvm', 'profasm', 'threaded1', 'threaded2', +# this group are 'hpc', 'optasm', 'optllvm', 'profasm', 'threaded1', 'threaded2', # 'profthreaded', 'ghci', and whichever of 'static/dyn' is not this GHC's # default mode. Other ways should be set explicitly from .T files. -config.compile_ways = ['normal', 'hpc'] -config.run_ways = ['normal', 'hpc'] +config.compile_ways = ['normal'] +config.run_ways = ['normal'] # ways that are not enabled by default, but can always be invoked explicitly -config.other_ways = ['prof', 'normal_h', +config.other_ways = ['hpc', + 'prof', 'normal_h', 'prof_hc_hb','prof_hb', 'prof_hd','prof_hy','prof_hr', 'sanity', @@ -34,6 +35,7 @@ config.other_ways = ['prof', 'normal_h', 'compacting_gc', ] + if ghc_with_native_codegen: config.compile_ways.append('optasm') config.run_ways.append('optasm') @@ -65,6 +67,16 @@ if windows: else: config.other_ways += winio_ways +# LLVM +if not config.unregisterised and not config.arch == "js" and config.have_llvm: + config.compile_ways.append('optllvm') + config.run_ways.append('optllvm') + +# HPC +if not config.arch == "js": + config.compile_ways.append('hpc') + config.run_ways.append('hpc') + config.way_flags = { 'normal' : [], 'normal_h' : [], @@ -179,13 +191,6 @@ llvm_ways = [x[0] for x in config.way_flags.items() if '-fllvm' in x[1]] def get_compiler_info(): - if config.unregisterised: - print("Unregisterised build; skipping LLVM ways...") - elif config.have_llvm: - config.compile_ways.append('optllvm') - config.run_ways.append('optllvm') - else: - print("Failed to find `llc` command; skipping LLVM ways...") # Whether GHC itself was built using the LLVM backend. We need to know this # since some tests in ext-interp fail when stage2 ghc is built using diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index a0f97098ab..39ba7d8b31 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -137,6 +137,18 @@ def no_deps( name, opts): def skip( name, opts ): opts.skip = True +# disable test on JS arch +def js_skip( name, opts ): + if arch("js"): + skip(name,opts) + +# expect broken for the JS backend +def js_broken( bug: IssueNumber ): + if arch("js"): + return expect_broken(bug); + else: + return normal; + def expect_fail( name, opts ): # The compiler, testdriver, OS or platform is missing a certain # feature, and we don't plan to or can't fix it now or in the @@ -250,15 +262,28 @@ def req_dynamic_hs( name, opts ): def req_interp( name, opts ): if not config.have_interp: opts.expect = 'fail' + # JS backend doesn't provide an interpreter yet + js_skip(name, opts) def req_rts_linker( name, opts ): if not config.have_RTS_linker: opts.expect = 'fail' + # JS backend doesn't provide the RTS linker + js_skip(name, opts) def req_c( name, opts ): """ Mark a test as requiring C source file support """ + # JS backend doesn't support C (yet) + js_skip(name, opts) + +def req_ffi_exports( name, opts): + """ + Mark a test as requiring FFI exports + """ + # JS backend doesn't support FFI exports (yet) + js_skip(name, opts) def req_th( name, opts ): """ @@ -739,6 +764,8 @@ def objcpp_src( name, opts ): def cmm_src( name, opts ): opts.cmm_src = True + # JS backend doesn't support Cmm + js_skip(name, opts) def outputdir( odir ): return lambda name, opts, d=odir: _outputdir(name, opts, d) @@ -2313,6 +2340,8 @@ def normalise_errmsg(s: str) -> str: # hacky solution is used in place of more sophisticated filename # mangling s = re.sub('([^\\s])\\.exe', '\\1', s) + # Same thing for .jsexe directories generated by the JS backend + s = re.sub('([^\\s])\\.jsexe', '\\1', s) # normalise slashes, minimise Windows/Unix filename differences s = re.sub('\\\\', '/', s) @@ -2320,6 +2349,10 @@ def normalise_errmsg(s: str) -> str: # The inplace ghc's are called ghc-stage[123] to avoid filename # collisions, so we need to normalise that to just "ghc" s = re.sub('ghc-stage[123]', 'ghc', s) + # Remove platform prefix (e.g. js-unknown-ghcjs) for cross-compiled tools + # (ghc, ghc-pkg, unlit, etc.) + s = re.sub('\\w+-\\w+-\\w+-ghc', 'ghc', s) + s = re.sub('\\w+-\\w+-\\w+-unlit', 'unlit', s) # On windows error messages can mention versioned executables s = re.sub('ghc-[0-9.]+', 'ghc', s) @@ -2428,6 +2461,7 @@ def normalise_slashes_( s: str ) -> str: def normalise_exe_( s: str ) -> str: s = re.sub('\.exe', '', s) + s = re.sub('\.jsexe', '', s) return s def normalise_output( s: str ) -> str: @@ -2436,8 +2470,10 @@ def normalise_output( s: str ) -> str: s = modify_lines(s, lambda l: re.sub(' error:', '', l)) s = modify_lines(s, lambda l: re.sub(' Warning:', ' warning:', l)) # Remove a .exe extension (for Windows) + # and .jsexe extension (for the JS backend) # This can occur in error messages generated by the program. s = re.sub('([^\\s])\\.exe', '\\1', s) + s = re.sub('([^\\s])\\.jsexe', '\\1', s) s = normalise_callstacks(s) s = normalise_type_reps(s) # ghci outputs are pretty unstable with -fexternal-dynamic-refs, which is diff --git a/testsuite/tests/backpack/cabal/T15594/all.T b/testsuite/tests/backpack/cabal/T15594/all.T index 1978865665..919f327ed7 100644 --- a/testsuite/tests/backpack/cabal/T15594/all.T +++ b/testsuite/tests/backpack/cabal/T15594/all.T @@ -4,6 +4,6 @@ else: cleanup = 'CLEANUP=0' test('T15594', - extra_files(['Setup.hs', 'Stuff.hs', 'Sig.hsig', 'pkg.cabal', 'src']), + [extra_files(['Setup.hs', 'Stuff.hs', 'Sig.hsig', 'pkg.cabal', 'src']), js_broken(22356)], run_command, ['$MAKE -s --no-print-directory T15594 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/T16219/all.T b/testsuite/tests/backpack/cabal/T16219/all.T index dc53deb2be..b0bc08c625 100644 --- a/testsuite/tests/backpack/cabal/T16219/all.T +++ b/testsuite/tests/backpack/cabal/T16219/all.T @@ -4,7 +4,9 @@ else: cleanup = 'CLEANUP=0' test('T16219', - [extra_files(['Setup.hs', 'backpack-issue.cabal', 'library-a', 'library-a-impl', 'library-b']), - when(opsys('mingw32'), fragile(17452))], + [ extra_files(['Setup.hs', 'backpack-issue.cabal', 'library-a', 'library-a-impl', 'library-b']) + , when(opsys('mingw32'), fragile(17452)) + , js_broken(22356) + ], run_command, ['$MAKE -s --no-print-directory T16219 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/T20509/all.T b/testsuite/tests/backpack/cabal/T20509/all.T index d94879a8d7..fa5f220454 100644 --- a/testsuite/tests/backpack/cabal/T20509/all.T +++ b/testsuite/tests/backpack/cabal/T20509/all.T @@ -4,7 +4,9 @@ else: cleanup = 'CLEANUP=0' test('T20509', - [extra_files(['p', 'q', 'T20509.cabal', 'Setup.hs']), - run_timeout_multiplier(2)], + [extra_files(['p', 'q', 'T20509.cabal', 'Setup.hs']) + , run_timeout_multiplier(2) + , js_broken(22356) + ], run_command, ['$MAKE -s --no-print-directory T20509 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal01/all.T b/testsuite/tests/backpack/cabal/bkpcabal01/all.T index 1b72bd2f70..f1987fc381 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal01/all.T +++ b/testsuite/tests/backpack/cabal/bkpcabal01/all.T @@ -5,6 +5,7 @@ else: test('bkpcabal01', [extra_files(['p', 'q', 'impl', 'bkpcabal01.cabal', 'Setup.hs', 'Main.hs']), + js_broken(22351), run_timeout_multiplier(2)], run_command, ['$MAKE -s --no-print-directory bkpcabal01 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal02/all.T b/testsuite/tests/backpack/cabal/bkpcabal02/all.T index f9639dadfd..995f945080 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal02/all.T +++ b/testsuite/tests/backpack/cabal/bkpcabal02/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('bkpcabal02', - extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']), + [extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory bkpcabal02 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal03/all.T b/testsuite/tests/backpack/cabal/bkpcabal03/all.T index 28bea90fd9..a8df318dbd 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal03/all.T +++ b/testsuite/tests/backpack/cabal/bkpcabal03/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('bkpcabal03', - extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs']), + [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory bkpcabal03 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal04/all.T b/testsuite/tests/backpack/cabal/bkpcabal04/all.T index 2acc61182b..59c245069f 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal04/all.T +++ b/testsuite/tests/backpack/cabal/bkpcabal04/all.T @@ -5,6 +5,7 @@ else: # Test recompilation checking on signatures test('bkpcabal04', - extra_files(['p', 'q', 'bkpcabal04.cabal.in1', 'bkpcabal04.cabal.in2', 'Setup.hs']), + [extra_files(['p', 'q', 'bkpcabal04.cabal.in1', 'bkpcabal04.cabal.in2', 'Setup.hs']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory bkpcabal04 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal05/all.T b/testsuite/tests/backpack/cabal/bkpcabal05/all.T index f6b74f2feb..e3ccc5c296 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal05/all.T +++ b/testsuite/tests/backpack/cabal/bkpcabal05/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('bkpcabal05', - extra_files(['bkpcabal05.cabal', 'A.hsig.in1', 'A.hsig.in2', 'M.hs', 'Setup.hs']), + [extra_files(['bkpcabal05.cabal', 'A.hsig.in1', 'A.hsig.in2', 'M.hs', 'Setup.hs']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory bkpcabal05 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal06/all.T b/testsuite/tests/backpack/cabal/bkpcabal06/all.T index 40ad858aee..b10c9a8f52 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal06/all.T +++ b/testsuite/tests/backpack/cabal/bkpcabal06/all.T @@ -5,6 +5,7 @@ else: test('bkpcabal06', [extra_files(['bkpcabal06.cabal', 'Setup.hs', 'sig', 'impl']), + js_broken(22351), when(opsys('mingw32'), skip)], run_command, ['$MAKE -s --no-print-directory bkpcabal06 ' + cleanup]) diff --git a/testsuite/tests/backpack/cabal/bkpcabal07/all.T b/testsuite/tests/backpack/cabal/bkpcabal07/all.T index bd6e689a4b..b4144540cc 100644 --- a/testsuite/tests/backpack/cabal/bkpcabal07/all.T +++ b/testsuite/tests/backpack/cabal/bkpcabal07/all.T @@ -5,6 +5,7 @@ else: test('bkpcabal07', [extra_files(['bkpcabal07.cabal', 'Setup.hs', 'M.hs', 'P.hsig']), + js_broken(22351), when(opsys('mingw32'), skip)], run_command, ['$MAKE -s --no-print-directory bkpcabal07 ' + cleanup]) diff --git a/testsuite/tests/cabal/T12733/all.T b/testsuite/tests/cabal/T12733/all.T index a9cf30f441..3a2c2f8af2 100644 --- a/testsuite/tests/cabal/T12733/all.T +++ b/testsuite/tests/cabal/T12733/all.T @@ -4,6 +4,8 @@ else: cleanup = 'CLEANUP=0' test('T12733', - extra_files(['p/', 'q/', 'Setup.hs']), + [extra_files(['p/', 'q/', 'Setup.hs']) + , js_broken(22356) + ], run_command, ['$MAKE -s --no-print-directory T12733 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal01/all.T b/testsuite/tests/cabal/cabal01/all.T index 4a17490f18..123a64c59d 100644 --- a/testsuite/tests/cabal/cabal01/all.T +++ b/testsuite/tests/cabal/cabal01/all.T @@ -23,6 +23,7 @@ def ignoreLdOutput(str): test('cabal01', [extra_files(['A.hs', 'B/', 'MainA.hs', 'Setup.lhs', 'c_src/', 'hello.c', 'test.cabal']), - normalise_errmsg_fun(ignoreLdOutput)], + normalise_errmsg_fun(ignoreLdOutput), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory cabal01 VANILLA=' + vanilla + ' PROF=' + prof + ' DYN=' + dyn + ' ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal03/all.T b/testsuite/tests/cabal/cabal03/all.T index 938d0e4c48..057f44e643 100644 --- a/testsuite/tests/cabal/cabal03/all.T +++ b/testsuite/tests/cabal/cabal03/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('cabal03', - extra_files(['Setup.lhs', 'p/', 'q/', 'r/']), + [extra_files(['Setup.lhs', 'p/', 'q/', 'r/']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory cabal03 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal04/all.T b/testsuite/tests/cabal/cabal04/all.T index d84acf98b3..ebb76b7d3c 100644 --- a/testsuite/tests/cabal/cabal04/all.T +++ b/testsuite/tests/cabal/cabal04/all.T @@ -19,6 +19,7 @@ else: cleanup = 'CLEANUP=0' test('cabal04', - extra_files(['Library.hs', 'Setup.lhs', 'TH.hs', 'thtest.cabal']), + [extra_files(['Library.hs', 'Setup.lhs', 'TH.hs', 'thtest.cabal']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory cabal04 VANILLA=' + vanilla + ' PROF=' + prof + ' DYN=' + dyn + ' ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal05/all.T b/testsuite/tests/cabal/cabal05/all.T index 0a2a0fd670..833d6edfa4 100644 --- a/testsuite/tests/cabal/cabal05/all.T +++ b/testsuite/tests/cabal/cabal05/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('cabal05', - extra_files(['Setup.hs', 'p/', 'q/', 'r/', 's/', 't/']), + [extra_files(['Setup.hs', 'p/', 'q/', 'r/', 's/', 't/']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory cabal05 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal06/all.T b/testsuite/tests/cabal/cabal06/all.T index aa53948738..cd7be2a70c 100644 --- a/testsuite/tests/cabal/cabal06/all.T +++ b/testsuite/tests/cabal/cabal06/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('cabal06', - extra_files(['Setup.hs', 'p-1.0/', 'p-1.1/', 'q/', 'r/']), + [extra_files(['Setup.hs', 'p-1.0/', 'p-1.1/', 'q/', 'r/']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory cabal06 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal08/all.T b/testsuite/tests/cabal/cabal08/all.T index 95864fdf96..3f1665b8fc 100644 --- a/testsuite/tests/cabal/cabal08/all.T +++ b/testsuite/tests/cabal/cabal08/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('cabal08', - extra_files(['Main.hs', 'Setup.hs', 'p1/', 'p2/']), + [extra_files(['Main.hs', 'Setup.hs', 'p1/', 'p2/']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory cabal08 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal09/all.T b/testsuite/tests/cabal/cabal09/all.T index 438161b05b..12b048bcfd 100644 --- a/testsuite/tests/cabal/cabal09/all.T +++ b/testsuite/tests/cabal/cabal09/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('cabal09', - extra_files(['Main.hs', 'Setup.hs', 'reexport.cabal']), + [extra_files(['Main.hs', 'Setup.hs', 'reexport.cabal']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory cabal09 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal10/all.T b/testsuite/tests/cabal/cabal10/all.T index 778637d948..15a255f82b 100644 --- a/testsuite/tests/cabal/cabal10/all.T +++ b/testsuite/tests/cabal/cabal10/all.T @@ -4,6 +4,7 @@ else: cleanup = 'CLEANUP=0' test('cabal10', - extra_files(['Use.hs', 'Setup.hs', 'src/', 'internal-lib.cabal']), + [extra_files(['Use.hs', 'Setup.hs', 'src/', 'internal-lib.cabal']), + js_broken(22351)], run_command, ['$MAKE -s --no-print-directory cabal10 ' + cleanup]) diff --git a/testsuite/tests/cabal/t18567/all.T b/testsuite/tests/cabal/t18567/all.T index 5b30bfaaf9..bbe84cda99 100644 --- a/testsuite/tests/cabal/t18567/all.T +++ b/testsuite/tests/cabal/t18567/all.T @@ -4,6 +4,8 @@ else: cleanup = 'CLEANUP=0' test('T18567', - extra_files(['Setup.hs', 'sublib/', 'sublib-unused', 'src/', 'internal-lib.cabal']), + [ extra_files(['Setup.hs', 'sublib/', 'sublib-unused', 'src/', 'internal-lib.cabal']) + , js_broken(22356) + ], run_command, ['$MAKE -s --no-print-directory T18567 ' + cleanup]) diff --git a/testsuite/tests/cabal/t19518/all.T b/testsuite/tests/cabal/t19518/all.T index a2cd241a70..e9daf4e970 100644 --- a/testsuite/tests/cabal/t19518/all.T +++ b/testsuite/tests/cabal/t19518/all.T @@ -4,6 +4,8 @@ else: cleanup = 'CLEANUP=0' test('t19518', - extra_files(['Setup.hs', 'p/', 'q/', 'r/']), + [ extra_files(['Setup.hs', 'p/', 'q/', 'r/']) + , js_broken(22356) + ], run_command, ['$MAKE -s --no-print-directory t19518 ' + cleanup]) diff --git a/testsuite/tests/cabal/t20242/all.T b/testsuite/tests/cabal/t20242/all.T index 4e1c0387ee..d0e93ef66b 100644 --- a/testsuite/tests/cabal/t20242/all.T +++ b/testsuite/tests/cabal/t20242/all.T @@ -4,6 +4,6 @@ else: cleanup = 'CLEANUP=0' test('T20242', - [extra_files(['Setup.hs', 'BootNoHeader.cabal','Foo.hs', 'Foo.hs-boot', 'Main.hs'])], + [extra_files(['Setup.hs', 'BootNoHeader.cabal','Foo.hs', 'Foo.hs-boot', 'Main.hs']), js_broken(22352)], run_command, ['$MAKE -s --no-print-directory T20242 ' + cleanup]) diff --git a/testsuite/tests/callarity/perf/all.T b/testsuite/tests/callarity/perf/all.T index 37e40e6f9c..b5c282ee18 100644 --- a/testsuite/tests/callarity/perf/all.T +++ b/testsuite/tests/callarity/perf/all.T @@ -1,7 +1,8 @@ test('T3924', [collect_stats('bytes allocated',8) , only_ways(['normal']) - ], + , js_broken(22261) + ], compile_and_run, ['-O']) diff --git a/testsuite/tests/callarity/unittest/all.T b/testsuite/tests/callarity/unittest/all.T index e39c1d7597..bbdff0d676 100644 --- a/testsuite/tests/callarity/unittest/all.T +++ b/testsuite/tests/callarity/unittest/all.T @@ -5,4 +5,4 @@ setTestOpts(f) setTestOpts(extra_hc_opts('-package ghc')) setTestOpts(extra_run_opts('"' + config.libdir + '"')) -test('CallArity1', normal, compile_and_run, ['']) +test('CallArity1', js_broken(22362), compile_and_run, ['']) diff --git a/testsuite/tests/cmm/opt/all.T b/testsuite/tests/cmm/opt/all.T index 0e4fc9abf2..9fdb8a700b 100644 --- a/testsuite/tests/cmm/opt/all.T +++ b/testsuite/tests/cmm/opt/all.T @@ -1,5 +1,5 @@ # Verify that we optimize away conditional branches which always jump # to the same target. -test('T15188', normal, makefile_test, []) +test('T15188', cmm_src, makefile_test, []) test('T18141', normal, compile, ['']) test('T20142', normal, compile, ['']) diff --git a/testsuite/tests/cmm/should_compile/T21370/all.T b/testsuite/tests/cmm/should_compile/T21370/all.T index a88bb4d26f..f0df98e111 100644 --- a/testsuite/tests/cmm/should_compile/T21370/all.T +++ b/testsuite/tests/cmm/should_compile/T21370/all.T @@ -1 +1,4 @@ -test('T21370', [extra_files(["subdir", "test.cmm", "test2.cmm", "Main.hs"])] , makefile_test, []) +test('T21370', + [ extra_files(["subdir", "test.cmm", "test2.cmm", "Main.hs"]) + , js_skip # use Cmm + ], makefile_test, []) diff --git a/testsuite/tests/cmm/should_compile/all.T b/testsuite/tests/cmm/should_compile/all.T index 40813f01ec..ce38d8d9a1 100644 --- a/testsuite/tests/cmm/should_compile/all.T +++ b/testsuite/tests/cmm/should_compile/all.T @@ -1,4 +1,7 @@ -# +setTestOpts( + [ js_skip # Cmm not supported by the JS backend + ]) + test('selfloop', [cmm_src], compile, ['-no-hs-main']) test('cmm_sink_sp', [ only_ways(['optasm']), grep_errmsg('(\[Sp.*\]).*(=).*(\[.*R1.*\]).*;',[1,2,3]), cmm_src], compile, ['-no-hs-main -ddump-cmm -dsuppress-uniques -O']) diff --git a/testsuite/tests/cmm/should_run/all.T b/testsuite/tests/cmm/should_run/all.T index bb667a93de..7290fee784 100644 --- a/testsuite/tests/cmm/should_run/all.T +++ b/testsuite/tests/cmm/should_run/all.T @@ -6,6 +6,7 @@ test('HooplPostorder', test('cmp64', [ extra_run_opts('"' + config.libdir + '"') , omit_ways(['ghci']) + , js_skip ], multi_compile_and_run, ['cmp64', [('cmp64_cmm.cmm', '')], '-O']) @@ -20,6 +21,7 @@ test('cmp64', test('ByteSwitch', [ extra_run_opts('"' + config.libdir + '"') , omit_ways(['ghci']) + , js_skip ], multi_compile_and_run, ['ByteSwitch', [('ByteSwitch_cmm.cmm', '')], '']) diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T index 58600faa98..4c636eb57d 100644 --- a/testsuite/tests/codeGen/should_compile/all.T +++ b/testsuite/tests/codeGen/should_compile/all.T @@ -27,7 +27,12 @@ test('T9155', normal, compile, ['-O2']) test('T9303', normal, compile, ['-O2']) test('T9329', [when(unregisterised(), expect_broken(15467)), cmm_src], compile, ['-no-hs-main']) -test('debug', normal, makefile_test, []) +test('debug', + [ normal, + js_skip # requires Cmm + ], + makefile_test, []) + test('T9964', normal, compile, ['-O']) test('T10518', [cmm_src], compile, ['-no-hs-main']) test('T10667', normal, compile, ['-g']) @@ -66,30 +71,40 @@ test('T17334', [ unless(have_ncg() and (arch('x86_64') or arch('i386')), skip) , only_ways(['normal']) ], compile, ['-O']) -test('T14373', [], +test('T14373', + [ js_skip # JS backend doesn't produce Cmm + ], multimod_compile_filter, ['T14373', '-fasm -O2 -c -ddump-cmm-from-stg', 'grep -e "const T14373\.._closure+.;"']) switch_skeleton_only = 'grep -e "switch \[" -e "case " -e "default: " | sed -e "s|\] .*|\]|g" -e "s|goto .*|goto |g"' -test('T14373a', [], +test('T14373a', + [ js_skip # JS backend doesn't produce Cmm + ], multimod_compile_filter, ['T14373a', '-fasm -O2 -c -ddump-cmm-from-stg', switch_skeleton_only]) -test('T14373b', [], +test('T14373b', + [ js_skip # JS backend doesn't produce Cmm + ], multimod_compile_filter, ['T14373b', '-fasm -O2 -c -ddump-cmm-from-stg', switch_skeleton_only]) -test('T14373c', [], +test('T14373c', + [ js_skip # JS backend doesn't produce Cmm + ], multimod_compile_filter, ['T14373c', '-fasm -O2 -c -ddump-cmm-from-stg', switch_skeleton_only]) switch_skeleton_and_entries_only = ('grep -e "switch \[" -e "case " -e "default: " -e "Default_entry(" -e "R1 = .*_closure+2;"' '| sed -e "s|\] .*|\]|g" -e "s|goto .*|goto |g" -e "s|R1 = .*_closure+2;.*|R1 = XYZ_closure+2;|g" -e "s|//.*|//|g"') -test('T14373d', [], +test('T14373d', + [ js_skip # JS backend doesn't produce Cmm + ], multimod_compile_filter, ['T14373d', '-fasm -O2 -c -ddump-cmm-from-stg', switch_skeleton_and_entries_only]) -test('T17648', normal, makefile_test, []) +test('T17648', js_broken(22370), makefile_test, []) test('T17904', normal, compile, ['-O']) test('T18227A', normal, compile, ['']) test('T18227B', normal, compile, ['']) diff --git a/testsuite/tests/codeGen/should_compile/cg010/all.T b/testsuite/tests/codeGen/should_compile/cg010/all.T index 7ce20471be..8c42213c44 100644 --- a/testsuite/tests/codeGen/should_compile/cg010/all.T +++ b/testsuite/tests/codeGen/should_compile/cg010/all.T @@ -1 +1,4 @@ -test('cg010', [extra_files(['A.hs','Main.hs'])], makefile_test, ['cg010']) +test('cg010', + [ extra_files(['A.hs','Main.hs']) + , js_skip # skip with JS backend because Cmm is required + ], makefile_test, ['cg010']) diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index 4b6d1b38a1..416eb4ecfd 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -74,7 +74,7 @@ test('cgrun065', normal, compile_and_run, ['']) test('cgrun066', normal, compile_and_run, ['']) test('cgrun067', [extra_files(['Cgrun067A.hs'])], compile_and_run, ['']) test('cgrun069', - [ omit_ways(['ghci'])], + [ omit_ways(['ghci']), js_skip], multi_compile_and_run, ['cgrun069', [('cgrun069_cmm.cmm', '')], '']) test('cgrun070', normal, compile_and_run, ['']) @@ -99,7 +99,7 @@ test('T3207', normal, compile_and_run, ['']) test('T3561', normal, compile_and_run, ['']) test('T3677', extra_run_opts('+RTS -K8k -RTS'), compile_and_run, ['']) test('T4441', normal, compile_and_run, ['']) -test('T5149', omit_ways(['ghci']), multi_compile_and_run, +test('T5149', [omit_ways(['ghci']), js_skip], multi_compile_and_run, ['T5149', [('T5149_cmm.cmm', '')], '']) test('T5129', # The bug is in simplifier when run with -O1 and above, so only run it @@ -148,8 +148,8 @@ test('T9013', omit_ways(['ghci']), # ghci doesn't support unboxed tuples compile_and_run, ['']) test('T9340', normal, compile_and_run, ['']) test('cgrun074', normal, compile_and_run, ['']) -test('CmmSwitchTest32', unless(wordsize(32), skip), compile_and_run, ['']) -test('CmmSwitchTest64', unless(wordsize(64), skip), compile_and_run, ['']) +test('CmmSwitchTest32', [unless(wordsize(32), skip),js_skip], compile_and_run, ['']) +test('CmmSwitchTest64', [unless(wordsize(64), skip),js_skip], compile_and_run, ['']) # Skipping WAY=ghci, because it is not broken. test('T10245', normal, compile_and_run, ['']) test('T10246', normal, compile_and_run, ['']) @@ -161,9 +161,15 @@ test('T10414', [only_ways(['threaded2']), extra_ways(['threaded2']), req_smp], test('T10521', normal, compile_and_run, ['']) test('T10521b', normal, compile_and_run, ['']) test('T10870', when(wordsize(32), skip), compile_and_run, ['']) -test('PopCnt', omit_ways(['ghci']), multi_compile_and_run, +test('PopCnt', + [omit_ways(['ghci']) + , js_skip # use Cmm + ], multi_compile_and_run, ['PopCnt', [('PopCnt_cmm.cmm', '')], '']) -test('T12059', normal, compile_and_run, ['']) +test('T12059', + [ js_skip # ByteArrays are always pinned with the JS backend + ], + compile_and_run, ['']) test('T12433', normal, compile_and_run, ['']) test('T12622', normal, multimod_compile_and_run, ['T12622', '-O']) test('T12757', normal, compile_and_run, ['']) @@ -177,7 +183,9 @@ test('T9577', [ unless(arch('x86_64') or arch('i386'),skip), test('T13425', normal, compile_and_run, ['-O']) test('castFloatWord', normal, compile_and_run, ['-dcmm-lint']) test('T13825-unit', - extra_run_opts('"' + config.libdir + '"'), + [ extra_run_opts('"' + config.libdir + '"') + , js_broken(22362) + ], compile_and_run, ['-package ghc']) test('T14619', normal, compile_and_run, ['']) diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T index 6bfeab4410..e57204b2c2 100644 --- a/testsuite/tests/concurrent/should_run/all.T +++ b/testsuite/tests/concurrent/should_run/all.T @@ -17,7 +17,10 @@ test('conc069a', only_threaded_ways, compile_and_run, ['']) # those for now. test('conc070', only_threaded_ways, compile_and_run, ['']) -test('conc071', omit_ways(concurrent_ways), compile_and_run, ['']) +test('conc071', + [ omit_ways(concurrent_ways) + , js_skip # JS RTS doesn't report the same cap/locked status + ] , compile_and_run, ['']) test('conc072', only_ways(concurrent_ways), compile_and_run, ['']) test('conc073', normal, compile_and_run, ['']) @@ -42,7 +45,7 @@ test('throwto002', normal, compile_and_run, ['']) test('throwto003', normal, compile_and_run, ['']) test('mask001', normal, compile_and_run, ['']) -test('mask002', normal, compile_and_run, ['']) +test('mask002', js_broken(22261), compile_and_run, ['']) test('async001', normal, compile_and_run, ['']) @@ -86,15 +89,20 @@ test('threadstatus-9333', [fragile_for(16555, ['ghci', 'profthreaded']), omit_wa test('T9379', normal, compile_and_run, ['']) -test('allocLimit1', exit_code(1), compile_and_run, ['']) -test('allocLimit2', normal, compile_and_run, ['']) +# Skip the allocLimit* tests with the JS backend as it doesn't support +# setThreadAllocationCounter + +test('allocLimit1', [exit_code(1), js_skip], compile_and_run, ['']) +test('allocLimit2', js_skip, compile_and_run, ['']) # The non-threaded RTS on Windows doesn't handle throwing exceptions at I/O # operations very well, and ends up duplicating the I/O, giving wrong results. test('allocLimit3', [ when(opsys('mingw32'), only_ways(threaded_ways)), + js_skip, exit_code(1) ], compile_and_run, ['']) test('allocLimit4', [ extra_run_opts('+RTS -xq300k -RTS'), + js_skip, # ghci consumes part of set limit at startup omit_ways(['ghci']) ], compile_and_run, ['']) @@ -114,21 +122,31 @@ test('conc010', normal, compile_and_run, ['']) # conc012(ghci) needs a smaller stack, or it takes forever test('conc012', - extra_run_opts('+RTS -K8m -RTS'), + [ extra_run_opts('+RTS -K8m -RTS') + , js_skip # no stack overflow detection with the JS backend (yet) + ], compile_and_run, ['']) test('conc013', normal, compile_and_run, ['']) test('conc014', normal, compile_and_run, ['']) -test('conc015', normal, compile_and_run, ['']) +test('conc015', + [ when(arch("js"), fragile(22261)) # delays are flaky with the JS backend when the system is overloaded + ], compile_and_run, ['']) test('conc015a', normal, compile_and_run, ['']) -test('conc016', omit_ways(concurrent_ways), # see comment in conc016.hs +test('conc016', [omit_ways(concurrent_ways) # see comment in conc016.hs + , js_skip + ], compile_and_run, ['']) test('conc017', normal, compile_and_run, ['']) test('conc017a', normal, compile_and_run, ['']) test('conc018', normal, compile_and_run, ['']) test('conc019', extra_run_opts('+RTS -K16m -RTS'), compile_and_run, ['']) test('conc020', normal, compile_and_run, ['']) -test('conc021', [ omit_ways(['ghci']), exit_code(1) ], compile_and_run, ['']) +test('conc021', + [ omit_ways(['ghci']), exit_code(1) + , js_skip # foreign exports not supported yet + ], + compile_and_run, ['']) test('conc022', normal, compile_and_run, ['']) test('conc024', normal, compile_and_run, ['']) @@ -147,7 +165,8 @@ test('conc033', normal, compile_and_run, ['']) test('conc034', [ normal, omit_ways(['ghci']), - extra_run_opts('+RTS -C0 -RTS')], + extra_run_opts('+RTS -C0 -RTS'), + js_skip], compile_and_run, ['']) test('conc035', normal, compile_and_run, ['']) @@ -181,13 +200,13 @@ test('foreignInterruptible', [when(fast(), skip), test('conc037', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) test('conc038', only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), compile_and_run, ['']) -# Omit for GHCi, uses foreign export +# Omit for GHCi and for the JS backend, uses foreign export # Omit for the threaded ways, because in this case the main thread is allowed to # complete, which causes the child thread to be interrupted. -test('conc039', omit_ways(['ghci'] + threaded_ways), compile_and_run, ['']) +test('conc039', [omit_ways(['ghci'] + threaded_ways), js_skip], compile_and_run, ['']) -# Omit for GHCi, uses foreign export -test('conc040', [exit_code(1), omit_ways(['ghci'])], compile_and_run, ['']) +# Omit for GHCi and for the JS backend, uses foreign export +test('conc040', [exit_code(1), omit_ways(['ghci']), js_skip], compile_and_run, ['']) # STM-related tests. test('conc041', normal, compile_and_run, ['']) @@ -236,6 +255,7 @@ test('hs_try_putmvar001', [ when(opsys('mingw32'),skip), # uses pthread APIs in the C code only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), + js_skip ], compile_and_run, ['hs_try_putmvar001_c.c']) @@ -245,6 +265,7 @@ test('hs_try_putmvar001', test('hs_try_putmvar002', [pre_cmd('$MAKE -s --no-print-directory hs_try_putmvar002_setup'), omit_ways(['ghci']), + js_skip, extra_run_opts('1 8 10000')], compile_and_run, ['hs_try_putmvar002_c.c']) @@ -254,6 +275,7 @@ test('hs_try_putmvar003', when(opsys('mingw32'),skip), # uses pthread APIs in the C code pre_cmd('$MAKE -s --no-print-directory hs_try_putmvar003_setup'), only_ways(['threaded1', 'threaded2', 'nonmoving_thr']), + js_skip, extra_run_opts('1 16 32 100'), fragile_for(16361, ['threaded1']) ], diff --git a/testsuite/tests/corelint/all.T b/testsuite/tests/corelint/all.T index 4271974c83..43c2cdd8f4 100644 --- a/testsuite/tests/corelint/all.T +++ b/testsuite/tests/corelint/all.T @@ -7,6 +7,6 @@ test('T21152', normal, compile, ['-g3']) setTestOpts(extra_hc_opts('-package ghc')) setTestOpts(extra_run_opts('"' + config.libdir + '"')) -test('LintEtaExpand', normal, compile_and_run, ['']) +test('LintEtaExpand', js_broken(22362), compile_and_run, ['']) ## These tests use the GHC API. ## Test cases which don't use the GHC API should be added nearer the top. diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T index 9e68957784..965e57dd16 100644 --- a/testsuite/tests/dependent/should_compile/all.T +++ b/testsuite/tests/dependent/should_compile/all.T @@ -1,6 +1,6 @@ test('Dep1', only_ways(['normal']), compile, ['']) test('Dep2', only_ways(['normal']), compile, ['']) -test('Dep3', only_ways(['normal']), compile, ['']) +test('Dep3', [only_ways(['normal']), js_broken(22364)], compile, ['']) test('KindEqualities', only_ways(['normal']), compile, ['']) test('KindEqualities2', [req_th,only_ways(['normal'])], compile, ['']) test('Rae31', [req_th,only_ways(['normal'])], compile, ['']) @@ -40,7 +40,7 @@ test('T13938', [req_th, extra_files(['T13938a.hs'])], makefile_test, ['T13938']) test('T14556', normal, compile, ['']) test('T14720', normal, compile, ['']) test('T14066a', normal, compile, ['']) -test('T14749', normal, compile, ['']) +test('T14749', js_broken(22364), compile, ['']) test('T14845_compile', normal, compile, ['']) test('T14991', normal, compile, ['']) test('DkNameRes', normal, compile, ['']) diff --git a/testsuite/tests/driver/MergeObjsMode/all.T b/testsuite/tests/driver/MergeObjsMode/all.T index ebcf4546c6..034b0a0dbd 100644 --- a/testsuite/tests/driver/MergeObjsMode/all.T +++ b/testsuite/tests/driver/MergeObjsMode/all.T @@ -1,4 +1,6 @@ test('MergeObjsMode', - extra_files(['A.hs', 'B.hs', 'Main.hs']), + [ extra_files(['A.hs', 'B.hs', 'Main.hs']) + , js_broken(22261) + ], makefile_test, []) diff --git a/testsuite/tests/driver/T12674/all.T b/testsuite/tests/driver/T12674/all.T index 716bc7d07f..1024e01f64 100644 --- a/testsuite/tests/driver/T12674/all.T +++ b/testsuite/tests/driver/T12674/all.T @@ -1,6 +1,10 @@ test('T12674', [extra_files(['-T12674.hs', '-T12674c.c']), - when(opsys('darwin') and arch('aarch64'), skip)], + when(opsys('darwin') and arch('aarch64'), skip), + req_c + ], makefile_test, []) test('T12674w', [extra_files(['-T12674.hs', '-T12674c.c']), - unless(opsys('mingw32'), skip)], + unless(opsys('mingw32'), skip), + req_c + ], makefile_test, []) diff --git a/testsuite/tests/driver/T1372/all.T b/testsuite/tests/driver/T1372/all.T index 0edd81d622..13b0f99703 100644 --- a/testsuite/tests/driver/T1372/all.T +++ b/testsuite/tests/driver/T1372/all.T @@ -1 +1 @@ -test('T1372', [extra_files(['p1/', 'p2/'])], makefile_test, ['T1372']) +test('T1372', [extra_files(['p1/', 'p2/']), js_broken(22356)], makefile_test, ['T1372']) diff --git a/testsuite/tests/driver/T13914/all.T b/testsuite/tests/driver/T13914/all.T index 7b11a62f0a..fe641a0a31 100644 --- a/testsuite/tests/driver/T13914/all.T +++ b/testsuite/tests/driver/T13914/all.T @@ -1,3 +1,5 @@ test('T13914', - [extra_files(['main.hs'])], + [ extra_files(['main.hs']) + , js_broken(22261) + ], makefile_test, ['t13914']) diff --git a/testsuite/tests/driver/T14075/all.T b/testsuite/tests/driver/T14075/all.T index 9cc75e2feb..16f0e482f9 100644 --- a/testsuite/tests/driver/T14075/all.T +++ b/testsuite/tests/driver/T14075/all.T @@ -1,5 +1,6 @@ test('T14075', [ extra_files(['F.hs', 'F.hs-boot', 'O.hs', 'V.hs', 'V.hs-boot']) - , req_smp, # uses ghc --make -j2 + , req_smp # uses ghc --make -j2 + , js_broken(22261) ], makefile_test, []) diff --git a/testsuite/tests/driver/T16318/all.T b/testsuite/tests/driver/T16318/all.T index 131ede819d..36c8c6f596 100644 --- a/testsuite/tests/driver/T16318/all.T +++ b/testsuite/tests/driver/T16318/all.T @@ -1 +1 @@ -test('T16318', normal, makefile_test, []) +test('T16318', js_broken(22370), makefile_test, []) diff --git a/testsuite/tests/driver/T1959/test.T b/testsuite/tests/driver/T1959/test.T index 77cfd75dc6..967310935a 100644 --- a/testsuite/tests/driver/T1959/test.T +++ b/testsuite/tests/driver/T1959/test.T @@ -1 +1 @@ -test('T1959', [extra_files(['B.hs', 'C.hs', 'D.hs', 'E1.hs', 'E2.hs'])], makefile_test, ['dotest']) +test('T1959', [extra_files(['B.hs', 'C.hs', 'D.hs', 'E1.hs', 'E2.hs']), js_broken(22261)], makefile_test, ['dotest']) diff --git a/testsuite/tests/driver/T3007/all.T b/testsuite/tests/driver/T3007/all.T index d0442712e9..5fd79d7024 100644 --- a/testsuite/tests/driver/T3007/all.T +++ b/testsuite/tests/driver/T3007/all.T @@ -1,3 +1,5 @@ test('T3007', - [extra_files(['A/', 'B/'])], + [ extra_files(['A/', 'B/']) + , js_broken(22356) + ], makefile_test, []) diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index 489e5c06a3..ab9cfcbcf5 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -8,15 +8,15 @@ test('driver014', [extra_files(['A014.hs'])], makefile_test, ['test014']) test('driver015', [extra_files(['A015.hs'])], makefile_test, ['test015']) -test('driver016', [extra_files(['F016.hs'])], makefile_test, ['test016']) +test('driver016', [req_ffi_exports, extra_files(['F016.hs'])], makefile_test, ['test016']) # JS backend doesn't support foreign export yet -test('driver017', [extra_files(['F017.hs'])], makefile_test, ['test017']) +test('driver017', [req_ffi_exports, extra_files(['F017.hs'])], makefile_test, ['test017']) # JS backend doesn't support foreign export yet test('driver018', [extra_files(['F018.hs'])], makefile_test, ['test018']) test('driver018a', [extra_files(['F018a.hs'])], makefile_test, ['test018a']) -test('driver019', [extra_files(['F019.hs'])], makefile_test, ['test019']) +test('driver019', [req_ffi_exports, extra_files(['F019.hs'])], makefile_test, ['test019']) # JS backend doesn't support foreign export yet test('driver021', [extra_files(['B021/'])], makefile_test, ['test021']) @@ -32,9 +32,9 @@ test('driver025', [extra_files(['B025/'])], makefile_test, ['test025']) test('driver026', [extra_files(['d026/'])], makefile_test, ['test026']) -test('driver027', [extra_files(['B027/'])], makefile_test, ['test027']) +test('driver027', [req_ffi_exports, extra_files(['B027/'])], makefile_test, ['test027']) # JS backend doesn't support foreign export yet -test('driver028', [extra_files(['B028/'])], makefile_test, ['test028']) +test('driver028', [req_ffi_exports, extra_files(['B028/'])], makefile_test, ['test028']) # JS backend doesn't support foreign export yet test('driver031', [extra_files(['A031.hs'])], makefile_test, ['test031']) @@ -42,9 +42,9 @@ test('driver032', [extra_files(['A032.hs'])], makefile_test, ['test032']) test('driver033', [extra_files(['A033.hs'])], makefile_test, ['test033']) -test('driver034', [extra_files(['F034.hs'])], makefile_test, ['test034']) +test('driver034', [req_ffi_exports, extra_files(['F034.hs'])], makefile_test, ['test034']) # JS backend doesn't support foreign export yet -test('driver035', [extra_files(['F035.hs'])], makefile_test, ['test035']) +test('driver035', [req_ffi_exports, extra_files(['F035.hs'])], makefile_test, ['test035']) # JS backend doesn't support foreign export yet test('driver041', [extra_files(['B041/'])], makefile_test, ['test041']) @@ -54,9 +54,9 @@ test('driver042stub', [extra_files(['B042stub/'])], makefile_test, ['test042stub test('driver043', [extra_files(['B043/'])], makefile_test, ['test043']) -test('driver044', [extra_files(['B044/'])], makefile_test, ['test044']) +test('driver044', [req_ffi_exports, extra_files(['B044/'])], makefile_test, ['test044']) # JS backend doesn't support foreign export yet -test('driver045', [extra_files(['B045/'])], makefile_test, ['test045']) +test('driver045', [req_ffi_exports, extra_files(['B045/'])], makefile_test, ['test045']) # JS backend doesn't support foreign export yet test('driver051', [extra_files(['d051_1/', 'd051_2/'])], makefile_test, ['test051']) @@ -64,9 +64,9 @@ test('driver052', [extra_files(['d052_1/', 'd052_2/'])], makefile_test, ['test05 test('driver053', [extra_files(['d053_1/', 'd053_2/'])], makefile_test, ['test053']) -test('driver061a', [extra_files(['A061a.hs']), when(unregisterised(), skip)], makefile_test, ['test061a']) +test('driver061a', [req_ffi_exports, extra_files(['A061a.hs']), when(unregisterised(), skip)], makefile_test, ['test061a']) # JS backend doesn't support foreign export yet -test('driver061b', [extra_files(['A061b.hs']), when(unregisterised(), skip)], makefile_test, ['test061b']) +test('driver061b', [req_ffi_exports, extra_files(['A061b.hs']), when(unregisterised(), skip)], makefile_test, ['test061b']) # JS backend doesn't support foreign export yet test('driver062a', [], makefile_test, ['test062a']) @@ -85,13 +85,13 @@ test('driver066', [extra_files(['A066.hs'])], makefile_test, ['test066']) test('driver067', [extra_files(['A067.hs'])], makefile_test, ['test067']) -test('driver070', [extra_files(['A070.hs']), when(unregisterised(), skip)], makefile_test, ['test070']) +test('driver070', [req_ffi_exports, extra_files(['A070.hs']), when(unregisterised(), skip)], makefile_test, ['test070']) # JS backend doesn't support foreign export yet -test('driver071', [extra_files(['A071.hs']), when(unregisterised(), skip)], makefile_test, ['test071']) +test('driver071', [req_ffi_exports, extra_files(['A071.hs']), when(unregisterised(), skip)], makefile_test, ['test071']) # JS backend doesn't support foreign export yet test('driver081a', [], makefile_test, ['test081a']) -test('driver081b', [], makefile_test, ['test081b']) +test('driver081b', [req_ffi_exports], makefile_test, ['test081b']) # JS backend doesn't support foreign export yet test('driver100', [extra_files(['overlap/'])], makefile_test, ['test100']) @@ -138,10 +138,13 @@ test('T5313', test('T2464', normal, compile, ['']) test('T3674', [], makefile_test, []) -test('rtsopts001', [extra_files(['rtsOpts.hs'])], makefile_test, []) -test('rtsopts002', normal, makefile_test, []) +test('rtsopts001', + [ extra_files(['rtsOpts.hs']) + , js_skip # JS RTS doesn't support -rtsopts + ], makefile_test, []) +test('rtsopts002', js_broken(22370), makefile_test, []) -test('withRtsOpts', [], makefile_test, []) +test('withRtsOpts', js_broken(22370), makefile_test, []) test('T3389', when(arch('i386'), expect_broken_for(17256, ['hpc'] + prof_ways)), compile_and_run, ['']) test('T3364', normalise_fun(normalise_errmsg), makefile_test, []) @@ -270,14 +273,16 @@ test('json2', normalise_version('base','ghc-prim'), compile, ['-ddump-types -ddu test('T16167', [req_interp,exit_code(1)], run_command, ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs']) test('T13604', [], makefile_test, []) -test('T13604a', [], makefile_test, []) +test('T13604a', + [ js_broken(22261) # require HPC support + ], makefile_test, []) # omitting hpc and profasm because they affect the # inlining and unfoldings test('inline-check', omit_ways(['hpc', 'profasm']) , compile , ['-dinline-check foo -O -ddebug-output']) -test('T14452', [], makefile_test, []) +test('T14452', js_broken(22261), makefile_test, []) test('T14923', normal, makefile_test, []) test('T15396', normal, compile_and_run, ['-package ghc']) test('T16737', @@ -292,7 +297,7 @@ test('T18369', normal, compile, ['-O']) test('T21682', normal, compile_fail, ['-Werror=unrecognised-warning-flags -Wfoo']) test('FullGHCVersion', normal, compile_and_run, ['-package ghc-boot']) test('OneShotTH', req_th, makefile_test, []) -test('T17481', normal, makefile_test, []) +test('T17481', js_broken(22261), makefile_test, []) test('T20084', normal, makefile_test, []) test('RunMode', [req_interp,extra_files(['RunMode/Test.hs'])], run_command, ['{compiler} --run -iRunMode/ -ignore-dot-ghci RunMode.hs -- hello']) test('T20439', normal, run_command, @@ -310,7 +315,7 @@ test('T16476b', normal, makefile_test, []) test('T20569', extra_files(["T20569/"]), makefile_test, []) test('T21866', normal, multimod_compile, ['T21866','-no-link']) test('T21349', extra_files(['T21349']), makefile_test, []) -test('T21869', [normal, when(unregisterised(), skip)], makefile_test, []) +test('T21869', [js_broken(22261), when(unregisterised(), skip)], makefile_test, []) test('T22044', normal, makefile_test, []) test('T22048', [only_ways(['normal']), grep_errmsg("_rule")], compile, ["-O -fomit-interface-pragmas -ddump-simpl"]) test('T21722', normal, compile_fail, ['-fno-show-error-context']) diff --git a/testsuite/tests/driver/fat-iface/all.T b/testsuite/tests/driver/fat-iface/all.T index e71b0f56bc..c526aa7493 100644 --- a/testsuite/tests/driver/fat-iface/all.T +++ b/testsuite/tests/driver/fat-iface/all.T @@ -1,5 +1,5 @@ test('fat001', [extra_files(['Fat.hs'])], makefile_test, ['fat001']) -test('fat005', [extra_files(['Fat.hs']), filter_stdout_lines(r'= Proto-BCOs')], makefile_test, ['fat005']) +test('fat005', [extra_files(['Fat.hs']), filter_stdout_lines(r'= Proto-BCOs'), js_broken(22261)], makefile_test, ['fat005']) test('fat006', [extra_files(['Fat.hs'])], makefile_test, ['fat006']) test('fat006a', [extra_files(['Fat.hs'])], makefile_test, ['fat006a']) test('fat007', [extra_files(['Fat.hs'])], makefile_test, ['fat007']) diff --git a/testsuite/tests/driver/multipleHomeUnits/all.T b/testsuite/tests/driver/multipleHomeUnits/all.T index 9e454029d2..97974e19e2 100644 --- a/testsuite/tests/driver/multipleHomeUnits/all.T +++ b/testsuite/tests/driver/multipleHomeUnits/all.T @@ -1,7 +1,7 @@ test('multipleHomeUnits_single1', [extra_files([ 'a/', 'unitA'])], multiunit_compile, [['unitA'], '-fhide-source-paths']) test('multipleHomeUnits_single2', [extra_files([ 'b/', 'unitB'])], multiunit_compile, [['unitB'], '-fhide-source-paths']) -test('multipleHomeUnits_single3', [extra_files([ 'c/', 'unitC'])], multiunit_compile, [['unitC'], '-fhide-source-paths']) -test('multipleHomeUnits_single4', [extra_files([ 'd/', 'unitD'])], multiunit_compile, [['unitD'], '-fhide-source-paths']) +test('multipleHomeUnits_single3', [js_broken(22261),extra_files([ 'c/', 'unitC'])], multiunit_compile, [['unitC'], '-fhide-source-paths']) +test('multipleHomeUnits_single4', [js_broken(22261),extra_files([ 'd/', 'unitD'])], multiunit_compile, [['unitD'], '-fhide-source-paths']) test('multipleHomeUnits_single5', [req_th,extra_files([ 'th/', 'unitTH'])], multiunit_compile, [['unitTH'], '-fhide-source-paths']) test('multipleHomeUnits_cpp', [extra_files([ 'cpp-includes/', 'unitCPPIncludes'])], multiunit_compile, [['unitCPPIncludes'], '-fhide-source-paths']) test('multipleHomeUnits_cfile', [extra_files([ 'c-file/', 'unitCFile'])], multiunit_compile, [['unitCFile'], '-fhide-source-paths']) @@ -22,12 +22,14 @@ test('multipleHomeUnits002', [ extra_files( [ 'c/', 'd/' , 'unitC', 'unitD']) + , js_broken(22261) ], makefile_test, []) test('multipleHomeUnits003', [ extra_files( [ 'a/', 'b/', 'c/', 'd/' , 'unitA', 'unitB', 'unitC', 'unitD']) + , js_broken(22261) ], makefile_test, []) test('multipleHomeUnits004', diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/all.T b/testsuite/tests/driver/multipleHomeUnits/different-db/all.T index 5661d6a017..56a4d3ceb3 100644 --- a/testsuite/tests/driver/multipleHomeUnits/different-db/all.T +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/all.T @@ -4,6 +4,8 @@ else: cleanup = 'CLEANUP=0' test('different-db', - extra_files(['p/', 'q/', 'r/', 'p1/', 'unitP', 'unitQ', 'unitR', 'unitP1', 'Setup.hs']), + [ extra_files(['p/', 'q/', 'r/', 'p1/', 'unitP', 'unitQ', 'unitR', 'unitP1', 'Setup.hs']) + , js_broken(22356) + ], run_command, ['$MAKE -s --no-print-directory different-db ' + cleanup]) diff --git a/testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T b/testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T index 0dcb2fb607..887bf5838a 100644 --- a/testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T +++ b/testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T @@ -1,6 +1,7 @@ # This test checks that getRootSummary doesn't cross package boundaries. test('multipleHomeUnits_hidir' , [extra_files([ 'p1/', 'unitP1']) + , js_broken(22261) ] , makefile_test , ['mhu-hidir']) diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/all.T b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/all.T index 16fb06efa9..20d7864498 100644 --- a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/all.T +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/all.T @@ -4,6 +4,8 @@ else: cleanup = 'CLEANUP=0' test('mhu-closure', - extra_files(['p/', 'q/', 'r/', 'r1/', 'unitP', 'unitQ', 'unitR', 'unitR1', 'Setup.hs']), + [ extra_files(['p/', 'q/', 'r/', 'r1/', 'unitP', 'unitQ', 'unitR', 'unitR1', 'Setup.hs']) + , js_broken(22356) + ], run_command, ['$MAKE -s --no-print-directory mhu-closure ' + cleanup]) diff --git a/testsuite/tests/driver/multipleHomeUnits/o-files/all.T b/testsuite/tests/driver/multipleHomeUnits/o-files/all.T index 0133545ea9..7fd69eeb40 100644 --- a/testsuite/tests/driver/multipleHomeUnits/o-files/all.T +++ b/testsuite/tests/driver/multipleHomeUnits/o-files/all.T @@ -1,6 +1,7 @@ # This test checks that getRootSummary doesn't cross package boundaries. test('multipleHomeUnits_o-files' , [extra_files([ 'p1/', 'unitP1']) + , js_broken(22261) , pre_cmd('$MAKE -s --no-print-directory setup')] , multiunit_compile , [['unitP1'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T b/testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T index 74d9baf953..8a46f7f061 100644 --- a/testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T +++ b/testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T @@ -1,6 +1,7 @@ # This test checks that getRootSummary doesn't cross package boundaries. test('multipleHomeUnits_target-file-path' , [extra_files([ 'p1/', 'unitP1']) + , js_broken(22261) ] , multiunit_compile , [['unitP1'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/package-imports-t20779/all.T b/testsuite/tests/driver/package-imports-t20779/all.T index c6fc03d5f1..558ea98ef5 100644 --- a/testsuite/tests/driver/package-imports-t20779/all.T +++ b/testsuite/tests/driver/package-imports-t20779/all.T @@ -1,4 +1,4 @@ test('package-imports-20779', [extra_files(['q-1', 'q-2', 'q-3', 'p', 'Setup.hs']), - when(fast(), skip)], + when(fast(), skip), js_broken(22356)], makefile_test, []) diff --git a/testsuite/tests/driver/recomp004/all.T b/testsuite/tests/driver/recomp004/all.T index cfb8a201dd..f6de00de79 100644 --- a/testsuite/tests/driver/recomp004/all.T +++ b/testsuite/tests/driver/recomp004/all.T @@ -1,2 +1,2 @@ -test('recomp004', [extra_files(['Main.hs', 'c.h', 'c1.c', 'c2.c'])], +test('recomp004', [extra_files(['Main.hs', 'c.h', 'c1.c', 'c2.c']), req_c], makefile_test, []) diff --git a/testsuite/tests/driver/recomp007/all.T b/testsuite/tests/driver/recomp007/all.T index 59fe8f5dad..0718f33e07 100644 --- a/testsuite/tests/driver/recomp007/all.T +++ b/testsuite/tests/driver/recomp007/all.T @@ -2,6 +2,8 @@ # See the patch # "Fix a recompilation checking bug when a package dependency changes" -test('recomp007', [extra_files(['Setup.hs', 'a1/', 'a2/', 'b/']) +test('recomp007', [ extra_files(['Setup.hs', 'a1/', 'a2/', 'b/']) , when(fast(), skip) - , normalise_slashes], makefile_test, []) + , normalise_slashes + , js_broken(22352) + ], makefile_test, []) diff --git a/testsuite/tests/driver/recomp008/all.T b/testsuite/tests/driver/recomp008/all.T index 07bfd14776..702b3b6f64 100644 --- a/testsuite/tests/driver/recomp008/all.T +++ b/testsuite/tests/driver/recomp008/all.T @@ -1,6 +1,8 @@ # Test for #4469, a recompilation bug related to instances test('recomp008', - [extra_files(['A1.hs', 'A2.hs', 'B.hs', 'Main.hs']), - when(fast(), skip), normalise_slashes], + [extra_files(['A1.hs', 'A2.hs', 'B.hs', 'Main.hs']) + , when(fast(), skip) + , normalise_slashes + , js_broken(22261)], makefile_test, []) diff --git a/testsuite/tests/driver/recomp011/all.T b/testsuite/tests/driver/recomp011/all.T index 00a8e74608..8125f95280 100644 --- a/testsuite/tests/driver/recomp011/all.T +++ b/testsuite/tests/driver/recomp011/all.T @@ -1,6 +1,8 @@ # Test for #3589, recompiling when #included files change test('recomp011', - [extra_files(['Main.hs']), - when(arch('powerpc64'), expect_broken(11260))], + [ extra_files(['Main.hs']) + , when(arch('powerpc64'), expect_broken(11260)) + , js_broken(22261) + ], makefile_test, []) diff --git a/testsuite/tests/driver/recomp015/all.T b/testsuite/tests/driver/recomp015/all.T index 25708b47d0..6810d901ae 100644 --- a/testsuite/tests/driver/recomp015/all.T +++ b/testsuite/tests/driver/recomp015/all.T @@ -5,6 +5,7 @@ test('recomp015', # See ticket:11022#comment:7 unless(opsys('linux') or opsys('solaris2') or opsys('openbsd'), skip), when(arch('arm'), skip), + js_skip, # JS backend doesn't support .s assembly files when(arch('powerpc64'), expect_broken(11323))], makefile_test, []) diff --git a/testsuite/tests/driver/recompChangedPackage/all.T b/testsuite/tests/driver/recompChangedPackage/all.T index f08a2534f6..384c66cff2 100644 --- a/testsuite/tests/driver/recompChangedPackage/all.T +++ b/testsuite/tests/driver/recompChangedPackage/all.T @@ -13,7 +13,10 @@ if not config.compiler_profiled and config.have_dynamic: else: dyn = '--disable-shared' -test('recompChangedPackage', [extra_files(['q', 'Main.hs', 'Setup.hs', 'PLib1.hs']), - when(fast(), skip)], +test('recompChangedPackage', + [ extra_files(['q', 'Main.hs', 'Setup.hs', 'PLib1.hs']), + js_broken(22352), + when(fast(), skip) + ], run_command, ['$MAKE -s --no-print-directory recompChangedPackage VANILLA=' + vanilla + ' PROF=' + prof + ' DYN=' + dyn]) diff --git a/testsuite/tests/driver/recompTHpackage/all.T b/testsuite/tests/driver/recompTHpackage/all.T index 78de429b70..141e6f9586 100644 --- a/testsuite/tests/driver/recompTHpackage/all.T +++ b/testsuite/tests/driver/recompTHpackage/all.T @@ -14,6 +14,7 @@ else: dyn = '--disable-shared' test('recompTHpackage', [extra_files(['p', 'q', 'Setup.hs']), - when(fast(), skip)], + when(fast(), skip), + js_broken(22352)], run_command, ['$MAKE -s --no-print-directory recompTHpackage VANILLA=' + vanilla + ' PROF=' + prof + ' DYN=' + dyn]) diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T index da98a5ff6b..3cece482b2 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -4,12 +4,16 @@ # extra run flags # expected process return value, if not zero -test('fed001', normal, compile_and_run, ['']) +test( 'fed001', js_broken(22374) # qsort not yet implemented in JavaScript backend + , compile_and_run, ['']) # Omit GHCi for these two, as they use foreign export -test('ffi001', omit_ways(['ghci']), compile_and_run, ['']) -test('ffi002', [ omit_ways(['ghci']), - pre_cmd('$MAKE -s --no-print-directory ffi002_setup') ], +test('ffi001', [ omit_ways(['ghci']) + , js_skip # JS backend doesn't support foreign export yet + ], compile_and_run, ['']) +test('ffi002', [ omit_ways(['ghci']) + , js_skip # JS backend doesn't support foreign export yet + , pre_cmd('$MAKE -s --no-print-directory ffi002_setup') ], # The ffi002_setup hack is to ensure that we generate # ffi002_stub.h before compiling ffi002_c.c, which # needs it. @@ -34,7 +38,7 @@ test('ffi005', [ omit_ways(prof_ways + ['ghci']), req_c ], compile_and_run, ['ffi005_c.c']) -test('ffi006', normal, compile_and_run, ['']) +test('ffi006', [normal, js_broken(22363)], compile_and_run, ['']) # Skip ffi00{7,8} for GHCi. These tests both try to exit or raise an # error from a foreign export, which shuts down the runtime. When @@ -43,8 +47,10 @@ test('ffi006', normal, compile_and_run, ['']) # Sometimes we end up with the wrong exit code, or get an extra # 'interrupted' message from the GHCi thread shutting down. -test('ffi007', omit_ways(['ghci']), compile_and_run, ['']) -test('ffi008', [exit_code(1), omit_ways(['ghci'])], compile_and_run, ['']) +test('ffi007', [ omit_ways(['ghci']) + , js_skip # foreign "dynamic" call + ], compile_and_run, ['']) +test('ffi008', [exit_code(1), omit_ways(['ghci']), js_broken(22363)], compile_and_run, ['']) # On i386, we need -msse2 to get reliable floating point results if config.platform.startswith('i386-'): @@ -53,7 +59,7 @@ else: opts = '' test('ffi010', normal, compile_and_run, ['']) -test('ffi011', normal, compile_and_run, ['']) +test('ffi011', [normal, js_broken(22363)], compile_and_run, ['']) # The stdcall calling convention works on Windows, and sometimes on # Linux, and fails everywhhere else. For now, we test only on Windows, @@ -66,7 +72,7 @@ else: skip_if_not_windows = skip test('ffi012', skip_if_not_windows, compile_and_run, ['']) -test('ffi013', normal, compile_and_run, ['']) +test('ffi013', [normal, js_broken(22363)], compile_and_run, ['']) # threaded2 sometimes gives ffi014: Main_dDu: interrupted test('ffi014', [only_ways(['threaded1', 'threaded2'])], compile_and_run, @@ -76,7 +82,9 @@ test('ffi014', [only_ways(['threaded1', 'threaded2'])], compile_and_run, test('ffi015', [req_c,omit_ways(['ghci'])], compile_and_run, ['ffi015_cbits.c']) # GHCi can't handle foreign import "&" -test('ffi016', omit_ways(['ghci']), compile_and_run, ['']) +test('ffi016', [ omit_ways(['ghci']) + , js_skip # foreign exports + ], compile_and_run, ['']) test('ffi017', normal, compile_and_run, ['']) @@ -86,13 +94,14 @@ test('ffi018_ghci', [extra_files(['ffi018.h']), only_ways(['ghci']), when(unregisterised(), fragile(16085)), - pre_cmd('$MAKE -s --no-print-directory ffi018_ghci_setup')], + pre_cmd('$MAKE -s --no-print-directory ffi018_ghci_setup'), + req_c], compile_and_run, ['ffi018_ghci_c.o']) -test('ffi019', normal, compile_and_run, ['']) +test('ffi019', [normal, js_broken(22363)], compile_and_run, ['']) # This one originally failed only GHCi, but doesn't hurt to test all ways. -test('T1679', normal, compile_and_run, ['']) +test('T1679', js_broken(22261), compile_and_run, ['']) test('T1288', [omit_ways(['ghci']), req_c], compile_and_run, ['T1288_c.c']) test('T1288_ghci', @@ -107,7 +116,7 @@ test('T2276_ghci', [ only_ways(['ghci']), pre_cmd('$MAKE -s --no-print-directory T2276_ghci_setup') ], compile_and_run, ['-fobject-code T2276_ghci_c.o']) -test('T2469', normal, compile_and_run, ['-optc-std=gnu99']) +test('T2469', js_broken(22261), compile_and_run, ['-optc-std=gnu99']) test('T2594', [omit_ways(['ghci']), req_c], compile_and_run, ['T2594_c.c']) @@ -122,10 +131,11 @@ test('T2917a', normal, compile_and_run, ['']) # omit prof ways, because this test causes the RTS to exit (correctly) # without generating profiling information. test('ffi020', [ omit_ways(prof_ways), - exit_code(1) ], compile_and_run, ['']) + exit_code(1), + js_broken(22363)], compile_and_run, ['']) -test('ffi021', normal, compile_and_run, ['']) +test('ffi021', [normal, js_broken(22363)], compile_and_run, ['']) test('ffi022', normal, compile_and_run, ['']) @@ -134,7 +144,7 @@ if config.os == 'mingw32': flagsForT4038 = ['-optl-Wl,--stack,10485760'] else: flagsForT4038 = [''] -test('T4038', normal, compile_and_run, flagsForT4038) +test('T4038', js_broken(22261), compile_and_run, flagsForT4038) test('T4221', [omit_ways(['ghci']),req_c], compile_and_run, ['T4221_c.c']) @@ -143,20 +153,24 @@ test('T5402', [ omit_ways(['ghci']), # The T5402_setup hack is to ensure that we generate # T5402_stub.h before compiling T5402_main.c, which # needs it. - pre_cmd('$MAKE -s --no-print-directory T5402_setup') ], + pre_cmd('$MAKE -s --no-print-directory T5402_setup'), + req_c + ], compile_and_run, ["-no-hs-main T5402_main.c"]) test('T5594', [ omit_ways(['ghci']), - pre_cmd('$MAKE -s --no-print-directory T5594_setup') ], + pre_cmd('$MAKE -s --no-print-directory T5594_setup'), # The T5594_setup hack is to ensure that we generate # T5594_stub.h before compiling T5594_c.c, which # needs it. + req_c + ], compile_and_run, ['T5594_c.c -no-hs-main']) -test('Capi_Ctype_001', [extra_files(['Capi_Ctype_A_001.hsc', 'capi_ctype_001.h', 'capi_ctype_001_c.c'])], +test('Capi_Ctype_001', [extra_files(['Capi_Ctype_A_001.hsc', 'capi_ctype_001.h', 'capi_ctype_001_c.c']), js_broken(22374)], makefile_test, ['Capi_Ctype_001']) -test('Capi_Ctype_002', [extra_files(['Capi_Ctype_A_002.hsc', 'capi_ctype_002_A.h', 'capi_ctype_002_B.h'])], +test('Capi_Ctype_002', [extra_files(['Capi_Ctype_A_002.hsc', 'capi_ctype_002_A.h', 'capi_ctype_002_B.h']), js_broken(22374)], makefile_test, ['Capi_Ctype_002']) test('ffi_parsing_001', [omit_ways(['ghci']), req_c], compile_and_run, @@ -169,7 +183,7 @@ test('T7170', exit_code(1)], compile_and_run, ['']) -test('T4012', [expect_broken_for(7388, ['ghci'])], multimod_compile_and_run, +test('T4012', [expect_broken_for(7388, ['ghci']), js_broken(22374)], multimod_compile_and_run, ['T4012', '']) test('T8083', [omit_ways(['ghci']), req_c], compile_and_run, ['T8083_c.c']) @@ -178,6 +192,7 @@ test('T9274', [omit_ways(['ghci'])], compile_and_run, ['']) test('ffi023', [ omit_ways(['ghci']), extra_run_opts('1000 4'), + js_broken(22363), pre_cmd('$MAKE -s --no-print-directory ffi023_setup') ], # The ffi023_setup hack is to ensure that we generate # ffi023_stub.h before compiling ffi023_c.c, which @@ -227,9 +242,9 @@ test('IncallAffinity', compile_and_run, ['IncallAffinity_c.c -no-hs-main']) -test('T19237', normal, compile_and_run, ['T19237_c.c']) +test('T19237', req_c, compile_and_run, ['T19237_c.c']) -test('T21305', omit_ways(['ghci']), multi_compile_and_run, +test('T21305', [cmm_src,omit_ways(['ghci'])], multi_compile_and_run, ['T21305', [('T21305_cmm.cmm', '')], '']) test('T22159', diff --git a/testsuite/tests/ghc-api/T4891/all.T b/testsuite/tests/ghc-api/T4891/all.T index c179398c33..01ebba8fa8 100644 --- a/testsuite/tests/ghc-api/T4891/all.T +++ b/testsuite/tests/ghc-api/T4891/all.T @@ -1 +1 @@ -test('T4891', [extra_files(['X.hs'])], makefile_test, ['T4891']) +test('T4891', [extra_files(['X.hs']), js_broken(22362)], makefile_test, ['T4891']) diff --git a/testsuite/tests/ghc-api/all.T b/testsuite/tests/ghc-api/all.T index 4d62a57682..4e6aa16748 100644 --- a/testsuite/tests/ghc-api/all.T +++ b/testsuite/tests/ghc-api/all.T @@ -1,23 +1,23 @@ test('ghcApi', normal, compile_and_run, ['-package ghc']) -test('T6145', normal, makefile_test, ['T6145']) +test('T6145', js_broken(22352), makefile_test, ['T6145']) test('T8639_api', req_rts_linker, makefile_test, ['T8639_api']) test('T8628', req_rts_linker, makefile_test, ['T8628']) -test('T9595', extra_run_opts('"' + config.libdir + '"'), +test('T9595', [extra_run_opts('"' + config.libdir + '"'), js_broken(22362)], compile_and_run, ['-package ghc']) test('T10508_api', [ extra_run_opts('"' + config.libdir + '"'), req_rts_linker ], compile_and_run, ['-package ghc']) -test('T10942', extra_run_opts('"' + config.libdir + '"'), +test('T10942', [extra_run_opts('"' + config.libdir + '"'), js_broken(22362)], compile_and_run, ['-package ghc']) test('T9015', extra_run_opts('"' + config.libdir + '"'), compile_and_run, ['-package ghc']) -test('T11579', extra_run_opts('"' + config.libdir + '"'), compile_and_run, +test('T11579', [extra_run_opts('"' + config.libdir + '"'), js_skip], compile_and_run, ['-package ghc']) test('T12099', normal, compile_and_run, ['-package ghc']) test('T18181', @@ -26,10 +26,12 @@ test('T18181', compile_and_run, ['-package ghc']) test('T18522-dbg-ppr', - extra_run_opts('"' + config.libdir + '"'), + [extra_run_opts('"' + config.libdir + '"'), js_broken(22362)], compile_and_run, ['-package ghc']) -test('T19156', extra_run_opts('"' + config.libdir + '"'), +test('T19156', [ extra_run_opts('"' + config.libdir + '"') + , js_broken(22261) + ], compile_and_run, ['-package ghc']) test('T20757', [unless(opsys('mingw32'), skip), exit_code(1)], diff --git a/testsuite/tests/ghc-api/annotations-literals/all.T b/testsuite/tests/ghc-api/annotations-literals/all.T index 88dd593bab..769aea7b42 100644 --- a/testsuite/tests/ghc-api/annotations-literals/all.T +++ b/testsuite/tests/ghc-api/annotations-literals/all.T @@ -1,2 +1,2 @@ -test('literals', [normalise_slashes, extra_files(['LiteralsTest.hs'])], makefile_test, ['literals']) -test('parsed', [extra_files(['LiteralsTest2.hs'])], makefile_test, ['parsed']) +test('literals', [normalise_slashes, extra_files(['LiteralsTest.hs']), js_broken(22352)], makefile_test, ['literals']) +test('parsed', [extra_files(['LiteralsTest2.hs']), js_broken(22352)], makefile_test, ['parsed']) diff --git a/testsuite/tests/ghc-api/apirecomp001/all.T b/testsuite/tests/ghc-api/apirecomp001/all.T index 363f9c05ab..672b7b4ac8 100644 --- a/testsuite/tests/ghc-api/apirecomp001/all.T +++ b/testsuite/tests/ghc-api/apirecomp001/all.T @@ -1,3 +1,4 @@ test('apirecomp001', - extra_files(['A.hs', 'B.hs', 'myghc.hs']), + [extra_files(['A.hs', 'B.hs', 'myghc.hs']), + js_broken(22352)], makefile_test, ['apirecomp001']) diff --git a/testsuite/tests/ghc-api/downsweep/all.T b/testsuite/tests/ghc-api/downsweep/all.T index 1096159c2c..c293c73cc0 100644 --- a/testsuite/tests/ghc-api/downsweep/all.T +++ b/testsuite/tests/ghc-api/downsweep/all.T @@ -1,12 +1,14 @@ test('PartialDownsweep', [ extra_run_opts('"' + config.libdir + '"') , ignore_stderr + , js_broken(22352) ], compile_and_run, ['-package ghc -package exceptions']) test('OldModLocation', [ extra_run_opts('"' + config.libdir + '"') + , js_broken(22362) , when(opsys('mingw32'), expect_broken(16772)) ], compile_and_run, diff --git a/testsuite/tests/ghc-api/target-contents/all.T b/testsuite/tests/ghc-api/target-contents/all.T index fc6aa9230c..684cd06d74 100644 --- a/testsuite/tests/ghc-api/target-contents/all.T +++ b/testsuite/tests/ghc-api/target-contents/all.T @@ -1,4 +1,6 @@ test('TargetContents', - [extra_run_opts('"' + config.libdir + '"')] + [ extra_run_opts('"' + config.libdir + '"') + , js_broken(22374) + ] , compile_and_run, ['-package ghc -package exceptions']) diff --git a/testsuite/tests/ghci/T13786/all.T b/testsuite/tests/ghci/T13786/all.T index b406fad214..a25b548da6 100644 --- a/testsuite/tests/ghci/T13786/all.T +++ b/testsuite/tests/ghci/T13786/all.T @@ -1,4 +1,4 @@ test('T13786', - when(unregisterised(), fragile(17018)), + [when(unregisterised(), fragile(17018)), js_broken(22359)], makefile_test, []) diff --git a/testsuite/tests/ghci/caf_crash/all.T b/testsuite/tests/ghci/caf_crash/all.T index 6fe22dd454..d50cc5c423 100644 --- a/testsuite/tests/ghci/caf_crash/all.T +++ b/testsuite/tests/ghci/caf_crash/all.T @@ -2,5 +2,6 @@ test('caf_crash', [extra_files(['A.hs', 'B.hs', 'D.hs', ]), when(ghc_dynamic(), skip), extra_ways(['ghci-ext']), - omit_ways(['ghci']), ], + omit_ways(['ghci']), + js_broken(22359)], ghci_script, ['caf_crash.script']) diff --git a/testsuite/tests/ghci/linking/all.T b/testsuite/tests/ghci/linking/all.T index 197500c039..d18d252a93 100644 --- a/testsuite/tests/ghci/linking/all.T +++ b/testsuite/tests/ghci/linking/all.T @@ -1,7 +1,8 @@ test('ghcilink001', [extra_files(['TestLink.hs', 'f.c']), when(ghc_dynamic(), expect_fail), # dynamic ghci can't load '.a's - unless(doing_ghci, skip)], + unless(doing_ghci, skip), + req_interp], # JS backend doesn't use ghci makefile_test, ['ghcilink001']) test('ghcilink002', [extra_files(['TestLink.hs', 'f.c']), @@ -15,7 +16,8 @@ test('ghcilink003', # from Big Sur onwards, we can't dlopen libstdc++.dylib # anymore. Will produce: # dlopen(libstdc++.dylib, 5): image not found - when(opsys('darwin'), fragile(16083)) + when(opsys('darwin'), fragile(16083)), + req_interp ], makefile_test, ['ghcilink003']) test('ghcilink004', @@ -29,7 +31,8 @@ test('ghcilink005', [extra_files(['TestLink.hs', 'f.c']), when(unregisterised(), fragile(16085)), unless(doing_ghci, skip), - req_dynamic_lib_support], + req_dynamic_lib_support, + req_interp], makefile_test, ['ghcilink005']) test('ghcilink006', @@ -37,18 +40,22 @@ test('ghcilink006', # from Big Sur onwards, we can't dlopen libstdc++.dylib # anymore. Will produce: # dlopen(libstdc++.dylib, 5): image not found - when(opsys('darwin'), fragile(16083)) + when(opsys('darwin'), fragile(16083)), + req_interp ], makefile_test, ['ghcilink006']) test('T3333', [unless(doing_ghci, skip), - when(unregisterised(), fragile(17018))], + when(unregisterised(), fragile(17018)), + js_broken(22359)], makefile_test, ['T3333']) test('T11531', [extra_files(['T11531.hs', 'T11531.c', 'T11531.h']), unless(doing_ghci, skip), unless(opsys('linux'), skip), + req_c, + req_interp, fragile(11531)], makefile_test, ['T11531']) @@ -60,7 +67,8 @@ test('T14708', test('T15729', [extra_files(['T15729.hs', 'T15729.c']), - unless(doing_ghci, skip)], + unless(doing_ghci, skip), + js_broken(22359)], makefile_test, ['T15729']) test('big-obj', [extra_files(['big-obj-c.c', 'big-obj.hs']), diff --git a/testsuite/tests/ghci/linking/dyn/all.T b/testsuite/tests/ghci/linking/dyn/all.T index 9b05ed5fc3..7711f2eb7a 100644 --- a/testsuite/tests/ghci/linking/dyn/all.T +++ b/testsuite/tests/ghci/linking/dyn/all.T @@ -1,14 +1,17 @@ setTestOpts(req_dynamic_lib_support) -test('load_short_name', [extra_files(['A.c']), - unless(doing_ghci, skip)], +test('load_short_name', [ extra_files(['A.c']) + , unless(doing_ghci, skip) + , req_c + ], makefile_test, ['load_short_name']) test('T1407', [extra_files(['A.c']), unless(doing_ghci, skip), pre_cmd('$MAKE -s --no-print-directory compile_libT1407'), - extra_hc_opts('-L"$PWD/T1407dir"')], + extra_hc_opts('-L"$PWD/T1407dir"'), + js_broken(22359)], makefile_test, []) test('T3242', @@ -23,7 +26,10 @@ test('T10955', extra_hc_opts('-L. -L./bin_dep')], ghci_script, ['T10955.script']) -test('T10955dyn', [extra_files(['A.c', 'B.c', 'A.def', 'B.def'])], +test('T10955dyn', + [extra_files(['A.c', 'B.c', 'A.def', 'B.def']) + , js_broken(22351) # dynamic linking not supported by the JS backend + ], makefile_test, ['compile_libAB_dyn']) test('T10458', diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index e64debbb49..321769f21e 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -258,7 +258,7 @@ test('T10963', normal, ghci_script, ['T10963.script']) test('T11547', normal, ghci_script, ['T11547.script']) test('T11721', normal, ghci_script, ['T11721.script']) test('T12005', normal, ghci_script, ['T12005.script']) -test('T12023', normal, makefile_test, []) +test('T12023', js_broken(22359), makefile_test, []) test('T12520', normal, ghci_script, ['T12520.script']) test('T12091', [extra_run_opts('-fobject-code')], ghci_script, ['T12091.script']) diff --git a/testsuite/tests/ghci/should_fail/all.T b/testsuite/tests/ghci/should_fail/all.T index 3e24f19ad3..d80b723c69 100644 --- a/testsuite/tests/ghci/should_fail/all.T +++ b/testsuite/tests/ghci/should_fail/all.T @@ -5,4 +5,4 @@ test('T16013', [], ghci_script, ['T16013.script']) test('T16287', [], ghci_script, ['T16287.script']) test('T18052b', [], ghci_script, ['T18052b.script']) test('T18027a', [], ghci_script, ['T18027a.script']) -test('T20214', [], makefile_test, ['T20214']) +test('T20214', js_broken(22370), makefile_test, ['T20214']) diff --git a/testsuite/tests/haddock/perf/all.T b/testsuite/tests/haddock/perf/all.T index 63e01cd28e..ad9f7ddf51 100644 --- a/testsuite/tests/haddock/perf/all.T +++ b/testsuite/tests/haddock/perf/all.T @@ -1,2 +1,2 @@ -test('haddock_parser_perf', [extra_files(['Fold.hs'])], makefile_test, []) -test('haddock_renamer_perf', [extra_files(['Fold.hs'])], makefile_test, []) +test('haddock_parser_perf', [extra_files(['Fold.hs']), js_skip], makefile_test, []) +test('haddock_renamer_perf', [extra_files(['Fold.hs']), js_skip], makefile_test, []) diff --git a/testsuite/tests/hiefile/should_run/all.T b/testsuite/tests/hiefile/should_run/all.T index 5536034d6b..79d1858cfb 100644 --- a/testsuite/tests/hiefile/should_run/all.T +++ b/testsuite/tests/hiefile/should_run/all.T @@ -2,4 +2,4 @@ test('PatTypes', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestU test('HieQueries', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) test('T20341', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) test('RecordDotTypes', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) -test('SpliceTypes', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) +test('SpliceTypes', [req_th, extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) diff --git a/testsuite/tests/hp2ps/all.T b/testsuite/tests/hp2ps/all.T index 4c652416e7..0227fa0cb6 100644 --- a/testsuite/tests/hp2ps/all.T +++ b/testsuite/tests/hp2ps/all.T @@ -1 +1 @@ -test('T15904', when(opsys('mingw32'), expect_broken(16388)), makefile_test, []) +test('T15904', [when(opsys('mingw32'), expect_broken(16388)), js_broken(22261)], makefile_test, []) diff --git a/testsuite/tests/hpc/all.T b/testsuite/tests/hpc/all.T index 2e2e7710a9..19909eb1a2 100644 --- a/testsuite/tests/hpc/all.T +++ b/testsuite/tests/hpc/all.T @@ -1,3 +1,5 @@ +setTestOpts(js_skip) # JS backend doesn't support HPC yet + test('T10138', [extra_files(['.keepme.hpc.T10138/']), ignore_stdout], run_command, # Using --hpcdir with an absolute path should work (exit code 0). diff --git a/testsuite/tests/hsc2hs/all.T b/testsuite/tests/hsc2hs/all.T index 3869ee4669..21b6974f6b 100644 --- a/testsuite/tests/hsc2hs/all.T +++ b/testsuite/tests/hsc2hs/all.T @@ -1,23 +1,27 @@ -test('hsc2hs001', [], makefile_test, []) +test('hsc2hs001', js_broken(22355), makefile_test, []) -test('hsc2hs002', [], makefile_test, []) +test('hsc2hs002', js_broken(22355), makefile_test, []) -test('hsc2hs003', [], makefile_test, []) +test('hsc2hs003', js_broken(22355), makefile_test, []) test('hsc2hs004', [], makefile_test, []) -test('T3837', [], makefile_test, []) +test('T3837', js_broken(22355), makefile_test, []) # These are broken on CI (and potentially elsewhere) since we # are building ARMv7 # binaries on an AArch64 machine. -test('T4340', when(arch('arm'), expect_broken(17556)), makefile_test, []) -test('T10272', when(arch('arm'), expect_broken(17556)), makefile_test, []) +test('T4340', [ when(arch('arm'), expect_broken(17556)) + , js_broken(17556) + ], makefile_test, []) +test('T10272', [ when(arch('arm'), expect_broken(17556)) + , js_broken(17556) + ], makefile_test, []) -test('T11004', [], makefile_test, []) +test('T11004', js_broken(22355), makefile_test, []) -test('T12504', [extra_files(['T12504']), ignore_stdout], makefile_test, []) +test('T12504', [extra_files(['T12504']), ignore_stdout, js_broken(22355)], makefile_test, []) # Make sure response files are read and used. -test('T15758', [], makefile_test, []) +test('T15758', js_broken(22355), makefile_test, []) diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index 7ebb9eae80..9fd26a660e 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -253,7 +253,7 @@ test('T12522b', normal, compile, ['']) test('T12676', normal, compile, ['']) test('T12526', normal, compile, ['']) test('T12538', normal, compile_fail, ['']) -test('T13244', normal, compile, ['']) +test('T13244', js_broken(22364), compile, ['']) test('T13398a', normal, compile, ['']) test('T13398b', normal, compile, ['']) test('T13662', normal, compile, ['']) diff --git a/testsuite/tests/lib/base/all.T b/testsuite/tests/lib/base/all.T index 5e3cf28f68..65f221187f 100644 --- a/testsuite/tests/lib/base/all.T +++ b/testsuite/tests/lib/base/all.T @@ -1,10 +1,10 @@ test('DataTypeOrd', normal, compile_and_run, ['']) test('T16586', normal, compile_and_run, ['-O2']) # Event-manager not supported on Windows -test('T16916', when(opsys('mingw32'), skip), compile_and_run, ['-O2 -threaded -with-rtsopts="-I0" -rtsopts']) +test('T16916', [when(opsys('mingw32'), skip), js_broken(22261)], compile_and_run, ['-O2 -threaded -with-rtsopts="-I0" -rtsopts']) test('T17310', normal, compile, ['']) test('T19691', normal, compile, ['']) -test('executablePath', extra_run_opts(config.os), compile_and_run, ['']) +test('executablePath', [extra_run_opts(config.os), js_broken(22261)], compile_and_run, ['']) test('T17472', normal, compile_and_run, ['']) test('T19569b', normal, compile_and_run, ['']) test('Monoid_ByteArray', normal, compile_and_run, ['']) diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T index 6e9b8517db..f2854ff1d4 100644 --- a/testsuite/tests/numeric/should_run/all.T +++ b/testsuite/tests/numeric/should_run/all.T @@ -53,7 +53,7 @@ test('mul2', normal, compile_and_run, ['-fobject-code']) test('quotRem2', normal, compile_and_run, ['-fobject-code']) test('T5863', normal, compile_and_run, ['']) -test('T7014', [], makefile_test, []) +test('T7014', js_skip, makefile_test, []) test('T7233', normal, compile_and_run, ['']) test('NumDecimals', normal, compile_and_run, ['']) @@ -63,7 +63,7 @@ test('T9407', normal, compile_and_run, ['']) test('T9810', normal, compile_and_run, ['']) test('T10011', normal, compile_and_run, ['']) test('T10962', omit_ways(['ghci']), compile_and_run, ['-O2']) -test('T11702', extra_ways(['optasm']), compile_and_run, ['']) +test('T11702', [unless(arch("js"),extra_ways(['optasm']))], compile_and_run, ['']) test('T12136', normal, compile_and_run, ['']) test('T15301', normal, compile_and_run, ['-O2']) test('T497', normal, compile_and_run, ['-O']) diff --git a/testsuite/tests/patsyn/should_compile/T13350/all.T b/testsuite/tests/patsyn/should_compile/T13350/all.T index 67b4101ba5..cbc3ed7ddf 100644 --- a/testsuite/tests/patsyn/should_compile/T13350/all.T +++ b/testsuite/tests/patsyn/should_compile/T13350/all.T @@ -1,5 +1,6 @@ # Test that importing COMPLETE sets from external packages works test('T13350', - extra_files(['T13350.hs', 'boolean']), + [extra_files(['T13350.hs', 'boolean']), + js_broken(22352)], makefile_test, ['T13350']) diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index de51bea667..00a5abe8dd 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -536,6 +536,7 @@ test('T16190', test ('T16473', [ collect_stats('bytes allocated',5) , only_ways(['normal']) + , js_broken(22261) ], compile_and_run, ['-O2 -flate-specialise']) diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index 9059a6f92f..59ad878a4c 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -1,3 +1,8 @@ +# disable performance tests for the JS backend +# .stats files aren't generated and the expected allocation metrics (e.g. "bytes +# allocated") can't be reported +setTestOpts(js_skip) + # T12791 and T5835 test that GHC uses top-level instances in places where using # a locally given solution would produce worse code. # See Note [Solving from instances when interacting Dicts] diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T index ec8f4dae97..d042101a4a 100644 --- a/testsuite/tests/perf/space_leaks/all.T +++ b/testsuite/tests/perf/space_leaks/all.T @@ -1,3 +1,4 @@ +setTestOpts(js_skip) test('space_leak_001', # This could potentially be replaced with diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index 65c24b1d00..f513d15a2e 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -8,7 +8,8 @@ test('T4442', test('T10481', exit_code(1), compile_and_run, ['']) test('T10678', [ collect_stats('bytes allocated',5), - only_ways(['normal']) + only_ways(['normal']), + js_broken(22360) ], compile_and_run, ['-O']) test('T11296', normal, compile_and_run, ['']) @@ -45,7 +46,7 @@ test('LevPolyPtrEquality2', normal, compile_and_run, ['']) test('UnliftedArray1', normal, compile_and_run, ['']) test('UnliftedArray2', normal, compile_and_run, ['']) test('UnliftedArrayCAS', normal, compile_and_run, ['']) -test('UnliftedIOPort', normal, compile_and_run, ['']) +test('UnliftedIOPort', js_broken(22261), compile_and_run, ['']) test('UnliftedMutVar1', normal, compile_and_run, ['']) test('UnliftedMutVar2', normal, compile_and_run, ['']) test('UnliftedMutVar3', normal, compile_and_run, ['']) diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T index 0584b1dfa0..34d0f5d879 100644 --- a/testsuite/tests/profiling/should_run/all.T +++ b/testsuite/tests/profiling/should_run/all.T @@ -1,3 +1,5 @@ +setTestOpts(js_skip) # JS backend doesn't support profiling yet + # Test for #1227, #1418 test('heapprof002', diff --git a/testsuite/tests/programs/seward-space-leak/test.T b/testsuite/tests/programs/seward-space-leak/test.T index 906fe94ff6..e1525de9c6 100644 --- a/testsuite/tests/programs/seward-space-leak/test.T +++ b/testsuite/tests/programs/seward-space-leak/test.T @@ -1,3 +1,5 @@ -test('seward-space-leak', [extra_files(['Main.lhs']), - when(fast(), skip)], multimod_compile_and_run, +test('seward-space-leak', [extra_files(['Main.lhs']) + , when(fast(), skip) + , js_broken(22352) + ], multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/rename/prog006/all.T b/testsuite/tests/rename/prog006/all.T index 3a956d702a..5b2c16105d 100644 --- a/testsuite/tests/rename/prog006/all.T +++ b/testsuite/tests/rename/prog006/all.T @@ -1 +1 @@ -test('rn.prog006', [extra_files(['A.hs', 'B/', 'Main.hs', 'pwd.hs'])], makefile_test, []) +test('rn.prog006', [extra_files(['A.hs', 'B/', 'Main.hs', 'pwd.hs']), js_broken(22261)], makefile_test, []) diff --git a/testsuite/tests/rep-poly/all.T b/testsuite/tests/rep-poly/all.T index 9d6adb937d..92d0a9e056 100644 --- a/testsuite/tests/rep-poly/all.T +++ b/testsuite/tests/rep-poly/all.T @@ -15,7 +15,7 @@ test('T18170b', [extra_files(['T18170c.hs']), expect_broken(19893)], multimod_co # T18170b isn't actually broken, but it causes a Core Lint error # even though the program is (correctly) rejected by the typechecker test('T18481', normal, compile, ['']) -test('T18481a', normal, compile, ['']) +test('T18481a', js_broken(22360), compile, ['']) test('T18534', normal, compile_fail, ['']) test('T19615', normal, compile_fail, ['']) test('T19709a', normal, compile_fail, ['']) @@ -30,7 +30,7 @@ test('T20426', normal, compile_fail, ['']) test('T21239', normal, compile, ['']) test('T21544', normal, compile, ['-Wno-deprecated-flags']) -test('EtaExpandDataCon', normal, compile, ['-O']) +test('EtaExpandDataCon', js_broken(22360), compile, ['-O']) test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags']) test('EtaExpandStupid2', normal, compile_fail, ['-Wno-deprecated-flags']) test('LevPolyLet', normal, compile_fail, ['']) @@ -40,10 +40,10 @@ test('RepPolyArgument', normal, compile_fail, ['']) test('RepPolyArrowCmd', normal, compile_fail, ['']) test('RepPolyArrowFun', normal, compile_fail, ['']) test('RepPolyBackpack1', normal, backpack_compile_fail, ['']) -test('RepPolyBackpack2', normal, backpack_run, ['']) +test('RepPolyBackpack2', req_c, backpack_run, ['']) test('RepPolyBackpack3', normal, backpack_compile_fail, ['']) -test('RepPolyBackpack4', normal, backpack_run, ['']) -test('RepPolyBackpack5', normal, backpack_run, ['']) +test('RepPolyBackpack4', req_c, backpack_run, ['']) +test('RepPolyBackpack5', js_broken(22360), backpack_run, ['']) test('RepPolyBinder', normal, compile_fail, ['']) test('RepPolyCase1', normal, compile_fail, ['']) test('RepPolyClassMethod', normal, compile_fail, ['']) @@ -79,8 +79,8 @@ test('RepPolySum', normal, compile_fail, ['']) test('RepPolyTuple', normal, compile_fail, ['']) test('RepPolyTupleSection', normal, compile_fail, ['']) test('RepPolyUnboxedPatterns', normal, compile_fail, ['']) -test('RepPolyUnliftedDatatype', normal, compile, ['']) -test('RepPolyUnliftedDatatype2', normal, compile, ['-O']) +test('RepPolyUnliftedDatatype', js_broken(22360), compile, ['']) +test('RepPolyUnliftedDatatype2', js_broken(22261), compile, ['-O']) test('RepPolyUnliftedNewtype', normal, compile, ['-fno-warn-partial-type-signatures -fno-warn-deprecated-flags']) test('RepPolyWildcardPattern', normal, compile_fail, ['']) @@ -95,7 +95,7 @@ test('UnliftedNewtypesLevityBinder', normal, compile_fail, ['']) ## ## ## These tests work! ## ## -test('T13105', normal, compile, ['']) ## +test('T13105', js_broken(22364), compile, ['']) ## test('T17536b', normal, compile, ['']) ## ## ## These don't! ## diff --git a/testsuite/tests/rts/T15261/all.T b/testsuite/tests/rts/T15261/all.T index 402764ddb7..e8cd0bd30e 100644 --- a/testsuite/tests/rts/T15261/all.T +++ b/testsuite/tests/rts/T15261/all.T @@ -1,2 +1,2 @@ -test('T15261a', normal, makefile_test, ['T15261a']) -test('T15261b', normal, makefile_test, ['T15261b']) +test('T15261a', js_broken(22370), makefile_test, ['T15261a']) +test('T15261b', js_broken(22370), makefile_test, ['T15261b']) diff --git a/testsuite/tests/rts/T15894/all.T b/testsuite/tests/rts/T15894/all.T index a2c207979e..0923a9fa28 100644 --- a/testsuite/tests/rts/T15894/all.T +++ b/testsuite/tests/rts/T15894/all.T @@ -1,3 +1,5 @@ test('T15894', - [extra_files(['copysign.c', 'main.hs']), when(ghc_dynamic(), skip)], + [ extra_files(['copysign.c', 'main.hs']), when(ghc_dynamic(), skip) + , js_broken(22359) + ], makefile_test, ['T15894']) diff --git a/testsuite/tests/rts/T1791/all.T b/testsuite/tests/rts/T1791/all.T index 483a2a0f58..a291749493 100644 --- a/testsuite/tests/rts/T1791/all.T +++ b/testsuite/tests/rts/T1791/all.T @@ -1,4 +1,6 @@ test('T1791', - [ exit_code(0) ], + [ exit_code(0) + , js_skip # The JS backend doesn't detect heap overflows + ], run_command, ['''"$MAKE" -s --no-print-directory T1791 >/dev/null && ./T1791 +RTS -M8M''']) diff --git a/testsuite/tests/rts/T8308/all.T b/testsuite/tests/rts/T8308/all.T index cbc86a51cb..74eeec3ebc 100644 --- a/testsuite/tests/rts/T8308/all.T +++ b/testsuite/tests/rts/T8308/all.T @@ -1 +1 @@ -test('T8308', normal, makefile_test, ['T8308']) +test('T8308', js_broken(22261), makefile_test, ['T8308']) diff --git a/testsuite/tests/rts/T9579/all.T b/testsuite/tests/rts/T9579/all.T index cc0180e822..62ea56a74d 100644 --- a/testsuite/tests/rts/T9579/all.T +++ b/testsuite/tests/rts/T9579/all.T @@ -1,3 +1,5 @@ +setTestOpts(js_skip) # the JS backend doesn't detect overflows + # some numbers like "(1 MB)" would still remain. # but let's just assume the actual difference in bytes # is too small to have an effect on the rounded megabyte value. diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 4f57c51f57..ac184db6cc 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -42,6 +42,7 @@ test('derefnull', when(platform('aarch64-apple-darwin'), [ignore_stderr, exit_code(139)]), when(opsys('mingw32'), [ignore_stderr, exit_code(11)]), when(opsys('mingw32'), [fragile(18548)]), + when(platform('js-unknown-ghcjs'), [ignore_stderr, exit_code(1)]), # ThreadSanitizer changes the output when(have_thread_sanitizer(), skip), # since these test are supposed to crash the @@ -96,10 +97,14 @@ test('outofmem', [ when(opsys('darwin'), skip), # windows, to prevent absolute exhaustion of memory # and subsequent termination (and failure) of unrelated # tests. + js_skip, + # similarly for the JS backend when(opsys('mingw32'), skip), normalise_errmsg_fun(remove_parenthesis)], makefile_test, ['outofmem']) -test('outofmem2', normal, makefile_test, ['outofmem2']) +test('outofmem2', + [ js_skip # JS backend doesn't detect heap exhaustion + ], makefile_test, ['outofmem2']) test('T2047', [ignore_stdout, @@ -136,6 +141,7 @@ test('stack003', [ omit_ways(['ghci']), # uses unboxed tuples # Test that +RTS -K0 (e.g. no stack limit) parses correctly test('stack004', [ extra_run_opts('+RTS -K0 -RTS') + , js_broken(22374) , expect_broken_for(14913, ['ghci']) ], compile_and_run, ['']) @@ -151,31 +157,44 @@ test('T3424', compile_and_run, ['']) # Test for out-of-range heap size -test('rtsflags001', [ only_ways(['normal']), exit_code(1), extra_run_opts('+RTS -H0m -RTS') ], compile_and_run, ['']) +test('rtsflags001', [ only_ways(['normal']), + exit_code(1), + extra_run_opts('+RTS -H0m -RTS'), + js_skip # JS backend uses its own rts. + ], + compile_and_run, ['']) # Crashed with 7.2 and earlier -test('rtsflags002', [ only_ways(['normal']) ], compile_and_run, ['-with-rtsopts="-B -B -B"']) +test('rtsflags002', [ only_ways(['normal']), js_broken(22261) ], compile_and_run, ['-with-rtsopts="-B -B -B"']) # omit dyn and profiling ways, because we don't build dyn_l or p_l # variants of the RTS by default test('traceEvent', [ omit_ways(['dyn', 'ghci'] + prof_ways), - extra_run_opts('+RTS -ls -RTS') ], + extra_run_opts('+RTS -ls -RTS'), + js_skip # JS backend has no payload size limit + ], compile_and_run, ['']) test('traceBinaryEvent', [ omit_ways(['dyn', 'ghci'] + prof_ways), - extra_run_opts('+RTS -ls -RTS') ], + extra_run_opts('+RTS -ls -RTS'), + js_skip # traceBinaryEvent not supported + ], compile_and_run, ['']) # Test that -ol flag works as expected test('EventlogOutput1', [ extra_files(["EventlogOutput.hs"]), - omit_ways(['dyn', 'ghci'] + prof_ways) ], + omit_ways(['dyn', 'ghci'] + prof_ways), + js_skip + ], makefile_test, ['EventlogOutput1']) # Test that -ol flag defaults to <program>.eventlog test('EventlogOutput2', [ extra_files(["EventlogOutput.hs"]), - omit_ways(['dyn', 'ghci'] + prof_ways) ], + omit_ways(['dyn', 'ghci'] + prof_ways), + js_skip + ], makefile_test, ['EventlogOutput2']) test('EventlogOutputNull', @@ -202,12 +221,16 @@ test('T4059', req_c, makefile_test, ['T4059']) test('exec_signals', [when(opsys('mingw32'), skip), pre_cmd('$MAKE -s --no-print-directory exec_signals-prep'), - cmd_prefix('./exec_signals_prepare')], + cmd_prefix('./exec_signals_prepare'), + js_broken(22355)], compile_and_run, ['']) test('return_mem_to_os', normal, compile_and_run, ['']) -test('T4850', when(opsys('mingw32'), expect_broken(4850)), makefile_test, ['T4850']) +test('T4850', + [ when(opsys('mingw32'), expect_broken(4850)) + , js_broken(22261) # FFI "dynamic" convention unsupported + ], makefile_test, ['T4850']) def config_T5250(name, opts): if not (config.arch in ['i386','x86_64']): @@ -227,18 +250,22 @@ test('T5423', cmm_src, makefile_test, ['T5423']) test('T5993', extra_run_opts('+RTS -k8 -RTS'), compile_and_run, ['']) test('T6006', [ omit_ways(prof_ways + ['ghci']), - pre_cmd('$MAKE -s --no-print-directory T6006_setup') ], + pre_cmd('$MAKE -s --no-print-directory T6006_setup'), + js_skip + ], # The T6006_setup hack is to ensure that we generate # T6006_stub.h before compiling T6006_c.c, which # needs it. compile_and_run, ['T6006_c.c -no-hs-main']) -test('T7037', [], makefile_test, ['T7037']) +test('T7037', js_broken(22374), makefile_test, ['T7037']) test('T7087', exit_code(1), compile_and_run, ['']) -test('T7160', omit_ways(['nonmoving_thr', 'nonmoving_thr_ghc']), compile_and_run, ['']) +test('T7160', [ omit_ways(['nonmoving_thr', 'nonmoving_thr_ghc']) + , js_broken(22261) + ], compile_and_run, ['']) -test('T7040', [omit_ways(['ghci'])], compile_and_run, ['T7040_c.c']) +test('T7040', [omit_ways(['ghci']), req_c], compile_and_run, ['T7040_c.c']) test('T7040_ghci', [extra_files(['T7040_c.h']), @@ -307,16 +334,19 @@ test('T10017', [ when(opsys('mingw32'), skip) test('T11108', normal, compile_and_run, ['']) -test('GcStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))], +test('GcStaticPointers', [ when(doing_ghci() + , extra_hc_opts('-fobject-code')) + , js_broken(22261) + ], compile_and_run, ['']) test('ListStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))], compile_and_run, ['']) # 251 = RTS exit code for "out of memory" -test('overflow1', [ exit_code(251), when(wordsize(32), expect_broken(15255)) ], +test('overflow1', [ js_skip, exit_code(251), when(wordsize(32), expect_broken(15255)) ], compile_and_run, ['']) -test('overflow2', [ exit_code(251) ], compile_and_run, ['']) -test('overflow3', [ exit_code(251) ], compile_and_run, ['']) +test('overflow2', [ js_skip, exit_code(251) ], compile_and_run, ['']) +test('overflow3', [ js_skip, exit_code(251) ], compile_and_run, ['']) def grep_stderr(pattern): def wrapper(cmd, pattern=pattern): @@ -326,8 +356,10 @@ def grep_stderr(pattern): # The ghci way gets confused by the RTS options test('T9839_01', - [omit_ways(['ghci']), extra_run_opts('+RTS -T-s'), no_check_hp, - grep_stderr('given an argument when none was expected')], + [ omit_ways(['ghci']), extra_run_opts('+RTS -T-s'), no_check_hp + , grep_stderr('given an argument when none was expected') + , js_broken(22261) + ], compile_and_run, ['']) test('T9839_02', @@ -352,16 +384,19 @@ test('T9839_05', # ignore_stderr as RTS reports slightly different error messages # in 'epoll' and 'select' backends on reading from EBADF # mingw32 skip as UNIX pipe and close(fd) is used to exercise the problem -test('T10590', [ignore_stderr, when(opsys('mingw32'), skip)], compile_and_run, ['']) +test('T10590', [ ignore_stderr + , when(opsys('mingw32'), skip) + , js_skip # JS backend doesn't support pipes + ], compile_and_run, ['']) # 20000 was easily enough to trigger the bug with 7.10 -test('T10904', [ omit_ways(['ghci']), extra_run_opts('20000') ], +test('T10904', [ omit_ways(['ghci']), extra_run_opts('20000'), req_c ], compile_and_run, ['T10904lib.c']) test('T10728', [extra_run_opts('+RTS -maxN3 -RTS'), only_ways(['threaded2'])], compile_and_run, ['']) -test('T9405', [when(opsys('mingw32'), expect_broken(21361))], makefile_test, ['T9405']) +test('T9405', [when(opsys('mingw32'), expect_broken(21361)), js_broken(22261)], makefile_test, ['T9405']) test('T11788', [ when(ghc_dynamic(), skip) , req_interp @@ -387,7 +422,8 @@ test('T13617', [ unless(opsys('mingw32'), skip)], test('T12903', [ when(opsys('mingw32'), skip) , when(opsys('darwin'), skip) , when(arch('i386'), fragile(20377)) - , omit_ways(['ghci', 'profasm'])] + , omit_ways(['ghci', 'profasm']) + , js_broken(22374)] , compile_and_run, ['']) test('T13832', exit_code(1), compile_and_run, ['-threaded']) @@ -395,7 +431,7 @@ test('T13894', normal, compile_and_run, ['']) # this test fails with the profasm way on some machines but not others, # so we just skip it. test('T14497', [omit_ways(['profasm']), multi_cpu_race], compile_and_run, ['-O']) -test('T14695', [normal, ignore_stderr], makefile_test, ['T14695']) +test('T14695', [js_broken(22359), ignore_stderr], makefile_test, ['T14695']) test('T14702', [ ignore_stdout , when(unregisterised(), skip) , when(opsys('mingw32'), fragile(18953)) @@ -404,9 +440,14 @@ test('T14702', [ ignore_stdout ] , compile_and_run, ['']) -test('T14900', normal, compile_and_run, ['-package ghc-compact']) -test('InternalCounters', normal, makefile_test, ['InternalCounters']) -test('alloccounter1', normal, compile_and_run, +test('T14900', + [ js_skip # Compact regions not supported by the JS backend yet + ], compile_and_run, ['-package ghc-compact']) + +test('InternalCounters', + [ js_skip # JS backend doesn't support internal counters + ], makefile_test, ['InternalCounters']) +test('alloccounter1', js_broken(22261), compile_and_run, [ # avoid allocating stack chunks, which counts as # allocation and messes up the results: @@ -472,19 +513,21 @@ test('T17088', [only_ways(['normal']), extra_run_opts('+RTS -c -A256k -RTS')], compile_and_run, ['-rtsopts -O2']) -test('T15427', normal, compile_and_run, ['']) +test('T15427', js_broken(22374), compile_and_run, ['']) test('T19481', [extra_run_opts('+RTS -T -RTS'), + js_broken(22374), # memory behavior changes appreciably with the nonmoving collector omit_ways(['nonmoving', 'nonmoving_thr', 'nonmoving_thr_sanity'])], compile_and_run, ['']) test('T19381', [extra_run_opts('+RTS -T -RTS'), + js_broken(22374), # memory behavior changes appreciably with the nonmoving collector omit_ways(['nonmoving', 'nonmoving_thr', 'nonmoving_thr_sanity'])], compile_and_run, ['']) -test('T20199', [ grep_errmsg('Hello') ] +test('T20199', [ grep_errmsg('Hello'), req_c ] , makefile_test, []) # We need to be precise about the used way here as different ways may lead to @@ -492,12 +535,30 @@ test('T20199', [ grep_errmsg('Hello') ] # test). test('cloneMyStack', [req_c,only_ways(['normal']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c']) -test('cloneMyStack2', ignore_stdout, compile_and_run, ['']) + +test('cloneMyStack2', + [ ignore_stdout + , js_broken(22261) # cloneMyStack# not yet implemented + ], compile_and_run, ['']) + test('cloneMyStack_retBigStackFrame', [req_c, extra_files(['cloneStackLib.c']), ignore_stdout], compile_and_run, ['cloneStackLib.c']) + test('cloneThreadStack', [req_c, only_ways(['threaded1']), extra_ways(['threaded1']), extra_files(['cloneStackLib.c'])], compile_and_run, ['cloneStackLib.c -threaded']) -test('decodeMyStack', normal, compile_and_run, ['-finfo-table-map']) + +test('decodeMyStack', + [ js_broken(22261) # cloneMyStack# not yet implemented + ], compile_and_run, ['-finfo-table-map']) + # Options: # - `-kc8K`: Set stack chunk size to it's minimum to provoke underflow stack frames. -test('decodeMyStack_underflowFrames', [extra_run_opts('+RTS -kc8K -RTS')], compile_and_run, ['-finfo-table-map -rtsopts']) +test('decodeMyStack_underflowFrames', + [ extra_run_opts('+RTS -kc8K -RTS') + , js_broken(22261) # cloneMyStack# not yet implemented + ], compile_and_run, ['-finfo-table-map -rtsopts']) + # -finfo-table-map intentionally missing -test('decodeMyStack_emptyListForMissingFlag', [ignore_stdout, ignore_stderr], compile_and_run, ['']) +test('decodeMyStack_emptyListForMissingFlag', + [ ignore_stdout + , ignore_stderr + , js_broken(22261) # cloneMyStack# not yet implemented + ], compile_and_run, ['']) diff --git a/testsuite/tests/rts/continuations/all.T b/testsuite/tests/rts/continuations/all.T index 7b35e29c00..e8852416eb 100644 --- a/testsuite/tests/rts/continuations/all.T +++ b/testsuite/tests/rts/continuations/all.T @@ -1,3 +1,5 @@ +setTestOpts(js_broken(22261)) + test('cont_simple_shift', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_simple_shift', '']) test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_exn_masking', '']) test('cont_missing_prompt_err', [extra_files(['ContIO.hs']), exit_code(1)], multimod_compile_and_run, ['cont_missing_prompt_err', '']) diff --git a/testsuite/tests/rts/flags/T17720/all.T b/testsuite/tests/rts/flags/T17720/all.T index d3921bc112..0ffe75777c 100644 --- a/testsuite/tests/rts/flags/T17720/all.T +++ b/testsuite/tests/rts/flags/T17720/all.T @@ -1,20 +1,23 @@ test('T17720a', [extra_run_opts('+RTS -ibogus'), exit_code(1), check_errmsg('bad value for -i'), extra_files(['T17720.hs']), - only_ways(['normal'])], + only_ways(['normal']), + js_broken(22261)], multimod_compile_and_run, ['T17720', '-rtsopts']) test('T17720b', [extra_run_opts('+RTS -Cv'), exit_code(1), check_errmsg('bad value for -C'), extra_files(['T17720.hs']), - only_ways(['normal'])], + only_ways(['normal']), + js_broken(22261)], multimod_compile_and_run, ['T17720', '-rtsopts']) test('T17720c', [extra_run_opts('+RTS -V3b'), exit_code(1), check_errmsg('bad value for -V'), extra_files(['T17720.hs']), - only_ways(['normal'])], + only_ways(['normal']), + js_broken(22261)], multimod_compile_and_run, - ['T17720', '-rtsopts'])
\ No newline at end of file + ['T17720', '-rtsopts']) diff --git a/testsuite/tests/rts/flags/all.T b/testsuite/tests/rts/flags/all.T index e60e58f0c1..65de43681a 100644 --- a/testsuite/tests/rts/flags/all.T +++ b/testsuite/tests/rts/flags/all.T @@ -1,3 +1,5 @@ +setTestOpts(js_skip) # JS backend doesn't support native RTS flags + # We ignore ways which depend on passing RTS arguments for simplicity and only # run in normal way. diff --git a/testsuite/tests/rts/linker/T11223/all.T b/testsuite/tests/rts/linker/T11223/all.T index 1fc09e3cfd..e58ca4afc8 100644 --- a/testsuite/tests/rts/linker/T11223/all.T +++ b/testsuite/tests/rts/linker/T11223/all.T @@ -14,12 +14,14 @@ def normalise_duplicate_errmsg( msg ): test('T11223_simple_link', [extra_files(['foo.c', 'foo.hs']), - when(ghc_dynamic(), skip)], + when(ghc_dynamic(), skip), + req_c], makefile_test, ['t_11223_simple_link']) test('T11223_simple_link_lib', [extra_files(['foo.c', 'foo.hs']), - when(ghc_dynamic(), skip)], + when(ghc_dynamic(), skip), + req_c], makefile_test, ['t_11223_simple_link_lib']) # I'm ignoring the output since for this particular invocation normalise_errmsg @@ -32,32 +34,38 @@ test('T11223_simple_duplicate', test('T11223_simple_duplicate_lib', [extra_files(['bar.c', 'foo.c', 'foo.hs']), when(platform('i386-unknown-mingw32'), expect_broken(13515)), - when(ghc_dynamic(), skip), normalise_errmsg_fun(normalise_duplicate_errmsg)], + when(ghc_dynamic(), skip), normalise_errmsg_fun(normalise_duplicate_errmsg), + req_c], makefile_test, ['t_11223_simple_duplicate_lib']) test('T11223_simple_unused_duplicate_lib', [extra_files(['bar.c', 'foo.c', 'foo.hs']), - when(ghc_dynamic(), skip)], + when(ghc_dynamic(), skip), + req_c], makefile_test, ['t_11223_simple_unused_duplicate_lib']) test('T11223_link_order_a_b_succeed', [extra_files(['bar.c', 'foo.c', 'foo2.hs']), - when(ghc_dynamic(), skip)], + when(ghc_dynamic(), skip), + req_c], makefile_test, ['t_11223_link_order_a_b_succeed']) test('T11223_link_order_b_a_succeed', [extra_files(['bar.c', 'foo.c', 'foo2.hs']), - when(ghc_dynamic(), skip)], + when(ghc_dynamic(), skip), + req_c], makefile_test, ['t_11223_link_order_b_a_succeed']) test('T11223_link_order_a_b_2_fail', [extra_files(['bar.c', 'foo.c', 'foo3.hs']), - when(ghc_dynamic(), skip), normalise_errmsg_fun(normalise_duplicate_errmsg)], + when(ghc_dynamic(), skip), normalise_errmsg_fun(normalise_duplicate_errmsg), + req_c], makefile_test, ['t_11223_link_order_a_b_2_fail']) test('T11223_link_order_b_a_2_succeed', [extra_files(['bar.c', 'foo.c', 'foo3.hs']), - when(ghc_dynamic(), skip)], + when(ghc_dynamic(), skip), + req_c], makefile_test, ['t_11223_link_order_b_a_2_succeed']) # Weak Symbols are not currently implemented. So Disable all the tests diff --git a/testsuite/tests/rts/linker/all.T b/testsuite/tests/rts/linker/all.T index 4387bc2337..5cbf1c2091 100644 --- a/testsuite/tests/rts/linker/all.T +++ b/testsuite/tests/rts/linker/all.T @@ -20,6 +20,7 @@ test('section_alignment', # Test to see if linker scripts link properly to real ELF files test('T2615', [extra_files(['libfoo_T2615.c', 'libfoo_script_T2615.so']), + js_broken(22374), when(opsys('mingw32'), skip), # OS X doesn't seem to support linker scripts when(opsys('darwin'), skip), @@ -75,9 +76,13 @@ test('T5435_v_gcc', makefile_test, ['T5435_v_gcc']) test('T5435_dyn_asm', [extra_files(['T5435.hs', 'T5435_asm.c']), + js_skip, # dynamic linking not supported by the JS backend check_stdout(checkDynAsm)], makefile_test, ['T5435_dyn_asm']) -test('T5435_dyn_gcc', extra_files(['T5435.hs', 'T5435_gcc.c']) , makefile_test, ['T5435_dyn_gcc']) +test('T5435_dyn_gcc', + [extra_files(['T5435.hs', 'T5435_gcc.c']), + js_skip], # dynamic linking not supported by the JS backend + makefile_test, ['T5435_dyn_gcc']) ###################################### test('linker_unload', @@ -94,12 +99,15 @@ test('linker_unload_native', ###################################### test('linker_error1', [extra_files(['linker_error.c']), + js_skip, # dynamic linking not supported by the JS backend ignore_stderr], makefile_test, ['linker_error1']) test('linker_error2', [extra_files(['linker_error.c']), + js_skip, # dynamic linking not supported by the JS backend ignore_stderr], makefile_test, ['linker_error2']) test('linker_error3', [extra_files(['linker_error.c']), + js_skip, # dynamic linking not supported by the JS backend ignore_stderr], makefile_test, ['linker_error3']) ###################################### @@ -107,6 +115,7 @@ test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip) # this needs runtime infrastructure to do in ghci: # '-rdynamic' ghc, load modules only via dlopen(RTLD_BLOBAL) and more. , omit_ways(['ghci']) + , js_broken(22374) ], compile_and_run, ['-rdynamic -package ghc']) diff --git a/testsuite/tests/rts/pause-resume/all.T b/testsuite/tests/rts/pause-resume/all.T index 88c6f6e483..cbbc057eb5 100644 --- a/testsuite/tests/rts/pause-resume/all.T +++ b/testsuite/tests/rts/pause-resume/all.T @@ -1,25 +1,30 @@ test('pause_resume_via_safe_ffi', [ only_ways(['threaded1', 'threaded2']) + , req_c , extra_files(['pause_resume.c','pause_resume.h']) ], multi_compile_and_run, ['pause_resume_via_safe_ffi', [('pause_resume.c','')], '']) test('pause_resume_via_pthread', [ only_ways(['threaded1', 'threaded2']) + , req_c , extra_files(['pause_resume.c','pause_resume.h']) ], multi_compile_and_run, ['pause_resume_via_pthread', [('pause_resume.c','')], '']) test('pause_resume_via_safe_ffi_concurrent', [ only_ways(['threaded1', 'threaded2']) + , req_c , extra_files(['pause_resume.c','pause_resume.h']) ], multi_compile_and_run, ['pause_resume_via_safe_ffi_concurrent', [('pause_resume.c','')], '']) test('pause_and_use_rts_api', [ only_ways(['threaded1', 'threaded2']) + , req_c , extra_files(['pause_resume.c','pause_resume.h']) ], multi_compile_and_run, ['pause_and_use_rts_api', [('pause_resume.c','')], '']) test('list_threads_and_misc_roots', [ only_ways(['threaded1', 'threaded2']) + , req_c , extra_files(['list_threads_and_misc_roots_c.c','list_threads_and_misc_roots_c.h']) ], - multi_compile_and_run, ['list_threads_and_misc_roots', [('list_threads_and_misc_roots_c.c','')], ''])
\ No newline at end of file + multi_compile_and_run, ['list_threads_and_misc_roots', [('list_threads_and_misc_roots_c.c','')], '']) diff --git a/testsuite/tests/rts/pause-resume/shouldfail/all.T b/testsuite/tests/rts/pause-resume/shouldfail/all.T index f778f8a257..8b11004b3e 100644 --- a/testsuite/tests/rts/pause-resume/shouldfail/all.T +++ b/testsuite/tests/rts/pause-resume/shouldfail/all.T @@ -6,18 +6,21 @@ test('unsafe_rts_pause', test('rts_lock_when_paused', [ only_ways(['threaded1', 'threaded2']) , exit_code(1) + , req_c , extra_files(['rts_pause_lock.c','rts_pause_lock.h']) ], multi_compile_and_run, ['rts_lock_when_paused', [('rts_pause_lock.c','')], '']) test('rts_pause_when_locked', [ only_ways(['threaded1', 'threaded2']) , exit_code(1) + , req_c , extra_files(['rts_pause_lock.c','rts_pause_lock.h']) ], multi_compile_and_run, ['rts_pause_when_locked', [('rts_pause_lock.c','')], '']) test('rts_double_pause', [ only_ways(['threaded1', 'threaded2']) , exit_code(1) + , req_c , extra_files(['rts_pause_lock.c','rts_pause_lock.h']) ], multi_compile_and_run, ['rts_double_pause', [('rts_pause_lock.c','')], '']) diff --git a/testsuite/tests/safeHaskell/check/pkg01/all.T b/testsuite/tests/safeHaskell/check/pkg01/all.T index fd23b2d362..712a91d58d 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/all.T +++ b/testsuite/tests/safeHaskell/check/pkg01/all.T @@ -31,7 +31,8 @@ test('safePkg01', normalise_errmsg_fun(ignoreLdOutput, normalise_errmsg), normalise_version("array", "ghc-bignum", "bytestring", "base", "deepseq", "ghc-prim"), - normalise_fun(normalise_errmsg)], + normalise_fun(normalise_errmsg), + js_skip], run_command, ['$MAKE -s --no-print-directory safePkg01 ' + make_args]) # Fail since we enable package trust @@ -52,57 +53,66 @@ test('ImpSafe03', test('ImpSafe04', normalise_version('base'), compile_fail, ['-fpackage-trust -distrust base']) test('ImpSafeOnly01', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly01 ' + make_args)], compile, ['-fpackage-trust -package-db pdb.ImpSafeOnly01/local.db -trust base']) test('ImpSafeOnly02', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly02 ' + make_args)], compile, ['-fpackage-trust -package-db pdb.ImpSafeOnly02/local.db -trust base -trust safePkg01']) # Fail since we enable package trust (and still need safePkg01 trusted) test('ImpSafeOnly03', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly03 ' + make_args)], compile_fail, ['-fpackage-trust -package-db pdb.ImpSafeOnly03/local.db -trust base']) # Succeed since we don't enable package trust test('ImpSafeOnly04', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly04 ' + make_args)], compile, ['-package-db pdb.ImpSafeOnly04/local.db -trust base']) # fail due to missing trust of safePkg01, next test succeeds. test('ImpSafeOnly05', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly05 ' + make_args)], compile_fail, ['-fpackage-trust -package-db pdb.ImpSafeOnly05/local.db -trust base']) test('ImpSafeOnly06', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly06 ' + make_args)], compile, ['-fpackage-trust -package-db pdb.ImpSafeOnly06/local.db -trust base -trust safePkg01']) # fail due to missing trust test('ImpSafeOnly07', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly07 ' + make_args), normalise_version("bytestring", "base")], compile_fail, ['-fpackage-trust -package-db pdb.ImpSafeOnly07/local.db -trust safePkg01 -distrust bytestring']) test('ImpSafeOnly08', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly08 ' + make_args), normalise_version("bytestring", "base")], compile_fail, ['-fpackage-trust -package-db pdb.ImpSafeOnly08/local.db -trust safePkg01']) test('ImpSafeOnly09', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly09 ' + make_args), normalise_version("bytestring")], compile_fail, @@ -110,7 +120,8 @@ test('ImpSafeOnly09', # finally succeed test('ImpSafeOnly10', - [extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), + [js_broken(22350), + extra_files(['M_SafePkg.hs', 'M_SafePkg2.hs', 'M_SafePkg3.hs', 'M_SafePkg4.hs', 'M_SafePkg5.hs', 'M_SafePkg6.hs', 'M_SafePkg7.hs', 'M_SafePkg8.hs', 'Setup.hs', 'p.cabal']), pre_cmd('$MAKE -s --no-print-directory mkPackageDatabase.ImpSafeOnly10 ' + make_args)], compile, ['-fpackage-trust -package-db pdb.ImpSafeOnly10/local.db -trust safePkg01 -trust base -trust bytestring']) diff --git a/testsuite/tests/showIface/all.T b/testsuite/tests/showIface/all.T index 0de1ae6e6c..da691a642c 100644 --- a/testsuite/tests/showIface/all.T +++ b/testsuite/tests/showIface/all.T @@ -7,7 +7,7 @@ test('DocsInHiFile1', makefile_test, ['DocsInHiFile1']) test('T17871', [extra_files(['T17871a.hs'])], multimod_compile, ['T17871', '-v0']) test('DocsInHiFileTH', - extra_files(['DocsInHiFileTHExternal.hs', 'DocsInHiFileTH.hs']), + [extra_files(['DocsInHiFileTHExternal.hs', 'DocsInHiFileTH.hs']), js_broken(22261)], makefile_test, ['DocsInHiFileTH']) test('NoExportList', normal, diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 1622c97766..321cb046b9 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -69,7 +69,7 @@ test('T4306', makefile_test, ['T4306']) test('T4201', - normal, + js_skip, # Test prints NCG codegen info (LFI, etc.) makefile_test, ['T4201']) test('T3772', @@ -151,7 +151,8 @@ test('T7702', # a large effect on allocation which is hard to separate from the # allocation done by the plugin... but a regression allocates > 90mb collect_compiler_stats('peak_megabytes_allocated',70), - when(opsys('mingw32'), fragile_for(16799, ['normal'])) + when(opsys('mingw32'), fragile_for(16799, ['normal'])), + js_skip ], compile, ['-v0 -package-db T7702plugin/pkg.T7702/local.package.conf -fplugin T7702Plugin -package T7702plugin ' + config.plugin_way_flags]) @@ -176,7 +177,7 @@ test('T5996', normal, makefile_test, ['T5996']) test('T8537', normal, compile, ['']) -test('T8832', normal, makefile_test, ['T8832']) +test('T8832', js_skip, makefile_test, ['T8832']) test('T8848', normal, makefile_test, ['T8848']) test('T8848a', only_ways(['optasm']), compile, ['-ddump-rules']) test('T8331', only_ways(['optasm']), compile, ['-ddump-rules']) @@ -198,7 +199,7 @@ test('T10083', makefile_test, ['T10083']) test('T10689', normal, compile, ['']) test('T11155', - normal, + js_broken(22261), makefile_test, ['T11155']) test('T11232', normal, compile, ['-O2']) test('T11562', normal, compile, ['-O2']) @@ -237,7 +238,7 @@ test('T13170', only_ways(['optasm']), compile, ['-dcore-lint']) test('T13317', normal, makefile_test, ['T13317']) -test('T13340', normal, makefile_test, ['T13340']) +test('T13340', js_skip, makefile_test, ['T13340']) test('T13338', only_ways(['optasm']), compile, ['-dcore-lint']) test('T13367', normal, makefile_test, ['T13367']) test('T13417', normal, compile, ['-O']) diff --git a/testsuite/tests/tcplugins/all.T b/testsuite/tests/tcplugins/all.T index c371deaaa8..cf1fc211a6 100644 --- a/testsuite/tests/tcplugins/all.T +++ b/testsuite/tests/tcplugins/all.T @@ -1,3 +1,4 @@ +setTestOpts(js_broken(22261)) # See NullaryPlugin.hs for a description of this plugin. test('TcPlugin_Nullary' diff --git a/testsuite/tests/typecheck/T13168/all.T b/testsuite/tests/typecheck/T13168/all.T index 5c4c5e8aa3..27a9a6cb2b 100644 --- a/testsuite/tests/typecheck/T13168/all.T +++ b/testsuite/tests/typecheck/T13168/all.T @@ -1,3 +1,3 @@ test('T13168', - [extra_files(['package1', 'package2', 'Setup.hs'])], + [extra_files(['package1', 'package2', 'Setup.hs']), js_broken(22352)], makefile_test, []) diff --git a/testsuite/tests/typecheck/bug1465/all.T b/testsuite/tests/typecheck/bug1465/all.T index eef85925c6..5578920ef8 100644 --- a/testsuite/tests/typecheck/bug1465/all.T +++ b/testsuite/tests/typecheck/bug1465/all.T @@ -1 +1 @@ -test('bug1465', [extra_files(['B1.hs', 'B2.hs', 'C.hs', 'v1/', 'v2/'])], makefile_test, []) +test('bug1465', [extra_files(['B1.hs', 'B2.hs', 'C.hs', 'v1/', 'v2/']), js_broken(22352)], makefile_test, []) diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 876bcc0dda..6413034c05 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -490,7 +490,7 @@ test('T10592', normal, compile, ['']) test('T11305', normal, compile, ['']) test('T11254', normal, compile, ['']) test('T11379', normal, compile, ['']) -test('T11462', normal, multi_compile, +test('T11462', js_broken(22261), multi_compile, [None, [('T11462_Plugin.hs', '-package ghc'), ('T11462.hs', '')], '-dynamic' if have_dynamic() else '']) test('T11480', normal, compile, ['']) @@ -558,7 +558,7 @@ test('T11723', normal, compile, ['']) test('T12987', normal, compile, ['']) test('T11736', normal, compile, ['']) test('T13248', expect_broken(13248), compile, ['']) -test('T11525', normal, multi_compile, +test('T11525', js_broken(22261), multi_compile, [None, [('T11525_Plugin.hs', '-package ghc'), ('T11525.hs', '')], '-dynamic' if have_dynamic() else '']) test('T12923_1', normal, compile, ['']) @@ -586,7 +586,7 @@ test('T13651a', normal, compile, ['']) test('T13680', normal, compile, ['']) test('T13785', normal, compile, ['']) test('T13804', normal, compile, ['']) -test('T13822', normal, compile, ['']) +test('T13822', js_broken(22364), compile, ['']) test('T13848', normal, compile, ['']) test('T13871', normal, compile, ['']) test('T13879', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index ab7821398a..8d3af674ab 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -411,8 +411,10 @@ test('T11948', normal, compile_fail, ['']) test('T11990a', normal, compile_fail, ['']) test('T11990b', normal, compile_fail, ['']) test('T12035', [], multimod_compile_fail, ['T12035', '-v0']) -test('T12035j', [extra_files(['T12035.hs', 'T12035a.hs', 'T12035.hs-boot']), - req_smp], multimod_compile_fail, ['T12035', '-j2 -v0']) +test('T12035j', [ extra_files(['T12035.hs', 'T12035a.hs', 'T12035.hs-boot']) + , req_smp + , js_broken(22261) + ], multimod_compile_fail, ['T12035', '-j2 -v0']) test('T12045b', normal, compile_fail, ['']) test('T12045c', normal, compile_fail, ['']) test('T12063', [expect_broken(12063)], multimod_compile_fail, ['T12063', '-v0']) diff --git a/testsuite/tests/typecheck/testeq1/test.T b/testsuite/tests/typecheck/testeq1/test.T index bd235315ac..9000e8f640 100644 --- a/testsuite/tests/typecheck/testeq1/test.T +++ b/testsuite/tests/typecheck/testeq1/test.T @@ -1,4 +1,6 @@ -test('typecheck.testeq1', [extra_files(['FakePrelude.hs', 'Main.hs', 'TypeCast.hs', 'TypeEq.hs']), - when(fast(), skip)], multimod_compile_and_run, +test('typecheck.testeq1', [ extra_files(['FakePrelude.hs', 'Main.hs', 'TypeCast.hs', 'TypeEq.hs']) + , when(fast(), skip) + , js_broken(22355) + ], multimod_compile_and_run, ['Main', '-v0']) diff --git a/testsuite/tests/unboxedsums/module/all.T b/testsuite/tests/unboxedsums/module/all.T index a3bd68e652..9850861d07 100644 --- a/testsuite/tests/unboxedsums/module/all.T +++ b/testsuite/tests/unboxedsums/module/all.T @@ -1,2 +1,2 @@ -test('sum_mod', [normalise_slashes, extra_files(['Lib.hs', 'Main.hs'])], +test('sum_mod', [normalise_slashes, extra_files(['Lib.hs', 'Main.hs']), js_broken(22261)], run_command, ['$MAKE -s main --no-print-director']) diff --git a/testsuite/tests/unlifted-datatypes/should_compile/all.T b/testsuite/tests/unlifted-datatypes/should_compile/all.T index d8c3eeb457..13835fe06b 100644 --- a/testsuite/tests/unlifted-datatypes/should_compile/all.T +++ b/testsuite/tests/unlifted-datatypes/should_compile/all.T @@ -1,4 +1,4 @@ test('UnlDataMonoSigs', normal, compile, ['']) -test('UnlDataPolySigs', normal, compile, ['']) +test('UnlDataPolySigs', js_broken(22360), compile, ['']) test('UnlDataFams', normal, compile, ['']) -test('UnlDataUsersGuide', normal, compile, ['']) +test('UnlDataUsersGuide', js_broken(22360), compile, ['']) diff --git a/testsuite/tests/utils/should_run/all.T b/testsuite/tests/utils/should_run/all.T index d3607e6590..765daf9823 100644 --- a/testsuite/tests/utils/should_run/all.T +++ b/testsuite/tests/utils/should_run/all.T @@ -1,2 +1 @@ -test('T15953', [ignore_stdout], makefile_test, []) - +test('T15953', [ignore_stdout, js_skip], makefile_test, []) diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs index b98d8979f9..f1d1cd742c 100644 --- a/utils/deriveConstants/Main.hs +++ b/utils/deriveConstants/Main.hs @@ -51,17 +51,26 @@ main = do opts <- parseArgs case mode of Gen_Haskell_Type -> writeHaskellType fn - [ what | (wh, what) <- wanteds "OS must not matter" + [ what | (wh, what) <- wanteds Nothing -- OS must not matter , wh `elem` [Haskell, Both] ] Gen_Computed cm -> - do os <- getOption "target os" o_targetOS + do os_str <- getOption "target os" o_targetOS tmpdir <- getOption "tmpdir" o_tmpdir gccProg <- getOption "gcc program" o_gccProg nmProg <- getOption "nm program" o_nmProg - let verbose = o_verbose opts + let os = case os_str of + "ghcjs" -> JS + "aix" -> AIX + "wasi" -> WASI + "openbsd" -> OpenBSD + "mingw32" -> Windows + _ -> DefaultOS + verbose = o_verbose opts gccFlags = o_gccFlags opts - rs <- getWanted verbose os tmpdir gccProg gccFlags nmProg - (o_objdumpProg opts) + rs <- case os of + JS -> getWantedJS + _ -> getWanted verbose os tmpdir gccProg gccFlags nmProg + (o_objdumpProg opts) let haskellRs = [ what | (wh, what) <- rs , wh `elem` [Haskell, Both] ] @@ -81,6 +90,15 @@ data Options = Options { o_targetOS :: Maybe String } +data OS + = DefaultOS + | JS + | AIX + | WASI + | OpenBSD + | Windows + deriving (Show, Eq) + -- | Write a file atomically -- -- This avoids other processes seeing the file while it is being written into. @@ -290,7 +308,7 @@ defSize w nameBase cExpr = [(w, GetWord ("SIZEOF_" ++ nameBase) (Fst cExpr))] defClosureSize :: Where -> Name -> CExpr -> Wanteds defClosureSize w nameBase cExpr = [(w, GetClosureSize ("SIZEOF_" ++ nameBase) (Fst cExpr))] -wanteds :: String -> Wanteds +wanteds :: Maybe OS -> Wanteds wanteds os = concat [-- Control group constant for integrity check; this -- round-tripped constant is used for testing that @@ -620,7 +638,7 @@ wanteds os = concat -- Note that this conditional part only affects the C headers. -- That's important, as it means we get the same PlatformConstants -- type on all platforms. - ,if os == "mingw32" + ,if os == Just Windows then concat [structSize C "StgAsyncIOResult" ,structField C "StgAsyncIOResult" "reqID" ,structField C "StgAsyncIOResult" "len" @@ -686,10 +704,10 @@ wanteds os = concat ,constantBool Haskell "USE_INLINE_SRT_FIELD" "defined(USE_INLINE_SRT_FIELD)" ] -getWanted :: Bool -> String -> FilePath -> FilePath -> [String] -> FilePath -> Maybe FilePath +getWanted :: Bool -> OS -> FilePath -> FilePath -> [String] -> FilePath -> Maybe FilePath -> IO Results getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram - = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) (wanteds os)) + = do let cStuff = unlines (headers ++ concatMap (doWanted . snd) (wanteds (Just os))) cFile = tmpdir </> "tmp.c" oFile = tmpdir </> "tmp.o" atomicWriteFile cFile cStuff @@ -700,19 +718,19 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram -- the buffer length info we're interested in. execute verbose gccProgram (gccFlags ++ ( case os of - "wasi" -> ["-emit-llvm", "-S"] + WASI -> ["-emit-llvm", "-S"] _ -> ["-c"] ) ++ [cFile, "-o", oFile]) xs <- case os of - "openbsd" -> readProcess objdumpProgam ["--syms", oFile] "" - "aix" -> readProcess objdumpProgam ["--syms", oFile] "" - "wasi" -> readFile oFile - _ -> readProcess nmProgram ["-P", oFile] "" + OpenBSD -> readProcess objdumpProgam ["--syms", oFile] "" + AIX -> readProcess objdumpProgam ["--syms", oFile] "" + WASI -> readFile oFile + _ -> readProcess nmProgram ["-P", oFile] "" let ls = lines xs m = Map.fromList $ case os of - "aix" -> parseAixObjdump ls - "wasi" -> mapMaybe parseLLLine ls + AIX -> parseAixObjdump ls + WASI -> mapMaybe parseLLLine ls _ -> mapMaybe parseNmLine ls case Map.lookup "CONTROL_GROUP_CONST_291" m of @@ -725,7 +743,7 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram ++ "to 'configure'.\n" Just x -> die ("unexpected value round-tripped for CONTROL_GROUP_CONST_291: " ++ show x) - mapM (lookupResult m) (wanteds os) + mapM (lookupResult m) (wanteds (Just os)) where headers = ["#define IN_STG_CODE 0", "", "/*", @@ -742,7 +760,7 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram -- FIXME: rts/PosixSource.h should include ghcplatform.h -- which should set this. There is a mismatch host/target -- again... - if os == "mingw32" then "#define mingw32_HOST_OS 1" else "", + if os == Windows then "#define mingw32_HOST_OS 1" else "", "", "#include \"rts/PosixSource.h\"", "#include \"Rts.h\"", @@ -901,6 +919,36 @@ getWanted verbose os tmpdir gccProgram gccFlags nmProgram mobjdumpProgram lookupResult _ (w, FieldTypeGcptrMacro name) = return (w, FieldTypeGcptrMacro name) +-- The JavaScript backend doesn't require the native-RTS constants, so we filter those here, +-- and provide reasonable presets for any remaining constants. This way, `deriveConstants` +-- can still produce a valid constants file (required by GHC), without the side-effect of +-- producing a c file. +getWantedJS :: IO Results +getWantedJS = mapM lookupResult (wanteds (Just JS)) + where + jsHardCoded :: Map String Integer + jsHardCoded = Map.fromList [ ("WORD_SIZE", 4) + , ("DOUBLE_SIZE", 8) + , ("CINT_SIZE", 4) + , ("CLONG_SIZE", 4) + , ("CLONG_LONG_SIZE", 8) + ] + + lookupResult :: (Where, What Fst) -> IO (Where, What Snd) + lookupResult (w, GetWord name _) | Just res <- Map.lookup name jsHardCoded + = return (w, GetWord name (Snd res)) + lookupResult (w, what) = return $ case what of + GetWord name _ -> (w, GetWord name (Snd 0)) + GetInt name _ -> (w, GetWord name (Snd 0)) + GetNatural name _ -> (w, GetWord name (Snd 0)) + GetBool name _ -> (w, GetBool name (Snd False)) + GetFieldType name _ -> (w, GetFieldType name (Snd 1)) + GetClosureSize name _ -> (w, GetClosureSize name (Snd 1)) + StructFieldMacro name -> (w, StructFieldMacro name) + ClosureFieldMacro name -> (w, ClosureFieldMacro name) + ClosurePayloadMacro name -> (w, ClosurePayloadMacro name) + FieldTypeGcptrMacro name -> (w, FieldTypeGcptrMacro name) + writeHaskellType :: FilePath -> [What Fst] -> IO () writeHaskellType fn ws = atomicWriteFile fn xs where xs = unlines [header, body, footer, parser] |