[Git][ghc/ghc][wip/backports] 4 commits: Fix two ASSERT buglets in reifyDataCon
Ben Gamari
gitlab at gitlab.haskell.org
Thu May 14 19:05:54 UTC 2020
Ben Gamari pushed to branch wip/backports at Glasgow Haskell Compiler / GHC
Commits:
9eb3f663 by Ryan Scott at 2020-05-14T15:05:48-04:00
Fix two ASSERT buglets in reifyDataCon
Two `ASSERT`s in `reifyDataCon` were always using `arg_tys`, but
`arg_tys` is not meaningful for GADT constructors. In fact, it's
worse than non-meaningful, since using `arg_tys` when reifying a
GADT constructor can lead to failed `ASSERT`ions, as #17305
demonstrates.
This patch applies the simplest possible fix to the immediate
problem. The `ASSERT`s now use `r_arg_tys` instead of `arg_tys`, as
the former makes sure to give something meaningful for GADT
constructors. This makes the panic go away at the very least. There
is still an underlying issue with the way the internals of
`reifyDataCon` work, as described in
https://gitlab.haskell.org/ghc/ghc/issues/17305#note_227023, but we
leave that as future work, since fixing the underlying issue is
much trickier (see
https://gitlab.haskell.org/ghc/ghc/issues/17305#note_227087).
(cherry picked from commit cfb66d181ac45ce3d934bda3521b94277e6eb683)
- - - - -
f30e8941 by Adam Gundry at 2020-05-14T15:05:48-04:00
Reject all duplicate declarations involving DuplicateRecordFields (fixes #17965)
This fixes a bug that resulted in some programs being accepted that used the same
identifier as a field label and another declaration, depending on the order they
appeared in the source code.
(cherry picked from commit 0d8c7a6c7c3513089668f49efb0a2dd8b4bbe74a)
- - - - -
4061ff3c by Ben Gamari at 2020-05-14T15:05:48-04:00
Ensure that printMinimalImports closes handle
Fixes #18166.
(cherry picked from commit 5afc160dee7142c96a842037fb64bee1429ad9ec)
- - - - -
29ca4c51 by Ben Gamari at 2020-05-14T15:05:48-04:00
rts: Make non-existent linker search path merely a warning
As noted in #18105, previously this resulted in a rather intrusive error
message. This is in contrast to the general expectation that search
paths are merely places to look, not places that must exist.
Fixes #18105.
(cherry picked from commit 24af9f30681444380c25465f555599da563713cb)
- - - - -
10 changed files:
- compiler/basicTypes/RdrName.hs
- compiler/rename/RnNames.hs
- compiler/typecheck/TcSplice.hs
- rts/linker/PEi386.c
- + testsuite/tests/overloadedrecflds/should_fail/T17965.hs
- + testsuite/tests/overloadedrecflds/should_fail/T17965.stderr
- testsuite/tests/overloadedrecflds/should_fail/all.T
- + testsuite/tests/th/T17305.hs
- + testsuite/tests/th/T17305.stderr
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/basicTypes/RdrName.hs
=====================================
@@ -57,7 +57,7 @@ module RdrName (
gresToAvailInfo,
-- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
- GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel,
+ GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel,
unQualOK, qualSpecOK, unQualSpecOK,
pprNameProvenance,
Parent(..), greParent_maybe,
@@ -842,6 +842,12 @@ isRecFldGRE :: GlobalRdrElt -> Bool
isRecFldGRE (GRE {gre_par = FldParent{}}) = True
isRecFldGRE _ = False
+isOverloadedRecFldGRE :: GlobalRdrElt -> Bool
+-- ^ Is this a record field defined with DuplicateRecordFields?
+-- (See Note [Parents for record fields])
+isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}}) = True
+isOverloadedRecFldGRE _ = False
+
-- Returns the field label of this GRE, if it has one
greLabel :: GlobalRdrElt -> Maybe FieldLabelString
greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl
=====================================
compiler/rename/RnNames.hs
=====================================
@@ -635,9 +635,12 @@ extendGlobalRdrEnvRn avails new_fixities
| otherwise
= return (extendGlobalRdrEnv env gre)
where
- name = gre_name gre
- occ = nameOccName name
- dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)
+ occ = greOccName gre
+ dups = filter isDupGRE (lookupGlobalRdrEnv env occ)
+ -- Duplicate GREs are those defined locally with the same OccName,
+ -- except cases where *both* GREs are DuplicateRecordFields (#17965).
+ isDupGRE gre' = isLocalGRE gre'
+ && not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre')
{- *********************************************************************
@@ -1611,9 +1614,8 @@ printMinimalImports imports_w_usage
= do { imports' <- getMinimalImports imports_w_usage
; this_mod <- getModule
; dflags <- getDynFlags
- ; liftIO $
- do { h <- openFile (mkFilename dflags this_mod) WriteMode
- ; printForUser dflags h neverQualify (vcat (map ppr imports')) }
+ ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h ->
+ printForUser dflags h neverQualify (vcat (map ppr imports'))
-- The neverQualify is important. We are printing Names
-- but they are in the context of an 'import' decl, and
-- we never qualify things inside there
@@ -1769,14 +1771,13 @@ addDupDeclErr gres@(gre : _)
= addErrAt (getSrcSpan (last sorted_names)) $
-- Report the error at the later location
vcat [text "Multiple declarations of" <+>
- quotes (ppr (nameOccName name)),
+ quotes (ppr (greOccName gre)),
-- NB. print the OccName, not the Name, because the
-- latter might not be in scope in the RdrEnv and so will
-- be printed qualified.
text "Declared at:" <+>
vcat (map (ppr . nameSrcLoc) sorted_names)]
where
- name = gre_name gre
sorted_names = sortWith nameSrcLoc (map gre_name gres)
=====================================
compiler/typecheck/TcSplice.hs
=====================================
@@ -1645,7 +1645,7 @@ reifyDataCon isGadtDataCon tys dc
-- constructors can be declared infix.
-- See Note [Infix GADT constructors] in TcTyClsDecls.
| dataConIsInfix dc && not isGadtDataCon ->
- ASSERT( arg_tys `lengthIs` 2 ) do
+ ASSERT( r_arg_tys `lengthIs` 2 ) do
{ let [r_a1, r_a2] = r_arg_tys
[s1, s2] = dcdBangs
; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
@@ -1664,7 +1664,7 @@ reifyDataCon isGadtDataCon tys dc
{ cxt <- reifyCxt theta'
; ex_tvs'' <- reifyTyVars ex_tvs'
; return (TH.ForallC ex_tvs'' cxt main_con) }
- ; ASSERT( arg_tys `equalLength` dcdBangs )
+ ; ASSERT( r_arg_tys `equalLength` dcdBangs )
ret_con }
{-
=====================================
rts/linker/PEi386.c
=====================================
@@ -776,12 +776,12 @@ HsPtr addLibrarySearchPath_PEi386(pathchar* dll_path)
WCHAR* abs_path = malloc(sizeof(WCHAR) * init_buf_size);
DWORD wResult = GetFullPathNameW(dll_path, bufsize, abs_path, NULL);
if (!wResult){
- sysErrorBelch("addLibrarySearchPath[GetFullPathNameW]: %" PATH_FMT " (Win32 error %lu)", dll_path, GetLastError());
+ IF_DEBUG(linker, debugBelch("addLibrarySearchPath[GetFullPathNameW]: %" PATH_FMT " (Win32 error %lu)", dll_path, GetLastError()));
}
else if (wResult > init_buf_size) {
abs_path = realloc(abs_path, sizeof(WCHAR) * wResult);
if (!GetFullPathNameW(dll_path, bufsize, abs_path, NULL)) {
- sysErrorBelch("addLibrarySearchPath[GetFullPathNameW]: %" PATH_FMT " (Win32 error %lu)", dll_path, GetLastError());
+ IF_DEBUG(linker, debugBelch("addLibrarySearchPath[GetFullPathNameW]: %" PATH_FMT " (Win32 error %lu)", dll_path, GetLastError()));
}
}
=====================================
testsuite/tests/overloadedrecflds/should_fail/T17965.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+main = return ()
+newtype Record a = Record { f :: a -> a }
+class C a where f :: a -> a
=====================================
testsuite/tests/overloadedrecflds/should_fail/T17965.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T17965.hs:4:17: error:
+ Multiple declarations of âfâ
+ Declared at: T17965.hs:3:29
+ T17965.hs:4:17
=====================================
testsuite/tests/overloadedrecflds/should_fail/all.T
=====================================
@@ -32,3 +32,4 @@ test('hasfieldfail03', normal, compile_fail, [''])
test('T14953', [extra_files(['T14953_A.hs', 'T14953_B.hs'])],
multimod_compile_fail, ['T14953', ''])
test('DuplicateExports', normal, compile_fail, [''])
+test('T17965', normal, compile_fail, [''])
=====================================
testsuite/tests/th/T17305.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module T17305 where
+
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+import System.IO
+
+data family Foo a
+data instance Foo :: Type -> Type where
+ MkFoo :: Foo a
+
+$(do i <- reify ''Foo
+ runIO $ hPutStrLn stderr $ pprint i
+ pure [])
=====================================
testsuite/tests/th/T17305.stderr
=====================================
@@ -0,0 +1,3 @@
+data family T17305.Foo (a_0 :: *) :: *
+data instance T17305.Foo where
+ T17305.MkFoo :: forall (a_1 :: *) . T17305.Foo a_1
=====================================
testsuite/tests/th/all.T
=====================================
@@ -489,6 +489,7 @@ test('T16980a', expect_broken(16980), compile_fail, [''])
test('T17270a', extra_files(['T17270.hs']), multimod_compile, ['T17270', '-v0'])
test('T17270b', extra_files(['T17270.hs']), multimod_compile, ['T17270', '-fenable-th-splice-warnings -v0'])
test('T17296', normal, compile, ['-v0'])
+test('T17305', normal, compile, ['-v0'])
test('T17380', normal, compile_fail, [''])
test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T17379a', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3697a0480bf86f06dcbb0021ef65963de7e2278b...29ca4c5121f1b1b08417bc6b87bc7915a20fdd42
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3697a0480bf86f06dcbb0021ef65963de7e2278b...29ca4c5121f1b1b08417bc6b87bc7915a20fdd42
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/20200514/12c15ddc/attachment-0001.html>
More information about the ghc-commits
mailing list