[Git][ghc/ghc][wip/D5082] Make tablesNextToCode a proper dynamic flag (#15548)

John Ericson gitlab at gitlab.haskell.org
Fri Apr 5 20:28:12 UTC 2019



John Ericson pushed to branch wip/D5082 at Glasgow Haskell Compiler / GHC


Commits:
e7369f6b by Joachim Breitner at 2019-04-05T20:28:04Z
Make tablesNextToCode a proper dynamic flag (#15548)

Summary:
There is no more use of the TABLES_NEXT_TO_CODE CPP macro in
`compiler/`. The default value of `tablesNextToCode` is calculated as
before, but now users of the GHCI API can modify this flag.

Reviewers:

Subscribers: TerrorJack, rwbarton, carter

GHC Trac Issues: #15548

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

- - - - -


9 changed files:

- compiler/ghc.mk
- compiler/ghci/ByteCodeItbls.hs
- compiler/main/DynFlags.hs
- compiler/main/SysTools.hs
- compiler/utils/Util.hs
- hadrian/src/Settings/Packages.hs
- libraries/ghci/GHCi/InfoTable.hsc
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs


Changes:

=====================================
compiler/ghc.mk
=====================================
@@ -330,14 +330,6 @@ endif
 ifeq "$(GhcWithInterpreter)" "YES"
 compiler_stage2_CONFIGURE_OPTS += --flags=ghci
 
-ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO"
-# Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style
-# or not?
-# XXX This should logically be a CPP option, but there doesn't seem to
-# be a flag for that
-compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE
-endif
-
 # Should the debugger commands be enabled?
 ifeq "$(GhciWithDebugger)" "YES"
 compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DDEBUGGER


=====================================
compiler/ghci/ByteCodeItbls.hs
=====================================
@@ -71,6 +71,8 @@ make_constr_itbls hsc_env cons =
 
          descr = dataConIdentity dcon
 
-     r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
+         tables_next_to_code = tablesNextToCode dflags
+
+     r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really
                               conNo (tagForCon dflags dcon) descr)
      return (getName dcon, ItblPtr r)


=====================================
compiler/main/DynFlags.hs
=====================================
@@ -58,7 +58,6 @@ module DynFlags (
         fFlags, fLangFlags, xFlags,
         wWarningFlags,
         dynFlagDependencies,
-        tablesNextToCode, mkTablesNextToCode,
         makeDynFlagsConsistent,
         shouldUseColor,
         shouldUseHexWordLiterals,
@@ -876,6 +875,10 @@ data DynFlags = DynFlags {
   integerLibrary        :: IntegerLibrary,
     -- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overriden
     --   by GHC-API users. See Note [The integer library] in PrelNames
+  tablesNextToCode      :: Bool,
+    -- ^ Determines whether we will be compiling info tables that reside just
+    --   before the entry code, or with an indirection to the entry code. See
+    --   TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h.
   llvmTargets           :: LlvmTargets,
   llvmPasses            :: LlvmPasses,
   verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]
@@ -1614,18 +1617,6 @@ defaultObjectTarget platform
   | cGhcWithNativeCodeGen == "YES"      =  HscAsm
   | otherwise                           =  HscLlvm
 
-tablesNextToCode :: DynFlags -> Bool
-tablesNextToCode dflags
-    = mkTablesNextToCode (platformUnregisterised (targetPlatform dflags))
-
--- Determines whether we will be compiling
--- info tables that reside just before the entry code, or with an
--- indirection to the entry code.  See TABLES_NEXT_TO_CODE in
--- includes/rts/storage/InfoTables.h.
-mkTablesNextToCode :: Bool -> Bool
-mkTablesNextToCode unregisterised
-    = not unregisterised && cGhcEnableTablesNextToCode == "YES"
-
 data DynLibLoader
   = Deployable
   | SystemDependent
@@ -1874,6 +1865,9 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
         ghcLink                 = LinkBinary,
         hscTarget               = defaultHscTarget (sTargetPlatform mySettings),
         integerLibrary          = cIntegerLibraryType,
+        tablesNextToCode        =
+            not (platformUnregisterised $ sTargetPlatform mySettings) &&
+            cGhcEnableTablesNextToCode == "YES",
         verbosity               = 0,
         optLevel                = 0,
         debugLevel              = 0,


=====================================
compiler/main/SysTools.hs
=====================================
@@ -199,15 +199,9 @@ initSysTools top_dir
        let unreg_gcc_args = if targetUnregisterised
                             then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
                             else []
-           -- TABLES_NEXT_TO_CODE affects the info table layout.
-           tntc_gcc_args
-            | mkTablesNextToCode targetUnregisterised
-               = ["-DTABLES_NEXT_TO_CODE"]
-            | otherwise = []
            cpp_args= map Option (words cpp_args_str)
            gcc_args = map Option (words gcc_args_str
-                               ++ unreg_gcc_args
-                               ++ tntc_gcc_args)
+                               ++ unreg_gcc_args)
        ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
        ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
        ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"


=====================================
compiler/utils/Util.hs
=====================================
@@ -11,7 +11,6 @@
 module Util (
         -- * Flags dependent on the compiler build
         ghciSupported, debugIsOn, ncgDebugIsOn,
-        ghciTablesNextToCode,
         isWindowsHost, isDarwinHost,
 
         -- * General list processing
@@ -208,13 +207,6 @@ ncgDebugIsOn = True
 ncgDebugIsOn = False
 #endif
 
-ghciTablesNextToCode :: Bool
-#if defined(GHCI_TABLES_NEXT_TO_CODE)
-ghciTablesNextToCode = True
-#else
-ghciTablesNextToCode = False
-#endif
-
 isWindowsHost :: Bool
 #if defined(mingw32_HOST_OS)
 isWindowsHost = True


=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -57,10 +57,6 @@ packageArgs = do
             , notM ghcWithSMP ? arg "--ghc-option=-optc-DNOSMP"
             , (any (wayUnit Threaded) rtsWays) ?
               notStage0 ? arg "--ghc-option=-optc-DTHREADED_RTS"
-            , ghcWithInterpreter ?
-              ghcEnableTablesNextToCode ?
-              notM (flag GhcUnregisterised) ?
-              notStage0 ? arg "--ghc-option=-DGHCI_TABLES_NEXT_TO_CODE"
             , ghcWithInterpreter ?
               ghciWithDebugger <$> flavour ?
               notStage0 ? arg "--ghc-option=-DDEBUGGER"


=====================================
libraries/ghci/GHCi/InfoTable.hsc
=====================================
@@ -26,19 +26,13 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 #endif
 
-ghciTablesNextToCode :: Bool
-#ifdef TABLES_NEXT_TO_CODE
-ghciTablesNextToCode = True
-#else
-ghciTablesNextToCode = False
-#endif
-
 #ifdef GHCI /* To end */
 -- NOTE: Must return a pointer acceptable for use in the header of a closure.
 -- If tables_next_to_code is enabled, then it must point the the 'code' field.
 -- Otherwise, it should point to the start of the StgInfoTable.
 mkConInfoTable
-   :: Int     -- ptr words
+   :: Bool    -- TABLES_NEXT_TO_CODE
+   -> Int     -- ptr words
    -> Int     -- non-ptr words
    -> Int     -- constr tag
    -> Int     -- pointer tag
@@ -47,23 +41,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 tables_next_to_code 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 tables_next_to_code itbl con_desc
 
 
 -- -----------------------------------------------------------------------------
@@ -81,39 +75,46 @@ data Arch = ArchSPARC
           | ArchARM64
           | ArchPPC64
           | ArchPPC64LE
-          | ArchUnknown
  deriving Show
 
-platform :: Arch
-platform =
+mkJumpToAddr :: Monad 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
 #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.
@@ -273,11 +274,6 @@ mkJumpToAddr a = case platform of
                    0x618C0000 .|. lo16 w32,
                    0x7D8903A6, 0x4E800420 ]
 
-    -- 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
 
@@ -321,38 +317,40 @@ data StgConInfoTable = StgConInfoTable {
 
 
 pokeConItbl
-  :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
+  :: Bool -> 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
+pokeConItbl tables_next_to_code wr_ptr _ex_ptr itbl = do
+  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
-  | not ghciTablesNextToCode = 0
-  | otherwise =
-     case mkJumpToAddr undefined of
+sizeOfEntryCode :: Monad m => Bool -> m Int
+sizeOfEntryCode tables_next_to_code = do
+  | 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
 
 -- Note: Must return proper pointer for use in a closure
-newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())
-newExecConItbl obj con_desc
+newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
+newExecConItbl tables_next_to_code obj con_desc
    = alloca $ \pcode -> do
+        sz0 <- sizeOfEntryCode tables_next_to_code
         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
@@ -361,17 +359,13 @@ newExecConItbl obj con_desc
         ex_ptr <- peek pcode
         let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
                                     , infoTable = obj }
-        pokeConItbl wr_ptr ex_ptr cinfo
+        pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo
         BS.useAsCStringLen con_desc $ \(src, len) ->
             copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len
-        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
+        if tables_next_to_code
+          then return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))
+          else return (castPtrToFunPtr ex_ptr)
 
 foreign import ccall unsafe "allocateExec"
   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)


=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -104,7 +104,8 @@ data Message a where
 
   -- | Create an info table for a constructor
   MkConInfoTable
-   :: Int     -- ptr words
+   :: Bool    -- TABLES_NEXT_TO_CODE
+   -> Int     -- ptr words
    -> Int     -- non-ptr words
    -> Int     -- constr tag
    -> Int     -- pointer tag
@@ -468,7 +469,7 @@ getMessage = do
       15 -> Msg <$> MallocStrings <$> get
       16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
       17 -> Msg <$> FreeFFI <$> get
-      18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get)
+      18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get <*> get)
       19 -> Msg <$> (EvalStmt <$> get <*> get)
       20 -> Msg <$> (ResumeStmt <$> get <*> get)
       21 -> Msg <$> (AbandonStmt <$> get)
@@ -510,7 +511,7 @@ putMessage m = case m of
   MallocStrings bss           -> putWord8 15 >> put bss
   PrepFFI conv args res       -> putWord8 16 >> put conv >> put args >> put res
   FreeFFI p                   -> putWord8 17 >> put p
-  MkConInfoTable p n t pt d   -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d
+  MkConInfoTable tc p n t pt d -> putWord8 18 >> put tc >> put p >> put n >> put t >> put pt >> put d
   EvalStmt opts val           -> putWord8 19 >> put opts >> put val
   ResumeStmt opts val         -> putWord8 20 >> put opts >> put val
   AbandonStmt val             -> putWord8 21 >> put val


=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -89,8 +89,8 @@ run m = case m of
   MallocStrings bss -> mapM mkString0 bss
   PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
   FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
-  MkConInfoTable ptrs nptrs tag ptrtag desc ->
-    toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc
+  MkConInfoTable tc ptrs nptrs tag ptrtag desc ->
+    toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc
   StartTH -> startTH
   GetClosure ref -> do
     clos <- getClosureData =<< localRef ref



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/e7369f6bf0351ab9fe0752afe27e71f6e691d694

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/e7369f6bf0351ab9fe0752afe27e71f6e691d694
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190405/ade7e4ef/attachment-0001.html>


More information about the ghc-commits mailing list