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.

19 files changed, 83 insertions, 24 deletions

diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index f5a8c964b3..66c46e9d91 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 2d6253bf92..af4d1b293a 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 1db3ea0df8..568a7e6108 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 889df9a675..be9c13cdf4 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 f5a915d61d..8884ae3886 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 e48f041b56..bfcb13cf93 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 62f8ec43a5..e649480549 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 d360cfe87b..7fc931344c 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 c0d28e6581..f0c72c3a2d 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 b0fab81cb3..1a83771439 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 6ce50fcae8..1bb37a7acd 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 ada9055ebd..a1610fc1f4 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 6e1d19d588..b00d310f05 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 3d4ee0f914..276066c6bf 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 a88073d1f8..9c016b7fbb 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 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 0d23a80877..7d2224eef1 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 b83ad63aba..9fe1437ecb 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