From f3d509f41f9c6ea8ea8a237ac374f1a663f2f126 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Sat, 27 Apr 2024 12:20:55 +0200 Subject: [PATCH] Make wrappers usable for boot libraries This changes the wrappers that we generate so that we can also apply them to the boot libraries, enabling us to trace FFI calls made by those libraries (such as `putStrLn`). This now also requires ghc 9.12, so removed all shimming. Co-authored-by: Zubin Duggal --- .github/workflows/haskell-ci.yml | 69 +- .gitignore | 1 + README.md | 236 ++++++- cabal.project.plugin-9.10.0.20240413 | 11 - ...lugin-9.6.4 => cabal.project.plugin-9.12.1 | 2 +- cabal.project.plugin-9.8.2 | 10 - example-pkg-A/example-pkg-A.cabal | 7 +- example-pkg-B/example-pkg-B.cabal | 7 +- .../src/Plugin/TraceForeignCalls.hs | 667 +++++++++++++----- .../Plugin/TraceForeignCalls/Instrument.hs | 152 ++-- .../src/Plugin/TraceForeignCalls/Options.hs | 21 +- .../src/Plugin/TraceForeignCalls/Util/GHC.hs | 65 +- .../src/Plugin/TraceForeignCalls/Util/Shim.hs | 127 ---- trace-foreign-calls/test/Main.hs | 44 +- .../test/Test/TraceForeignCalls/UsePlugin.hs | 2 - trace-foreign-calls/trace-foreign-calls.cabal | 18 +- 16 files changed, 932 insertions(+), 507 deletions(-) delete mode 100644 cabal.project.plugin-9.10.0.20240413 rename cabal.project.plugin-9.6.4 => cabal.project.plugin-9.12.1 (73%) delete mode 100644 cabal.project.plugin-9.8.2 delete mode 100644 trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/Shim.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index b15617c..c91c6bd 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20240421 +# version: 0.19.20250104 # -# REGENDATA ("0.19.20240421",["github","cabal.project.ci"]) +# REGENDATA ("0.19.20250104",["github","cabal.project.ci"]) # name: Haskell-CI on: @@ -28,33 +28,36 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.10.0.20240413 + - compiler: ghc-9.12.1 compilerKind: ghc - compilerVersion: 9.10.0.20240413 - setup-method: ghcup - allow-failure: false - - compiler: ghc-9.8.2 - compilerKind: ghc - compilerVersion: 9.8.2 - setup-method: ghcup - allow-failure: false - - compiler: ghc-9.6.4 - compilerKind: ghc - compilerVersion: 9.6.4 + compilerVersion: 9.12.1 setup-method: ghcup allow-failure: false fail-fast: false steps: - - name: apt + - name: apt-get install run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + - name: Install GHCup + run: | mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; + - name: Install cabal-install + run: | + "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1 || (cat "$HOME"/.ghcup/logs/*.* && false) + echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1 -vnormal+nowrap" >> "$GITHUB_ENV" + - name: Install GHC (GHCup) + if: matrix.setup-method == 'ghcup' + run: | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -65,21 +68,12 @@ jobs: echo "LANG=C.UTF-8" >> "$GITHUB_ENV" echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" - HCDIR=/opt/$HCKIND/$HCVER - HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") - HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') - HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" - echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - if [ $((HCNUMVER >= 91000)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" - echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -106,18 +100,6 @@ jobs: repository hackage.haskell.org url: http://hackage.haskell.org/ EOF - if $HEADHACKAGE; then - cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> cabal.project - fi - $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(example-pkg-A|example-pkg-B|trace-foreign-calls)$/; }' >> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(example-pkg-A|example-pkg-B|trace-foreign-calls)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -237,8 +216,8 @@ jobs: rm -f cabal.project.local $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - name: save cache - uses: actions/cache/save@v4 if: always() + uses: actions/cache/save@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store diff --git a/.gitignore b/.gitignore index f0f6e14..a3f1701 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ .envrc dist-newstyle/ *.eventlog +.ghc.environment.* diff --git a/README.md b/README.md index f719aa1..2e402d8 100644 --- a/README.md +++ b/README.md @@ -2,56 +2,66 @@ ## Overview -Suppose we have a `foreign import` such as +The `trace-foreign-calls` compiler plugin transforms your code, replacing all +foreign imports ```haskell -foreign import capi "cbits.h xkcdRandomNumber" someForeignFunInA :: IO CInt +foreign import capi "foo" c_foo :: .. ``` -If the module containing the import is compiled with this plugin enabled, this -foreign function will be wrapped in a function that emits custom events to the -eventlog before and after the foreign call is made. If you run your executable -with +by -```bash -$ cabal run your-executable -- +RTS -l +```haskell +foreign import capi "foo" c_foo_uninstrumented :: .. +``` + +alongside a wrapper + +```haskell +c_foo :: .. ``` -and then inspect the eventlog with -[`ghc-events`](https://hackage.haskell.org/package/ghc-events) `show`, you will -see something like this: +which calls the original FFI function, but additionally emits eventlog events +before and after the foreign function invocation: ``` -.. -397876: cap 0: running thread 1 -491265: cap 0: trace-foreign-calls: call someForeignFunInA (capi safe "cbits.h xkcdRandomNumber") at CallStack (from HasCallStack): - someForeignFunInA, called at src/ExamplePkgB.hs:11:21 in example-pkg-B-0.1.0-inplace:ExamplePkgB -491815: cap 0: stopping thread 1 (making a foreign call) -492165: cap 0: running thread 1 -500755: cap 0: trace-foreign-calls: return someForeignFunInA -.. +1769223930: cap 2: trace-foreign-calls: call c_foo (capi safe "foo") +... +2206695620: cap 2: trace-foreign-calls: return c_foo ``` -Of course any other tooling for the eventlog, such as -[`threadscope`](https://hackage.haskell.org/package/threadscope), will be able -to see these events as well. +This makes it possible to profile the time spent in foreign calls, either by +processing the event log yourself or by using +[ghc-events-util](https://github.com/well-typed/ghc-events-util). -## Enabling the plugin for your package +## Limitations and future work + +* Requires GHC 9.12 +* Standard time profiling tools can _NOT_ be used on the eventlog. +* It is not possible to profile Haskell functions and FFI functions at the + same time. + +Some of these limitations arise from the fact that we re-using the existing +"heap profile sample" event for a different purpose, which would confuse +existing time profiling tools. A better solution would be to add support for +profiling foreign functions to GHC itself. This would involve adding new types +of eventlog events, corresponding primops to generate them, and update existing +time profiling tooling to interpret those events. + +## Usage + +### Enabling the plugin Add a dependency to the `build-depends` of your `.cabal` file ```cabal - build-depends: - .. - trace-foreign-calls - .. + build-depends: .., trace-foreign-calls ``` and then enable the module either globally by adding ```cabal - ghc-options: - -fplugin=Plugin.TraceForeignCalls + ghc-options: -fplugin=Plugin.TraceForeignCalls ``` to your `.cabal` file, or on a per-module basis by adding this pragma to the @@ -61,7 +71,7 @@ module header: {-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls #-} ``` -## Plugin options +### Plugin options If you want to see how the plugin transforms your code, you can add a plugin option @@ -71,11 +81,50 @@ option -fplugin-opt Plugin.TraceForeignCalls:dump-generated #-} ``` -You can disable `HasCallStack` support by setting +### Running your code +To run your application, make sure to pass the `-l` runtime flag: + +``` +cabal run your-application -- +RTS -l +``` + +### Callstacks + +The plugin will generate a (custom) `call` and `return` event each time a +foreign call is made. To additionally also get a cost-centre callstack, compile +your application with profiling enabled, but do _not_ enbale the `-p` runtime +flag when running it: + +``` +cabal run your-application --enable-profiling -- +RTS -l ``` -{-# OPTIONS_GHC -fplugin-opt Plugin.TraceForeignCalls:disable-callstack #-} + ``` +1769223930: cap 2: trace-foreign-calls: call c_foo (capi safe "foo") +1769224110: heap prof sample 0, residency 2, cost centre stack 29765, 29855, 29768, 24306 +... +2206695620: cap 2: trace-foreign-calls: return c_foo +``` + +The heap sample event we generate is not a true profiling event, and cannot be +processed by standard time profiling tooling. The stack is a true cost-centre +stack, but we leave the `profile` field at zero and abuse the `residency` field +to instead record the capability (this allows us to correlative concurrent +foreign calls). + +### Concurrency + +If your application does any kind of concurrency, make sure to compile your +application with `-threaded`, and run with + +``` +cabal run your-application [--enable-profiling] -- +RTS -l -N +``` + +This will ensure that concurrent foreign calls will run on different +capabilities, making it easier to correlate interleaved `call` and `return` +events. ## Enabling the plugin on all (transitive) dependencies @@ -105,7 +154,9 @@ use a workaround. First, we will install the `plugin` in a fresh `cabal` store: ```bash -$ cabal --store-dir=/tmp/cabal-plugin-store install --lib trace-foreign-calls +cabal --store-dir=/tmp/cabal-plugin-store install \ + --lib trace-foreign-calls \ + --package-env . ``` Create a `cabal.project.plugin` file with @@ -115,7 +166,7 @@ import: cabal.project package * ghc-options: - -package-db=/tmp/cabal-plugin-store/ghc-9.6.4/package.db + -package-db=/tmp/cabal-plugin-store/ghc-9.12.1-a75a/package.db -fplugin-trustworthy -plugin-package=trace-foreign-calls -fplugin=Plugin.TraceForeignCalls @@ -127,10 +178,10 @@ You should then be able to build or run your executable, rebuilding (almost) all of its dependencies, with ```bash -$ cabal run --project-file cabal.project.plugin +$ cabal run --project-file cabal.project.plugin ``` -## Upgrading the plugin +### Upgrading the plugin When you install a new version of the plugin, `cabal` will not try to rebuild any dependencies (it does not include the hash of the plugin in the hash of the @@ -138,6 +189,119 @@ packages). So wipe your `cabal-plugin-store` as well as your `dist-newstyle` directory each time you update your plugin (another good reason for using a separate store for the plugin). +## The generated wrappers + +### IO function, no profiling + +An IO function such as + +```haskell +foreign import capi "test_cbits.h slow_add" + c_slowAddIO :: CLong -> CLong -> IO CLong +``` + +gets replaced by + +```haskell +foreign import capi "test_cbits.h slow_add" + c_slowAddIO_uninstrumented :: CLong -> CLong -> IO CLong +``` + +and the following wrapper is generated: + +```haskell +c_slowAddIO :: CLong -> CLong -> IO CLong +c_slowAddIO x y = + case c_slowAddIO_uninstrumented x y of IO f -> IO $ \s0 -> + + case traceEvent# call s0 of s1 -> + case f s1 of (# s2, result #) -> + case traceEvent# return s2 of s3 -> + + (# s3, result #) + where + call = "trace-foreign-calls: call c_slowAddIO (capi safe \"test_cbits.h slow_add\")"# + return = "trace-foreign-calls: return c_slowAddIO"# +``` + +### Profiling + +When profiling is enabled, we generate some additional calls: + +```haskell +c_slowAddIO :: CLong -> CLong -> IO CLong +c_slowAddIO x y = + case c_slowAddIO_uninstrumented x y of IO f -> IO $ \s0 -> + + case traceEvent# call s0 of s1 -> + case getCurrentCCS# f s1 of (# s2, ccs #) -> + case myThreadId# s2 of (# s3, tid #) -> + case threadStatus# tid s3 of (# s4, _, cap, _ #) -> + + case traceCCS# 0#Word8 ccs (int64ToWord64# (intToInt64# cap)) of IO runTrace -> + + case runTrace s4 of (# s5, _unit #) -> + case f s5 of (# s6, result #) -> + case traceEvent# return s6 of s7 -> + + (# s7, result #) +``` + +### Pure functions + +For a pure foreign import + +```haskell +foreign import capi "test_cbits.h slow_add" + c_slowAddPure :: CLong -> CLong -> CLong +``` + +we generate nearly the same wrapper, except that it starts with + +```haskell +let f = c_slowAddPure_uninstrumented x y in .. +``` + +and we call the function using + +```haskell +case seq# f s of (# s', result #) -> .. +``` + +The wrapper is otherwise identical (with or without profiling). + +## Tests + +### Running the test suite + +To run the test suite, use + +``` +cabal run test-trace-foreign-calls [--enable-profiling] +``` + +The test suite is mostly there to verify that the code generated by the +plugin compiles; we make no effort to inspect the eventlog. To do this manually, +you can use + +``` +ghc-events show test-trace-foreign-calls.eventlog +``` + +and look for `trace-foreign-calls` events. + +### Compiling transitive dependencies + +Set things up as described above; then run + +``` +cabal run --project-file cabal.project.plugin-9.12.1 example-pkg-B -- +RTS -l +``` + +Then `test-B.eventlog` should contain `trace-foreign-calls` events for both +`someForeignFunInA` (defined in `example-pkg-A`) as well as various `zlib` +related functions such as `c_zlibVersion`. + ## `libphread` For reasons currently unclear, enabling the plugin on packages that declare diff --git a/cabal.project.plugin-9.10.0.20240413 b/cabal.project.plugin-9.10.0.20240413 deleted file mode 100644 index 0ce57c5..0000000 --- a/cabal.project.plugin-9.10.0.20240413 +++ /dev/null @@ -1,11 +0,0 @@ -import: cabal.project - --- ghc 9.10.1-alpha3 -package * - ghc-options: - -package-db=/tmp/cabal-plugin-store/ghc-9.10.0.20240413/package.db - -fplugin-trustworthy - -plugin-package=trace-foreign-calls - -fplugin=Plugin.TraceForeignCalls - -store-dir: /tmp/cabal-plugin-store diff --git a/cabal.project.plugin-9.6.4 b/cabal.project.plugin-9.12.1 similarity index 73% rename from cabal.project.plugin-9.6.4 rename to cabal.project.plugin-9.12.1 index 84baa7b..9a456f2 100644 --- a/cabal.project.plugin-9.6.4 +++ b/cabal.project.plugin-9.12.1 @@ -2,7 +2,7 @@ import: cabal.project package * ghc-options: - -package-db=/tmp/cabal-plugin-store/ghc-9.6.4/package.db + -package-db=/tmp/cabal-plugin-store/ghc-9.12.1-a75a/package.db -fplugin-trustworthy -plugin-package=trace-foreign-calls -fplugin=Plugin.TraceForeignCalls diff --git a/cabal.project.plugin-9.8.2 b/cabal.project.plugin-9.8.2 deleted file mode 100644 index f42d482..0000000 --- a/cabal.project.plugin-9.8.2 +++ /dev/null @@ -1,10 +0,0 @@ -import: cabal.project - -package * - ghc-options: - -package-db=/tmp/cabal-plugin-store/ghc-9.8.2/package.db - -fplugin-trustworthy - -plugin-package=trace-foreign-calls - -fplugin=Plugin.TraceForeignCalls - -store-dir: /tmp/cabal-plugin-store diff --git a/example-pkg-A/example-pkg-A.cabal b/example-pkg-A/example-pkg-A.cabal index 520b108..3ad4982 100644 --- a/example-pkg-A/example-pkg-A.cabal +++ b/example-pkg-A/example-pkg-A.cabal @@ -12,15 +12,14 @@ category: Development build-type: Simple extra-source-files: cbits/cbits.h cbits/cbits.c -tested-with: GHC ==9.6.4 - GHC ==9.8.2 - GHC ==9.10.1 +tested-with: GHC ==9.12.1 common lang ghc-options: -Wall build-depends: - base >= 4.18 && < 4.21 + -- For now we don't support ghc < 9.12 + base >= 4.21 && < 4.22 default-language: GHC2021 diff --git a/example-pkg-B/example-pkg-B.cabal b/example-pkg-B/example-pkg-B.cabal index 9c4b3d9..8fa2ea0 100644 --- a/example-pkg-B/example-pkg-B.cabal +++ b/example-pkg-B/example-pkg-B.cabal @@ -12,15 +12,14 @@ author: Edsko de Vries maintainer: edsko@well-typed.com category: Development build-type: Simple -tested-with: GHC ==9.6.4 - GHC ==9.8.2 - GHC ==9.10.1 +tested-with: GHC ==9.12.1 common lang ghc-options: -Wall build-depends: - base >= 4.18 && < 4.21 + -- For now we don't support ghc < 9.12 + base >= 4.21 && < 4.22 default-language: GHC2021 diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs index e4a0d3c..159b3d9 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Plugin.TraceForeignCalls (plugin) where @@ -10,25 +12,26 @@ import Data.Either (partitionEithers) import GHC import GHC.Plugins -import GHC.Builtin.Names -import GHC.Data.Bag -import GHC.Tc.Types -import GHC.Types.ForeignCall -import GHC.Types.SourceText +import GHC.Builtin.Names qualified as Names +import GHC.Builtin.Types.Prim qualified as Prim +import GHC.LanguageExtensions qualified as LangExt +import GHC.Tc.Utils.Monad (TcM, TcGblEnv) +import GHC.Tc.Utils.Monad qualified as TC +import GHC.Types.ForeignCall qualified as Foreign +import GHC.Types.SourceFile (isHsBootOrSig) import Plugin.TraceForeignCalls.Instrument import Plugin.TraceForeignCalls.Options import Plugin.TraceForeignCalls.Util.GHC -import Plugin.TraceForeignCalls.Util.Shim {------------------------------------------------------------------------------- Top-level References: - - https://downloads.haskell.org/ghc/9.6.4/docs/users_guide/extending_ghc.html#compiler-plugins - - https://hackage.haskell.org/package/ghc-9.6.4 - - https://downloads.haskell.org/ghc/9.6.4/docs/users_guide/exts/ffi.html + - https://downloads.haskell.org/ghc/9.12.1/docs/users_guide/extending_ghc.html#compiler-plugins + - https://hackage.haskell.org/package/ghc-9.12.1 + - https://downloads.haskell.org/ghc/9.12.1/docs/users_guide/exts/ffi.html - https://www.haskell.org/onlinereport/haskell2010/haskellch8.html -------------------------------------------------------------------------------} @@ -36,6 +39,12 @@ plugin :: Plugin plugin = defaultPlugin { renamedResultAction = processRenamed , pluginRecompile = purePlugin + , driverPlugin = \_ -> pure . enableUnliftedFFITypes + } + +enableUnliftedFFITypes :: HscEnv -> HscEnv +enableUnliftedFFITypes env = env { + hsc_dflags = xopt_set (hsc_dflags env) LangExt.UnliftedFFITypes } processRenamed :: @@ -43,25 +52,41 @@ processRenamed :: -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) -processRenamed options tcGblEnv group = do - runInstrument options $ (tcGblEnv,) <$> processGroup group +processRenamed options tcGblEnv group + | moduleUnit (TC.tcg_mod tcGblEnv) `elem` [primUnit, bignumUnit] + = pure (tcGblEnv, group) + + | isHsBootOrSig (TC.tcg_src tcGblEnv) + = pure (tcGblEnv, group) + + | otherwise + = (tcGblEnv,) <$> runInstrument tcGblEnv options (processGroup group) {------------------------------------------------------------------------------- Binding groups -------------------------------------------------------------------------------} processGroup :: HsGroup GhcRn -> Instrument (HsGroup GhcRn) -processGroup group@HsGroup{ +processGroup group@HsGroup{ hs_fords , hs_valds = XValBindsLR (NValBinds bindingGroups sigs) } = do - (exports, imports) <- partitionEithers <$> mapM processForeignDecl hs_fords + mTraceCCS <- findName nameTraceCCS + + -- Wrap all (possible) foreign imports + (ignore, imports) <- partitionEithers <$> mapM processForeignDecl hs_fords wrappers <- forM imports $ \i -> (i,) <$> mkWrapper i - whenOption_ optionsDumpGenerated $ dumpWrappers wrappers + + -- Debug output + dump <- optionsDumpGenerated <$> getOptions + when dump $ dumpWrappers wrappers + + -- Construct modified module let (newSigs, newValues) = unzip $ map snd wrappers return $ group { hs_fords = concat [ - exports + ignore + , [importTraceCCS traceCCS | Just traceCCS <- [mTraceCCS]] , map reconstructForeignDecl imports ] , hs_valds = @@ -89,39 +114,107 @@ data ReplacedForeignImport = ReplacedForeignImport { -- | The original (unmodified) foreign import , rfiForeignImport :: ForeignImport GhcRn + + -- | The type of this import + , rfiImportType :: ForeignImportType } +data ForeignImportType = + -- | Pure foreign import + -- + -- We can only process these if we have access to @seq#@, so we record + -- that evidence here. + ForeignImportPure Name + + -- | Function in the IO monad + | ForeignImportIO + +-- | Import @traceCCS#@ +-- +-- Generates +-- +-- > foreign import ccall unsafe "traceHeapProfSampleCostCentre" +-- > traceCCS# :: Word8# -> Addr# -> Word64# -> IO () +importTraceCCS :: Name -> LForeignDecl GhcRn +importTraceCCS traceCCS = noLocValue $ + ForeignImport { + fd_i_ext = noValue + , fd_name = noLocValue traceCCS + , fd_sig_ty = noLocValue $ + HsSig noValue (HsOuterImplicit []) + $ nlHsFunTy (nlHsTyVar NotPromoted Prim.word8PrimTyConName) + $ nlHsFunTy (nlHsTyVar NotPromoted (tyConName Prim.addrPrimTyCon)) + $ nlHsFunTy (nlHsTyVar NotPromoted Prim.word64PrimTyConName) + $ ioUnit + , fd_fi = + CImport + noValue + (noLocA Foreign.CCallConv) + (noLocA Foreign.PlayRisky) + Nothing -- header + (CFunction $ + Foreign.StaticTarget + noValue + (fsLit "traceHeapProfSampleCostCentre") + Nothing -- unit + True -- is this a function? + ) + } + reconstructForeignDecl :: ReplacedForeignImport -> LForeignDecl GhcRn reconstructForeignDecl ReplacedForeignImport { rfiSuffixedName , rfiSigType , rfiForeignImport - } = - noLocValue $ ForeignImport{ + } = noLocValue $ + ForeignImport{ fd_i_ext = noValue , fd_name = rfiSuffixedName , fd_sig_ty = rfiSigType , fd_fi = rfiForeignImport } +-- | Classify foreign declarations +-- +-- Foreign declarations that we don't need to, or cannot handle, are returned +-- as Left values. These are: +-- +-- * Foreign exports +-- * Foreign imports of primops (@prim@ calling convention) processForeignDecl :: LForeignDecl GhcRn -> Instrument (Either (LForeignDecl GhcRn) ReplacedForeignImport) -processForeignDecl decl@(L _ ForeignExport{}) = - return $ Left decl -processForeignDecl (L _ ForeignImport{ +processForeignDecl decl@(L _ ForeignExport{}) + = return $ Left decl +processForeignDecl decl@(L _ ForeignImport{ fd_i_ext = NoExtField , fd_name = rfiOriginalName , fd_sig_ty = rfiSigType , fd_fi = rfiForeignImport - }) = do - rfiSuffixedName <- renameForeignImport rfiOriginalName - return $ Right ReplacedForeignImport{ - rfiOriginalName - , rfiSuffixedName - , rfiSigType - , rfiForeignImport - } + }) + | CImport _ (unLoc -> conv) _ _ _ <- rfiForeignImport + , conv == Foreign.PrimCallConv + = return $ Left decl + + | checkIsIO rfiSigType + = Right <$> aux ForeignImportIO + + | otherwise + = do mSeq <- findName nameSeq + case mSeq of + Nothing -> return $ Left decl + Just seqHash -> Right <$> aux (ForeignImportPure seqHash) + where + aux :: ForeignImportType -> Instrument ReplacedForeignImport + aux rfiImportType = do + rfiSuffixedName <- renameForeignImport rfiOriginalName + return ReplacedForeignImport{ + rfiOriginalName + , rfiSuffixedName + , rfiSigType + , rfiForeignImport + , rfiImportType + } dumpWrappers :: [(ReplacedForeignImport, (LSig GhcRn, LHsBind GhcRn))] @@ -162,16 +255,11 @@ renameForeignImport (L l n) = do mkWrapper :: ReplacedForeignImport -> Instrument (LSig GhcRn, LHsBind GhcRn) mkWrapper rfi@ReplacedForeignImport { - rfiOriginalName - , rfiSuffixedName - , rfiSigType = L _ sigType - } = do - (args, body) <- mkWrapperBody rfi - - mHasCallStack :: Maybe (LHsType GhcRn) <- - whenOption (not . optionsDisableCallStack) $ do - hasCallStack <- findName nameHasCallStack - return $ noLocValue $ HsTyVar noValue NotPromoted (noLocValue hasCallStack) + rfiOriginalName + , rfiSuffixedName + , rfiSigType = L _ sigType + } = do + (args, body) <- mkWrapperBody rfi return ( noLocValue $ @@ -181,25 +269,15 @@ mkWrapper rfi@ReplacedForeignImport { HsWC { hswc_ext = [] , hswc_body = noLocValue $ sigType { - -- Signature as the original import but with HasCallStack - sig_body = - case mHasCallStack of - Nothing -> - sig_body sigType - Just hasCallStack -> noLocValue $ - HsQualTy { - hst_xqual = noValue - , hst_ctxt = noLocValue [hasCallStack] - , hst_body = sig_body sigType - } + sig_body = sig_body sigType } } , noLocValue $ FunBind { - fun_ext = mkNameSet [unLoc rfiSuffixedName] -- TODO: what is this? + fun_ext = mkNameSet [unLoc rfiSuffixedName] , fun_id = rfiOriginalName , fun_matches = MG { - mg_ext = originGenerated + mg_ext = Generated OtherExpansion SkipPmc , mg_alts = noLocValue . map noLocValue $ [ Match { m_ext = noValue @@ -207,8 +285,9 @@ mkWrapper rfi@ReplacedForeignImport { mc_fun = rfiOriginalName , mc_fixity = Prefix , mc_strictness = NoSrcStrict + , mc_an = AnnFunRhs NoEpTok [] [] } - , m_pats = map namedVarPat args + , m_pats = noLocValue $ map namedVarPat args , m_grhss = GRHSs { grhssExt = emptyComments , grhssGRHSs = map noLocValue [ @@ -228,82 +307,92 @@ mkWrapper rfi@ReplacedForeignImport { -- | Make the body for the wrapper -- -- Also returns the arguments to the wrapper -mkWrapperBody :: - ReplacedForeignImport - -> Instrument ([Name], LHsExpr GhcRn) -mkWrapperBody rfi@ReplacedForeignImport {rfiSuffixedName, rfiSigType} = do - traceEventIO <- findName nameTraceEventIO - let callTraceEventIO :: LHsExpr GhcRn -> ExprLStmt GhcRn - callTraceEventIO arg = noLocValue $ - BodyStmt - noValue - (callNamedFn traceEventIO [arg]) - regularBodyStmt - NoSyntaxExprRn - - evaluate <- findName nameEvaluate - let callEvaluate :: LHsExpr GhcRn -> LHsExpr GhcRn - callEvaluate arg = callNamedFn evaluate [arg] - - unsafePerformIO <- findName nameUnsafePerformIO - let callUnsafePerformIO :: LHsExpr GhcRn -> LHsExpr GhcRn - callUnsafePerformIO arg = callNamedFn unsafePerformIO [arg] - - (args, resultTy) <- uniqArgsFor (sig_body $ unLoc rfiSigType) - let callUninstrumented :: LHsExpr GhcRn - callUninstrumented = callLNamedFn rfiSuffixedName (map namedVar args) - - result <- uniqInternalName "result" - eventLogCall <- mkEventLogCall rfi - eventLogReturn <- mkEventLogReturn rfi - let doBlock :: LHsExpr GhcRn - doBlock = noLocValue $ HsDo noValue (DoExpr Nothing) $ noLocValue [ - callTraceEventIO eventLogCall - , noLocValue $ - BindStmt - regularBindStmt - (namedVarPat result) - ( case checkIsIO resultTy of - Just _ -> callUninstrumented - Nothing -> callEvaluate callUninstrumented - ) - , callTraceEventIO eventLogReturn - , noLocValue $ - LastStmt - noValue - (callNamedFn returnMName [namedVar result]) - Nothing - NoSyntaxExprRn - ] - - return ( - args - , case checkIsIO resultTy of - Just _ -> doBlock - Nothing -> callUnsafePerformIO doBlock - ) +mkWrapperBody :: ReplacedForeignImport -> Instrument ([Name], LHsExpr GhcRn) +mkWrapperBody rfi = do + mTraceCCS <- findName nameTraceCCS + + -- Construct call to the original function, for fresh args + args <- uniqArgsFor (sig_body $ unLoc rfiSigType) + let callOrig :: LHsExpr GhcRn + callOrig = callLNamedFn rfiSuffixedName (map namedVar args) + + -- TODO: + -- + -- * Add capability (and thread ID?) to event + + wrapped <- + case rfiImportType of + + ForeignImportIO -> do + unwrapIO "f" callOrig $ \f -> wrapIO $ + wrap mTraceCCS f $ \s -> + -- Pass the RealWorld argument, actually running the function + return $ mkHsApp f s + + ForeignImportPure seqHash -> do + let_ "f" callOrig $ \f -> runIO $ + wrap mTraceCCS f $ \s -> return $ + -- For evaluation we use @seq#@, to guarantee ordering + callNamedFn seqHash [f, s] + + return (args, wrapped) + where + ReplacedForeignImport{ + rfiSuffixedName + , rfiSigType + , rfiImportType + } = rfi + + zero8Lit :: LHsExpr GhcRn + zero8Lit = noLocValue $ HsLit noValue $ HsWord8Prim noValue 0 + + eventLogCall, eventLogReturn :: LHsExpr GhcRn + eventLogCall = mkEventLogCall rfi + eventLogReturn = mkEventLogReturn rfi + + wrap :: + Maybe Name + -> LHsExpr GhcRn + -> (RealWorld -> Instrument (LHsExpr GhcRn)) + -> (RealWorld -> Instrument (LHsExpr GhcRn)) + wrap Nothing _ = withoutProfiling + wrap (Just traceCCS) f = withProfiling traceCCS f + + withoutProfiling :: + (RealWorld -> Instrument (LHsExpr GhcRn)) + -> (RealWorld -> Instrument (LHsExpr GhcRn)) + withoutProfiling call_f = + callTraceEvent eventLogCall $ + callIO ["result"] call_f $ \[result] -> + callTraceEvent eventLogReturn $ + returnIO result + + withProfiling :: + Name + -> LHsExpr GhcRn + -> (RealWorld -> Instrument (LHsExpr GhcRn)) + -> (RealWorld -> Instrument (LHsExpr GhcRn)) + withProfiling traceCCS f call_f = + callTraceEvent eventLogCall $ + callIO ["ccs"] (callNamedIO nameGetCurrentCCS [f]) $ \[ccs] -> + callIO ["tid"] (callNamedIO nameMyThreadId []) $ \[tid] -> + getCapability tid $ \cap -> + callTraceCCS traceCCS zero8Lit ccs cap $ + callIO ["result"] call_f $ \[result] -> + callTraceEvent eventLogReturn $ + returnIO result {------------------------------------------------------------------------------- Generate eventlog events -------------------------------------------------------------------------------} -- | Eventlog description for calling the foreign function -mkEventLogCall :: ReplacedForeignImport -> Instrument (LHsExpr GhcRn) +mkEventLogCall :: ReplacedForeignImport -> LHsExpr GhcRn mkEventLogCall ReplacedForeignImport{ rfiOriginalName , rfiForeignImport - } = do - noCallStack <- asksOption optionsDisableCallStack - - if noCallStack then - return $ stringExpr prefix - else do - callStack <- findName nameCallStack - prettyCalllStack <- findName namePrettyCallStack - return $ callNamedFn appendName [ - stringExpr (prefix ++ " at ") - , callNamedFn prettyCalllStack [namedVar callStack] - ] + } = + ubstringExpr prefix where prefix :: String prefix = concat [ @@ -325,23 +414,23 @@ mkEventLogCall ReplacedForeignImport{ showSDocUnsafe $ ppr cCallConv , showSDocUnsafe $ ppr safety , case mHeader of - Just (Header _sourceText hdr) -> unpackFS hdr ++ " " - Nothing -> "" + Just (Foreign.Header _sourceText hdr) -> unpackFS hdr ++ " " + Nothing -> "" , case cImportSpec of CLabel cLabel -> unpackFS cLabel - CFunction (StaticTarget _sourceText cLabel _ _) -> + CFunction (Foreign.StaticTarget _sourceText cLabel _ _) -> unpackFS cLabel - CFunction DynamicTarget -> + CFunction Foreign.DynamicTarget -> "" CWrapper -> "" ) -- | Eventlog description for the return of the foreign function -mkEventLogReturn :: ReplacedForeignImport -> Instrument (LHsExpr GhcRn) -mkEventLogReturn ReplacedForeignImport{rfiOriginalName} = do - return $ stringExpr $ concat [ +mkEventLogReturn :: ReplacedForeignImport -> LHsExpr GhcRn +mkEventLogReturn ReplacedForeignImport{rfiOriginalName} = + ubstringExpr $ concat [ "trace-foreign-calls: return " , occNameString . nameOccName . unLoc $ rfiOriginalName ] @@ -350,67 +439,293 @@ mkEventLogReturn ReplacedForeignImport{rfiOriginalName} = do Auxiliary -------------------------------------------------------------------------------} -trivialBindingGroup :: LHsBind GhcRn -> (RecFlag, Bag (LHsBind GhcRn)) -trivialBindingGroup binding = (NonRecursive, unitBag binding) - -uniqInternalName :: String -> Instrument Name -uniqInternalName n = do - resultUniq <- getUniqueM - return $ mkInternalName resultUniq (mkVarOcc n) noSrcSpan - -regularBodyStmt :: SyntaxExprRn -regularBodyStmt = SyntaxExprRn $ HsVar noValue (noLocValue thenMName) - -regularBindStmt :: XBindStmtRn -regularBindStmt = - XBindStmtRn { - xbsrn_bindOp = SyntaxExprRn $ HsVar noValue (noLocValue bindMName) - , xbsrn_failOp = Nothing - } +trivialBindingGroup :: LHsBind GhcRn -> (RecFlag, [LHsBind GhcRn]) +trivialBindingGroup binding = (NonRecursive, [binding]) -- | Create unique name for each argument of the function --- --- Also returns the result type. -uniqArgsFor :: LHsType GhcRn -> Instrument ([Name], LHsType GhcRn) -uniqArgsFor = go [] +uniqArgsFor :: LHsType GhcRn -> Instrument [Name] +uniqArgsFor = go [] . unLoc where - go :: - [Name] - -> LHsType GhcRn - -> Instrument ([Name], LHsType GhcRn) - go acc (L _ HsForAllTy{hst_body}) = - go acc hst_body - go acc (L _ HsQualTy{hst_body}) = - go acc hst_body - go acc (L _ (HsFunTy _ _ _lhs rhs)) = do - arg <- uniqInternalName ("arg" ++ show (length acc)) - go (arg:acc) rhs - go acc otherTy = - return (reverse acc, otherTy) - --- | Match against @IO a@ for some @a@ -checkIsIO :: LHsType GhcRn -> Maybe (LHsType GhcRn) -checkIsIO (L _ ty) = - case ty of - HsAppTy _ (L _ (HsTyVar _ _ (L _ io))) b | io == ioTyConName -> - Just b - _otherwise -> - Nothing + go :: [Name] -> HsType GhcRn -> Instrument [Name] + go acc HsForAllTy{hst_body} = go acc (unLoc hst_body) + go acc HsQualTy{hst_body} = go acc (unLoc hst_body) + go acc (HsFunTy _ _ _ rhs) = do + arg <- liftTcM $ uniqInternalName ("arg" ++ show (length acc)) + go (arg:acc) (unLoc rhs) + go acc _otherTy = + return $ reverse acc + +-- | Check if a function signature returns something in the @IO@ monad +checkIsIO :: LHsSigType GhcRn -> Bool +checkIsIO = go . unLoc . sig_body . unLoc + where + go :: HsType GhcRn -> Bool + go HsForAllTy{hst_body} = go (unLoc hst_body) + go HsQualTy{hst_body} = go (unLoc hst_body) + go (HsFunTy _ _ _ rhs) = go (unLoc rhs) + go ty = + case ty of + HsAppTy _ (L _ (HsTyVar _ _ (L _ io))) _ | io == Names.ioTyConName -> + True + _otherwise -> + False emptyWhereClause :: HsLocalBinds GhcRn emptyWhereClause = EmptyLocalBinds noValue -stringExpr :: String -> LHsExpr GhcRn -stringExpr = noLocValue . HsLit noValue . HsString NoSourceText . fsLit +ubstringExpr :: String -> LHsExpr GhcRn +ubstringExpr = noLocValue . HsLit noValue . mkHsStringPrimLit . fsLit callLNamedFn :: LIdP GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn -callLNamedFn fn args = mkHsApps (noLocValue $ HsVar noValue fn) args +callLNamedFn fn args = + mkHsApps (noLocValue $ HsVar noValue fn) $ + map mkLHsPar args -callNamedFn :: Name -> [LHsExpr GhcRn] -> LHsExpr GhcRn +callNamedFn :: IdP GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn callNamedFn = callLNamedFn . noLocValue -namedVar :: Name -> LHsExpr GhcRn -namedVar = noLocValue . HsVar noValue . noLocValue +namedLVar :: LIdP GhcRn -> LHsExpr GhcRn +namedLVar = noLocValue . HsVar noValue + +namedVar :: IdP GhcRn -> LHsExpr GhcRn +namedVar = namedLVar . noLocValue namedVarPat :: Name -> LPat GhcRn -namedVarPat = noLocValue . VarPat noValue . noLocValue \ No newline at end of file +namedVarPat = noLocValue . VarPat noValue . noLocValue + +-- | @IO ()@ +ioUnit :: LHsType GhcRn +ioUnit = + nlHsAppTy + (nlHsTyVar NotPromoted Names.ioTyConName) + (nlHsTyVar NotPromoted (tyConName unitTyCon)) + +{------------------------------------------------------------------------------- + Auxiliary: construct IO calls +-------------------------------------------------------------------------------} + +type RealWorld = LHsExpr GhcRn + +-- | Bind to value without evaluating it +-- +-- Given @e@, constructs +-- +-- > let x = e in k x +-- +-- for fresh @x@. +let_ :: m ~ Instrument + => String + -> LHsExpr GhcRn + -> (LHsExpr GhcRn -> m (LHsExpr GhcRn)) + -> m (LHsExpr GhcRn) +let_ xNameHint e k = do + x <- liftTcM $ uniqInternalName xNameHint + cont <- k (namedVar x) + let binding :: LHsBind GhcRn + binding = noLocA $ PatBind { + pat_ext = mkNameSet [x] + , pat_lhs = namedVarPat x + , pat_mult = noValue + , pat_rhs = GRHSs { + grhssExt = noValue + , grhssGRHSs = [noLocA $ GRHS noValue [] e] + , grhssLocalBinds = EmptyLocalBinds noValue + } + } + return $ noLocValue $ + HsLet noValue ( + HsValBinds noValue $ + XValBindsLR $ NValBinds [(NonRecursive, [binding])] [] + ) + $ cont + +-- | Unwrap @IO@ action +-- +-- Given @io@ and continuation @k@, constructs +-- +-- > case io of IO f -> k f +-- +-- for fresh @f@. +unwrapIO :: m ~ Instrument + => String + -> LHsExpr GhcRn + -> (LHsExpr GhcRn -> m (LHsExpr GhcRn)) + -> m (LHsExpr GhcRn) +unwrapIO fNameHint io k = do + f <- liftTcM $ uniqInternalName fNameHint + cont <- k (namedVar f) + return $ noLocValue $ + HsCase CaseAlt io + $ mkMatchGroup (Generated OtherExpansion SkipPmc) . noLocValue . pure + $ mkHsCaseAlt (noLocValue $ + ConPat + noExtField + (noLocValue Names.ioDataConName) + (PrefixCon [] [namedVarPat f]) + ) + $ cont + +-- | Wrap @IO@ action +-- +-- Given @f@, constructs +-- +-- > IO (\s -> f s) +-- +-- for fresh @s@. +wrapIO :: m ~ Instrument + => (RealWorld -> m (LHsExpr GhcRn)) + -> m (LHsExpr GhcRn) +wrapIO f = do + s <- liftTcM $ uniqInternalName "s" + body <- f (namedVar s) + return $ + mkHsApp (namedVar Names.ioDataConName) + $ mkHsLam (noLocValue [namedVarPat s]) + $ body + +-- | Similar to 'wrapIO', but in a pure context (essentially @unsafePerformIO@) +-- +-- Given @f@, constructs +-- +-- > case runRW# (\s -> f (noDuplicate# s)) of (# _, result #) -> result +-- +-- for fresh @s@ and @result@ +runIO :: m ~ Instrument + => (RealWorld -> m (LHsExpr GhcRn)) + -> m (LHsExpr GhcRn) +runIO f = do + s <- liftTcM $ uniqInternalName "s" + result <- liftTcM $ uniqInternalName "result" + runRW <- findName nameRunRW + noDup <- findName nameNoDuplicate + body <- f $ callNamedFn noDup [namedVar s] + let scrut = callNamedFn runRW [mkHsLam (noLocValue [namedVarPat s]) body] + return $ noLocValue $ + HsCase CaseAlt scrut + $ mkMatchGroup (Generated OtherExpansion SkipPmc) . noLocValue . pure + $ mkHsCaseAlt (noLocValue $ + TuplePat + noExtField + [ noLocValue (WildPat noExtField) + , namedVarPat result + ] + Unboxed + ) + $ namedVar result + +-- | Return value in (low-level) IO monad +-- +-- Constructs +-- +-- > (# s, result #) +-- +-- for given @s@ and @result@ +returnIO :: m ~ Instrument + => LHsExpr GhcRn + -> RealWorld -> m (LHsExpr GhcRn) +returnIO result s = + return $ noLocValue $ + ExplicitTuple + noExtField + [ Present noExtField s + , Present noExtField result + ] + Unboxed + +-- | Do low-level IO call +-- +-- Given a context @IO (\s -> ..)@, @callIO f k s@ generates +-- +-- > case f s of (# s', result #) -> k result s' +-- +-- for fresh @s'@ and @result@ +callIO :: m ~ Instrument + => [String] + -> ( RealWorld -> m (LHsExpr GhcRn)) + -> ([LHsExpr GhcRn] -> RealWorld -> m (LHsExpr GhcRn)) + -> ( RealWorld -> m (LHsExpr GhcRn)) +callIO resultNameHints f k s = do + s' <- liftTcM $ uniqInternalName "s'" + results <- liftTcM $ mapM uniqInternalName resultNameHints + scrut <- f s + cont <- k (map namedVar results) (namedVar s') + return $ noLocValue $ + HsCase CaseAlt scrut + $ mkMatchGroup (Generated OtherExpansion SkipPmc) . noLocValue . pure + $ mkHsCaseAlt (noLocValue $ + TuplePat + noExtField + (namedVarPat s' : map namedVarPat results) + Unboxed + ) + $ cont + +-- | Like 'callIO', but for when the result is trivial @()@ +callIO_ :: m ~ Instrument + => (RealWorld -> m (LHsExpr GhcRn)) + -> (RealWorld -> m (LHsExpr GhcRn)) + -> (RealWorld -> m (LHsExpr GhcRn)) +callIO_ f k = callIO ["_unit"] f (\[_unit] -> k) + +-- | Call @traceEvent#@ +-- +-- This function is a little unusual, as it does not return a tuple. +-- +-- > traceEvent# :: Addr# -> State# d -> State# d +callTraceEvent :: m ~ Instrument + => LHsExpr GhcRn -- ^ String for the custom eent + -> (RealWorld -> m (LHsExpr GhcRn)) + -> (RealWorld -> m (LHsExpr GhcRn)) +callTraceEvent eventString k s = do + s' <- liftTcM $ uniqInternalName "s'" + scrut <- callNamedIO nameTraceEvent [eventString] s + cont <- k (namedVar s') + return $ noLocValue $ + HsCase CaseAlt scrut + $ mkMatchGroup (Generated OtherExpansion SkipPmc) . noLocValue . pure + $ mkHsCaseAlt (namedVarPat s') + $ cont + +-- | Call @traceCCS#@ +callTraceCCS :: m ~ Instrument + => Name + -> LHsExpr GhcRn -- ^ Profile ID (Word8#) + -> LHsExpr GhcRn -- ^ Stack (Addr#) + -> LHsExpr GhcRn -- ^ Residency (Word64#) + -> (RealWorld -> m (LHsExpr GhcRn)) + -> (RealWorld -> m (LHsExpr GhcRn)) +callTraceCCS traceCCS profileId ccs residency k s = + unwrapIO "runTrace" call $ \runTrace -> + callIO_ (return . mkHsApp runTrace) k s + where + call = mkHsApps (namedVar traceCCS) [profileId, ccs, residency] + +-- | Get capability +-- +-- Returns the capability as a 'Word64#' +getCapability :: m ~ Instrument + => LHsExpr GhcRn -- ^ ThreadId# + -> (LHsExpr GhcRn -> RealWorld -> m (LHsExpr GhcRn)) + -> ( RealWorld -> m (LHsExpr GhcRn)) +getCapability tid k s = do + intToInt64 <- findName nameIntToInt64 + int64ToWord64 <- findName nameInt64ToWord64 + callIO + ["_status", "cap", "_locked"] + (callNamedIO nameThreadStatus [tid]) + (\[_status, cap, _locked] -> + k $ mkLHsPar . mkHsApp (namedVar int64ToWord64) + $ mkLHsPar . mkHsApp (namedVar intToInt64) + $ cap + ) + s + +callNamedIO :: m ~ Instrument + => (Names -> Name) + -> [LHsExpr GhcRn] + -> (RealWorld -> m (LHsExpr GhcRn)) +callNamedIO f args s = do + fName <- findName f + return $ callNamedFn fName (args ++ [s]) + + diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs index 8122c62..1782a27 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Instrument.hs @@ -5,10 +5,7 @@ module Plugin.TraceForeignCalls.Instrument ( Instrument -- opaque , runInstrument , liftTcM - -- * Options - , asksOption - , whenOption - , whenOption_ + , getOptions -- * Names , Names(..) , findName @@ -16,16 +13,20 @@ module Plugin.TraceForeignCalls.Instrument ( import Control.Monad import Control.Monad.IO.Class +import Data.Maybe (isJust) import GHC import GHC.Plugins hiding (getHscEnv) -import GHC.Tc.Types -import GHC.Utils.Logger +import GHC.Builtin.Names qualified as Names +import GHC.Platform.Ways (Way(WayProf), hasWay) +import GHC.Tc.Utils.Monad (TcM, TcGblEnv) +import GHC.Tc.Utils.Monad qualified as TC +import GHC.Unit.Env (lookupHugByModule) +import GHC.Utils.Logger (HasLogger(..)) import Plugin.TraceForeignCalls.Options import Plugin.TraceForeignCalls.Util.GHC -import Plugin.TraceForeignCalls.Util.Shim {------------------------------------------------------------------------------- Definition @@ -44,18 +45,21 @@ liftTcM = Wrap . const getTracerEnv :: Instrument TracerEnv getTracerEnv = Wrap return -runInstrument :: forall a. [String] -> Instrument a -> TcM a -runInstrument rawOptions ma = do +runInstrument :: TcGblEnv -> [String] -> Instrument a -> TcM a +runInstrument tcGblEnv rawOptions ma = do tracerEnvOptions <- parseOptions rawOptions + tracerEnvNames <- mkNames tcGblEnv let tracerEnv :: TracerEnv - tracerEnv = TracerEnv { + tracerEnv = TracerEnv{ tracerEnvOptions - , tracerEnvNames = mkNames + , tracerEnvNames } - unwrap ma tracerEnv +getOptions :: Instrument Options +getOptions = tracerEnvOptions <$> getTracerEnv + {------------------------------------------------------------------------------- Instances -------------------------------------------------------------------------------} @@ -78,23 +82,6 @@ instance HasHscEnv Instrument where getHscEnv = liftTcM getHscEnv instance HasLogger Instrument where getLogger = liftTcM getLogger instance MonadUnique Instrument where getUniqueSupplyM = liftTcM getUniqueSupplyM -{------------------------------------------------------------------------------- - Options --------------------------------------------------------------------------------} - -asksOption :: (Options -> a) -> Instrument a -asksOption f = f . tracerEnvOptions <$> getTracerEnv - -whenOption :: (Options -> Bool) -> Instrument a -> Instrument (Maybe a) -whenOption f ma = do - flag <- asksOption f - if flag - then Just <$> ma - else return Nothing - -whenOption_ :: (Options -> Bool) -> Instrument () -> Instrument () -whenOption_ f = void . whenOption f - {------------------------------------------------------------------------------- Names @@ -103,23 +90,96 @@ whenOption_ f = void . whenOption f -------------------------------------------------------------------------------} data Names = Names { - nameTraceEventIO :: TcM Name - , nameEvaluate :: TcM Name - , nameUnsafePerformIO :: TcM Name - , nameHasCallStack :: TcM Name - , nameCallStack :: TcM Name - , namePrettyCallStack :: TcM Name - } + -- | @ghc-prim:GHC.Prim.getCurrentCCS#@ + nameGetCurrentCCS :: Name + + -- | @ghc-prim:GHC.Prim.noDuplicate#@ + , nameNoDuplicate :: Name + + -- | @ghc-prim:GHC.Prim.traceEvent#@ + , nameTraceEvent :: Name + + -- | @ghc-prim:GHC.Prim.myThreadId#@ + , nameMyThreadId :: Name + + -- | @ghc-prim:GHC.Prim.threadStatus#@ + , nameThreadStatus :: Name + + -- | @ghc-prim:GHC.Prim.intToInt64#@ + , nameIntToInt64 :: Name + + -- | @ghc-prim:GHC.Prim.int64ToWord64#@ + , nameInt64ToWord64 :: Name + + -- | @ghc-prim:GHC.Magic.runRW#@ + , nameRunRW :: Name + + -- | @ghc-internal:GHC.Internal.IO.seq#@ + -- + -- NOTE: This is only available /after/ @GHC.Internal.IO@ is compiled. + -- For this reason we cannot add any tracing to pure FFI calls in + -- @GHC.Internal.IO@ (currently there aren't any). + , nameSeq :: Maybe Name -mkNames :: Names -mkNames = Names { - nameTraceEventIO = resolveVarName modlTraceEventIO "traceEventIO" - , nameEvaluate = resolveVarName modlEvaluate "evaluate" - , nameUnsafePerformIO = resolveVarName modlUnsafePerformIO "unsafePerformIO" - , nameHasCallStack = resolveTcName modlHasCallStack "HasCallStack" - , nameCallStack = resolveVarName modlCallStack "callStack" - , namePrettyCallStack = resolveVarName modlPrettyCallStack "prettyCallStack" + -- | @traceCCS#@ + -- + -- This name is a little different from the others: it does not exist + -- as a standard (foreign) import anywhere, and so we need to import it + -- ourselves. To avoid name clashes, we generate a new unique name for it. + -- + -- 'Nothing' if we are not in profiling mode + , nameTraceCCS :: Maybe Name } -findName :: (Names -> TcM Name) -> Instrument Name -findName f = Wrap $ f . tracerEnvNames +mkNames :: TcGblEnv -> TcM Names +mkNames tcGblEnv = do + nameGetCurrentCCS <- var prim "GHC.Prim" "getCurrentCCS#" + nameNoDuplicate <- var prim "GHC.Prim" "noDuplicate#" + nameTraceEvent <- var prim "GHC.Prim" "traceEvent#" + nameMyThreadId <- var prim "GHC.Prim" "myThreadId#" + nameThreadStatus <- var prim "GHC.Prim" "threadStatus#" + nameIntToInt64 <- var prim "GHC.Prim" "intToInt64#" + nameInt64ToWord64 <- var prim "GHC.Prim" "int64ToWord64#" + nameRunRW <- var prim "GHC.Magic" "runRW#" + + haveSeq <- checkHaveSeq tcGblEnv <$> TC.getTopEnv + nameSeq <- if haveSeq + then Just <$> var intr "GHC.Internal.IO" "seq#" + else return Nothing + + profiling <- checkProfiling <$> getDynFlags + nameTraceCCS <- if profiling + then Just <$> uniqInternalName "traceCCS#" + else return Nothing + + return Names { + nameGetCurrentCCS + , nameNoDuplicate + , nameRunRW + , nameTraceEvent + , nameMyThreadId + , nameThreadStatus + , nameIntToInt64 + , nameInt64ToWord64 + , nameSeq + , nameTraceCCS + } + where + var :: Unit -> String -> String -> TcM Name + var pkg modl fn = resolveVarName (mkModule pkg $ mkModuleName modl) fn + + prim, intr :: Unit + prim = primUnit + intr = ghcInternalUnit + +findName :: (Names -> a) -> Instrument a +findName f = Wrap $ return . f . tracerEnvNames + +checkHaveSeq :: TcGblEnv -> HscEnv -> Bool +checkHaveSeq tcGblEnv hsc = + if moduleUnit (TC.tcg_mod tcGblEnv) == ghcInternalUnit + then isJust $ lookupHugByModule Names.gHC_INTERNAL_IO (hsc_HUG hsc) + else True + +checkProfiling :: DynFlags -> Bool +checkProfiling df = sccProfilingEnabled df && ways df `hasWay` WayProf diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs index e812ecc..2447e03 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Options.hs @@ -21,19 +21,11 @@ import Plugin.TraceForeignCalls.Util.GHC data Options = Options { -- | Dump the generated code optionsDumpGenerated :: Bool - - -- | Disable generating HasCallStack constraints - -- - -- By default the generated wrappers have a 'HasCallStack' constraint, - -- which is used to add additional info into the eventlog. For some - -- applications however this may cause problems. - , optionsDisableCallStack :: Bool } defaultOptions :: Options defaultOptions = Options { - optionsDumpGenerated = False - , optionsDisableCallStack = False + optionsDumpGenerated = False } {------------------------------------------------------------------------------- @@ -44,10 +36,9 @@ parseOptions :: forall m. HasHscEnv m => [String] -> m Options parseOptions = ($ defaultOptions) . foldr (>=>) return . map aux where aux :: String -> Options -> m Options - aux "dump-generated" opts = return $ opts { optionsDumpGenerated = True } - aux "disable-callstack" opts = return $ opts { optionsDisableCallStack = True } - aux opt _ = throwSimpleError noSrcSpan $ hcat [ - "Unexpected option " - , fromString (show opt) - ] + aux "dump-generated" opts = return $ opts { optionsDumpGenerated = True } + aux opt _ = throwSimpleError noSrcSpan $ hcat [ + "Unexpected option " + , fromString (show opt) + ] diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs index f6e2d2f..3669af5 100644 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs +++ b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/GHC.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} module Plugin.TraceForeignCalls.Util.GHC ( -- * Access to 'HscEnv' @@ -9,6 +10,10 @@ module Plugin.TraceForeignCalls.Util.GHC ( -- * Names , resolveVarName , resolveTcName + , uniqInternalName + -- * Annotations + , NoValue(..) + , noLocValue ) where import GHC hiding (getNamePprCtx) @@ -22,6 +27,7 @@ import GHC.Rename.Env import GHC.Runtime.Context import GHC.Tc.Types import GHC.Types.Error +import GHC.Types.SourceText import GHC.Utils.Error import GHC.Utils.Logger @@ -73,16 +79,16 @@ printSimpleWarning l doc = do liftIO $ printMessages @DiagnosticMessage logger - (defaultDiagnosticOpts @DiagnosticMessage) + NoDiagnosticOpts diagOpts (singleMessage $ mkMsgEnvelope diagOpts l namePprCtx diag) where diag :: DiagnosticMessage diag = DiagnosticMessage { - diagMessage = mkSimpleDecorated doc - , diagReason = WarningWithoutFlag - , diagHints = [] - } + diagMessage = mkSimpleDecorated $ pprSetDepth AllTheWay doc + , diagReason = WarningWithoutFlag + , diagHints = [] + } {------------------------------------------------------------------------------- Names @@ -110,3 +116,50 @@ resolveTcName = resolveName mkTcOcc -- | Internal generalization resolveName :: (String -> OccName) -> Module -> String -> TcM Name resolveName f modl name = lookupOccRn $ Orig modl (f name) + +uniqInternalName :: String -> TcM Name +uniqInternalName n = do + resultUniq <- getUniqueM + return $ mkInternalName resultUniq (mkVarOcc n) noSrcSpan + +{------------------------------------------------------------------------------- + Annotations +-------------------------------------------------------------------------------} + +class NoValue a where + -- | Value that provides no additional information + noValue :: a + +noLocValue :: NoValue l => e -> GenLocated l e +noLocValue = L noValue + +instance (NoValue l, NoValue e) => NoValue (GenLocated l e) where + noValue = noLocValue noValue + +instance NoValue NoExtField where + noValue = NoExtField + +instance NoValue SrcSpan where + noValue = noSrcSpan + +instance NoValue SourceText where + noValue = NoSourceText + +instance NoValue EpAnnComments where + noValue = emptyComments + +instance NoValue (AnnSortKey tag) where + noValue = NoAnnSortKey + +instance (XNoMultAnn pass ~ ann, NoValue ann) => NoValue (HsMultAnn pass) where + noValue = HsNoMultAnn noValue + +instance NoAnn ann => NoValue (EpAnn ann) where + noValue = noAnn + +instance NoValue AnnSig where + noValue = noAnn + +instance NoValue EpaLocation where + noValue = noAnn + diff --git a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/Shim.hs b/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/Shim.hs deleted file mode 100644 index d4022ce..0000000 --- a/trace-foreign-calls/src/Plugin/TraceForeignCalls/Util/Shim.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | GHC shim --- --- All CPP should live in this module. -module Plugin.TraceForeignCalls.Util.Shim ( - -- * Constructing the AST - noValue - , noLocValue - , originGenerated - -- * Name resolution - , modlCallStack - , modlEvaluate - , modlHasCallStack - , modlPrettyCallStack - , modlTraceEventIO - , modlUnsafePerformIO - ) where - -import GHC -import GHC.Plugins - -{------------------------------------------------------------------------------- - Annotations --------------------------------------------------------------------------------} - -class NoValue a where - -- | Value that provides no additional information - noValue :: a - -noLocValue :: NoValue l => e -> GenLocated l e -noLocValue = L noValue - -instance NoValue NoExtField where - noValue = NoExtField - -instance NoValue SrcSpan where - noValue = noSrcSpan - -#if __GLASGOW_HASKELL__ < 910 - -instance NoValue a => NoValue (SrcSpanAnn' a) where - noValue = SrcSpanAnn noValue noValue - -instance NoValue (EpAnn ann) where - noValue = EpAnnNotUsed - -#else - -instance NoAnn ann => NoValue (EpAnn ann) where - noValue = noAnn - -instance NoValue AnnSig where - noValue = noAnn - -instance NoValue [AddEpAnn] where - noValue = [] - -#endif - -{------------------------------------------------------------------------------- - Origin --------------------------------------------------------------------------------} - -originGenerated :: Origin -#if __GLASGOW_HASKELL__ == 906 -originGenerated = Generated -#endif -#if __GLASGOW_HASKELL__ == 908 -originGenerated = Generated SkipPmc -#endif -#if __GLASGOW_HASKELL__ >= 910 -originGenerated = Generated OtherExpansion SkipPmc -#endif - -{------------------------------------------------------------------------------- - Defining modules for various symbols --------------------------------------------------------------------------------} - -modlTraceEventIO :: Module -modlTraceEventIO = -#if __GLASGOW_HASKELL__ < 910 - mkModule baseUnit $ mkModuleName "Debug.Trace" -#else - mkModule ghcInternalUnit $ mkModuleName "GHC.Internal.Debug.Trace" -#endif - -modlEvaluate :: Module -modlEvaluate = -#if __GLASGOW_HASKELL__ < 910 - mkModule baseUnit $ mkModuleName "GHC.IO" -#else - mkModule ghcInternalUnit $ mkModuleName "GHC.Internal.IO" -#endif - -modlUnsafePerformIO :: Module -modlUnsafePerformIO = -#if __GLASGOW_HASKELL__ < 910 - mkModule baseUnit $ mkModuleName "GHC.IO.Unsafe" -#else - mkModule ghcInternalUnit $ mkModuleName "GHC.Internal.IO.Unsafe" -#endif - -modlHasCallStack :: Module -modlHasCallStack = -#if __GLASGOW_HASKELL__ < 910 - mkModule baseUnit $ mkModuleName "GHC.Stack.Types" -#else - mkModule ghcInternalUnit $ mkModuleName "GHC.Internal.Stack.Types" -#endif - -modlCallStack :: Module -modlCallStack = -#if __GLASGOW_HASKELL__ < 910 - mkModule baseUnit $ mkModuleName "GHC.Stack" -#else - mkModule ghcInternalUnit $ mkModuleName "GHC.Internal.Stack" -#endif - -modlPrettyCallStack :: Module -modlPrettyCallStack = -#if __GLASGOW_HASKELL__ < 910 - mkModule baseUnit $ mkModuleName "GHC.Exception" -#else - mkModule ghcInternalUnit $ mkModuleName "GHC.Internal.Stack" -#endif - diff --git a/trace-foreign-calls/test/Main.hs b/trace-foreign-calls/test/Main.hs index edae19e..0dc059d 100644 --- a/trace-foreign-calls/test/Main.hs +++ b/trace-foreign-calls/test/Main.hs @@ -1,26 +1,34 @@ module Main (main) where +import Control.Concurrent.Async (concurrently) import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.Runners (NumThreads(..)) import Test.TraceForeignCalls.UsePlugin main :: IO () -main = defaultMain $ testGroup "trace-foreign-calls" [ - testCase "answerIO" $ do - answer <- answerIO - assertEqual "" 42 $ answer - , testCase "answerPure" $ do - let answer = answerPure - assertEqual "" 42 $ answer - , testCase "slowAddIO" $ do - let a = 1_000_000_000 - b = 2_000_000_000 - result <- slowAddIO a b - assertEqual "" (a + b) $ result - , testCase "slowAddPure" $ do - let a = 1_000_000_000 - b = 2_000_000_000 - let result = slowAddPure a b - assertEqual "" (a + b) $ result - ] +main = defaultMain $ localOption (NumThreads 1) $ + testGroup "trace-foreign-calls" [ + testCase "answerIO" $ do + answer <- answerIO + assertEqual "" 42 $ answer + , testCase "answerPure" $ do + let answer = answerPure + assertEqual "" 42 $ answer + , testCase "slowAddIO" $ do + let a = 1_000_000_000 + b = 2_000_000_000 + result <- slowAddIO a b + assertEqual "" (a + b) $ result + , testCase "slowAddPure" $ do + let a = 1_000_000_000 + b = 2_000_000_000 + let result = slowAddPure a b + assertEqual "" (a + b) $ result + , testCase "slowAddConcurrent" $ do + let a = 1_000_000_000 + b = 2_000_000_000 + (ab, ba) <- concurrently (slowAddIO a b) (slowAddIO b a) + assertEqual "" ab ba + ] diff --git a/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs b/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs index 9d4ac04..50b956f 100644 --- a/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs +++ b/trace-foreign-calls/test/Test/TraceForeignCalls/UsePlugin.hs @@ -2,8 +2,6 @@ {-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls -fplugin-opt Plugin.TraceForeignCalls:dump-generated #-} --- -fplugin-opt Plugin.TraceForeignCalls:disable-callstack --- {-# OPTIONS_GHC -fplugin=Plugin.TraceForeignCalls #-} module Test.TraceForeignCalls.UsePlugin ( -- * IO functions diff --git a/trace-foreign-calls/trace-foreign-calls.cabal b/trace-foreign-calls/trace-foreign-calls.cabal index 4aedee9..085c53d 100644 --- a/trace-foreign-calls/trace-foreign-calls.cabal +++ b/trace-foreign-calls/trace-foreign-calls.cabal @@ -17,9 +17,7 @@ build-type: Simple extra-doc-files: CHANGELOG.md extra-source-files: test-cbits/test_cbits.h test-cbits/test_cbits.c -tested-with: GHC ==9.6.4 - GHC ==9.8.2 - GHC ==9.10.1 +tested-with: GHC ==9.12.1 source-repository head type: git @@ -27,7 +25,8 @@ source-repository head common lang build-depends: - base >= 4.18 && < 4.21 + -- For now we don't support ghc < 9.12 + base >= 4.21 && < 4.22 default-language: GHC2021 ghc-options: @@ -46,19 +45,24 @@ library Plugin.TraceForeignCalls.Instrument Plugin.TraceForeignCalls.Options Plugin.TraceForeignCalls.Util.GHC - Plugin.TraceForeignCalls.Util.Shim hs-source-dirs: src build-depends: -- dependencies intentionally kept at a minimum -- (we want to be able to build the boot libs with this plugin) - , ghc >= 9.6 && < 9.11 + , ghc >= 9.12 && < 9.14 + , ghc-boot test-suite test-trace-foreign-calls import: lang type: exitcode-stdio-1.0 + ghc-options: + -threaded + "-with-rtsopts -l -N" + cc-options: + -O0 hs-source-dirs: test include-dirs: @@ -74,6 +78,8 @@ test-suite test-trace-foreign-calls trace-foreign-calls build-depends: -- external dependencies + , async , tasty , tasty-hunit +