[Git][ghc/ghc][wip/initializers] 6 commits: gitlab-ci: Bump Docker images

Ben Gamari gitlab at gitlab.haskell.org
Fri Sep 11 10:23:14 UTC 2020



Ben Gamari pushed to branch wip/initializers at Glasgow Haskell Compiler / GHC


Commits:
5aae5b32 by Ben Gamari at 2020-09-09T18:31:40-04:00
gitlab-ci: Bump Docker images

We now generate our Docker images via Dhall definitions, as described in
ghc/ci-images!52. Additionally, we are far more careful about where tools
come from, using the ALEX, HAPPY, HSCOLOR, and GHC environment variables
(set in the Dockerfiles) to find bootstrapping tools.

- - - - -
4ce9fe88 by Ben Gamari at 2020-09-09T18:31:40-04:00
hadrian: Fix leakage of GHC in PATH into build

Previously hadrian would use GHC on PATH when configuring packages (or
fail if there is no such GHC). Fix this. Unfortunately this runs into
another bug in Cabal which we workaround.

- - - - -
291a15dd by Ben Gamari at 2020-09-09T18:31:40-04:00
utils: Bump cabal-version of hp2ps and unlit

- - - - -
4798caa0 by David Himmelstrup at 2020-09-09T18:32:16-04:00
rts comment: RTS_TICKY_SYMBOLS moved from rts/Linker.c to rts/RtsSymbols.c

- - - - -
d05194e4 by Ben Gamari at 2020-09-11T06:22:56-04:00
rts: Refactor foreign export tracking

This avoids calling `libc` in the initializers which are responsible for
registering foreign exports. We believe this should avoid the corruption
observed in #18548.

See Note [Tracking foreign exports] in rts/ForeignExports.c for an
overview of the new scheme.

- - - - -
ff8d9013 by Ben Gamari at 2020-09-11T06:23:03-04:00
rts: Refactor unloading of foreign export StablePtrs

Previously we would allocate a linked list cell for each foreign export.
Now we can avoid this by taking advantage of the fact that they are
already broken into groups.

- - - - -


19 changed files:

- .gitlab-ci.yml
- .gitlab/ci.sh
- compiler/GHC/HsToCore/Foreign/Decl.hs
- hadrian/build-cabal
- hadrian/build-cabal.bat
- hadrian/src/Hadrian/Oracles/Cabal/Rules.hs
- includes/Rts.h
- + includes/rts/ForeignExports.h
- includes/stg/Ticky.h
- + rts/ForeignExports.c
- + rts/ForeignExports.h
- rts/Linker.c
- rts/LinkerInternals.h
- rts/RtsStartup.c
- rts/RtsSymbols.c
- rts/rts.cabal.in
- testsuite/tests/module/mod184.stderr
- utils/hp2ps/hp2ps.cabal
- utils/unlit/unlit.cabal


Changes:

=====================================
.gitlab-ci.yml
=====================================
@@ -2,7 +2,7 @@ variables:
   GIT_SSL_NO_VERIFY: "1"
 
   # Commit of ghc/ci-images repository from which to pull Docker images
-  DOCKER_REV: b65e1145d7c0a62c3533904a88dac14f56fb371b
+  DOCKER_REV: e1cdfaea745989faa266f09c1d6c4c981aa34dc6
 
   # Sequential version number capturing the versions of all tools fetched by
   # .gitlab/ci.sh.
@@ -119,7 +119,7 @@ lint-testsuite:
   stage: lint
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
   script:
-    - make -Ctestsuite list_broken TEST_HC=ghc
+    - make -Ctestsuite list_broken TEST_HC=$GHC
   dependencies: []
   tags:
     - lint
@@ -259,7 +259,7 @@ hadrian-ghc-in-ghci:
     - x86_64-linux
   script:
     - cabal update
-    - cd hadrian; cabal new-build --project-file=ci.project; cd ..
+    - cd hadrian; cabal new-build --with-compiler=$GHC --project-file=ci.project; cd ..
     - git clean -xdf && git submodule foreach git clean -xdf
     - .gitlab/ci.sh setup
     - if [[ -d ./cabal-cache ]]; then cp -R ./.cabal-cache ~/.cabal-cache; fi
@@ -461,66 +461,66 @@ validate-x86_64-darwin:
       - toolchain
 
 #################################
-# aarch64-linux-deb9
+# aarch64-linux-deb10
 #################################
 
-.build-aarch64-linux-deb9:
+.build-aarch64-linux-deb10:
   extends: .validate-linux
   stage: full-build
-  image: "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb9:$DOCKER_REV"
+  image: "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb10:$DOCKER_REV"
   allow_failure: true
   variables:
-    TEST_ENV: "aarch64-linux-deb9"
-    BIN_DIST_PREP_TAR_COMP: "ghc-aarch64-linux-deb9.tar.xz"
+    TEST_ENV: "aarch64-linux-deb10"
+    BIN_DIST_PREP_TAR_COMP: "ghc-aarch64-linux-deb10.tar.xz"
   cache:
-    key: linux-aarch64-deb9
+    key: linux-aarch64-deb10
   tags:
     - aarch64-linux
 
-validate-aarch64-linux-deb9:
-  extends: .build-aarch64-linux-deb9
+validate-aarch64-linux-deb10:
+  extends: .build-aarch64-linux-deb10
   artifacts:
     when: always
     expire_in: 2 week
 
-nightly-aarch64-linux-deb9:
+nightly-aarch64-linux-deb10:
   <<: *nightly
-  extends: .build-aarch64-linux-deb9
+  extends: .build-aarch64-linux-deb10
   variables:
     TEST_TYPE: slowtest
 
 #################################
-# armv7-linux-deb9
+# armv7-linux-deb10
 #################################
 
-.build-armv7-linux-deb9:
+.build-armv7-linux-deb10:
   extends: .validate-linux
   stage: full-build
-  image: "registry.gitlab.haskell.org/ghc/ci-images/armv7-linux-deb9:$DOCKER_REV"
+  image: "registry.gitlab.haskell.org/ghc/ci-images/armv7-linux-deb10:$DOCKER_REV"
   # Due to linker issues
   allow_failure: true
   variables:
-    TEST_ENV: "armv7-linux-deb9"
-    BIN_DIST_PREP_TAR_COMP: "ghc-armv7-linux-deb9.tar.xz"
+    TEST_ENV: "armv7-linux-deb10"
+    BIN_DIST_PREP_TAR_COMP: "ghc-armv7-linux-deb10.tar.xz"
     CONFIGURE_ARGS: "--host=armv7-linux-gnueabihf --build=armv7-linux-gnueabihf --target=armv7-linux-gnueabihf"
     # N.B. We disable ld.lld explicitly here because it appears to fail
     # non-deterministically on ARMv7. See #18280.
     LD: "ld.gold"
     GccUseLdOpt: "-fuse-ld=gold"
   cache:
-    key: linux-armv7-deb9
+    key: linux-armv7-deb10
   tags:
     - armv7-linux
 
-validate-armv7-linux-deb9:
-  extends: .build-armv7-linux-deb9
+validate-armv7-linux-deb10:
+  extends: .build-armv7-linux-deb10
   artifacts:
     when: always
     expire_in: 2 week
 
-nightly-armv7-linux-deb9:
+nightly-armv7-linux-deb10:
   <<: *nightly
-  extends: .build-armv7-linux-deb9
+  extends: .build-armv7-linux-deb10
   variables:
     TEST_TYPE: slowtest
 
@@ -734,7 +734,7 @@ release-x86_64-linux-deb8:
 .build-x86_64-linux-alpine-hadrian:
   extends: .validate-linux-hadrian
   stage: full-build
-  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine:$DOCKER_REV"
+  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-alpine3_12:$DOCKER_REV"
   # There are currently a few failing tests
   allow_failure: true
   variables:
@@ -1082,8 +1082,8 @@ perf-nofib:
       make install
       popd
       rm -Rf tmp
-    - export BOOT_HC=$(which ghc)
-    - cabal update; cabal install -w $BOOT_HC regex-compat
+    - export BOOT_HC=$GHC
+    - cabal update; cabal install -w "$BOOT_HC" --lib regex-compat
     - export PATH=$root/bin:$PATH
     - make -C nofib boot mode=fast -j$CPUS
     - "make -C nofib EXTRA_RUNTEST_OPTS='-cachegrind +RTS -V0 -RTS' NoFibRuns=1 mode=fast -j$CPUS 2>&1 | tee nofib.log"


=====================================
.gitlab/ci.sh
=====================================
@@ -152,22 +152,26 @@ function show_tool() {
 function set_toolchain_paths() {
   needs_toolchain=1
   case "$(uname)" in
-    Linux) needs_toolchain="" ;;
+    Linux) needs_toolchain="0" ;;
     *) ;;
   esac
 
-  if [[ -n "$needs_toolchain" ]]; then
+  if [[ "$needs_toolchain" = 1 ]]; then
       # These are populated by setup_toolchain
       GHC="$toolchain/bin/ghc$exe"
       CABAL="$toolchain/bin/cabal$exe"
       HAPPY="$toolchain/bin/happy$exe"
       ALEX="$toolchain/bin/alex$exe"
   else
-      GHC="$(which ghc)"
-      CABAL="/usr/local/bin/cabal"
-      HAPPY="$HOME/.cabal/bin/happy"
-      ALEX="$HOME/.cabal/bin/alex"
+      # These are generally set by the Docker image but
+      # we provide these handy fallbacks in case the
+      # script isn't run from within a GHC CI docker image.
+      if [ -z "$GHC" ]; then GHC="$(which ghc)"; fi
+      if [ -z "$CABAL" ]; then GHC="$(which cabal)"; fi
+      if [ -z "$HAPPY" ]; then GHC="$(which happy)"; fi
+      if [ -z "$ALEX" ]; then GHC="$(which alex)"; fi
   fi
+
   export GHC
   export CABAL
   export HAPPY
@@ -204,12 +208,12 @@ function setup() {
 }
 
 function fetch_ghc() {
-  local v="$GHC_VERSION"
-  if [[ -z "$v" ]]; then
-      fail "GHC_VERSION is not set"
-  fi
-
   if [ ! -e "$GHC" ]; then
+      local v="$GHC_VERSION"
+      if [[ -z "$v" ]]; then
+          fail "neither GHC nor GHC_VERSION are not set"
+      fi
+
       start_section "fetch GHC"
       url="https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-${boot_triple}.tar.xz"
       info "Fetching GHC binary distribution from $url..."
@@ -233,12 +237,12 @@ function fetch_ghc() {
 }
 
 function fetch_cabal() {
-  local v="$CABAL_INSTALL_VERSION"
-  if [[ -z "$v" ]]; then
-      fail "CABAL_INSTALL_VERSION is not set"
-  fi
-
   if [ ! -e "$CABAL" ]; then
+      local v="$CABAL_INSTALL_VERSION"
+      if [[ -z "$v" ]]; then
+          fail "neither CABAL nor CABAL_INSTALL_VERSION are not set"
+      fi
+
       start_section "fetch GHC"
       case "$(uname)" in
         # N.B. Windows uses zip whereas all others use .tar.xz
@@ -279,7 +283,11 @@ function fetch_cabal() {
 function setup_toolchain() {
   fetch_ghc
   fetch_cabal
-  cabal_install="$CABAL v2-install --index-state=$hackage_index_state --installdir=$toolchain/bin"
+
+  cabal_install="$CABAL v2-install \
+    --with-compiler=$GHC \
+    --index-state=$hackage_index_state --installdir=$toolchain/bin"
+
   # Avoid symlinks on Windows
   case "$(uname)" in
     MSYS_*|MINGW*) cabal_install="$cabal_install --install-method=copy" ;;


=====================================
compiler/GHC/HsToCore/Foreign/Decl.hs
=====================================
@@ -91,15 +91,16 @@ dsForeigns' :: [LForeignDecl GhcTc]
 dsForeigns' []
   = return (NoStubs, nilOL)
 dsForeigns' fos = do
+    mod <- getModule
     fives <- mapM do_ldecl fos
     let
         (hs, cs, idss, bindss) = unzip4 fives
         fe_ids = concat idss
-        fe_init_code = map foreignExportInitialiser fe_ids
+        fe_init_code = foreignExportsInitialiser mod fe_ids
     --
     return (ForeignStubs
              (vcat hs)
-             (vcat cs $$ vcat fe_init_code),
+             (vcat cs $$ fe_init_code),
             foldr (appOL . toOL) nilOL bindss)
   where
    do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
@@ -700,8 +701,8 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
      ]
 
 
-foreignExportInitialiser :: Id -> SDoc
-foreignExportInitialiser hs_fn =
+foreignExportsInitialiser :: Module -> [Id] -> SDoc
+foreignExportsInitialiser mod hs_fns =
    -- Initialise foreign exports by registering a stable pointer from an
    -- __attribute__((constructor)) function.
    -- The alternative is to do this from stginit functions generated in
@@ -710,14 +711,24 @@ foreignExportInitialiser hs_fn =
    -- all modules that are imported directly or indirectly are actually used by
    -- the program.
    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
+   --
+   -- See Note [Tracking foreign exports] in rts/ForeignExports.c
    vcat
-    [ text "static void stginit_export_" <> ppr hs_fn
-         <> text "() __attribute__((constructor));"
-    , text "static void stginit_export_" <> ppr hs_fn <> text "()"
-    , braces (text "foreignExportStablePtr"
-       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
-       <> semi)
+    [ text "static struct ForeignExportsList" <+> list_symbol <+> equals
+         <+> braces (text ".exports = " <+> export_list) <> semi
+    , text "static void " <> ctor_symbol <> text "(void)"
+         <+> text " __attribute__((constructor));"
+    , text "static void " <> ctor_symbol <> text "()"
+    , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi)
     ]
+  where
+    mod_str = moduleStableString mod
+    ctor_symbol = text "stginit_export_" <> ppr mod_str
+    list_symbol = text "stg_exports_" <> text mod_str
+    export_list = braces $ pprWithCommas closure_ptr hs_fns
+
+    closure_ptr :: Id -> SDoc
+    closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"
 
 
 mkHObj :: Type -> SDoc


=====================================
hadrian/build-cabal
=====================================
@@ -1,8 +1,9 @@
 #!/usr/bin/env bash
 
-CABAL=cabal
-CABFLAGS=("--disable-documentation" "--disable-profiling" "--disable-library-profiling" $CABFLAGS)
-( ${GHC:-ghc} --info | grep -s '("Support SMP","YES")' > /dev/null ) || CABFLAGS+=("--constraint=hadrian -threaded")
+CABAL="${CABAL:-cabal}"
+GHC="${GHC:-ghc}"
+CABFLAGS=("--with-compiler=$GHC" "--disable-documentation" "--disable-profiling" "--disable-library-profiling" $CABFLAGS)
+( $GHC --info | grep -s '("Support SMP","YES")' > /dev/null ) || CABFLAGS+=("--constraint=hadrian -threaded")
 
 # It is currently more robust to pass Cabal an absolute path to the project file.
 PROJ="$PWD/hadrian/cabal.project"


=====================================
hadrian/build-cabal.bat
=====================================
@@ -4,8 +4,12 @@ if "%CABAL%"=="" (
     set CABAL=cabal
 )
 
+if "%GHC%"=="" (
+    set GHC=ghc
+)
+
 if "%CABFLAGS%"=="" (
-    set CABFLAGS=--disable-documentation --disable-profiling --disable-library-profiling
+    set CABFLAGS=--with-compiler=%GHC% --disable-documentation --disable-profiling --disable-library-profiling
 )
 
 rem It is currently more robust to pass Cabal an absolute path to the project file.


=====================================
hadrian/src/Hadrian/Oracles/Cabal/Rules.hs
=====================================
@@ -15,6 +15,7 @@ import Control.Monad
 import Data.Maybe
 import Development.Shake
 import Distribution.Simple.GHC
+import Distribution.Simple.Program.Builtin
 import Distribution.Simple.Program.Db
 import Distribution.Verbosity
 
@@ -58,8 +59,13 @@ cabalOracle = do
                ++ quote (pkgName pkg) ++ " (" ++ show stage ++ ")..."
         -- Configure the package with the GHC corresponding to the given stage
         hcPath <- builderPath (Ghc CompileHs stage)
+        let progDb = userSpecifyPath "ghc" hcPath
+                     $ addKnownProgram ghcProgram emptyProgramDb
         (compiler, maybePlatform, _pkgdb) <- liftIO $
-            configure silent (Just hcPath) Nothing emptyProgramDb
+            -- N.B. the hcPath parameter of `configure` is broken when given an
+            -- empty ProgramDb. To work around this we manually construct an
+            -- appropriate ProgramDb.
+            configure silent Nothing Nothing progDb
         let platform = fromMaybe (error msg) maybePlatform
             msg      = "PackageConfiguration oracle: cannot detect platform"
         return $ PackageConfiguration (compiler, platform)


=====================================
includes/Rts.h
=====================================
@@ -212,6 +212,9 @@ void _assertFail(const char *filename, unsigned int linenum)
 #include "rts/storage/GC.h"
 #include "rts/NonMoving.h"
 
+/* Foreign exports */
+#include "rts/ForeignExports.h"
+
 /* Other RTS external APIs */
 #include "rts/Parallel.h"
 #include "rts/Signals.h"


=====================================
includes/rts/ForeignExports.h
=====================================
@@ -0,0 +1,38 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1995-2009
+ *
+ * Interface to the RTS's foreign export tracking code.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+struct _ObjectCode;
+
+/* N.B. See Note [Tracking foreign exports] in
+ * rts/ForeignExports.c. */
+struct ForeignExportsList {
+      /* a link field for linking these together into lists.
+       */
+    struct ForeignExportsList *next;
+      /* the length of ->exports */
+    int n_entries;
+      /* if the RTS linker loaded the module,
+       * to which ObjectCode these exports belong. */
+    struct _ObjectCode *oc;
+      /* if the RTS linker loaded the module,
+       * this points to an array of length ->n_entries
+       * recording the StablePtr for each export. */
+    StgStablePtr **stable_ptrs;
+      /* the exported closures. of length ->exports. */
+    StgPtr exports[];
+};
+
+void registerForeignExports(struct ForeignExportsList *exports);
+


=====================================
includes/stg/Ticky.h
=====================================
@@ -19,7 +19,7 @@
 
 /* Here are all the counter declarations: */
 /* If you change this list, make the corresponding change
-   in RTS_TICKY_SYMBOLS in rts/Linker.c  */
+   in RTS_TICKY_SYMBOLS in rts/RtsSymbols.c  */
 
 /* These two are explicitly declared in rts/Ticky.c, and
    hence should not be extern'd except when using this header


=====================================
rts/ForeignExports.c
=====================================
@@ -0,0 +1,130 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020
+ *
+ * Management of foreign exports.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "ForeignExports.h"
+
+/* protected by linker_mutex after start-up */
+static struct ForeignExportsList *pending = NULL;
+static ObjectCode *loading_obj = NULL;
+
+/*
+ * Note [Tracking foreign exports]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ *
+ * Foreign exports are garbage collection roots. That is, things (e.g. CAFs)
+ * depended upon by a module's `foreign export`s need to be kept alive for as
+ * long an module is loaded. To ensure this we create a stable pointer to each
+ * `foreign export`'d closure. This works as follows:
+ *
+ * 1. The compiler  (namely GHC.HsToCore.Foreign.Decl.foreignExports)
+ *    inserts a C-stub into each module containing a `foreign export`. This
+ *    stub contains two things:
+ *
+ *    - A `ForeignExportsList` listing all of the exported closures, and
+ *
+ *    - An initializer which calls `registerForeignExports` with a reference to
+ *      the `ForeignExportsList`.
+ *
+ * 2. When the module's object code is loaded, its initializer is called by the
+ *    linker (this might be the system's dynamic linker or GHC's own static
+ *    linker). `registerForeignExports` then places the module's
+ *    `ForeignExportsList` on `pending` list.
+ *
+ * 3. When loading has finished (e.g. during RTS initialization or at the end
+ *    of `Linker.c:ocTryLoad`) `processForeignExports` is called. Here we
+ *    traverse the `pending` list and create a `StablePtr` for each export
+ *    therein.
+ *
+ * The reason for this two-step process is that we are very restricted in what
+ * we can do in an initializer function. For instance, we cannot necessarily
+ * call `malloc`  since the `libc`'s own initializer may not have run yet.
+ * For instance, doing exactly this resulted in #18548.
+ *
+ * Another consideration here is that the linker needs to know which
+ * `StablePtr`s belong to each `ObjectCode` so it can free them when the module is
+ * unloaded.  For this reason, the linker informs us when it is loading an
+ * object by calling `foreignExportsLoadingObject` and
+ * `foreignExportsFinishedLoadingObject`. We take note of the `ObjectCode*` we
+ * are loading in `loading_obj` such that we can associate the `ForeignExportsList` with
+ * the `ObjectCode` in `processForeignExports`. We then record each of the
+ * StablePtrs we create in the ->stable_ptrs array of ForeignExportsList so
+ * they can be enumerated during unloading.
+ *
+ */
+
+void registerForeignExports(struct ForeignExportsList *exports)
+{
+    ASSERT(exports->next == NULL);
+    ASSERT(exports->oc == NULL);
+    exports->next = pending;
+    exports->oc = loading_obj;
+    pending = exports;
+}
+
+/* -----------------------------------------------------------------------------
+   Create a StablePtr for a foreign export.  This is normally called by
+   a C function with __attribute__((constructor)), which is generated
+   by GHC and linked into the module.
+
+   If the object code is being loaded dynamically, then we remember
+   which StablePtrs were allocated by the constructors and free them
+   again in unloadObj().
+   -------------------------------------------------------------------------- */
+
+void foreignExportsLoadingObject(ObjectCode *oc)
+{
+    ASSERT(loading_obj == NULL);
+    loading_obj = oc;
+}
+
+void foreignExportsFinishedLoadingObject()
+{
+    ASSERT(loading_obj != NULL);
+    loading_obj = NULL;
+    processForeignExports();
+}
+
+/* Caller must own linker_mutex so that we can safely modify
+ * oc->stable_ptrs. */
+void processForeignExports()
+{
+    while (pending) {
+        ForeignExportsList *cur = pending;
+        pending = cur->next;
+
+        /* sanity check */
+        ASSERT(cur->stable_ptrs == NULL);
+
+        /* N.B. We only need to populate the ->stable_ptrs
+         * array if the object might later be unloaded.
+         */
+        if (cur->oc != NULL) {
+            cur->stable_ptrs =
+              stgMallocBytes(sizeof(StgStablePtr*) * cur->n_entries,
+                             "foreignExportStablePtr");
+
+            for (int i=0; i < cur->n_entries; i++) {
+                StgStablePtr *sptr = getStablePtr(cur->exports[i]);
+
+                if (cur->oc != NULL) {
+                    cur->stable_ptrs[i] = sptr;
+                }
+            }
+            cur->next = cur->oc->stable_ptrs;
+            cur->oc->stable_ptrs = cur;
+        } else {
+            /* can't be unloaded, don't bother populating
+             * ->stable_ptrs array. */
+            for (int i=0; i < cur->n_entries; i++) {
+                getStablePtr(cur->exports[i]);
+            }
+        }
+    }
+}


=====================================
rts/ForeignExports.h
=====================================
@@ -0,0 +1,20 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2020
+ *
+ * Management of foreign exports.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "BeginPrivate.h"
+#include "Rts.h"
+#include "LinkerInternals.h"
+
+void foreignExportsLoadingObject(ObjectCode *oc);
+void foreignExportsFinishedLoadingObject(void);
+void processForeignExports(void);
+
+#include "EndPrivate.h"
+


=====================================
rts/Linker.c
=====================================
@@ -26,6 +26,7 @@
 #include "RtsSymbols.h"
 #include "RtsSymbolInfo.h"
 #include "Profiling.h"
+#include "ForeignExports.h"
 #include "sm/OSMem.h"
 #include "linker/M32Alloc.h"
 #include "linker/CacheFlush.h"
@@ -968,37 +969,6 @@ SymbolAddr* lookupSymbol( SymbolName* lbl )
     return r;
 }
 
-/* -----------------------------------------------------------------------------
-   Create a StablePtr for a foreign export.  This is normally called by
-   a C function with __attribute__((constructor)), which is generated
-   by GHC and linked into the module.
-
-   If the object code is being loaded dynamically, then we remember
-   which StablePtrs were allocated by the constructors and free them
-   again in unloadObj().
-   -------------------------------------------------------------------------- */
-
-static ObjectCode *loading_obj = NULL;
-
-StgStablePtr foreignExportStablePtr (StgPtr p)
-{
-    ForeignExportStablePtr *fe_sptr;
-    StgStablePtr *sptr;
-
-    sptr = getStablePtr(p);
-
-    if (loading_obj != NULL) {
-        fe_sptr = stgMallocBytes(sizeof(ForeignExportStablePtr),
-                                 "foreignExportStablePtr");
-        fe_sptr->stable_ptr = sptr;
-        fe_sptr->next = loading_obj->stable_ptrs;
-        loading_obj->stable_ptrs = fe_sptr;
-    }
-
-    return sptr;
-}
-
-
 /* -----------------------------------------------------------------------------
  * Debugging aid: look in GHCi's object symbol tables for symbols
  * within DELTA bytes of the specified address, and show their names.
@@ -1269,12 +1239,16 @@ static void freeOcStablePtrs (ObjectCode *oc)
 {
     // Release any StablePtrs that were created when this
     // object module was initialized.
-    ForeignExportStablePtr *fe_ptr, *next;
+    ForeignExportsList *exports, *next;
 
-    for (fe_ptr = oc->stable_ptrs; fe_ptr != NULL; fe_ptr = next) {
-        next = fe_ptr->next;
-        freeStablePtr(fe_ptr->stable_ptr);
-        stgFree(fe_ptr);
+    for (exports = oc->foreign_exports; exports != NULL; exports = next) {
+        next = exports->next;
+        for (int i = 0; i < exports->n_entries) {
+            freeStablePtr(exports->stable_ptrs[i]);
+        }
+        stgFree(exports->stable_ptrs);
+        exports->stable_ptrs = NULL;
+        exports->next = NULL;
     }
     oc->stable_ptrs = NULL;
 }
@@ -1793,7 +1767,8 @@ int ocTryLoad (ObjectCode* oc) {
 
     IF_DEBUG(linker, debugBelch("ocTryLoad: ocRunInit start\n"));
 
-    loading_obj = oc; // tells foreignExportStablePtr what to do
+    // See Note [Tracking foreign exports] in ForeignExports.c
+    foreignExportsLoadingObject(oc);
 #if defined(OBJFORMAT_ELF)
     r = ocRunInit_ELF ( oc );
 #elif defined(OBJFORMAT_PEi386)
@@ -1803,7 +1778,7 @@ int ocTryLoad (ObjectCode* oc) {
 #else
     barf("ocTryLoad: initializers not implemented on this platform");
 #endif
-    loading_obj = NULL;
+    foreignExportsFinishedLoadingObject();
 
     if (!r) { return r; }
 


=====================================
rts/LinkerInternals.h
=====================================
@@ -135,17 +135,6 @@ typedef struct _Segment {
     int n_sections;
 } Segment;
 
-/*
- * We must keep track of the StablePtrs that are created for foreign
- * exports by constructor functions when the module is loaded, so that
- * we can free them again when the module is unloaded.  If we don't do
- * this, then the StablePtr will keep the module alive indefinitely.
- */
-typedef struct ForeignExportStablePtr_ {
-    StgStablePtr stable_ptr;
-    struct ForeignExportStablePtr_ *next;
-} ForeignExportStablePtr;
-
 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
 #define NEED_SYMBOL_EXTRAS 1
 #endif
@@ -240,7 +229,8 @@ typedef struct _ObjectCode {
     char* bssBegin;
     char* bssEnd;
 
-    ForeignExportStablePtr *stable_ptrs;
+    /* a list of all ForeignExportsLists owned by this object */
+    ForeignExportsList *foreign_exports;
 
     /* Holds the list of symbols in the .o file which
        require extra information.*/


=====================================
rts/RtsStartup.c
=====================================
@@ -20,6 +20,7 @@
 #include "STM.h"        /* initSTM */
 #include "RtsSignals.h"
 #include "Weak.h"
+#include "ForeignExports.h"     /* processForeignExports */
 #include "Ticky.h"
 #include "StgRun.h"
 #include "Prelude.h"            /* fixupRTStoPreludeRefs */
@@ -339,7 +340,13 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     getStablePtr((StgPtr)processRemoteCompletion_closure);
 #endif
 
-    // Initialize the top-level handler system
+    /*
+     * process any foreign exports which were registered while loading the
+     * image
+     * */
+    processForeignExports();
+
+    /* initialize the top-level handler system */
     initTopHandler();
 
     /* initialise the shared Typeable store */


=====================================
rts/RtsSymbols.c
=====================================
@@ -652,7 +652,7 @@
       SymI_HasProto(freeFullProgArgv)                                   \
       SymI_HasProto(getProcessElapsedTime)                              \
       SymI_HasProto(getStablePtr)                                       \
-      SymI_HasProto(foreignExportStablePtr)                             \
+      SymI_HasProto(registerForeignExports)                             \
       SymI_HasProto(hs_init)                                            \
       SymI_HasProto(hs_init_with_rtsopts)                               \
       SymI_HasProto(hs_init_ghc)                                        \


=====================================
rts/rts.cabal.in
=====================================
@@ -140,6 +140,7 @@ library
                       rts/EventLogWriter.h
                       rts/FileLock.h
                       rts/Flags.h
+                      rts/ForeignExports.h
                       rts/GetTime.h
                       rts/Globals.h
                       rts/Hpc.h
@@ -412,6 +413,7 @@ library
                ClosureFlags.c
                Disassembler.c
                FileLock.c
+               ForeignExports.c
                Globals.c
                Hash.c
                Heap.c


=====================================
testsuite/tests/module/mod184.stderr
=====================================
@@ -1,3 +1,4 @@
+
 mod184.hs:6:8: warning: [-Wprepositive-qualified-module]
     Found ‘qualified’ in prepositive position
     Suggested fix: place  ‘qualified’ after the module name instead.


=====================================
utils/hp2ps/hp2ps.cabal
=====================================
@@ -1,4 +1,4 @@
-cabal-version: 2.1
+cabal-version: 2.4
 Name: hp2ps
 Version: 0.1
 Copyright: XXX


=====================================
utils/unlit/unlit.cabal
=====================================
@@ -1,4 +1,4 @@
-cabal-version: 2.1
+cabal-version: 2.4
 Name: unlit
 Version: 0.1
 Copyright: XXX



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d2d0faba923909d2dc18342c310807e571ff5bf3...ff8d901367e11d66455a87ad16c50700ff408ce2

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d2d0faba923909d2dc18342c310807e571ff5bf3...ff8d901367e11d66455a87ad16c50700ff408ce2
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200911/9e9cac31/attachment-0001.html>


More information about the ghc-commits mailing list