hadrian/src/Builder.hs

-{-# 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

+{-# 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

+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, [''])