From ddb152d57356cf6a2649b8598e596b5e8051ded2 Mon Sep 17 00:00:00 2001
From: Moritz Angermann <moritz.angermann@gmail.com>
Date: Sat, 13 Feb 2021 16:44:19 +0800
Subject: [PATCH] Allocate Adjustors and mark them readable in two steps
This drops allocateExec for darwin, and replaces it with
a alloc, write, mark executable strategy instead. This prevents
us from trying to allocate an executable range and then write to
it, which X^W will prohibit on darwin.
This will *only* work if we can use mmap.
---
compiler/main/Packages.hs | 6 +++---
docs/users_guide/packages.rst | 2 +-
hadrian/src/Rules/Rts.hs | 2 +-
includes/Rts.h | 6 ++++++
includes/rts/storage/GC.h | 8 +++++++-
libraries/base/base.cabal | 2 +-
libraries/ghci/GHCi/InfoTable.hsc | 18 ++++++++++++++++++
libraries/ghci/ghci.cabal.in | 1 +
rts/Adjustor.c | 2 +-
rts/Linker.c | 2 +-
rts/LinkerInternals.h | 5 +++++
rts/StgCRun.c | 4 ++--
rts/ghc.mk | 2 +-
rts/package.conf.in | 2 +-
rts/rts.cabal.in | 2 +-
rts/sm/Storage.c | 31 +++++++++++++++++++++++++++----
testsuite/tests/th/T10279.hs | 4 ++--
testsuite/tests/th/T10279.stderr | 6 +++---
utils/ghc-cabal/Main.hs | 2 +-
19 files changed, 83 insertions(+), 24 deletions(-)
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index f5a8c964b31c..66c46e9d9188 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -1862,9 +1862,9 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
-- This change elevates the need to add custom hooks
-- and handling specifically for the `rts` package for
-- example in ghc-cabal.
- addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
- addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag)
- addSuffix other_lib = other_lib ++ (expandTag tag)
+ addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
+ addSuffix rts@"HSrts-1.0.1" = rts ++ (expandTag rts_tag)
+ addSuffix other_lib = other_lib ++ (expandTag tag)
expandTag t | null t = ""
| otherwise = '_':t
diff --git a/docs/users_guide/packages.rst b/docs/users_guide/packages.rst
index 2d6253bf920e..af4d1b293aae 100644
--- a/docs/users_guide/packages.rst
+++ b/docs/users_guide/packages.rst
@@ -75,7 +75,7 @@ To see which packages are currently available, use the ``ghc-pkg list`` command:
pretty-1.0.1.0
process-1.0.1.1
random-1.0.0.1
- rts-1.0
+ rts-1.0.1
syb-0.1.0.0
template-haskell-2.4.0.0
terminfo-0.3.1
diff --git a/hadrian/src/Rules/Rts.hs b/hadrian/src/Rules/Rts.hs
index a99d0f40a616..4583f06d5169 100644
--- a/hadrian/src/Rules/Rts.hs
+++ b/hadrian/src/Rules/Rts.hs
@@ -155,7 +155,7 @@ needRtsSymLinks stage rtsWays
prefix, versionlessPrefix :: String
versionlessPrefix = "libHSrts"
-prefix = versionlessPrefix ++ "-1.0"
+prefix = versionlessPrefix ++ "-1.0.1"
-- removeRtsDummyVersion "a/libHSrts-1.0-ghc1.2.3.4.so"
-- == "a/libHSrts-ghc1.2.3.4.so"
diff --git a/includes/Rts.h b/includes/Rts.h
index 1db3ea0df82e..568a7e610824 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -29,6 +29,12 @@ extern "C" {
#include <windows.h>
#endif
+#if defined(ios_HOST_OS) || defined(darwin_HOST_OS)
+/* Inclusion of system headers usually requires _DARWIN_C_SOURCE on Mac OS X
+ * because of some specific defines like MMAP_ANON, MMAP_ANONYMOUS. */
+#define _DARWIN_C_SOURCE 1
+#endif
+
#if !defined(IN_STG_CODE)
#define IN_STG_CODE 0
#endif
diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h
index 889df9a67555..be9c13cdf4ed 100644
--- a/includes/rts/storage/GC.h
+++ b/includes/rts/storage/GC.h
@@ -199,9 +199,15 @@ typedef void* AdjustorExecutable;
AdjustorWritable allocateExec(W_ len, AdjustorExecutable *exec_addr);
void flushExec(W_ len, AdjustorExecutable exec_addr);
-#if defined(ios_HOST_OS)
+#if (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) && (defined(ios_HOST_OS) || defined(darwin_HOST_OS))
AdjustorWritable execToWritable(AdjustorExecutable exec);
#endif
+
+#if RTS_LINKER_USE_MMAP
+AdjustorWritable allocateWrite(W_ bytes);
+void markExec(W_ bytes, AdjustorWritable writ);
+void freeWrite(W_ bytes, AdjustorWritable writ);
+#endif
void freeExec (AdjustorExecutable p);
// Used by GC checks in external .cmm code:
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index f5a915d61d16..8884ae3886ba 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -95,7 +95,7 @@ Library
UnliftedFFITypes
Unsafe
- build-depends: rts == 1.0, ghc-prim >= 0.5.1.0 && < 0.7
+ build-depends: rts == 1.0.*, ghc-prim >= 0.5.1.0 && < 0.7
-- sanity-check to ensure exactly one flag is set
if !((flag(integer-gmp) && !flag(integer-simple)) || (!flag(integer-gmp) && flag(integer-simple)))
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
index e48f041b562e..bfcb13cf9336 100644
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -360,7 +360,11 @@ sizeOfEntryCode
-- Note: Must return proper pointer for use in a closure
newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())
newExecConItbl obj con_desc
+#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1)
+ = do
+#else
= alloca $ \pcode -> do
+#endif
let lcon_desc = BS.length con_desc + 1{- null terminator -}
-- SCARY
-- This size represents the number of bytes in an StgConInfoTable.
@@ -369,8 +373,13 @@ newExecConItbl obj con_desc
-- table, because on a 64-bit platform we reference this string
-- with a 32-bit offset relative to the info table, so if we
-- allocated the string separately it might be out of range.
+#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1)
+ wr_ptr <- _allocateWrite (sz + fromIntegral lcon_desc)
+ let ex_ptr = wr_ptr
+#else
wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode
ex_ptr <- peek pcode
+#endif
let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
, infoTable = obj }
pokeConItbl wr_ptr ex_ptr cinfo
@@ -379,6 +388,9 @@ newExecConItbl obj con_desc
let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
_flushExec sz ex_ptr -- Cache flush (if needed)
+#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1)
+ _markExec (sz + fromIntegral lcon_desc) ex_ptr
+#endif
#if defined(TABLES_NEXT_TO_CODE)
return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))
#else
@@ -391,6 +403,12 @@ foreign import ccall unsafe "allocateExec"
foreign import ccall unsafe "flushExec"
_flushExec :: CUInt -> Ptr a -> IO ()
+#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1)
+foreign import ccall unsafe "allocateWrite"
+ _allocateWrite :: CUInt -> IO (Ptr a)
+foreign import ccall unsafe "markExec"
+ _markExec :: CUInt -> Ptr a -> IO ()
+#endif
-- -----------------------------------------------------------------------------
-- Constants and config
diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in
index 62f8ec43a5c2..e64948054997 100644
--- a/libraries/ghci/ghci.cabal.in
+++ b/libraries/ghci/ghci.cabal.in
@@ -71,6 +71,7 @@ library
SizedSeq
Build-Depends:
+ rts,
array == 0.5.*,
base >= 4.8 && < 4.15,
binary == 0.8.*,
diff --git a/rts/Adjustor.c b/rts/Adjustor.c
index d360cfe87b11..7fc931344c95 100644
--- a/rts/Adjustor.c
+++ b/rts/Adjustor.c
@@ -99,7 +99,7 @@ freeHaskellFunctionPtr(void* ptr)
{
ffi_closure *cl;
-#if defined(ios_HOST_OS)
+#if defined(ios_HOST_OS) || defined(darwin_HOST_OS)
cl = execToWritable(ptr);
#else
cl = (ffi_closure*)ptr;
diff --git a/rts/Linker.c b/rts/Linker.c
index c0d28e65814f..f0c72c3a2d10 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1484,7 +1484,7 @@ preloadObjectFile (pathchar *path)
*
* See also the misalignment logic for darwin below.
*/
-#if defined(ios_HOST_OS)
+#if defined(darwin_HOST_OS)
image = mmapForLinker(fileSize, PROT_READ|PROT_WRITE, MAP_PRIVATE, fd, 0);
#else
image = mmapForLinker(fileSize, PROT_READ|PROT_WRITE|PROT_EXEC,
diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h
index b0fab81cb3e0..1a83771439d7 100644
--- a/rts/LinkerInternals.h
+++ b/rts/LinkerInternals.h
@@ -13,6 +13,11 @@
#include "linker/M32Alloc.h"
#if RTS_LINKER_USE_MMAP
+#if defined(ios_HOST_OS) || defined(darwin_HOST_OS)
+/* Inclusion of system headers usually requires _DARWIN_C_SOURCE on Mac OS X
+ * because of some specific defines like MMAP_ANON, MMAP_ANONYMOUS. */
+#define _DARWIN_C_SOURCE 1
+#endif
#include <sys/mman.h>
void* mmap_next(void *addr, size_t length, int prot, int flags, int fd, off_t offset);
#endif
diff --git a/rts/StgCRun.c b/rts/StgCRun.c
index 6ce50fcae8fe..1bb37a7acd55 100644
--- a/rts/StgCRun.c
+++ b/rts/StgCRun.c
@@ -899,7 +899,7 @@ StgRun(StgFunPtr f, StgRegTable *basereg) {
".globl " STG_RETURN "\n\t"
THUMB_FUNC
-#if !defined(ios_HOST_OS)
+#if !(defined(ios_HOST_OS) || defined(darwin_HOST_OS))
".type " STG_RETURN ", %%function\n"
#endif
STG_RETURN ":\n\t"
@@ -982,7 +982,7 @@ StgRun(StgFunPtr f, StgRegTable *basereg) {
"br %1\n\t"
".globl " STG_RETURN "\n\t"
-#if !defined(ios_HOST_OS)
+#if !defined(ios_HOST_OS) && !defined(darwin_HOST_OS)
".type " STG_RETURN ", %%function\n"
#endif
STG_RETURN ":\n\t"
diff --git a/rts/ghc.mk b/rts/ghc.mk
index ada9055ebdfe..a1610fc1f429 100644
--- a/rts/ghc.mk
+++ b/rts/ghc.mk
@@ -17,7 +17,7 @@
rts_dist_HC = $(GHC_STAGE1)
rts_INSTALL_INFO = rts
-rts_VERSION = 1.0
+rts_VERSION = 1.0.1
# Minimum supported Windows version.
# These numbers can be found at:
diff --git a/rts/package.conf.in b/rts/package.conf.in
index 6e1d19d58822..b00d310f0573 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -5,7 +5,7 @@
#include "MachDeps.h"
name: rts
-version: 1.0
+version: 1.0.1
id: rts
key: rts
license: BSD-3-Clause
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index 3d4ee0f914dc..276066c6bf9d 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: rts
-version: 1.0
+version: 1.0.1
license: BSD-3-Clause
maintainer: glasgow-haskell-users@haskell.org
build-type: Simple
diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index a88073d1f833..9c016b7fbb71 100644
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -30,10 +30,14 @@
#include "GC.h"
#include "Evac.h"
#include "NonMoving.h"
-#if defined(ios_HOST_OS)
+#if defined(ios_HOST_OS) || defined(darwin_HOST_OS)
#include "Hash.h"
#endif
+#if RTS_LINKER_USE_MMAP
+#include "LinkerInternals.h"
+#endif
+
#include <string.h>
#include "ffi.h"
@@ -1543,7 +1547,7 @@ StgWord calcTotalCompactW (void)
should be modified to use allocateExec instead of VirtualAlloc.
------------------------------------------------------------------------- */
-#if (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) && defined(ios_HOST_OS)
+#if (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) && (defined(ios_HOST_OS) || defined(darwin_HOST_OS))
#include <libkern/OSCacheControl.h>
#endif
@@ -1574,7 +1578,7 @@ void flushExec (W_ len, AdjustorExecutable exec_addr)
/* x86 doesn't need to do anything, so just suppress some warnings. */
(void)len;
(void)exec_addr;
-#elif (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) && defined(ios_HOST_OS)
+#elif (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) && (defined(ios_HOST_OS) || defined(darwin_HOST_OS))
/* On iOS we need to use the special 'sys_icache_invalidate' call. */
sys_icache_invalidate(exec_addr, len);
#elif defined(__clang__)
@@ -1628,7 +1632,7 @@ void freeExec (AdjustorExecutable addr)
RELEASE_SM_LOCK
}
-#elif defined(ios_HOST_OS)
+#elif defined(darwin_HOST_OS)
static HashTable* allocatedExecs;
@@ -1636,6 +1640,11 @@ AdjustorWritable allocateExec(W_ bytes, AdjustorExecutable *exec_ret)
{
AdjustorWritable writ;
ffi_closure* cl;
+ // This check is necessary as we can't use allocateExec for anything *but*
+ // ffi_closures on ios/darwin on arm. libffi does some heavy lifting to
+ // get around the X^W restrictions, and we can't just use this codepath
+ // to allocate generic executable space. For those cases we have to refer
+ // back to allocateWrite/markExec/freeWrite (see above.)
if (bytes != sizeof(ffi_closure)) {
barf("allocateExec: for ffi_closure only");
}
@@ -1753,6 +1762,20 @@ void freeExec (void *addr)
#endif /* switch(HOST_OS) */
+#if RTS_LINKER_USE_MMAP
+AdjustorWritable allocateWrite(W_ bytes) {
+ return mmapForLinker(bytes, PROT_READ | PROT_WRITE, MAP_ANONYMOUS, -1, 0);
+}
+
+void markExec(W_ bytes, AdjustorWritable writ) {
+ mmapForLinkerMarkExecutable(writ, bytes);
+}
+
+void freeWrite(W_ bytes, AdjustorWritable writ) {
+ munmap(writ, bytes);
+}
+#endif
+
#if defined(DEBUG)
// handy function for use in gdb, because Bdescr() is inlined.
diff --git a/testsuite/tests/th/T10279.hs b/testsuite/tests/th/T10279.hs
index fbc2dbbf51ee..ea0d79de290d 100644
--- a/testsuite/tests/th/T10279.hs
+++ b/testsuite/tests/th/T10279.hs
@@ -2,9 +2,9 @@ module T10279 where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
--- NB: rts-1.0 is used here because it doesn't change.
+-- NB: rts-1.0.1 is used here because it doesn't change.
-- You do need to pick the right version number, otherwise the
-- error message doesn't recognize it as a source package ID,
-- (This is OK, since it will look obviously wrong when they
-- try to find the package in their package database.)
-blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A"))))
+blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0.1") (mkModName "A"))))
diff --git a/testsuite/tests/th/T10279.stderr b/testsuite/tests/th/T10279.stderr
index 0d23a80877b2..7d2224eef133 100644
--- a/testsuite/tests/th/T10279.stderr
+++ b/testsuite/tests/th/T10279.stderr
@@ -1,8 +1,8 @@
T10279.hs:10:10: error:
• Failed to load interface for ‘A’
- no unit id matching ‘rts-1.0’ was found
+ no unit id matching ‘rts-1.0.1’ was found
(This unit ID looks like the source package ID;
the real unit ID is ‘rts’)
- • In the expression: (rts-1.0:A.Foo)
- In an equation for ‘blah’: blah = (rts-1.0:A.Foo)
+ • In the expression: (rts-1.0.1:A.Foo)
+ In an equation for ‘blah’: blah = (rts-1.0.1:A.Foo)
diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs
index b83ad63aba45..9fe1437ecb8a 100644
--- a/utils/ghc-cabal/Main.hs
+++ b/utils/ghc-cabal/Main.hs
@@ -382,7 +382,7 @@ generate directory distdir config_args
transitiveDepLibNames
| packageKeySupported comp = map fixupRtsLibName transitiveDeps
| otherwise = transitiveDeps
- fixupRtsLibName "rts-1.0" = "rts"
+ fixupRtsLibName x | "rts-" `isPrefixOf` x = "rts"
fixupRtsLibName x = x
transitiveDepNames = map (display . packageName) transitive_dep_ids
--
GitLab