Prepare to use run-time tablesNextToCode in compiler exclusively

Factor out CPP as much as possible to prepare for runtime
determinattion.

Progress towards #15548

2 files changed, 65 insertions, 61 deletions

diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
index 783744f26a..943a234391 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
@@ -31,10 +31,10 @@ type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
 -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/InfoTables.h>
 -- for more details on this data structure.
 data StgInfoTable = StgInfoTable {
-   entry  :: Maybe EntryFunPtr, -- Just <=> not ghciTablesNextToCode
+   entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE
    ptrs   :: HalfWord,
    nptrs  :: HalfWord,
    tipe   :: ClosureType,
    srtlen :: HalfWord,
-   code   :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
+   code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE
   } deriving (Show, Generic)
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
index 587e39bbed..09970e0370 100644
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -13,20 +13,22 @@ module GHCi.InfoTable
     mkConInfoTable
   ) where
 
-import Prelude -- See note [Why do we import Prelude here?]
+import Prelude hiding (fail) -- See note [Why do we import Prelude here?]
+
 import Foreign
 import Foreign.C
 import GHC.Ptr
 import GHC.Exts
 import GHC.Exts.Heap
 import Data.ByteString (ByteString)
+import Control.Monad.Fail
 import qualified Data.ByteString as BS
 
-ghciTablesNextToCode :: Bool
+tables_next_to_code :: Bool
 #if defined(TABLES_NEXT_TO_CODE)
-ghciTablesNextToCode = True
+tables_next_to_code = True
 #else
-ghciTablesNextToCode = False
+tables_next_to_code = False
 #endif
 
 -- NOTE: Must return a pointer acceptable for use in the header of a closure.
@@ -42,23 +44,23 @@ mkConInfoTable
       -- resulting info table is allocated with allocateExec(), and
       -- should be freed with freeExec().
 
-mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =
-  castFunPtrToPtr <$> newExecConItbl itbl con_desc
-  where
-     entry_addr = interpConstrEntry !! ptrtag
-     code' = mkJumpToAddr entry_addr
+mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc = do
+  let entry_addr = interpConstrEntry !! ptrtag
+  code' <- if tables_next_to_code
+    then Just <$> mkJumpToAddr entry_addr
+    else pure Nothing
+  let
      itbl  = StgInfoTable {
-                 entry = if ghciTablesNextToCode
+                 entry = if tables_next_to_code
                          then Nothing
                          else Just entry_addr,
                  ptrs  = fromIntegral ptr_words,
                  nptrs = fromIntegral nonptr_words,
                  tipe  = CONSTR,
                  srtlen = fromIntegral tag,
-                 code  = if ghciTablesNextToCode
-                         then Just code'
-                         else Nothing
+                 code  = code'
               }
+  castFunPtrToPtr <$> newExecConItbl itbl con_desc
 
 
 -- -----------------------------------------------------------------------------
@@ -77,41 +79,48 @@ data Arch = ArchSPARC
           | ArchPPC64
           | ArchPPC64LE
           | ArchS390X
-          | ArchUnknown
  deriving Show
 
-platform :: Arch
-platform =
+mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
+mkJumpToAddr ptr = do
+  arch <- case mArch of
+    Just a -> pure a
+    Nothing ->
+      -- This code must not be called. You either need to add your
+      -- architecture as a distinct case to 'Arch' and 'mArch', or use
+      -- non-TABLES_NEXT_TO_CODE mode.
+      fail "mkJumpToAddr: Unknown obscure arch is not supported with TABLES_NEXT_TO_CODE"
+  pure $ mkJumpToAddr' arch ptr
+
+-- | 'Just' if it's a known OS, or 'Nothing' otherwise.
+mArch :: Maybe Arch
+mArch =
 #if defined(sparc_HOST_ARCH)
-       ArchSPARC
+       Just ArchSPARC
 #elif defined(powerpc_HOST_ARCH)
-       ArchPPC
+       Just ArchPPC
 #elif defined(i386_HOST_ARCH)
-       ArchX86
+       Just ArchX86
 #elif defined(x86_64_HOST_ARCH)
-       ArchX86_64
+       Just ArchX86_64
 #elif defined(alpha_HOST_ARCH)
-       ArchAlpha
+       Just ArchAlpha
 #elif defined(arm_HOST_ARCH)
-       ArchARM
+       Just ArchARM
 #elif defined(aarch64_HOST_ARCH)
-       ArchARM64
+       Just ArchARM64
 #elif defined(powerpc64_HOST_ARCH)
-       ArchPPC64
+       Just ArchPPC64
 #elif defined(powerpc64le_HOST_ARCH)
-       ArchPPC64LE
+       Just ArchPPC64LE
 #elif defined(s390x_HOST_ARCH)
-       ArchS390X
+       Just ArchS390X
 #else
-#    if defined(TABLES_NEXT_TO_CODE)
-#        error Unimplemented architecture
-#    else
-       ArchUnknown
-#    endif
+       Nothing
 #endif
 
-mkJumpToAddr :: EntryFunPtr -> ItblCodes
-mkJumpToAddr a = case platform of
+mkJumpToAddr' :: Arch -> EntryFunPtr -> ItblCodes
+mkJumpToAddr' platform a = case platform of
     ArchSPARC ->
         -- After some consideration, we'll try this, where
         -- 0x55555555 stands in for the address to jump to.
@@ -285,11 +294,6 @@ mkJumpToAddr a = case platform of
                   0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,
                   0x07, 0xF1 ]
 
-    -- This code must not be called. You either need to
-    -- add your architecture as a distinct case or
-    -- use non-TABLES_NEXT_TO_CODE mode
-    ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"
-
 byte0 :: (Integral w) => w -> Word8
 byte0 w = fromIntegral w
 
@@ -336,24 +340,25 @@ pokeConItbl
   :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
   -> IO ()
 pokeConItbl wr_ptr _ex_ptr itbl = do
-#if defined(TABLES_NEXT_TO_CODE)
-  -- Write the offset to the con_desc from the end of the standard InfoTable
-  -- at the first byte.
-  let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
-  (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset
-#else
-  -- Write the con_desc address after the end of the info table.
-  -- Use itblSize because CPP will not pick up PROFILING when calculating
-  -- the offset.
-  pokeByteOff wr_ptr itblSize (conDesc itbl)
-#endif
+  if tables_next_to_code
+    then do
+      -- Write the offset to the con_desc from the end of the standard InfoTable
+      -- at the first byte.
+      let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
+      (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset
+    else do
+      -- Write the con_desc address after the end of the info table.
+      -- Use itblSize because CPP will not pick up PROFILING when calculating
+      -- the offset.
+      pokeByteOff wr_ptr itblSize (conDesc itbl)
   pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)
 
-sizeOfEntryCode :: Int
+sizeOfEntryCode :: MonadFail m => m Int
 sizeOfEntryCode
-  | not ghciTablesNextToCode = 0
-  | otherwise =
-     case mkJumpToAddr undefined of
+  | not tables_next_to_code = pure 0
+  | otherwise = do
+     code' <- mkJumpToAddr undefined
+     pure $ case code' of
        Left  xs -> sizeOf (head xs) * length xs
        Right xs -> sizeOf (head xs) * length xs
 
@@ -361,10 +366,11 @@ sizeOfEntryCode
 newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())
 newExecConItbl obj con_desc
    = alloca $ \pcode -> do
+        sz0 <- sizeOfEntryCode
         let lcon_desc = BS.length con_desc + 1{- null terminator -}
             -- SCARY
             -- This size represents the number of bytes in an StgConInfoTable.
-            sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)
+            sz = fromIntegral $ conInfoTableSizeB + sz0
                -- Note: we need to allocate the conDesc string next to the info
                -- table, because on a 64-bit platform we reference this string
                -- with a 32-bit offset relative to the info table, so if we
@@ -379,11 +385,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 defined(TABLES_NEXT_TO_CODE)
-        return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))
-#else
-        return (castPtrToFunPtr ex_ptr)
-#endif
+        pure $ if tables_next_to_code
+          then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB
+          else castPtrToFunPtr ex_ptr
 
 foreign import ccall unsafe "allocateExec"
   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)