[Git][ghc/ghc][wip/update-directory] 5 commits: compiler: Fix pretty printing of ticked prefix constructors (#24237)
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Wed Aug 21 09:32:44 UTC 2024
Matthew Pickering pushed to branch wip/update-directory at Glasgow Haskell Compiler / GHC
Commits:
5f972bfb by Zubin Duggal at 2024-08-21T03:18:15-04:00
compiler: Fix pretty printing of ticked prefix constructors (#24237)
- - - - -
ef0a08e7 by Mike Pilgrem at 2024-08-21T03:18:57-04:00
Fix #15773 Clarify further -rtsopts 'defaults' in docs
- - - - -
05a4be58 by Sebastian Graf at 2024-08-21T03:19:33-04:00
Improve efficiency of `assertError` (#24625)
... by moving `lazy` to the exception-throwing branch.
It's all documented in `Note [Strictness of assertError]`.
- - - - -
a300f12c by Sylvain Henry at 2024-08-21T09:32:36+00:00
JS: add basic support for POSIX *at functions (#25190)
openat/fstatat/unlinkat/dup are now used in the recent release of the
`directory` and `file-io` packages.
As such, these functions are (indirectly) used in the following tests
one we'll bump the `directory` submodule (see !13122):
- openFile008
- jsOptimizer
- T20509
- bkpcabal02
- bkpcabal03
- bkpcabal04
- - - - -
b0d6d279 by Matthew Pickering at 2024-08-21T09:32:36+00:00
Update directory submodule to latest master
The primary reason for this bump is to fix the warning from `ghc-pkg
check`:
```
Warning: include-dirs: /data/home/ubuntu/.ghcup/ghc/9.6.2/lib/ghc-9.6.2/lib/../lib/aarch64-linux-ghc-9.6.2/directory-1.3.8.1/include doesn't exist or isn't a directory
```
This also requires adding the `file-io` package as a boot library (which
is discussed in #25145)
Fixes #23594 #25145
- - - - -
17 changed files:
- .gitmodules
- compiler/GHC/Iface/Type.hs
- docs/users_guide/9.12.1-notes.rst
- docs/users_guide/phases.rst
- hadrian/src/Packages.hs
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Default.hs
- libraries/directory
- + libraries/file-io
- libraries/ghc-internal/jsbits/base.js
- libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- + testsuite/tests/printer/T24237.hs
- + testsuite/tests/printer/T24237.stderr
- testsuite/tests/printer/all.T
- + testsuite/tests/simplCore/should_compile/T24625.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
.gitmodules
=====================================
@@ -118,3 +118,6 @@
[submodule "hadrian/vendored/Cabal"]
path = hadrian/vendored/Cabal
url = https://gitlab.haskell.org/ghc/packages/Cabal.git
+[submodule "libraries/file-io"]
+ path = libraries/file-io
+ url = https://gitlab.haskell.org/ghc/packages/file-io.git
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1847,17 +1847,16 @@ ppr_iface_tc_app pp ctxt_prec tc tys =
| tc `ifaceTyConHasKey` liftedTypeKindTyConKey
-> ppr_kind_type ctxt_prec
- | not (isSymOcc (nameOccName (ifaceTyConName tc)))
- -> pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
+ | isSymOcc (nameOccName (ifaceTyConName tc))
- | [ ty1@(_, Required), ty2@(_, Required) ] <- tys
+ , [ ty1@(_, Required), ty2@(_, Required) ] <- tys
-- Infix, two visible arguments (we know nothing of precedence though).
-- Don't apply this special case if one of the arguments is invisible,
-- lest we print something like (@LiftedRep -> @LiftedRep) (#15941).
- -> pprIfaceInfixApp ctxt_prec (ppr tc) (pp opPrec ty1) (pp opPrec ty2)
+ -> pprIfaceInfixApp ctxt_prec (pprIfaceTyCon tc) (pp opPrec ty1) (pp opPrec ty2)
| otherwise
- -> pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
+ -> pprIfacePrefixApp ctxt_prec (pprParendIfaceTyCon tc) (map (pp appPrec) tys)
data TupleOrSum = IsSum | IsTuple TupleSort
deriving (Eq)
@@ -2070,7 +2069,18 @@ instance Outputable IfLclName where
ppr = ppr . ifLclNameFS
instance Outputable IfaceTyCon where
- ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
+ ppr = pprIfaceTyCon
+
+-- | Print an `IfaceTyCon` with a promotion tick if needed, without parens,
+-- suitable for use in infix contexts
+pprIfaceTyCon :: IfaceTyCon -> SDoc
+pprIfaceTyCon tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
+
+-- | Print an `IfaceTyCon` with a promotion tick if needed, possibly with parens,
+-- suitable for use in prefix contexts
+pprParendIfaceTyCon :: IfaceTyCon -> SDoc
+pprParendIfaceTyCon tc = pprPromotionQuote tc <> pprPrefixVar (isSymOcc (nameOccName tc_name)) (ppr tc_name)
+ where tc_name = ifaceTyConName tc
instance Outputable IfaceTyConInfo where
ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom
=====================================
docs/users_guide/9.12.1-notes.rst
=====================================
@@ -222,3 +222,4 @@ for further change information.
libraries/Win32/Win32.cabal: Dependency of ``ghc`` library
libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable
libraries/os-string/os-string.cabal: Dependency of ``filepath`` library
+ libraries/file-io/file-io.cabal: Dependency of ``directory`` library
=====================================
docs/users_guide/phases.rst
=====================================
@@ -1151,8 +1151,9 @@ for example).
:shortdesc: Control whether the RTS behaviour can be tweaked via command-line
flags and the ``GHCRTS`` environment variable. Using ``none``
means no RTS flags can be given; ``some`` means only a minimum
- of safe options can be given (the default); ``all`` (or no
- argument at all) means that all RTS flags are permitted; ``ignore``
+ of safe options can be given (the default, if ``-rtsopts`` is
+ not passed); ``all`` means that all RTS flags are permitted (the
+ default, if ``-rtsopts`` is passed with no argument); ``ignore``
means RTS flags can be given, but are treated as regular arguments and
passed to the Haskell program as arguments; ``ignoreAll`` is the same as
``ignore``, but ``GHCRTS`` is also ignored. ``-rtsopts`` does not
@@ -1161,11 +1162,12 @@ for example).
:type: dynamic
:category: linking
- :default: some
+ :default: ``some``, if ``-rtsopts`` is not passed; ``all``, if ``-rtsopts``
+ is passed with no argument.
This option affects the processing of RTS control options given
either on the command line or via the :envvar:`GHCRTS` environment
- variable. There are five possibilities:
+ variable. There are six possibilities:
``-rtsopts=none``
Disable all processing of RTS options. If ``+RTS`` appears
@@ -1181,18 +1183,22 @@ for example).
``GHCRTS`` options will be processed normally.
``-rtsopts=ignoreAll``
- Same as ``ignore`` but also ignores ``GHCRTS``.
+ Same as ``ignore`` with the exception of ``GHCRTS`` options, which are
+ also ignored.
``-rtsopts=some``
- [this is the default setting] Enable only the "safe" RTS
- options: (Currently only ``-?`` and ``--info``.) Any other RTS
- options on the command line or in the ``GHCRTS`` environment
- variable causes the program with to abort with an error message.
+ [this is the default setting, if ``-rtsopts`` is not passed] Enable only
+ the "safe" RTS options: (Currently only ``-?`` and ``--info``.) Any
+ other RTS options on the command line or in the ``GHCRTS`` environment
+ variable causes the program to abort with an error message.
- ``-rtsopts=all`` or just ``-rtsopts``
+ ``-rtsopts=all``
Enable *all* RTS option processing, both on the command line and
through the ``GHCRTS`` environment variable.
+ ``-rtsopts``
+ Equivalent to ``-rtsopts=all``.
+
In GHC 6.12.3 and earlier, the default was to process all RTS
options. However, since RTS options can be used to write logging
data to arbitrary files under the security context of the running
=====================================
hadrian/src/Packages.hs
=====================================
@@ -4,7 +4,7 @@ module Packages (
array, base, binary, bytestring, cabal, cabalSyntax, checkPpr,
checkExact, countDeps,
compareSizes, compiler, containers, deepseq, deriveConstants, directory, dumpDecls,
- exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, ghcBootThNext, ghcPlatform,
+ exceptions, filepath, fileio, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, ghcBootThNext, ghcPlatform,
ghcCompact, ghcConfig, ghcExperimental, ghcHeap, ghcInternal, ghci, ghciWrapper, ghcPkg, ghcPrim,
ghcToolchain, ghcToolchainBin, haddockApi, haddockLibrary, haddock, haskeline,
hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy,
@@ -40,7 +40,7 @@ ghcPackages =
, ghcToolchain, ghcToolchainBin, haddockApi, haddockLibrary, haddock, haskeline, hsc2hs
, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, mtl, osString
, parsec, pretty, process, rts, runGhc, stm, semaphoreCompat, templateHaskell
- , terminfo, text, time, transformers, unlit, unix, win32, xhtml
+ , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio
, timeout
, lintersCommon
, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
@@ -79,6 +79,7 @@ directory = lib "directory"
dumpDecls = util "dump-decls"
exceptions = lib "exceptions"
filepath = lib "filepath"
+fileio = lib "file-io"
genapply = util "genapply"
genprimopcode = util "genprimopcode"
ghc = prg "ghc-bin" `setPath` "ghc"
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -138,6 +138,7 @@ toolTargets = [ cabalSyntax
, directory
, process
, filepath
+ , fileio
, osString
-- , ghc -- # depends on ghc library
-- , runGhc -- # depends on ghc library
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -83,8 +83,9 @@ stage0Packages = do
return $ [ cabalSyntax
, cabal
, compiler
- , directory -- depends on filepath
+ , directory -- depends on filepath, fileIo
, filepath -- depends on os-string
+ , fileio
, ghc
, ghcBoot
, ghcBootThNext
=====================================
libraries/directory
=====================================
@@ -1 +1 @@
-Subproject commit a97a8a8f30d652f972192122fd5f459a147c13e5
+Subproject commit 6045b93c4ef7a713c8f3d6837ca69f8e96b12bf1
=====================================
libraries/file-io
=====================================
@@ -0,0 +1 @@
+Subproject commit a4a0464ccd38e8380c202949a90b21d9e592aeef
=====================================
libraries/ghc-internal/jsbits/base.js
=====================================
@@ -138,6 +138,126 @@ function h$base_fstat(fd, stat, stat_off, c) {
h$unsupported(-1, c);
}
+function h$stat(path, path_off, stat, stat_off) {
+#ifndef GHCJS_BROWSER
+ if(h$isNode()) {
+ try {
+ var stats = h$fs.statSync(h$decodeUtf8z(path, path_off));
+ h$base_fillStat(stats, stat, stat_off);
+ return 0;
+ } catch(e) {
+ h$setErrno(e);
+ return -1;
+ }
+ }
+ else
+#endif
+ h$unsupported(-1);
+}
+
+function h$lstat(path, path_off, stat, stat_off) {
+#ifndef GHCJS_BROWSER
+ if(h$isNode()) {
+ try {
+ var stats = h$fs.lstatSync(h$decodeUtf8z(path, path_off));
+ h$base_fillStat(stats, stat, stat_off);
+ return 0;
+ } catch(e) {
+ h$setErrno(e);
+ return -1;
+ }
+ }
+ else
+#endif
+ h$unsupported(-1);
+}
+
+function h$fstatat(dirfd, path, path_off, stat, stat_off, flag) {
+#ifndef GHCJS_BROWSER
+ if(h$isNode()) {
+ var fp = h$calculate_at(dirfd, path, path_off);
+ try {
+ if (flag & h$base_at_symlink_nofollow) {
+ var fs = h$fs.lstatSync(fp);
+ h$base_fillStat(fs, stat, stat_off);
+ return 0;
+ }
+ else {
+ var fs = h$fs.statSync(fp);
+ h$base_fillStat(fs, stat, stat_off);
+ return 0;
+ }
+
+ } catch(e) {
+ h$setErrno(e);
+ return -1;
+ }
+ }
+#endif
+
+ return h$unsupported(-1);
+}
+
+function h$unlinkat(dirfd, path, path_off, flag) {
+#ifndef GHCJS_BROWSER
+ if(h$isNode()) {
+ var fp = h$calculate_at(dirfd, path, path_off);
+ try {
+ if (flag & h$base_at_removedir) {
+ h$fs.rmdirSync(fp);
+ return 0;
+ }
+ else {
+ h$fs.unlinkSync(fp);
+ return 0;
+ }
+
+ } catch(e) {
+ h$setErrno(e);
+ return -1;
+ }
+ }
+#endif
+
+ return h$unsupported(-1);
+}
+
+function h$dup(fd) {
+#ifndef GHCJS_BROWSER
+ if(h$isNode()) {
+ try {
+ // NodeJS doesn't provide "dup" (see
+ // https://github.com/nodejs/node/issues/41733), so we do this hack that
+ // probably only works on Linux.
+ return h$fs.openSync("/proc/self/fd/"+fd);
+ } catch(e) {
+ h$setErrno(e);
+ return -1;
+ }
+ }
+ else
+#endif
+ h$unsupported(-1);
+}
+
+function h$fdopendir(fd) {
+#ifndef GHCJS_BROWSER
+ if(h$isNode()) {
+ try {
+ // NodeJS doesn't provide "fdopendir", so we do this hack that probably
+ // only works on Linux.
+ return h$fs.opendirSync("/proc/self/fd/"+fd);
+ } catch(e) {
+ h$setErrno(e);
+ return -1;
+ }
+ }
+ else
+#endif
+ h$unsupported(-1);
+}
+
+
function h$base_isatty(fd) {
TRACE_IO("base_isatty " + fd)
// return 1; // fixme debug
@@ -333,25 +453,55 @@ function h$realpath(path,off,resolved,resolved_off) {
h$unsupported(-1);
}
-function h$base_open(file, file_off, how, mode, c) {
- return h$open(file,file_off,how,mode,c);
+function h$path_is_abs(path) {
+ return path.charAt(0) === '/';
}
-function h$openat(dirfd, file, file_off, how, mode) {
- if (dirfd != h$base_at_fdcwd) {
- // we only support AT_FDWCD (open) until NodeJS provides "openat"
- return h$unsupported(-1);
+function h$path_join2(p1,p2) {
+ // Emscripten would normalize the path here. We don't for now.
+ return (p1 + '/' + p2);
+}
+
+// Compute path from a FD and a path
+function h$calculate_at(dirfd, file, file_off) {
+ var path = h$decodeUtf8z(file,file_off);
+
+ if (h$path_is_abs(path)) {
+ return path;
+ }
+
+ // relative path
+ var dir;
+ if (dirfd == h$base_at_fdcwd) {
+ dir = h$process.cwd();
}
+#ifndef GHCJS_BROWSER
+ else if (h$isNode()) {
+ // hack that probably only works on Linux with /proc mounted
+ dir = h$fs.readlinkSync("/proc/self/fd/"+dirfd);
+ }
+#endif
else {
- return h$open(file,file_off,how,mode,undefined);
+ return h$unsupported(-1);
}
+
+ return h$path_join2(dir,path);
+}
+
+function h$openat(dirfd, file, file_off, how, mode, c) {
+ var path = h$calculate_at(dirfd, file, file_off);
+ return h$base_open(path, how, mode, c);
+}
+
+function h$open(file, file_off, how, mode, c) {
+ var path = h$decodeUtf8z(file, file_off);
+ return h$base_open(path, how, mode, c);
}
-function h$open(file, file_off, how, mode,c) {
+function h$base_open(fp, how, mode, c) {
#ifndef GHCJS_BROWSER
if(h$isNode()) {
var flags, off;
- var fp = h$decodeUtf8z(file, file_off);
TRACE_IO("open: " + fp)
var acc = how & h$base_o_accmode;
// passing a number lets node.js use it directly as the flags (undocumented)
@@ -586,6 +736,9 @@ const h$base_o_noctty = 0x20000;
const h$base_o_nonblock = 0x00004;
const h$base_o_binary = 0x00000;
const h$base_at_fdcwd = -100;
+const h$base_at_symlink_nofollow = 0x100;
+const h$base_at_removedir = 0x200;
+const h$base_at_symlink_follow = 0x400;
function h$base_stat_check_mode(mode,p) {
=====================================
libraries/ghc-internal/src/GHC/Internal/IO/Exception.hs
=====================================
@@ -438,13 +438,10 @@ instance Show IOException where
"" -> id
_ -> showString " (" . showString s . showString ")")
--- Note the use of "lazy". This means that
--- assert False (throw e)
--- will throw the assertion failure rather than e. See trac #5561.
assertError :: (?callStack :: CallStack) => Bool -> a -> a
assertError predicate v
- | predicate = lazy v
- | otherwise = unsafeDupablePerformIO $ do
+ | predicate = v
+ | otherwise = lazy $ unsafeDupablePerformIO $ do -- lazy: See Note [Strictness of assertError]
ccsStack <- currentCallStack
let
implicitParamCallStack = prettyCallStackLines ?callStack
@@ -452,6 +449,44 @@ assertError predicate v
stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack
throwIO (AssertionFailed ("Assertion failed\n" ++ stack))
+{- Note [Strictness of assertError]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is vital that Demand Analysis does not see `assertError p e` as strict in e.
+#5561 details what happens otherwise, tested by libraries/base/tests/assert.hs:
+
+ let e1 i = throw Overflow
+ in assertError False (e1 5)
+
+This should *not* throw the Overflow exception; rather it should throw an
+AssertionError.
+Hence we use GHC.Exts.lazy to make assertError appear lazy in e, so that it
+is not called by-value.
+(Note that the reason we need `lazy` in the first place is that error has a
+bottoming result, which is strict in all free variables.)
+The way we achieve this is a bit subtle; before #24625 we defined it as
+
+ assertError p e | p = lazy e
+ | otherwise = error "assertion"
+
+but this means that in the following example (full code in T24625) we cannot
+cancel away the allocation of `Just x` because of the intervening `lazy`:
+
+ case assertError False (Just x) of Just y -> y
+ ==> { simplify }
+ case lazy (Just x) of Just y -> y
+
+Instead, we put `lazy` in the otherwise branch, thus
+
+ assertError p e | p = e
+ | otherwise = lazy $ error "assertion"
+
+The effect on #5561 is the same: since the otherwise branch appears lazy in e,
+the overall demand on `e` must be lazy as well.
+Furthermore, since there is no intervening `lazy` on the expected code path,
+the Simplifier may perform case-of-case on e and simplify the `Just x` example
+to `x`.
+-}
+
unsupportedOperation :: IOError
unsupportedOperation =
(IOError Nothing UnsupportedOperation ""
@@ -480,4 +515,3 @@ untangle coded message
_ -> (loc, "")
}
not_bar c = c /= '|'
-
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
=====================================
@@ -537,11 +537,11 @@ foreign import javascript interruptible "h$base_lseek"
c_lseek :: CInt -> COff -> CInt -> IO COff
foreign import javascript interruptible "h$base_lstat"
lstat :: CFilePath -> Ptr CStat -> IO CInt
-foreign import javascript interruptible "h$base_open"
+foreign import javascript interruptible "h$open"
c_open :: CFilePath -> CInt -> CMode -> IO CInt
-foreign import javascript interruptible "h$base_open"
+foreign import javascript interruptible "h$open"
c_interruptible_open_ :: CFilePath -> CInt -> CMode -> IO CInt
-foreign import javascript interruptible "h$base_open"
+foreign import javascript interruptible "h$open"
c_safe_open_ :: CFilePath -> CInt -> CMode -> IO CInt
foreign import javascript interruptible "h$base_read"
c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
=====================================
testsuite/tests/printer/T24237.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE DataKinds #-}
+{-# OPTIONS_GHC -fprint-redundant-promotion-ticks #-}
+module T24237 where
+
+import Data.Proxy
+
+foo :: Proxy '(:)
+foo = ()
=====================================
testsuite/tests/printer/T24237.stderr
=====================================
@@ -0,0 +1,7 @@
+T24237.hs:8:7: error: [GHC-83865]
+ • Couldn't match expected type ‘Proxy '(:)’ with actual type ‘()’
+ • In the expression: ()
+ In an equation for ‘foo’: foo = ()
+ • Relevant bindings include
+ foo :: Proxy '(:) (bound at T24237.hs:8:1)
+
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -210,3 +210,5 @@ test('Test24753', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24753'])
test('Test24771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24771'])
test('Test24159', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24159'])
test('Test25132', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25132'])
+
+test('T24237', normal, compile_fail, [''])
=====================================
testsuite/tests/simplCore/should_compile/T24625.hs
=====================================
@@ -0,0 +1,14 @@
+module T24625 where
+
+import GHC.IO.Exception
+import GHC.Exts
+
+data Foo = Foo !Int !Int String
+
+true :: Bool
+true = True
+{-# NOINLINE true #-}
+
+function :: Int -> Int -> String -> Int
+function !a !b c = case assertError true (Foo a b c) of
+ Foo a b c -> a + b
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -526,5 +526,6 @@ test('T24808', [ grep_errmsg(r'myFunction') ], compile, ['-O -ddump-simpl'])
# T24944 needs -O2 because it's about SpecConstr
test('T24944', [extra_files(['T24944a.hs'])], multimod_compile, ['T24944', '-v0 -O2'])
+test('T24625', [ grep_errmsg(r'case lazy') ], compile, ['-O -fno-ignore-asserts -ddump-simpl -dsuppress-uniques'])
test('T24725a', [ grep_errmsg(r'testedRule')], compile, ['-O -ddump-rule-firings'])
test('T25033', normal, compile, ['-O'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/20d0623abcec8846e4fee5fabe9e32cf4e7562f9...b0d6d279335b28a7e388f0a1815a79179c4c6e1b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/20d0623abcec8846e4fee5fabe9e32cf4e7562f9...b0d6d279335b28a7e388f0a1815a79179c4c6e1b
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/20240821/fb4ab83f/attachment-0001.html>
More information about the ghc-commits
mailing list