[Git][ghc/ghc][wip/extensible-interface-files] 3 commits: testsuite: Move no_lint to the top level, tweak hie002

Josh Meredith gitlab at gitlab.haskell.org
Sat Apr 11 03:37:12 UTC 2020



Josh Meredith pushed to branch wip/extensible-interface-files at Glasgow Haskell Compiler / GHC


Commits:
723062ed by Ömer Sinan Ağacan at 2020-04-10T09:18:14+03:00
testsuite: Move no_lint to the top level, tweak hie002

- We don't want to benchmark linting so disable lints in hie002 perf
  test

- Move no_lint to the top-level to be able to use it in tests other than
  those in `testsuite/tests/perf/compiler`.

- Filter out -dstg-lint in no_lint.

- hie002 allocation numbers on 32-bit are unstable, so skip it on 32-bit

Metric Decrease:
    hie002
    ManyConstructors
    T12150
    T12234
    T13035
    T1969
    T4801
    T9233
    T9961

- - - - -
bcafaa82 by Peter Trommler at 2020-04-10T19:29:33-04:00
Testsuite: mark T11531 fragile

The test depends on a link editor allowing undefined symbols in an ELF
shared object. This is the standard but it seems some distributions
patch their link editor. See the report by @hsyl20 in #11531.

Fixes #11531

- - - - -
bcf72afe by Josh Meredith at 2020-04-10T23:37:08-04:00
Implement extensible interface files

- - - - -


12 changed files:

- compiler/GHC/Driver/Types.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/utils/Binary.hs
- docs/users_guide/extending_ghc.rst
- testsuite/driver/testlib.py
- testsuite/tests/ghci/linking/all.T
- testsuite/tests/hiefile/should_compile/all.T
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/showIface/DocsInHiFile0.stdout
- testsuite/tests/showIface/DocsInHiFile1.stdout


Changes:

=====================================
compiler/GHC/Driver/Types.hs
=====================================
@@ -147,7 +147,14 @@ module GHC.Driver.Types (
 
         -- * COMPLETE signature
         CompleteMatch(..), CompleteMatchMap,
-        mkCompleteMatchMap, extendCompleteMatchMap
+        mkCompleteMatchMap, extendCompleteMatchMap,
+
+        -- * Exstensible Iface fields
+        ExtensibleFields(..), FieldName,
+        emptyExtensibleFields,
+        readField, readIfaceField, readIfaceFieldWith,
+        writeField, writeIfaceField, writeIfaceFieldWith,
+        deleteField, deleteIfaceField,
     ) where
 
 #include "HsVersions.h"
@@ -215,8 +222,10 @@ import GHC.Serialized   ( Serialized )
 import qualified GHC.LanguageExtensions as LangExt
 
 import Foreign
-import Control.Monad    ( guard, liftM, ap )
+import Control.Monad    ( guard, liftM, ap, forM, forM_, replicateM )
 import Data.IORef
+import Data.Map         ( Map )
+import qualified Data.Map as Map
 import Data.Time
 import Exception
 import System.FilePath
@@ -1090,9 +1099,17 @@ data ModIface_ (phase :: ModIfacePhase)
         mi_arg_docs :: ArgDocMap,
                 -- ^ Docs on arguments.
 
-        mi_final_exts :: !(IfaceBackendExts phase)
+        mi_final_exts :: !(IfaceBackendExts phase),
                 -- ^ Either `()` or `ModIfaceBackend` for
                 -- a fully instantiated interface.
+
+        mi_ext_fields :: ExtensibleFields
+                -- ^ Additional optional fields, where the Map key represents
+                -- the field name, resulting in a (size, serialized data) pair.
+                -- Because the data is intended to be serialized through the
+                -- internal `Binary` class (increasing compatibility with types
+                -- using `Name` and `FastString`, such as HIE), this format is
+                -- chosen over `ByteString`s.
      }
 
 -- | Old-style accessor for whether or not the ModIface came from an hs-boot
@@ -1164,6 +1181,9 @@ instance Binary ModIface where
                  mi_doc_hdr   = doc_hdr,
                  mi_decl_docs = decl_docs,
                  mi_arg_docs  = arg_docs,
+                 mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we
+                                              -- can deal with it's pointer in the header
+                                              -- when we write the actual file
                  mi_final_exts = ModIfaceBackend {
                    mi_iface_hash = iface_hash,
                    mi_mod_hash = mod_hash,
@@ -1264,6 +1284,8 @@ instance Binary ModIface where
                  mi_doc_hdr     = doc_hdr,
                  mi_decl_docs   = decl_docs,
                  mi_arg_docs    = arg_docs,
+                 mi_ext_fields  = emptyExtensibleFields, -- placeholder because this is dealt
+                                                         -- with specially when the file is read
                  mi_final_exts = ModIfaceBackend {
                    mi_iface_hash = iface_hash,
                    mi_mod_hash = mod_hash,
@@ -1307,7 +1329,9 @@ emptyPartialModIface mod
                mi_doc_hdr     = Nothing,
                mi_decl_docs   = emptyDeclDocMap,
                mi_arg_docs    = emptyArgDocMap,
-               mi_final_exts        = () }
+               mi_final_exts  = (),
+               mi_ext_fields  = emptyExtensibleFields
+             }
 
 emptyFullModIface :: Module -> ModIface
 emptyFullModIface mod =
@@ -3279,7 +3303,105 @@ phaseForeignLanguage phase = case phase of
 -- avoid major space leaks.
 instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where
   rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12
-                f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) =
+                f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =
     rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`
     f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq`
     rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23
+    `seq` rnf f24
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Extensible Iface Fields}
+*                                                                      *
+************************************************************************
+-}
+
+type FieldName = String
+
+newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) }
+
+instance Binary ExtensibleFields where
+  put_ bh (ExtensibleFields fs) = do
+    put_ bh (Map.size fs :: Int)
+
+    -- Put the names of each field, and reserve a space
+    -- for a payload pointer after each name:
+    header_entries <- forM (Map.toList fs) $ \(name, dat) -> do
+      put_ bh name
+      field_p_p <- tellBin bh
+      put_ bh field_p_p
+      return (field_p_p, dat)
+
+    -- Now put the payloads and use the reserved space
+    -- to point to the start of each payload:
+    forM_ header_entries $ \(field_p_p, dat) -> do
+      field_p <- tellBin bh
+      putAt bh field_p_p field_p
+      seekBin bh field_p
+      put_ bh dat
+
+  get bh = do
+    n <- get bh :: IO Int
+
+    -- Get the names and field pointers:
+    header_entries <- replicateM n $ do
+      (,) <$> get bh <*> get bh
+
+    -- Seek to and get each field's payload:
+    fields <- forM header_entries $ \(name, field_p) -> do
+      seekBin bh field_p
+      dat <- get bh
+      return (name, dat)
+
+    return . ExtensibleFields . Map.fromList $ fields
+
+instance NFData ExtensibleFields where
+  rnf (ExtensibleFields fs) = rnf fs
+
+emptyExtensibleFields :: ExtensibleFields
+emptyExtensibleFields = ExtensibleFields Map.empty
+
+--------------------------------------------------------------------------------
+-- | Reading
+
+readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a)
+readIfaceField name = readIfaceFieldWith name get
+
+readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)
+readField name = readFieldWith name get
+
+readIfaceFieldWith :: FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)
+readIfaceFieldWith name read iface = readFieldWith name read (mi_ext_fields iface)
+
+readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)
+readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>
+  Map.lookup name (getExtensibleFields fields)
+
+--------------------------------------------------------------------------------
+-- | Writing
+
+writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface
+writeIfaceField name x = writeIfaceFieldWith name (`put_` x)
+
+writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields
+writeField name x = writeFieldWith name (`put_` x)
+
+writeIfaceFieldWith :: FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface
+writeIfaceFieldWith name write iface = do
+  fields <- writeFieldWith name write (mi_ext_fields iface)
+  return iface{ mi_ext_fields = fields }
+
+writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields
+writeFieldWith name write fields = do
+  bh <- openBinMem (1024 * 1024)
+  write bh
+  --
+  bd <- handleData bh
+  return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)
+
+deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields
+deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs
+
+deleteIfaceField :: FieldName -> ModIface -> ModIface
+deleteIfaceField name iface = iface { mi_ext_fields = deleteField name (mi_ext_fields iface) }


=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -148,7 +148,15 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
     wantedGot "Way" way_descr check_way ppr
     when (checkHiWay == CheckHiWay) $
         errorOnMismatch "mismatched interface file ways" way_descr check_way
-    getWithUserData ncu bh
+
+    extFields_p <- get bh
+
+    mod_iface <- getWithUserData ncu bh
+
+    seekBin bh extFields_p
+    extFields <- get bh
+
+    return mod_iface{mi_ext_fields = extFields}
 
 
 -- | This performs a get action after reading the dictionary and symbol
@@ -200,8 +208,16 @@ writeBinIface dflags hi_path mod_iface = do
     let way_descr = getWayDescr dflags
     put_  bh way_descr
 
+    extFields_p_p <- tellBin bh
+    put_ bh extFields_p_p
 
     putWithUserData (debugTraceMsg dflags 3) bh mod_iface
+
+    extFields_p <- tellBin bh
+    putAt bh extFields_p_p extFields_p
+    seekBin bh extFields_p
+    put_ bh (mi_ext_fields mod_iface)
+
     -- And send the result to the file
     writeBinMem bh hi_path
 


=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Driver.Types
 import GHC.Types.Basic hiding (SuccessFlag(..))
 import GHC.Tc.Utils.Monad
 
+import Binary   ( BinData(..) )
 import Constants
 import PrelNames
 import PrelInfo
@@ -83,6 +84,7 @@ import GHC.Driver.Plugins
 import Control.Monad
 import Control.Exception
 import Data.IORef
+import Data.Map ( toList )
 import System.FilePath
 import System.Directory
 
@@ -1159,6 +1161,7 @@ pprModIface iface at ModIface{ mi_final_exts = exts }
         , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
         , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
         , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
+        , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))
         ]
   where
     pp_hsc_src HsBootFile = text "[boot]"
@@ -1248,6 +1251,11 @@ pprIfaceAnnotation :: IfaceAnnotation -> SDoc
 pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
   = ppr target <+> text "annotated by" <+> ppr serialized
 
+pprExtensibleFields :: ExtensibleFields -> SDoc
+pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs
+  where
+    pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"
+
 {-
 *********************************************************
 *                                                       *


=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -268,7 +268,8 @@ mkIface_ hsc_env
           mi_doc_hdr     = doc_hdr,
           mi_decl_docs   = decl_docs,
           mi_arg_docs    = arg_docs,
-          mi_final_exts  = () }
+          mi_final_exts  = (),
+          mi_ext_fields  = emptyExtensibleFields }
   where
      cmp_rule     = comparing ifRuleName
      -- Compare these lexicographically by OccName, *not* by unique,


=====================================
compiler/utils/Binary.hs
=====================================
@@ -27,6 +27,8 @@ module Binary
     {-type-}  BinHandle,
     SymbolTable, Dictionary,
 
+   BinData(..), dataHandle, handleData,
+
    openBinMem,
 --   closeBin,
 
@@ -73,6 +75,7 @@ import Fingerprint
 import GHC.Types.Basic
 import GHC.Types.SrcLoc
 
+import Control.DeepSeq
 import Foreign
 import Data.Array
 import Data.ByteString (ByteString)
@@ -95,6 +98,44 @@ import GHC.Serialized
 
 type BinArray = ForeignPtr Word8
 
+
+
+---------------------------------------------------------------
+-- BinData
+---------------------------------------------------------------
+
+data BinData = BinData Int BinArray
+
+instance NFData BinData where
+  rnf (BinData sz _) = rnf sz
+
+instance Binary BinData where
+  put_ bh (BinData sz dat) = do
+    put_ bh sz
+    putPrim bh sz $ \dest ->
+      withForeignPtr dat $ \orig ->
+        copyBytes dest orig sz
+  --
+  get bh = do
+    sz <- get bh
+    dat <- mallocForeignPtrBytes sz
+    getPrim bh sz $ \orig ->
+      withForeignPtr dat $ \dest ->
+        copyBytes dest orig sz
+    return (BinData sz dat)
+
+dataHandle :: BinData -> IO BinHandle
+dataHandle (BinData size bin) = do
+  ixr <- newFastMutInt
+  szr <- newFastMutInt
+  writeFastMutInt ixr 0
+  writeFastMutInt szr size
+  binr <- newIORef bin
+  return (BinMem noUserData ixr szr binr)
+
+handleData :: BinHandle -> IO BinData
+handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
+
 ---------------------------------------------------------------
 -- BinHandle
 ---------------------------------------------------------------


=====================================
docs/users_guide/extending_ghc.rst
=====================================
@@ -749,6 +749,33 @@ NOT be invoked with your own modules.
 In the ``ModIface`` datatype you can find lots of useful information, including
 the exported definitions and type class instances.
 
+The ``ModIface`` datatype also contains facilities for extending it with extra
+data, stored in a ``Map`` of serialised fields, indexed by field names and using
+GHC's internal ``Binary`` class. The interface to work with these fields is:
+
+::
+
+    readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a)
+    writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface
+    deleteIfaceField :: FieldName -> ModIface -> ModIface
+
+The ``FieldName`` is open-ended, but typically it should contain the producing
+package name, along with the actual field name. Then, the version number can either
+be attached to the serialised data for that field, or in cases where multiple versions
+of a field could exist in the same interface file, included in the field name.
+
+Depending on if the field version advances with the package version, or independently,
+the version can be attached to either the package name or the field name. Examples of
+each case:
+
+::
+
+    package/field
+    ghc-n.n.n/core
+    package/field-n
+
+To read an interface file from an external tool without linking to GHC, the format
+is described at `Extensible Interface Files<https://gitlab.haskell.org/ghc/ghc/wikis/Extensible-Interface-Files>`_.
 
 Source plugin example
 ^^^^^^^^^^^^^^^^^^^^^


=====================================
testsuite/driver/testlib.py
=====================================
@@ -116,6 +116,12 @@ def expect_fail( name, opts ):
     # future.
     opts.expect = 'fail';
 
+def no_lint( name, opts ):
+   """Disable Core, STG and Cmm lints. Useful when testing compiler perf."""
+   opts.compiler_always_flags = \
+       [opt for opt in opts.compiler_always_flags \
+            if opt not in ['-dcore-lint', '-dstg-lint', '-dcmm-lint']]
+
 def reqlib( lib ):
     return lambda name, opts, l=lib: _reqlib (name, opts, l )
 


=====================================
testsuite/tests/ghci/linking/all.T
=====================================
@@ -46,7 +46,8 @@ test('T3333',
 test('T11531',
      [extra_files(['T11531.hs', 'T11531.c', 'T11531.h']),
       unless(doing_ghci, skip),
-      unless(opsys('linux'), skip)],
+      unless(opsys('linux'), skip),
+      fragile(11531)],
      makefile_test, ['T11531'])
 
 test('T14708',


=====================================
testsuite/tests/hiefile/should_compile/all.T
=====================================
@@ -1,6 +1,12 @@
 test('hie001',       normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
-test('hie002',       collect_compiler_stats('bytes allocated',10),
-                                               compile, ['-fno-code -fwrite-ide-info'])
+test('hie002',
+     [# Allocation numbers unstable on 32-bit, skip:
+      when(wordsize(32), skip),
+      # No linting in perf tests:
+      no_lint,
+      collect_compiler_stats('bytes allocated',10)],
+     compile,
+     ['-fno-code -fwrite-ide-info'])
 test('hie003',       normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 test('hie004',       normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 test('hie005',       normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])


=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -1,10 +1,5 @@
 # Tests that call 'collect_compiler_stats' are skipped when debugging is on.
 # See testsuite/driver/testlib.py.
-
-def no_lint(name, opts):
-   opts.compiler_always_flags = \
-       [opt for opt in opts.compiler_always_flags if opt != '-dcore-lint' and opt != '-dcmm-lint']
-
 setTestOpts(no_lint)
 
 test('T1969',


=====================================
testsuite/tests/showIface/DocsInHiFile0.stdout
=====================================
@@ -2,3 +2,4 @@ module header:
   Nothing
 declaration docs:
 arg docs:
+extensible fields:


=====================================
testsuite/tests/showIface/DocsInHiFile1.stdout
=====================================
@@ -33,4 +33,4 @@ arg docs:
   p:
     0:
       " An argument"
-
+extensible fields:



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b03ae53c8c455bd665c701fef51bd8813f38e6c9...bcf72afe16c851afae3e0723ea851946750e7b30

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b03ae53c8c455bd665c701fef51bd8813f38e6c9...bcf72afe16c851afae3e0723ea851946750e7b30
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/20200410/5b93ac79/attachment-0001.html>


More information about the ghc-commits mailing list