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.

18 files changed, 90 insertions, 20 deletions

diff --git a/compiler/GHC/Unit/Info.hs b/compiler/GHC/Unit/Info.hs
index d95ea5b442..f88a9ea94b 100644
--- a/compiler/GHC/Unit/Info.hs
+++ b/compiler/GHC/Unit/Info.hs
@@ -248,10 +248,9 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar
         -- 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 f24275311b..837a444a74 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 a99d0f40a6..4583f06d51 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 0f96ba2eca..e7fb8561f6 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 6acfd10cea..12f0e32f0f 100644
--- a/includes/rts/storage/GC.h
+++ b/includes/rts/storage/GC.h
@@ -205,9 +205,15 @@ typedef void* AdjustorExecutable;
 
 AdjustorWritable allocateExec(W_ len, AdjustorExecutable *exec_addr);
 void flushExec(W_ len, AdjustorExecutable exec_addr);
-#if (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) && (defined(ios_HOST_OS) || defined(darwin_HOST_OS))
+#if 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 530e0503c0..8d7460e7c4 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -87,7 +87,7 @@ Library
         Unsafe
 
     build-depends:
-        rts == 1.0,
+        rts == 1.0.*,
         ghc-prim >= 0.5.1.0 && < 0.9,
         ghc-bignum >= 1.0 && < 2.0
 
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
index 2fe35ee927..fce2c653f2 100644
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -318,7 +318,11 @@ sizeOfEntryCode tables_next_to_code
 -- Note: Must return proper pointer for use in a closure
 newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
 newExecConItbl tables_next_to_code obj con_desc
+#if RTS_LINKER_USE_MMAP && MIN_VERSION_rts(1,0,1)
+   = do
+#else
    = alloca $ \pcode -> do
+#endif
         sz0 <- sizeOfEntryCode tables_next_to_code
         let lcon_desc = BS.length con_desc + 1{- null terminator -}
             -- SCARY
@@ -328,8 +332,13 @@ newExecConItbl tables_next_to_code 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 tables_next_to_code wr_ptr ex_ptr cinfo
@@ -338,6 +347,9 @@ newExecConItbl tables_next_to_code 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
         pure $ if tables_next_to_code
           then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB
           else castPtrToFunPtr ex_ptr
@@ -348,6 +360,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 ffba9d670b..e9922ab24a 100644
--- a/libraries/ghci/ghci.cabal.in
+++ b/libraries/ghci/ghci.cabal.in
@@ -70,6 +70,7 @@ library
         GHCi.TH.Binary
 
     Build-Depends:
+        rts,
         array            == 0.5.*,
         base             >= 4.8 && < 4.17,
         ghc-prim         >= 0.5.0 && < 0.9,
diff --git a/rts/Linker.c b/rts/Linker.c
index 5bc46b486d..6a294ffb8b 100644
--- a/rts/Linker.c
+++ b/rts/Linker.c
@@ -1528,7 +1528,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 444849fbac..4be364cdb8 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>
 #endif
 
diff --git a/rts/StgCRun.c b/rts/StgCRun.c
index 536ee45835..f1148139e2 100644
--- a/rts/StgCRun.c
+++ b/rts/StgCRun.c
@@ -849,7 +849,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"
diff --git a/rts/ghc.mk b/rts/ghc.mk
index 16fd42f133..73a65824ba 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 718fa1b203..f703feec06 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 a2e22acae1..6e1de4a4d5 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 dc0dd7fd01..37f32de0f5 100644
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -11,6 +11,18 @@
  *
  * ---------------------------------------------------------------------------*/
 
+#include <ghcconfig.h>
+#if RTS_LINKER_USE_MMAP
+/*
+ * On FreeBSD and Darwin, when _XOPEN_SOURCE is defined, MAP_ANONYMOUS is not
+ * exposed from <sys/mman.h>.  Include <sys/mman.h> before "PosixSource.h".
+ *
+ * Alternatively, we could drop "PosixSource.h" from this file, but for just
+ * one non-POSIX macro, that seems a needless price to pay.
+ */
+#include <sys/mman.h>
+#endif
+
 #include "PosixSource.h"
 #include "Rts.h"
 
@@ -34,6 +46,10 @@
 #include "Hash.h"
 #endif
 
+#if RTS_LINKER_USE_MMAP
+#include "LinkerInternals.h"
+#endif
+
 #include <string.h>
 
 #include "ffi.h"
@@ -1791,6 +1807,20 @@ void flushExec (W_ len, AdjustorExecutable exec_addr)
 #endif
 }
 
+#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(linux_HOST_OS) || defined(netbsd_HOST_OS)
 
 // On Linux we need to use libffi for allocating executable memory,
@@ -1820,7 +1850,7 @@ void freeExec (AdjustorExecutable addr)
     RELEASE_SM_LOCK
 }
 
-#elif (defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) && (defined(ios_HOST_OS) || defined(darwin_HOST_OS))
+#elif defined(darwin_HOST_OS)
 
 static HashTable* allocatedExecs;
 
@@ -1828,6 +1858,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");
     }
diff --git a/testsuite/tests/th/T10279.hs b/testsuite/tests/th/T10279.hs
index fbc2dbbf51..ea0d79de29 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 e71f28795b..b66e5b4fba 100644
--- a/testsuite/tests/th/T10279.stderr
+++ b/testsuite/tests/th/T10279.stderr
@@ -1,8 +1,8 @@
 
 T10279.hs:10:9: 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 78efc133f1..3e3b824a26 100644
--- a/utils/ghc-cabal/Main.hs
+++ b/utils/ghc-cabal/Main.hs
@@ -385,7 +385,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