Disable the SRT offset optimisation on MachO platforms

Unfortunately, this optimisation is infeasible on MachO platforms (e.g.
Darwin) due to an object format limitation. Specifically, linking fails
with errors of the form:

     error: unsupported relocation with subtraction expression, symbol
     '_integerzmgmp_GHCziIntegerziType_quotInteger_closure' can not be
     undefined in a subtraction expression

Apparently MachO does not permit relocations' subtraction expressions to
refer to undefined symbols. As far as I can tell this means that it is
essentially impossible to express an offset between symbols living in
different compilation units. This means that we lively can't use this
optimisation on MachO platforms.

Test Plan: Validate on Darwin

Reviewers: simonmar, erikd

Subscribers: rwbarton, thomie, carter, angerman

GHC Trac Issues: #15169

Differential Revision: https://phabricator.haskell.org/D4715

3 files changed, 40 insertions, 5 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 3dfd7a7d1d..8f614ab34f 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -94,10 +94,12 @@ module CLabel (
 
         mkHpcTicksLabel,
 
+        -- * Predicates
         hasCAF,
         needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
         isMathFun,
         isCFunctionLabel, isGcPtrLabel, labelDynamic,
+        isLocalCLabel,
 
         -- * Conversions
         toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
@@ -975,13 +977,29 @@ idInfoLabelType info =
 
 
 -- -----------------------------------------------------------------------------
--- Does a CLabel need dynamic linkage?
 
+-- | Is a 'CLabel' defined in the current module being compiled?
+--
+-- Sometimes we can optimise references within a compilation unit in ways that
+-- we couldn't for inter-module references. This provides a conservative
+-- estimate of whether a 'CLabel' lives in the current module.
+isLocalCLabel :: Module -> CLabel -> Bool
+isLocalCLabel this_mod lbl =
+  case lbl of
+    IdLabel name _ _
+      | isInternalName name -> True
+      | otherwise           -> nameModule name == this_mod
+    LocalBlockLabel _       -> True
+    _                       -> False
+
+-- -----------------------------------------------------------------------------
+
+-- | Does a 'CLabel' need dynamic linkage?
+--
 -- When referring to data in code, we need to know whether
 -- that data resides in a DLL or not. [Win32 only.]
 -- @labelDynamic@ returns @True@ if the label is located
 -- in a DLL, be it a data reference or not.
-
 labelDynamic :: DynFlags -> Module -> CLabel -> Bool
 labelDynamic dflags this_mod lbl =
   case lbl of
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index ecbe89d8f0..3d13fc7873 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -16,6 +16,7 @@ import Hoopl.Label
 import Hoopl.Collections
 import Hoopl.Dataflow
 import Module
+import Platform
 import Digraph
 import CLabel
 import PprCmmDecl ()
@@ -120,7 +121,7 @@ offset to the SRT can be stored in 32 bits (all code lives within a
 the info table by storing the srt_offset in the srt field, which is
 half a word.
 
-On x86_64 with TABLES_NEXT_TO_CODE:
+On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
 
 - info->srt is zero if there's no SRT, otherwise:
 - info->srt is an offset from the info pointer to the SRT object
@@ -636,14 +637,27 @@ oneSRT dflags staticFuns blockids lbls isCAF cafs = do
         let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
         put (Map.union newSRTMap srtMap)
 
+    this_mod = thisModule topSRT
+
   case Set.toList filtered of
     [] -> do
       srtTrace "oneSRT: empty" (ppr lbls) $ return ()
       updateSRTMap Nothing
       return ([], [], [])
 
+    -- When we have only one entry there is no need to build a new SRT at all.
     [one@(SRTEntry lbl)]
-      | not (labelDynamic dflags (thisModule topSRT) lbl) -> do
+      | -- Info tables refer to SRTs by offset (as noted in the section
+        -- "Referring to an SRT from the info table" of Note [SRTs]). However,
+        -- when dynamic linking is used we cannot guarantee that the offset
+        -- between the SRT and the info table will fit in the offset field.
+        -- Consequently we build a singleton SRT in in this case.
+        not (labelDynamic dflags this_mod lbl)
+
+        -- MachO relocations can't express offsets between compilation units at
+        -- all, so we are always forced to build a singleton SRT in this case.
+          && (not (osMachOTarget $ platformOS $ targetPlatform dflags)
+             || isLocalCLabel this_mod lbl) -> do
         updateSRTMap (Just one)
         return ([], map (,lbl) blockids, [])
 
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 3b2eea1a5e..43cba2526d 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -271,7 +271,10 @@ mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))
 mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))
 
 
--- | is the SRT offset field inline in the info table on this platform?
+-- | Is the SRT offset field inline in the info table on this platform?
+--
+-- See the section "Referring to an SRT from the info table" in
+-- Note [SRTs] in CmmBuildInfoTables.hs
 inlineSRT :: DynFlags -> Bool
 inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64
   && tablesNextToCode dflags