[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix and enforce validation of header for .hie files
Marge Bot
gitlab at gitlab.haskell.org
Fri May 31 22:25:13 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
0e0d87da by Zubin Duggal at 2019-05-31T06:34:57Z
Fix and enforce validation of header for .hie files
Implements #16686
The files version is automatically generated from the current GHC
version in the same manner as normal interface files.
This means that clients can first read the version and then decide how
to read the rest of the file.
- - - - -
0fede68f by Nathan Collins at 2019-05-31T22:25:02Z
Improve ThreadId Show instance
By making it include parens when a derived instance would. For example, this changes the (hypothetical) code `show (Just (ThreadId 3))` to produce `"Just (ThreadId 3)"` instead of the current `"Just ThreadId 3"`.
- - - - -
7902c891 by Ryan Scott at 2019-05-31T22:25:05Z
Reject nested foralls in foreign imports (#16702)
This replaces a panic observed in #16702 with a simple error message
stating that nested `forall`s simply aren't allowed in the type
signature of a `foreign import` (at least, not at present).
Fixes #16702.
- - - - -
3c8d1989 by Ryan Scott at 2019-05-31T22:25:07Z
Fix space leaks in dynLoadObjs (#16708)
When running the test suite on a GHC built with the `quick` build
flavour, `-fghci-leak-check` noticed some space leaks. Careful
investigation led to `Linker.dynLoadObjs` being the culprit.
Pattern-matching on `PeristentLinkerState` and a dash of `$!` were
sufficient to fix the issue. (ht to mpickering for his suggestions,
which were crucial to discovering a fix)
Fixes #16708.
- - - - -
13 changed files:
- compiler/ghci/Linker.hs
- compiler/hieFile/HieAst.hs
- compiler/hieFile/HieBin.hs
- compiler/hieFile/HieDebug.hs
- compiler/hieFile/HieTypes.hs
- compiler/main/HscMain.hs
- compiler/typecheck/TcForeign.hs
- docs/users_guide/ffi-chap.rst
- libraries/base/GHC/Conc/Sync.hs
- + testsuite/tests/ffi/should_fail/T16702.hs
- + testsuite/tests/ffi/should_fail/T16702.stderr
- testsuite/tests/ffi/should_fail/all.T
- utils/haddock
Changes:
=====================================
compiler/ghci/Linker.hs
=====================================
@@ -115,7 +115,7 @@ readPLS dl =
modifyMbPLS_
:: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
-modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f
+modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f
emptyPLS :: DynFlags -> PersistentLinkerState
emptyPLS _ = PersistentLinkerState {
@@ -881,8 +881,8 @@ dynLinkObjs hsc_env pls objs = do
dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
-> IO PersistentLinkerState
-dynLoadObjs _ pls [] = return pls
-dynLoadObjs hsc_env pls objs = do
+dynLoadObjs _ pls [] = return pls
+dynLoadObjs hsc_env pls at PersistentLinkerState{..} objs = do
let dflags = hsc_dflags hsc_env
let platform = targetPlatform dflags
let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
@@ -899,13 +899,13 @@ dynLoadObjs hsc_env pls objs = do
-- library.
ldInputs =
concatMap (\l -> [ Option ("-l" ++ l) ])
- (nub $ snd <$> temp_sos pls)
+ (nub $ snd <$> temp_sos)
++ concatMap (\lp -> [ Option ("-L" ++ lp)
, Option "-Xlinker"
, Option "-rpath"
, Option "-Xlinker"
, Option lp ])
- (nub $ fst <$> temp_sos pls)
+ (nub $ fst <$> temp_sos)
++ concatMap
(\lp ->
[ Option ("-L" ++ lp)
@@ -933,13 +933,13 @@ dynLoadObjs hsc_env pls objs = do
-- link all "loaded packages" so symbols in those can be resolved
-- Note: We are loading packages with local scope, so to see the
-- symbols in this link we must link all loaded packages again.
- linkDynLib dflags2 objs (pkgs_loaded pls)
+ linkDynLib dflags2 objs pkgs_loaded
-- if we got this far, extend the lifetime of the library file
changeTempFilesLifetime dflags TFL_GhcSession [soFile]
m <- loadDLL hsc_env soFile
case m of
- Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
+ Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
Just err -> panic ("Loading temp shared object failed: " ++ err)
rmDupLinkables :: [Linkable] -- Already loaded
=====================================
compiler/hieFile/HieAst.hs
=====================================
@@ -1,3 +1,6 @@
+{-
+Main functions for .hie file generation
+-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -20,7 +23,6 @@ import BooleanFormula
import Class ( FunDep )
import CoreUtils ( exprType )
import ConLike ( conLikeName )
-import Config ( cProjectVersion )
import Desugar ( deSugarExpr )
import FieldLabel
import HsSyn
@@ -42,7 +44,6 @@ import HieUtils
import qualified Data.Array as A
import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BSC
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Data ( Data, Typeable )
@@ -98,9 +99,7 @@ mkHieFile ms ts rs = do
let Just src_file = ml_hs_file $ ms_location ms
src <- liftIO $ BS.readFile src_file
return $ HieFile
- { hie_version = curHieVersion
- , hie_ghc_version = BSC.pack cProjectVersion
- , hie_hs_file = src_file
+ { hie_hs_file = src_file
, hie_module = ms_mod ms
, hie_types = arr
, hie_asts = asts'
=====================================
compiler/hieFile/HieBin.hs
=====================================
@@ -1,8 +1,11 @@
+{-
+Binary serialization for .hie files.
+-}
{-# LANGUAGE ScopedTypeVariables #-}
-module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where
+module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where
+import Config ( cProjectVersion )
import GhcPrelude
-
import Binary
import BinIface ( getDictFastString )
import FastMutInt
@@ -14,17 +17,23 @@ import Outputable
import PrelInfo
import SrcLoc
import UniqSupply ( takeUniqFromSupply )
+import Util ( maybeRead )
import Unique
import UniqFM
import qualified Data.Array as A
import Data.IORef
+import Data.ByteString ( ByteString )
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
import Data.List ( mapAccumR )
-import Data.Word ( Word32 )
-import Control.Monad ( replicateM )
+import Data.Word ( Word8, Word32 )
+import Control.Monad ( replicateM, when )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath ( takeDirectory )
+import HieTypes
+
-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
-- these two types.
@@ -63,10 +72,33 @@ data HieDictionary = HieDictionary
initBinMemSize :: Int
initBinMemSize = 1024*1024
-writeHieFile :: Binary a => FilePath -> a -> IO ()
+-- | The header for HIE files - Capital ASCII letters "HIE".
+hieMagic :: [Word8]
+hieMagic = [72,73,69]
+
+hieMagicLen :: Int
+hieMagicLen = length hieMagic
+
+ghcVersion :: ByteString
+ghcVersion = BSC.pack cProjectVersion
+
+putBinLine :: BinHandle -> ByteString -> IO ()
+putBinLine bh xs = do
+ mapM_ (putByte bh) $ BS.unpack xs
+ putByte bh 10 -- newline char
+
+-- | Write a `HieFile` to the given `FilePath`, with a proper header and
+-- symbol tables for `Name`s and `FastString`s
+writeHieFile :: FilePath -> HieFile -> IO ()
writeHieFile hie_file_path hiefile = do
bh0 <- openBinMem initBinMemSize
+ -- Write the header: hieHeader followed by the
+ -- hieVersion and the GHC version used to generate this file
+ mapM_ (putByte bh0) hieMagic
+ putBinLine bh0 $ BSC.pack $ show hieVersion
+ putBinLine bh0 $ ghcVersion
+
-- remember where the dictionary pointer will go
dict_p_p <- tellBin bh0
put_ bh0 dict_p_p
@@ -105,7 +137,7 @@ writeHieFile hie_file_path hiefile = do
symtab_map' <- readIORef symtab_map
putSymbolTable bh symtab_next' symtab_map'
- -- write the dictionary pointer at the fornt of the file
+ -- write the dictionary pointer at the front of the file
dict_p <- tellBin bh
putAt bh dict_p_p dict_p
seekBin bh dict_p
@@ -120,10 +152,87 @@ writeHieFile hie_file_path hiefile = do
writeBinMem bh hie_file_path
return ()
-readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache)
+data HieFileResult
+ = HieFileResult
+ { hie_file_result_version :: Integer
+ , hie_file_result_ghc_version :: ByteString
+ , hie_file_result :: HieFile
+ }
+
+type HieHeader = (Integer, ByteString)
+
+-- | Read a `HieFile` from a `FilePath`. Can use
+-- an existing `NameCache`. Allows you to specify
+-- which versions of hieFile to attempt to read.
+-- `Left` case returns the failing header versions.
+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache))
+readHieFileWithVersion readVersion nc file = do
+ bh0 <- readBinMem file
+
+ (hieVersion, ghcVersion) <- readHieFileHeader file bh0
+
+ if readVersion (hieVersion, ghcVersion)
+ then do
+ (hieFile, nc') <- readHieFileContents bh0 nc
+ return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc')
+ else return $ Left (hieVersion, ghcVersion)
+
+
+-- | Read a `HieFile` from a `FilePath`. Can use
+-- an existing `NameCache`.
+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache)
readHieFile nc file = do
+
bh0 <- readBinMem file
+ (readHieVersion, ghcVersion) <- readHieFileHeader file bh0
+
+ -- Check if the versions match
+ when (readHieVersion /= hieVersion) $
+ panic $ unwords ["readHieFile: hie file versions don't match for file:"
+ , file
+ , "Expected"
+ , show hieVersion
+ , "but got", show readHieVersion
+ ]
+ (hieFile, nc') <- readHieFileContents bh0 nc
+ return $ (HieFileResult hieVersion ghcVersion hieFile, nc')
+
+readBinLine :: BinHandle -> IO ByteString
+readBinLine bh = BS.pack . reverse <$> loop []
+ where
+ loop acc = do
+ char <- get bh :: IO Word8
+ if char == 10 -- ASCII newline '\n'
+ then return acc
+ else loop (char : acc)
+
+readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
+readHieFileHeader file bh0 = do
+ -- Read the header
+ magic <- replicateM hieMagicLen (get bh0)
+ version <- BSC.unpack <$> readBinLine bh0
+ case maybeRead version of
+ Nothing ->
+ panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"
+ , show version
+ ]
+ Just readHieVersion -> do
+ ghcVersion <- readBinLine bh0
+
+ -- Check if the header is valid
+ when (magic /= hieMagic) $
+ panic $ unwords ["readHieFileHeader: headers don't match for file:"
+ , file
+ , "Expected"
+ , show hieMagic
+ , "but got", show magic
+ ]
+ return (readHieVersion, ghcVersion)
+
+readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache)
+readHieFileContents bh0 nc = do
+
dict <- get_dictionary bh0
-- read the symbol table so we are capable of reading the actual data
=====================================
compiler/hieFile/HieDebug.hs
=====================================
@@ -1,3 +1,6 @@
+{-
+Functions to validate and check .hie file ASTs generated by GHC.
+-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
=====================================
compiler/hieFile/HieTypes.hs
=====================================
@@ -1,3 +1,8 @@
+{-
+Types for the .hie file format are defined here.
+
+For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
+-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
@@ -7,6 +12,7 @@ module HieTypes where
import GhcPrelude
+import Config
import Binary
import FastString ( FastString )
import IfaceType
@@ -28,8 +34,8 @@ import Control.Applicative ( (<|>) )
type Span = RealSrcSpan
-- | Current version of @.hie@ files
-curHieVersion :: Word8
-curHieVersion = 0
+hieVersion :: Integer
+hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
{- |
GHC builds up a wealth of information about Haskell source as it compiles it.
@@ -48,13 +54,7 @@ Besides saving compilation cycles, @.hie@ files also offer a more stable
interface than the GHC API.
-}
data HieFile = HieFile
- { hie_version :: Word8
- -- ^ version of the HIE format
-
- , hie_ghc_version :: ByteString
- -- ^ Version of GHC that produced this file
-
- , hie_hs_file :: FilePath
+ { hie_hs_file :: FilePath
-- ^ Initial Haskell source file path
, hie_module :: Module
@@ -74,11 +74,8 @@ data HieFile = HieFile
, hie_hs_src :: ByteString
-- ^ Raw bytes of the initial Haskell source
}
-
instance Binary HieFile where
put_ bh hf = do
- put_ bh $ hie_version hf
- put_ bh $ hie_ghc_version hf
put_ bh $ hie_hs_file hf
put_ bh $ hie_module hf
put_ bh $ hie_types hf
@@ -93,8 +90,6 @@ instance Binary HieFile where
<*> get bh
<*> get bh
<*> get bh
- <*> get bh
- <*> get bh
{-
=====================================
compiler/main/HscMain.hs
=====================================
@@ -174,7 +174,7 @@ import Data.Set (Set)
import HieAst ( mkHieFile )
import HieTypes ( getAsts, hie_asts )
-import HieBin ( readHieFile, writeHieFile )
+import HieBin ( readHieFile, writeHieFile , hie_file_result)
import HieDebug ( diffFile, validateScopes )
#include "HsVersions.h"
@@ -434,7 +434,7 @@ extract_renamed_stuff mod_summary tc_result = do
-- Roundtrip testing
nc <- readIORef $ hsc_NC hs_env
(file', _) <- readHieFile nc out_file
- case diffFile hieFile file' of
+ case diffFile hieFile (hie_file_result file') of
[] ->
putMsg dflags $ text "Got no roundtrip errors"
xs -> do
=====================================
compiler/typecheck/TcForeign.hs
=====================================
@@ -64,7 +64,6 @@ import Hooks
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
-import Data.Maybe
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
@@ -251,8 +250,7 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
; let
-- Drop the foralls before inspecting the
-- structure of the foreign type.
- (bndrs, res_ty) = tcSplitPiTys norm_sig_ty
- arg_tys = mapMaybe binderRelevantType_maybe bndrs
+ (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty)
id = mkLocalId nm sig_ty
-- Use a LocalId to obey the invariant that locally-defined
-- things are LocalIds. However, it does not need zonking,
@@ -424,10 +422,9 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
return (CExport (L l (CExportStatic esrc str cconv')) src)
where
- -- Drop the foralls before inspecting n
+ -- Drop the foralls before inspecting
-- the structure of the foreign type.
- (bndrs, res_ty) = tcSplitPiTys sig_ty
- arg_tys = mapMaybe binderRelevantType_maybe bndrs
+ (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty)
{-
************************************************************************
@@ -458,6 +455,11 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty
= -- Got an IO result type, that's always fine!
check (pred_res_ty res_ty) (illegalForeignTyErr result)
+ -- We disallow nested foralls in foreign types
+ -- (at least, for the time being). See #16702.
+ | tcIsForAllTy ty
+ = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall")
+
-- Case for non-IO result type with FFI Import
| not non_io_result_ok
= addErrTc $ illegalForeignTyErr result (text "IO result type expected")
=====================================
docs/users_guide/ffi-chap.rst
=====================================
@@ -14,9 +14,10 @@ Foreign function interface (FFI)
Allow use of the Haskell foreign function interface.
-GHC (mostly) conforms to the Haskell Foreign Function Interface, whose
-definition is part of the Haskell Report on
-`http://www.haskell.org/ <http://www.haskell.org/>`__.
+GHC (mostly) conforms to the Haskell Foreign Function Interface as specified
+in the Haskell Report. Refer to the `relevant chapter
+<https://www.haskell.org/onlinereport/haskell2010/haskellch8.html>_`
+of the Haskell Report for more details.
FFI support is enabled by default, but can be enabled or disabled
explicitly with the :extension:`ForeignFunctionInterface` flag.
@@ -102,6 +103,25 @@ OK: ::
foreign import foo :: Int -> MyIO Int
foreign import "dynamic" baz :: (Int -> MyIO Int) -> CInt -> MyIO Int
+.. _ffi-foralls:
+
+Explicit ``forall``s in foreign types
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The type variables in the type of a foreign declaration may be quantified with
+an explicit ``forall`` by using the :extension:`ExplicitForAll` language
+extension, as in the following example: ::
+
+ {-# LANGUAGE ExplicitForAll #-}
+ foreign import ccall "mmap" c_mmap :: forall a. CSize -> IO (Ptr a)
+
+Note that an explicit ``forall`` must appear at the front of the type signature
+and is not permitted to appear nested within the type, as in the following
+(erroneous) examples: ::
+
+ foreign import ccall "mmap" c_mmap' :: CSize -> forall a. IO (Ptr a)
+ foreign import ccall quux :: (forall a. Ptr a) -> IO ()
+
.. _ffi-prim:
Primitive imports
=====================================
libraries/base/GHC/Conc/Sync.hs
=====================================
@@ -113,7 +113,7 @@ import GHC.IORef
import GHC.MVar
import GHC.Ptr
import GHC.Real ( fromIntegral )
-import GHC.Show ( Show(..), showString )
+import GHC.Show ( Show(..), showParen, showString )
import GHC.Stable ( StablePtr(..) )
import GHC.Weak
@@ -145,7 +145,7 @@ This misfeature will hopefully be corrected at a later date.
-- | @since 4.2.0.0
instance Show ThreadId where
- showsPrec d t =
+ showsPrec d t = showParen (d >= 11) $
showString "ThreadId " .
showsPrec d (getThreadId (id2TSO t))
=====================================
testsuite/tests/ffi/should_fail/T16702.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE RankNTypes #-}
+
+module T16702 where
+
+import Foreign.C.Types
+import Foreign.Ptr
+import Data.Kind (Type)
+
+foreign import ccall "math.h pow"
+ c_pow :: CDouble
+ -> forall (a :: Type). CDouble
+ -> forall (b :: Type). CDouble
+
+foreign import ccall "malloc"
+ malloc1 :: CSize -> forall a. IO (Ptr a)
+
+foreign import ccall "malloc"
+ malloc2 :: Show a => CSize -> IO (Ptr a)
+
+foreign import ccall "malloc"
+ malloc3 :: CSize -> Show a => IO (Ptr a)
=====================================
testsuite/tests/ffi/should_fail/T16702.stderr
=====================================
@@ -0,0 +1,29 @@
+
+T16702.hs:12:1: error:
+ • Unacceptable result type in foreign declaration:
+ Unexpected nested forall
+ • When checking declaration:
+ foreign import ccall safe "math.h pow" c_pow
+ :: CDouble
+ -> forall (a :: Type). CDouble -> forall (b :: Type). CDouble
+
+T16702.hs:17:1: error:
+ • Unacceptable result type in foreign declaration:
+ Unexpected nested forall
+ • When checking declaration:
+ foreign import ccall safe "malloc" malloc1
+ :: CSize -> forall a. IO (Ptr a)
+
+T16702.hs:20:1: error:
+ • Unacceptable argument type in foreign declaration:
+ ‘Show a’ cannot be marshalled in a foreign call
+ • When checking declaration:
+ foreign import ccall safe "malloc" malloc2
+ :: Show a => CSize -> IO (Ptr a)
+
+T16702.hs:23:1: error:
+ • Unacceptable argument type in foreign declaration:
+ ‘Show a’ cannot be marshalled in a foreign call
+ • When checking declaration:
+ foreign import ccall safe "malloc" malloc3
+ :: CSize -> Show a => IO (Ptr a)
=====================================
testsuite/tests/ffi/should_fail/all.T
=====================================
@@ -14,6 +14,7 @@ test('T5664', normal, compile_fail, ['-v0'])
test('T7506', normal, compile_fail, [''])
test('T7243', normal, compile_fail, [''])
test('T10461', normal, compile_fail, [''])
+test('T16702', normal, compile_fail, [''])
# UnsafeReenter tests implementation of an undefined behavior (calling Haskell
# from an unsafe foreign function) and only makes sense in non-threaded way
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit f01473ed28e7c2700ff8e87b00ab87a802c9edd9
+Subproject commit 83bb9870a117f9426e6f6cff6fec3bb6e93a7c18
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/297cb6ab63d5d8e35a506e865620e96181fc88fa...3c8d1989a19faa65287c976fecfdbde96995d367
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/297cb6ab63d5d8e35a506e865620e96181fc88fa...3c8d1989a19faa65287c976fecfdbde96995d367
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/20190531/412026ed/attachment-0001.html>
More information about the ghc-commits
mailing list