[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 13 commits: Display FFI labels (fix #18539)
Marge Bot
gitlab at gitlab.haskell.org
Fri Dec 11 18:29:32 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
381eb660 by Sylvain Henry at 2020-12-11T12:57:35-05:00
Display FFI labels (fix #18539)
- - - - -
4548d1f8 by Aaron Allen at 2020-12-11T12:58:14-05:00
Elide extraneous messages for :doc command (#15784)
Do not print `<has no documentation>` alongside a valid doc.
Additionally, if two matching symbols lack documentation then the
message will only be printed once. Hence, `<has no documentation>` will
be printed at most once and only if all matching symbols are lacking
docs.
- - - - -
5eba91b6 by Aaron Allen at 2020-12-11T12:58:14-05:00
Add :doc test case for duplicate record fields
Tests that the output of the `:doc` command is correct for duplicate
record fields defined using -XDuplicateRecordFields.
- - - - -
e9d4d651 by Ryan Scott at 2020-12-11T13:29:06-05:00
Delete outdated Note [Kind-checking tyvar binders for associated types]
This Note has severely bitrotted, as it has no references anywhere in the
codebase, and none of the functions that it mentions exist anymore. Let's just
delete this. While I was in town, I deleted some outdated comments from
`checkFamPatBinders` of a similar caliber.
Fixes #19008.
[ci skip]
- - - - -
35ad9b32 by Sylvain Henry at 2020-12-11T13:29:08-05:00
Arrows: correctly query arrow methods (#17423)
Consider the following code:
proc (C x y) -> ...
Before this patch, the evidence binding for the Arrow dictionary was
attached to the C pattern:
proc (C x y) { $dArrow = ... } -> ...
But then when we desugar this, we use arrow operations ("arr", ">>>"...)
specialised for this arrow:
let
arr_xy = arr $dArrow -- <-- Not in scope!
...
in
arr_xy (\(C x y) { $dArrow = ... } -> ...)
This patch allows arrow operations to be type-checked before the proc
itself, avoiding this issue.
Fix #17423
- - - - -
2e1a3ea3 by Sylvain Henry at 2020-12-11T13:29:09-05:00
Validate script: fix configure command when using stack
- - - - -
3ce19314 by Sylvain Henry at 2020-12-11T13:29:11-05:00
Hadrian: fix libffi tarball parsing
Fix parsing of "libffi-3.3.tar.gz".
NB: switch to a newer libffi isn't done in this patch
- - - - -
042e0745 by Sylvain Henry at 2020-12-11T13:29:13-05:00
Parser: move parser utils into their own module
Move code unrelated to runtime evaluation out of GHC.Runtime.Eval
- - - - -
7bf4421a by Sylvain Henry at 2020-12-11T13:29:15-05:00
Move SizedSeq into ghc-boot
- - - - -
ccbac10d by Sylvain Henry at 2020-12-11T13:29:15-05:00
ghci: don't compile unneeded modules
- - - - -
d5c3cbff by Sylvain Henry at 2020-12-11T13:29:15-05:00
ghci: reuse Arch from ghc-boot
- - - - -
c4a46af9 by Sylvain Henry at 2020-12-11T13:29:17-05:00
rts: don't use siginterrupt (#19019)
- - - - -
fde4be6d by Sylvain Henry at 2020-12-11T13:29:19-05:00
Use static array in zeroCount
- - - - -
30 changed files:
- compiler/GHC.hs
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- + compiler/GHC/Parser/Utils.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- hadrian/src/Rules/Libffi.hs
- libraries/base/GHC/Float/ConversionUtils.hs
- libraries/ghci/SizedSeq.hs → libraries/ghc-boot/GHC/Data/SizedSeq.hs
- libraries/ghc-boot/GHC/Platform/ArchOS.hs
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghci/GHCi/CreateBCO.hs
- libraries/ghci/GHCi/InfoTable.hsc
- libraries/ghci/GHCi/ResolvedBCO.hs
- libraries/ghci/ghci.cabal.in
- rts/posix/Signals.c
- testsuite/tests/gadt/T17423.hs → testsuite/tests/arrows/should_compile/T17423.hs
- testsuite/tests/arrows/should_compile/all.T
- testsuite/tests/gadt/all.T
- testsuite/tests/ghci/scripts/ghci065.hs
- testsuite/tests/ghci/scripts/ghci065.script
- testsuite/tests/ghci/scripts/ghci065.stdout
- testsuite/tests/numeric/should_compile/all.T
- validate
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -325,6 +325,7 @@ import qualified GHC.Parser as Parser
import GHC.Parser.Lexer
import GHC.Parser.Annotation
import GHC.Parser.Errors.Ppr
+import GHC.Parser.Utils
import GHC.Iface.Load ( loadSysInterface )
import GHC.Hs
@@ -1347,6 +1348,18 @@ getPackageModuleInfo hsc_env mdl
minf_modBreaks = emptyModBreaks
}))
+availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
+availsToGlobalRdrEnv mod_name avails
+ = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
+ where
+ -- We're building a GlobalRdrEnv as if the user imported
+ -- all the specified modules into the global interactive module
+ imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
+ decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
+ is_qual = False,
+ is_dloc = srcLocSpan interactiveSrcLoc }
+
+
getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env mdl =
case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -41,12 +41,11 @@ import GHC.Utils.Misc
import GHC.Core.TyCon
import GHC.Data.FastString
+import GHC.Data.SizedSeq
+
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Platform
--- From iserv
-import SizedSeq
-
import Control.Monad
import Control.Monad.ST ( runST )
import Control.Monad.Trans.Class
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -26,7 +26,6 @@ import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray
-import SizedSeq
import GHC.Builtin.PrimOps
@@ -34,6 +33,7 @@ import GHC.Unit.Types
import GHC.Unit.Module.Name
import GHC.Data.FastString
+import GHC.Data.SizedSeq
import GHC.Utils.Panic
import GHC.Utils.Outputable
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -17,12 +17,12 @@ module GHC.ByteCode.Types
import GHC.Prelude
import GHC.Data.FastString
+import GHC.Data.SizedSeq
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Utils.Outputable
import GHC.Builtin.PrimOps
-import SizedSeq
import GHC.Core.Type
import GHC.Types.SrcLoc
import GHCi.BreakArray
=====================================
compiler/GHC/Parser/Utils.hs
=====================================
@@ -0,0 +1,58 @@
+module GHC.Parser.Utils
+ ( isStmt
+ , hasImport
+ , isImport
+ , isDecl
+ )
+where
+
+import GHC.Prelude
+import GHC.Hs
+import GHC.Data.StringBuffer
+import GHC.Data.FastString
+import GHC.Types.SrcLoc
+
+import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)
+import GHC.Parser.Lexer (ParserOpts)
+import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport)
+
+
+-- | Returns @True@ if passed string is a statement.
+isStmt :: ParserOpts -> String -> Bool
+isStmt pflags stmt =
+ case parseThing Parser.parseStmt pflags stmt of
+ Lexer.POk _ _ -> True
+ Lexer.PFailed _ -> False
+
+-- | Returns @True@ if passed string has an import declaration.
+hasImport :: ParserOpts -> String -> Bool
+hasImport pflags stmt =
+ case parseThing Parser.parseModule pflags stmt of
+ Lexer.POk _ thing -> hasImports thing
+ Lexer.PFailed _ -> False
+ where
+ hasImports = not . null . hsmodImports . unLoc
+
+-- | Returns @True@ if passed string is an import declaration.
+isImport :: ParserOpts -> String -> Bool
+isImport pflags stmt =
+ case parseThing Parser.parseImport pflags stmt of
+ Lexer.POk _ _ -> True
+ Lexer.PFailed _ -> False
+
+-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
+isDecl :: ParserOpts -> String -> Bool
+isDecl pflags stmt =
+ case parseThing Parser.parseDeclaration pflags stmt of
+ Lexer.POk _ thing ->
+ case unLoc thing of
+ SpliceD _ _ -> False
+ _ -> True
+ Lexer.PFailed _ -> False
+
+parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing
+parseThing parser opts stmt = do
+ let buf = stringToStringBuffer stmt
+ loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
+
+ Lexer.unP parser (Lexer.initParserState opts buf loc)
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -17,7 +17,6 @@ module GHC.Runtime.Eval (
Resume(..), History(..),
execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,
runDecls, runDeclsWithLocation, runParsedDecls,
- isStmt, hasImport, isImport, isDecl,
parseImportDecl, SingleStep(..),
abandon, abandonAll,
getResumeContext,
@@ -26,7 +25,6 @@ module GHC.Runtime.Eval (
getHistoryModule,
back, forward,
setContext, getContext,
- availsToGlobalRdrEnv,
getNamesInScope,
getRdrNamesInScope,
moduleIsInterpreted,
@@ -96,17 +94,12 @@ import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
-import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)
-import GHC.Parser.Lexer (ParserOpts)
-import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport)
-
import GHC.Types.RepType
import GHC.Types.Fixity.Env
import GHC.Types.Var
import GHC.Types.Id as Id
import GHC.Types.Name hiding ( varName )
import GHC.Types.Name.Set
-import GHC.Types.Avail
import GHC.Types.Name.Reader
import GHC.Types.Var.Env
import GHC.Types.SrcLoc
@@ -126,7 +119,6 @@ import qualified Data.IntMap as IntMap
import Data.List (find,intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
-import GHC.Data.StringBuffer (stringToStringBuffer)
import Control.Monad
import Control.Monad.Catch as MC
import Data.Array
@@ -796,17 +788,6 @@ findGlobalRdrEnv hsc_env imports
Left err -> Left (mod, err)
Right env -> Right env
-availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
-availsToGlobalRdrEnv mod_name avails
- = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
- where
- -- We're building a GlobalRdrEnv as if the user imported
- -- all the specified modules into the global interactive module
- imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
- decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
- is_qual = False,
- is_dloc = srcLocSpan interactiveSrcLoc }
-
mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
mkTopLevEnv hpt modl
= case lookupHpt hpt modl of
@@ -892,45 +873,6 @@ parseName str = withSession $ \hsc_env -> liftIO $
do { lrdr_name <- hscParseIdentifier hsc_env str
; hscTcRnLookupRdrName hsc_env lrdr_name }
--- | Returns @True@ if passed string is a statement.
-isStmt :: ParserOpts -> String -> Bool
-isStmt pflags stmt =
- case parseThing Parser.parseStmt pflags stmt of
- Lexer.POk _ _ -> True
- Lexer.PFailed _ -> False
-
--- | Returns @True@ if passed string has an import declaration.
-hasImport :: ParserOpts -> String -> Bool
-hasImport pflags stmt =
- case parseThing Parser.parseModule pflags stmt of
- Lexer.POk _ thing -> hasImports thing
- Lexer.PFailed _ -> False
- where
- hasImports = not . null . hsmodImports . unLoc
-
--- | Returns @True@ if passed string is an import declaration.
-isImport :: ParserOpts -> String -> Bool
-isImport pflags stmt =
- case parseThing Parser.parseImport pflags stmt of
- Lexer.POk _ _ -> True
- Lexer.PFailed _ -> False
-
--- | Returns @True@ if passed string is a declaration but __/not a splice/__.
-isDecl :: ParserOpts -> String -> Bool
-isDecl pflags stmt =
- case parseThing Parser.parseDeclaration pflags stmt of
- Lexer.POk _ thing ->
- case unLoc thing of
- SpliceD _ _ -> False
- _ -> True
- Lexer.PFailed _ -> False
-
-parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing
-parseThing parser opts stmt = do
- let buf = stringToStringBuffer stmt
- loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
-
- Lexer.unP parser (Lexer.initParserState opts buf loc)
getDocs :: GhcMonad m
=> Name
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -89,14 +89,17 @@ tcProc :: LPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr
-> ExpRhoType -- Expected type of whole proc expression
-> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion)
-tcProc pat cmd exp_ty
- = newArrowScope $
- do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows
+tcProc pat cmd@(L _ (HsCmdTop names _)) exp_ty
+ = do { exp_ty <- expTypeToType exp_ty -- no higher-rank stuff with arrows
; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
+ -- start with the names as they are used to desugar the proc itself
+ -- See #17423
+ ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
- ; (pat', cmd') <- tcCheckPat ProcExpr pat (unrestricted arg_ty) $
- tcCmdTop cmd_env cmd (unitTy, res_ty)
+ ; (pat', cmd') <- newArrowScope
+ $ tcCheckPat ProcExpr pat (unrestricted arg_ty)
+ $ tcCmdTop cmd_env names' cmd (unitTy, res_ty)
; let res_co = mkTcTransCo co
(mkTcAppCo co1 (mkTcNomReflCo res_ty))
; return (pat', cmd', res_co) }
@@ -115,7 +118,7 @@ type CmdArgType = TcTauType -- carg_type, a nested tuple
data CmdEnv
= CmdEnv {
- cmd_arr :: TcType -- arrow type constructor, of kind *->*->*
+ cmd_arr :: TcType -- ^ Arrow type constructor, of kind *->*->*
}
mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
@@ -123,15 +126,15 @@ mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
---------------------------------------
tcCmdTop :: CmdEnv
+ -> CmdSyntaxTable GhcTc -- ^ Type-checked Arrow class methods (arr, (>>>), ...)
-> LHsCmdTop GhcRn
-> CmdType
-> TcM (LHsCmdTop GhcTc)
-tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
+tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)
= setSrcSpan loc $
- do { cmd' <- tcCmd env cmd cmd_ty
- ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
- ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
+ do { cmd' <- tcCmd env cmd cmd_ty
+ ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }
----------------------------------------
tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)
@@ -319,12 +322,13 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
where
tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)
- tc_cmd_arg cmd
+ tc_cmd_arg cmd@(L _ (HsCmdTop names _))
= do { arr_ty <- newFlexiTyVarTy arrowTyConKind
; stk_ty <- newFlexiTyVarTy liftedTypeKind
; res_ty <- newFlexiTyVarTy liftedTypeKind
+ ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names
; let env' = env { cmd_arr = arr_ty }
- ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
+ ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)
; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
-----------------------------------------------------------------
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -2819,24 +2819,6 @@ But notice that (#16322 comment:3)
although T3 is really polymorphic-recursive too.
Perhaps we should somehow reject that.
-Note [Kind-checking tyvar binders for associated types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When kind-checking the type-variable binders for associated
- data/newtype decls
- family decls
-we behave specially for type variables that are already in scope;
-that is, bound by the enclosing class decl. This is done in
-kcLHsQTyVarBndrs:
- * The use of tcImplicitQTKBndrs
- * The tcLookupLocal_maybe code in kc_hs_tv
-
-See Note [Associated type tyvar names] in GHC.Core.Class and
- Note [TyVar binders for associated decls] in GHC.Hs.Decls
-
-We must do the same for family instance decls, where the in-scope
-variables may be bound by the enclosing class instance decl.
-Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen.
-
Note [Kind variable ordering for associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What should be the kind of `T` in the following example? (#15591)
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -2263,12 +2263,6 @@ checkFamPatBinders :: TyCon
-> [TcType] -- LHS patterns
-> Type -- RHS
-> TcM ()
--- We do these binder checks now, in tcFamTyPatsAndGen, rather
--- than later, in checkValidFamEqn, for two reasons:
--- - We have the implicitly and explicitly
--- bound type variables conveniently to hand
--- - If implicit variables are out of scope it may
--- cause a crash; notably in tcConDecl in tcDataFamInstDecl
checkFamPatBinders fam_tc qtvs pats rhs
= do { traceTc "checkFamPatBinders" $
vcat [ debugPprType (mkTyConApp fam_tc pats)
=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -206,24 +206,26 @@ instance Outputable CExportSpec where
instance Outputable CCallSpec where
ppr (CCallSpec fun cconv safety)
- = hcat [ whenPprDebug callconv, ppr_fun fun ]
+ = hcat [ whenPprDebug callconv, ppr_fun fun, text " ::" ]
where
callconv = text "{-" <> ppr cconv <> text "-}"
- gc_suf | playSafe safety = text "_GC"
- | otherwise = empty
+ gc_suf | playSafe safety = text "_safe"
+ | otherwise = text "_unsafe"
- ppr_fun (StaticTarget st _fn mPkgId isFun)
- = text (if isFun then "__pkg_ccall"
- else "__pkg_ccall_value")
+ ppr_fun (StaticTarget st lbl mPkgId isFun)
+ = text (if isFun then "__ffi_static_ccall"
+ else "__ffi_static_ccall_value")
<> gc_suf
<+> (case mPkgId of
Nothing -> empty
Just pkgId -> ppr pkgId)
+ <> text ":"
+ <> ppr lbl
<+> (pprWithSourceText st empty)
ppr_fun DynamicTarget
- = text "__dyn_ccall" <> gc_suf <+> text "\"\""
+ = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""
-- The filename for a C header file
-- Note [Pragma source text] in GHC.Types.SourceText
=====================================
compiler/ghc.cabal.in
=====================================
@@ -480,6 +480,7 @@ Library
GHC.Parser.PostProcess
GHC.Parser.PostProcess.Haddock
GHC.Parser.Types
+ GHC.Parser.Utils
GHC.Platform
GHC.Platform.ARM
GHC.Platform.AArch64
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -1791,22 +1791,32 @@ docCmd "" =
docCmd s = do
-- TODO: Maybe also get module headers for module names
names <- GHC.parseName s
- e_docss <- mapM GHC.getDocs names
- sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss
+ e_docss <- sequence <$> mapM GHC.getDocs names
+ sdocs <- either handleGetDocsFailure (pure . pprDocs) e_docss
let sdocs' = vcat (intersperse (text "") sdocs)
unqual <- GHC.getPrintUnqual
dflags <- getDynFlags
(liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'
+pprDocs :: [(Maybe HsDocString, Map Int HsDocString)] -> [SDoc]
+pprDocs docs
+ | null nonEmptyDocs = pprDoc <$> take 1 docs
+ -- elide <has no documentation> if there's at least one non-empty doc (#15784)
+ | otherwise = pprDoc <$> nonEmptyDocs
+ where
+ empty (mb_decl_docs, arg_docs)
+ = isNothing mb_decl_docs && null arg_docs
+ nonEmptyDocs = filter (not . empty) docs
+
-- TODO: also print arg docs.
-pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc
-pprDocs (mb_decl_docs, _arg_docs) =
+pprDoc :: (Maybe HsDocString, Map Int HsDocString) -> SDoc
+pprDoc (mb_decl_docs, _arg_docs) =
maybe
(text "<has no documentation>")
(text . unpackHDS)
mb_decl_docs
-handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc
+handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m [SDoc]
handleGetDocsFailure no_docs = do
dflags <- getDynFlags
let msg = showPpr dflags no_docs
=====================================
hadrian/src/Rules/Libffi.hs
=====================================
@@ -190,7 +190,7 @@ libffiRules = do
removeDirectory libffiPath
tarball <- needLibfffiArchive libffiPath
-- Go from 'libffi-3.99999+git20171002+77e130c.tar.gz' to 'libffi-3.99999'
- let libname = takeWhile (/= '+') $ takeFileName tarball
+ let libname = takeWhile (/= '+') $ fromJust $ stripExtension "tar.gz" $ takeFileName tarball
-- Move extracted directory to libffiPath.
root <- buildRoot
=====================================
libraries/base/GHC/Float/ConversionUtils.hs
=====================================
@@ -33,13 +33,10 @@ default ()
#define TO64 integerToInt64#
-toByte64# :: Int64# -> Int#
-toByte64# i = word2Int# (and# 255## (int2Word# (int64ToInt# i)))
-
-- Double mantissae have 53 bits, too much for Int#
elim64# :: Int64# -> Int# -> (# Integer, Int# #)
elim64# n e =
- case zeroCount (toByte64# n) of
+ case zeroCount (int64ToInt# n) of
t | isTrue# (e <=# t) -> (# integerFromInt64# (uncheckedIShiftRA64# n e), 0# #)
| isTrue# (t <# 8#) -> (# integerFromInt64# (uncheckedIShiftRA64# n t), e -# t #)
| otherwise -> elim64# (uncheckedIShiftRA64# n 8#) (e -# 8#)
@@ -60,41 +57,13 @@ elimZerosInteger m e = elim64# (TO64 m) e
elimZerosInt# :: Int# -> Int# -> (# Integer, Int# #)
elimZerosInt# n e =
- case zeroCount (toByte# n) of
+ case zeroCount n of
t | isTrue# (e <=# t) -> (# IS (uncheckedIShiftRA# n e), 0# #)
| isTrue# (t <# 8#) -> (# IS (uncheckedIShiftRA# n t), e -# t #)
| otherwise -> elimZerosInt# (uncheckedIShiftRA# n 8#) (e -# 8#)
-{-# INLINE zeroCount #-}
+-- | Number of trailing zero bits in a byte
zeroCount :: Int# -> Int#
-zeroCount i =
- case zeroCountArr of
- BA ba -> indexInt8Array# ba i
-
-toByte# :: Int# -> Int#
-toByte# i = word2Int# (and# 255## (int2Word# i))
-
-
-data BA = BA ByteArray#
-
--- Number of trailing zero bits in a byte
-zeroCountArr :: BA
-zeroCountArr =
- let mkArr s =
- case newByteArray# 256# s of
- (# s1, mba #) ->
- case writeInt8Array# mba 0# 8# s1 of
- s2 ->
- let fillA step val idx st
- | isTrue# (idx <# 256#) =
- case writeInt8Array# mba idx val st of
- nx -> fillA step val (idx +# step) nx
- | isTrue# (step <# 256#) =
- fillA (2# *# step) (val +# 1#) step st
- | otherwise = st
- in case fillA 2# 0# 1# s2 of
- s3 -> case unsafeFreezeByteArray# mba s3 of
- (# _, ba #) -> ba
- in case mkArr realWorld# of
- b -> BA b
-
+zeroCount i = indexInt8OffAddr# arr (word2Int# (narrow8Word# (int2Word# i))) -- index must be in [0,255]
+ where
+ arr = "\8\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\5\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\6\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\5\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\7\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\5\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\6\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\5\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0\4\0\1\0\2\0\1\0\3\0\1\0\2\0\1\0"#
=====================================
libraries/ghci/SizedSeq.hs → libraries/ghc-boot/GHC/Data/SizedSeq.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
-module SizedSeq
+module GHC.Data.SizedSeq
( SizedSeq(..)
, emptySS
, addToSS
=====================================
libraries/ghc-boot/GHC/Platform/ArchOS.hs
=====================================
@@ -73,8 +73,8 @@ data ArmABI
-- | PowerPC 64-bit ABI
data PPC_64ABI
- = ELF_V1
- | ELF_V2
+ = ELF_V1 -- ^ PowerPC64
+ | ELF_V2 -- ^ PowerPC64 LE
deriving (Read, Show, Eq)
-- | Operating systems.
=====================================
libraries/ghc-boot/ghc-boot.cabal.in
=====================================
@@ -39,6 +39,7 @@ Library
exposed-modules:
GHC.BaseDir
GHC.Data.ShortText
+ GHC.Data.SizedSeq
GHC.Utils.Encoding
GHC.LanguageExtensions
GHC.Unit.Database
=====================================
libraries/ghci/GHCi/CreateBCO.hs
=====================================
@@ -17,7 +17,7 @@ import Prelude -- See note [Why do we import Prelude here?]
import GHCi.ResolvedBCO
import GHCi.RemoteTypes
import GHCi.BreakArray
-import SizedSeq
+import GHC.Data.SizedSeq
import System.IO (fixIO)
import Control.Monad
=====================================
libraries/ghci/GHCi/InfoTable.hsc
=====================================
@@ -23,6 +23,8 @@ import GHC.Exts.Heap
import Data.ByteString (ByteString)
import Control.Monad.Fail
import qualified Data.ByteString as BS
+import GHC.Platform.Host (hostPlatformArch)
+import GHC.Platform.ArchOS
-- NOTE: Must return a pointer acceptable for use in the header of a closure.
-- If tables_next_to_code is enabled, then it must point the 'code' field.
@@ -63,59 +65,9 @@ mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc =
funPtrToInt :: FunPtr a -> Int
funPtrToInt (FunPtr a) = I## (addr2Int## a)
-data Arch = ArchSPARC
- | ArchPPC
- | ArchX86
- | ArchX86_64
- | ArchAlpha
- | ArchARM
- | ArchAArch64
- | ArchPPC64
- | ArchPPC64LE
- | ArchS390X
- deriving Show
-
mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
-mkJumpToAddr ptr = do
- arch <- case mArch of
- Just a -> pure a
- Nothing ->
- -- This code must not be called. You either need to add your
- -- architecture as a distinct case to 'Arch' and 'mArch', or use
- -- non-TABLES_NEXT_TO_CODE mode.
- fail "mkJumpToAddr: Unknown obscure arch is not supported with TABLES_NEXT_TO_CODE"
- pure $ mkJumpToAddr' arch ptr
-
--- | 'Just' if it's a known OS, or 'Nothing' otherwise.
-mArch :: Maybe Arch
-mArch =
-#if defined(sparc_HOST_ARCH)
- Just ArchSPARC
-#elif defined(powerpc_HOST_ARCH)
- Just ArchPPC
-#elif defined(i386_HOST_ARCH)
- Just ArchX86
-#elif defined(x86_64_HOST_ARCH)
- Just ArchX86_64
-#elif defined(alpha_HOST_ARCH)
- Just ArchAlpha
-#elif defined(arm_HOST_ARCH)
- Just ArchARM
-#elif defined(aarch64_HOST_ARCH)
- Just ArchAArch64
-#elif defined(powerpc64_HOST_ARCH)
- Just ArchPPC64
-#elif defined(powerpc64le_HOST_ARCH)
- Just ArchPPC64LE
-#elif defined(s390x_HOST_ARCH)
- Just ArchS390X
-#else
- Nothing
-#endif
-
-mkJumpToAddr' :: Arch -> EntryFunPtr -> ItblCodes
-mkJumpToAddr' platform a = case platform of
- ArchSPARC ->
+mkJumpToAddr a = case hostPlatformArch of
+ ArchSPARC -> pure $
-- After some consideration, we'll try this, where
-- 0x55555555 stands in for the address to jump to.
-- According to includes/rts/MachRegs.h, %g3 is very
@@ -137,7 +89,7 @@ mkJumpToAddr' platform a = case platform of
0x81C0C000,
0x01000000 ]
- ArchPPC ->
+ ArchPPC -> pure $
-- We'll use r12, for no particular reason.
-- 0xDEADBEEF stands for the address:
-- 3D80DEAD lis r12,0xDEAD
@@ -152,7 +104,7 @@ mkJumpToAddr' platform a = case platform of
0x618C0000 .|. lo16 w32,
0x7D8903A6, 0x4E800420 ]
- ArchX86 ->
+ ArchX86 -> pure $
-- Let the address to jump to be 0xWWXXYYZZ.
-- Generate movl $0xWWXXYYZZ,%eax ; jmp *%eax
-- which is
@@ -167,7 +119,7 @@ mkJumpToAddr' platform a = case platform of
in
Left insnBytes
- ArchX86_64 ->
+ ArchX86_64 -> pure $
-- Generates:
-- jmpq *.L1(%rip)
-- .align 8
@@ -191,7 +143,7 @@ mkJumpToAddr' platform a = case platform of
in
Left insnBytes
- ArchAlpha ->
+ ArchAlpha -> pure $
let w64 = fromIntegral (funPtrToInt a) :: Word64
in Right [ 0xc3800000 -- br at, .+4
, 0xa79c000c -- ldq at, 12(at)
@@ -200,7 +152,7 @@ mkJumpToAddr' platform a = case platform of
, fromIntegral (w64 .&. 0x0000FFFF)
, fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
- ArchARM { } ->
+ ArchARM {} -> pure $
-- Generates Arm sequence,
-- ldr r1, [pc, #0]
-- bx r1
@@ -214,7 +166,7 @@ mkJumpToAddr' platform a = case platform of
, 0x11, 0xff, 0x2f, 0xe1
, byte0 w32, byte1 w32, byte2 w32, byte3 w32]
- ArchAArch64 { } ->
+ ArchAArch64 {} -> pure $
-- Generates:
--
-- ldr x1, label
@@ -230,7 +182,8 @@ mkJumpToAddr' platform a = case platform of
, 0xd61f0020
, fromIntegral w64
, fromIntegral (w64 `shiftR` 32) ]
- ArchPPC64 ->
+
+ ArchPPC_64 ELF_V1 -> pure $
-- We use the compiler's register r12 to read the function
-- descriptor and the linker's register r11 as a temporary
-- register to hold the function entry point.
@@ -256,7 +209,7 @@ mkJumpToAddr' platform a = case platform of
0xE96C0010,
0x4E800420]
- ArchPPC64LE ->
+ ArchPPC_64 ELF_V2 -> pure $
-- The ABI requires r12 to point to the function's entry point.
-- We use the medium code model where code resides in the first
-- two gigabytes, so loading a non-negative32 bit address
@@ -274,7 +227,7 @@ mkJumpToAddr' platform a = case platform of
0x618C0000 .|. lo16 w32,
0x7D8903A6, 0x4E800420 ]
- ArchS390X ->
+ ArchS390X -> pure $
-- Let 0xAABBCCDDEEFFGGHH be the address to jump to.
-- The following code loads the address into scratch
-- register r1 and jumps to it.
@@ -288,6 +241,12 @@ mkJumpToAddr' platform a = case platform of
0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,
0x07, 0xF1 ]
+ arch ->
+ -- The arch isn't supported. You either need to add your architecture as a
+ -- distinct case, or use non-TABLES_NEXT_TO_CODE mode.
+ fail $ "mkJumpToAddr: arch is not supported with TABLES_NEXT_TO_CODE ("
+ ++ show arch ++ ")"
+
byte0 :: (Integral w) => w -> Word8
byte0 w = fromIntegral w
=====================================
libraries/ghci/GHCi/ResolvedBCO.hs
=====================================
@@ -7,7 +7,7 @@ module GHCi.ResolvedBCO
) where
import Prelude -- See note [Why do we import Prelude here?]
-import SizedSeq
+import GHC.Data.SizedSeq
import GHCi.RemoteTypes
import GHCi.BreakArray
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -50,10 +50,12 @@ library
if flag(internal-interpreter)
CPP-Options: -DHAVE_INTERNAL_INTERPRETER
exposed-modules:
+ GHCi.InfoTable
GHCi.Run
GHCi.CreateBCO
GHCi.ObjLink
GHCi.Signals
+ GHCi.StaticPtrTable
GHCi.TH
include-dirs: @FFIIncludeDir@
@@ -65,10 +67,7 @@ library
GHCi.ResolvedBCO
GHCi.RemoteTypes
GHCi.FFI
- GHCi.InfoTable
- GHCi.StaticPtrTable
GHCi.TH.Binary
- SizedSeq
Build-Depends:
array == 0.5.*,
=====================================
rts/posix/Signals.c
=====================================
@@ -680,15 +680,11 @@ initDefaultHandlers(void)
// install the SIGINT handler
action.sa_handler = shutdown_handler;
sigemptyset(&action.sa_mask);
- action.sa_flags = 0;
+ action.sa_flags = 0; // disable SA_RESTART
if (sigaction(SIGINT, &action, &oact) != 0) {
sysErrorBelch("warning: failed to install SIGINT handler");
}
-#if defined(HAVE_SIGINTERRUPT)
- siginterrupt(SIGINT, 1); // isn't this the default? --SDM
-#endif
-
// install the SIGFPE handler
// In addition to handling SIGINT, also handle SIGFPE by ignoring it.
=====================================
testsuite/tests/gadt/T17423.hs → testsuite/tests/arrows/should_compile/T17423.hs
=====================================
=====================================
testsuite/tests/arrows/should_compile/all.T
=====================================
@@ -16,3 +16,4 @@ test('T5283', normal, compile, [''])
test('T5267', expect_broken(5267), compile, [''])
test('T5022', normalise_fun(normalise_errmsg), compile, [''])
test('T5333', normal, compile, [''])
+test('T17423', normal, compile, [''])
=====================================
testsuite/tests/gadt/all.T
=====================================
@@ -119,6 +119,5 @@ test('T14808', normal, compile, [''])
test('T15009', normal, compile, [''])
test('T15558', normal, compile, [''])
test('T16427', normal, compile_fail, [''])
-test('T17423', expect_broken(17423), compile_and_run, [''])
test('T18191', normal, compile_fail, [''])
test('SynDataRec', normal, compile, [''])
=====================================
testsuite/tests/ghci/scripts/ghci065.hs
=====================================
@@ -5,6 +5,7 @@
-- this test is constructed with simple text (without markup) only.
--
+{-# LANGUAGE DuplicateRecordFields #-}
module Test where
-- | This is the haddock comment of a data declaration for Data1.
@@ -13,6 +14,25 @@ data Data1 = Val1a | Val1b
data Data2 = Val2a -- ^ This is the haddock comment of a data value for Val2a
| Val2b -- ^ This is the haddock comment of a data value for Val2b
+-- | This is the haddock comment of a data declaration for Data3.
+newtype Data3 =
+ Data3 { getData3 :: Int }
+
+newtype Data4 =
+ -- | This is the haddock comment of a data constructor for Data4.
+ Data4 { getData4 :: Int }
+
+data DupeFields1 =
+ DF1 { dupeField :: Int -- ^ This is the first haddock comment of a duplicate record field.
+ }
+
+data DupeFields2 =
+ DF2 { dupeField :: Int -- ^ This is the second haddock comment of a duplicate record field.
+ }
+
+data DupeFields3 =
+ DF3 { dupeField :: Int -- No haddock
+ }
-- | This is the haddock comment of a function declaration for func1.
func1 :: Int -> Int -> Int
=====================================
testsuite/tests/ghci/scripts/ghci065.script
=====================================
@@ -5,6 +5,9 @@
:doc Data1
:doc Val2a
:doc Val2b
+:doc Data3
+:doc Data4
+:doc dupeField
:doc func1
:doc func2
=====================================
testsuite/tests/ghci/scripts/ghci065.stdout
=====================================
@@ -1,6 +1,11 @@
This is the haddock comment of a data declaration for Data1.
This is the haddock comment of a data value for Val2a
This is the haddock comment of a data value for Val2b
+ This is the haddock comment of a data declaration for Data3.
+ This is the haddock comment of a data constructor for Data4.
+ This is the second haddock comment of a duplicate record field.
+
+ This is the first haddock comment of a duplicate record field.
This is the haddock comment of a function declaration for func1.
<has no documentation>
This is the haddock comment of a function declaration for func3.
=====================================
testsuite/tests/numeric/should_compile/all.T
=====================================
@@ -8,4 +8,4 @@ test('T7881', normal, compile, [''])
# desugaring, so we don't get the warning we expect.
test('T8542', omit_ways(['hpc']), compile, [''])
test('T10929', normal, compile, [''])
-test('T16402', [ grep_errmsg(r'and') ], compile, [''])
+test('T16402', [ grep_errmsg(r'and'), when(wordsize(32), expect_broken(19024)) ], compile, [''])
=====================================
validate
=====================================
@@ -145,6 +145,8 @@ fi
echo "using THREADS=${threads}" >&2
+configure_cmd="./configure"
+
if [ "$use_hadrian" = "NO" ]
then
make="gmake"
@@ -173,6 +175,7 @@ else
hadrian/build-stack --help > /dev/null
cd hadrian
hadrian_cmd=$(stack exec -- which hadrian)
+ configure_cmd="stack --stack-yaml hadrian/stack.yaml exec -- ./configure"
fi
cd ..
# TODO: define a hadrian Flavour that mimics
@@ -199,7 +202,7 @@ if [ $testsuite_only -eq 0 ]; then
INSTDIR="$thisdir/inst"
python3 ./boot --validate
- ./configure --prefix="$INSTDIR" $config_args
+ $configure_cmd --prefix="$INSTDIR" $config_args
fi
if [ "$use_hadrian" = "NO" ]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d112fb3dbd8519b33bfb3cea22000022f68169d4...fde4be6db8c3dd1dd1b029e34b93d09e51ac2b23
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d112fb3dbd8519b33bfb3cea22000022f68169d4...fde4be6db8c3dd1dd1b029e34b93d09e51ac2b23
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/20201211/4a9ebd70/attachment-0001.html>
More information about the ghc-commits
mailing list