...
 
Commits (232)
......@@ -107,6 +107,7 @@ _darcs/
/distrib/ghc.iss
/docs/man
/docs/index.html
/docs/users_guide/.log
/docs/users_guide/users_guide
/docs/users_guide/ghc.1
/docs/users_guide/flags.pyc
......@@ -227,7 +228,7 @@ ghc.nix/
.gdbinit
# Tooling - direnv
.envrc
.envrc
# Tooling - vscode
.vscode
This diff is collapsed.
#!/usr/bin/env python3
"""
Linters for testsuite makefiles
"""
from linter import run_linters, RegexpLinter
"""
Warn for use of `--interactive` inside Makefiles (#11468).
......@@ -7,13 +13,19 @@ Encourage the use of `$(TEST_HC_OPTS_INTERACTIVE)` instead of
`$(TEST_HC_OPTS) --interactive -ignore-dot-ghci -v0`. It's too easy to
forget one of those flags when adding a new test.
"""
from linter import run_linters, RegexpLinter
linters = [
interactive_linter = \
RegexpLinter(r'--interactive',
message = "Warning: Use `$(TEST_HC_OPTS_INTERACTIVE)` instead of `--interactive -ignore-dot-ghci -v0`."
).add_path_filter(lambda path: path.name == 'Makefile')
test_hc_quotes_linter = \
RegexpLinter('\t\\$\\(TEST_HC\\)',
message = "Warning: $(TEST_HC) should be quoted in Makefiles.",
).add_path_filter(lambda path: path.name == 'Makefile')
linters = [
interactive_linter,
test_hc_quotes_linter,
]
if __name__ == '__main__':
......
......@@ -98,11 +98,22 @@ def run_linters(linters: Sequence[Linter],
subdir: str = '.') -> None:
import argparse
parser = argparse.ArgumentParser()
parser.add_argument('base', help='Base commit')
parser.add_argument('head', help='Head commit')
subparsers = parser.add_subparsers()
subparser = subparsers.add_parser('commits', help='Lint a range of commits')
subparser.add_argument('base', help='Base commit')
subparser.add_argument('head', help='Head commit')
subparser.set_defaults(get_linted_files=lambda args:
get_changed_files(args.base, args.head, subdir))
subparser = subparsers.add_parser('files', help='Lint a range of commits')
subparser.add_argument('file', nargs='+', help='File to lint')
subparser.set_defaults(get_linted_files=lambda args: args.file)
args = parser.parse_args()
for path in get_changed_files(args.base, args.head, subdir):
linted_files = args.get_linted_files(args)
for path in linted_files:
if path.startswith('.gitlab/linters'):
continue
for linter in linters:
......
......@@ -23,6 +23,7 @@ BUILD_SPHINX_HTML=$BUILD_SPHINX_HTML
BUILD_SPHINX_PDF=$BUILD_SPHINX_PDF
BeConservative=YES
INTEGER_LIBRARY=$INTEGER_LIBRARY
XZ_CMD=pxz
EOF
cat <<EOF >> mk/build.mk
......
......@@ -195,6 +195,9 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
powerpc64le)
test -z "[$]2" || eval "[$]2=\"ArchPPC_64 {ppc_64ABI = ELF_V2}\""
;;
s390x)
test -z "[$]2" || eval "[$]2=ArchS390X"
;;
sparc)
test -z "[$]2" || eval "[$]2=ArchSPARC"
;;
......@@ -217,7 +220,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
mipsel)
test -z "[$]2" || eval "[$]2=ArchMipsel"
;;
hppa|hppa1_1|ia64|m68k|nios2|riscv32|riscv64|rs6000|s390|s390x|sh4|vax)
hppa|hppa1_1|ia64|m68k|nios2|riscv32|riscv64|rs6000|s390|sh4|vax)
test -z "[$]2" || eval "[$]2=ArchUnknown"
;;
*)
......@@ -842,6 +845,48 @@ AC_DEFUN([FP_CHECK_SIZEOF_AND_ALIGNMENT],
FP_CHECK_ALIGNMENT([$1])
])# FP_CHECK_SIZEOF_AND_ALIGNMENT
# FP_DEFAULT_CHOICE_OVERRIDE_CHECK(
# flag, name, anti name, var name, help string,
# [var true val], [var false val], [flag true val])
# ---------------------------------------------------
# Helper for when there is a automatic detection and an explicit flag for the
# user to override disable a feature, but not override enable a feature.
#
# $1 = flag of feature
# $2 = name of feature
# $3 = name of anti feature
# $4 = name of variable
# $5 = help string
# $6 = when true
# $7 = when false
# $8 = default explicit case (yes/no). Used for handle "backwards" legacy
# options where enabling makes fewer assumptions than disabling.
AC_DEFUN(
[FP_DEFAULT_CHOICE_OVERRIDE_CHECK],
[AC_ARG_ENABLE(
[$1],
[AC_HELP_STRING(
[--enable-$1],
[$5])],
[AS_IF(
[test x"$enableval" = x"m4_default([$8],yes)"],
[AS_CASE(
[x"$$4Default"],
[x"m4_default([$6],YES)"],
[AC_MSG_NOTICE([user chose $2 matching default for platform])],
[x"m4_default([$7],NO)"],
[AC_MSG_ERROR([user chose $2 overriding only supported option for platform])],
[AC_MSG_ERROR([invalid default])])
$4=m4_default([$6],YES)],
[AS_CASE(
[x"$$4Default"],
[x"m4_default([$6],YES)"],
[AC_MSG_NOTICE([user chose $3 overriding for platform])],
[x"m4_default([$7],NO)"],
[AC_MSG_NOTICE([user chose $3 matching default for platform])],
[AC_MSG_ERROR([invalid default])])
$4=m4_default([$7],NO)])],
[$4="$$4Default"])])
# FP_LEADING_UNDERSCORE
# ---------------------
......@@ -1270,55 +1315,41 @@ AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB],[
# FP_GCC_VERSION
# -----------
# Extra testing of the result AC_PROG_CC, testing the gcc version no. Sets the
# output variable GccVersion.
AC_DEFUN([FP_GCC_VERSION],
[AC_REQUIRE([AC_PROG_CC])
if test -z "$CC"
then
AC_MSG_ERROR([gcc is required])
fi
GccLT46=NO
AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version],
[
# Be sure only to look at the first occurrence of the "version " string;
# Some Apple compilers emit multiple messages containing this string.
fp_cv_gcc_version="`$CC -v 2>&1 | sed -n -e '1,/version /s/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/p'`"
FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.4],
[AC_MSG_ERROR([Need at least gcc version 4.4 (4.7+ recommended)])])
FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6], GccLT46=YES)
])
AC_SUBST([GccVersion], [$fp_cv_gcc_version])
AC_SUBST(GccLT46)
# (unsubstituted) output variable GccVersion.
AC_DEFUN([FP_GCC_VERSION], [
AC_REQUIRE([AC_PROG_CC])
if test -z "$CC"
then
AC_MSG_ERROR([gcc is required])
fi
AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version],
[
# Be sure only to look at the first occurrence of the "version " string;
# Some Apple compilers emit multiple messages containing this string.
fp_cv_gcc_version="`$CC -v 2>&1 | sed -n -e '1,/version /s/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/p'`"
FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6],
[AC_MSG_ERROR([Need at least gcc version 4.6 (4.7+ recommended)])])
])
GccVersion="$fp_cv_gcc_version"
])# FP_GCC_VERSION
dnl Check to see if the C compiler is clang or llvm-gcc
dnl
GccIsClang=NO
AC_DEFUN([FP_CC_LLVM_BACKEND],
[AC_REQUIRE([AC_PROG_CC])
AC_MSG_CHECKING([whether C compiler is clang])
$CC -x c /dev/null -dM -E > conftest.txt 2>&1
if grep "__clang__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [1])
AC_SUBST([CC_LLVM_BACKEND], [1])
GccIsClang=YES
AC_MSG_RESULT([yes])
else
AC_MSG_RESULT([no])
AC_MSG_CHECKING([whether C compiler has an LLVM back end])
if grep "__llvm__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [0])
AC_SUBST([CC_LLVM_BACKEND], [1])
AC_MSG_RESULT([yes])
else
AC_SUBST([CC_CLANG_BACKEND], [0])
AC_SUBST([CC_LLVM_BACKEND], [0])
AC_MSG_RESULT([no])
fi
fi
AC_SUBST(GccIsClang)
[AC_REQUIRE([AC_PROG_CC])
AC_MSG_CHECKING([whether C compiler has an LLVM back end])
$CC -x c /dev/null -dM -E > conftest.txt 2>&1
if grep "__llvm__" conftest.txt >/dev/null 2>&1; then
AC_DEFINE([CC_LLVM_BACKEND], [1], [Define (to 1) if C compiler has an LLVM back end])
CcLlvmBackend=YES
AC_MSG_RESULT([yes])
else
CcLlvmBackend=NO
AC_MSG_RESULT([no])
fi
AC_SUBST(CcLlvmBackend)
rm -f conftest.txt
rm -f conftest.txt
])
# FP_GCC_SUPPORTS__ATOMICS
......
......@@ -118,7 +118,7 @@ deriving instance Data (HsModule GhcPs)
deriving instance Data (HsModule GhcRn)
deriving instance Data (HsModule GhcTc)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where
instance (OutputableBndrId p) => Outputable (HsModule (GhcPass p)) where
ppr (HsModule Nothing _ imports decls _ mbDoc)
= pp_mb mbDoc $$ pp_nonnull imports
......
......@@ -11,6 +11,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
......@@ -617,17 +618,15 @@ Specifically,
it's just an error thunk
-}
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsLocalBindsLR idL idR) where
instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsLocalBindsLR (GhcPass pl) (GhcPass pr)) where
ppr (HsValBinds _ bs) = ppr bs
ppr (HsIPBinds _ bs) = ppr bs
ppr (EmptyLocalBinds _) = empty
ppr (XHsLocalBindsLR x) = ppr x
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsValBindsLR idL idR) where
instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where
ppr (ValBinds _ binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs)
......@@ -642,15 +641,15 @@ instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec"
pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)
=> LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL),
OutputableBndrId (GhcPass idR),
OutputableBndrId (GhcPass id2))
pprLHsBindsForUser :: (OutputableBndrId idL,
OutputableBndrId idR,
OutputableBndrId id2)
=> LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups
......@@ -725,12 +724,11 @@ plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsBindLR idL idR) where
instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where
ppr mbind = ppr_monobind mbind
ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)
=> HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
......@@ -766,16 +764,16 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
pprLHsBinds val_binds
ppr_monobind (XHsBindsLR x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where
instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)]
ppr (XABExport x) = ppr x
instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR,
Outputable (XXPatSynBind idL idR))
=> Outputable (PatSynBind idL idR) where
instance (OutputableBndrId l, OutputableBndrId r,
Outputable (XXPatSynBind (GhcPass l) (GhcPass r)))
=> Outputable (PatSynBind (GhcPass l) (GhcPass r)) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
= ppr_lhs <+> ppr_rhs
......@@ -866,13 +864,13 @@ data IPBind id
type instance XCIPBind (GhcPass p) = NoExtField
type instance XXIPBind (GhcPass p) = NoExtCon
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsIPBinds p) where
instance OutputableBndrId p
=> Outputable (HsIPBinds (GhcPass p)) where
ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (ppr ds)
ppr (XHsIPBinds x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where
instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
......@@ -1168,10 +1166,10 @@ signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap.
-}
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where
instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where
ppr sig = ppr_sig sig
ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc
ppr_sig :: (OutputableBndrId p) => Sig (GhcPass p) -> SDoc
ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig _ is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
......@@ -1204,8 +1202,8 @@ ppr_sig (CompleteMatchSig _ src cs mty)
opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
ppr_sig (XSig x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (FixitySig p) where
instance OutputableBndrId p
=> Outputable (FixitySig (GhcPass p)) where
ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]
where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
......
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE CPP, KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
......@@ -28,24 +29,24 @@ data MatchGroup (a :: *) (body :: *)
data GRHSs (a :: *) (body :: *)
data SyntaxExpr (i :: *)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p)
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p)
instance OutputableBndrId p => Outputable (HsExpr (GhcPass p))
instance OutputableBndrId p => Outputable (HsCmd (GhcPass p))
type LHsExpr a = Located (HsExpr a)
pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc
pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc
pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc
pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc
pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc
pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc
pprSpliceDecl :: (OutputableBndrId (GhcPass p))
pprSpliceDecl :: (OutputableBndrId p)
=> HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr),
OutputableBndrId (GhcPass p),
pprPatBind :: forall bndr p body. (OutputableBndrId bndr,
OutputableBndrId p,
Outputable body)
=> LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc
pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body)
pprFunBind :: (OutputableBndrId idR, Outputable body)
=> MatchGroup (GhcPass idR) body -> SDoc
......@@ -1162,13 +1162,13 @@ type OutputableX p = -- See Note [OutputableX]
-- ----------------------------------------------------------------------
-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both
-- the @id@ and the 'NameOrRdrName' type for it
type OutputableBndrId id =
( OutputableBndr (NameOrRdrName (IdP id))
, OutputableBndr (IdP id)
, OutputableBndr (NameOrRdrName (IdP (NoGhcTc id)))
, OutputableBndr (IdP (NoGhcTc id))
, NoGhcTc id ~ NoGhcTc (NoGhcTc id)
, OutputableX id
, OutputableX (NoGhcTc id)
-- the @p@ and the 'NameOrRdrName' type for it
type OutputableBndrId pass =
( OutputableBndr (NameOrRdrName (IdP (GhcPass pass)))
, OutputableBndr (IdP (GhcPass pass))
, OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass))))
, OutputableBndr (IdP (NoGhcTc (GhcPass pass)))
, NoGhcTc (GhcPass pass) ~ NoGhcTc (NoGhcTc (GhcPass pass))
, OutputableX (GhcPass pass)
, OutputableX (NoGhcTc (GhcPass pass))
)
......@@ -8,6 +8,7 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
......@@ -125,8 +126,8 @@ simpleImportDecl mn = ImportDecl {
ideclHiding = Nothing
}
instance (p ~ GhcPass pass,OutputableBndrId p)
=> Outputable (ImportDecl p) where
instance OutputableBndrId p
=> Outputable (ImportDecl (GhcPass p)) where
ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'
, ideclPkgQual = pkg
, ideclSource = from, ideclSafe = safe
......@@ -322,7 +323,7 @@ replaceWrappedName (IEType (L l _)) n = IEType (L l n)
replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2
replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')
instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where
instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
ppr (IEVar _ var) = ppr (unLoc var)
ppr (IEThingAbs _ thing) = ppr (unLoc thing)
ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"]
......
......@@ -9,6 +9,7 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
......@@ -227,7 +228,7 @@ instance Ord OverLitVal where
compare (HsIsString _ _) (HsFractional _) = GT
-- Instance specific to GhcPs, need the SourceText
instance p ~ GhcPass pass => Outputable (HsLit p) where
instance Outputable (HsLit (GhcPass p)) where
ppr (HsChar st c) = pprWithSourceText st (pprHsChar c)
ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c)
ppr (HsString st s) = pprWithSourceText st (pprHsString s)
......@@ -249,8 +250,8 @@ pp_st_suffix NoSourceText _ doc = doc
pp_st_suffix (SourceText st) suffix _ = text st <> suffix
-- in debug mode, print the expression that it's resolved to, too
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsOverLit p) where
instance OutputableBndrId p
=> Outputable (HsOverLit (GhcPass p)) where
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (whenPprDebug (parens (pprExpr witness)))
ppr (XOverLit x) = ppr x
......
......@@ -504,7 +504,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
************************************************************************
-}
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
ppr = pprPat
pprPatBndr :: OutputableBndr name => name -> SDoc
......@@ -516,11 +516,11 @@ pprPatBndr var -- Print with type info if -dppr-debug is on
else
pprPrefixOcc var
pprParendLPat :: (OutputableBndrId (GhcPass p))
pprParendLPat :: (OutputableBndrId p)
=> PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p = pprParendPat p . unLoc
pprParendPat :: (OutputableBndrId (GhcPass p))
pprParendPat :: (OutputableBndrId p)
=> PprPrec -> Pat (GhcPass p) -> SDoc
pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
if need_parens dflags pat
......@@ -535,7 +535,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
-- But otherwise the CoPat is discarded, so it
-- is the pattern inside that matters. Sigh.
pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar)
pprPat (WildPat _) = char '_'
pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat
......@@ -577,12 +577,12 @@ pprPat (ConPatOut { pat_con = con
pprPat (XPat x) = ppr x
pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
pprUserCon :: (OutputableBndr con, OutputableBndrId p)
=> con -> HsConPatDetails (GhcPass p) -> SDoc
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
pprConArgs :: (OutputableBndrId (GhcPass p))
pprConArgs :: (OutputableBndrId p)
=> HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
......@@ -696,7 +696,7 @@ looksLazyPat (VarPat {}) = False
looksLazyPat (WildPat {}) = False
looksLazyPat _ = True
isIrrefutableHsPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> Bool
isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool
-- (isIrrefutableHsPat p) is true if matching against p cannot fail,
-- in the sense of falling through to the next pattern.
-- (NB: this is not quite the same as the (silly) defn
......
{-# LANGUAGE CPP, KindSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module GHC.Hs.PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
......@@ -15,4 +16,4 @@ type role Pat nominal
data Pat (i :: *)
type LPat i = Pat i
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
instance (OutputableBndrId p) => Outputable (Pat (GhcPass p))
......@@ -901,8 +901,8 @@ data ConDeclField pass -- Record fields have Haddoc docs on them
type instance XConDeclField (GhcPass _) = NoExtField
type instance XXConDeclField (GhcPass _) = NoExtCon
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (ConDeclField p) where
instance OutputableBndrId p
=> Outputable (ConDeclField (GhcPass p)) where
ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
ppr (XConDeclField x) = ppr x
......@@ -1377,8 +1377,8 @@ data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass
| XFieldOcc
(XXFieldOcc pass)
deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p)
deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p)
deriving instance Eq (XCFieldOcc (GhcPass p)) => Eq (FieldOcc (GhcPass p))
deriving instance Ord (XCFieldOcc (GhcPass p)) => Ord (FieldOcc (GhcPass p))
type instance XCFieldOcc GhcPs = NoExtField
type instance XCFieldOcc GhcRn = Name
......@@ -1420,10 +1420,10 @@ type instance XAmbiguous GhcTc = Id
type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon
instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where
instance Outputable (AmbiguousFieldOcc (GhcPass p)) where
ppr = ppr . rdrNameAmbiguousFieldOcc
instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where
instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where
pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc
pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
......@@ -1459,30 +1459,30 @@ ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec
************************************************************************
-}
instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where
instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (LHsQTyVars p) where
instance OutputableBndrId p
=> Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
ppr (XLHsQTyVars x) = ppr x
instance (p ~ GhcPass pass, OutputableBndrId p)
=> Outputable (HsTyVarBndr p) where
instance OutputableBndrId p
=> Outputable (HsTyVarBndr (GhcPass p)) where
ppr (UserTyVar _ n) = ppr n
ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
ppr (XTyVarBndr nec) = noExtCon nec
instance (p ~ GhcPass pass,Outputable thing)
=> Outputable (HsImplicitBndrs p thing) where
instance Outputable thing
=> Outputable (HsImplicitBndrs (GhcPass p) thing) where
ppr (HsIB { hsib_body = ty }) = ppr ty
ppr (XHsImplicitBndrs x) = ppr x
instance (p ~ GhcPass pass,Outputable thing)
=> Outputable (HsWildCardBndrs p thing) where
instance Outputable thing
=> Outputable (HsWildCardBndrs (GhcPass p) thing) where
ppr (HsWC { hswc_body = ty }) = ppr ty
ppr (XHsWildCardBndrs x) = ppr x
......@@ -1491,7 +1491,7 @@ pprAnonWildCard = char '_'
-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@
-- only when @-dppr-debug@ is enabled.
pprHsForAll :: (OutputableBndrId (GhcPass p))
pprHsForAll :: (OutputableBndrId p)
=> ForallVisFlag -> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
pprHsForAll = pprHsForAllExtra Nothing
......@@ -1503,7 +1503,7 @@ pprHsForAll = pprHsForAllExtra Nothing
-- function for this is needed, as the extra-constraints wildcard is removed
-- from the actual context and type, and stored in a separate field, thus just
-- printing the type will not print the extra-constraints wildcard.
pprHsForAllExtra :: (OutputableBndrId (GhcPass p))
pprHsForAllExtra :: (OutputableBndrId p)
=> Maybe SrcSpan -> ForallVisFlag
-> [LHsTyVarBndr (GhcPass p)]
-> LHsContext (GhcPass p) -> SDoc
......@@ -1517,7 +1517,7 @@ pprHsForAllExtra extra fvf qtvs cxt
-- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print
-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing'
pprHsExplicitForAll :: (OutputableBndrId (GhcPass p))
pprHsExplicitForAll :: (OutputableBndrId p)
=> ForallVisFlag
-> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc
pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs
......@@ -1530,14 +1530,14 @@ ppr_forall_separator :: ForallVisFlag -> SDoc
ppr_forall_separator ForallVis = space <> arrow
ppr_forall_separator ForallInvis = dot
pprLHsContext :: (OutputableBndrId (GhcPass p))
pprLHsContext :: (OutputableBndrId p)
=> LHsContext (GhcPass p) -> SDoc
pprLHsContext lctxt
| null (unLoc lctxt) = empty
| otherwise = pprLHsContextAlways lctxt
-- For use in a HsQualTy, which always gets printed if it exists.
pprLHsContextAlways :: (OutputableBndrId (GhcPass p))
pprLHsContextAlways :: (OutputableBndrId p)
=> LHsContext (GhcPass p) -> SDoc
pprLHsContextAlways (L _ ctxt)
= case ctxt of
......@@ -1546,7 +1546,7 @@ pprLHsContextAlways (L _ ctxt)
_ -> parens (interpp'SP ctxt) <+> darrow
-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@
pprLHsContextExtra :: (OutputableBndrId (GhcPass p))
pprLHsContextExtra :: (OutputableBndrId p)
=> Bool -> LHsContext (GhcPass p) -> SDoc
pprLHsContextExtra show_extra lctxt@(L _ ctxt)
| not show_extra = pprLHsContext lctxt
......@@ -1555,7 +1555,7 @@ pprLHsContextExtra show_extra lctxt@(L _ ctxt)
where
ctxt' = map ppr ctxt ++ [char '_']
pprConDeclFields :: (OutputableBndrId (GhcPass p))
pprConDeclFields :: (OutputableBndrId p)
=> [LConDeclField (GhcPass p)] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
......@@ -1581,13 +1581,13 @@ seems like the Right Thing anyway.)
-- Printing works more-or-less as for Types
pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
pprHsType ty = ppr_mono_ty ty
ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc
ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc
ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc
ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })
= sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty]
......@@ -1644,7 +1644,7 @@ ppr_mono_ty (HsDocTy _ ty doc)
ppr_mono_ty (XHsType t) = ppr t
--------------------------
ppr_fun_ty :: (OutputableBndrId (GhcPass p))
ppr_fun_ty :: (OutputableBndrId p)
=> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc
ppr_fun_ty ty1 ty2
= let p1 = ppr_mono_lty ty1
......
......@@ -1040,8 +1040,8 @@ collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmt
collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
where
collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat
collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
collectArgBinders _ = []
collectStmtBinders (XStmtLR nec) = noExtCon nec
......@@ -1344,8 +1344,8 @@ lStmtsImplicits = hs_lstmts
-> [(SrcSpan, [Name])]
hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat
do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts
where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
do_arg (_, XApplicativeArg nec) = noExtCon nec
hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds)
hs_stmt (BodyStmt {}) = []
......
This diff is collapsed.
This diff is collapsed.
......@@ -53,6 +53,7 @@ import Type
import TyCon
import Literal
import CoreSyn
import CoreMap
import CoreUtils (exprType)
import PrelNames
import TysWiredIn
......@@ -440,23 +441,31 @@ instance Outputable a => Outputable (SharedDIdEnv a) where
-- entries are possibly shared when we figure out that two variables must be
-- equal, thus represent the same set of values.
--
-- See Note [TmState invariants].
newtype TmState = TmSt (SharedDIdEnv VarInfo)
-- Deterministic so that we generate deterministic error messages
-- See Note [TmState invariants] in Oracle.
data TmState
= TmSt
{ ts_facts :: !(SharedDIdEnv VarInfo)
-- ^ Facts about term variables. Deterministic env, so that we generate
-- deterministic error messages.
, ts_reps :: !(CoreMap Id)
-- ^ An environment for looking up whether we already encountered semantically
-- equivalent expressions that we want to represent by the same 'Id'
-- representative.
}
-- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@,
-- and negative ('vi_neg') facts, like "x is not (:)".
-- Also caches the type ('vi_ty'), the 'PossibleMatches' of a COMPLETE set
-- ('vi_cache').
--
-- Subject to Note [The Pos/Neg invariant].
-- Subject to Note [The Pos/Neg invariant] in PmOracle.
data VarInfo
= VI
{ vi_ty :: !Type
-- ^ The type of the variable. Important for rejecting possible GADT
-- constructors or incompatible pattern synonyms (@Just42 :: Maybe Int@).
, vi_pos :: [(PmAltCon, [Id])]
, vi_pos :: ![(PmAltCon, [Id])]
-- ^ Positive info: 'PmAltCon' apps it is (i.e. @x ~ [Just y, PatSyn z]@), all
-- at the same time (i.e. conjunctive). We need a list because of nested
-- pattern matches involving pattern synonym
......@@ -488,16 +497,16 @@ data VarInfo
-- | Not user-facing.
instance Outputable TmState where
ppr (TmSt state) = ppr state
ppr (TmSt state reps) = ppr state $$ ppr reps
-- | Not user-facing.
instance Outputable VarInfo where
ppr (VI ty pos neg cache)
= braces (hcat (punctuate comma [ppr ty, ppr pos, ppr neg, ppr cache]))
-- | Initial state of the oracle.
-- | Initial state of the term oracle.
initTmState :: TmState
initTmState = TmSt emptySDIE
initTmState = TmSt emptySDIE emptyCoreMap
-- | The type oracle state. A poor man's 'TcSMonad.InsertSet': The invariant is
-- that all constraints in there are mutually compatible.
......
......@@ -12,6 +12,7 @@ import Reg
import qualified GHC.Platform.ARM as ARM
import qualified GHC.Platform.ARM64 as ARM64
import qualified GHC.Platform.PPC as PPC
import qualified GHC.Platform.S390X as S390X
import qualified GHC.Platform.SPARC as SPARC
import qualified GHC.Platform.X86 as X86
import qualified GHC.Platform.X86_64 as X86_64
......@@ -27,6 +28,7 @@ callerSaves platform
= case platformArch platform of
ArchX86 -> X86.callerSaves
ArchX86_64 -> X86_64.callerSaves
ArchS390X -> S390X.callerSaves
ArchSPARC -> SPARC.callerSaves
ArchARM {} -> ARM.callerSaves
ArchARM64 -> ARM64.callerSaves
......@@ -48,6 +50,7 @@ activeStgRegs platform
= case platformArch platform of
ArchX86 -> X86.activeStgRegs
ArchX86_64 -> X86_64.activeStgRegs
ArchS390X -> S390X.activeStgRegs
ArchSPARC -> SPARC.activeStgRegs
ArchARM {} -> ARM.activeStgRegs
ArchARM64 -> ARM64.activeStgRegs
......@@ -64,6 +67,7 @@ haveRegBase platform
= case platformArch platform of
ArchX86 -> X86.haveRegBase
ArchX86_64 -> X86_64.haveRegBase
ArchS390X -> S390X.haveRegBase
ArchSPARC -&