[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: TH: fix Show/Eq/Ord instances for Bytes (#16457)
Marge Bot
gitlab at gitlab.haskell.org
Mon Apr 27 15:34:34 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
cb4dbc0c by Sylvain Henry at 2020-04-27T11:34:24-04:00
TH: fix Show/Eq/Ord instances for Bytes (#16457)
We shouldn't compare pointer values but the actual bytes.
- - - - -
e74b9ee2 by Alp Mestanogullari at 2020-04-27T11:34:29-04:00
hadrian: always capture both stdout and stderr when running a builder fails
The idea being that when a builder('s command) fails, we quite likely want to
have all the information available to figure out why. Depending on the builder
_and_ the particular problem, the useful bits of information can be printed
on stdout or stderr.
We accomplish this by defining a simple wrapper for Shake's `cmd` function,
that just _always_ captures both streams in case the command returns a non-zero
exit code, and by using this wrapper everywhere in `hadrian/src/Builder.hs`.
Fixes #18089.
- - - - -
6 changed files:
- hadrian/src/Builder.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- + testsuite/tests/th/TH_BytesShowEqOrd.hs
- + testsuite/tests/th/TH_BytesShowEqOrd.stdout
- testsuite/tests/th/all.T
Changes:
=====================================
hadrian/src/Builder.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE InstanceSigs, TypeOperators #-}
module Builder (
-- * Data types
ArMode (..), CcMode (..), ConfigurationInfo (..), GhcMode (..),
@@ -14,7 +14,9 @@ module Builder (
applyPatch
) where
+import Control.Exception.Extra (Partial)
import Development.Shake.Classes
+import Development.Shake.Command
import GHC.Generics
import qualified Hadrian.Builder as H
import Hadrian.Builder hiding (Builder)
@@ -214,7 +216,7 @@ instance H.Builder Builder where
needBuilder builder
path <- H.builderPath builder
need [path]
- Stdout stdout <- cmd [path] ["--no-user-package-db", "field", input, "depends"]
+ Stdout stdout <- cmd' [path] ["--no-user-package-db", "field", input, "depends"]
return stdout
_ -> error $ "Builder " ++ show builder ++ " can not be asked!"
@@ -231,7 +233,7 @@ instance H.Builder Builder where
echo = EchoStdout (verbosity >= Loud)
-- Capture stdout and write it to the output file.
captureStdout = do
- Stdout stdout <- cmd [path] buildArgs
+ Stdout stdout <- cmd' [path] buildArgs
writeFileChanged output stdout
case builder of
Ar Pack _ -> do
@@ -239,54 +241,54 @@ instance H.Builder Builder where
if useTempFile then runAr path buildArgs
else runArWithoutTempFile path buildArgs
- Ar Unpack _ -> cmd echo [Cwd output] [path] buildArgs
+ Ar Unpack _ -> cmd' echo [Cwd output] [path] buildArgs
- Autoreconf dir -> cmd echo [Cwd dir] ["sh", path] buildArgs
+ Autoreconf dir -> cmd' echo [Cwd dir] ["sh", path] buildArgs
Configure dir -> do
-- Inject /bin/bash into `libtool`, instead of /bin/sh,
-- otherwise Windows breaks. TODO: Figure out why.
bash <- bashPath
let env = AddEnv "CONFIG_SHELL" bash
- cmd echo env [Cwd dir] ["sh", path] buildOptions buildArgs
+ cmd' echo env [Cwd dir] ["sh", path] buildOptions buildArgs
GenApply -> captureStdout
GenPrimopCode -> do
stdin <- readFile' input
- Stdout stdout <- cmd (Stdin stdin) [path] buildArgs
+ Stdout stdout <- cmd' (Stdin stdin) [path] buildArgs
writeFileChanged output stdout
GhcPkg Copy _ -> do
- Stdout pkgDesc <- cmd [path]
+ Stdout pkgDesc <- cmd' [path]
[ "--expand-pkgroot"
, "--no-user-package-db"
, "describe"
, input -- the package name
]
- cmd (Stdin pkgDesc) [path] (buildArgs ++ ["-"])
+ cmd' (Stdin pkgDesc) [path] (buildArgs ++ ["-"])
GhcPkg Unregister _ -> do
- Exit _ <- cmd echo [path] (buildArgs ++ [input])
+ Exit _ <- cmd' echo [path] (buildArgs ++ [input])
return ()
HsCpp -> captureStdout
- Make dir -> cmd echo path ["-C", dir] buildArgs
+ Make dir -> cmd' echo path ["-C", dir] buildArgs
Makeinfo -> do
- cmd echo [path] "--no-split" [ "-o", output] [input]
+ cmd' echo [path] "--no-split" [ "-o", output] [input]
Xelatex -> do
- unit $ cmd [Cwd output] [path] buildArgs
- unit $ cmd [Cwd output] [path] buildArgs
- unit $ cmd [Cwd output] [path] buildArgs
- unit $ cmd [Cwd output] ["makeindex"] (input -<.> "idx")
- unit $ cmd [Cwd output] [path] buildArgs
- unit $ cmd [Cwd output] [path] buildArgs
+ unit $ cmd' [Cwd output] [path] buildArgs
+ unit $ cmd' [Cwd output] [path] buildArgs
+ unit $ cmd' [Cwd output] [path] buildArgs
+ unit $ cmd' [Cwd output] ["makeindex"] (input -<.> "idx")
+ unit $ cmd' [Cwd output] [path] buildArgs
+ unit $ cmd' [Cwd output] [path] buildArgs
- Tar _ -> cmd buildOptions echo [path] buildArgs
- _ -> cmd echo [path] buildArgs
+ Tar _ -> cmd' buildOptions echo [path] buildArgs
+ _ -> cmd' echo [path] buildArgs
-- TODO: Some builders are required only on certain platforms. For example,
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
@@ -366,4 +368,9 @@ applyPatch dir patch = do
needBuilder Patch
path <- builderPath Patch
putBuild $ "| Apply patch " ++ file
- quietly $ cmd [Cwd dir, FileStdin file] [path, "-p0"]
+ quietly $ cmd' [Cwd dir, FileStdin file] [path, "-p0"]
+
+-- | Wrapper for 'cmd' that makes sure we include both stdout and stderr in
+-- Shake's output when any of our builder commands fail.
+cmd' :: (Partial, CmdArguments args) => args :-> Action r
+cmd' = cmd [WithStderr True, WithStdout True]
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -45,12 +45,15 @@ import GHC.Generics ( Generic )
import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..),
TYPE, RuntimeRep(..) )
import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# )
+import GHC.Ptr ( Ptr, plusPtr )
import GHC.Lexeme ( startsVarSym, startsVarId )
import GHC.ForeignSrcLang.Type
import Language.Haskell.TH.LanguageExtensions
import Numeric.Natural
import Prelude
import Foreign.ForeignPtr
+import Foreign.C.String
+import Foreign.C.Types
-----------------------------------------------------
--
@@ -1868,7 +1871,45 @@ data Bytes = Bytes
-- , bytesInitialized :: Bool -- ^ False: only use `bytesSize` to allocate
-- -- an uninitialized region
}
- deriving (Eq,Ord,Data,Generic,Show)
+ deriving (Data,Generic)
+
+-- We can't derive Show instance for Bytes because we don't want to show the
+-- pointer value but the actual bytes (similarly to what ByteString does). See
+-- #16457.
+instance Show Bytes where
+ show b = unsafePerformIO $ withForeignPtr (bytesPtr b) $ \ptr ->
+ peekCStringLen ( ptr `plusPtr` fromIntegral (bytesOffset b)
+ , fromIntegral (bytesSize b)
+ )
+
+-- We can't derive Eq and Ord instances for Bytes because we don't want to
+-- compare pointer values but the actual bytes (similarly to what ByteString
+-- does). See #16457
+instance Eq Bytes where
+ (==) = eqBytes
+
+instance Ord Bytes where
+ compare = compareBytes
+
+eqBytes :: Bytes -> Bytes -> Bool
+eqBytes a@(Bytes fp off len) b@(Bytes fp' off' len')
+ | len /= len' = False -- short cut on length
+ | fp == fp' && off == off' = True -- short cut for the same bytes
+ | otherwise = compareBytes a b == EQ
+
+compareBytes :: Bytes -> Bytes -> Ordering
+compareBytes (Bytes _ _ 0) (Bytes _ _ 0) = EQ -- short cut for empty Bytes
+compareBytes (Bytes fp1 off1 len1) (Bytes fp2 off2 len2) =
+ unsafePerformIO $
+ withForeignPtr fp1 $ \p1 ->
+ withForeignPtr fp2 $ \p2 -> do
+ i <- memcmp (p1 `plusPtr` fromIntegral off1)
+ (p2 `plusPtr` fromIntegral off2)
+ (fromIntegral (min len1 len2))
+ return $! (i `compare` 0) <> (len1 `compare` len2)
+
+foreign import ccall unsafe "memcmp"
+ memcmp :: Ptr a -> Ptr b -> CSize -> IO CInt
-- | Pattern in Haskell given in @{}@
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -10,6 +10,12 @@
and `unTypeQ` are also generalised in terms of `Quote` rather than specific
to `Q`.
+ * Fix Eq/Ord instances for `Bytes`: we were comparing pointers while we should
+ compare the actual bytes (#16457).
+
+ * Fix Show instance for `Bytes`: we were showing the pointer value while we
+ want to show the contents (#16457).
+
## 2.16.0.0 *TBA*
* Add support for tuple sections. (#15843) The type signatures of `TupE` and
=====================================
testsuite/tests/th/TH_BytesShowEqOrd.hs
=====================================
@@ -0,0 +1,40 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
+
+module Main where
+
+import Language.Haskell.TH.Lib
+import GHC.Ptr
+import Foreign.ForeignPtr
+
+main :: IO ()
+main = do
+
+ let
+ !x = "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz"#
+ !y = "ABCDEabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz"#
+
+ p1 <- newForeignPtr_ (Ptr x)
+ p2 <- newForeignPtr_ (Ptr y)
+
+ let
+ b1 = mkBytes p1 0 5
+ b2 = mkBytes p1 10 5
+ b3 = mkBytes p1 26 5
+ b4 = mkBytes p2 5 5
+ b5 = mkBytes p2 10 5
+
+ let myCmp a b = putStrLn $ "compare " ++ show a ++ " to " ++ show b ++ " => " ++ show (compare a b)
+
+ putStr "same pointer, same offset, same bytes: "
+ myCmp b1 b1
+ putStr "same pointer, different offset, same bytes: "
+ myCmp b1 b3
+ putStr "same pointer, different offset, different bytes: "
+ myCmp b1 b2
+ putStr "same pointer, different offset, different bytes: "
+ myCmp b2 b1
+ putStr "different pointer, different offset, same bytes: "
+ myCmp b1 b4
+ putStr "different pointer, different offset, different bytes: "
+ myCmp b1 b5
=====================================
testsuite/tests/th/TH_BytesShowEqOrd.stdout
=====================================
@@ -0,0 +1,6 @@
+same pointer, same offset, same bytes: compare abcde to abcde => EQ
+same pointer, different offset, same bytes: compare abcde to abcde => EQ
+same pointer, different offset, different bytes: compare abcde to klmno => LT
+same pointer, different offset, different bytes: compare klmno to abcde => GT
+different pointer, different offset, same bytes: compare abcde to abcde => EQ
+different pointer, different offset, different bytes: compare abcde to fghij => LT
=====================================
testsuite/tests/th/all.T
=====================================
@@ -504,3 +504,4 @@ test('T17688a', normal, compile, [''])
test('T17688b', normal, compile, [''])
test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
test('TH_StringLift', normal, compile, [''])
+test('TH_BytesShowEqOrd', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/22bf5c738e0339fa12940414d6448896c6733808...e74b9ee22e2523141a898cdddf27f0bad398cfb9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/22bf5c738e0339fa12940414d6448896c6733808...e74b9ee22e2523141a898cdddf27f0bad398cfb9
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/20200427/25f8cc8f/attachment-0001.html>
More information about the ghc-commits
mailing list