[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: TH: fix Show/Eq/Ord instances for Bytes (#16457)
Marge Bot
gitlab at gitlab.haskell.org
Tue Apr 28 11:59:58 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
99823ed2 by Sylvain Henry at 2020-04-27T20:24:46-04:00
TH: fix Show/Eq/Ord instances for Bytes (#16457)
We shouldn't compare pointer values but the actual bytes.
- - - - -
c62271a2 by Alp Mestanogullari at 2020-04-27T20:25:33-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.
- - - - -
5259eef1 by Ryan Scott at 2020-04-28T07:59:52-04:00
Define a Quote IO instance
Fixes #18103.
- - - - -
47b2e153 by Ryan Scott at 2020-04-28T07:59:53-04:00
Make boxed 1-tuples have known keys
Unlike other tuples, which use special syntax and are "known" by way
of a special `isBuiltInOcc_maybe` code path, boxed 1-tuples do not
use special syntax. Therefore, in order to make sure that the
internals of GHC are aware of the `data Unit a = Unit a` definition
in `GHC.Tuple`, we give `Unit` known keys. For the full details, see
`Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)`
in `GHC.Builtin.Types`.
Fixes #18097.
- - - - -
15 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Builtin/Utils.hs
- hadrian/src/Builder.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- + testsuite/tests/quotes/T18103.hs
- testsuite/tests/quotes/TH_localname.stderr
- testsuite/tests/quotes/all.T
- + testsuite/tests/th/T18097.hs
- + testsuite/tests/th/TH_BytesShowEqOrd.hs
- + testsuite/tests/th/TH_BytesShowEqOrd.stdout
- testsuite/tests/th/all.T
- testsuite/tests/typecheck/should_compile/holes.stderr
- testsuite/tests/typecheck/should_compile/holes3.stderr
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -111,6 +111,10 @@ by the user. For those things that *can* appear in source programs,
See also Note [Built-in syntax and the OrigNameCache]
+Note that one-tuples are an exception to the rule, as they do get assigned
+known keys. See
+Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
+in GHC.Builtin.Types.
Note [The integer library]
~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -71,7 +71,7 @@ module GHC.Builtin.Types (
-- * Tuples
mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,
- tupleTyCon, tupleDataCon, tupleTyConName,
+ tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,
promotedTupleDataCon,
unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,
pairTyCon,
@@ -725,9 +725,13 @@ for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations:
data Unit a = Unit a
data (a,b) = (a,b)
-There is no way to write a boxed one-tuple in Haskell, but it can be
-created in Template Haskell or in, e.g., `deriving` code. There is
-nothing special about one-tuples in Core; in particular, they have no
+There is no way to write a boxed one-tuple in Haskell using tuple syntax.
+They can, however, be written using other methods:
+
+1. They can be written directly by importing them from GHC.Tuple.
+2. They can be generated by way of Template Haskell or in `deriving` code.
+
+There is nothing special about one-tuples in Core; in particular, they have no
custom pretty-printing, just using `Unit`.
Note that there is *not* a unary constraint tuple, unlike for other forms of
@@ -737,6 +741,29 @@ details.
See also Note [Flattening one-tuples] in GHC.Core.Make and
Note [Don't flatten tuples from HsSyn] in GHC.Core.Make.
+-----
+-- Wrinkle: Make boxed one-tuple names have known keys
+-----
+
+We make boxed one-tuple names have known keys so that `data Unit a = Unit a`,
+defined in GHC.Tuple, will be used when one-tuples are spliced in through
+Template Haskell. This program (from #18097) crucially relies on this:
+
+ case $( tupE [ [| "ok" |] ] ) of Unit x -> putStrLn x
+
+Unless Unit has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an
+ExplicitTuple of length 1) will not match the type of Unit (an ordinary
+data constructor used in a pattern). Making Unit known-key allows GHC to make
+this connection.
+
+Unlike Unit, every other tuple is /not/ known-key
+(see Note [Infinite families of known-key names] in GHC.Builtin.Names). The
+main reason for this exception is that other tuples are written with special
+syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe`
+function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache).
+In contrast, Unit is just an ordinary data type with no special syntax, so it
+doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Unit
+known-key is the next-best way to teach the internals of the compiler about it.
-}
-- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names
@@ -760,6 +787,8 @@ isBuiltInOcc_maybe occ =
"->" -> Just funTyConName
-- boxed tuple data/tycon
+ -- We deliberately exclude Unit (the boxed 1-tuple).
+ -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
"()" -> Just $ tup_name Boxed 0
_ | Just rest <- "(" `BS.stripPrefix` name
, (commas, rest') <- BS.span (==',') rest
@@ -889,6 +918,9 @@ tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one
tupleDataCon Boxed i = snd (boxedTupleArr ! i)
tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)
+tupleDataConName :: Boxity -> Arity -> Name
+tupleDataConName sort i = dataConName (tupleDataCon sort i)
+
boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]]
unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]
=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -59,6 +59,7 @@ import GHC.Core.Opt.ConstantFold
import GHC.Types.Avail
import GHC.Builtin.PrimOps
import GHC.Core.DataCon
+import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Env
@@ -124,14 +125,17 @@ knownKeyNames
= all_names
where
all_names =
+ -- We exclude most tuples from this list—see
+ -- Note [Infinite families of known-key names] in GHC.Builtin.Names.
+ -- We make an exception for Unit (i.e., the boxed 1-tuple), since it does
+ -- not use special syntax like other tuples.
+ -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
+ -- in GHC.Builtin.Types.
+ tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 :
concat [ wired_tycon_kk_names funTyCon
, concatMap wired_tycon_kk_names primTyCons
-
, concatMap wired_tycon_kk_names wiredInTyCons
- -- Does not include tuples
-
, concatMap wired_tycon_kk_names typeNatTyCons
-
, map idName wiredInIds
, map (idName . primOpId) allThePrimOps
, map (idName . primOpWrapperId) allThePrimOps
=====================================
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
-----------------------------------------------------
--
@@ -122,8 +125,7 @@ class (MonadIO m, MonadFail m) => Quasi m where
-----------------------------------------------------
instance Quasi IO where
- qNewName s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
- ; pure (mkNameU s n) }
+ qNewName = newNameIO
qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
@@ -150,6 +152,13 @@ instance Quasi IO where
qIsExtEnabled _ = badIO "isExtEnabled"
qExtsEnabled = badIO "extsEnabled"
+instance Quote IO where
+ newName = newNameIO
+
+newNameIO :: String -> IO Name
+newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x))
+ ; pure (mkNameU s n) }
+
badIO :: String -> IO a
badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
; fail "Template Haskell failure" }
@@ -1868,7 +1877,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/quotes/T18103.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module T18103 where
+
+import Language.Haskell.TH
+
+ex :: IO [Dec]
+ex = [d| foo x = x |]
=====================================
testsuite/tests/quotes/TH_localname.stderr
=====================================
@@ -7,8 +7,10 @@ TH_localname.hs:3:11: error:
x :: t0 -> m0 Language.Haskell.TH.Syntax.Exp
(bound at TH_localname.hs:3:1)
Probable fix: use a type annotation to specify what ‘m0’ should be.
- These potential instance exist:
- one instance involving out-of-scope types
+ These potential instances exist:
+ instance Language.Haskell.TH.Syntax.Quote IO
+ -- Defined in ‘Language.Haskell.TH.Syntax’
+ ...plus one instance involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the expression:
[| y |]
=====================================
testsuite/tests/quotes/all.T
=====================================
@@ -17,6 +17,7 @@ test('T9824', normal, compile, ['-v0'])
test('T10384', normal, compile_fail, [''])
test('T16384', req_th, compile, [''])
test('T17857', normal, compile, [''])
+test('T18103', normal, compile, [''])
test('TH_tf2', normal, compile, ['-v0'])
test('TH_ppr1', normal, compile_and_run, [''])
=====================================
testsuite/tests/th/T18097.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T18097 where
+
+import Language.Haskell.TH
+import GHC.Tuple
+
+f = case $( tupE [ [| "ok" |] ] ) of Unit x -> putStrLn x
+g = case Unit "ok" of $( tupP [ [p| x |] ] ) -> putStrLn x
+
+h :: $( tupleT 1 ) String
+h = Unit "ok"
+
+i :: Unit String
+i = $( tupE [ [| "ok" |] ] )
=====================================
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
=====================================
@@ -502,5 +502,7 @@ test('T17511', normal, compile, [''])
test('T17608', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T17688a', normal, compile, [''])
test('T17688b', normal, compile, [''])
+test('T18097', normal, compile, [''])
test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
test('TH_StringLift', normal, compile, [''])
+test('TH_BytesShowEqOrd', normal, compile_and_run, [''])
=====================================
testsuite/tests/typecheck/should_compile/holes.stderr
=====================================
@@ -90,6 +90,7 @@ holes.hs:11:15: warning: [-Wtyped-holes (in -Wdefault)]
Nothing :: forall a. Maybe a
Just :: forall a. a -> Maybe a
[] :: forall a. [a]
+ Unit :: forall a. a -> Unit a
asTypeOf :: forall a. a -> a -> a
id :: forall a. a -> a
until :: forall a. (a -> Bool) -> (a -> a) -> a -> a
=====================================
testsuite/tests/typecheck/should_compile/holes3.stderr
=====================================
@@ -93,6 +93,7 @@ holes3.hs:11:15: error:
Nothing :: forall a. Maybe a
Just :: forall a. a -> Maybe a
[] :: forall a. [a]
+ Unit :: forall a. a -> Unit a
asTypeOf :: forall a. a -> a -> a
id :: forall a. a -> a
until :: forall a. (a -> Bool) -> (a -> a) -> a -> a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e74b9ee22e2523141a898cdddf27f0bad398cfb9...47b2e1530fb0758de4b394f23da78c13b178e706
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e74b9ee22e2523141a898cdddf27f0bad398cfb9...47b2e1530fb0758de4b394f23da78c13b178e706
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/20200428/3caaa4fd/attachment-0001.html>
More information about the ghc-commits
mailing list